program drive_torch include 'implno.dek' include 'const.dek' include 'timers.dek' include 'vector_eos.dek' include 'burn_common.dek' include 'network.dek' c..this program exercises the torch network c..declare integer i,j,k,nok,nbad double precision tstart,tstep,conserv, 1 tin,din,ein,vin,zin,xin(abignet), 2 tout,dout,eout,xout(abignet) double precision abar,zbar,wbar,xcess,ye c..for density and temperature loops character*80 lihsin integer ndstep,ntstep double precision dhi,dlo,den_step,thi,tlo,temp_step c..initialize the network write(6,*) 'reading isotope data from bdat' c call zet47 c call zet76 c call zet127 c call zet200 c call zet383 call zet489 c call zet513 c call zet3302 c call zet5 call init_torch c..keep coming back to here, get the users input 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..loop over density and temperature c..20 points per decade c write(6,*) 'give dlo and dhi =>' c read(5,*) dlo,dhi c dhi = 10.0 c dlo = 4.0 c ndstep = 20*abs(int(dhi - dlo)) + 1 c den_step = (dhi - dlo)/float(ndstep - 1) c thi = 10.0 c tlo = 4.0 c ntstep = 20*abs(int(thi - tlo)) + 1 c temp_step = (thi - tlo)/float(ntstep - 1) c write(6,*) 'give lihsin file name' c read(5,108) lihsin c 108 format(a) c open(unit=44,file=lihsin,status='unknown') c..use qfloat in the loop arithmetic to obtain better precision c do j=1,ndstep c din = dlo + qfloat(j-1) * den_step c din = 10.0d0**din c den0 = din c do i=1,ntstep c tin = tlo + qfloat(i-1) * temp_step c tin = tin * 1.0e9 c temp0 = tin c write(hfile,112) j c 112 format('a',i4.4,'/foo_') c..re-start the clock call zsecond(timzer) c..burn it call burner(tstart,tstep, 1 tin,din,vin,zin,ein,xin, 2 tout,dout,eout,xout, 3 conserv,nok,nbad) c..output a summary of the integration, and decay the composition call net_final_abund(xout) call net_decay_abund(xout) call net_summary(tstep,tin,din,ein,tout,dout,eout,conserv, 1 nbad,nok,xout) call zsecond(timtot) timtot = timtot - timzer c..end of loop over density and temnperature c write(6,113) tin,din,xout(iti44),xout(ini56), c 1 xout(ihe4),xout(ife54),xout(ic12), c 2 xout(io16),xout(isi28),timtot c write(44,113) tin,din,xout(iti44),xout(ini56), c 1 xout(ihe4),xout(ife54),xout(ic12), c 2 xout(io16),xout(isi28),timtot c 113 format(1x,1p12e14.6) c enddo c enddo c close(unit=44) c..back for more goto 20 end subroutine burner(beg,tstep, 1 tin,din,vin,zin,ein,xin, 2 tout,dout,eout,xout, 3 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 beg,tstep,tin,din,vin,zin,ein,xin(*), 1 tout,dout,eout,xout(*),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 stptry,stpmin,tend,ys2(abignet*nzmax), 1 odescal,tol parameter (tol = 1.0d-6, 1 odescal = 1.0d-12) external torch,storch,btorch,dtorch 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_umf5 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 ys2(iener) = ein ys2(itemp) = tin ys2(iden) = din ys2(ivelx) = vin ys2(iposx) = zin 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. c 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 torch network call netint(beg,stptry,stpmin,tend,ys2, 1 tol,neqs,nok,nbad,kount,odescal, c 4 torch,storch,btorch,forder_ma28) c 4 torch,storch,btorch,forder_umf) c 4 torch,storch,btorch,forder_y12m) c 4 torch,dtorch,btorch,forder_ludcmp) c 4 torch,dtorch,btorch,forder_leqs) c 4 torch,dtorch,btorch,forder_lapack) c 4 torch,dtorch,btorch,forder_gift) c 4 torch,storch,btorch,forder_biconj) c 4 torch,storch,btorch,rosen_ma28) c 4 torch,storch,btorch,rosen_umf) c 4 torch,storch,btorch,rosen_y12m) c 4 torch,dtorch,btorch,rosen_ludcmp) c 4 torch,dtorch,btorch,rosen_leqs) c 4 torch,dtorch,btorch,rosen_lapack) c 4 torch,dtorch,btorch,rosen_gift) c 4 torch,storch,btorch,rosen_biconj) 4 torch,storch,btorch,stifbs_ma28) c 4 torch,storch,btorch,stifbs_umf) c 4 torch,storch,btorch,stifbs_umf5) c 4 torch,storch,btorch,stifbs_y12m) c 4 torch,dtorch,btorch,stifbs_ludcmp) c 4 torch,dtorch,btorch,stifbs_leqs) c 4 torch,dtorch,btorch,stifbs_lapack) c 4 torch,dtorch,btorch,stifbs_gift) c 4 torch,storch,btorch,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 the torch network c..routine torch sets up the odes c..routine dtorch is the analytic dense jacobian of torch c..routine btorch builds the nonzero locations for storch c..routine storch is the analytic sparse jacobian of torch c..routine torchrat gets the reaction rates for torch c..routine torchtab gets the raw rates by table interpolation c..routine screen_torch screens the raw reaction rates c..routine init_torch initializes the general torch network c..routine naray sets the pointers c..routine weak_rates drives computes reaction rates c..routine weak2 computes ffn electron capture rates c..routine zferm1 is the order 1 fermi integral for weak2 c..routine zferm2 is the order 2 fermi integral for weak2 c..routine zferm3 is the order 3 fermi integral for weak2 c..routine zferm4 is the order 4 fermi integral for weak2 subroutine torch(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 ode's for the torch network c..declare the pass double precision tt,y(1),dydt(1) c..local variables integer i double precision enuc,taud,taut,y1,r1,y2,r2,y3,r3,snupp, 1 b1a,b1b,b2a,b2b,b3a,b3b,y4,b4a,b4b,y5,b5a,b5b, 2 snucno,sum1,sum2,z, 3 zbarxx,ytot1,abar,zbar,wbar,ye,xcess,snuda,snudz double precision denom,suma,sumz,ww,velx,posx,cs,dpde, 1 combo,phi,dtdp double precision xa,wien1,dwien1dx,wien2,dwien2dx, 1 f1,df1,f2,df2,con,zeta3 parameter (zeta3 = 1.20205690315732d0) double precision conv parameter (conv = ev2erg*1.0d6*avo) c..positive definite molar 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 c do i=1,ionmax c zwork1(i) = y(i)*aion(i) c enddo c call azbar(zwork1,aion,zion,wion,ionmax, c 1 zwork2,abar,zbar,wbar,ye,xcess) 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 c..from a history file if (trho_hist) call update2(tt,y(itemp),y(iden)) if (pt_hist) call update3(tt,y(itemp),bpres) c..for pressure evolutions if (self_heat_const_pres .or. pt_hist) 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 torchtab(ye) else call torchrat(ye) end if c..get the weak rates after torchrat call weak_rates(y) c..screening of rates call screen_torch(y) c..get the right hand side of the odes call rhs(y,sig,ratdum,dydt) 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 y1 = 0.0d0 r1 = 0.0d0 y2 = 0.0d0 r2 = 0.0d0 y3 = 0.0d0 r3 = 0.0d0 if (ih2 .ne. 0) then y1 = y(iprot) r1 = 0.5d0*ratdum(irpp) end if if (ibe7 .ne. 0 .and. ili7 .ne. 0) then y2 = y(ibe7) r2 = sig(6,ili7) end if if (ib8 .ne. 0) then y3 = y(ib8) r3 = ratdum(irb8ep) end if sneutpp = snupp(y1,r1,y2,r2,y3,r3) c..get the cno specific neutrino losses y1 = 0.0d0 b1a = 0.0d0 b1b = 0.0d0 if (in13 .ne. 0 .and. ic13 .ne. 0) then y1 = y(in13) b1a = bion(ic13) b1b = bion(in13) end if y2 = 0.0d0 b2a = 0.0d0 b2b = 0.0d0 if (io14 .ne. 0 .and. in14 .ne. 0) then y2 = y(io14) b2a = bion(in14) b2b = bion(io14) end if y3 = 0.0d0 b3a = 0.0d0 b3b = 0.0d0 if (io15 .ne. 0 .and. in15 .ne. 0) then y3 = y(io15) b3a = bion(in15) b3b = bion(io15) end if y4 = 0.0d0 b4a = 0.0d0 b4b = 0.0d0 if (if17 .ne. 0 .and. io17 .ne. 0) then y4 = y(if17) b4a = bion(io17) b4b = bion(if17) end if y5 = 0.0d0 b5a = 0.0d0 b5b = 0.0d0 if (if18 .ne. 0 .and. io18 .ne. 0) then y5 = y(if18) b5a = bion(io18) b5b = bion(if18) end if sneutcno = snucno(y1,b1a,b1b,y2,b2a,b2b, 1 y3,b3a,b3b,y4,b4a,b4b, 2 y5,b5a,b5b) c..sum 'em if (bbang) then sneut = 0.0d0 else sneut = sneut + sneutpp + sneutcno end if c..append an energy equation dydt(iener) = enuc - sneut c dydt(iener) = 0.0d0 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 dydt(ivelx) = 0.0d0 dydt(iposx) = 0.0d0 c..adiabatic expansion or contraction else if (expansion) then c taud = 446.0d0/sqrt(bden) taud = 446.0d0/sqrt(den0) taut = 3.0d0 * taud dydt(itemp) = -psi * y(itemp)/taut dydt(iden) = -psi * y(iden)/taud dydt(ivelx) = 0.0d0 dydt(iposx) = 0.0d0 c..power law fit to 2d simulations c taut = 1.0d0/(tt + 0.5d0) c taud = 0.5d0 * taut c dydt(itemp) = -temp0*taud*taut c dydt(iden) = -3.0d0*den0*taud*taud*taud*taut c dydt(ivelx) = 0.0d0 c dydt(iposx) = 0.0d0 c..self heating at constant density 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, velocity, and position equations dydt(iden) = 0.0d0 dydt(ivelx) = 0.0d0 dydt(iposx) = 0.0d0 c..self-consistent temperature equation dydt(itemp) = dydt(iener)/cv_row(1) c..self heating at constant pressure else if (self_heat_const_pres) then c..call an eos c temp_row(1) = btemp c den_row(1) = bden c abar_row(1) = abar c zbar_row(1) = zbar c jlo_eos = 1 c jhi_eos = 1 c call helmeos c..velocity, and position equations dydt(ivelx) = 0.0d0 dydt(iposx) = 0.0d0 c..self-consistent temperature equation dydt(itemp) = dydt(iener)/cp_row(1) c..self-consistent density equation dydt(iden) = 0.0d0 c dydt(iden) = -dpt_row(1)/dpd_row(1) * dydt(itemp) c..detonation else if (detonation) then c..map the rest of the input vector velx = y(ivelx) posx = y(iposx) 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..for de/dy and dp/dy suma = 0.0d0 do i=1,ionmax suma = suma - dydt(i) enddo sumz = 0.0d0 do i=1,ionmax sumz = sumz + (zion(i) - zbar)*dydt(i) enddo c..the possibly singular denominator cs = cs_row(1) denom = velx*velx - cs*cs c..the function phi dpde = dpt_row(1)/det_row(1) z = suma*dpa_row(1)*abar*abar + sumz*dpz_row(1)*abar ww = suma*dea_row(1)*abar*abar + sumz*dez_row(1)*abar phi = dpde*(dydt(iener) - ww) - z c..a common combination if (denom .ne. 0.0) then combo = phi/denom else combo = 0.0d0 write(6,*) 'combo is zero!' end if c..position equation dydt(iposx) = velx c..density equation dydt(iden) = combo c..velocity equations dydt(ivelx) = -velx/bden*dydt(iden) c..temperature equation dtdp = 1.0d0/dpt_row(1) ww = suma*dpa_row(1)*abar*abar + sumz*dpz_row(1)*abar dydt(itemp) = dtdp*((velx*velx - dpd_row(1))*dydt(iden) - ww) c..bbang else if (bbang) then c..temperature equation xa = me * clight**2 / (kerg * btemp) f1 = wien1(xa) df1 = dwien1dx(xa) f2 = wien2(xa) con = sqrt(f2 * 8.0d0*pi*g*asol/(3.0d0*clight**2) ) dydt(itemp) = con*btemp**3 / (xa * df1/(3.0d0*f1) - 1.0d0) c..density equation f1 = 30.0d0 * zeta3/pi**4 * asol/(kerg*avo) dydt(iden) = 3.0d0 * f1 * eta1 * btemp**2 * dydt(itemp) dydt(ivelx) = 0.0d0 dydt(iposx) = 0.0d0 end if return end subroutine rhs(y,rte,rate,dydt) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..evaluates the right hand side of the aprox13 odes c..declare the pass double precision y(*),rte(14,abignet),rate(*),dydt(*) c..local variables integer i,j,k,in,ip,ia double precision aaa,aap,aan,b1,b2,a0,a1,a2,a3,a4 double precision sixth parameter (sixth = 1.0d0/6.0d0) c..zero the odes do i=1,neqs dydt(i) = 0.0d0 enddo c..set the pointers for n,p and a reactions in = ineut aan = y(ineut) ip = iprot aap = y(iprot) ia = ihe4 aaa = y(ihe4) c..for every isotope in the network do j=ionbeg,ionend c..set up the y(j)(n,g)y(k) and y(k)(g,n)y(j) components k = nrr(1,j) if (k .gt. 0) then b1 = -aan*rte(1,j)*y(j) + rte(2,j)*y(k) dydt(j) = dydt(j) + b1 dydt(k) = dydt(k) - b1 dydt(in) = dydt(in) + b1 end if c..set up the (p,n) (n,p) and beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then b1 = -aap*rte(3,j)*y(j) + aan*rte(4,j)*y(k) b2 = -y(j)*rte(5,j) + y(k)*rte(6,j) dydt(j) = dydt(j) + b1 + b2 dydt(k) = dydt(k) - b1 - b2 dydt(in) = dydt(in) - b1 dydt(ip) = dydt(ip) + b1 end if c..set up the (p,g) and (g,p) components k = nrr(3,j) if (k .gt. 0) then b1 = -aap*rte(7,j)*y(j) + rte(8,j)*y(k) dydt(j) = dydt(j) + b1 dydt(k) = dydt(k) - b1 dydt(ip) = dydt(ip) + b1 end if c..set up the (a,p) and (p,a) reactions k = nrr(4,j) if (k .gt. 0) then b1 = -aaa*rte(9,j)*y(j) + aap*rte(10,j)*y(k) dydt(j) = dydt(j) + b1 dydt(k) = dydt(k) - b1 dydt(ip) = dydt(ip) - b1 dydt(ia) = dydt(ia) + b1 end if c..set up the (a,n) and (n,a) components k = nrr(5,j) if (k .gt. 0) then b1 = -aaa*rte(11,j)*y(j) + aan*rte(12,j)*y(k) dydt(j) = dydt(j) + b1 dydt(k) = dydt(k) - b1 dydt(in) = dydt(in) - b1 dydt(ia) = dydt(ia) + b1 end if c..and the (a,g) and (g,a) components k = nrr(6,j) if (k .gt. 0) then b1 = -aaa*rte(13,j)*y(j) + rte(14,j)*y(k) dydt(j) = dydt(j) + b1 dydt(k) = dydt(k) - b1 dydt(ia) = dydt(ia) + b1 end if enddo 223 format(1x,a,a,a,1p2e14.6) c..now the special matrix elements c..for p(e-,nu)n and n(e+,nub)p reactions a1 = aan*rate(irnep) a2 = aap*rate(irpen) dydt(in) = dydt(in) - a1 + a2 dydt(ip) = dydt(ip) - a2 + a1 c..triple alpha reactions; must have c12 in the network if (ic12 .ne. 0) then a1 = sixth*rate(ir3a)*aaa*aaa*aaa a2 = rate(irg3a)*y(ic12) dydt(ia) = dydt(ia) - 3.0d0*a1 + 3.0d0*a2 dydt(ic12) = dydt(ic12) + a1 - a2 c..c12+c12 reactions; must have ne20, na23, mg23 in the network if (ine20 .ne. 0 .and. ina23 .ne. 0 .and. img23 .ne. 0) then a1 = 0.5d0*y(ic12)*y(ic12) a2 = 0.5d0*aaa*y(ine20)*rate(irne20ac) a3 = 0.5d0*aap*y(ina23)*rate(irna23pc) a4 = 0.5d0*aan*y(img23)*rate(irmg23nc) dydt(ic12) = dydt(ic12) - 2.0d0*a1* 1 (rate(ir1212n) + rate(ir1212p) + rate(ir1212a)) 2 + 2.0d0*(a2 + a3 + a4) dydt(ine20) = dydt(ine20) - a2 + a1*rate(ir1212a) dydt(ia) = dydt(ia) - a2 + a1*rate(ir1212a) dydt(ina23) = dydt(ina23) - a3 + a1*rate(ir1212p) dydt(ip) = dydt(ip) - a3 + a1*rate(ir1212p) dydt(img23) = dydt(img23) - a4 + a1*rate(ir1212n) dydt(in) = dydt(in) - a4 + a1*rate(ir1212n) end if end if c..o16+o16 reactions; must have si28, p30, p31 and s31 in the network if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then a0 = 0.5d0*y(io16)*y(io16) a1 = 0.5d0*aaa*y(isi28)*rate(irsi28ao) a2 = 0.5d0*aap*y(ip31)*rate(irp31po) a3 = 0.5d0*aan*y(is31)*rate(irs31no) dydt(io16) = dydt(io16) + 2.0d0*(a1 + a2 + a3 1 - a0*(rate(ir1616n) + rate(ir1616p) + 2 rate(ir1616a) + rate(ir1616d))) dydt(isi28) = dydt(isi28) + a0*rate(ir1616a) - a1 dydt(ia) = dydt(ia) + a0*rate(ir1616a) - a1 dydt(ip31) = dydt(ip31) + a0*rate(ir1616p) - a2 dydt(ip) = dydt(ip) + a0*rate(ir1616p) - a2 dydt(is31) = dydt(is31) + a0*rate(ir1616n) - a3 dydt(in) = dydt(in) + a0*rate(ir1616n) - a3 dydt(ip30) = dydt(ip30) + a0*rate(ir1616d) dydt(in) = dydt(in) + a0*rate(ir1616d) dydt(ip) = dydt(ip) + a0*rate(ir1616d) end if c..c12+o16 reactions; must have mg24, al27, si27 in the network if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then a0 = y(ic12)*y(io16) a1 = aap*y(ial27)*rate(iral27po) a2 = aan*y(isi27)*rate(irsi27no) a3 = aaa*y(img24)*rate(irmg24ao) dydt(ic12) = dydt(ic12) + a1 + a2 + a3 1 - a0*(rate(ir1216n) + rate(ir1216p) + rate(ir1216a)) dydt(io16) = dydt(io16) + a1 + a2 + a3 1 - a0*(rate(ir1216n) + rate(ir1216p) + rate(ir1216a)) dydt(isi27) = dydt(isi27) - a2 + a0*rate(ir1216n) dydt(ial27) = dydt(ial27) - a1 + a0*rate(ir1216p) dydt(img24) = dydt(img24) - a3 + a0*rate(ir1216a) dydt(in) = dydt(in) - a2 + a0*rate(ir1216n) dydt(ip) = dydt(ip) - a1 + a0*rate(ir1216p) dydt(ia) = dydt(ia) - a3 + a0*rate(ir1216a) end if c..if we have deuterium if (ih2 .ne. 0) then c..pp and pep a1 = aap*aap*(rate(irpp) + rate(irpep)) dydt(ip) = dydt(ip) - a1 dydt(ih2) = dydt(ih2) + 0.5d0 * a1 c..p(n,g)d b1 = -aan*rate(irpng)*aap + rate(irdgn)*y(ih2) dydt(ip) = dydt(ip) + b1 dydt(in) = dydt(in) + b1 dydt(ih2) = dydt(ih2) - b1 c..d(p,n)2p a1 = aap*y(ih2)*rate(irdpn) 1 - 0.5d0*aan*aap*rate(ir2pnp) dydt(in) = dydt(in) + a1 dydt(ip) = dydt(ip) + a1 dydt(ih2) = dydt(ih2) - a1 c..d(d,g)he4 a1 = -y(ih2)*y(ih2)*rate(irddg) 1 + 2.0d0*aaa*rate(irhe4gd) dydt(ih2) = dydt(ih2) + a1 dydt(ia) = dydt(ia) - 0.5d0 * a1 end if c..if we have deuterium and tritium if (ih2 .ne. 0 .and. ih3 .ne. 0) then c..d(t,n)he4, dt reaction a1 = y(ih2)*y(ih3)*rate(irtdn) 1 - aan*aaa*rate(irhe4nd) dydt(ih2) = dydt(ih2) - a1 dydt(ih3) = dydt(ih3) - a1 dydt(ia) = dydt(ia) + a1 dydt(in) = dydt(in) + a1 c..d(d,p)t a1 = 0.5d0*y(ih2)*y(ih2)*rate(irddp) 1 - aap*y(ih3)*rate(irtpd) dydt(ih2) = dydt(ih2) - 2.0d0 * a1 dydt(ih3) = dydt(ih3) + a1 dydt(ip) = dydt(ip) + a1 end if c..if we have tritium if (ih3 .ne. 0) then c..t(p,g)he4 b1 = -aap*rate(irh3pg)*y(ih3) 1 + rate(irhe4gp)*aaa dydt(ih3) = dydt(ih3) + b1 dydt(ia) = dydt(ia) - b1 dydt(ip) = dydt(ip) + b1 c..t(t,2n)he4 a1 = y(ih3)*y(ih3)*rate(irtt2n) 1 - aaa*aan*rate(irhe42nt) dydt(ih3) = dydt(ih3) - a1 dydt(in) = dydt(in) + a1 dydt(ia) = dydt(ia) + 0.5d0 * a1 end if c..if we have he3 if (ihe3 .ne. 0) then c..he3(he3,2p)he4 a1 = y(ihe3)*y(ihe3)*rate(ir33) 1 - aaa*aap*rate(ir33inv) dydt(ihe3) = dydt(ihe3) - a1 dydt(ip) = dydt(ip) + a1 dydt(ia) = dydt(ia) + 0.5d0 * a1 c..he3(p,e+nu)he4 a1 = y(ihe3)*aap*rate(irhep) dydt(ihe3) = dydt(ihe3) - a1 dydt(ip) = dydt(ip) - a1 dydt(ia) = dydt(ia) + a1 c..he3(n,g)he4 b1 = -aan*rate(irhe3ng)*y(ihe3) 1 + rate(irhe4gn)*aaa dydt(ihe3) = dydt(ihe3) + b1 dydt(in) = dydt(in) + b1 dydt(ia) = dydt(ia) - b1 end if c..if we have deuterium and he3 if (ih2 .ne. 0 .and. ihe3 .ne. 0) then c..he3(d,p)he4 a1 = y(ihe3)*y(ih2)*rate(irhe3dp) 1 - aap*aaa*rate(irhe4pd) dydt(ih2) = dydt(ih2) - a1 dydt(ihe3) = dydt(ihe3) - a1 dydt(ia) = dydt(ia) + a1 dydt(ip) = dydt(ip) + a1 c..d(d,n)he3 a1 = 0.5d0*y(ih2)*y(ih2)*rate(irddn) 1 - aan*y(ihe3)*rate(irhe3nd) dydt(ih2) = dydt(ih2) - 2.0d0 * a1 dydt(ihe3) = dydt(ihe3) + a1 dydt(in) = dydt(in) + a1 end if c..if we have deuterium, tritium, and he3 if (ihe3 .ne. 0 .and. ih3 .ne. 0 .and. ih2 .ne. 0) then c..he3(t,d)he4 a1 = y(ihe3)*y(ih3)*rate(irhe3td) 1 - aaa*y(ih2)*rate(irhe4dt) dydt(ih2) = dydt(ih2) + a1 dydt(ih3) = dydt(ih3) - a1 dydt(ihe3) = dydt(ihe3) - a1 dydt(ia) = dydt(ia) + a1 end if c..if we have tritium and he3 if (ihe3 .ne. 0 .and. ih3 .ne. 0) then c..he3(t,np)he4 b1 = y(ih3)*y(ihe3)*rate(irhe3tnp) dydt(ihe3) = dydt(ihe3) - b1 dydt(ih3) = dydt(ih3) - b1 dydt(ia) = dydt(ia) + b1 dydt(ip) = dydt(ip) + b1 dydt(in) = dydt(in) + b1 end if c..if we have li7 if (ili7 .ne. 0) then c..li7(p,g)be8=>2a + li7(p,a)a reactions a1 = -y(ili7)*aap*rate(irli7pag) 1 + 0.5d0*aaa*aaa*rate(ir2he4ga) dydt(ili7) = dydt(ili7) + a1 dydt(ip) = dydt(ip) + a1 dydt(ia) = dydt(ia) - 2.0d0*a1 end if c..if we have deuterium and li7 if (ili7 .ne. 0 .and. ih2 .ne. 0) then c..li7(d,n)2a a1 = y(ili7)*y(ih2)*rate(irli7dn) dydt(ih2) = dydt(ih2) - a1 dydt(ili7) = dydt(ili7) - a1 dydt(in) = dydt(in) + a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have tritium and li7 if (ili7 .ne. 0 .and. ih3 .ne. 0) then c..li7(t,2n)2a a1 = y(ili7)*y(ih3)*rate(irli7t2n) dydt(ih3) = dydt(ih3) - a1 dydt(ili7) = dydt(ili7) - a1 dydt(in) = dydt(in) + 2.0d0*a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have he3 and li7 if (ili7 .ne. 0 .and. ihe3 .ne. 0) then c..li7(he3,np)2a a1 = y(ili7)*y(ihe3)*rate(irli7he3np) dydt(ihe3) = dydt(ihe3) - a1 dydt(ili7) = dydt(ili7) - a1 dydt(in) = dydt(in) + a1 dydt(ip) = dydt(ip) + a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have deuterium and be7 if (ibe7 .ne. 0 .and. ih2 .ne. 0) then c..be7(d,p)2a a1 = y(ibe7)*y(ih2)*rate(irbe7dp) dydt(ih2) = dydt(ih2) - a1 dydt(ibe7) = dydt(ibe7) - a1 dydt(ip) = dydt(ip) + a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have tritium and be7 if (ibe7 .ne. 0 .and. ih3 .ne. 0) then c..be7(t,np)2a a1 = y(ibe7)*y(ih3)*rate(irbe7tnp) dydt(ih3) = dydt(ih3) - a1 dydt(ibe7) = dydt(ibe7) - a1 dydt(ip) = dydt(ip) + a1 dydt(in) = dydt(in) + a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have he3 and tritium if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then c..be7(he3,2p)2a a1 = y(ibe7)*y(ihe3)*rate(irbe7he32p) dydt(ihe3) = dydt(ihe3) - a1 dydt(ibe7) = dydt(ibe7) - a1 dydt(ip) = dydt(ip) + 2.0d0*a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have be9 if (ibe9 .ne. 0) then c..a(an,g)be9 b1 = 0.5d0*aaa*aaa*aan*rate(iraan) 1 - y(ibe9) * rate(irgaan) dydt(ibe9) = dydt(ibe9) + b1 dydt(in) = dydt(in) - b1 dydt(ia) = dydt(ia) - 2.0d0 * b1 end if c..if we have deuteriuma and be9 if (ibe9 .ne. 0 .and. ih2 .ne. 0) then c..be9(p,d)be8 =>2a b1 = y(ibe9)*aap*rate(irbe9pd) dydt(ih2) = dydt(ih2) + b1 dydt(ibe9) = dydt(ibe9) - b1 dydt(ip) = dydt(ip) - b1 dydt(ia) = dydt(ia) + 2.0d0*b1 end if c..if we have b8 if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions a1 = y(ib8)*rate(irb8ep) dydt(ib8) = dydt(ib8) - a1 dydt(ia) = dydt(ia) + 2.0d0*a1 end if c..if we have b11 if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions a1 = -y(ib11)*aap*rate(irb11pa) + aaa*aaa*rate(ir3ap)/3.0d0 dydt(ib11) = dydt(ib11) + a1 dydt(ip) = dydt(ip) + a1 dydt(ia) = dydt(ia) - 3.00d0*a1 end if c..if we have c11 if (ic11 .ne. 0) then c..c11(na)be8 => 2a a1 = aan*y(ic11)*rate(irc11na) dydt(ic11) = dydt(ic11) - a1 dydt(in) = dydt(in) - a1 dydt(ia) = dydt(ia) + 3.0d0*a1 end if return end subroutine dtorch(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 jacobain for the torch network c..declare the pass integer nlog,nphys double precision tt,y(*),dfdy(nphys,nphys) c..local variables integer in,ip,ia,i,j,k double precision a0,a1,a2,a3,a4,a5,a6,aaa,aap,aan, 1 b1,b2, 2 zbarxx,ytot1,abar,zbar,ye,taud,taut,snuda,snudz double precision dydt(neqs),enuc,velx,posx,suma,sumz,sum1,sum, 3 sum5,sum6,sum7,sum8,sum9,sum10,sum11,sum12,sum2, 4 cs,denombv,dpde,dpdebd,dpdebt,phi,phibd,phibt, 5 combo,combobv,combobd,combobt,z,zbd,zbt, 6 ww,wwbd,wwbt,dtdp,dtdpbd,dtdpbt,yy, 7 dpdbd,dpdbt,foo(8),moo(8), 8 csbd,csbt,dptbd,dptbt,detbd,detbt,dpabd,dpabt, 9 dpzbd,dpzbt,deabd,deabt,dezbd,dezbt, & denomdd,denomdt double precision xa,dxadt,wien1,dwien1dx,wien2,dwien2dx, 1 f1,df1,f2,df2,zz,xx,con,dcondt,denom, 2 ddenom,zeta3 parameter (zeta3 = 1.20205690315732d0) double precision conv,oneth,sixth parameter (conv = ev2erg*1.0d6*avo, 1 oneth = 1.0d0/3.0d0, 2 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 c..from a history file if (trho_hist) call update2(tt,y(itemp),y(iden)) c..for constant pressure 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 torchtab(ye) else call torchrat(ye) end if c..get the weak rates after torchrat call weak_rates(y) c..screening of the rates call screen_torch(y) c..set the pointers for n,p and a reactions in = ineut aan = y(ineut) ip = iprot aap = y(iprot) ia = ihe4 aaa = y(ihe4) c..for every isotope in the network do j=ionbeg,ionend c..set up the (n,gam) components k = nrr(1,j) if (k .gt. 0) then a1 = sig(1,j) * aan a2 = sig(2,j) a3 = sig(1,j) * y(j) dfdy(j,j) = dfdy(j,j) - a1 dfdy(j,k) = dfdy(j,k) + a2 dfdy(j,in) = dfdy(j,in) - a3 dfdy(k,j) = dfdy(k,j) + a1 dfdy(k,k) = dfdy(k,k) - a2 dfdy(k,in) = dfdy(k,in) + a3 dfdy(in,j) = dfdy(in,j) - a1 dfdy(in,k) = dfdy(in,k) + a2 dfdy(in,in) = dfdy(in,in) - a3 end if c..set up the (p,n) beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then a1 = sig(3,j) * aap a2 = sig(4,j) * aan a3 = sig(3,j) * y(j) a4 = sig(4,j) * y(k) a5 = sig(5,j) a6 = sig(6,j) dfdy(j,j) = dfdy(j,j) - a1 - a5 dfdy(j,k) = dfdy(j,k) + a2 + a6 dfdy(j,in) = dfdy(j,in) + a4 dfdy(j,ip) = dfdy(j,ip) - a3 dfdy(k,j) = dfdy(k,j) + a1 + a5 dfdy(k,k) = dfdy(k,k) - a2 - a6 dfdy(k,in) = dfdy(k,in) - a4 dfdy(k,ip) = dfdy(k,ip) + a3 dfdy(in,j) = dfdy(in,j) + a1 dfdy(in,k) = dfdy(in,k) - a2 dfdy(in,in) = dfdy(in,in) - a4 dfdy(in,ip) = dfdy(in,ip) + a3 dfdy(ip,j) = dfdy(ip,j) - a1 dfdy(ip,k) = dfdy(ip,k) + a2 dfdy(ip,in) = dfdy(ip,in) + a4 dfdy(ip,ip) = dfdy(ip,ip) - a3 end if c..set up the (p,gam) components k = nrr(3,j) if (k .gt. 0) then a1 = sig(7,j) * aap a2 = sig(8,j) a3 = sig(7,j) * y(j) dfdy(j,j) = dfdy(j,j) - a1 dfdy(j,k) = dfdy(j,k) + a2 dfdy(j,ip) = dfdy(j,ip) - a3 dfdy(k,j) = dfdy(k,j) + a1 dfdy(k,k) = dfdy(k,k) - a2 dfdy(k,ip) = dfdy(k,ip) + a3 dfdy(ip,j) = dfdy(ip,j) - a1 dfdy(ip,k) = dfdy(ip,k) + a2 dfdy(ip,ip) = dfdy(ip,ip) - a3 end if c..set up the (alp,p) reactions k = nrr(4,j) if (k .gt. 0) then a1 = sig(9,j) * aaa a2 = sig(10,j) * aap a3 = sig(9,j) * y(j) a4 = sig(10,j) * y(k) dfdy(j,j) = dfdy(j,j) - a1 dfdy(j,k) = dfdy(j,k) + a2 dfdy(j,ip) = dfdy(j,ip) + a4 dfdy(j,ia) = dfdy(j,ia) - a3 dfdy(k,j) = dfdy(k,j) + a1 dfdy(k,k) = dfdy(k,k) - a2 dfdy(k,ip) = dfdy(k,ip) - a4 dfdy(k,ia) = dfdy(k,ia) + a3 dfdy(ip,j) = dfdy(ip,j) + a1 dfdy(ip,k) = dfdy(ip,k) - a2 dfdy(ip,ip) = dfdy(ip,ip) - a4 dfdy(ip,ia) = dfdy(ip,ia) + a3 dfdy(ia,j) = dfdy(ia,j) - a1 dfdy(ia,k) = dfdy(ia,k) + a2 dfdy(ia,ip) = dfdy(ia,ip) + a4 dfdy(ia,ia) = dfdy(ia,ia) - a3 end if c..set up the (alp,n) components k = nrr(5,j) if (k .gt. 0) then a1 = sig(11,j) * aaa a2 = sig(11,j) * y(j) a3 = sig(12,j) * aan a4 = sig(12,j) * y(k) dfdy(j,j) = dfdy(j,j) - a1 dfdy(j,k) = dfdy(j,k) + a3 dfdy(j,in) = dfdy(j,in) + a4 dfdy(j,ia) = dfdy(j,ia) - a2 dfdy(k,j) = dfdy(k,j) + a1 dfdy(k,k) = dfdy(k,k) - a3 dfdy(k,in) = dfdy(k,in) - a4 dfdy(k,ia) = dfdy(k,ia) + a2 dfdy(in,j) = dfdy(in,j) + a1 dfdy(in,k) = dfdy(in,k) - a3 dfdy(in,in) = dfdy(in,in) - a4 dfdy(in,ia) = dfdy(in,ia) + a2 dfdy(ia,j) = dfdy(ia,j) - a1 dfdy(ia,k) = dfdy(ia,k) + a3 dfdy(ia,in) = dfdy(ia,in) + a4 dfdy(ia,ia) = dfdy(ia,ia) - a2 end if c..and the (alp,gam) components k = nrr(6,j) if (k .gt. 0) then a1 = sig(13,j) * aaa a2 = sig(13,j) * y(j) a3 = sig(14,j) dfdy(j,j) = dfdy(j,j) - a1 dfdy(j,k) = dfdy(j,k) + a3 dfdy(j,ia) = dfdy(j,ia) - a2 dfdy(k,j) = dfdy(k,j) + a1 dfdy(k,k) = dfdy(k,k) - a3 dfdy(k,ia) = dfdy(k,ia) + a2 dfdy(ia,j) = dfdy(ia,j) - a1 dfdy(ia,k) = dfdy(ia,k) + a3 dfdy(ia,ia) = dfdy(ia,ia) - a2 end if enddo c..now the special matrix elements c..for p(e-,nu)n and n(e+,nub)p reactions dfdy(ip,ip) = dfdy(ip,ip) - ratdum(irpen) dfdy(ip,in) = dfdy(ip,in) + ratdum(irnep) dfdy(in,ip) = dfdy(in,ip) + ratdum(irpen) dfdy(in,in) = dfdy(in,in) - ratdum(irnep) c..triple alpha reactions if (ic12 .ne. 0) then dfdy(ia,ia) = dfdy(ia,ia) - 1.5d0*aaa*aaa*ratdum(ir3a) dfdy(ia,ic12) = dfdy(ia,ic12) + 3.0*ratdum(irg3a) dfdy(ic12,ic12) = dfdy(ic12,ic12) - ratdum(irg3a) dfdy(ic12,ia) = dfdy(ic12,ia) + 0.5d0*aaa*aaa*ratdum(ir3a) end if c..c12+c12 reactions; must have ne20 na23 and mg23 if (ic12 .ne. 0 .and. ine20 .ne. 0 .and. 1 ina23 .ne. 0 .and. img23 .ne. 0) then dfdy(ic12,ic12) = dfdy(ic12,ic12) 1 - 2.0d0*y(ic12)* 2 (ratdum(ir1212n) + ratdum(ir1212p) + ratdum(ir1212a)) dfdy(ic12,ine20) = dfdy(ic12,ine20) + ratdum(irne20ac)*aaa dfdy(ic12,ina23) = dfdy(ic12,ina23) + ratdum(irna23pc)*aap dfdy(ic12,img23) = dfdy(ic12,img23) + ratdum(irmg23nc)*aan dfdy(ic12,ia) = dfdy(ic12,ia) + ratdum(irne20ac)*y(ine20) dfdy(ic12,ip) = dfdy(ic12,ip) + ratdum(irna23pc)*y(ina23) dfdy(ic12,in) = dfdy(ic12,in) + ratdum(irmg23nc)*y(img23) dfdy(ine20,ine20) = dfdy(ine20,ine20) - 0.5d0* 1 ratdum(irne20ac)*aaa dfdy(ine20,ic12) = dfdy(ine20,ic12) + ratdum(ir1212a)*y(ic12) dfdy(ine20,ia) = dfdy(ine20,ia) - 0.5d0* 1 ratdum(irne20ac)*y(ine20) dfdy(ia,ia) = dfdy(ia,ia) - 0.5d0* 1 ratdum(irne20ac)*y(ine20) dfdy(ia,ic12) = dfdy(ia,ic12) + ratdum(ir1212a)*y(ic12) dfdy(ia,ine20) = dfdy(ia,ine20) - 0.5d0* 1 ratdum(irne20ac)*aaa dfdy(ina23,ina23) = dfdy(ina23,ina23) - 0.5d0* 1 ratdum(irna23pc)*aap dfdy(ina23,ic12) = dfdy(ina23,ic12) + ratdum(ir1212p)*y(ic12) dfdy(ina23,ip) = dfdy(ina23,ip) - 0.5d0* 1 ratdum(irna23pc)*y(ina23) dfdy(ip,ip) = dfdy(ip,ip) - 0.5d0* 1 ratdum(irna23pc)*y(ina23) dfdy(ip,ic12) = dfdy(ip,ic12) + ratdum(ir1212p)*y(ic12) dfdy(ip,ina23) = dfdy(ip,ina23) - 0.5d0* 1 ratdum(irna23pc)*aap dfdy(img23,img23) = dfdy(img23,img23) - 0.5d0* 1 ratdum(irmg23nc)*aan dfdy(img23,ic12) = dfdy(img23,ic12) + ratdum(ir1212n)*y(ic12) dfdy(img23,in) = dfdy(img23,in) - 0.5d0* 1 ratdum(irmg23nc)*y(img23) dfdy(in,in) = dfdy(in,in) - 0.5d0* 1 ratdum(irmg23nc)*y(img23) dfdy(in,ic12) = dfdy(in,ic12) + ratdum(ir1212n)*y(ic12) dfdy(in,img23) = dfdy(in,img23) - 0.5d0* 1 ratdum(irmg23nc)*aan end if c..o16+o16 reactions; must have si28 p30 p31 s31 if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is32 .ne. 0) then dfdy(io16,io16) = dfdy(io16,io16) 1 - 2.0d0*y(io16)*(ratdum(ir1616n) + 2 ratdum(ir1616p) + ratdum(ir1616a) + ratdum(ir1616d)) dfdy(io16,isi28) = dfdy(io16,isi28) + ratdum(irsi28ao)*aaa dfdy(io16,ip31) = dfdy(io16,ip31) + ratdum(irp31po)*aap dfdy(io16,is31) = dfdy(io16,is31) + ratdum(irs31no)*aan dfdy(io16,ia) = dfdy(io16,ia) + ratdum(irsi28ao)*y(isi28) dfdy(io16,ip) = dfdy(io16,ip) + ratdum(irp31po)*y(ip31) dfdy(io16,in) = dfdy(io16,in) + ratdum(irs31no)*y(is31) dfdy(isi28,io16) = dfdy(isi28,io16) + ratdum(ir1616a)*y(io16) dfdy(isi28,isi28) = dfdy(isi28,isi28) - 0.5d0* 1 ratdum(irsi28ao)*aaa dfdy(isi28,ia) = dfdy(isi28,ia) - 0.5d0* 1 ratdum(irsi28ao)*y(isi28) dfdy(ia,io16) = dfdy(ia,io16) + ratdum(ir1616a)*y(io16) dfdy(ia,isi28) = dfdy(ia,isi28) - 0.5d0* 1 ratdum(irsi28ao)*aaa dfdy(ia,ia) = dfdy(ia,ia) - 0.5d0* 1 ratdum(irsi28ao)*y(isi28) dfdy(ip31,io16) = dfdy(ip31,io16) + ratdum(ir1616p)*y(io16) dfdy(ip31,ip31) = dfdy(ip31,ip31) - 0.5d0*ratdum(irp31po)*aap dfdy(ip31,ip) = dfdy(ip31,ip) - 0.5d0* 1 ratdum(irp31po)*y(ip31) dfdy(ip,io16) = dfdy(ip,io16) + ratdum(ir1616p)*y(io16) dfdy(ip,ip31) = dfdy(ip,ip31) - 0.5d0*ratdum(irp31po)*aap dfdy(ip,ip) = dfdy(ip,ip) - 0.5d0* 1 ratdum(irp31po)*y(ip31) dfdy(is31,io16) = dfdy(is31,io16) + ratdum(ir1616n)*y(io16) dfdy(is31,is31) = dfdy(is31,is31) - 0.5d0*ratdum(irs31no)*aan dfdy(is31,in) = dfdy(is31,in) - 0.5d0* 1 ratdum(irs31no)*y(is31) dfdy(in,io16) = dfdy(in,io16) + ratdum(ir1616n)*y(io16) dfdy(in,is31) = dfdy(in,is31) - 0.5d0*ratdum(irs31no)*aan dfdy(in,in) = dfdy(in,in) - 0.5d0* 1 ratdum(irs31no)*y(is31) dfdy(ip30,io16) = dfdy(ip30,io16) + ratdum(ir1616d)*y(io16) dfdy(in,io16) = dfdy(in,io16) + ratdum(ir1616d)*y(io16) dfdy(ip,io16) = dfdy(ip,io16) + ratdum(ir1616d)*y(io16) end if c..c12+o16 reactions; must have mg24 al27 si27 if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then dfdy(ic12,ic12) = dfdy(ic12,ic12) 1 - y(io16)*(ratdum(ir1216n) + ratdum(ir1216p) + ratdum(ir1216a)) dfdy(ic12,io16) = dfdy(ic12,io16) 1 - y(ic12)*(ratdum(ir1216n) + ratdum(ir1216p) + ratdum(ir1216a)) dfdy(ic12,isi27) = dfdy(ic12,isi27) + aan*ratdum(irsi27no) dfdy(ic12,ial27) = dfdy(ic12,ial27) + aap*ratdum(iral27po) dfdy(ic12,img24) = dfdy(ic12,img24) + aaa*ratdum(irmg24ao) dfdy(ic12,in) = dfdy(ic12,in) + y(isi27)*ratdum(irsi27no) dfdy(ic12,ip) = dfdy(ic12,ip) + y(ial27)*ratdum(iral27po) dfdy(ic12,ia) = dfdy(ic12,ia) + y(img24)*ratdum(irmg24ao) dfdy(io16,ic12) = dfdy(io16,ic12) 1 - y(io16)*(ratdum(ir1216n) + ratdum(ir1216p) + ratdum(ir1216a)) dfdy(io16,io16) = dfdy(io16,io16) 1 - y(ic12)*(ratdum(ir1216n) + ratdum(ir1216p) + ratdum(ir1216a)) dfdy(io16,isi27) = dfdy(io16,isi27) + aan*ratdum(irsi27no) dfdy(io16,ial27) = dfdy(io16,ial27) + aap*ratdum(iral27po) dfdy(io16,img24) = dfdy(io16,img24) + aaa*ratdum(irmg24ao) dfdy(io16,in) = dfdy(io16,in) + y(isi27)*ratdum(irsi27no) dfdy(io16,ip) = dfdy(io16,ip) + y(ial27)*ratdum(iral27po) dfdy(io16,ia) = dfdy(io16,ia) + y(img24)*ratdum(irmg24ao) dfdy(isi27,ic12) = dfdy(isi27,ic12) + y(io16)*ratdum(ir1216n) dfdy(isi27,io16) = dfdy(isi27,io16) + y(ic12)*ratdum(ir1216n) dfdy(isi27,isi27) = dfdy(isi27,isi27) - aan*ratdum(irsi27no) dfdy(isi27,in) = dfdy(isi27,in) - y(isi27)*ratdum(irsi27no) dfdy(ial27,ic12) = dfdy(ial27,ic12) + y(io16)*ratdum(ir1216p) dfdy(ial27,io16) = dfdy(ial27,io16) + y(ic12)*ratdum(ir1216p) dfdy(ial27,ial27) = dfdy(ial27,ial27) - aap*ratdum(iral27po) dfdy(ial27,ip) = dfdy(ial27,ip) - y(ial27)*ratdum(iral27po) dfdy(img24,ic12) = dfdy(img24,ic12) + y(io16)*ratdum(ir1216a) dfdy(img24,io16) = dfdy(img24,io16) + y(ic12)*ratdum(ir1216a) dfdy(img24,img24) = dfdy(img24,img24) - aaa*ratdum(irmg24ao) dfdy(img24,ia) = dfdy(img24,ia) - y(img24)*ratdum(irmg24ao) dfdy(in,ic12) = dfdy(in,ic12) + y(io16)*ratdum(ir1216n) dfdy(in,io16) = dfdy(in,io16) + y(ic12)*ratdum(ir1216n) dfdy(in,isi27) = dfdy(in,isi27) - aan*ratdum(irsi27no) dfdy(in,in) = dfdy(in,in) - y(isi27)*ratdum(irsi27no) dfdy(ip,ic12) = dfdy(ip,ic12) + y(io16)*ratdum(ir1216p) dfdy(ip,io16) = dfdy(ip,io16) + y(ic12)*ratdum(ir1216p) dfdy(ip,ial27) = dfdy(ip,ial27) - aap*ratdum(iral27po) dfdy(ip,ip) = dfdy(ip,ip) - y(ial27)*ratdum(iral27po) dfdy(ia,ic12) = dfdy(ia,ic12) + y(io16)*ratdum(ir1216a) dfdy(ia,io16) = dfdy(ia,io16) + y(ic12)*ratdum(ir1216a) dfdy(ia,ia) = dfdy(ia,ia) - y(img24)*ratdum(irmg24ao) dfdy(ia,img24) = dfdy(ia,img24) - aaa*ratdum(irmg24ao) end if c..if we have deutrium if (ih2 .ne. 0) then c..pp and pep dfdy(ip,ip) = dfdy(ip,ip) 1 - 2.0d0*aap*(ratdum(irpp)+ ratdum(irpep)) dfdy(ih2,ip) = dfdy(ih2,ip) + aap*(ratdum(irpp)+ ratdum(irpep)) c..p(n,g)d a1 = ratdum(irpng)*aan a2 = ratdum(irdgn) a3 = ratdum(irpng)*aap dfdy(ih2,ih2) = dfdy(ih2,ih2) - a2 dfdy(ih2,in) = dfdy(ih2,in) + a3 dfdy(ih2,ip) = dfdy(ih2,ip) + a1 dfdy(in,ih2) = dfdy(in,ih2) + a2 dfdy(in,in) = dfdy(in,in) - a3 dfdy(in,ip) = dfdy(in,ip) - a1 dfdy(ip,ih2) = dfdy(ip,ih2) + a2 dfdy(ip,in) = dfdy(ip,in) - a3 dfdy(ip,ip) = dfdy(ip,ip) - a1 c..d(p,n)2p a1 = 0.5d0*aap*ratdum(ir2pnp) a2 = y(ih2)*ratdum(irdpn) - 0.5d0*aan*ratdum(ir2pnp) a3 = aap*ratdum(irdpn) dfdy(ih2,ih2) = dfdy(ih2,ih2) - a3 dfdy(ih2,in) = dfdy(ih2,in) + a1 dfdy(ih2,ip) = dfdy(ih2,ip) - a2 dfdy(in,ih2) = dfdy(in,ih2) + a3 dfdy(in,in) = dfdy(in,in) - a1 dfdy(in,ip) = dfdy(in,ip) + a2 dfdy(ip,ih2) = dfdy(ip,ih2) + a3 dfdy(ip,in) = dfdy(ip,in) - a1 dfdy(ip,ip) = dfdy(ip,ip) + a2 c..d(d,g)he4 a1 = -2.0d0*y(ih2)*ratdum(irddg) a2 = 2.0d0*ratdum(irhe4gd) dfdy(ih2,ih2) = dfdy(ih2,ih2) + a1 dfdy(ih2,ia) = dfdy(ih2,ia) + a2 dfdy(ia,ih2) = dfdy(ia,ih2) - 0.5d0 * a1 dfdy(ia,ia) = dfdy(ia,ia) - 0.5d0 * a2 end if c..if we have deuterium and tritium if (ih2.ne.0 .and. ih3 .ne. 0) then c..d(t,n)he4, dt reaction a1 = y(ih3)*ratdum(irtdn) a2 = y(ih2)*ratdum(irtdn) a3 = -aan*ratdum(irhe4nd) a4 = -aaa*ratdum(irhe4nd) dfdy(ih2,ih2) = dfdy(ih2,ih2) - a1 dfdy(ih2,ih3) = dfdy(ih2,ih3) - a2 dfdy(ih2,ia) = dfdy(ih2,ia) - a3 dfdy(ih2,in) = dfdy(ih2,in) - a4 dfdy(ih3,ih3) = dfdy(ih3,ih3) - a1 dfdy(ih3,ih2) = dfdy(ih3,ih2) - a2 dfdy(ih3,ia) = dfdy(ih3,ia) - a3 dfdy(ih3,in) = dfdy(ih3,in) - a4 dfdy(ia,ih2) = dfdy(ia,ih2) + a1 dfdy(ia,ih3) = dfdy(ia,ih3) + a2 dfdy(ia,ia) = dfdy(ia,ia) + a3 dfdy(ia,in) = dfdy(ia,in) + a4 dfdy(in,ih2) = dfdy(in,ih2) + a1 dfdy(in,ih3) = dfdy(in,ih3) + a2 dfdy(in,ia) = dfdy(in,ia) + a3 dfdy(in,in) = dfdy(in,in) + a4 c..d(d,p)t a1 = y(ih2)*ratdum(irddp) a2 = -aap*ratdum(irtpd) a3 = -y(ih3)*ratdum(irtpd) dfdy(ih2,ih2) = dfdy(ih2,ih2) - 2.0d0 * a1 dfdy(ih2,ih3) = dfdy(ih2,ih3) - 2.0d0 * a2 dfdy(ih2,ip) = dfdy(ih2,ip) - 2.0d0 * a3 dfdy(ih3,ih2) = dfdy(ih3,ih2) + a1 dfdy(ih3,ih3) = dfdy(ih3,ih3) + a2 dfdy(ih3,ip) = dfdy(ih3,ip) + a3 dfdy(ip,ih2) = dfdy(ip,ih2) + a1 dfdy(ip,ih3) = dfdy(ip,ih3) + a2 dfdy(ip,ip) = dfdy(ip,ip) + a3 end if c..if we have tritium if (ih3.ne.0) then c..t(p,g)he4 a1 = ratdum(irh3pg)*aap a2 = ratdum(irhe4gp) a3 = ratdum(irh3pg)*y(ih3) dfdy(ih3,ih3) = dfdy(ih3,ih3) - a1 dfdy(ih3,ia) = dfdy(ih3,ia) + a2 dfdy(ih3,ip) = dfdy(ih3,ip) - a3 dfdy(ia,ih3) = dfdy(ia,ih3) + a1 dfdy(ia,ia) = dfdy(ia,ia) - a2 dfdy(ia,ip) = dfdy(ia,ip) + a3 dfdy(ip,ih3) = dfdy(ip,ih3) - a1 dfdy(ip,ia) = dfdy(ip,ia) + a2 dfdy(ip,ip) = dfdy(ip,ip) - a3 c..t(t,2n)he4 a1 = 2.0d0*y(ih3)*ratdum(irtt2n) a2 = -aaa*ratdum(irhe42nt) a3 = -aan*ratdum(irhe42nt) dfdy(ih3,ih3) = dfdy(ih3,ih3) - a1 dfdy(ih3,in) = dfdy(ih3,in) - a2 dfdy(ih3,ia) = dfdy(ih3,ia) - a3 dfdy(in,ih3) = dfdy(in,ih3) + a1 dfdy(in,in) = dfdy(in,in) + a2 dfdy(in,ia) = dfdy(in,ia) + a3 dfdy(ia,ih3) = dfdy(ia,ih3) + 0.5d0 * a1 dfdy(ia,in) = dfdy(ia,in) + 0.5d0 * a2 dfdy(ia,ia) = dfdy(ia,ia) + 0.5d0 * a3 end if c..if we have he3 if (ihe3 .ne. 0) then c..he3(he3,2p)he4 a1 = 2.0d0*y(ihe3)*ratdum(ir33) a2 = -aaa*ratdum(ir33inv) a3 = -aap*ratdum(ir33inv) dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a1 dfdy(ihe3,ip) = dfdy(ihe3,ip) - a2 dfdy(ihe3,ia) = dfdy(ihe3,ia) - a3 dfdy(ip,ihe3) = dfdy(ip,ihe3) + a1 dfdy(ip,ip) = dfdy(ip,ip) + a2 dfdy(ip,ia) = dfdy(ip,ia) + a3 dfdy(ia,ihe3) = dfdy(ia,ihe3) + 0.5d0 * a1 dfdy(ia,ip) = dfdy(ia,ip) + 0.5d0 * a2 dfdy(ia,ia) = dfdy(ia,ia) + 0.5d0 * a3 c..he3(p,e+nu)he4 a1 = y(ihe3)*ratdum(irhep) a2 = aap*ratdum(irhep) dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a2 dfdy(ihe3,ip) = dfdy(ihe3,ip) - a1 dfdy(ip,ihe3) = dfdy(ip,ihe3) - a2 dfdy(ip,ip) = dfdy(ip,ip) - a1 dfdy(ia,ihe3) = dfdy(ia,ihe3) + a2 dfdy(ia,ip) = dfdy(ia,ip) + a1 c..he3(n,g)he4 a1 = ratdum(irhe3ng)*aan a2 = ratdum(irhe4gn) a3 = ratdum(irhe3ng)*y(ihe3) dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a1 dfdy(ihe3,ia) = dfdy(ihe3,ia) + a2 dfdy(ihe3,in) = dfdy(ihe3,in) - a3 dfdy(ia,ihe3) = dfdy(ia,ihe3) + a1 dfdy(ia,ia) = dfdy(ia,ia) - a2 dfdy(ia,in) = dfdy(ia,in) + a3 dfdy(in,ihe3) = dfdy(in,ihe3) - a1 dfdy(in,ia) = dfdy(in,ia) + a2 dfdy(in,in) = dfdy(in,in) - a3 end if c..if we have deuterium and he3 if (ih2 .ne. 0 .and. ihe3 .ne. 0) then c..he3(d,p)he4 a1 = y(ihe3)*ratdum(irhe3dp) a2 = y(ih2)*ratdum(irhe3dp) a3 = -aap*ratdum(irhe4pd) a4 = -aaa*ratdum(irhe4pd) dfdy(ih2,ih2) = dfdy(ih2,ih2) - a1 dfdy(ih2,ihe3) = dfdy(ih2,ihe3) - a2 dfdy(ih2,ia) = dfdy(ih2,ia) - a3 dfdy(ih2,ip) = dfdy(ih2,ip) - a4 dfdy(ihe3,ih2) = dfdy(ihe3,ih2) - a1 dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a2 dfdy(ihe3,ia) = dfdy(ihe3,ia) - a3 dfdy(ihe3,ip) = dfdy(ihe3,ip) - a4 dfdy(ia,ih2) = dfdy(ia,ih2) + a1 dfdy(ia,ihe3) = dfdy(ia,ihe3) + a2 dfdy(ia,ia) = dfdy(ia,ia) + a3 dfdy(ia,ip) = dfdy(ia,ip) + a4 dfdy(ip,ih2) = dfdy(ip,ih2) + a1 dfdy(ip,ihe3) = dfdy(ip,ihe3) + a2 dfdy(ip,ia) = dfdy(ip,ia) + a3 dfdy(ip,ip) = dfdy(ip,ip) + a4 c..d(d,n)he3 a1 = y(ih2)*ratdum(irddn) a2 = -aan*ratdum(irhe3nd) a3 = -y(ihe3)*ratdum(irhe3nd) dfdy(ih2,ih2) = dfdy(ih2,ih2) - 2.0d0 * a1 dfdy(ih2,ihe3) = dfdy(ih2,ihe3) - 2.0d0 * a2 dfdy(ih2,in) = dfdy(ih2,in) - 2.0d0 * a3 dfdy(ihe3,ih2) = dfdy(ihe3,ih2) + a1 dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) + a2 dfdy(ihe3,in) = dfdy(ihe3,in) + a3 dfdy(in,ih2) = dfdy(in,ih2) + a1 dfdy(in,ihe3) = dfdy(in,ihe3) + a2 dfdy(in,in) = dfdy(in,in) + a3 end if c..if we have deuterium, tritium, and he3 if (ihe3 .ne. 0 .and. ih3 .ne. 0 .and. ih2 .ne. 0) then c..he3(t,d)he4 a1 = -aaa*ratdum(irhe4dt) a2 = y(ihe3)*ratdum(irhe3td) a3 = y(ih3)*ratdum(irhe3td) a4 = -y(ih2)*ratdum(irhe4dt) dfdy(ih2,ih2) = dfdy(ih2,ih2) + a1 dfdy(ih2,ih3) = dfdy(ih2,ih3) + a2 dfdy(ih2,ihe3) = dfdy(ih2,ihe3) + a3 dfdy(ih2,ia) = dfdy(ih2,ia) + a4 dfdy(ih3,ih2) = dfdy(ih3,ih2) - a1 dfdy(ih3,ih3) = dfdy(ih3,ih3) - a2 dfdy(ih3,ihe3) = dfdy(ih3,ihe3) - a3 dfdy(ih3,ia) = dfdy(ih3,ia) - a4 dfdy(ihe3,ih2) = dfdy(ihe3,ih2) - a1 dfdy(ihe3,ih3) = dfdy(ihe3,ih3) - a2 dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a3 dfdy(ihe3,ia) = dfdy(ihe3,ia) - a4 dfdy(ia,ih2) = dfdy(ia,ih2) + a1 dfdy(ia,ih3) = dfdy(ia,ih3) + a2 dfdy(ia,ihe3) = dfdy(ia,ihe3) + a3 dfdy(ia,ia) = dfdy(ia,ia) + a4 end if c..if we have tritium and he3 if (ihe3 .ne. 0 .and. ih3 .ne. 0) then c..he3(t,np)he4 a1 = y(ihe3)*ratdum(irhe3tnp) a2 = y(ih3)*ratdum(irhe3tnp) dfdy(ih3,ih3) = dfdy(ih3,ih3) - a1 dfdy(ih3,ihe3) = dfdy(ih3,ihe3) - a2 dfdy(ihe3,ih3) = dfdy(ihe3,ih3) - a1 dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a2 dfdy(ia,ih3) = dfdy(ia,ih3) + a1 dfdy(ia,ihe3) = dfdy(ia,ihe3) + a2 dfdy(ip,ih3) = dfdy(ip,ih3) + a1 dfdy(ip,ihe3) = dfdy(ip,ihe3) + a2 dfdy(in,ih3) = dfdy(in,ih3) + a1 dfdy(in,ihe3) = dfdy(in,ihe3) + a2 end if c..if we have lithium7 if (ili7 .ne. 0) then c..li7(p,g)be8=>2a + li7(p,a)a reactions a1 = -aap*ratdum(irli7pag) a2 = -y(ili7)*ratdum(irli7pag) a3 = aaa*ratdum(ir2he4ga) dfdy(ili7,ili7) = dfdy(ili7,ili7) + a1 dfdy(ili7,ip) = dfdy(ili7,ip) + a2 dfdy(ili7,ia) = dfdy(ili7,ia) + a3 dfdy(ip,ili7) = dfdy(ip,ili7) + a1 dfdy(ip,ip) = dfdy(ip,ip) + a2 dfdy(ip,ia) = dfdy(ip,ia) + a3 dfdy(ia,ili7) = dfdy(ia,ili7) - 2.0d0 * a1 dfdy(ia,ip) = dfdy(ia,ip) - 2.0d0 * a2 dfdy(ia,ia) = dfdy(ia,ia) - 2.0d0 * a3 end if c..if we have deuterium and li7 if (ili7 .ne. 0 .and. ih2 .ne. 0) then c..li7(d,n)2a a1 = y(ili7)*ratdum(irli7dn) a2 = y(ih2)*ratdum(irli7dn) dfdy(ih2,ih2) = dfdy(ih2,ih2) - a1 dfdy(ih2,ili7) = dfdy(ih2,ili7) - a2 dfdy(ili7,ih2) = dfdy(ili7,ih2) - a1 dfdy(ili7,ili7) = dfdy(ili7,ili7) - a2 dfdy(in,ih2) = dfdy(in,ih2) + a1 dfdy(in,ili7) = dfdy(in,ili7) + a2 dfdy(ia,ih2) = dfdy(ia,ih2) + 2.0d0 * a1 dfdy(ia,ili7) = dfdy(ia,ili7) + 2.0d0 * a2 end if c..if we have tritium and li7 if (ili7 .ne. 0 .and. ih3 .ne. 0) then c..li7(t,2n)2a a1 = y(ili7)*ratdum(irli7t2n) a2 = y(ih3)*ratdum(irli7t2n) dfdy(ih3,ih3) = dfdy(ih3,ih3) - a1 dfdy(ih3,ili7) = dfdy(ih3,ili7) - a2 dfdy(ili7,ih3) = dfdy(ili7,ih3) - a1 dfdy(ili7,ili7) = dfdy(ili7,ili7) - a2 dfdy(in,ih3) = dfdy(in,ih3) + 2.0d0 * a1 dfdy(in,ili7) = dfdy(in,ili7) + 2.0d0 * a2 dfdy(ia,ih3) = dfdy(ia,ih3) + 2.0d0 * a1 dfdy(ia,ili7) = dfdy(ia,ili7) + 2.0d0 * a2 end if c..if we have he3 and li7 if (ili7 .ne. 0 .and. ihe3 .ne. 0) then c..li7(he3,np)2a a1 = y(ili7)*ratdum(irli7he3np) a2 = y(ihe3)*ratdum(irli7he3np) dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a1 dfdy(ihe3,ili7) = dfdy(ihe3,ili7) - a2 dfdy(ili7,ihe3) = dfdy(ili7,ihe3) - a1 dfdy(ili7,ili7) = dfdy(ili7,ili7) - a2 dfdy(in,ihe3) = dfdy(in,ihe3) + a1 dfdy(in,ili7) = dfdy(in,ili7) + a2 dfdy(ip,ihe3) = dfdy(ip,ihe3) + a1 dfdy(ip,ili7) = dfdy(ip,ili7) + a2 dfdy(ia,ihe3) = dfdy(ia,ihe3) + 2.0d0 * a1 dfdy(ia,ili7) = dfdy(ia,ili7) + 2.0d0 * a2 end if c..if we have deuterium and be7 if (ibe7 .ne. 0 .and. ih2 .ne. 0) then c..be7(d,p)2a a1 = y(ibe7)*ratdum(irbe7dp) a2 = y(ih2)*ratdum(irbe7dp) dfdy(ih2,ih2) = dfdy(ih2,ih2) - a1 dfdy(ih2,ibe7) = dfdy(ih2,ibe7) - a2 dfdy(ibe7,ih2) = dfdy(ibe7,ih2) - a1 dfdy(ibe7,ibe7) = dfdy(ibe7,ibe7) - a2 dfdy(ip,ih2) = dfdy(ip,ih2) + a1 dfdy(ip,ibe7) = dfdy(ip,ibe7) + a2 dfdy(ia,ih2) = dfdy(ia,ih2) + 2.0d0 * a1 dfdy(ia,ibe7) = dfdy(ia,ibe7) + 2.0d0 * a2 end if c..if we have tritium and be7 if (ibe7 .ne. 0 .and. ih3 .ne. 0) then c..be7(t,np)2a a1 = y(ibe7)*ratdum(irbe7tnp) a2 = y(ih3)*ratdum(irbe7tnp) dfdy(ih3,ih3) = dfdy(ih3,ih3) - a1 dfdy(ih3,ibe7) = dfdy(ih3,ibe7) - a2 dfdy(ibe7,ih3) = dfdy(ibe7,ih3) - a1 dfdy(ibe7,ibe7) = dfdy(ibe7,ibe7) - a2 dfdy(ip,ih3) = dfdy(ip,ih3) + a1 dfdy(ip,ibe7) = dfdy(ip,ibe7) + a2 dfdy(in,ih3) = dfdy(in,ih3) + a1 dfdy(in,ibe7) = dfdy(in,ibe7) + a2 dfdy(ia,ih3) = dfdy(ia,ih3) + 2.0d0 * a1 dfdy(ia,ibe7) = dfdy(ia,ibe7) + 2.0d0 * a2 end if c..if we have he3 and be7 if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then c..be7(he3,2p)2a a1 = y(ibe7)*ratdum(irbe7he32p) a2 = y(ihe3)*ratdum(irbe7he32p) dfdy(ihe3,ihe3) = dfdy(ihe3,ihe3) - a1 dfdy(ihe3,ibe7) = dfdy(ihe3,ibe7) - a2 dfdy(ibe7,ihe3) = dfdy(ibe7,ihe3) - a1 dfdy(ibe7,ibe7) = dfdy(ibe7,ibe7) - a2 dfdy(ip,ihe3) = dfdy(ip,ihe3) + 2.0d0 * a1 dfdy(ip,ibe7) = dfdy(ip,ibe7) + 2.0d0 * a2 dfdy(ia,ihe3) = dfdy(ia,ihe3) + 2.0d0 * a1 dfdy(ia,ibe7) = dfdy(ia,ibe7) + 2.0d0 * a2 end if c..if we have be9 if (ibe9 .ne. 0) then c..a(an,g)be9 a1 = aaa * aan * ratdum(iraan) a2 = 0.5d0*aaa * aaa * ratdum(iraan) dfdy(ia,ia) = dfdy(ia,ia) - 2.0d0 * a1 dfdy(ia,in) = dfdy(ia,in) - 2.0d0 * a2 dfdy(ia,ibe9) = dfdy(ia,ibe9) + 2.0d0 * ratdum(irgaan) dfdy(in,ia) = dfdy(in,ia) - a1 dfdy(in,in) = dfdy(in,in) - a2 dfdy(in,ibe9) = dfdy(in,ibe9) + ratdum(irgaan) dfdy(ibe9,ia) = dfdy(ibe9,ia) + a1 dfdy(ibe9,in) = dfdy(ibe9,in) + a2 dfdy(ibe9,ibe9) = dfdy(ibe9,ibe9) - ratdum(irgaan) end if c..if we have deuterium aand be9 if (ibe9 .ne. 0 .and. ih2 .ne. 0) then c..be9(p,d)be8 =>2a a1 = aap*ratdum(irbe9pd) a2 = y(ibe9)*ratdum(irbe9pd) dfdy(ibe9,ibe9) = dfdy(ibe9,ibe9) - a1 dfdy(ibe9,ip) = dfdy(ibe9,ip) - a2 dfdy(ip,ibe9) = dfdy(ip,ibe9) - a1 dfdy(ip,ip) = dfdy(ip,ip) - a2 dfdy(ih2,ibe9) = dfdy(ih2,ibe9) + a1 dfdy(ih2,ip) = dfdy(ih2,ip) + a2 dfdy(ia,ibe9) = dfdy(ia,ibe9) + 2.0d0*a1 dfdy(ia,ip) = dfdy(ia,ip) + 2.0d0*a2 end if c..if we have boron 8 if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions dfdy(ib8,ib8) = dfdy(ib8,ib8) - ratdum(irb8ep) dfdy(ia,ib8) = dfdy(ia,ib8) + 2.0d0*ratdum(irb8ep) end if c..if we have boron 11 if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions a1 = -aap*ratdum(irb11pa) a2 = -y(ib11)*ratdum(irb11pa) a3 = 2.0d0*aaa*ratdum(ir3ap)/3.0d0 dfdy(ib11,ib11) = dfdy(ib11,ib11) + a1 dfdy(ib11,ip) = dfdy(ib11,ip) + a2 dfdy(ib11,ia) = dfdy(ib11,ia) + a3 dfdy(ip,ib11) = dfdy(ip,ib11) + a1 dfdy(ip,ip) = dfdy(ip,ip) + a2 dfdy(ip,ia) = dfdy(ip,ia) + a3 dfdy(ia,ib11) = dfdy(ia,ib11) - 3.0d0 * a1 dfdy(ia,ip) = dfdy(ia,ip) - 3.0d0 * a2 dfdy(ia,ia) = dfdy(ia,ia) - 3.0d0 * a3 end if c..if we have carbon 11 if (ic11 .ne. 0) then c..c11(na)be8 => 2a a1 = aan*ratdum(irc11na) a2 = y(ic11)*ratdum(irc11na) dfdy(ic11,ic11) = dfdy(ic11,ic11) - a1 dfdy(ic11,in) = dfdy(ic11,in) - a2 dfdy(in,ic11) = dfdy(in,ic11) - a1 dfdy(in,in) = dfdy(in,in) - a2 dfdy(ia,ic11) = dfdy(ia,ic11) + 3.0d0*a1 dfdy(ia,in) = dfdy(ia,in) + 3.0d0*a2 end if c..if we are doing a pure network, we are done if (pure_network .eq. 1) return c..temperature dependence of the reaction equations call rhs(y,sigdt,dratdumdt,zwork1) do i=1,ionmax dfdy(i,itemp) = zwork1(i) enddo c..density dependence of the reaction equations call rhs(y,sigdd,dratdumdd,zwork1) 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) c dfdy(iener,j) = 0.0d0 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) c dfdy(iener,j) = 0.0d0 c dfdy(iener,itemp) = 0.0d0 c dfdy(iener,iden) = 0.0d0 enddo dfdy(iener,itemp) = dfdy(iener,itemp) * conv dfdy(iener,iden) = dfdy(iener,iden) * conv c dfdy(iener,itemp) = 0.0d0 c dfdy(iener,iden) = 0.0d0 dsdotdt = dfdy(iener,itemp) dsdotdd = dfdy(iener,iden) c..account for the neutrino losses if (bbang) then sneut = 0.0d0 dsneutdt = 0.0d0 dsneutdd = 0.0d0 snuda = 0.0d0 snudz = 0.0d0 else call sneut5(btemp,bden,abar,zbar, 1 sneut,dsneutdt,dsneutdd,snuda,snudz) end if do j=1,ionmax dfdy(iener,j) = dfdy(iener,j) 1 - (-abar*abar*snuda + (zion(j) - zbar)*abar*snudz) c dfdy(iener,j) = 0.0d0 enddo dfdy(iener,itemp) = dfdy(iener,itemp) - dsneutdt dfdy(iener,iden) = dfdy(iener,iden) - dsneutdd c dfdy(iener,itemp) = 0.0d0 c dfdy(iener,iden) = 0.0d0 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 c taud = 446.0d0/sqrt(bden) taud = 446.0d0/sqrt(den0) taut = 3.0d0 * taud dfdy(itemp,itemp) = -psi/taut dfdy(iden,iden) = -psi/taud c..power law fit to 2d simulations c dfdy(itemp,itemp) = 0.0d0 c dfdy(iden,iden) = 0.0d0 c..for self-heating at constant density 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) c..for self-heating at constant pressure else if (self_heat_const_pres) then c..call an eos c temp_row(1) = btemp c den_row(1) = bden c abar_row(1) = abar c zbar_row(1) = zbar c jlo_eos = 1 c jhi_eos = 1 c call helmeos c..d(itemp)/d(yi) zz = 1.0d0/cp_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) c..for detonations else if (detonation) then c..get the right hand sides call rhs(y,sig,ratdum,dydt) c..instantaneous energy generation rate enuc = 0.0d0 do i=1,ionmax enuc = enuc + dydt(i) * bion(i) enddo enuc = enuc * conv dydt(iener) = enuc - sneut c..map the rest of the input vector velx = y(ivelx) posx = y(iposx) c..it appears as if we need the derivatives of derivative based c..eos quantities. grrr. z = bden xx = 0.01d0*z bden = z + xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos foo(1) = cs_row(1) foo(2) = dpt_row(1) foo(3) = dpt_row(1)/det_row(1) foo(4) = dpd_row(1) foo(5) = dpa_row(1) foo(6) = dpz_row(1) foo(7) = dea_row(1) foo(8) = dez_row(1) bden = z - xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos moo(1) = cs_row(1) moo(2) = dpt_row(1) moo(3) = dpt_row(1)/det_row(1) moo(4) = dpd_row(1) moo(5) = dpa_row(1) moo(6) = dpz_row(1) moo(7) = dea_row(1) moo(8) = dez_row(1) bden = z z = 0.5d0/xx csbd = (foo(1) - moo(1))*z dptbd = (foo(2) - moo(2))*z dpdebd = (foo(3) - moo(3))*z dpdbd = (foo(4) - moo(4))*z dpabd = (foo(5) - moo(5))*z dpzbd = (foo(6) - moo(6))*z deabd = (foo(7) - moo(7))*z dezbd = (foo(8) - moo(8))*z z = btemp xx = 0.01d0*z btemp = z + xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos foo(1) = cs_row(1) foo(2) = dpt_row(1) foo(3) = dpt_row(1)/det_row(1) foo(4) = dpd_row(1) foo(5) = dpa_row(1) foo(6) = dpz_row(1) foo(7) = dea_row(1) foo(8) = dez_row(1) btemp = z - xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos moo(1) = cs_row(1) moo(2) = dpt_row(1) moo(3) = dpt_row(1)/det_row(1) moo(4) = dpd_row(1) moo(5) = dpa_row(1) moo(6) = dpz_row(1) moo(7) = dea_row(1) moo(8) = dez_row(1) btemp = z z = 0.5d0/xx csbt = (foo(1) - moo(1))*z dptbt = (foo(2) - moo(2))*z dpdebt = (foo(3) - moo(3))*z dpdbt = (foo(4) - moo(4))*z dpabt = (foo(5) - moo(5))*z dpzbt = (foo(6) - moo(6))*z deabt = (foo(7) - moo(7))*z dezbt = (foo(8) - moo(8))*z 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..for de/dy and dp/dy suma = 0.0d0 do i=1,ionmax suma = suma - dydt(i) enddo sumz = 0.0d0 do i=1,ionmax sumz = sumz + (zion(i) - zbar)*dydt(i) enddo sum = 0.0d0 do i=1,ionmax sum = sum - dfdy(i,iden) enddo sum5 = sum * dea_row(1)*abar*abar sum9 = sum * dpa_row(1)*abar*abar sum = 0.0d0 do i=1,ionmax sum = sum + (zion(i) - zbar)*dfdy(i,iden) enddo sum6 = sum * dez_row(1)*abar sum10 = sum * dpz_row(1)*abar sum = 0.0d0 do i=1,ionmax sum = sum - dfdy(i,itemp) enddo sum7 = sum * dea_row(1)*abar*abar sum11 = sum * dpa_row(1)*abar*abar sum = 0.0d0 do i=1,ionmax sum = sum + (zion(i) - zbar)*dfdy(i,itemp) enddo sum8 = sum * dez_row(1)*abar sum12 = sum * dpz_row(1)*abar c..the possibly singular denominator cs = cs_row(1) denom = velx*velx - cs*cs denombv = 2.0d0*velx denomdd = -2.0d0*cs*csbd denomdt = -2.0d0*cs*csbt c..the function phi dpde = dpt_row(1)/det_row(1) z = suma*dpa_row(1)*abar*abar + sumz*dpz_row(1)*abar zbd = suma*dpabd*abar*abar + sumz*dpzbd*abar + sum9 + sum10 zbt = suma*dpabt*abar*abar + sumz*dpzbt*abar + sum11 + sum12 ww = suma*dea_row(1)*abar*abar + sumz*dez_row(1)*abar wwbd = suma*deabd*abar*abar + sumz*dezbd*abar + sum5 + sum6 wwbt = suma*deabt*abar*abar + sumz*dezbt*abar + sum7 + sum8 phi = dpde*(dydt(iener) - ww) - z phibd = dpdebd*(dydt(iener) - ww) - zbd 1 + dpde*(dfdy(iener,iden) - wwbd) phibt = dpdebt*(dydt(iener) - ww) - zbt 1 + dpde*(dfdy(iener,itemp) - wwbt) c..a common combination if (denom .ne. 0.0) then combo = phi/denom combobv = -combo/denom*denombv combobd = -combo/denom*denomdd + phibd/denom combobt = -combo/denom*denomdt + phibt/denom else combo = 0.0d0 combobv = 0.0d0 combobd = 0.0d0 combobt = 0.0d0 write(6,*) 'combo is zero!' end if c..position equation dydt(iposx) = velx dfdy(iposx,ivelx) = 1.0d0 c..density equation dydt(iden) = combo dfdy(iden,ivelx) = combobv dfdy(iden,iden) = combobd dfdy(iden,itemp) = combobt c..d(iden)/d(yi) yy = 1.0d0/denom zz = dpde*yy do j=1,ionmax xx = 0.0d0 ww = 0.0d0 do i=1,ionmax xx = xx + dfdy(i,j)*(-dea_row(1)*abar*abar 1 + dez_row(1)*(zion(i)-zbar)*abar) ww = ww + dfdy(i,j)*(-dpa_row(1)*abar*abar 1 + dpz_row(1)*(zion(i)-zbar)*abar) enddo dfdy(iden,j) = zz*(dfdy(iener,j) - xx) - ww*yy enddo c..velocity equation z = velx/bden dydt(ivelx) = -z*dydt(iden) dfdy(ivelx,ivelx) = -dydt(iden)/bden - z*dfdy(iden,ivelx) dfdy(ivelx,iden) = z/bden*dydt(iden) - z*dfdy(iden,iden) dfdy(ivelx,itemp) = -z*dfdy(iden,itemp) c..d(ivelx)/d(yi) do j=1,ionmax dfdy(ivelx,j) = -z*dfdy(iden,j) enddo c..temperature equation dtdp = 1.0d0/dpt_row(1) dtdpbd = -dtdp*dtdp*dptbd dtdpbt = -dtdp*dtdp*dptbt ww = suma*dpa_row(1)*abar*abar + sumz*dpz_row(1)*abar wwbd = suma*dpabd*abar*abar + sumz*dpzbd*abar + sum9 + sum10 wwbt = suma*dpabt*abar*abar + sumz*dpzbt*abar + sum11 + sum12 dydt(itemp) = dtdp*((velx*velx - dpd_row(1))*dydt(iden) - ww) dfdy(itemp,ivelx) = dtdp*(2.0d0*velx*dydt(iden) 1 + (velx*velx - dpd_row(1))*dfdy(iden,ivelx)) dfdy(itemp,iden) = dtdpbd*((velx*velx-dpd_row(1))*dydt(iden)-ww) 1 + dtdp*((velx*velx-dpd_row(1))*dfdy(iden,iden) 2 - dpdbd*dydt(iden) 3 - wwbd) dfdy(itemp,itemp) = dtdpbt*((velx*velx-dpd_row(1))*dydt(iden)-ww) 1 + dtdp*((velx*velx-dpd_row(1))*dfdy(iden,itemp) 2 - dpdbt*dydt(iden) 3 - wwbt) c..d(itemp)/d(yi) do j=1,ionmax ww = 0.0d0 do i=1,ionmax ww = ww + dfdy(i,j)*(-dpa_row(1)*abar*abar 1 + dpz_row(1)*(zion(i)-zbar)*abar) enddo dfdy(itemp,j) = dtdp*((velx*velx - dpd_row(1))*dfdy(iden,j) -ww) enddo c..bbang else if (bbang) then c..temperature jacobian elements xa = me * clight**2 / (kerg * btemp) dxadt = -xa/btemp f1 = wien1(xa) df1 = dwien1dx(xa) f2 = wien2(xa) df2 = dwien2dx(xa) con = sqrt(f2 * 8.0d0*pi*g*asol/(3.0d0*clight**2) ) dcondt = con/f2*df2*dxadt denom = xa * df1/(3.0d0*f1) - 1.0d0 ddenom = dxadt*df1/(3.0d0*f1) - xa*df1/(3.0d0*f1**2)*df1*dxadt zz = con*btemp**3 / denom dfdy(itemp,itemp) = 3.0d0*zz/btemp + zz/con * dcondt 1 - zz/denom * ddenom c..density jacobian elements f1 = 30.0d0 * zeta3/pi**4 * asol/(kerg*avo) xx = 3.0d0 * f1 * eta1 * btemp**2 dfdy(iden,itemp) = 2.0d0*xx*zz/btemp + xx*dfdy(itemp,itemp) end if return end subroutine btorch(iloc,jloc,nzo,np) include 'implno.dek' include 'network.dek' c..this routine builds the nonzero matrix locations for saprox c..input is the integer arrys iloc and jloc, both of dimension np, that c..on output contain nzo matrix element locations. c..declare integer np,iloc(np),jloc(np),nzo,in,ip,ia,j,k,i c..communicate with storch integer neloc parameter (neloc=260000) integer eloc(neloc),nterms common /elctch/ eloc,nterms c..initialize nterms = 0 nzo = 0 do i=1,neloc eloc(i) = 0 enddo call tree_init(neqs) c..set the pointers for n,p and a reactions in = ineut ip = iprot ia = ihe4 c..for every isotope in the network do j=ionbeg,ionend c..set up the (n,gam) components k = nrr(1,j) if (k .gt. 0) then call tree(j,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..set up the (p,n) beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then call tree(j,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..set up the (p,gam) components k = nrr(3,j) if (k .gt. 0) then call tree(j,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..set up the (alp,p) reactions k = nrr(4,j) if (k .gt. 0) then call tree(j,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..set up the (alp,n) components k = nrr(5,j) if (k .gt. 0) then call tree(j,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..and the (alp,gam) components k = nrr(6,j) if (k .gt. 0) then call tree(j,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(j,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(k,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,j,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,k,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if enddo c..now the special matrix elements c..for p(e-,nu)n and n(e+,nub)p reactions call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) c..triple alpha reactions if (ic12 .ne. 0) then call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..c12+c12 reactions must have ne20 na23 mg24 if (ic12 .ne. 0 .and. ine20 .ne. 0 .and. ina23 .ne. 0 .and. 1 img23 .ne. 0) then call tree(ic12,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ina23,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,img23,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ina23,ina23,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ina23,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ina23,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ina23,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img23,img23,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img23,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img23,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,img23,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..o16+o16 reactions if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then call tree(io16,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ip31,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,is31,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip31,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip31,ip31,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip31,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip31,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is31,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is31,is31,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is31,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,is31,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip30,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..c12+o16 reactions if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then call tree(ic12,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,isi27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ial27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,isi27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ial27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi27,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi27,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi27,isi27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi27,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ial27,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ial27,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ial27,ial27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ial27,ip,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,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img24,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,isi27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ial27,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have deutrium if (ih2 .ne. 0) then c..pp and pep call tree(ih2,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) c..p(n,g)d call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) c..d(p,n)2p call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) c..d(d,g)he4 call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have deutrium and tritium if (ih2 .ne. 0 .and. ih3 .ne. 0) then c..d(t,n)he4 dt reaction call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) c..d(d,p,t) call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have tritium if (ih3 .ne. 0) then c..t(p,g)he4 call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) c..t(t,2n)he4 call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have he3 if (ihe3 .ne. 0) then c..he3(he3,2p)he4 reaction call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) c..he3(p,e+nu)he4 call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) c..he3(n,g) call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have deutrium and he3 if (ih2 .ne. 0 .and. ihe3 .ne. 0) then c..he3(d,p)he4 call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ip,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,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) c..d(d,n)he3 call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,in,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,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have deuterium, tritium and he3 if (ihe3 .ne. 0 .and. ih3 .ne. 0 .and. ih2 .ne. 0) then c..he3(t,d)he4 call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..if we have tritium and he3 if (ihe3.ne.0 .and. ih3 .ne. 0) then c..he3(t,np)he4 call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..li7(p,g)be8=>2a + li7(p,a)a reactions if (ili7 .ne. 0) then call tree(ili7,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..li7(d,n)2a if (ili7 .ne. 0 .and. ih2 .ne. 0) then call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..li7(t,2n)2a if (ili7 .ne. 0 .and. ih3 .ne. 0) then call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..li7(he3,np)2a if (ili7 .ne. 0 .and. ihe3 .ne. 0) then call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..be7(d,n)2a if (ibe7 .ne. 0 .and. ih2 .ne. 0) then call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..be7(t,np)2a if (ibe7 .ne. 0 .and. ih3 .ne. 0) then call tree(ih3,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih3,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ih3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..be7(he3,2p)2a if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..b11(pa) reactions if (ib11 .ne. 0) then call tree(ib11,ib11,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ib11,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ib11,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ib11,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ib11,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..b8(e + nu) reactions if (ib8 .ne. 0) then call tree(ib8,ib8,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ib8,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..be9(p,d)2 alpha reactions if (ibe9 .ne. 0 .and. ih2 .ne. 0) then call tree(ibe9,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe9,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ip,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ip,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..c11(na) reactions if (ic11 .ne. 0) then call tree(ic11,ic11,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic11,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ic11,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ic11,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,in,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..a(an,g)be9 if (ibe9 .ne. 0) then call tree(ia,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ia,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe9,ia,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe9,in,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe9,ibe9,eloc,neloc,nterms,nzo,iloc,jloc,np) end if 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 jacobian elements 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) call tree(ivelx,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iposx,iposx,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) call tree(ivelx,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iposx,iposx,eloc,neloc,nterms,nzo,iloc,jloc,np) c..self heating at constant density 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) call tree(ivelx,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iposx,iposx,eloc,neloc,nterms,nzo,iloc,jloc,np) c..self heating at constant pressure else if (self_heat_const_pres) 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) do i=1,ionmax call tree(iden,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo call tree(iden,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ivelx,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iposx,iposx,eloc,neloc,nterms,nzo,iloc,jloc,np) c..detonation else if (detonation) then call tree(iposx,iposx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iposx,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) do i=1,ionmax call tree(iden,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo call tree(ivelx,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ivelx,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ivelx,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) do i=1,ionmax call tree(ivelx,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo call tree(itemp,ivelx,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(itemp,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(itemp,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) do i=1,ionmax call tree(itemp,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo c..bbang else if (bbang) then call tree(itemp,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,itemp,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 write(6,*) ' ' write(6,*) nzo,' matrix elements' write(6,*) nterms,' jacobian contributions' write(6,*) ' ' 111 format(1x,4i4) c do i=1,nterms c write(6,111) i,eloc(i) c enddo c do i=1,nzo c write(6,111) i,iloc(i),jloc(i) c enddo c write(6,*) 'done write to 4' c read(5,*) return end subroutine storch(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 jacobain of the odes in the for the torch c..network. c..declare the pass integer nzo double precision tt,y(1),dfdy(1) c..local variables integer in,ip,ia,i,j,k,nt,iat double precision a0,a1,a2,a3,a4,a5,a6,aaa,aap,aan,b1,b2, 2 zbarxx,ytot1,abar,zbar,ye,taud,taut,snuda,snudz double precision enuc,velx,posx,suma,sumz,sum1,sum,sum2, 3 sum5,sum6,sum7,sum8,sum9,sum10,sum11,sum12, 4 cs,denombv,dpde,dpdebd,dpdebt,phi,phibd,phibt, 5 combo,combobv,combobd,combobt,z,zbd,zbt, 6 ww,wwbd,wwbt,dtdp,dtdpbd,dtdpbt, 7 dpdbd,dpdbt,foo(8),moo(8),enucbd,enucbt, 8 csbd,csbt,dptbd,dptbt,detbd,detbt,dpabd,dpabt, 9 dpzbd,dpzbt,deabd,deabt,dezbd,dezbt, & denomdd,denomdt double precision xa,dxadt,wien1,dwien1dx,wien2,dwien2dx, 1 f1,df1,f2,df2,zz,xx,con,dcondt,denom, 2 ddenom,zeta3 parameter (zeta3 = 1.20205690315732d0) double precision conv,oneth,sixth parameter (conv = ev2erg*1.0d6*avo, 1 oneth = 1.0d0/3.0d0, 2 sixth = 1.0d0/6.0d0) c..communicate with the builder integer neloc parameter (neloc=260000) integer eloc(neloc),nterms common /elctch/ eloc,nterms c..zero the jacobian 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 c..from a history file if (trho_hist) call update2(tt,y(itemp),y(iden)) c..for constant pressure 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 torchtab(ye) else call torchrat(ye) end if c..get the weak rates after torchrat call weak_rates(y) c..screening of the rates call screen_torch(y) c..set the pointers and abundances for n,p and alpha reactions in = ineut aan = y(ineut) ip = iprot aap = y(iprot) ia = ihe4 aaa = y(ihe4) c..for every isotope in the network do j=ionbeg,ionend c..set up the (n,g) and (g,n) components k = nrr(1,j) if (k .gt. 0) then a1 = sig(1,j) * aan a2 = sig(2,j) a3 = sig(1,j) * y(j) c..d(j)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(j) c..d(j)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(j) c..d(j)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(in) = xsum(in) - a3 * bion(j) c..d(k)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(k) c..d(k)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(k) = xsum(k) - a2 * bion(k) c..d(k)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(k) c..d(neut)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(in) c..d(neut)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(in) = xsum(in) - a3 * bion(in) end if c..set up the (p,n) (n,p) beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then a1 = sig(3,j) * aap a2 = sig(4,j) * aan a3 = sig(3,j) * y(j) a4 = sig(4,j) * y(k) a5 = sig(5,j) a6 = sig(6,j) c..d(j)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 - a5 xsum(j) = xsum(j) - (a1+a5) * bion(j) c..d(j)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 + a6 xsum(k) = xsum(k) + (a2+a6) * bion(j) c..d(j)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(in) = xsum(in) + a4 * bion(j) c..d(j)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ip) = xsum(ip) - a3 * bion(j) c..d(k)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 + a5 xsum(j) = xsum(j) + (a1+a5) * bion(k) c..d(k)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 - a6 xsum(k) = xsum(k) - (a2+a6) * bion(k) c..d(k)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(in) = xsum(in) - a4 * bion(k) c..d(k)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ip) = xsum(ip) + a3 * bion(k) c..d(neut)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(in) c..d(neut)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(k) = xsum(k) - a2 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(in) = xsum(in) - a4 * bion(in) c..d(neut)/d(ip) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ip) = xsum(ip) + a3 * bion(in) c..d(prot)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(ip) c..d(prot)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(ip) c..d(prot)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(in) = xsum(in) + a4 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ip) = xsum(ip) - a3 * bion(ip) end if c..set up the (p,g) and (g,p) components k = nrr(3,j) if (k .gt. 0) then a1 = sig(7,j) * aap a2 = sig(8,j) a3 = sig(7,j) * y(j) c..d(j)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(j) c..d(j)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(j) c..d(j)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ip) = xsum(ip) - a3 * bion(j) c..d(k)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(k) c..d(k)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(k) = xsum(k) - a2 * bion(k) c..d(k)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ip) = xsum(ip) + a3 * bion(k) c..d(prot)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(ip) c..d(prot)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ip) = xsum(ip) - a3 * bion(ip) end if c..set up the (a,p) and (p,a) components k = nrr(4,j) if (k .gt. 0) then a1 = sig(9,j) * aaa a2 = sig(10,j) * aap a3 = sig(9,j) * y(j) a4 = sig(10,j) * y(k) c..d(j)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(j) c..d(j)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(j) c..d(j)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ip) = xsum(ip) + a4 * bion(j) c..d(j)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(j) c..d(k)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(k) c..d(k)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(k) = xsum(k) - a2 * bion(k) c..d(k)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(ip) = xsum(ip) - a4 * bion(k) c..d(k)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(k) c..d(prot)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(ip) c..d(prot)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(k) = xsum(k) - a2 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(ip) = xsum(ip) - a4 * bion(ip) c..d(prot)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ip) c..d(alfa)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(ia) c..d(alfa)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(k) = xsum(k) + a2 * bion(ia) c..d(alfa)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ip) = xsum(ip) + a4 * bion(ia) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ia) end if c..set up the (a,n) (n,a) components k = nrr(5,j) if (k .gt. 0) then a1 = sig(11,j) * aaa a2 = sig(11,j) * y(j) a3 = sig(12,j) * aan a4 = sig(12,j) * y(k) c..d(j)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(j) c..d(j)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(k) = xsum(k) + a3 * bion(j) c..d(j)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(in) = xsum(in) + a4 * bion(j) c..d(j)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ia) = xsum(ia) - a2 * bion(j) c..d(k)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(k) c..d(k)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(k) = xsum(k) - a3 * bion(k) c..d(k)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(in) = xsum(in) - a4 * bion(k) c..d(k)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(k) c..d(neut)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(in) c..d(neut)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(k) = xsum(k) - a3 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(in) = xsum(in) - a4 * bion(in) c..d(neut)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(in) c..d(alfa)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(ia) c..d(alfa)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(k) = xsum(k) + a3 * bion(ia) c..d(alfa)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(in) = xsum(in) + a4 * bion(ia) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ia) = xsum(ia) - a2 * bion(ia) end if c..and finally the (a,g) (g,a) components k = nrr(6,j) if (k .gt. 0) then a1 = sig(13,j) * aaa a2 = sig(13,j) * y(j) a3 = sig(14,j) c..d(j)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(j) c..d(j)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(k) = xsum(k) + a3 * bion(j) c..d(j)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ia) = xsum(ia) - a2 * bion(j) c..d(k)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(j) = xsum(j) + a1 * bion(k) c..d(k)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(k) = xsum(k) - a3 * bion(k) c..d(k)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(k) c..d(alfa)/d(j) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(j) = xsum(j) - a1 * bion(ia) c..d(alfa)/d(k) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(k) = xsum(k) + a3 * bion(ia) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ia) = xsum(ia) - a2 * bion(ia) end if enddo c..now the special matrix elements c..for p(e-,nu)n and n(e+,nub)p reactions c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - ratdum(irpen) xsum(ip) = xsum(ip) - ratdum(irpen) * bion(ip) c..d(prot)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + ratdum(irnep) xsum(in) = xsum(in) + ratdum(irnep) * bion(ip) c..d(neut)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + ratdum(irpen) xsum(ip) = xsum(ip) + ratdum(irpen) * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - ratdum(irnep) xsum(in) = xsum(in) - ratdum(irnep) * bion(in) c..triple alpha reactions if (ic12 .ne. 0) then a1 = -1.5d0*aaa*aaa*ratdum(ir3a) a2 = 3.0*ratdum(irg3a) a3 =-ratdum(irg3a) a4 = 0.5d0*aaa*aaa*ratdum(ir3a) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ia) c..d(alfa)/d(c12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ic12) = xsum(ic12) + a2 * bion(ia) c..d(c12)/d(c12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ic12) = xsum(ic12) + a3 * bion(ic12) c..d(c12)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ia) = xsum(ia) + a4 * bion(ic12) end if c..c12+c12 reactions must have ne20 na23 mg24 if (ic12 .ne. 0 .and. ine20 .ne. 0 .and. 1 ina23 .ne. 0 .and. img23 .ne. 0) then c..d(c12)/d(c12) a1 = -2.0d0*y(ic12)* 1 (ratdum(ir1212n) + ratdum(ir1212p) + ratdum(ir1212a)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ic12) c..d(c12)/d(ne20) a1 = ratdum(irne20ac)*aaa nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(ic12) c..d(c12)/d(na23) a1 = ratdum(irna23pc)*aap nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ina23) = xsum(ina23) + a1 * bion(ic12) c..d(c12)/d(mg23) a1 = ratdum(irmg23nc)*aan nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img23) = xsum(img23) + a1 * bion(ic12) c..d(c12)/d(alfa) a1 = ratdum(irne20ac)*y(ine20) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ic12) c..d(c12)/d(prot) a1 = ratdum(irna23pc)*y(ina23) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ic12) c..d(c12)/d(neut) a1 = ratdum(irmg23nc)*y(img23) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(ic12) c..d(ne20)/d(ne20) a1 = -0.5d0*ratdum(irne20ac)*aaa nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(ine20) c..d(ne20)/d(c12) a1 = ratdum(ir1212a)*y(ic12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ine20) c..d(ne20)/d(alfa) a1 = -0.5d0*ratdum(irne20ac)*y(ine20) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ine20) c..d(alfa)/d(alfa) a1 = -0.5d0*ratdum(irne20ac)*y(ine20) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ia) c..d(alfa)/d(c12) a1 = ratdum(ir1212a)*y(ic12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ia) c..d(alfa)/d(ne20) a1 = -0.5d0*ratdum(irne20ac)*aaa nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(ia) c..d(na23)/d(na23) a1 = -0.5d0*ratdum(irna23pc)*aap nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ina23) = xsum(ina23) + a1 * bion(ina23) c..d(na23)/d(c12) a1 = ratdum(ir1212p)*y(ic12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ina23) c..d(na23)/d(prot) a1 = -0.5d0*ratdum(irna23pc)*y(ina23) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ina23) c..d(prot)/d(prot) a1 = -0.5d0*ratdum(irna23pc)*y(ina23) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ip) c..d(prot)/d(c12) a1 = ratdum(ir1212p)*y(ic12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ip) c..d(prot)/d(na23) a1 = -0.5d0*ratdum(irna23pc)*aap nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ina23) = xsum(ina23) + a1 * bion(ip) c..d(mg23)/d(mg23) a1 = -0.5d0*ratdum(irmg23nc)*aan nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img23) = xsum(img23) + a1 * bion(img23) c..d(mg23)/d(c12) a1 = ratdum(ir1212n)*y(ic12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(img23) c..d(mg23)/d(neut) a1 = -0.5d0*ratdum(irmg23nc)*y(img23) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(img23) c..d(neut)/d(neut) a1 = -0.5d0*ratdum(irmg23nc)*y(img23) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(in) c..d(neut)/d(c12) a1 = ratdum(ir1212n)*y(ic12) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(in) c..d(neut)/d(mg23) a1 = -0.5d0*ratdum(irmg23nc)*aan nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img23) = xsum(img23) + a1 * bion(in) end if c..o16+o16 reactions if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then c..d(o16)/d(o16) a1 = -2.0d0*y(io16)*(ratdum(ir1616n) + ratdum(ir1616p) + 1 ratdum(ir1616a) + ratdum(ir1616d)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(io16) c..d(o16)/d(si28) a1 = ratdum(irsi28ao)*aaa nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(io16) c..d(o16)/d(p31) a1 = ratdum(irp31po)*aap nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip31) = xsum(ip31) + a1 * bion(io16) c..d(o16)/d(s31) a1 = ratdum(irs31no)*aan nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is31) = xsum(is31) + a1 * bion(io16) c..d(o16)/d(alfa) a1 = ratdum(irsi28ao)*y(isi28) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(io16) c..d(o16)/d(prot) a1 = ratdum(irp31po)*y(ip31) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(io16) c..d(o16)/d(neut) a1 = ratdum(irs31no)*y(is31) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(io16) c..d(si28)/d(o16) a1 = ratdum(ir1616a)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(isi28) c..d(si28)/d(si28) a1 = -0.5d0*ratdum(irsi28ao)*aaa nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(isi28) c..d(si28)/d(alfa) a1 = -0.5d0*ratdum(irsi28ao)*y(isi28) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(isi28) c..d(alfa)/d(o16) a1 = ratdum(ir1616a)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ia) c..d(alfa)/d(si28) a1 = -0.5d0*ratdum(irsi28ao)*aaa nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(ia) c..d(alfa)/d(alfa) a1 = -0.5d0*ratdum(irsi28ao)*y(isi28) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ia) c..d(p31)/d(o16) a1 = ratdum(ir1616p)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ip31) c..d(p31)/d(p31) a1 = -0.5d0*ratdum(irp31po)*aap nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip31) = xsum(ip31) + a1 * bion(ip31) c..d(p31)/d(prot) a1 = -0.5d0*ratdum(irp31po)*y(ip31) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ip31) c..d(prot)/d(o16) a1 = ratdum(ir1616p)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ip) c..d(prot)/d(p31) a1 = -0.5d0*ratdum(irp31po)*aap nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip31) = xsum(ip31) + a1 * bion(ip) c..d(prot)/d(prot) a1 = -0.5d0*ratdum(irp31po)*y(ip31) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ip) c..d(s31)/d(o16) a1 = ratdum(ir1616n)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(is31) c..d(s31)/d(s31) a1 = -0.5d0*ratdum(irs31no)*aan nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is31) = xsum(is31) + a1 * bion(is31) c..d(s31)/d(neut) a1 = -0.5d0*ratdum(irs31no)*y(is31) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(is31) c..d(neut)/d(o16) a1 = ratdum(ir1616n)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(in) c..d(neut)/d(s31) a1 = -0.5d0*ratdum(irs31no)*aan nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is31) = xsum(is31) + a1 * bion(in) c..d(neut)/d(neut) a1 = -0.5d0*ratdum(irs31no)*y(is31) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(in) c..d(p30)/d(o16) a1 = ratdum(ir1616d)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ip30) c..d(neut)/d(o16) a1 = ratdum(ir1616d)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(in) c..d(prot)/d(o16) a1 = ratdum(ir1616d)*y(io16) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ip) end if c..c12+o16 reactions if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then c..d(c12)/d(c12) a1 = -y(io16)*(ratdum(ir1216n) + ratdum(ir1216p) 1 + ratdum(ir1216a)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ic12) c..d(c12)/d(o16) a1 = -y(ic12)*(ratdum(ir1216n) + ratdum(ir1216p) 1 + ratdum(ir1216a)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ic12) c..d(c12)/d(si27) a1 = aan*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi27) = xsum(isi27) + a1 * bion(ic12) c..d(c12)/d(al27) a1 = aap*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ial27) = xsum(ial27) + a1 * bion(ic12) c..d(c12)/d(mg24) a1 = aaa*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(ic12) c..d(c12)/d(neut) a1 = y(isi27)*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(ic12) c..d(c12)/d(prot) a1 = y(ial27)*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ic12) c..d(c12)/d(alfa) a1 = y(img24)*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ic12) c..d(o16)/d(c12) a1 = -y(io16)*(ratdum(ir1216n) + ratdum(ir1216p) 1 + ratdum(ir1216a)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(io16) c..d(o16)/d(o16) a1 = -y(ic12)*(ratdum(ir1216n) + ratdum(ir1216p) 1 + ratdum(ir1216a)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(io16) c..d(o16)/d(si27) a1 = aan*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi27) = xsum(isi27) + a1 * bion(io16) c..d(o16)/d(al27) a1 = aap*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ial27) = xsum(ial27) + a1 * bion(io16) c..d(o16)/d(mg24) a1 = aaa*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(io16) c..d(o16)/d(neut) a1 = y(isi27)*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(io16) c..d(o16)/d(prot) a1 = y(ial27)*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(io16) c..d(o16)/d(alfa) a1 = y(img24)*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(io16) c..d(si27)/d(c12) a1 = y(io16)*ratdum(ir1216n) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(isi27) c..d(si27)/d(o16) a1 = y(ic12)*ratdum(ir1216n) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(isi27) c..d(si27)/d(si27) a1 = -aan*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi27) = xsum(isi27) + a1 * bion(isi27) c..d(si27)/d(neut) a1 = -y(isi27)*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(isi27) c..d(al27)/d(c12) a1 = y(io16)*ratdum(ir1216p) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ial27) c..d(al27)/d(o16) a1 = y(ic12)*ratdum(ir1216p) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ial27) c..d(al27)/d(al27) a1 = -aap*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ial27) = xsum(ial27) + a1 * bion(ial27) c..d(al27)/d(prot) a1 = -y(ial27)*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ial27) c..d(mg24)/d(c12) a1 = y(io16)*ratdum(ir1216a) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(img24) c..d(mg24)/d(o16) a1 = y(ic12)*ratdum(ir1216a) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(img24) c..d(mg24)/d(mg24) a1 = -aaa*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(img24) c..d(mg24)/d(alfa) a1 = -y(img24)*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(img24) c..d(neut)/d(c12) a1 = y(io16)*ratdum(ir1216n) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(in) c..d(neut)/d(o16) a1 = y(ic12)*ratdum(ir1216n) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(in) c..d(neut)/d(si27) a1 = -aan*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi27) = xsum(isi27) + a1 * bion(in) c..d(neut)/d(neut) a1 = -y(isi27)*ratdum(irsi27no) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(in) c..d(prot)/d(c12) a1 = y(io16)*ratdum(ir1216p) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ip) c..d(prot)/d(o16) a1 = y(ic12)*ratdum(ir1216p) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ip) c..d(prot)/d(al27) a1 = -aap*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ial27) = xsum(ial27) + a1 * bion(ip) c..d(prot)/d(prot) a1 = -y(ial27)*ratdum(iral27po) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ip) c..d(alfa)/d(c12) a1 = y(io16)*ratdum(ir1216a) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ia) c..d(alfa)/d(o16) a1 = y(ic12)*ratdum(ir1216a) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ia) c..d(alfa)/d(mg24) a1 = -aaa*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(ia) c..d(alfa)/d(alfa) a1 = -y(img24)*ratdum(irmg24ao) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ia) end if c..if we have deuterium if (ih2 .ne. 0) then c..d(h2)/d(prot) a1 = aap*(ratdum(irpp) + ratdum(irpep)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ih2) c..d(prot)/d(prot) a1 = -2.0d0*aap*(ratdum(irpp) + ratdum(irpep)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ip) a1 = ratdum(irpng)*aan a2 = ratdum(irdgn) a3 = ratdum(irpng)*aap c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ih2) = xsum(ih2) - a2 * bion(ih2) c..d(h2)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(ih2) c..d(h2)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ih2) c..d(neut)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih2) = xsum(ih2) + a2 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(in) = xsum(in) - a3 * bion(in) c..d(neut)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ip) = xsum(ip) - a1 * bion(in) c..d(prot)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih2) = xsum(ih2) + a2 * bion(ip) c..d(prot)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(in) = xsum(in) - a3 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ip) = xsum(ip) - a1 * bion(ip) c..d(p,n)2p a1 = 0.5d0*aap*ratdum(ir2pnp) a2 = y(ih2)*ratdum(irdpn) - 0.5d0*aan*ratdum(ir2pnp) a3 = aap*ratdum(irdpn) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ih2) = xsum(ih2) - a3 * bion(ih2) c..d(h2)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(ih2) c..d(h2)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ip) = xsum(ip) - a2 * bion(ih2) c..d(neut)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ih2) = xsum(ih2) + a3 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(in) = xsum(in) - a1 * bion(in) c..d(neut)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(in) c..d(prot)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ih2) = xsum(ih2) + a3 * bion(ip) c..d(prot)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(in) = xsum(in) - a1 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ip) c..d(d,g)he4 a1 = -2.0d0*y(ih2)*ratdum(irddg) a2 = 2.0d0*ratdum(irhe4gd) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ih2) c..d(h2)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(ih2) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 0.5d0 * a1 xsum(ih2) = xsum(ih2) - 0.5d0 * a1 * bion(ia) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 0.5d0 * a2 xsum(ia) = xsum(ia) - 0.5d0 * a2 * bion(ia) end if c..if we have deutrium and tritium if (ih2 .ne. 0 .and. ih3 .ne. 0) then c..d(t,n)he4, dt reaction a1 = y(ih3)*ratdum(irtdn) a2 = y(ih2)*ratdum(irtdn) a3 = -aan*ratdum(irhe4nd) a4 = -aaa*ratdum(irhe4nd) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ih2) c..d(h2)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ih3) = xsum(ih3) - a2 * bion(ih2) c..d(h2)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ih2) c..d(h2)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(in) = xsum(in) - a4 * bion(ih2) c..d(h3)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ih3) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ih3) = xsum(ih3) - a2 * bion(ih3) c..d(h3)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ih3) c..d(h3)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(in) = xsum(in) - a4 * bion(ih3) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ia) c..d(he4)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih3) = xsum(ih3) + a2 * bion(ia) c..d(he4)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ia) c..d(he4)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(in) = xsum(in) + a4 * bion(ia) c..d(neut)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(in) c..d(neut)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih3) = xsum(ih3) + a2 * bion(in) c..d(neut)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(in) = xsum(in) + a4 * bion(in) c..d(d,p)t a1 = y(ih2)*ratdum(irddp) a2 = -aap*ratdum(irtpd) a3 = -y(ih3)*ratdum(irtpd) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a1 xsum(ih2) = xsum(ih2) - 2.0d0 * a1 * bion(ih2) c..d(h2)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a2 xsum(ih3) = xsum(ih3) - 2.0d0 * a2 * bion(ih2) c..d(h2)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a3 xsum(iprot) = xsum(iprot) - 2.0d0 * a3 * bion(ih2) c..d(h3)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ih3) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih3) = xsum(ih3) + a2 * bion(ih3) c..d(h3)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(iprot) = xsum(iprot) + a3 * bion(ih3) c..d(prot)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(iprot) c..d(prot)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih3) = xsum(ih3) + a2 * bion(iprot) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(iprot) = xsum(iprot) + a3 * bion(iprot) end if c..if we have tritium if (ih3 .ne. 0) then c..t(p,g)he4 a1 = ratdum(irh3pg)*aap a2 = ratdum(irhe4gp) a3 = ratdum(irh3pg)*y(ih3) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ih3) c..d(h3)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(ih3) c..d(h3)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ip) = xsum(ip) - a3 * bion(ih3) c..d(alfa)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(ia) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ia) = xsum(ia) - a2 * bion(ia) c..d(alfa)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ip) = xsum(ip) + a3 * bion(ia) c..d(prot)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ip) c..d(prot)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ip) = xsum(ip) - a3 * bion(ip) c..t(t,2n)he4 a1 = 2.0d0*y(ih3)*ratdum(irtt2n) a2 = -aaa*ratdum(irhe42nt) a3 = -aan*ratdum(irhe42nt) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ih3) c..d(h3)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(in) = xsum(in) - a2 * bion(ih3) c..d(h3)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ih3) c..d(neut)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(in) = xsum(in) + a2 * bion(in) c..d(neut)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(in) c..d(he4)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 0.5d0 * a1 xsum(ih3) = xsum(ih3) + 0.5d0 * a1 * bion(ia) c..d(he4)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 0.5d0 * a2 xsum(in) = xsum(in) + 0.5d0 * a2 * bion(ia) c..d(he4)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 0.5d0 * a3 xsum(ia) = xsum(ia) + 0.5d0 * a3 * bion(ia) end if c..if we have he3 if (ihe3 .ne. 0) then c..he3(he3,2p)he4 a1 = 2.0d0*y(ihe3)*ratdum(ir33) a2 = -aaa*ratdum(ir33inv) a3 = -aap*ratdum(ir33inv) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(ihe3) c..d(he3)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ip) = xsum(ip) - a2 * bion(ihe3) c..d(he3)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ihe3) c..d(prot)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ip) c..d(prot)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ip) c..d(he4)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 0.5d0 * a1 xsum(ihe3) = xsum(ihe3) + 0.5d0 * a1 * bion(ia) c..d(he4)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 0.5d0 * a2 xsum(ip) = xsum(ip) + 0.5d0 * a2 * bion(ia) c..d(he4)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 0.5d0 * a3 xsum(ia) = xsum(ia) + 0.5d0 * a3 * bion(ia) c..he3(p,e+nu)he4 a1 = y(ihe3)*ratdum(irhep) a2 = aap*ratdum(irhep) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ihe3) = xsum(ihe3) - a2 * bion(ihe3) c..d(he3)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ip) = xsum(ip) - a1 * bion(ihe3) c..d(prot)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ip) c..d(he4)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ia) c..d(he4)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ip) = xsum(ip) + a1 * bion(ia) c..he3(n,g)he4 a1 = ratdum(irhe3ng)*aan a2 = ratdum(irhe4gn) a3 = ratdum(irhe3ng)*y(ihe3) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(ihe3) c..d(he3)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(ihe3) c..d(he3)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(in) = xsum(in) - a3 * bion(ihe3) c..d(alfa)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ia) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ia) = xsum(ia) - a2 * bion(ia) c..d(alfa)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(ia) c..d(neut)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(in) c..d(neut)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ia) = xsum(ia) + a2 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(in) = xsum(in) - a3 * bion(in) end if c..if we have deuterium and he3 if (ih2 .ne. 0 .and. ihe3 .ne. 0) then c..he3(d,p)he4 a1 = y(ihe3)*ratdum(irhe3dp) a2 = y(ih2)*ratdum(irhe3dp) a3 = -aap*ratdum(irhe4pd) a4 = -aaa*ratdum(irhe4pd) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ih2) c..d(h2)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ihe3) = xsum(ihe3) - a2 * bion(ih2) c..d(h2)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ih2) c..d(h2)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(ip) = xsum(ip) - a4 * bion(ih2) c..d(he3)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ihe3) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ihe3) = xsum(ihe3) - a2 * bion(ihe3) c..d(he3)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ia) = xsum(ia) - a3 * bion(ihe3) c..d(he3)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(ip) = xsum(ip) - a4 * bion(ihe3) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ihe4) c..d(he4)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ihe4) c..d(he4)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ihe4) c..d(he4)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ip) = xsum(ip) + a4 * bion(ihe4) c..d(prot)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ip) c..d(prot)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ip) c..d(prot)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ip) = xsum(ip) + a4 * bion(ip) c..d(d,n)he3 a1 = y(ih2)*ratdum(irddn) a2 = -aan*ratdum(irhe3nd) a3 = -y(ihe3)*ratdum(irhe3nd) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a1 xsum(ih2) = xsum(ih2) - 2.0d0 * a1 * bion(ih2) c..d(h2)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a2 xsum(ihe3) = xsum(ihe3) - 2.0d0 * a2 * bion(ih2) c..d(h2)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a3 xsum(in) = xsum(in) - 2.0d0 * a3 * bion(ih2) c..d(he3)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ihe3) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ihe3) c..d(he3)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(ihe3) c..d(neut)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(in) c..d(neut)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(in) c..d(neut)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(in) end if c..if we have deuterium, tritium, and he3 if (ihe3.ne.0 .and. ih3 .ne. 0 .and. ih2 .ne. 0) then c..he3(t,d)he4 a1 = -aaa*ratdum(irhe4dt) a2 = y(ihe3)*ratdum(irhe3td) a3 = y(ih3)*ratdum(irhe3td) a4 = -y(ih2)*ratdum(irhe4dt) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ih2) c..d(h2)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih3) = xsum(ih3) + a2 * bion(ih2) c..d(h2)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ihe3) = xsum(ihe3) + a3 * bion(ih2) c..d(h2)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ia) = xsum(ia) + a4 * bion(ih2) c..d(h3)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ih3) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ih3) = xsum(ih3) - a2 * bion(ih3) c..d(h3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ihe3) = xsum(ihe3) - a3 * bion(ih3) c..d(h3)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(ia) = xsum(ia) - a4 * bion(ih3) c..d(he3)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ihe3) c..d(he3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ih3) = xsum(ih3) - a2 * bion(ihe3) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a3 xsum(ihe3) = xsum(ihe3) - a3 * bion(ihe3) c..d(he3)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a4 xsum(ia) = xsum(ia) - a4 * bion(ihe3) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ia) c..d(he4)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ih3) = xsum(ih3) + a2 * bion(ia) c..d(he4)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ihe3) = xsum(ihe3) + a3 * bion(ia) c..d(he4)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 xsum(ia) = xsum(ia) + a4 * bion(ia) end if c..if we have tritium and he3 if (ihe3 .ne. 0 .and. ih3 .ne. 0) then c..he3(t,np)he4 a1 = y(ihe3)*ratdum(irhe3tnp) a2 = y(ih3)*ratdum(irhe3tnp) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ih3) c..d(h3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ihe3) = xsum(ihe3) - a2 * bion(ih3) c..d(he3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ihe3) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ihe3) = xsum(ihe3) - a2 * bion(ihe3) c..d(alfa)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(ia) c..d(alfa)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ia) c..d(prot)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(ip) c..d(prot)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(ip) c..d(neut)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(in) c..d(neut)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ihe3) = xsum(ihe3) + a2 * bion(in) end if c..li7(p,g)be8=>2a + li7(p,a)a reactions if (ili7 .ne. 0) then a1 = -aap*ratdum(irli7pag) a2 = -y(ili7)*ratdum(irli7pag) a3 = aaa*ratdum(ir2he4ga) c..d(li7)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ili7) = xsum(ili7) + a1 * bion(ili7) c..d(li7)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ili7) c..d(li7)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ili7) c..d(prot)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ili7) = xsum(ili7) + a1 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ip) c..d(prot)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ip) c..d(alfa)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a1 xsum(ili7) = xsum(ili7) - 2.0d0 * a1 * bion(ia) c..d(alfa)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a2 xsum(ip) = xsum(ip) - 2.0d0 * a2 * bion(ia) c..d(alfa)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 2.0d0 * a3 xsum(ia) = xsum(ia) - 2.0d0 * a3 * bion(ia) end if c..li7(d,n)2a if (ili7 .ne. 0 .and. ih2 .ne. 0) then a1 = y(ili7)*ratdum(irli7dn) a2 = y(ih2)*ratdum(irli7dn) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ih2) c..d(h2)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ili7) = xsum(ili7) - a2 * bion(ih2) c..d(li7)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ili7) c..d(li7)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ili7) = xsum(ili7) - a2 * bion(ili7) c..d(neut)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(in) c..d(neut)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ili7) = xsum(ili7) + a2 * bion(in) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ih2) = xsum(ih2) + 2.0d0 * a1 * bion(ia) c..d(he4)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ili7) = xsum(ili7) + 2.0d0 * a2 * bion(ia) end if c..li7(t,2n)2a if (ili7 .ne. 0 .and. ih3 .ne. 0) then a1 = y(ili7)*ratdum(irli7t2n) a2 = y(ih3)*ratdum(irli7t2n) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ih3) c..d(h3)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ili7) = xsum(ili7) - a2 * bion(ih3) c..d(li7)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ili7) c..d(li7)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ili7) = xsum(ili7) - a2 * bion(ili7) c..d(neut)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ih3) = xsum(ih3) + 2.0d0 * a1 * bion(in) c..d(neut)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ili7) = xsum(ili7) + 2.0d0 * a2 * bion(in) c..d(he4)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ih3) = xsum(ih3) + 2.0d0 * a1 * bion(ia) c..d(he4)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ili7) = xsum(ili7) + 2.0d0 * a2 * bion(ia) end if c..li7(he3,np)2a if (ili7 .ne. 0 .and. ihe3 .ne. 0) then a1 = y(ili7)*ratdum(irli7he3np) a2 = y(ihe3)*ratdum(irli7he3np) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(ihe3) c..d(he3)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ili7) = xsum(ili7) - a2 * bion(ihe3) c..d(li7)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(ili7) c..d(li7)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ili7) = xsum(ili7) - a2 * bion(ili7) c..d(neut)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(in) c..d(neut)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ili7) = xsum(ili7) + a2 * bion(in) c..d(prot)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ip) c..d(prot)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ili7) = xsum(ili7) + a2 * bion(ip) c..d(he4)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ihe3) = xsum(ihe3) + 2.0d0 * a1 * bion(ia) c..d(he4)/d(li7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ili7) = xsum(ili7) + 2.0d0 * a2 * bion(ia) end if c..be7(d,p)2a if (ibe7 .ne. 0 .and. ih2 .ne. 0) then a1 = y(ibe7)*ratdum(irbe7dp) a2 = y(ih2)*ratdum(irbe7dp) c..d(h2)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ih2) c..d(h2)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ibe7) = xsum(ibe7) - a2 * bion(ih2) c..d(be7)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih2) = xsum(ih2) - a1 * bion(ibe7) c..d(be7)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ibe7) = xsum(ibe7) - a2 * bion(ibe7) c..d(prot)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ip) c..d(prot)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ibe7) = xsum(ibe7) + a2 * bion(ip) c..d(he4)/d(h2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ih2) = xsum(ih2) + 2.0d0 * a1 * bion(ia) c..d(he4)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ibe7) = xsum(ibe7) + 2.0d0 * a2 * bion(ia) end if c..be7(t,np)2a if (ibe7 .ne. 0 .and. ih3 .ne. 0) then a1 = y(ibe7)*ratdum(irbe7tnp) a2 = y(ih3)*ratdum(irbe7tnp) c..d(h3)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ih3) c..d(h3)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ibe7) = xsum(ibe7) - a2 * bion(ih3) c..d(be7)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ih3) = xsum(ih3) - a1 * bion(ibe7) c..d(be7)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ibe7) = xsum(ibe7) - a2 * bion(ibe7) c..d(prot)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(ip) c..d(prot)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ibe7) = xsum(ibe7) + a2 * bion(ip) c..d(neut)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih3) = xsum(ih3) + a1 * bion(in) c..d(neut)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ibe7) = xsum(ibe7) + a2 * bion(in) c..d(he4)/d(h3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ih3) = xsum(ih3) + 2.0d0 * a1 * bion(ia) c..d(he4)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ibe7) = xsum(ibe7) + 2.0d0 * a2 * bion(ia) end if c..be7(he3,2p)2a if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then a1 = y(ibe7)*ratdum(irbe7he32p) a2 = y(ihe3)*ratdum(irbe7he32p) c..d(he3)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(ihe3) c..d(he3)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ibe7) = xsum(ibe7) - a2 * bion(ihe3) c..d(be7)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ihe3) = xsum(ihe3) - a1 * bion(ibe7) c..d(be7)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ibe7) = xsum(ibe7) - a2 * bion(ibe7) c..d(prot)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ihe3) = xsum(ihe3) + 2.0d0 * a1 * bion(ip) c..d(prot)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ibe7) = xsum(ibe7) + 2.0d0 * a2 * bion(ip) c..d(he4)/d(he3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a1 xsum(ihe3) = xsum(ihe3) + 2.0d0 * a1 * bion(ia) c..d(he4)/d(be7) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0 * a2 xsum(ibe7) = xsum(ibe7) + 2.0d0 * a2 * bion(ia) end if c..b11(p,a)be8 => 2a reactions if (ib11 .ne. 0) then a1 = -aap*ratdum(irb11pa) a2 = -y(ib11)*ratdum(irb11pa) a3 = 2.0d0*aaa*ratdum(ir3ap)/3.0d0 c..d(b11)/d(b11) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib11) = xsum(ib11) + a1 * bion(ib11) c..d(b11)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ib11) c..d(b11)/d(he4) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ib11) c..d(prot)/d(b11) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib11) = xsum(ib11) + a1 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ip) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ip) c..d(alfa)/d(b11) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 3.0d0 * a1 xsum(ib11) = xsum(ib11) - 3.0d0 * a1 * bion(ia) c..d(alfa)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 3.0d0 * a2 xsum(ip) = xsum(ip) - 3.0d0 * a2 * bion(ia) c..d(alfa)/d(lafa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - 3.0d0 * a3 xsum(ia) = xsum(ia) - 3.0d0 * a3 * bion(ia) end if c..b8(p=>n)be8 =>2a reactions if (ib8 .ne. 0) then c..d(b8)/d(b8) a1 = -ratdum(irb8ep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib8) = xsum(ib8) + a1 * bion(ib8) c..d(alfa)/d(b8) a1 = 2.0d0*ratdum(irb8ep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib8) = xsum(ib8) + a1 * bion(ia) end if c..be9(p,d)be8 =>2a if (ibe9 .ne. 0 .and. ih2 .ne. 0) then a1 = aap*ratdum(irbe9pd) a2 = y(ibe9)*ratdum(irbe9pd) c..d(be9)/d(be9) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ibe9) = xsum(ibe9) - a1 * bion(ibe9) c..d(be9)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ip) = xsum(ip) - a2 * bion(ibe9) c..d(prot)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a2 xsum(ip) = xsum(ip) - a2 * bion(ip) c..d(prot)/d(be9) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) - a1 xsum(ibe9) = xsum(ibe9) - a1 * bion(ip) c..d(h2)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(ip) = xsum(ip) + a2 * bion(ih2) c..d(h2)/d(be9) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ibe9) = xsum(ibe9) + a1 * bion(ih2) c..d(alfa)/d(prot) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0*a2 xsum(ip) = xsum(ip) + 2.0d0*a2 * bion(ia) c..d(alfa)/d(be9) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + 2.0d0*a1 xsum(ibe9) = xsum(ibe9) + 2.0d0*a1 * bion(ia) end if c..c11(na)be8 => 2a if (ic11 .ne. 0) then c..d(c11)/d(c11) a1 = -aan*ratdum(irc11na) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic11) = xsum(ic11) + a1 * bion(ic11) c..d(c11)/d(neut) a1 = -y(ic11)*ratdum(irc11na) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(ic11) c..d(neut)/d(c11) a1 = -aan*ratdum(irc11na) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic11) = xsum(ic11) + a1 * bion(in) c..d(neut)/d(neut) a1 = -y(ic11)*ratdum(irc11na) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(in) c..d(alfa)/d(c11) a1 = 3.*aan*ratdum(irc11na) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic11) = xsum(ic11) + a1 * bion(ia) c..d(alfa)/d(neut) a1 = 3.*y(ic11)*ratdum(irc11na) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in) = xsum(in) + a1 * bion(ia) end if c..a(an,g)be9 if (ibe9 .ne. 0) then a1 = aaa * aan * ratdum(iraan) a2 = 0.5d0*aaa * aaa * ratdum(iraan) c..d(alfa)/d(alfa) a3 = -2.0d0 * a1 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(ia) c..d(alfa)/d(neut) a3 = -2.0d0 * a2 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(ia) c..d(alfa)/d(be9) a3 = 2.0d0 * ratdum(irgaan) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ibe9) = xsum(ibe9) + a3 * bion(ia) c..d(neut)/d(alfa) a3 = -a1 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ia) = xsum(ia) + a3 * bion(in) c..d(neut)/d(neut) a3 = -a2 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(in) = xsum(in) + a3 * bion(in) c..d(neut)/d(be9) a3 = ratdum(irgaan) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ibe9) = xsum(ibe9) + a3 * bion(in) c..d(be9)/d(alfa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ia) = xsum(ia) + a1 * bion(ibe9) c..d(be9)/d(neut) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a2 xsum(in) = xsum(in) + a2 * bion(ibe9) c..d(be9)/d(be9) a3 = -ratdum(irgaan) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a3 xsum(ibe9) = xsum(ibe9) + a3 * bion(ibe9) end if c..if we are doing a pure network, we are done, head to the error check if (pure_network .eq. 1) goto 678 c..append the temperature derivatives of the rate equations c..d(yi)/dtemp call rhs(y,sigdt,dratdumdt,zwork1) 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 c..d(yi)/d(den) call rhs(y,sigdd,dratdumdd,zwork2) do i=1,ionmax nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + zwork2(i) enddo c..energy jacobian elements 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 if (bbang) then sneut = 0.0d0 dsneutdt = 0.0d0 dsneutdd = 0.0d0 snuda = 0.0d0 snudz = 0.0d0 else call sneut5(btemp,bden,abar,zbar, 1 sneut,dsneutdt,dsneutdd,snuda,snudz) end if 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 jacobian elements 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..d(ivelx)/d(ivelx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iposx)/d(iposx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..adiabatic expansion else if (expansion) then c taud = 446.0d0/sqrt(bden) c taud = 446.0d0/sqrt(den0) c taut = 3.0d0 * taud c..d(itemp)/d(itemp) c a1 = -psi/taut c nt = nt + 1 c iat = eloc(nt) c dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(iden) c a1 = -psi/taud c nt = nt + 1 c iat = eloc(nt) c dfdy(iat) = dfdy(iat) + a1 c..d(ivelx)/d(ivelx) c a1 = 0.0d0 c nt = nt + 1 c iat = eloc(nt) c dfdy(iat) = dfdy(iat) + a1 c..d(iposx)/d(iposx) c a1 = 0.0d0 c nt = nt + 1 c iat = eloc(nt) c dfdy(iat) = dfdy(iat) + a1 c..power law fit to 2d simulations 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..d(ivelx)/d(ivelx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iposx)/d(iposx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..self heating at constant density 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..d(ivelx)/d(ivelx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iposx)/d(iposx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..self heating at constant pressure else if (self_heat_const_pres) then c..call an eos c temp_row(1) = btemp c den_row(1) = bden c abar_row(1) = abar c zbar_row(1) = zbar c jlo_eos = 1 c jhi_eos = 1 c call helmeos c..temperature jacobian elements c..d(itemp)/d(yi) zz = 1.0d0/cp_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..density jacobian elements c.. dydt(iden) = 0.0d0 c.. dydt(iden) = -dpt_row(1)/dpd_row(1) * dydt(itemp) c..d(iden)/d(yi) zz = 0.0d0 c zz = -dpt_row(1)/(dpd_row(1) * cp_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(iden)/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(iden)/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(ivelx)/d(ivelx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iposx)/d(iposx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..detonation else if (detonation) then c..get the right hand sides call rhs(y,sig,ratdum,zwork1) c..instantaneous energy generation rate enuc = 0.0d0 do i=1,ionmax enuc = enuc + zwork1(i) * bion(i) enddo enuc = enuc * conv zwork1(iener) = enuc - sneut c..map the rest of the input vector velx = y(ivelx) posx = y(iposx) c..it appears as if we need the derivatives of derivative based c..eos quantities. grrr. z = bden xx = 0.01d0*z bden = z + xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos foo(1) = cs_row(1) foo(2) = dpt_row(1) foo(3) = dpt_row(1)/det_row(1) foo(4) = dpd_row(1) foo(5) = dpa_row(1) foo(6) = dpz_row(1) foo(7) = dea_row(1) foo(8) = dez_row(1) bden = z - xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos moo(1) = cs_row(1) moo(2) = dpt_row(1) moo(3) = dpt_row(1)/det_row(1) moo(4) = dpd_row(1) moo(5) = dpa_row(1) moo(6) = dpz_row(1) moo(7) = dea_row(1) moo(8) = dez_row(1) bden = z z = 0.5d0/xx csbd = (foo(1) - moo(1))*z dptbd = (foo(2) - moo(2))*z dpdebd = (foo(3) - moo(3))*z dpdbd = (foo(4) - moo(4))*z dpabd = (foo(5) - moo(5))*z dpzbd = (foo(6) - moo(6))*z deabd = (foo(7) - moo(7))*z dezbd = (foo(8) - moo(8))*z z = btemp xx = 0.01d0*z btemp = z + xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos foo(1) = cs_row(1) foo(2) = dpt_row(1) foo(3) = dpt_row(1)/det_row(1) foo(4) = dpd_row(1) foo(5) = dpa_row(1) foo(6) = dpz_row(1) foo(7) = dea_row(1) foo(8) = dez_row(1) btemp = z - xx temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos moo(1) = cs_row(1) moo(2) = dpt_row(1) moo(3) = dpt_row(1)/det_row(1) moo(4) = dpd_row(1) moo(5) = dpa_row(1) moo(6) = dpz_row(1) moo(7) = dea_row(1) moo(8) = dez_row(1) btemp = z z = 0.5d0/xx csbt = (foo(1) - moo(1))*z dptbt = (foo(2) - moo(2))*z dpdebt = (foo(3) - moo(3))*z dpdbt = (foo(4) - moo(4))*z dpabt = (foo(5) - moo(5))*z dpzbt = (foo(6) - moo(6))*z deabt = (foo(7) - moo(7))*z dezbt = (foo(8) - moo(8))*z 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..for de/dy and dp/dy suma = 0.0d0 do i=1,ionmax suma = suma - zwork1(i) enddo sumz = 0.0d0 do i=1,ionmax sumz = sumz + (zion(i) - zbar)*zwork1(i) enddo sum = 0.0d0 do i=1,ionmax sum = sum - zwork2(i) enddo sum5 = sum*dea_row(1)*abar*abar sum9 = sum*dpa_row(1)*abar*abar sum = 0.0d0 do i=1,ionmax sum = sum + zwork2(i)*(zion(i)-zbar) enddo sum6 = sum*dez_row(1)*abar sum10 = sum*dpz_row(1)*abar sum = 0.0d0 do i=1,ionmax sum = sum - zwork1(i) enddo sum7 = sum*dea_row(1)*abar*abar sum11 = sum*dpa_row(1)*abar*abar sum = 0.0d0 do i=1,ionmax sum = sum + zwork1(i)*(zion(i)-zbar) enddo sum8 = sum*dez_row(1)*abar sum12 = sum*dpz_row(1)*abar c..the possibly singular denominator cs = cs_row(1) denom = velx*velx - cs*cs denombv = 2.0d0*velx denomdd = -2.0d0*cs*csbd denomdt = -2.0d0*cs*csbt c..the function phi dpde = dpt_row(1)/det_row(1) z = suma*dpa_row(1)*abar*abar + sumz*dpz_row(1)*abar zbd = suma*dpabd*abar*abar + sumz*dpzbd*abar + sum9 + sum10 zbt = suma*dpabt*abar*abar + sumz*dpzbt*abar + sum11 + sum12 ww = suma*dea_row(1)*abar*abar + sumz*dez_row(1)*abar wwbd = suma*deabd*abar*abar + sumz*dezbd*abar + sum5 + sum6 wwbt = suma*deabt*abar*abar + sumz*dezbt*abar + sum7 + sum8 phi = dpde*(zwork1(iener) - ww) - z phibd = dpdebd*(zwork1(iener) - ww) - zbd 1 + dpde*(enucbd - wwbd) phibt = dpdebt*(zwork1(iener) - ww) - zbt 1 + dpde*(enucbt - wwbt) c..a common combination if (denom .ne. 0.0) then combo = phi/denom combobv = -combo/denom*denombv combobd = -combo/denom*denomdd + phibd/denom combobt = -combo/denom*denomdt + phibt/denom else combo = 0.0d0 combobv = 0.0d0 combobd = 0.0d0 combobt = 0.0d0 end if c..position equation zwork1(iposx) = velx c..d(iposx)/d(iposx) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iposx)/d(ivelx) a1 = 1.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..density equation zwork1(iden) = combo c..d(iden)/d(ivelx) a1 = combobv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(iden) a1 = combobd nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(itemp) a1 = combobt nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(yi) xx = 1.0d0/denom zz = dpde*xx do i=1,ionmax a1 = zz*xsum(i) * conv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 enddo c..velocity equation z = velx/bden zwork1(ivelx) = -z*zwork1(iden) c..d(ivelx)/d(ivelx) a1 = -zwork1(iden)/bden - z*combobv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(ivelx)/d(iden) a1 = z/bden*zwork1(iden) - z*combobd nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(ivelx)/d(itemp) a1 = -z*combobt nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(ivelx)/d(yi) zz = -z * dpde/denom do i=1,ionmax a1 = zz*xsum(i) * conv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 enddo c..temperature equation dtdp = 1.0d0/dpt_row(1) dtdpbd = -dtdp*dtdp*dptbd dtdpbt = -dtdp*dtdp*dptbt ww = suma*dpa_row(1)*abar*abar + sumz*dpz_row(1)*abar wwbd = suma*dpabd*abar*abar + sumz*dpzbd*abar + sum9 + sum10 wwbt = suma*dpabt*abar*abar + sumz*dpzbt*abar + sum11 + sum12 zwork1(itemp) = dtdp*((velx*velx 1 - dpd_row(1))*zwork1(iden) - ww) c..d(itemp)/d(ivelx) a1 = dtdp*(2.0d0*velx*zwork1(iden) 1 + (velx*velx - dpd_row(1))*combobv) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(itemp)/d(iden) a1 = dtdpbd*((velx*velx-dpd_row(1))*zwork1(iden)-ww) 1 + dtdp*((velx*velx-dpd_row(1))*combobd 2 - dpdbd*zwork1(iden) 3 - wwbd) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(itemp)/d(itemp) a1 = dtdpbt*((velx*velx-dpd_row(1))*zwork1(iden)-ww) 1 + dtdp*((velx*velx-dpd_row(1))*combobt 2 - dpdbt*zwork1(iden) 3 - wwbt) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(itemp)/d(yi) xx = 1.0d0/denom zz = dpde*xx do i=1,ionmax a3 = zz * xsum(i) * conv a1 = dtdp * ((velx*velx - dpd_row(1)) * a3) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 enddo c..bbang else if (bbang) then c..d(itemp)/d(itemp) xa = me * clight**2 / (kerg * btemp) dxadt = -xa/btemp f1 = wien1(xa) df1 = dwien1dx(xa) f2 = wien2(xa) df2 = dwien2dx(xa) con = sqrt(f2 * 8.0d0*pi*g*asol/(3.0d0*clight**2) ) dcondt = con/f2*df2*dxadt denom = xa * df1/(3.0d0*f1) - 1.0d0 ddenom = dxadt*df1/(3.0d0*f1) - xa*df1/(3.0d0*f1**2)*df1*dxadt zz = con*btemp**3 / denom a1 = 3.0d0*zz/btemp + zz/con * dcondt - zz/denom * ddenom nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(itemp) f1 = 30.0d0 * zeta3/pi**4 * asol/(kerg*avo) xx = 3.0d0 * f1 * eta1 * btemp**2 f2 = 2.0d0*xx*zz/btemp + xx*a1 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + f2 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 storch: nt .ne. nterms' stop 'error in routine storch' end if return end subroutine torchrat(ye) include 'implno.dek' include 'burn_common.dek' include 'vector_eos.dek' include 'network.dek' include 'tfactors.dek' c..this routine generates nuclear reaction rates for the torch network c.. c..declare the pass double precision ye c..local variables integer i,j,k,jd1,jd2,jd3,jd4,jd5,jn,j1,j2,k0,k1,k2,k3, 1 k4,k5,k6,k7,k8,k9,jxx,inap, 2 nrate,lk0,jk,lk1,lk2,lk3,lk4,lk5,lk6,lk7,lk8 double precision term,dtermdt,aa,daa,bb,dbb,cc,dcc,dd,ddd,ee,dee, 1 frate,dfratedt,dfratedd,rrate,drratedt,drratedd, 2 z,g0,dg0,sp1,sn1 c..initialize inap = 0 c do i=1,ionmax c do j=1,14 c sigraw(j,i) = 0.0d0 c sigrawdt(j,i) = 0.0d0 c sigrawdd(j,i) = 0.0d0 c enddo c enddo if (btemp .lt. 1.0e6) return c..get the temperature factors call tfactors(btemp) c..calculate the temperature dependent partition functions wpart(i) c..zwork1(i) is the ratio of wpart(i) to the ground state partition function c..zwork2(i) is the temperature derivative of zwork1 do i=ionbeg,ionend jd1 = 5*(i-1) + 1 jd2 = jd1 + 1 jd3 = jd2 + 1 jd4 = jd3 + 1 jd5 = jd4 + 1 zwork1(i) = 0.0d0 zwork2(i) = 0.0d0 g0 = 1.0d0 dg0 = 0.0d0 if (as(jd2) .ne. 0.0) then aa = as(jd2)*t9i + as(jd3) + as(jd4)*t9 + as(jd5)*t92 daa = -as(jd2)*t9i2 + as(jd4) + 2.0d0*as(jd5)*t9 zwork1(i) = exp(aa) zwork2(i) = zwork1(i)*daa if (ist(i) .ne. 0) then do jxx=6*(i-1)+1,6*(i-1)+2*ist(i)-1,2 aa = gs(jxx+1) * exp(-gs(jxx)*t9i) daa = aa*gs(jxx)*t9i2 g0 = g0 + aa dg0 = dg0 + daa enddo end if end if zwork1(i) = g0 + zwork1(i) zwork2(i) = dg0 + zwork2(i) wpart(i) = as(jd1) * zwork1(i) c..no partition functions c zwork1(i) = 1.0d0 c zwork2(i) = 0.0d0 c wpart(i) = 1.0d0 enddo c..generate strong, electromagnetic and ground state beta decay rates c..j=1=(ng) j=2=(pn) j=3=b- j=4=(pg) j=5=(ap) j=6=(an) j=7=(ag) j=8=a decay do i=ionbeg,ionend c..set up the y(j)(n,g)y(k) and y(k)(g,n)y(j) components if (nrr(1,i) .gt. 0) then call vbean(1,i,sigraw(1,i),sigrawdt(1,i),sigrawdd(1,i), 1 sigraw(2,i),sigrawdt(2,i),sigrawdd(2,i)) inap = inap + 2 end if c..set up the (p,n) (n,p) and beta- beta+ decay components if (nrr(2,i) .gt. 0) then call vbean(3,i,sigraw(3,i),sigrawdt(3,i),sigrawdd(3,i), 1 sigraw(4,i),sigrawdt(4,i),sigrawdd(4,i)) call vbean(5,i,sigraw(5,i),sigrawdt(5,i),sigrawdd(5,i), 1 sigraw(6,i),sigrawdt(6,i),sigrawdd(6,i)) c..na23 entry in bdat, mg23b+ is the problem c if ( i .eq. ina23) then c write(6,111) i,ionam(i),sigraw(5,i),sigraw(6,i) c 111 format(1x,i5,' ',a5,' ',1p2e14.6) c end if c if (i .eq. ina23) then c sigraw(5,i) = 0.0d0 c sigrawdt(5,i) = 0.0d0 c sigrawdd(5,i) = 0.0d0 c sigraw(6,i) = 0.0d0 c sigrawdt(6,i) = 0.0d0 c sigrawdd(6,i) = 0.0d0 c end if inap = inap + 4 end if c..set up the (p,g) and (g,p) components if (nrr(3,i) .gt. 0) then call vbean(7,i,sigraw(7,i),sigrawdt(7,i),sigrawdd(7,i), 1 sigraw(8,i),sigrawdt(8,i),sigrawdd(8,i)) inap = inap + 2 end if c..set up the (a,p) and (p,a) reactions if (nrr(4,i) .gt. 0) then call vbean(9,i,sigraw(9,i),sigrawdt(9,i),sigrawdd(9,i), 1 sigraw(10,i),sigrawdt(10,i),sigrawdd(10,i)) inap = inap + 2 end if c..set up the (a,n) and (n,a) components if (nrr(5,i) .gt. 0) then call vbean(11,i,sigraw(11,i),sigrawdt(11,i),sigrawdd(11,i), 1 sigraw(12,i),sigrawdt(12,i),sigrawdd(12,i)) inap = inap + 2 end if c..and the (a,g) and (g,a) components if (nrr(6,i) .gt. 0) then call vbean(13,i,sigraw(13,i),sigrawdt(13,i),sigrawdd(13,i), 1 sigraw(14,i),sigrawdt(14,i),sigrawdd(14,i)) inap = inap + 2 end if enddo c..now add in the cf88 + additions reaction rates c..for p(e-,nu)n and n(e+,nub)p reactions c..count them, but don't compute them here inap = inap + 2 c..triple alpha to c12 if (ic12 .ne. 0) then call rate_tripalf(btemp,bden, 1 ratraw(ir3a),dratrawdt(ir3a),dratrawdd(ir3a), 2 ratraw(irg3a),dratrawdt(irg3a),dratrawdd(irg3a)) inap = inap + 2 c ratraw(ir3a) = 0.0d0 c dratrawdt(ir3a) = 0.0d0 c dratrawdd(ir3a) = 0.0d0 c ratraw(irg3a) = 0.0d0 c dratrawdt(irg3a) = 0.0d0 c dratrawdd(irg3a) = 0.0d0 c..c12 + c12 if (ine20.ne.0 .and. ina23.ne.0 .and. img23.ne.0) then call rate_c12c12npa(btemp,bden, 1 ratraw(ir1212n),dratrawdt(ir1212n),dratrawdd(ir1212n), 2 ratraw(irmg23nc),dratrawdt(irmg23nc),dratrawdd(irmg23nc), 3 ratraw(ir1212p),dratrawdt(ir1212p),dratrawdd(ir1212p), 4 ratraw(irna23pc),dratrawdt(irna23pc),dratrawdd(irna23pc), 5 ratraw(ir1212a),dratrawdt(ir1212a),dratrawdd(ir1212a), 6 ratraw(irne20ac),dratrawdt(irne20ac),dratrawdd(irne20ac)) inap = inap + 6 c ratraw(ir1212n) = 0.0d0 c dratrawdt(ir1212n) = 0.0d0 c dratrawdd(ir1212n) = 0.0d0 c ratraw(irmg23nc) = 0.0d0 c dratrawdt(irmg23nc) = 0.0d0 c dratrawdd(irmg23nc) = 0.0d0 c ratraw(ir1212p) = 0.0d0 c dratrawdt(ir1212p) = 0.0d0 c dratrawdd(ir1212p) = 0.0d0 c ratraw(irna23pc) = 0.0d0 c dratrawdt(irna23pc) = 0.0d0 c dratrawdd(irna23pc) = 0.0d0 c ratraw(ir1212a) = 0.0d0 c dratrawdt(ir1212a) = 0.0d0 c dratrawdd(ir1212a) = 0.0d0 c ratraw(irne20ac) = 0.0d0 c dratrawdt(irne20ac) = 0.0d0 c dratrawdd(irne20ac) = 0.0d0 end if end if c..o16 + o16 if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30.ne.0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then call rate_o16o16npad(btemp,bden, 1 ratraw(ir1616n),dratrawdt(ir1616n),dratrawdd(ir1616n), 2 ratraw(irs31no),dratrawdt(irs31no),dratrawdd(irs31no), 3 ratraw(ir1616p),dratrawdt(ir1616p),dratrawdd(ir1616p), 4 ratraw(irp31po),dratrawdt(irp31po),dratrawdd(irp31po), 5 ratraw(ir1616a),dratrawdt(ir1616a),dratrawdd(ir1616a), 6 ratraw(irsi28ao),dratrawdt(irsi28ao),dratrawdd(irsi28ao), 7 ratraw(ir1616d),dratrawdt(ir1616d),dratrawdd(ir1616d), 8 ratraw(irp30do),dratrawdt(irp30do),dratrawdd(irp30do)) inap = inap + 8 c ratraw(ir1616n) = 0.0d0 c dratrawdt(ir1616n) = 0.0d0 c dratrawdd(ir1616n) = 0.0d0 c ratraw(irs31no) = 0.0d0 c dratrawdt(irs31no) = 0.0d0 c dratrawdd(irs31no) = 0.0d0 c ratraw(ir1616p) = 0.0d0 c dratrawdt(ir1616p) = 0.0d0 c dratrawdd(ir1616p) = 0.0d0 c ratraw(irp31po) = 0.0d0 c dratrawdt(irp31po) = 0.0d0 c dratrawdd(irp31po) = 0.0d0 c ratraw(ir1616a) = 0.0d0 c dratrawdt(ir1616a) = 0.0d0 c dratrawdd(ir1616a) = 0.0d0 c ratraw(irsi28ao) = 0.0d0 c dratrawdt(irsi28ao) = 0.0d0 c dratrawdd(irsi28ao) = 0.0d0 c ratraw(ir1616d) = 0.0d0 c dratrawdt(ir1616d) = 0.0d0 c dratrawdd(ir1616d) = 0.0d0 c ratraw(irp30do) = 0.0d0 c dratrawdt(irp30do) = 0.0d0 c dratrawdd(irp30do) = 0.0d0 end if c..c12 + o16 reaction if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then call rate_c12o16npa(btemp,bden, 1 ratraw(ir1216n),dratrawdt(ir1216n),dratrawdd(ir1216n), 2 ratraw(irsi27no),dratrawdt(irsi27no),dratrawdd(irsi27no), 3 ratraw(ir1216p),dratrawdt(ir1216p),dratrawdd(ir1216p), 4 ratraw(iral27po),dratrawdt(iral27po),dratrawdd(iral27po), 5 ratraw(ir1216a),dratrawdt(ir1216a),dratrawdd(ir1216a), 6 ratraw(irmg24ao),dratrawdt(irmg24ao),dratrawdd(irmg24ao)) inap = inap + 6 c ratraw(ir1216n) = 0.0d0 c dratrawdt(ir1216n) = 0.0d0 c dratrawdd(ir1216n) = 0.0d0 c ratraw(irsi27no) = 0.0d0 c dratrawdt(irsi27no) = 0.0d0 c dratrawdd(irsi27no) = 0.0d0 c ratraw(ir1216p) = 0.0d0 c dratrawdt(ir1216p) = 0.0d0 c dratrawdd(ir1216p) = 0.0d0 c ratraw(iral27po) = 0.0d0 c dratrawdt(iral27po) = 0.0d0 c dratrawdd(iral27po) = 0.0d0 c ratraw(ir1216a) = 0.0d0 c dratrawdt(ir1216a) = 0.0d0 c dratrawdd(ir1216a) = 0.0d0 c ratraw(irmg24ao) = 0.0d0 c dratrawdt(irmg24ao) = 0.0d0 c dratrawdd(irmg24ao) = 0.0d0 end if c..if have deuterium if (ih2 .ne. 0) then c..p(p,e+nu)d call rate_pp(btemp,bden, 1 ratraw(irpp),dratrawdt(irpp),dratrawdd(irpp), 2 rrate,drratedt,drratedd) inap = inap + 1 c..p(e-p,nu)d call rate_pep(btemp,bden,ye, 1 ratraw(irpep),dratrawdt(irpep),dratrawdd(irpep), 2 rrate,drratedt,drratedd) inap = inap + 1 c..d(p,g)he3 call rate_dpg(btemp,bden, 1 sigraw(7,ih2),sigrawdt(7,ih2),sigrawdd(7,ih2), 2 sigraw(8,ih2),sigrawdt(8,ih2),sigrawdd(8,ih2)) c..d(n,g)t call rate_dng(btemp,bden, 1 sigraw(1,ih2),sigrawdt(1,ih2),sigrawdd(1,ih2), 2 sigraw(2,ih2),sigrawdt(2,ih2),sigrawdd(2,ih2)) c..p(n,g)d call rate_png(btemp,bden, 1 ratraw(irpng),dratrawdt(irpng),dratrawdd(irpng), 2 ratraw(irdgn),dratrawdt(irdgn),dratrawdd(irdgn)) inap = inap + 2 c..d(a,g)li6 call rate_he4dg(btemp,bden, 1 sigraw(13,ih2),sigrawdt(13,ih2),sigrawdd(13,ih2), 2 sigraw(14,ih2),sigrawdt(14,ih2),sigrawdd(14,ih2)) c..d(p,n)2p call rate_dpn(btemp,bden, 1 ratraw(irdpn),dratrawdt(irdpn),dratrawdd(irdpn), 2 ratraw(ir2pnp),dratrawdt(ir2pnp),dratrawdd(ir2pnp)) inap = inap + 2 c..d(d,g)he4 call rate_ddg(btemp,bden, 1 ratraw(irddg),dratrawdt(irddg),dratrawdd(irddg), 2 ratraw(irhe4gd),dratrawdt(irhe4gd),dratrawdd(irhe4gd)) inap = inap + 2 end if c..if we have tritium if (ih3 .ne. 0) then c..d(d,p)t call rate_ddp(btemp,bden, 1 ratraw(irddp),dratrawdt(irddp),dratrawdd(irddp), 2 ratraw(irtpd),dratrawdt(irtpd),dratrawdd(irtpd)) inap = inap + 2 c..t(p,n)he3 call rate_tpn(btemp,bden, 1 sigraw(3,ih3),sigrawdt(3,ih3),sigrawdd(3,ih3), 2 sigraw(4,ih3),sigrawdt(4,ih3),sigrawdd(4,ih3)) c..t(p,g)he4 call rate_tpg(btemp,bden, 1 ratraw(irh3pg),dratrawdt(irh3pg),dratrawdd(irh3pg), 2 ratraw(irhe4gp),dratrawdt(irhe4gp),dratrawdd(irhe4gp)) inap = inap + 2 c..t(d,n)he4 call rate_tdn(btemp,bden, 1 ratraw(irtdn),dratrawdt(irtdn),dratrawdd(irtdn), 2 ratraw(irhe4nd),dratrawdt(irhe4nd),dratrawdd(irhe4nd)) inap = inap + 2 c..t(t,2n)he4 call rate_tt2n(btemp,bden, 1 ratraw(irtt2n),dratrawdt(irtt2n),dratrawdd(irtt2n), 2 ratraw(irhe42nt),dratrawdt(irhe42nt),dratrawdd(irhe42nt)) inap = inap + 2 c..t(a,g)li7 call rate_he4tg(btemp,bden, 1 sigraw(13,ih3),sigrawdt(13,ih3),sigrawdd(13,ih3), 2 sigraw(14,ih3),sigrawdt(14,ih3),sigrawdd(14,ih3)) c..t(a,n)li6 call rate_he4tn(btemp,bden, 1 sigraw(11,ih3),sigrawdt(11,ih3),sigrawdd(11,ih3), 2 sigraw(12,ih3),sigrawdt(12,ih3),sigrawdd(12,ih3)) end if c..if we have he3 if (ihe3 .ne. 0) then c..he3(he3,2p)he4 call rate_he3he3(btemp,bden, 1 ratraw(ir33),dratrawdt(ir33),dratrawdd(ir33), 2 ratraw(ir33inv),dratrawdt(ir33inv),dratrawdd(ir33inv)) inap = inap + 2 c..he3(p,e+nu)he4 call rate_hep(btemp,bden, 1 ratraw(irhep),dratrawdt(irhep),dratrawdd(irhep), 2 rrate,drratedt,drratedd) inap = inap + 1 c..he3(n,g)he4 call rate_he3ng(btemp,bden, 1 ratraw(irhe3ng),dratrawdt(irhe3ng),dratrawdd(irhe3ng), 2 ratraw(irhe4gn),dratrawdt(irhe4gn),dratrawdd(irhe4gn)) inap = inap + 2 c..he3(a,g)be7 call rate_he3he4(btemp,bden, 1 sigraw(13,ihe3),sigrawdt(13,ihe3),sigrawdd(13,ihe3), 2 sigraw(14,ihe3),sigrawdt(14,ihe3),sigrawdd(14,ihe3)) c..he3(a,p)li6 call rate_li6phe3(btemp,bden, 1 sigraw(10,ihe3),sigrawdt(10,ihe3),sigrawdd(10,ihe3), 2 sigraw(9,ihe3),sigrawdt(9,ihe3),sigrawdd(9,ihe3)) c..he3(d,p)he4 call rate_he3dp(btemp,bden, 1 ratraw(irhe3dp),dratrawdt(irhe3dp),dratrawdd(irhe3dp), 2 ratraw(irhe4pd),dratrawdt(irhe4pd),dratrawdd(irhe4pd)) inap = inap + 2 c..d(d,n)he3 call rate_ddn(btemp,bden, 1 ratraw(irddn),dratrawdt(irddn),dratrawdd(irddn), 2 ratraw(irhe3nd),dratrawdt(irhe3nd),dratrawdd(irhe3nd)) inap = inap + 2 c..he3(t,d)he4 call rate_he3td(btemp,bden, 1 ratraw(irhe3td),dratrawdt(irhe3td),dratrawdd(irhe3td), 2 ratraw(irhe4dt),dratrawdt(irhe4dt),dratrawdd(irhe4dt)) inap = inap + 2 c..he3(t,np)he4 call rate_he3tnp(btemp,bden, 1 ratraw(irhe3tnp),dratrawdt(irhe3tnp),dratrawdd(irhe3tnp), 2 rrate,drratedt,drratedd) inap = inap + 1 end if c..if we have li6 if (ili6 .ne. 0) then c..li6(p,g)be7 call rate_li6pg(btemp,bden, 1 sigraw(7,ili6),sigrawdt(7,ili6),sigrawdd(7,ili6), 2 sigraw(8,ili6),sigrawdt(8,ili6),sigrawdd(8,ili6)) c..li6(a,g)b10 call rate_li6ag(btemp,bden, 1 sigraw(13,ili6),sigrawdt(13,ili6),sigrawdd(13,ili6), 2 sigraw(14,ili6),sigrawdt(14,ili6),sigrawdd(14,ili6)) c..li6(a,p)be9 call rate_be9pa(btemp,bden, 1 sigraw(10,ili6),sigrawdt(10,ili6),sigrawdd(10,ili6), 2 sigraw(9,ili6),sigrawdt(9,ili6),sigrawdd(9,ili6)) c..li6(n,g)li7 call rate_li6ng(btemp,bden, 1 sigraw(1,ili6),sigrawdt(1,ili6),sigrawdd(1,ili6), 2 sigraw(2,ili6),sigrawdt(2,ili6),sigrawdd(2,ili6)) end if c..for li7 if (ili7 .ne. 0)then c..li7(t,2n)2a call rate_li7t2n(btemp,bden, 1 ratraw(irli7t2n),dratrawdt(irli7t2n),dratrawdd(irli7t2n), 2 rrate,drratedt,drratedd) inap = inap + 1 c..li7(n,g)li8 call rate_li7ng(btemp,bden, 1 sigraw(1,ili7),sigrawdt(1,ili7),sigrawdd(1,ili7), 2 sigraw(2,ili7),sigrawdt(2,ili7),sigrawdd(2,ili7)) c..li7(p,n)be7 call rate_li7pn(btemp,bden, 1 sigraw(3,ili7),sigrawdt(3,ili7),sigrawdd(3,ili7), 2 sigraw(4,ili7),sigrawdt(4,ili7),sigrawdd(4,ili7)) c..li7(p,g)be8 and li7(p,a)he4 call rate_li7pag(btemp,bden, 1 ratraw(irli7pag),dratrawdt(irli7pag),dratrawdd(irli7pag), 2 ratraw(ir2he4ga),dratrawdt(ir2he4ga),dratrawdd(ir2he4ga)) inap = inap + 2 c..li7(d,n)2a call rate_li7dn(btemp,bden, 1 ratraw(irli7dn),dratrawdt(irli7dn),dratrawdd(irli7dn), 2 rrate,drratedt,drratedd) inap = inap + 1 c..li7(he3,np)2a call rate_li7he3np(btemp,bden, 1 ratraw(irli7he3np),dratrawdt(irli7he3np),dratrawdd(irli7he3np), 2 rrate,drratedt,drratedd) inap = inap + 1 c..li7(a,g)b11 call rate_li7ag(btemp,bden, 1 sigraw(13,ili7),sigrawdt(13,ili7),sigrawdd(13,ili7), 2 sigraw(14,ili7),sigrawdt(14,ili7),sigrawdd(14,ili7)) c..li7(a,n)b10 q = -2.790 call rate_li7an(btemp,bden, 1 sigraw(11,ili7),sigrawdt(11,ili7),sigrawdd(11,ili7), 2 sigraw(12,ili7),sigrawdt(12,ili7),sigrawdd(12,ili7)) c..be7(e-,nu+g)li7 call rate_be7em(btemp,bden,ye, 1 sigraw(6,ili7),sigrawdt(6,ili7),sigrawdd(6,ili7), 2 rrate,drratedt,drratedd) end if c..for be7 if (ibe7 .ne. 0) then c..be7(p,g)b8 call rate_be7pg(btemp,bden, 1 sigraw(7,ibe7),sigrawdt(7,ibe7),sigrawdd(7,ibe7), 2 sigraw(8,ibe7),sigrawdt(8,ibe7),sigrawdd(8,ibe7)) c..be7(d,p)2a call rate_be7dp(btemp,bden, 1 ratraw(irbe7dp),dratrawdt(irbe7dp),dratrawdd(irbe7dp), 2 rrate,drratedt,drratedd) inap = inap + 1 c..be7(t,np)2a call rate_be7tnp(btemp,bden, 1 ratraw(irbe7tnp),dratrawdt(irbe7tnp),dratrawdd(irbe7tnp), 2 rrate,drratedt,drratedd) inap = inap + 1 c..be7(he3,2p)2a call rate_be7he32p(btemp,bden, 1 ratraw(irbe7he32p),dratrawdt(irbe7he32p),dratrawdd(irbe7he32p), 2 rrate,drratedt,drratedd) inap = inap + 1 c..b10(p,a)be7 call rate_b10pa(btemp,bden, 1 sigraw(10,ibe7),sigrawdt(10,ibe7),sigrawdd(10,ibe7), 2 sigraw(9,ibe7),sigrawdt(9,ibe7),sigrawdd(9,ibe7)) c..be7(a,g)c11 call rate_be7ag(btemp,bden, 1 sigraw(13,ibe7),sigrawdt(13,ibe7),sigrawdd(13,ibe7), 2 sigraw(14,ibe7),sigrawdt(14,ibe7),sigrawdd(14,ibe7)) end if c..for be9 if (ibe9 .ne. 0) then c..a(an,g)be9 call rate_aan(btemp,bden, 1 ratraw(iraan),dratrawdt(iraan),dratrawdd(iraan), 2 ratraw(irgaan),dratrawdt(irgaan),dratrawdd(irgaan)) inap = inap + 2 c..be9(a,n)c12 call rate_be9an(btemp,bden, 1 sigraw(11,ibe9),sigrawdt(11,ibe9),sigrawdd(11,ibe9), 2 sigraw(12,ibe9),sigrawdt(12,ibe9),sigrawdd(12,ibe9)) c..be9(p,d)be8 call rate_be9pd(btemp,bden, 1 ratraw(irbe9pd),dratrawdt(irbe9pd),dratrawdd(irbe9pd), 2 rrate,drratedt,drratedd) inap = inap + 1 c..be9(p,g)b10 call rate_be9pg(btemp,bden, 1 sigraw(7,ibe9),sigrawdt(7,ibe9),sigrawdd(7,ibe9), 2 sigraw(8,ibe9),sigrawdt(8,ibe9),sigrawdd(8,ibe9)) c..be9(p,n)b9 call rate_be9pn(btemp,bden, 1 sigraw(3,ibe9),sigrawdt(3,ibe9),sigrawdd(3,ibe9), 2 sigraw(4,ibe9),sigrawdt(4,ibe9),sigrawdd(4,ibe9)) end if c..for b8 if (ib8 .ne. 0) then c..b8(a,p)c11 call rate_b8ap(btemp,bden, 1 sigraw(9,ib8),sigrawdt(9,ib8),sigrawdd(9,ib8), 2 sigraw(10,ib8),sigrawdt(10,ib8),sigrawdd(10,ib8)) c..b8(e+,nu)be8 => 2a call rate_b8ep(btemp,bden, 1 ratraw(irb8ep),dratrawdt(irb8ep),dratrawdd(irb8ep), 2 rrate,drratedt,drratedd) inap = inap + 1 end if c..for b10 if (ib10 .ne. 0) then c..b10(p,g)c11 call rate_b10pg(btemp,bden, 1 sigraw(7,ib10),sigrawdt(7,ib10),sigrawdd(7,ib10), 2 sigraw(8,ib10),sigrawdt(8,ib10),sigrawdd(8,ib10)) c..b10(a,n)n13 call rate_b10an(btemp,bden, 1 sigraw(11,ib10),sigrawdt(11,ib10),sigrawdd(11,ib10), 2 sigraw(12,ib10),sigrawdt(12,ib10),sigrawdd(12,ib10)) end if c..if we have b11 if (ib11 .ne. 0) then c..b11(p,n)c11 call rate_b11pn(btemp,bden, 1 sigraw(3,ib11),sigrawdt(3,ib11),sigrawdd(3,ib11), 2 sigraw(4,ib11),sigrawdt(4,ib11),sigrawdd(4,ib11)) c..b11(p,g)c12 call rate_b11pg(btemp,bden, 1 sigraw(7,ib11),sigrawdt(7,ib11),sigrawdd(7,ib11), 2 sigraw(8,ib11),sigrawdt(8,ib11),sigrawdd(8,ib11)) c..b11(p,a)be8=>2a call rate_b11pa(btemp,bden, 1 ratraw(irb11pa),dratrawdt(irb11pa),dratrawdd(irb11pa), 2 ratraw(ir3ap),dratrawdt(ir3ap),dratrawdd(ir3ap)) inap = inap + 2 c..b11(a,p)c14 call rate_b11ap(btemp,bden, 1 sigraw(9,ib11),sigrawdt(9,ib11),sigrawdd(9,ib11), 2 sigraw(10,ib11),sigrawdt(10,ib11),sigrawdd(10,ib11)) c..b11(a,n)n14 call rate_b11an(btemp,bden, 1 sigraw(11,ib11),sigrawdt(11,ib11),sigrawdd(11,ib11), 2 sigraw(12,ib11),sigrawdt(12,ib11),sigrawdd(12,ib11)) end if c..for c11 if (ic11 .ne. 0) then c..n14(p,a)c11 call rate_n14pa(btemp,bden, 1 sigraw(10,ic11),sigrawdt(10,ic11),sigrawdd(10,ic11), 2 sigraw(9,ic11),sigrawdt(9,ic11),sigrawdd(9,ic11)) c..c11(p,g)n12 call rate_c11pg(btemp,bden, 1 sigraw(7,ic11),sigrawdt(7,ic11),sigrawdd(7,ic11), 2 sigraw(8,ic11),sigrawdt(8,ic11),sigrawdd(8,ic11)) c..c11(na)be8 => 2a call rate_c11na(btemp,bden, 1 ratraw(irc11na),dratrawdt(irc11na),dratrawdd(irc11na), 2 rrate,drratedt,drratedd) inap = inap + 1 end if c..for c12 if (ic12 .ne. 0) then c..c12(p,g)n13 call rate_c12pg(btemp,bden, 1 sigraw(7,ic12),sigrawdt(7,ic12),sigrawdd(7,ic12), 2 sigraw(8,ic12),sigrawdt(8,ic12),sigrawdd(8,ic12)) c..c12(a,n)o15 call rate_c12an(btemp,bden, 1 sigraw(11,ic12),sigrawdt(11,ic12),sigrawdd(11,ic12), 2 sigraw(12,ic12),sigrawdt(12,ic12),sigrawdd(12,ic12)) c..c12(a,g)o16 call rate_c12ag(btemp,bden, 1 sigraw(13,ic12),sigrawdt(13,ic12),sigrawdd(13,ic12), 2 sigraw(14,ic12),sigrawdt(14,ic12),sigrawdd(14,ic12)) c..n15(p,a)c12 call rate_n15pa(btemp,bden, 1 sigraw(10,ic12),sigrawdt(10,ic12),sigrawdd(10,ic12), 2 sigraw(9,ic12),sigrawdt(9,ic12),sigrawdd(9,ic12)) end if c..for c13 if (ic13 .ne. 0) then c..c13(p,g)n14 call rate_c13pg(btemp,bden, 1 sigraw(7,ic13),sigrawdt(7,ic13),sigrawdd(7,ic13), 2 sigraw(8,ic13),sigrawdt(8,ic13),sigrawdd(8,ic13)) c..c13(a,n)o16 call rate_c13an(btemp,bden, 1 sigraw(11,ic13),sigrawdt(11,ic13),sigrawdd(11,ic13), 2 sigraw(12,ic13),sigrawdt(12,ic13),sigrawdd(12,ic13)) c..c13(p,n)n13 call rate_c13pn(btemp,bden, 1 sigraw(3,ic13),sigrawdt(3,ic13),sigrawdd(3,ic13), 2 sigraw(4,ic13),sigrawdt(4,ic13),sigrawdd(4,ic13)) end if c..for c14 if (ic14 .ne. 0) then c..c14(p,g)n15 call rate_c14pg(btemp,bden, 1 sigraw(7,ic14),sigrawdt(7,ic14),sigrawdd(7,ic14), 2 sigraw(8,ic14),sigrawdt(8,ic14),sigrawdd(8,ic14)) c..c14(p,n)n14 call rate_c14pn(btemp,bden, 1 sigraw(3,ic14),sigrawdt(3,ic14),sigrawdd(3,ic14), 2 sigraw(4,ic14),sigrawdt(4,ic14),sigrawdd(4,ic14)) c..c14(a,g)o18 call rate_c14ag(btemp,bden, 1 sigraw(13,ic14),sigrawdt(13,ic14),sigrawdd(13,ic14), 2 sigraw(14,ic14),sigrawdt(14,ic14),sigrawdd(14,ic14)) end if c..for n13 if (in13 .ne. 0) then c..n13(p,g)o14 call rate_n13pg(btemp,bden, 1 sigraw(7,in13),sigrawdt(7,in13),sigrawdd(7,in13), 2 sigraw(8,in13),sigrawdt(8,in13),sigrawdd(8,in13)) c..o16(p,a)n13 call rate_o16pa(btemp,bden, 1 sigraw(10,in13),sigrawdt(10,in13),sigrawdd(10,in13), 2 sigraw(9,in13),sigrawdt(9,in13),sigrawdd(9,in13)) end if c..for n14 if (in14 .ne. 0) then c..n14(p,n)o14 call rate_n14pn(btemp,bden, 1 sigraw(3,in14),sigrawdt(3,in14),sigrawdd(3,in14), 2 sigraw(4,in14),sigrawdt(4,in14),sigrawdd(4,in14)) c..n14(p,g)o15 call rate_n14pg(btemp,bden, 1 sigraw(7,in14),sigrawdt(7,in14),sigrawdd(7,in14), 2 sigraw(8,in14),sigrawdt(8,in14),sigrawdd(8,in14)) c..n14(a,n)f17 call rate_n14an(btemp,bden, 1 sigraw(11,in14),sigrawdt(11,in14),sigrawdd(11,in14), 2 sigraw(12,in14),sigrawdt(12,in14),sigrawdd(12,in14)) c..n14(a,g)f18 call rate_n14ag(btemp,bden, 1 sigraw(13,in14),sigrawdt(13,in14),sigrawdd(13,in14), 2 sigraw(14,in14),sigrawdt(14,in14),sigrawdd(14,in14)) c..o17(p,a)n14 call rate_o17pa(btemp,bden, 1 sigraw(10,in14),sigrawdt(10,in14),sigrawdd(10,in14), 2 sigraw(9,in14),sigrawdt(9,in14),sigrawdd(9,in14)) end if c..for n15 if (in15 .ne. 0) then c..n15(p,g)o16 call rate_n15pg(btemp,bden, 1 sigraw(7,in15),sigrawdt(7,in15),sigrawdd(7,in15), 2 sigraw(8,in15),sigrawdt(8,in15),sigrawdd(8,in15)) c..n15(p,n)o15 call rate_n15pn(btemp,bden, 1 sigraw(3,in15),sigrawdt(3,in15),sigrawdd(3,in15), 2 sigraw(4,in15),sigrawdt(4,in15),sigrawdd(4,in15)) c..n15(a,n)f18 call rate_n15an(btemp,bden, 1 sigraw(11,in15),sigrawdt(11,in15),sigrawdd(11,in15), 2 sigraw(12,in15),sigrawdt(12,in15),sigrawdd(12,in15)) c..n15(a,g)f19 call rate_n15ag(btemp,bden, 1 sigraw(13,in15),sigrawdt(13,in15),sigrawdd(13,in15), 2 sigraw(14,in15),sigrawdt(14,in15),sigrawdd(14,in15)) c..o18(p,a)n15 call rate_o18pa(btemp,bden, 1 sigraw(10,in15),sigrawdt(10,in15),sigrawdd(10,in15), 2 sigraw(9,in15),sigrawdt(9,in15),sigrawdd(9,in15)) end if c..for o14 if (io14 .ne. 0) then c..o14(a,g)ne18 call rate_o14ag(btemp,bden, 1 sigraw(13,io14),sigrawdt(13,io14),sigrawdd(13,io14), 2 sigraw(14,io14),sigrawdt(14,io14),sigrawdd(14,io14)) c..o14(a,p)f17 call rate_o14ap(btemp,bden, 1 sigraw(9,io14),sigrawdt(9,io14),sigrawdd(9,io14), 2 sigraw(10,io14),sigrawdt(10,io14),sigrawdd(10,io14)) end if c..for o15 if (io15 .ne. 0) then c..o15(a,g)ne19 call rate_o15ag(btemp,bden, 1 sigraw(13,io15),sigrawdt(13,io15),sigrawdd(13,io15), 2 sigraw(14,io15),sigrawdt(14,io15),sigrawdd(14,io15)) c..f18(p,a)o15 call rate_f18pa(btemp,bden, 1 sigraw(10,io15),sigrawdt(10,io15),sigrawdd(10,io15), 2 sigraw(9,io15),sigrawdt(9,io15),sigrawdd(9,io15)) end if c..for o16 if (io16 .ne. 0) then c..o16(p,g)f17 call rate_o16pg(btemp,bden, 1 sigraw(7,io16),sigrawdt(7,io16),sigrawdd(7,io16), 2 sigraw(8,io16),sigrawdt(8,io16),sigrawdd(8,io16)) c..o16(a,g)ne20 call rate_o16ag(btemp,bden, 1 sigraw(13,io16),sigrawdt(13,io16),sigrawdd(13,io16), 2 sigraw(14,io16),sigrawdt(14,io16),sigrawdd(14,io16)) c..f19(p,a)o16 call rate_f19pa(btemp,bden, 1 sigraw(10,io16),sigrawdt(10,io16),sigrawdd(10,io16), 2 sigraw(9,io16),sigrawdt(9,io16),sigrawdd(9,io16)) end if c..for o17 if (io17 .ne. 0) then c..o17(p,g)f18 call rate_o17pg(btemp,bden, 1 sigraw(7,io17),sigrawdt(7,io17),sigrawdd(7,io17), 2 sigraw(8,io17),sigrawdt(8,io17),sigrawdd(8,io17)) c..o17(a,g)ne21 call rate_o17ag(btemp,bden, 1 sigraw(13,io17),sigrawdt(13,io17),sigrawdd(13,io17), 2 sigraw(14,io17),sigrawdt(14,io17),sigrawdd(14,io17)) c..o17(a,n)ne20 call rate_o17an(btemp,bden, 1 sigraw(11,io17),sigrawdt(11,io17),sigrawdd(11,io17), 2 sigraw(12,io17),sigrawdt(12,io17),sigrawdd(12,io17)) end if c..for o18 if (io18 .ne. 0) then c..o18(p,g)f19 call rate_o18pg(btemp,bden, 1 sigraw(7,io18),sigrawdt(7,io18),sigrawdd(7,io18), 2 sigraw(8,io18),sigrawdt(8,io18),sigrawdd(8,io18)) c..o18(a,g)ne22 call rate_o18ag(btemp,bden, 1 sigraw(13,io18),sigrawdt(13,io18),sigrawdd(13,io18), 2 sigraw(14,io18),sigrawdt(14,io18),sigrawdd(14,io18)) c..o18(a,n)ne21 call rate_o18an(btemp,bden, 1 sigraw(11,io18),sigrawdt(11,io18),sigrawdd(11,io18), 2 sigraw(12,io18),sigrawdt(12,io18),sigrawdd(12,io18)) end if c..for f17 if (if17 .ne. 0) then c..f17(p,g)ne18 call rate_f17pg(btemp,bden, 1 sigraw(7,if17),sigrawdt(7,if17),sigrawdd(7,if17), 2 sigraw(8,if17),sigrawdt(8,if17),sigrawdd(8,if17)) c..ne20(p,a)f17 call rate_ne20pa(btemp,bden, 1 sigraw(10,if17),sigrawdt(10,if17),sigrawdd(10,if17), 2 sigraw(9,if17),sigrawdt(9,if17),sigrawdd(9,if17)) end if c..for f18 if (if18 .ne. 0) then c..f18(p,g)ne19 call rate_f18pg(btemp,bden, 1 sigraw(7,if18),sigrawdt(7,if18),sigrawdd(7,if18), 2 sigraw(8,if18),sigrawdt(8,if18),sigrawdd(8,if18)) end if c..for f19 if (if19 .ne. 0) then c..f19(p,g)ne20 call rate_f19pg(btemp,bden, 1 sigraw(7,if19),sigrawdt(7,if19),sigrawdd(7,if19), 2 sigraw(8,if19),sigrawdt(8,if19),sigrawdd(8,if19)) c..f19(p,n)ne19 call rate_f19pn(btemp,bden, 1 sigraw(3,if19),sigrawdt(3,if19),sigrawdd(3,if19), 2 sigraw(4,if19),sigrawdt(4,if19),sigrawdd(4,if19)) c..f19(a,p)ne22 call rate_f19ap(btemp,bden, 1 sigraw(9,if19),sigrawdt(9,if19),sigrawdd(9,if19), 2 sigraw(10,if19),sigrawdt(10,if19),sigrawdd(10,if19)) c..na22(n,a)f19 call rate_na22na(btemp,bden, 1 sigraw(12,if19),sigrawdt(12,if19),sigrawdd(12,if19), 2 sigraw(11,if19),sigrawdt(11,if19),sigrawdd(11,if19)) end if c..for ne19 if (ine19 .ne. 0) then c..ne19(p,g)na20 call rate_ne19pg(btemp,bden, 1 sigraw(7,ine19),sigrawdt(7,ine19),sigrawdd(7,ine19), 2 sigraw(8,ine19),sigrawdt(8,ine19),sigrawdd(8,ine19)) end if c..for ne20 if (ine20 .ne. 0) then c..ne20(p,g)na21 call rate_ne20pg(btemp,bden, 1 sigraw(7,ine20),sigrawdt(7,ine20),sigrawdd(7,ine20), 2 sigraw(8,ine20),sigrawdt(8,ine20),sigrawdd(8,ine20)) c..ne20(a,g)mg24 call rate_ne20ag(btemp,bden, 1 sigraw(13,ine20),sigrawdt(13,ine20),sigrawdd(13,ine20), 2 sigraw(14,ine20),sigrawdt(14,ine20),sigrawdd(14,ine20)) c..na23(p,a)ne20 call rate_na23pa(btemp,bden, 1 sigraw(10,ine20),sigrawdt(10,ine20),sigrawdd(10,ine20), 2 sigraw(9,ine20),sigrawdt(9,ine20),sigrawdd(9,ine20)) c..ne20(n,g)ne21 call rate_ne20ng(btemp,bden, 1 sigraw(1,ine20),sigrawdt(1,ine20),sigrawdd(1,ine20), 2 sigraw(2,ine20),sigrawdt(2,ine20),sigrawdd(2,ine20)) end if c..for ne21 if (ine21 .ne. 0) then c..ne21(p,g)na22 call rate_ne21pg(btemp,bden, 1 sigraw(7,ine21),sigrawdt(7,ine21),sigrawdd(7,ine21), 2 sigraw(8,ine21),sigrawdt(8,ine21),sigrawdd(8,ine21)) c..ne21(a,g)mg25 call rate_ne21ag(btemp,bden, 1 sigraw(13,ine21),sigrawdt(13,ine21),sigrawdd(13,ine21), 2 sigraw(14,ine21),sigrawdt(14,ine21),sigrawdd(14,ine21)) c..ne21(a,n)mg24 call rate_ne21an(btemp,bden, 1 sigraw(11,ine21),sigrawdt(11,ine21),sigrawdd(11,ine21), 2 sigraw(12,ine21),sigrawdt(12,ine21),sigrawdd(12,ine21)) end if c..for ne22 if (ine22 .ne. 0) then c..ne22(p,g)na23 call rate_ne22pg(btemp,bden, 1 sigraw(7,ine22),sigrawdt(7,ine22),sigrawdd(7,ine22), 2 sigraw(8,ine22),sigrawdt(8,ine22),sigrawdd(8,ine22)) c..ne22(a,g)mg26 call rate_ne22ag(btemp,bden, 1 sigraw(13,ine22),sigrawdt(13,ine22),sigrawdd(13,ine22), 2 sigraw(14,ine22),sigrawdt(14,ine22),sigrawdd(14,ine22)) c..na22(n,p)ne22 call rate_na22np(btemp,bden, 1 sigraw(4,ine22),sigrawdt(4,ine22),sigrawdd(4,ine22), 2 sigraw(3,ine22),sigrawdt(3,ine22),sigrawdd(3,ine22)) c..ne22(a,n)mg25 call rate_ne22an(btemp,bden, 1 sigraw(11,ine22),sigrawdt(11,ine22),sigrawdd(11,ine22), 2 sigraw(12,ine22),sigrawdt(12,ine22),sigrawdd(12,ine22)) end if c..for na21 if (ina21 .ne. 0) then c..na21(p,g)mg22 call rate_na21pg(btemp,bden, 1 sigraw(7,ina21),sigrawdt(7,ina21),sigrawdd(7,ina21), 2 sigraw(8,ina21),sigrawdt(8,ina21),sigrawdd(8,ina21)) c..mg24(p,a)na21 call rate_mg24pa(btemp,bden, 1 sigraw(10,ina21),sigrawdt(10,ina21),sigrawdd(10,ina21), 2 sigraw(9,ina21),sigrawdt(9,ina21),sigrawdd(9,ina21)) end if c..for na22 if (ina22 .ne. 0) then c..na22(p,g)mg23 call rate_na22pg(btemp,bden, 1 sigraw(7,ina22),sigrawdt(7,ina22),sigrawdd(7,ina22), 2 sigraw(8,ina22),sigrawdt(8,ina22),sigrawdd(8,ina22)) end if c..for na23 if (ina23 .ne. 0) then c..na23(p,g)mg24 call rate_na23pg(btemp,bden, 1 sigraw(7,ina23),sigrawdt(7,ina23),sigrawdd(7,ina23), 2 sigraw(8,ina23),sigrawdt(8,ina23),sigrawdd(8,ina23)) c..na23(p,n)mg23 call rate_na23pn(btemp,bden, 1 sigraw(3,ina23),sigrawdt(3,ina23),sigrawdd(3,ina23), 2 sigraw(4,ina23),sigrawdt(4,ina23),sigrawdd(4,ina23)) end if c..for mg24 if (img24 .ne. 0) then c..mg24(p,g)al25 call rate_mg24pg(btemp,bden, 1 sigraw(7,img24),sigrawdt(7,img24),sigrawdd(7,img24), 2 sigraw(8,img24),sigrawdt(8,img24),sigrawdd(8,img24)) c..mg24(a,g)si28 call rate_mg24ag(btemp,bden, 1 sigraw(13,img24),sigrawdt(13,img24),sigrawdd(13,img24), 2 sigraw(14,img24),sigrawdt(14,img24),sigrawdd(14,img24)) c..al27(p,a)mg24 call rate_al27pa(btemp,bden, 1 sigraw(10,img24),sigrawdt(10,img24),sigrawdd(10,img24), 2 sigraw(9,img24),sigrawdt(9,img24),sigrawdd(9,img24)) end if c..for mg25 if (img25 .ne. 0) then c..mg25(p,g)al26 call rate_mg25pg(btemp,bden, 1 sigraw(7,img25),sigrawdt(7,img25),sigrawdd(7,img25), 2 sigraw(8,img25),sigrawdt(8,img25),sigrawdd(8,img25)) c..mg25(a,p)al28 call rate_mg25ap(btemp,bden, 1 sigraw(9,img25),sigrawdt(9,img25),sigrawdd(9,img25), 2 sigraw(10,img25),sigrawdt(10,img25),sigrawdd(10,img25)) c..mg25(a,g)si29 call rate_mg25ag(btemp,bden, 1 sigraw(13,img25),sigrawdt(13,img25),sigrawdd(13,img25), 2 sigraw(14,img25),sigrawdt(14,img25),sigrawdd(14,img25)) c..mg25(a,n)si28 call rate_mg25an(btemp,bden, 1 sigraw(11,img25),sigrawdt(11,img25),sigrawdd(11,img25), 2 sigraw(12,img25),sigrawdt(12,img25),sigrawdd(12,img25)) end if c..for mg26 if (img26 .ne. 0) then c..mg26(p,g)al27 call rate_mg26pg(btemp,bden, 1 sigraw(7,img26),sigrawdt(7,img26),sigrawdd(7,img26), 2 sigraw(8,img26),sigrawdt(8,img26),sigrawdd(8,img26)) c..mg26(a,g)si30 call rate_mg26ag(btemp,bden, 1 sigraw(13,img26),sigrawdt(13,img26),sigrawdd(13,img26), 2 sigraw(14,img26),sigrawdt(14,img26),sigrawdd(14,img26)) c..mg26(a,n)si29 call rate_mg26an(btemp,bden, 1 sigraw(11,img26),sigrawdt(11,img26),sigrawdd(11,img26), 2 sigraw(12,img26),sigrawdt(12,img26),sigrawdd(12,img26)) end if c..for al25 if (ial25 .ne. 0) then c..al25(p,g)si26 call rate_al25pg(btemp,bden, 1 sigraw(7,ial25),sigrawdt(7,ial25),sigrawdd(7,ial25), 2 sigraw(8,ial25),sigrawdt(8,ial25),sigrawdd(8,ial25)) endif c..for al26 if (ial26 .ne. 0) then c..al26(p,g)si27 call rate_al26pg(btemp,bden, 1 sigraw(7,ial26),sigrawdt(7,ial26),sigrawdd(7,ial26), 2 sigraw(8,ial26),sigrawdt(8,ial26),sigrawdd(8,ial26)) end if c..for al27 if (ial27 .ne. 0) then c..al27(p,g)si28 call rate_al27pg(btemp,bden, 1 sigraw(7,ial27),sigrawdt(7,ial27),sigrawdd(7,ial27), 2 sigraw(8,ial27),sigrawdt(8,ial27),sigrawdd(8,ial27)) c..al27(a,n)p30 call rate_al27an(btemp,bden, 1 sigraw(11,ial27),sigrawdt(11,ial27),sigrawdd(11,ial27), 2 sigraw(12,ial27),sigrawdt(12,ial27),sigrawdd(12,ial27)) end if c..for si27 if (isi27 .ne. 0) then c..si27(p,g)p28 call rate_si27pg(btemp,bden, 1 sigraw(7,isi27),sigrawdt(7,isi27),sigrawdd(7,isi27), 2 sigraw(8,isi27),sigrawdt(8,isi27),sigrawdd(8,isi27)) end if c..for si28 if (isi28 .ne. 0) then c..si28(a,g)s32 call rate_si28ag(btemp,bden, 1 sigraw(13,isi28),sigrawdt(13,isi28),sigrawdd(13,isi28), 2 sigraw(14,isi28),sigrawdt(14,isi28),sigrawdd(14,isi28)) c..si28(p,g)p29 call rate_si28pg(btemp,bden, 1 sigraw(7,isi28),sigrawdt(7,isi28),sigrawdd(7,isi28), 2 sigraw(8,isi28),sigrawdt(8,isi28),sigrawdd(8,isi28)) end if c..for si29 if (isi29 .ne. 0) then c..si29(p,g)p30 call rate_si29pg(btemp,bden, 1 sigraw(7,isi29),sigrawdt(7,isi29),sigrawdd(7,isi29), 2 sigraw(8,isi29),sigrawdt(8,isi29),sigrawdd(8,isi29)) end if c..for si30 if (isi30 .ne. 0) then c..si30(p,g)p31 call rate_si30pg(btemp,bden, 1 sigraw(7,isi30),sigrawdt(7,isi30),sigrawdd(7,isi30), 2 sigraw(8,isi30),sigrawdt(8,isi30),sigrawdd(8,isi30)) end if c..bullet check the counting if (inap .ne. nrat) then write(6,*) write(6,*) 'in torchrat inap =',inap write(6,*) 'in torchrat nrat =',nrat write(6,*) 'inap is not equal to nrat' write(6,*) 'fatal counting error' write(6,*) stop 'fatal counting error in torchrat' end if return end subroutine vbean(jat,iat,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'burn_common.dek' include 'network.dek' include 'tfactors.dek' c..this routine generates nuclear reaction rates for the torch network c.. c..declare the pass integer jat,iat double precision fr,dfrdt,dfrdd,rr,drrdt,drrdd c..local variables integer j,k,jd1,jd2,jd3,jd4,jd5,jn,j1,j2,k0,k1,k2,k3, 1 k4,k5,k6,k7,k8,k9,jxx, 2 nrate,lk0,jk,lk1,lk2,lk3,lk4,lk5,lk6,lk7,lk8 double precision term,dtermdt,aa,daa,bb,dbb,cc,dcc,dd,ddd,ee,dee, 2 z c..initialize fr = 0.0d0 dfrdt = 0.0d0 dfrdd = 0.0d0 rr = 0.0d0 drrdt = 0.0d0 drrdd = 0.0d0 if (btemp .lt. 1.0e6) return c..set the reaction index j based on jat being c..even (reverse rates) or odd (foward rates) if (int(jat/2) .eq. int((jat+1)/2)) then j = jat/2 else j = max(1,(jat - 1)/2 + 1) end if c..set the location index jn jn = j if (jn - 3 .ge. 0) jn = j-1 c if (iat .eq. ina23 .and. jat .eq. 5) then c write(6,*) 'in vbean iat=',iat,jat,j,jn c write(6,*) nrr(jn,iat),ic1(j,iat) c 127 format(1x,1p6e14.6) c read(5,*) c end if c..bail if there is no link to the isotope or no stored formula coefficients if (nrr(jn,iat) .eq. 0 .or. ic1(j,iat) .eq. 0) return c..at most 10 fitting constants for strong and electromagnetic rates k = ic3(j,iat) k0 = k k1 = k + 1 k2 = k + 2 k3 = k + 3 k4 = k + 4 k5 = k + 5 k6 = k + 6 k7 = k + 7 k8 = k + 8 k9 = k + 9 c..ground state plus first excited state positron decay c..excited state assumed to be in thermal equilibrium if (ic1(j,iat) .eq. 6) then aa = cx(k2) * cx(k3) * exp(-11.60485d0*cx(k4)*t9i) daa = aa*11.60485d0*cx(k4)*t9i2 bb = cx(k0)*cx(k1) + aa dbb = daa cc = cx(k2)*exp(-11.60485d0*cx(k4)*t9i) dcc = cc*11.60485d0*cx(k4)*t9i2 dd = cx(k0) + cc ddd = dcc z = 1.0d0/dd ee = bb*z dee = (dbb - ee*ddd)*z rr = ee drrdt = dee * 1.0d-9 drrdd = 0.0d0 c..ground state beta decay else if (ic1(j,iat) .eq. 7) then fr = cx(k0) dfrdt = 0.0d0 dfrdd = 0.0d0 c..ground state positron decay or electron capture else if (ic1(j,iat) .eq. 8) then rr = cx(k0) drrdt = 0.0d0 drrdd = 0.0d0 c..rates from f.k.thielemann reaclib deck c..exoergic frwd (14), rev (15), beta- (16), and beta+ or ec (17) c..do not evaluate if t9.lt.0.01 else if (ic1(j,iat) .eq. 14 .or. 1 ic1(j,iat) .eq. 15 .or. 2 ic1(j,iat) .eq. 16 .or. 3 ic1(j,iat) .eq. 17 ) then if (t9 .ge. 0.01) then nrate = (ic2(j,iat)-2)/7 lk0 = k do jk=1,nrate lk1 = lk0 + 1 lk2 = lk1 + 1 lk3 = lk2 + 1 lk4 = lk3 + 1 lk5 = lk4 + 1 lk6 = lk5 + 1 lk7 = lk6 + 1 lk8 = lk7 + 1 aa = cx(lk0) + cx(lk1)*t9i + cx(lk2)*t9i13 1 + cx(lk3)*t913 + cx(lk4)*t9 + cx(lk5)*t953 2 + cx(lk6)*log(t9) daa = -cx(lk1)*t9i2 - oneth*cx(lk2)*t9i43 1 + oneth*cx(lk3)*t9i23 + cx(lk4) + fiveth*cx(lk5)*t923 2 + cx(lk6)*t9i if (aa .lt. 200.0) then term = exp(aa) dtermdt = term*daa*1.0d-9 else term = exp(200.0d0) dtermdt = 0.0d0 end if if (ic1(j,iat).eq.14) then fr = fr + term dfrdt = dfrdt + dtermdt end if if (ic1(j,iat).eq.15) then rr = rr + term drrdt = drrdt + dtermdt end if if (ic1(j,iat).eq.16) then fr = fr + term dfrdt = dfrdt + dtermdt end if if (ic1(j,iat).eq.17) then rr = rr + term drrdt = drrdt + dtermdt end if lk0 = lk0+7 enddo c..no rev rate for weak if (ic1(j,iat) .ge. 16 .or. ic1(j,iat) .eq. 17) return if (j.eq.2 .or. j.eq.5 .or. j.eq.6) then if (ic1(j,iat).eq.14) then z = 1.0d0/zwork1(nrr(jn,iat)) aa = zwork1(iat)*z daa = (zwork2(iat) - aa*zwork2(nrr(jn,iat)))*z bb = cx(lk7) * exp(-cx(lk8)*t9i) dbb = bb*cx(lk8)*t9i2 cc = aa*bb dcc = (daa*bb + aa*dbb) * 1.0d-9 c..forward rate dfrdd = fr fr = fr*bden dfrdt = dfrdt*bden c..reverse rate rr = fr*cc drrdt = dfrdt*cc + fr*dcc drrdd = dfrdd*cc else z = 1.0d0/zwork1(iat) aa = zwork1(nrr(jn,iat))*z daa = (zwork2(nrr(jn,iat)) - aa*zwork2(iat))*z bb = cx(lk7) * exp(-cx(lk8)*t9i) dbb = bb*cx(lk8)*t9i2 cc = aa*bb dcc = (daa*bb + aa*dbb) * 1.0d-9 c..reverse rate drrdd = rr rr = rr *bden drrdt = drrdt*bden c..forward rate fr = rr*cc dfrdt = drrdt*cc + rr*dcc drrdd = drrdd*cc endif else if (ic1(j,iat).eq.14) then aa = zwork1(iat)/zwork1(nrr(jn,iat)) daa = (zwork2(iat) - aa*zwork2(nrr(jn,iat))) 1 / zwork1(nrr(jn,iat)) bb = cx(lk7) * t932 * exp(-cx(lk8)*t9i) dbb = 1.5d0*bb*t9i + bb*cx(lk8)*t9i2 cc = aa*bb dcc = (daa*bb + aa*dbb) * 1.0d-9 c..reverse rate rr = fr*cc drrdt = dfrdt*cc + fr*dcc drrdd = 0.0d0 c..forward rate dfrdd = fr fr = fr*bden dfrdt = dfrdt*bden else aa = zwork1(nrr(jn,iat))/zwork1(iat) daa = (zwork2(nrr(jn,iat)) - aa*zwork2(iat))/zwork1(iat) bb = cx(lk7) * t932 * exp(-cx(lk8)*t9i) dbb = 1.5d0*bb*t9i + bb*cx(lk8)*t9i2 cc = aa*bb dcc = (daa*bb + aa*dbb) * 1.0d-9 c..forward rate fr = rr *cc dfrdt = drrdt*cc + rr*dcc drrdd = 0.0d0 c..reverse rate drrdd = rr rr = rr*bden drrdt = drrdt*bden end if end if endif c..particle capture rates (n,g), (p,g), (a,g) from rath 2000, c..these are treated specially because they have negative Q values else if (ic1(j,iat) .eq. 18) then if (t9 .ge. 0.01) then lk0 = k lk1 = lk0+1 lk2 = lk1+1 lk3 = lk2+1 lk4 = lk3+1 lk5 = lk4+1 lk6 = lk5+1 lk7 = lk6+1 lk8 = lk7+1 c..forward (x,g) rate aa = cx(lk0) + cx(lk1)*t9i + cx(lk2)*t9i13 1 + cx(lk3)*t913 + cx(lk4)*t9 + cx(lk5)*t953 2 + cx(lk6)*log(t9) daa = -cx(lk1)*t9i2 - oneth*cx(lk2)*t9i43 1 + oneth*cx(lk3)*t9i23 + cx(lk4) + fiveth*cx(lk5)*t923 2 + cx(lk6)*t9i bb = exp(aa) dbb = bb*daa fr = bden * bb dfrdt = bden * dbb * 1.0d-9 dfrdd = bb c..reverse (g,x) rate z = 1.0d0/zwork1(nrr(jn,iat)) aa = zwork1(iat)*z daa = (zwork2(iat) - aa*zwork2(nrr(jn,iat)))*z bb = cx(lk7) + cx(lk8)*t9i + cx(lk2)*t9i13 1 + cx(lk3)*t913 + cx(lk4)*t9 + cx(lk5)*t953 2 +(cx(lk6)+1.5)*log(t9) dbb = -cx(lk8)*t9i2 - oneth*cx(lk2)*t9i43 1 + oneth*cx(lk3)*t9i23 + cx(lk4) + fiveth*cx(lk5)*t923 2 + (cx(lk6)+1.5)*t9i cc = exp(bb) dcc = cc*dbb rr = cc*aa drrdt = (dcc*aa + cc*daa)*1.0d-9 drrdd = 0.0d0 endif c..g.s. 1 parameter alpha decay from nwc c..apply by adding to (g,a) reaction channel. c..The rate for alpha-decay is stored in nucleus c..card deck (z-2,a-4) in bdat. Ex: te106ad found c..in sn102 card deck just after sn102(a,g) c..just adding a constant, no changes to the derivatives else if (ic1(j,iat) .eq. 19) then fr = fr + cx(k0) c..or an unknown reaction else write(6,*) 'unknown ic1(j,iat)', j, iat, ic1(j,iat) stop 'unknown ic1(j,iat) in routine torchrat' end if return end subroutine torchtab(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. c..declare the pass double precision ye integer i,j,k,m,imax,iat,mp,mpo2,per_decade,ifirst parameter (mp = 4, mpo2 = mp/2, per_decade = 120) double precision 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)*per_decade + 1 if (imax .gt. nrattab) stop 'imax too small in torchtab' 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 m=1,imax btemp = tlo + float(m-1)*tstp btemp = 10.0d0**(btemp) call torchrat(ye) ttab(m) = btemp i = 0 do j=ionbeg,ionend c..(n,g) and (g,n) reactions k = nrr(1,j) if (k .gt. 0) then i = i + 1 rattab(i,m) = sigraw(1,j) drattabdt(i,m) = sigrawdt(1,j) drattabdd(i,m) = sigrawdd(1,j) i = i + 1 rattab(i,m) = sigraw(2,j) drattabdt(i,m) = sigrawdt(2,j) drattabdd(i,m) = sigrawdd(2,j) end if c..(p,n) beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then i = i + 1 rattab(i,m) = sigraw(3,j) drattabdt(i,m) = sigrawdt(3,j) drattabdd(i,m) = sigrawdd(3,j) i = i + 1 rattab(i,m) = sigraw(4,j) drattabdt(i,m) = sigrawdt(4,j) drattabdd(i,m) = sigrawdd(4,j) i = i + 1 rattab(i,m) = sigraw(5,j) drattabdt(i,m) = sigrawdt(5,j) drattabdd(i,m) = sigrawdd(5,j) i = i + 1 rattab(i,m) = sigraw(6,j) drattabdt(i,m) = sigrawdt(6,j) drattabdd(i,m) = sigrawdd(6,j) end if c..(p,g) and (g,p) reactions k = nrr(3,j) if (k .gt. 0) then i = i + 1 rattab(i,m) = sigraw(7,j) drattabdt(i,m) = sigrawdt(7,j) drattabdd(i,m) = sigrawdd(7,j) i = i + 1 rattab(i,m) = sigraw(8,j) drattabdt(i,m) = sigrawdt(8,j) drattabdd(i,m) = sigrawdd(8,j) end if c..(a,p) and (p,a) reactions k = nrr(4,j) if (k .gt. 0) then i = i + 1 rattab(i,m) = sigraw(9,j) drattabdt(i,m) = sigrawdt(9,j) drattabdd(i,m) = sigrawdd(9,j) i = i + 1 rattab(i,m) = sigraw(10,j) drattabdt(i,m) = sigrawdt(10,j) drattabdd(i,m) = sigrawdd(10,j) end if c..(a,n) and (n,a) reactions k = nrr(5,j) if (k .gt. 0) then i = i + 1 rattab(i,m) = sigraw(11,j) drattabdt(i,m) = sigrawdt(11,j) drattabdd(i,m) = sigrawdd(11,j) i = i + 1 rattab(i,m) = sigraw(12,j) drattabdt(i,m) = sigrawdt(12,j) drattabdd(i,m) = sigrawdd(12,j) end if c..(a,g) and (g,a) reactions k = nrr(6,j) if (k .gt. 0) then i = i + 1 rattab(i,m) = sigraw(13,j) drattabdt(i,m) = sigrawdt(13,j) drattabdd(i,m) = sigrawdd(13,j) i = i + 1 rattab(i,m) = sigraw(14,j) drattabdt(i,m) = sigrawdt(14,j) drattabdd(i,m) = sigrawdd(14,j) end if enddo c..for p(e-,nu)n and n(e+,nub)p reactions c..count them, but don't compute them here i = i + 1 rattab(i,m) = 0.0d0 drattabdt(i,m) = 0.0d0 drattabdd(i,m) = 0.0d0 i = i + 1 rattab(i,m) = 0.0d0 drattabdt(i,m) = 0.0d0 drattabdd(i,m) = 0.0d0 c..c12 reactions, first triple alpha if (ic12 .ne. 0) then i = i + 1 rattab(i,m) = ratraw(ir3a) drattabdt(i,m) = dratrawdt(ir3a) drattabdd(i,m) = dratrawdd(ir3a) i = i + 1 rattab(i,m) = ratraw(irg3a) drattabdt(i,m) = dratrawdt(irg3a) drattabdd(i,m) = dratrawdd(irg3a) c..c12+c12 reactions; must have ne20, na23, mg23 in the network if (ine20 .ne. 0 .and. ina23 .ne. 0 .and. img23 .ne. 0) then i = i + 1 rattab(i,m) = ratraw(ir1212n) drattabdt(i,m) = dratrawdt(ir1212n) drattabdd(i,m) = dratrawdd(ir1212n) i = i + 1 rattab(i,m) = ratraw(irmg23nc) drattabdt(i,m) = dratrawdt(irmg23nc) drattabdd(i,m) = dratrawdd(irmg23nc) i = i + 1 rattab(i,m) = ratraw(ir1212p) drattabdt(i,m) = dratrawdt(ir1212p) drattabdd(i,m) = dratrawdd(ir1212p) i = i + 1 rattab(i,m) = ratraw(irna23pc) drattabdt(i,m) = dratrawdt(irna23pc) drattabdd(i,m) = dratrawdd(irna23pc) i = i + 1 rattab(i,m) = ratraw(ir1212a) drattabdt(i,m) = dratrawdt(ir1212a) drattabdd(i,m) = dratrawdd(ir1212a) i = i + 1 rattab(i,m) = ratraw(irne20ac) drattabdt(i,m) = dratrawdt(irne20ac) drattabdd(i,m) = dratrawdd(irne20ac) end if end if c..o16+o16 reactions; must have si28, p 30, p31 and s31 in the network if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then i = i + 1 rattab(i,m) = ratraw(ir1616n) drattabdt(i,m) = dratrawdt(ir1616n) drattabdd(i,m) = dratrawdd(ir1616n) i = i + 1 rattab(i,m) = ratraw(irs31no) drattabdt(i,m) = dratrawdt(irs31no) drattabdd(i,m) = dratrawdd(irs31no) i = i + 1 rattab(i,m) = ratraw(ir1616p) drattabdt(i,m) = dratrawdt(ir1616p) drattabdd(i,m) = dratrawdd(ir1616p) i = i + 1 rattab(i,m) = ratraw(irp31po) drattabdt(i,m) = dratrawdt(irp31po) drattabdd(i,m) = dratrawdd(irp31po) i = i + 1 rattab(i,m) = ratraw(ir1616a) drattabdt(i,m) = dratrawdt(ir1616a) drattabdd(i,m) = dratrawdd(ir1616a) i = i + 1 rattab(i,m) = ratraw(irsi28ao) drattabdt(i,m) = dratrawdt(irsi28ao) drattabdd(i,m) = dratrawdd(irsi28ao) i = i + 1 rattab(i,m) = ratraw(ir1616d) drattabdt(i,m) = dratrawdt(ir1616d) drattabdd(i,m) = dratrawdd(ir1616d) i = i + 1 rattab(i,m) = ratraw(irp30do) drattabdt(i,m) = dratrawdt(irp30do) drattabdd(i,m) = dratrawdd(irp30do) end if c..c12+o16 reactions; must have mg24, al27, si27 in the network if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then i = i + 1 rattab(i,m) = ratraw(ir1216n) drattabdt(i,m) = dratrawdt(ir1216n) drattabdd(i,m) = dratrawdd(ir1216n) i = i + 1 rattab(i,m) = ratraw(irsi27no) drattabdt(i,m) = dratrawdt(irsi27no) drattabdd(i,m) = dratrawdd(irsi27no) i = i + 1 rattab(i,m) = ratraw(ir1216p) drattabdt(i,m) = dratrawdt(ir1216p) drattabdd(i,m) = dratrawdd(ir1216p) i = i + 1 rattab(i,m) = ratraw(iral27po) drattabdt(i,m) = dratrawdt(iral27po) drattabdd(i,m) = dratrawdd(iral27po) i = i + 1 rattab(i,m) = ratraw(ir1216a) drattabdt(i,m) = dratrawdt(ir1216a) drattabdd(i,m) = dratrawdd(ir1216a) i = i + 1 rattab(i,m) = ratraw(irmg24ao) drattabdt(i,m) = dratrawdt(irmg24ao) drattabdd(i,m) = dratrawdd(irmg24ao) end if c..proton-proton and neutron capture on proton reactions if (ih2 .ne. 0) then c..pp i = i + 1 rattab(i,m) = ratraw(irpp) drattabdt(i,m) = dratrawdt(irpp) drattabdd(i,m) = dratrawdd(irpp) i = i + 1 rattab(i,m) = ratraw(irpep) drattabdt(i,m) = dratrawdt(irpep) drattabdd(i,m) = dratrawdd(irpep) c..p(n,g)d i = i + 1 rattab(i,m) = ratraw(irpng) drattabdt(i,m) = dratrawdt(irpng) drattabdd(i,m) = dratrawdd(irpng) i = i + 1 rattab(i,m) = ratraw(irdgn) drattabdt(i,m) = dratrawdt(irdgn) drattabdd(i,m) = dratrawdd(irdgn) c..d(p,n)2p i = i + 1 rattab(i,m) = ratraw(irdpn) drattabdt(i,m) = dratrawdt(irdpn) drattabdd(i,m) = dratrawdd(irdpn) i = i + 1 rattab(i,m) = ratraw(ir2pnp) drattabdt(i,m) = dratrawdt(ir2pnp) drattabdd(i,m) = dratrawdd(ir2pnp) c..d(d,g)he4 i = i + 1 rattab(i,m) = ratraw(irddg) drattabdt(i,m) = dratrawdt(irddg) drattabdd(i,m) = dratrawdd(irddg) i = i + 1 rattab(i,m) = ratraw(irhe4gd) drattabdt(i,m) = dratrawdt(irhe4gd) drattabdd(i,m) = dratrawdd(irhe4gd) end if if (ih3 .ne. 0) then c..d(d,p)t i = i + 1 rattab(i,m) = ratraw(irddp) drattabdt(i,m) = dratrawdt(irddp) drattabdd(i,m) = dratrawdd(irddp) i = i + 1 rattab(i,m) = ratraw(irtpd) drattabdt(i,m) = dratrawdt(irtpd) drattabdd(i,m) = dratrawdd(irtpd) c..t(p,g)he4 i = i + 1 rattab(i,m) = ratraw(irh3pg) drattabdt(i,m) = dratrawdt(irh3pg) drattabdd(i,m) = dratrawdd(irh3pg) i = i + 1 rattab(i,m) = ratraw(irhe4gp) drattabdt(i,m) = dratrawdt(irhe4gp) drattabdd(i,m) = dratrawdd(irhe4gp) c..t(d,n)he4 reaction i = i + 1 rattab(i,m) = ratraw(irtdn) drattabdt(i,m) = dratrawdt(irtdn) drattabdd(i,m) = dratrawdd(irtdn) i = i + 1 rattab(i,m) = ratraw(irhe4nd) drattabdt(i,m) = dratrawdt(irhe4nd) drattabdd(i,m) = dratrawdd(irhe4nd) c..t(t,2n)he4 i = i + 1 rattab(i,m) = ratraw(irtt2n) drattabdt(i,m) = dratrawdt(irtt2n) drattabdd(i,m) = dratrawdd(irtt2n) i = i + 1 rattab(i,m) = ratraw(irhe42nt) drattabdt(i,m) = dratrawdt(irhe42nt) drattabdd(i,m) = dratrawdd(irhe42nt) end if if (ihe3 .ne. 0) then c..he3(he3,2p)he4 i = i + 1 rattab(i,m) = ratraw(ir33) drattabdt(i,m) = dratrawdt(ir33) drattabdd(i,m) = dratrawdd(ir33) i = i + 1 rattab(i,m) = ratraw(ir33inv) drattabdt(i,m) = dratrawdt(ir33inv) drattabdd(i,m) = dratrawdd(ir33inv) c..he3(p,e+nu)he4 i = i + 1 rattab(i,m) = ratraw(irhep) drattabdt(i,m) = dratrawdt(irhep) drattabdd(i,m) = dratrawdd(irhep) c..he3(n,g)he4 i = i + 1 rattab(i,m) = ratraw(irhe3ng) drattabdt(i,m) = dratrawdt(irhe3ng) drattabdd(i,m) = dratrawdd(irhe3ng) i = i + 1 rattab(i,m) = ratraw(irhe4gn) drattabdt(i,m) = dratrawdt(irhe4gn) drattabdd(i,m) = dratrawdd(irhe4gn) c..he3(d,p)he4 i = i + 1 rattab(i,m) = ratraw(irhe3dp) drattabdt(i,m) = dratrawdt(irhe3dp) drattabdd(i,m) = dratrawdd(irhe3dp) i = i + 1 rattab(i,m) = ratraw(irhe4pd) drattabdt(i,m) = dratrawdt(irhe4pd) drattabdd(i,m) = dratrawdd(irhe4pd) c..d(d,n)he3 i = i + 1 rattab(i,m) = ratraw(irddn) drattabdt(i,m) = dratrawdt(irddn) drattabdd(i,m) = dratrawdd(irddn) i = i + 1 rattab(i,m) = ratraw(irhe3nd) drattabdt(i,m) = dratrawdt(irhe3nd) drattabdd(i,m) = dratrawdd(irhe3nd) c..he3(t,d)he4 i = i + 1 rattab(i,m) = ratraw(irhe3td) drattabdt(i,m) = dratrawdt(irhe3td) drattabdd(i,m) = dratrawdd(irhe3td) i = i + 1 rattab(i,m) = ratraw(irhe4dt) drattabdt(i,m) = dratrawdt(irhe4dt) drattabdd(i,m) = dratrawdd(irhe4dt) c..he3(t,np)he4 i = i + 1 rattab(i,m) = ratraw(irhe3tnp) drattabdt(i,m) = dratrawdt(irhe3tnp) drattabdd(i,m) = dratrawdd(irhe3tnp) end if if (ili7 .ne. 0) then c..li7(t,2n)2a i = i + 1 rattab(i,m) = ratraw(irli7t2n) drattabdt(i,m) = dratrawdt(irli7t2n) drattabdd(i,m) = dratrawdd(irli7t2n) c..li7(p,g)be8 and li7(p,a)he4 i = i + 1 rattab(i,m) = ratraw(irli7pag) drattabdt(i,m) = dratrawdt(irli7pag) drattabdd(i,m) = dratrawdd(irli7pag) i = i + 1 rattab(i,m) = ratraw(ir2he4ga) drattabdt(i,m) = dratrawdt(ir2he4ga) drattabdd(i,m) = dratrawdd(ir2he4ga) c..li7(d,n)2a i = i + 1 rattab(i,m) = ratraw(irli7dn) drattabdt(i,m) = dratrawdt(irli7dn) drattabdd(i,m) = dratrawdd(irli7dn) c..li7(he3,np)2a i = i + 1 rattab(i,m) = ratraw(irli7he3np) drattabdt(i,m) = dratrawdt(irli7he3np) drattabdd(i,m) = dratrawdd(irli7he3np) end if if (ibe7 .ne. 0) then c..be7(d,p)2a i = i + 1 rattab(i,m) = ratraw(irbe7dp) drattabdt(i,m) = dratrawdt(irbe7dp) drattabdd(i,m) = dratrawdd(irbe7dp) c..be7(t,np)2a i = i + 1 rattab(i,m) = ratraw(irbe7tnp) drattabdt(i,m) = dratrawdt(irbe7tnp) drattabdd(i,m) = dratrawdd(irbe7tnp) c..be7(he3,2p)2a i = i + 1 rattab(i,m) = ratraw(irbe7he32p) drattabdt(i,m) = dratrawdt(irbe7he32p) drattabdd(i,m) = dratrawdd(irbe7he32p) end if if (ibe9 .ne. 0) then c..a(an,g)be9 i = i + 1 rattab(i,m) = ratraw(iraan) drattabdt(i,m) = dratrawdt(iraan) drattabdd(i,m) = dratrawdd(iraan) i = i + 1 rattab(i,m) = ratraw(irgaan) drattabdt(i,m) = dratrawdt(irgaan) drattabdd(i,m) = dratrawdd(irgaan) c..be9(p,d)be8 =>2a i = i + 1 rattab(i,m) = ratraw(irbe9pd) drattabdt(i,m) = dratrawdt(irbe9pd) drattabdd(i,m) = dratrawdd(irbe9pd) end if if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions i = i + 1 rattab(i,m) = ratraw(irb8ep) drattabdt(i,m) = dratrawdt(irb8ep) drattabdd(i,m) = dratrawdd(irb8ep) end if if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions i = i + 1 rattab(i,m) = ratraw(irb11pa) drattabdt(i,m) = dratrawdt(irb11pa) drattabdd(i,m) = dratrawdd(irb11pa) i = i + 1 rattab(i,m) = ratraw(ir3ap) drattabdt(i,m) = dratrawdt(ir3ap) drattabdd(i,m) = dratrawdd(ir3ap) end if if (ic11 .ne. 0) then c..c11(na)be8 => 2a i = i + 1 rattab(i,m) = ratraw(irc11na) drattabdt(i,m) = dratrawdt(irc11na) drattabdd(i,m) = dratrawdd(irc11na) end if c..bullet check the counting if (i .ne. nrat) then write(6,*) 'in torchtab i=',i write(6,*) 'in torchtab nrat=',nrat write(6,*) 'i is not equal to nrat' write(6,*) 'fatal counting error making table in torchtab' write(6,*) stop 'fatal counting error in torchtab' end if c..end of temperature do loop enddo c..restore the input bden = bden_sav btemp = btemp_sav ye = ye_sav end if c..normal execution starts here c..get the temperature factors call tfactors(btemp) c..set the density dependence vector i = 0 do j=ionbeg,ionend c..(n,g) and (g,n) reactions k = nrr(1,j) if (k .gt. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 end if c..(p,n) beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 i = i + 1 dtab(i) = 1.0d0 end if c..(p,g) and (g,p) reactions k = nrr(3,j) if (k .gt. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 end if c..(a,p) and (p,a) reactions k = nrr(4,j) if (k .gt. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden end if c..(a,n) and (n,a) reactions k = nrr(5,j) if (k .gt. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden end if c..(a,g) and (g,a) reactions k = nrr(6,j) if (k .gt. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 end if enddo c..for p(e-,nu)n and n(e+,nub)p reactions c..count them, but don't compute them here i = i + 1 dtab(i) = 1.0d0 i = i + 1 dtab(i) = 1.0d0 c..c12 reactions, first triple alpha if (ic12 .ne. 0) then i = i + 1 dtab(i) = bden*bden i = i + 1 dtab(i) = 1.0d0 c..c12+c12 reactions; must have ne20, na23, mg23 in the network if (ine20 .ne. 0 .and. ina23 .ne. 0 .and. img23 .ne. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden end if end if c..o16+o16 reactions; must have si28, p 30, p31 and s31 in the network if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden end if c..c12+o16 reactions; must have mg24, al27, si27 in the network if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden end if if (ih2 .ne. 0) then c..p(p,e+nu)d i = i + 1 dtab(i) = bden c..p(e-p,nu)d i = i + 1 dtab(i) = ye*bden*bden c..p(n,g)d i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 c..d(p,n)2p i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..d(d,g)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 end if if (ih3 .ne. 0) then c..d(d,p)t i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..t(p,g)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 c..t(d,n)he4 reaction i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..t(t,2n)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden end if if (ihe3 .ne. 0) then c..he3(he3,2p)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..he3(p,e-nu)he4 i = i + 1 dtab(i) = bden c..he3(n,g)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 c..he3(d,p)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..d(d,n)he3 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..he3(t,d)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..he3(t,np)he4 i = i + 1 dtab(i) = bden end if if (ili7 .ne. 0) then c..li7(t,2n)2a i = i + 1 dtab(i) = bden c..li7(p,g)be8 and li7(p,a)he4 i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = bden c..li7(d,n)2a i = i + 1 dtab(i) = bden c..li7(he3,np)2a i = i + 1 dtab(i) = bden end if if (ibe7 .ne. 0) then c..be7 reactions i = i + 1 dtab(i) = bden c..be7(t,np)2a i = i + 1 dtab(i) = bden c..be7(he3,2p)2a i = i + 1 dtab(i) = bden end if if (ibe9 .ne. 0) then c..a(an,g)be9 i = i + 1 dtab(i) = bden*bden i = i + 1 dtab(i) = 1.0d0 c..be9(p,d)be8 =>2a i = i + 1 dtab(i) = bden end if if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions i = i + 1 dtab(i) = 1.0d0 end if if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions i = i + 1 dtab(i) = bden i = i + 1 dtab(i) = 1.0d0 end if if (ic11 .ne. 0) then c..c11(na)be8 => 2a i = i + 1 dtab(i) = bden end if c..bullet check the counting if (i .ne. nrat) then write(6,*) write(6,*) 'in torchtab i=',i write(6,*) 'in torchtab nrat=',nrat write(6,*) 'i is not equal to nrat' write(6,*) 'fatal counting error filling dtab in torchtab' write(6,*) stop 'fatal counting error in filling dtab in torchtab' end if c..hash locate the temperature iat = int((log10(btemp) - tlo)/tstp) + 1 iat = max(1,min(iat - mpo2 + 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 reactions if (ir3a .ne. 0) dratrawdd(ir3a) = bden * dratrawdd(ir3a) if (iraan .ne. 0) dratrawdd(iraan) = bden * dratrawdd(iraan) if (irpep .ne.0) dratrawdd(irpep) = ye * bden * dratrawdd(irpep) c..positive definite do j=1,nrat if (ratraw(j) .le. 0.0) then ratraw(j) = 0.0d0 dratrawdt(j) = 0.0d0 dratrawdd(j) = 0.0d0 end if enddo c..finally fill the sigraw array i = 0 do j=ionbeg,ionend c..(n,g) and (g,n) reactions k = nrr(1,j) if (k .gt. 0) then i = i + 1 sigraw(1,j) = ratraw(i) sigrawdt(1,j) = dratrawdt(i) sigrawdd(1,j) = dratrawdd(i) i = i + 1 sigraw(2,j) = ratraw(i) sigrawdt(2,j) = dratrawdt(i) sigrawdd(2,j) = dratrawdd(i) end if c..(p,n) beta- beta+ decay components k = nrr(2,j) if (k .gt. 0) then i = i + 1 sigraw(3,j) = ratraw(i) sigrawdt(3,j) = dratrawdt(i) sigrawdd(3,j) = dratrawdd(i) i = i + 1 sigraw(4,j) = ratraw(i) sigrawdt(4,j) = dratrawdt(i) sigrawdd(4,j) = dratrawdd(i) i = i + 1 sigraw(5,j) = ratraw(i) sigrawdt(5,j) = dratrawdt(i) sigrawdd(5,j) = dratrawdd(i) i = i + 1 sigraw(6,j) = ratraw(i) sigrawdt(6,j) = dratrawdt(i) sigrawdd(6,j) = dratrawdd(i) end if c..(p,g) and (g,p) reactions k = nrr(3,j) if (k .gt. 0) then i = i + 1 sigraw(7,j) = ratraw(i) sigrawdt(7,j) = dratrawdt(i) sigrawdd(7,j) = dratrawdd(i) i = i + 1 sigraw(8,j) = ratraw(i) sigrawdt(8,j) = dratrawdt(i) sigrawdd(8,j) = dratrawdd(i) end if c..(a,p) and (p,a) reactions k = nrr(4,j) if (k .gt. 0) then i = i + 1 sigraw(9,j) = ratraw(i) sigrawdt(9,j) = dratrawdt(i) sigrawdd(9,j) = dratrawdd(i) i = i + 1 sigraw(10,j) = ratraw(i) sigrawdt(10,j) = dratrawdt(i) sigrawdd(10,j) = dratrawdd(i) end if c..(a,n) and (n,a) reactions k = nrr(5,j) if (k .gt. 0) then i = i + 1 sigraw(11,j) = ratraw(i) sigrawdt(11,j) = dratrawdt(i) sigrawdd(11,j) = dratrawdd(i) i = i + 1 sigraw(12,j) = ratraw(i) sigrawdt(12,j) = dratrawdt(i) sigrawdd(12,j) = dratrawdd(i) end if c..(a,g) and (g,a) reactions k = nrr(6,j) if (k .gt. 0) then i = i + 1 sigraw(13,j) = ratraw(i) sigrawdt(13,j) = dratrawdt(i) sigrawdd(13,j) = dratrawdd(i) i = i + 1 sigraw(14,j) = ratraw(i) sigrawdt(14,j) = dratrawdt(i) sigrawdd(14,j) = dratrawdd(i) end if enddo c..bullet check the counting c if (i .ne. nsigrat) then c write(6,*) c write(6,*) 'in torchtab i=',i c write(6,*) 'in torchtab nsigrat=',nsigrat c write(6,*) 'i is not equal to nsigrat' c write(6,*) 'fatal counting error filling sig in torchtab' c write(6,*) c stop 'fatal counting error in filling sig torchtab' c end if c..hand finish the weak reactions if (ili7 .ne. 0) then sigraw(6,ili7) = ye * bden * sigraw(6,ili7) sigrawdt(6,ili7) = ye * bden * sigrawdt(6,ili7) sigrawdd(6,ili7) = ye * bden * sigrawdd(6,ili7) endif return end subroutine screen_torch(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..declare the pass double precision y(*) c..loc al variables integer i,j,k,jscr double precision abar,zbar,z2bar,ytot1,zbarxx,z2barxx, 1 scfacp,scfacpdt,scfacpdd, 2 scfaca,scfacadt,scfacadd integer nscreen_max parameter (nscreen_max = 2*abignet + 40) double precision zsc1(nscreen_max),asc1(nscreen_max), 1 zsc2(nscreen_max),asc2(nscreen_max), 2 scvec(nscreen_max), 3 scvecdt(nscreen_max), 4 scvecdd(nscreen_max) double precision scpp,scppdt,scppdd,sc1a,sc1adt,sc1add, 1 sc2a,sc2adt,sc2add,sc3a,sc3adt,sc3add, 2 sc1212,sc1212dt,sc1212dd, 3 sc1216,sc1216dt,sc1216dd, 4 sc1616,sc1616dt,sc1616dd, 5 scdt,scdtdt,scdtdd,sch3p,sch3pdt,sch3pdd, 6 sctt,scttdt,scttdd,sc33,sc33dt,sc33dd, 7 sche3d,sche3ddt,sche3ddd, 8 sche3t,sche3tdt,sche3tdd, 9 sche4p,sche4pdt,sche4pdd, & scli7d,scli7ddt,scli7ddd, 1 scli7t,scli7tdt,scli7tdd, 2 scli7he3,scli7he3dt,scli7he3dd, 3 scbe7d,scbe7ddt,scbe7ddd, 4 scbe7t,scbe7tdt,scbe7tdd, 5 scbe7he3,scbe7he3dt,scbe7he3dd, 6 sche4d,sche4ddt,sche4ddd,sche3p,sche3pdt,sche3pdd c..initialize the screening factors do j=ionbeg,ionend scvec(j) = 1.0d0 scvecdt(j) = 0.0d0 scvecdd(j) = 0.0d0 enddo scfacp = 1.0d0 scfacpdt = 0.0d0 scfacpdd = 0.0d0 scfaca = 1.0d0 scfacadt = 0.0d0 scfacadd = 0.0d0 scpp = 1.0d0 scppdt = 0.0d0 scppdd = 0.0d0 sc1a = 1.0d0 sc1adt = 0.0d0 sc1add = 0.0d0 sc2a = 1.0d0 sc2adt = 0.0d0 sc2add = 0.0d0 sc3a = 1.0d0 sc3adt = 0.0d0 sc3add = 0.0d0 sc1212 = 1.0d0 sc1212dt = 0.0d0 sc1212dd = 0.0d0 sc1216 = 1.0d0 sc1216dt = 0.0d0 sc1216dd = 0.0d0 sc1616 = 1.0d0 sc1616dt = 0.0d0 sc1616dd = 0.0d0 scdt = 1.0d0 scdtdt = 0.0d0 scdtdd = 0.0d0 sch3p = 1.0d0 sch3pdt = 0.0d0 sch3pdd = 0.0d0 sctt = 1.0d0 scttdt = 0.0d0 scttdd = 0.0d0 sc33 = 1.0d0 sc33dt = 0.0d0 sc33dd = 0.0d0 sche3p = 1.0d0 sche3pdt = 0.0d0 sche3pdd = 0.0d0 sche3d = 1.0d0 sche3ddt = 0.0d0 sche3ddd = 0.0d0 sche3t = 1.0d0 sche3tdt = 0.0d0 sche3tdd = 0.0d0 sche4p = 1.0d0 sche4pdt = 0.0d0 sche4pdd = 0.0d0 scli7d = 1.0d0 scli7ddt = 0.0d0 scli7ddd = 0.0d0 scli7t = 1.0d0 scli7tdt = 0.0d0 scli7tdd = 0.0d0 scli7he3 = 1.0d0 scli7he3dt = 0.0d0 scli7he3dd = 0.0d0 scbe7d = 1.0d0 scbe7ddt = 0.0d0 scbe7ddd = 0.0d0 scbe7t = 1.0d0 scbe7tdt = 0.0d0 scbe7tdd = 0.0d0 scbe7he3 = 1.0d0 scbe7he3dt = 0.0d0 scbe7he3dd = 0.0d0 c..if screening corrections are on if (screen_on .eq. 1) 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..load the screening pipeline jscr = 0 do j=ionbeg,ionend jscr = jscr + 1 zsc1(jscr) = zion(j) asc1(jscr) = aion(j) zsc2(jscr) = zion(iprot) asc2(jscr) = aion(iprot) jscr = jscr + 1 zsc1(jscr) = zion(j) asc1(jscr) = aion(j) zsc2(jscr) = zion(ihe4) asc2(jscr) = aion(ihe4) enddo c..now get the specials c..pp jscr = jscr + 1 zsc1(jscr) = zion(iprot) asc1(jscr) = aion(iprot) zsc2(jscr) = zion(iprot) asc2(jscr) = aion(iprot) c..triple alpha jscr = jscr + 1 zsc1(jscr) = zion(ihe4) asc1(jscr) = aion(ihe4) zsc2(jscr) = zion(ihe4) asc2(jscr) = aion(ihe4) jscr = jscr + 1 zsc1(jscr) = zion(ihe4) asc1(jscr) = aion(ihe4) zsc2(jscr) = 4.0d0 asc2(jscr) = 8.0d0 c..c12 + c12 if (ic12 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ic12) asc1(jscr) = aion(ic12) zsc2(jscr) = zion(ic12) asc2(jscr) = aion(ic12) end if c..c12 + o16 if (ic12 .ne. 0 .and. io16 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ic12) asc1(jscr) = aion(ic12) zsc2(jscr) = zion(io16) asc2(jscr) = aion(io16) end if c..o16 + o16 if (io16 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(io16) asc1(jscr) = aion(io16) zsc2(jscr) = zion(io16) asc2(jscr) = aion(io16) end if c..d + t if (ih2 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ih2) asc1(jscr) = aion(ih2) zsc2(jscr) = zion(ih3) asc2(jscr) = aion(ih3) end if c..h3 + p if (ih3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ih3) asc1(jscr) = aion(ih3) zsc2(jscr) = zion(iprot) asc2(jscr) = aion(iprot) jscr = jscr + 1 zsc1(jscr) = zion(ih3) asc1(jscr) = aion(ih3) zsc2(jscr) = zion(ih3) asc2(jscr) = aion(ih3) end if c..he3 + he3 if (ihe3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ihe3) asc1(jscr) = aion(ihe3) zsc2(jscr) = zion(ihe3) asc2(jscr) = aion(ihe3) c..he3 + p jscr = jscr + 1 zsc1(jscr) = zion(ihe3) asc1(jscr) = aion(ihe3) zsc2(jscr) = zion(iprot) asc2(jscr) = aion(iprot) end if c..he3 + d if (ihe3 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ihe3) asc1(jscr) = aion(ihe3) zsc2(jscr) = zion(ih2) asc2(jscr) = aion(ih2) jscr = jscr + 1 zsc1(jscr) = zion(ihe4) asc1(jscr) = aion(ihe4) zsc2(jscr) = zion(iprot) asc2(jscr) = aion(iprot) end if c..he3 + t if (ihe3 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ihe3) asc1(jscr) = aion(ihe3) zsc2(jscr) = zion(ih3) asc2(jscr) = aion(ih3) jscr = jscr + 1 zsc1(jscr) = zion(ihe4) asc1(jscr) = aion(ihe4) zsc2(jscr) = zion(ih2) asc2(jscr) = aion(ih2) end if c..li7(d,n)2a if (ili7 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ili7) asc1(jscr) = aion(ili7) zsc2(jscr) = zion(ih2) asc2(jscr) = aion(ih2) end if c..li7(t,2n)2a if (ili7 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ili7) asc1(jscr) = aion(ili7) zsc2(jscr) = zion(ih3) asc2(jscr) = aion(ih3) end if c..li7(he3,np)2a if (ili7 .ne. 0 .and. ihe3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ili7) asc1(jscr) = aion(ili7) zsc2(jscr) = zion(ihe3) asc2(jscr) = aion(ihe3) end if c..be7(d,p)2a if (ibe7 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ibe7) asc1(jscr) = aion(ibe7) zsc2(jscr) = zion(ih2) asc2(jscr) = aion(ih2) end if c..be7(t,np)2a if (ibe7 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ibe7) asc1(jscr) = aion(ibe7) zsc2(jscr) = zion(ih3) asc2(jscr) = aion(ih3) end if c..be7(he3,2p)2a if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then jscr = jscr + 1 zsc1(jscr) = zion(ibe7) asc1(jscr) = aion(ibe7) zsc2(jscr) = zion(ihe3) asc2(jscr) = aion(ihe3) end if c..make sure we are within the bounds allocated if (jscr .gt. nscreen_max) then write(6,*) 'jscr=',jscr,' nscreen_max=',nscreen_max stop 'jscr > nscreen_max in routine screen_torch' end if c..get all the screening factors call screen6(jscr, 1 btemp,bden,zbar,abar,z2bar, 2 zsc1,asc1,zsc2,asc2, 3 scvec,scvecdt,scvecdd) c..end of screen_on if end if c..apply the screening factors and store stuff i = 0 jscr = 0 do j=ionbeg,ionend if (screen_on .eq. 1) then jscr = jscr + 1 scfacp = scvec(jscr) scfacpdt = scvecdt(jscr) scfacpdd = scvecdd(jscr) jscr = jscr + 1 scfaca = scvec(jscr) scfacadt = scvecdt(jscr) scfacadd = scvecdd(jscr) end if c..(n,g) and (g,n) reactions c..no screening here k = nrr(1,j) if (k .gt. 0) then i = i + 1 sig(1,j) = sigraw(1,j) sigdt(1,j) = sigrawdt(1,j) sigdd(1,j) = sigrawdd(1,j) ratraw(i) = sigraw(1,j) dratrawdt(i) = sigrawdt(1,j) dratrawdd(i) = sigrawdd(1,j) ratdum(i) = sig(1,j) dratdumdt(i) = sigdt(1,j) dratdumdd(i) = sigdd(1,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 i = i + 1 sig(2,j) = sigraw(2,j) sigdt(2,j) = sigrawdt(2,j) sigdd(2,j) = sigrawdd(2,j) ratraw(i) = sigraw(2,j) dratrawdt(i) = sigrawdt(2,j) dratrawdd(i) = sigrawdd(2,j) ratdum(i) = sig(2,j) dratdumdt(i) = sigdt(2,j) dratdumdd(i) = sigdd(2,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if c..set up the (p,n) beta- beta+ decay components c..screen the (p,n) reactions c..do not screen the (n,p) reactions, c..thielemann & truran, advances in nuclear astrophysics, 1986 k = nrr(2,j) if (k .gt. 0) then i = i + 1 sig(3,j) = sigraw(3,j) * scfacp sigdt(3,j) = sigrawdt(3,j)*scfacp + sigraw(3,j)*scfacpdt sigdd(3,j) = sigrawdd(3,j)*scfacp + sigraw(3,j)*scfacpdd ratraw(i) = sigraw(3,j) dratrawdt(i) = sigrawdt(3,j) dratrawdd(i) = sigrawdd(3,j) ratdum(i) = sig(3,j) dratdumdt(i) = sigdt(3,j) dratdumdd(i) = sigdd(3,j) scfac(i) = scfacp dscfacdt(i) = scfacpdt dscfacdd(i) = scfacpdd i = i + 1 sig(4,j) = sigraw(4,j) sigdt(4,j) = sigrawdt(4,j) sigdd(4,j) = sigrawdd(4,j) ratraw(i) = sigraw(4,j) dratrawdt(i) = sigrawdt(4,j) dratrawdd(i) = sigrawdd(4,j) ratdum(i) = sig(4,j) dratdumdt(i) = sigdt(4,j) dratdumdd(i) = sigdd(4,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 i = i + 1 sig(5,j) = sigraw(5,j) sigdt(5,j) = sigrawdt(5,j) sigdd(5,j) = sigrawdd(5,j) ratraw(i) = sigraw(5,j) dratrawdt(i) = sigrawdt(5,j) dratrawdd(i) = sigrawdd(5,j) ratdum(i) = sig(5,j) dratdumdt(i) = sigdt(5,j) dratdumdd(i) = sigdd(5,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 i = i + 1 sig(6,j) = sigraw(6,j) sigdt(6,j) = sigrawdt(6,j) sigdd(6,j) = sigrawdd(6,j) ratraw(i) = sigraw(6,j) dratrawdt(i) = sigrawdt(6,j) dratrawdd(i) = sigrawdd(6,j) ratdum(i) = sig(6,j) dratdumdt(i) = sigdt(6,j) dratdumdd(i) = sigdd(6,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if c..(p,g) and (g,p) reactions c..screen the (p,g) reactions c..do not screen (g,p) reactions k = nrr(3,j) if (k .gt. 0) then i = i + 1 sig(7,j) = sigraw(7,j) * scfacp sigdt(7,j) = sigrawdt(7,j)*scfacp + sigraw(7,j)*scfacpdt sigdd(7,j) = sigrawdd(7,j)*scfacp + sigraw(7,j)*scfacpdd ratraw(i) = sigraw(7,j) dratrawdt(i) = sigrawdt(7,j) dratrawdd(i) = sigrawdd(7,j) ratdum(i) = sig(7,j) dratdumdt(i) = sigdt(7,j) dratdumdd(i) = sigdd(7,j) scfac(i) = scfacp dscfacdt(i) = scfacpdt dscfacdd(i) = scfacpdd i = i + 1 sig(8,j) = sigraw(8,j) sigdt(8,j) = sigrawdt(8,j) sigdd(8,j) = sigrawdd(8,j) ratraw(i) = sigraw(8,j) dratrawdt(i) = sigrawdt(8,j) dratrawdd(i) = sigrawdd(8,j) ratdum(i) = sig(8,j) dratdumdt(i) = sigdt(8,j) dratdumdd(i) = sigdd(8,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if c..(a,p) and (p,a) reactions c..this case is complicated because of two charged particles in c..the entrance and exit channels. for now we will c..screen the (a,p) reactions with scfaca(j) c..screen the (p,a) reactions with scfacp(j) k = nrr(4,j) if (k .gt. 0) then i = i + 1 sig(9,j) = sigraw(9,j) * scfaca sigdt(9,j) = sigrawdt(9,j)*scfaca + sigraw(9,j)*scfacadt sigdd(9,j) = sigrawdd(9,j)*scfaca + sigraw(9,j)*scfacadd ratraw(i) = sigraw(9,j) dratrawdt(i) = sigrawdt(9,j) dratrawdd(i) = sigrawdd(9,j) ratdum(i) = sig(9,j) dratdumdt(i) = sigdt(9,j) dratdumdd(i) = sigdd(9,j) scfac(i) = scfaca dscfacdt(i) = scfacadt dscfacdd(i) = scfacadd i = i + 1 sig(10,j) = sigraw(10,j) * scfacp sigdt(10,j) = sigrawdt(10,j)*scfacp + sigraw(10,j)*scfacpdt sigdd(10,j) = sigrawdd(10,j)*scfacp + sigraw(10,j)*scfacpdd ratraw(i) = sigraw(10,j) dratrawdt(i) = sigrawdt(10,j) dratrawdd(i) = sigrawdd(10,j) ratdum(i) = sig(10,j) dratdumdt(i) = sigdt(10,j) dratdumdd(i) = sigdd(10,j) scfac(i) = scfacp dscfacdt(i) = scfacpdt dscfacdd(i) = scfacpdd end if c..(a,n) and (n,a) reactions c..screen the (a,n) reactions c..do not screen the (n,a) reactions k = nrr(5,j) if (k .gt. 0) then i = i + 1 sig(11,j) = sigraw(11,j) * scfaca sigdt(11,j) = sigrawdt(11,j)*scfaca + sigraw(11,j)*scfacadt sigdd(11,j) = sigrawdd(11,j)*scfaca + sigraw(11,j)*scfacadd ratraw(i) = sigraw(11,j) dratrawdt(i) = sigrawdt(11,j) dratrawdd(i) = sigrawdd(11,j) ratdum(i) = sig(11,j) dratdumdt(i) = sigdt(11,j) dratdumdd(i) = sigdd(11,j) scfac(i) = scfaca dscfacdt(i) = scfacadt dscfacdd(i) = scfacadd i = i + 1 sig(12,j) = sigraw(12,j) sigdt(12,j) = sigrawdt(12,j) sigdd(12,j) = sigrawdd(12,j) ratraw(i) = sigraw(12,j) dratrawdt(i) = sigrawdt(12,j) dratrawdd(i) = sigrawdd(12,j) ratdum(i) = sig(12,j) dratdumdt(i) = sigdt(12,j) dratdumdd(i) = sigdd(12,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if c..(a,g) and (g,a) reactions c..screen the (a,g) reactions c..do not screen (g,a) reactions k = nrr(6,j) if (k .gt. 0) then i = i + 1 sig(13,j) = sigraw(13,j) * scfaca sigdt(13,j) = sigrawdt(13,j)*scfaca + sigraw(13,j)*scfacadt sigdd(13,j) = sigrawdd(13,j)*scfaca + sigraw(13,j)*scfacadd ratraw(i) = sigraw(13,j) dratrawdt(i) = sigrawdt(13,j) dratrawdd(i) = sigrawdd(13,j) ratdum(i) = sig(13,j) dratdumdt(i) = sigdt(13,j) dratdumdd(i) = sigdd(13,j) scfac(i) = scfaca dscfacdt(i) = scfacadt dscfacdd(i) = scfacadd i = i + 1 sig(14,j) = sigraw(14,j) sigdt(14,j) = sigrawdt(14,j) sigdd(14,j) = sigrawdd(14,j) ratraw(i) = sigraw(14,j) dratrawdt(i) = sigrawdt(14,j) dratrawdd(i) = sigrawdd(14,j) ratdum(i) = sig(14,j) dratdumdt(i) = sigdt(14,j) dratdumdd(i) = sigdd(14,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if enddo c..if screening corrections are on if (screen_on .eq. 1) then c..stuff the rest into scalers to avoid repeated array access c..pp jscr = jscr + 1 scpp = scvec(jscr) scppdt = scvecdt(jscr) scppdd = scvecdd(jscr) c..triple alpha jscr = jscr + 1 sc1a = scvec(jscr) sc1adt = scvecdt(jscr) sc1add = scvecdd(jscr) jscr = jscr + 1 sc2a = scvec(jscr) sc2adt = scvecdt(jscr) sc2add = scvecdd(jscr) sc3a = sc1a * sc2a sc3adt = sc1adt*sc2a + sc1a*sc2adt sc3add = sc1add*sc2a + sc1a*sc2add c..c12 + c12 if (ic12 .ne. 0) then jscr = jscr + 1 sc1212 = scvec(jscr) sc1212dt = scvecdt(jscr) sc1212dd = scvecdd(jscr) end if c..c12 + o16 if (ic12 .ne. 0 .and. io16 .ne. 0) then jscr = jscr + 1 sc1216 = scvec(jscr) sc1216dt = scvecdt(jscr) sc1216dd = scvecdd(jscr) end if c..o16 + o16 if (io16 .ne. 0) then jscr = jscr + 1 sc1616 = scvec(jscr) sc1616dt = scvecdt(jscr) sc1616dd = scvecdd(jscr) end if c..d + t if (ih2 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 scdt = scvec(jscr) scdtdt = scvecdt(jscr) scdtdd = scvecdd(jscr) end if c..h3 + p if (ih3 .ne. 0) then jscr = jscr + 1 sch3p = scvec(jscr) sch3pdt = scvecdt(jscr) sch3pdd = scvecdd(jscr) jscr = jscr + 1 sctt = scvec(jscr) scttdt = scvecdt(jscr) scttdd = scvecdd(jscr) end if c..he3 + he3 if (ihe3 .ne. 0) then jscr = jscr + 1 sc33 = scvec(jscr) sc33dt = scvecdt(jscr) sc33dd = scvecdd(jscr) c..he3 + p jscr = jscr + 1 sche3p = scvec(jscr) sche3pdt = scvecdt(jscr) sche3pdd = scvecdd(jscr) end if c..he3 + d if (ihe3 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 sche3d = scvec(jscr) sche3ddt = scvecdt(jscr) sche3ddd = scvecdd(jscr) jscr = jscr + 1 sche4p = scvec(jscr) sche4pdt = scvecdt(jscr) sche4pdd = scvecdd(jscr) end if c..he3 + t if (ihe3 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 sche3t = scvec(jscr) sche3tdt = scvecdt(jscr) sche3tdd = scvecdd(jscr) jscr = jscr + 1 sche4d = scvec(jscr) sche4ddt = scvecdt(jscr) sche4ddd = scvecdd(jscr) end if c..li7(d,n)2a if (ili7 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 scli7d = scvec(jscr) scli7ddt = scvecdt(jscr) scli7ddd = scvecdd(jscr) end if c..li7(t,2n)2a if (ili7 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 scli7t = scvec(jscr) scli7tdt = scvecdt(jscr) scli7tdd = scvecdd(jscr) end if c..li7(he3,np)2a if (ili7 .ne. 0 .and. ihe3 .ne. 0) then jscr = jscr + 1 scli7he3 = scvec(jscr) scli7he3dt = scvecdt(jscr) scli7he3dd = scvecdd(jscr) end if c..be7(d,p)2a if (ibe7 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 scbe7d = scvec(jscr) scbe7ddt = scvecdt(jscr) scbe7ddd = scvecdd(jscr) end if c..be7(t,np)2a if (ibe7 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 scbe7t = scvec(jscr) scbe7tdt = scvecdt(jscr) scbe7tdd = scvecdd(jscr) end if c..be7(he3,2p)2a if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then jscr = jscr + 1 scbe7he3 = scvec(jscr) scbe7he3dt = scvecdt(jscr) scbe7he3dd = scvecdd(jscr) end if c..end of screen_on if end if c..finish recording the rates and multipliers c..for p(e-,nu)n and n(e+,nub)p reactions i = i + 1 ratdum(irpen) = ratraw(irpen) dratdumdt(irpen) = dratrawdt(irpen) dratdumdd(irpen) = dratrawdd(irpen) scfac(irpen) = 1.0d0 dscfacdt(irpen) = 0.0d0 dscfacdd(irpen) = 0.0d0 i = i + 1 ratdum(irnep) = ratraw(irnep) dratdumdt(irnep) = dratrawdt(irnep) dratdumdd(irnep) = dratrawdd(irnep) scfac(irnep) = 1.0d0 dscfacdt(irnep) = 0.0d0 dscfacdd(irnep) = 0.0d0 c..c12 reactions, first triple alpha if (ic12 .ne. 0) then i = i + 1 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 i = i + 1 ratdum(irg3a) = ratraw(irg3a) * sc3a dratdumdt(irg3a) = dratrawdt(irg3a)*sc3a + ratraw(irg3a)*sc3adt dratdumdd(irg3a) = dratrawdd(irg3a)*sc3a + ratraw(irg3a)*sc3add scfac(irg3a) = sc3a dscfacdt(irg3a) = sc3adt dscfacdd(irg3a) = sc3add c..c12+c12 reactions; must have ne20, na23, mg23 in the network if (ine20 .ne. 0 .and. ina23 .ne. 0 .and. img23 .ne. 0) then i = i + 1 ratdum(ir1212n) = ratraw(ir1212n) * sc1212 dratdumdt(ir1212n) = dratrawdt(ir1212n) * sc1212 1 + ratraw(ir1212n) * sc1212dt dratdumdd(ir1212n) = dratrawdd(ir1212n) * sc1212 1 + ratraw(ir1212n) * sc1212dd scfac(ir1212n) = sc1212 dscfacdt(ir1212n) = sc1212dt dscfacdd(ir1212n) = sc1212dd i = i + 1 ratdum(irmg23nc) = ratraw(irmg23nc) * sc1212 dratdumdt(irmg23nc) = dratrawdt(irmg23nc) * sc1212 1 + ratraw(irmg23nc) * sc1212dt dratdumdd(irmg23nc) = dratrawdd(irmg23nc) * sc1212 1 + ratraw(irmg23nc) * sc1212dd scfac(irmg23nc) = sc1212 dscfacdt(irmg23nc) = sc1212dt dscfacdd(irmg23nc) = sc1212dd i = i + 1 ratdum(ir1212p) = ratraw(ir1212p) * sc1212 dratdumdt(ir1212p) = dratrawdt(ir1212p) * sc1212 1 + ratraw(ir1212p) * sc1212dt dratdumdd(ir1212p) = dratrawdd(ir1212p) * sc1212 1 + ratraw(ir1212p) * sc1212dd scfac(ir1212p) = sc1212 dscfacdt(ir1212p) = sc1212dt dscfacdd(ir1212p) = sc1212dd i = i + 1 ratdum(irna23pc) = ratraw(irna23pc) * sc1212 dratdumdt(irna23pc) = dratrawdt(irna23pc) * sc1212 1 + ratraw(irna23pc) * sc1212dt dratdumdd(irna23pc) = dratrawdd(irna23pc) * sc1212 1 + ratraw(irna23pc) * sc1212dd scfac(irna23pc) = sc1212 dscfacdt(irna23pc) = sc1212dt dscfacdd(irna23pc) = sc1212dd i = i + 1 ratdum(ir1212a) = ratraw(ir1212a) * sc1212 dratdumdt(ir1212a) = dratrawdt(ir1212a) * sc1212 1 + ratraw(ir1212a) * sc1212dt dratdumdd(ir1212a) = dratrawdd(ir1212a) * sc1212 1 + ratraw(ir1212a) * sc1212dd scfac(ir1212a) = sc1212 dscfacdt(ir1212a) = sc1212dt dscfacdd(ir1212a) = sc1212dd i = i + 1 ratdum(irne20ac) = ratraw(irne20ac) * sc1212 dratdumdt(irne20ac) = dratrawdt(irne20ac) * sc1212 1 + ratraw(irne20ac) * sc1212dt dratdumdd(irne20ac) = dratrawdd(irne20ac) * sc1212 1 + ratraw(irne20ac) * sc1212dd scfac(irne20ac) = sc1212 dscfacdt(irne20ac) = sc1212dt dscfacdd(irne20ac) = sc1212dd end if end if c..o16+o16 reactions; must have si28, p 30, p31 and s31 in the network if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then i = i + 1 ratdum(ir1616n) = ratraw(ir1616n) * sc1616 dratdumdt(ir1616n) = dratrawdt(ir1616n) * sc1616 + 1 ratraw(ir1616n) * sc1616dt dratdumdd(ir1616n) = dratrawdd(ir1616n) * sc1616 + 1 ratraw(ir1616n) * sc1616dd scfac(ir1616n) = sc1616 dscfacdt(ir1616n) = sc1616dt dscfacdd(ir1616n) = sc1616dd i = i + 1 ratdum(irs31no) = ratraw(irs31no) * sc1616 dratdumdt(irs31no) = dratrawdt(irs31no) * sc1616 + 1 ratraw(irs31no) * sc1616dt dratdumdd(irs31no) = dratrawdd(irs31no) * sc1616 + 1 ratraw(irs31no) * sc1616dd scfac(irs31no) = sc1616 dscfacdt(irs31no) = sc1616dt dscfacdd(irs31no) = sc1616dd i = i + 1 ratdum(ir1616p) = ratraw(ir1616p) * sc1616 dratdumdt(ir1616p) = dratrawdt(ir1616p) * sc1616 + 1 ratraw(ir1616p) * sc1616dt dratdumdd(ir1616p) = dratrawdd(ir1616p) * sc1616 + 1 ratraw(ir1616p) * sc1616dd scfac(ir1616p) = sc1616 dscfacdt(ir1616p) = sc1616dt dscfacdd(ir1616p) = sc1616dd i = i + 1 ratdum(irp31po) = ratraw(irp31po) * sc1616 dratdumdt(irp31po) = dratrawdt(irp31po) * sc1616 + 1 ratraw(irp31po) * sc1616dt dratdumdd(irp31po) = dratrawdd(irp31po) * sc1616 + 1 ratraw(irp31po) * sc1616dd scfac(irp31po) = sc1616 dscfacdt(irp31po) = sc1616dt dscfacdd(irp31po) = sc1616dd i = i + 1 ratdum(ir1616a) = ratraw(ir1616a) * sc1616 dratdumdt(ir1616a) = dratrawdt(ir1616a) * sc1616 + 1 ratraw(ir1616a) * sc1616dt dratdumdd(ir1616a) = dratrawdd(ir1616a) * sc1616 + 1 ratraw(ir1616a) * sc1616dd scfac(ir1616a) = sc1616 dscfacdt(ir1616a) = sc1616dt dscfacdd(ir1616a) = sc1616dd i = i + 1 ratdum(irsi28ao) = ratraw(irsi28ao) * sc1616 dratdumdt(irsi28ao) = dratrawdt(irsi28ao) * sc1616 + 1 ratraw(irsi28ao) * sc1616dt dratdumdd(irsi28ao) = dratrawdd(irsi28ao) * sc1616 + 1 ratraw(irsi28ao) * sc1616dd scfac(irsi28ao) = sc1616 dscfacdt(irsi28ao) = sc1616dt dscfacdd(irsi28ao) = sc1616dd i = i + 1 ratdum(ir1616d) = ratraw(ir1616d) * sc1616 dratdumdt(ir1616d) = dratrawdt(ir1616d) * sc1616 + 1 ratraw(ir1616d) * sc1616dt dratdumdd(ir1616d) = dratrawdd(ir1616d) * sc1616 + 1 ratraw(ir1616d) * sc1616dd scfac(ir1616d) = sc1616 dscfacdt(ir1616d) = sc1616dt dscfacdd(ir1616d) = sc1616dd i = i + 1 ratdum(irp30do) = ratraw(irp30do) * sc1616 dratdumdt(irp30do) = dratrawdt(irp30do) * sc1616 + 1 ratraw(irp30do) * sc1616dt dratdumdd(irp30do) = dratrawdd(irp30do) * sc1616 + 1 ratraw(irp30do) * sc1616dd scfac(irp30do) = sc1616 dscfacdt(irp30do) = sc1616dt dscfacdd(irp30do) = sc1616dd end if c..c12+o16 reactions; must have mg24, al27, si27 in the network if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then i = i + 1 ratdum(ir1216n) = ratraw(ir1216n) * sc1216 dratdumdt(ir1216n) = dratrawdt(ir1216n) * sc1216 1 + ratraw(ir1216n) * sc1216dt dratdumdd(ir1216n) = dratrawdd(ir1216n) * sc1216 1 + ratraw(ir1216n) * sc1216dd scfac(ir1216n) = sc1216 dscfacdt(ir1216n) = sc1216dt dscfacdd(ir1216n) = sc1216dd i = i + 1 ratdum(irsi27no) = ratraw(irsi27no) * sc1216 dratdumdt(irsi27no) = dratrawdt(irsi27no) * sc1216 1 + ratraw(irsi27no) * sc1216dt dratdumdd(irsi27no) = dratrawdd(irsi27no) * sc1216 1 + ratraw(irsi27no) * sc1216dd scfac(irsi27no) = sc1216 dscfacdt(irsi27no) = sc1216dt dscfacdd(irsi27no) = sc1216dd i = i + 1 ratdum(ir1216p) = ratraw(ir1216p) * sc1216 dratdumdt(ir1216p) = dratrawdt(ir1216p) * sc1216 1 + ratraw(ir1216p) * sc1216dt dratdumdd(ir1216p) = dratrawdd(ir1216p) * sc1216 1 + ratraw(ir1216p) * sc1216dd scfac(ir1216p) = sc1216 dscfacdt(ir1216p) = sc1216dt dscfacdd(ir1216p) = sc1216dd i = i + 1 ratdum(iral27po) = ratraw(iral27po) * sc1216 dratdumdt(iral27po) = dratrawdt(iral27po) * sc1216 1 + ratraw(iral27po) * sc1216dt dratdumdd(iral27po) = dratrawdd(iral27po) * sc1216 1 + ratraw(iral27po) * sc1216dd scfac(iral27po) = sc1216 dscfacdt(iral27po) = sc1216dt dscfacdd(iral27po) = sc1216dd i = i + 1 ratdum(ir1216a) = ratraw(ir1216a) * sc1216 dratdumdt(ir1216a) = dratrawdt(ir1216a) * sc1216 1 + ratraw(ir1216a) * sc1216dt dratdumdd(ir1216a) = dratrawdd(ir1216a) * sc1216 1 + ratraw(ir1216a) * sc1216dd scfac(ir1216a) = sc1216 dscfacdt(ir1216a) = sc1216dt dscfacdd(ir1216a) = sc1216dd i = i + 1 ratdum(irmg24ao) = ratraw(irmg24ao) * sc1216 dratdumdt(irmg24ao) = dratrawdt(irmg24ao) * sc1216 1 + ratraw(irmg24ao) * sc1216dt dratdumdd(irmg24ao) = dratrawdd(irmg24ao) * sc1216 1 + ratraw(irmg24ao) * sc1216dd scfac(irmg24ao) = sc1216 dscfacdt(irmg24ao) = sc1216dt dscfacdd(irmg24ao) = sc1216dd end if c..if we have deuterium if (ih2 .ne. 0) then c..pp i = i + 1 ratdum(irpp) = ratraw(irpp) * scpp dratdumdt(irpp) = dratrawdt(irpp)*scpp + ratraw(irpp)*scppdt dratdumdd(irpp) = dratrawdd(irpp)*scpp + ratraw(irpp)*scppdd scfac(irpp) = scpp dscfacdt(irpp) = scppdt dscfacdd(irpp) = scppdd i = i + 1 ratdum(irpep) = ratraw(irpep) * scpp dratdumdt(irpep) = dratrawdt(irpep)*scpp + ratraw(irpep)*scppdt dratdumdd(irpep) = dratrawdd(irpep)*scpp + ratraw(irpep)*scppdd scfac(irpep) = scpp dscfacdt(irpep) = scppdt dscfacdd(irpep) = scppdd c..p(n,g)d i = i + 1 ratdum(irpng) = ratraw(irpng) dratdumdt(irpng) = dratrawdt(irpng) dratdumdd(irpng) = dratrawdd(irpng) scfac(irpng) = 1.0d0 dscfacdt(irpng) = 0.0d0 dscfacdd(irpng) = 0.0d0 i = i + 1 ratdum(irdgn) = ratraw(irdgn) dratdumdt(irdgn) = dratrawdt(irdgn) dratdumdd(irdgn) = dratrawdd(irdgn) scfac(irdgn) = 1.0d0 dscfacdt(irdgn) = 0.0d0 dscfacdd(irdgn) = 0.0d0 c..d(p,n)2p i = i + 1 ratdum(irdpn) = ratraw(irdpn) dratdumdt(irdpn) = dratrawdt(irdpn) dratdumdd(irdpn) = dratrawdd(irdpn) scfac(irdpn) = 1.0d0 dscfacdt(irdpn) = 0.0d0 dscfacdd(irdpn) = 0.0d0 i = i + 1 ratdum(ir2pnp) = ratraw(ir2pnp) dratdumdt(ir2pnp) = dratrawdt(ir2pnp) dratdumdd(ir2pnp) = dratrawdd(ir2pnp) scfac(ir2pnp) = 1.0d0 dscfacdt(ir2pnp) = 0.0d0 dscfacdd(ir2pnp) = 0.0d0 c..d(d,g)he4 i = i + 1 ratdum(irddg) = ratraw(irddg) dratdumdt(irddg) = dratrawdt(irddg) dratdumdd(irddg) = dratrawdd(irddg) scfac(irddg) = 1.0d0 dscfacdt(irddg) = 0.0d0 dscfacdd(irddg) = 0.0d0 i = i + 1 ratdum(irhe4gd) = ratraw(irhe4gd) dratdumdt(irhe4gd) = dratrawdt(irhe4gd) dratdumdd(irhe4gd) = dratrawdd(irhe4gd) scfac(irhe4gd) = 1.0d0 dscfacdt(irhe4gd) = 0.0d0 dscfacdd(irhe4gd) = 0.0d0 end if if (ih3 .ne. 0) then c..d(d,p)t i = i + 1 ratdum(irddp) = ratraw(irddp) dratdumdt(irddp) = dratrawdt(irddp) dratdumdd(irddp) = dratrawdd(irddp) scfac(irddp) = 1.0d0 dscfacdt(irddp) = 0.0d0 dscfacdd(irddp) = 0.0d0 i = i + 1 ratdum(irtpd) = ratraw(irtpd) dratdumdt(irtpd) = dratrawdt(irtpd) dratdumdd(irtpd) = dratrawdd(irtpd) scfac(irtpd) = 1.0d0 dscfacdt(irtpd) = 0.0d0 dscfacdd(irtpd) = 0.0d0 c..t(p,g)he4 i = i + 1 ratdum(irh3pg) = ratraw(irh3pg) dratdumdt(irh3pg) = dratrawdt(irh3pg) dratdumdd(irh3pg) = dratrawdd(irh3pg) scfac(irh3pg) = 1.0d0 dscfacdt(irh3pg) = 0.0d0 dscfacdd(irh3pg) = 0.0d0 i = i + 1 ratdum(irhe4gp) = ratraw(irhe4gp) dratdumdt(irhe4gp) = dratrawdt(irhe4gp) dratdumdd(irhe4gp) = dratrawdd(irhe4gp) scfac(irhe4gp) = 1.0d0 dscfacdt(irhe4gp) = 0.0d0 dscfacdd(irhe4gp) = 0.0d0 c..t(d,n)he4 i = i + 1 ratdum(irtdn) = ratraw(irtdn) * scdt dratdumdt(irtdn) = dratrawdt(irtdn)*scdt + ratraw(irtdn)*scdtdt dratdumdd(irtdn) = dratrawdd(irtdn)*scdt + ratraw(irtdn)*scdtdd scfac(irtdn) = scdt dscfacdt(irtdn) = scdtdt dscfacdd(irtdn) = scdtdd i = i + 1 ratdum(irhe4nd) = ratraw(irhe4nd) dratdumdt(irhe4nd) = dratrawdt(irhe4nd) dratdumdd(irhe4nd) = dratrawdd(irhe4nd) scfac(irhe4nd) = 1.0d0 dscfacdt(irhe4nd) = 0.0d0 dscfacdd(irhe4nd) = 0.0d0 c..t(t,2n)he4 i = i + 1 ratdum(irtt2n) = ratraw(irtt2n) * sctt dratdumdt(irtt2n) = dratrawdt(irtt2n)*sctt 1 + ratraw(irtt2n)*scttdt dratdumdd(irtt2n) = dratrawdd(irtt2n)*sctt 1 + ratraw(irtt2n)*scttdd scfac(irtt2n) = sctt dscfacdt(irtt2n) = scttdt dscfacdd(irtt2n) = scttdd i = i + 1 ratdum(irhe42nt) = ratraw(irhe42nt) dratdumdt(irhe42nt) = dratrawdt(irhe42nt) dratdumdd(irhe42nt) = dratrawdd(irhe42nt) scfac(irhe42nt) = 1.0d0 dscfacdt(irhe42nt) = 0.0d0 dscfacdd(irhe42nt) = 0.0d0 end if if (ihe3 .ne. 0) then c..he3(he3,2p)he4 i = i + 1 ratdum(ir33) = ratraw(ir33) * sc33 dratdumdt(ir33) = dratrawdt(ir33) * sc33 1 + ratraw(ir33) * sc33dt dratdumdd(ir33) = dratrawdd(ir33) * sc33 1 + ratraw(ir33) * sc33dd scfac(ir33) = sc33 dscfacdt(ir33) = sc33dt dscfacdd(ir33) = sc33dd i = i + 1 ratdum(ir33inv) = ratraw(ir33inv) dratdumdt(ir33inv) = dratrawdt(ir33inv) dratdumdd(ir33inv) = dratrawdd(ir33inv) scfac(ir33inv) = 1.0d0 dscfacdt(ir33inv) = 0.0d0 dscfacdd(ir33inv) = 0.0d0 c..he3(p,e-nu)he4 i = i + 1 ratdum(irhep) = ratraw(irhep) * sche3p dratdumdt(irhep) = dratrawdt(irhep) * sche3p 1 + ratraw(irhep) * sche3pdt dratdumdd(irhep) = dratrawdd(irhep) * sche3p 1 + ratraw(irhep) * sche3pdd scfac(irhep) = sche3p dscfacdt(irhep) = sche3pdt dscfacdd(irhep) = sche3pdd c..he3(n,g)he4 i = i + 1 ratdum(irhe3ng) = ratraw(irhe3ng) dratdumdt(irhe3ng) = dratrawdt(irhe3ng) dratdumdd(irhe3ng) = dratrawdd(irhe3ng) scfac(irhe3ng) = 1.0d0 dscfacdt(irhe3ng) = 0.0d0 dscfacdd(irhe3ng) = 0.0d0 i = i + 1 ratdum(irhe4gn) = ratraw(irhe4gn) dratdumdt(irhe4gn) = dratrawdt(irhe4gn) dratdumdd(irhe4gn) = dratrawdd(irhe4gn) scfac(irhe4gn) = 1.0d0 dscfacdt(irhe4gn) = 0.0d0 dscfacdd(irhe4gn) = 0.0d0 c..he3(d,p)he4 i = i + 1 ratdum(irhe3dp) = ratraw(irhe3dp) * sche3d dratdumdt(irhe3dp) = dratrawdt(irhe3dp) * sche3d 1 + ratraw(irhe3dp) * sche3ddt dratdumdd(irhe3dp) = dratrawdd(irhe3dp) * sche3d 1 + ratraw(irhe3dp) * sche3ddd scfac(irhe3dp) = sche3d dscfacdt(irhe3dp) = sche3ddt dscfacdd(irhe3dp) = sche3ddd i = i + 1 ratdum(irhe4pd) = ratraw(irhe4pd) * sche4p dratdumdt(irhe4pd) = dratrawdt(irhe4pd) * sche4p 1 + ratraw(irhe4pd) * sche4pdt dratdumdd(irhe4pd) = dratrawdd(irhe4pd) * sche4p 1 + ratraw(irhe4pd) * sche4pdd scfac(irhe4pd) = sche4p dscfacdt(irhe4pd) = sche4pdt dscfacdd(irhe4pd) = sche4pdd c..d(d,n)he3 i = i + 1 ratdum(irddn) = ratraw(irddn) dratdumdt(irddn) = dratrawdt(irddn) dratdumdd(irddn) = dratrawdd(irddn) scfac(irddn) = 1.0d0 dscfacdt(irddn) = 0.0d0 dscfacdd(irddn) = 0.0d0 i = i + 1 ratdum(irhe3nd) = ratraw(irhe3nd) dratdumdt(irhe3nd) = dratrawdt(irhe3nd) dratdumdd(irhe3nd) = dratrawdd(irhe3nd) scfac(irhe3nd) = 1.0d0 dscfacdt(irhe3nd) = 0.0d0 dscfacdd(irhe3nd) = 0.0d0 c..he3(t,d)he4 i = i + 1 ratdum(irhe3td) = ratraw(irhe3td) * sche3t dratdumdt(irhe3td) = dratrawdt(irhe3td) * sche3t 1 + ratraw(irhe3td) * sche3tdt dratdumdd(irhe3td) = dratrawdd(irhe3td) * sche3t 1 + ratraw(irhe3td) * sche3tdd scfac(irhe3td) = sche3t dscfacdt(irhe3td) = sche3tdt dscfacdd(irhe3td) = sche3tdd i = i + 1 ratdum(irhe4dt) = ratraw(irhe4dt) * sche4d dratdumdt(irhe4dt) = dratrawdt(irhe4dt) * sche4d 1 + ratraw(irhe4dt) * sche4ddt dratdumdd(irhe4dt) = dratrawdd(irhe4dt) * sche4d 1 + ratraw(irhe4dt) * sche4ddd scfac(irhe4dt) = sche4d dscfacdt(irhe4dt) = sche4ddt dscfacdd(irhe4dt) = sche4ddd c..he3(t,np)he4 i = i + 1 ratdum(irhe3tnp) = ratraw(irhe3tnp) * sche3t dratdumdt(irhe3tnp) = dratrawdt(irhe3tnp) * sche3t 1 + ratraw(irhe3tnp) * sche3tdt dratdumdd(irhe3tnp) = dratrawdd(irhe3tnp) * sche3t 1 + ratraw(irhe3tnp) * sche3tdd scfac(irhe3tnp) = sche3t dscfacdt(irhe3tnp) = sche3tdt dscfacdd(irhe3tnp) = sche3tdd end if if (ili7 .ne. 0) then c..li7(t,2n)2a i = i + 1 ratdum(irli7t2n) = ratraw(irli7t2n) * scli7t dratdumdt(irli7t2n) = dratrawdt(irli7t2n) * scli7t 1 + ratraw(irli7t2n) * scli7tdt dratdumdd(irli7t2n) = dratrawdd(irli7t2n) * scli7t 1 + ratraw(irli7t2n) * scli7tdd scfac(irli7t2n) = scli7t dscfacdt(irli7t2n) = scli7tdt dscfacdd(irli7t2n) = scli7tdd c..li7(p,g)be8 and li7(p,a)he4 c..must add screening to this one i = i + 1 ratdum(irli7pag) = ratraw(irli7pag) dratdumdt(irli7pag) = dratrawdt(irli7pag) dratdumdd(irli7pag) = dratrawdd(irli7pag) scfac(irli7pag) = 1.0d0 dscfacdt(irli7pag) = 0.0d0 dscfacdd(irli7pag) = 0.0d0 i = i + 1 ratdum(ir2he4ga) = ratraw(ir2he4ga) dratdumdt(ir2he4ga) = dratrawdt(ir2he4ga) dratdumdd(ir2he4ga) = dratrawdd(ir2he4ga) scfac(ir2he4ga) = 1.0d0 dscfacdt(ir2he4ga) = 0.0d0 dscfacdd(ir2he4ga) = 0.0d0 c..li7(d,n)2a i = i + 1 ratdum(irli7dn) = ratraw(irli7dn) * scli7d dratdumdt(irli7dn) = dratrawdt(irli7dn) * scli7d 1 + ratraw(irli7dn) * scli7ddt dratdumdd(irli7dn) = dratrawdd(irli7dn) * scli7d 1 + ratraw(irli7dn) * scli7ddd scfac(irli7dn) = scli7d dscfacdt(irli7dn) = scli7ddt dscfacdd(irli7dn) = scli7ddd c..li7(he3,np)2a i = i + 1 ratdum(irli7he3np) = ratraw(irli7he3np) * scli7he3 dratdumdt(irli7he3np) = dratrawdt(irli7he3np) * scli7he3 1 + ratraw(irli7he3np) * scli7he3dt dratdumdd(irli7he3np) = dratrawdd(irli7he3np) * scli7he3 1 + ratraw(irli7he3np) * scli7he3dd scfac(irli7he3np) = scli7he3 dscfacdt(irli7he3np) = scli7he3dt dscfacdd(irli7he3np) = scli7he3dd end if if (ibe7 .ne. 0) then c..be7(d,p)2a i = i + 1 ratdum(irbe7dp) = ratraw(irbe7dp) * scbe7d dratdumdt(irbe7dp) = dratrawdt(irbe7dp) * scbe7d 1 + ratraw(irbe7dp) * scbe7ddt dratdumdd(irbe7dp) = dratrawdd(irbe7dp) * scbe7d 1 + ratraw(irbe7dp) * scbe7ddd scfac(irbe7dp) = scbe7d dscfacdt(irbe7dp) = scbe7ddt dscfacdd(irbe7dp) = scbe7ddd c..be7(t,np)2a i = i + 1 ratdum(irbe7tnp) = ratraw(irbe7tnp) * scbe7t dratdumdt(irbe7tnp) = dratrawdt(irbe7tnp) * scbe7t 1 + ratraw(irbe7tnp) * scbe7tdt dratdumdd(irbe7tnp) = dratrawdd(irbe7tnp) * scbe7t 1 + ratraw(irbe7tnp) * scbe7tdd scfac(irbe7tnp) = scbe7t dscfacdt(irbe7tnp) = scbe7tdt dscfacdd(irbe7tnp) = scbe7tdd c..be7(he3,2p)2a i = i + 1 ratdum(irbe7he32p) = ratraw(irbe7he32p) * scbe7he3 dratdumdt(irbe7he32p) = dratrawdt(irbe7he32p) * scbe7he3 1 + ratraw(irbe7he32p) * scbe7he3dt dratdumdd(irbe7he32p) = dratrawdd(irbe7he32p) * scbe7he3 1 + ratraw(irbe7he32p) * scbe7he3dd scfac(irbe7he32p) = scbe7he3 dscfacdt(irbe7he32p) = scbe7he3dt dscfacdd(irbe7he32p) = scbe7he3dd end if if (ibe9 .ne. 0) then c..a(an,g)be9 i = i + 1 ratdum(iraan) = ratraw(iraan) * sc1a dratdumdt(iraan) = dratrawdt(iraan)*sc1a + ratraw(iraan)*sc1adt dratdumdd(iraan) = dratrawdd(iraan)*sc1a + ratraw(iraan)*sc1add scfac(iraan) = sc1a dscfacdt(iraan) = sc1adt dscfacdd(iraan) = sc1add i = i + 1 ratdum(irgaan) = ratraw(irgaan) dratdumdt(irgaan) = dratrawdt(irgaan) dratdumdd(irgaan) = dratrawdd(irgaan) scfac(irgaan) = 1.0d0 dscfacdt(irgaan) = 0.0d0 dscfacdd(irgaan) = 0.0d0 c..be9(p,d)be8 =>2a c..must add screening to this one i = i + 1 ratdum(irbe9pd) = ratraw(irbe9pd) dratdumdt(irbe9pd) = dratrawdt(irbe9pd) dratdumdd(irbe9pd) = dratrawdd(irbe9pd) scfac(irbe9pd) = 1.0d0 dscfacdt(irbe9pd) = 0.0d0 dscfacdd(irbe9pd) = 0.0d0 end if if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions i = i + 1 ratdum(irb8ep) = ratraw(irb8ep) dratdumdt(irb8ep) = dratrawdt(irb8ep) dratdumdd(irb8ep) = dratrawdd(irb8ep) scfac(irb8ep) = 1.0d0 dscfacdt(irb8ep) = 0.0d0 dscfacdd(irb8ep) = 0.0d0 end if if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions c..must add screening to this one i = i + 1 ratdum(irb11pa) = ratraw(irb11pa) dratdumdt(irb11pa) = dratrawdt(irb11pa) dratdumdd(irb11pa) = dratrawdd(irb11pa) scfac(irb11pa) = 1.0d0 dscfacdt(irb11pa) = 0.0d0 dscfacdd(irb11pa) = 0.0d0 i = i + 1 ratdum(ir3ap) = ratraw(ir3ap) dratdumdt(ir3ap) = dratrawdt(ir3ap) dratdumdd(ir3ap) = dratrawdd(ir3ap) scfac(ir3ap) = 1.0d0 dscfacdt(ir3ap) = 0.0d0 dscfacdd(ir3ap) = 0.0d0 end if c..c11(na)be8 => 2a if (ic11 .ne. 0) then i = i + 1 ratdum(irc11na) = ratraw(irc11na) dratdumdt(irc11na) = dratrawdt(irc11na) dratdumdd(irc11na) = dratrawdd(irc11na) scfac(irc11na) = 1.0d0 dscfacdt(irc11na) = 0.0d0 dscfacdd(irc11na) = 0.0d0 end if c..bullet check the counting if (i .ne. nrat) then write(6,*) write(6,*) 'in screen_torch i=',i write(6,*) 'in screen_torch nrat=',nrat write(6,*) 'i is not equal to nrat' write(6,*) 'fatal counting error' write(6,*) stop 'fatal counting error in screen_torch' end if c..debugs c do i=1,nrat c if (ratdum(i) .lt. 0.0) then c write(6,110) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c 110 format(1x,i4,' ',a,' ',1p3e12.4) c stop 'negative rate' c end if c enddo c read(5,*) c open(unit=22,file='rate_chek.dat',status='unknown') c write(6,109) btemp,bden,nrat c write(22,109) btemp,bden,nrat c 109 format(1x,1p2e14.6,i6) c do i=1,nrat c if (ratraw(i) .gt. 0.0) then c write(6,111) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c write(22,111) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c write(6,111) i,ratnam(i),ratraw(i),dratrawdt(i),dratrawdd(i) c write(22,111) i,ratnam(i),ratraw(i),dratrawdt(i),dratrawdd(i) c 111 format(1x,i4,' ',a,' ',1p8e10.2) c end if c enddo c close(unit=22) c write(6,*) 'wrote rates to rate_chek.dat' c read(5,*) c write(6,117) ratraw(irpen),scfac(irpen),ratdum(irpen) c write(6,117) ratraw(irnep),scfac(irnep),ratdum(irnep) c write(6,117) ratraw(ir3a),scfac(ir3a),ratdum(ir3a) c write(6,117) ratraw(irg3a),scfac(irg3a),ratdum(irg3a) c write(6,117) ratdum(ir3a),ratdum(irg3a) c write(6,117) sigraw(13,img24),sigraw(14,img24) c write(6,117) sigraw(9,iti44),sigraw(10,iti44) c 117 format(1x,1p3e14.6) c read(5,*) return end subroutine screen_torch_old(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..declare integer i,j,k,jscr,init double precision y(*),scpp,scppdt,scppdd,sc1a,sc1adt,sc1add, 1 sc2a,sc2adt,sc2add,sc3a,sc3adt,sc3add, 2 sc1212,sc1212dt,sc1212dd, 3 sc1216,sc1216dt,sc1216dd, 4 sc1616,sc1616dt,sc1616dd, 5 scdt,scdtdt,scdtdd,sch3p,sch3pdt,sch3pdd, 6 sctt,scttdt,scttdd,sc33,sc33dt,sc33dd, 7 sche3d,sche3ddt,sche3ddd, 8 sche3t,sche3tdt,sche3tdd, 9 sche4p,sche4pdt,sche4pdd, & scli7d,scli7ddt,scli7ddd, 1 scli7t,scli7tdt,scli7tdd, 2 scli7he3,scli7he3dt,scli7he3dd, 3 scbe7d,scbe7ddt,scbe7ddd, 4 scbe7t,scbe7tdt,scbe7tdd, 5 scbe7he3,scbe7he3dt,scbe7he3dd, 6 sche4d,sche4ddt,sche4ddd,sche3p,sche3pdt,sche3pdd integer nscreen_max parameter (nscreen_max = 2*abignet + 40) double precision abar,zbar,z2bar,ytot1,zbarxx,z2barxx, 1 scfacp(nscreen_max), 2 scfacpdt(nscreen_max), 3 scfacpdd(nscreen_max), 4 scfaca(nscreen_max), 5 scfacadt(nscreen_max), 6 scfacadd(nscreen_max) data init/1/ c..initialize the screening factors do j=ionbeg,ionend scfacp(j) = 1.0d0 scfacpdt(j) = 0.0d0 scfacpdd(j) = 0.0d0 scfaca(j) = 1.0d0 scfacadt(j) = 0.0d0 scfacadd(j) = 0.0d0 enddo scpp = 1.0d0 scppdt = 0.0d0 scppdd = 0.0d0 sc1a = 1.0d0 sc1adt = 0.0d0 sc1add = 0.0d0 sc2a = 1.0d0 sc2adt = 0.0d0 sc2add = 0.0d0 sc3a = 1.0d0 sc3adt = 0.0d0 sc3add = 0.0d0 sc1212 = 1.0d0 sc1212dt = 0.0d0 sc1212dd = 0.0d0 sc1216 = 1.0d0 sc1216dt = 0.0d0 sc1216dd = 0.0d0 sc1616 = 1.0d0 sc1616dt = 0.0d0 sc1616dd = 0.0d0 scdt = 1.0d0 scdtdt = 0.0d0 scdtdd = 0.0d0 sch3p = 1.0d0 sch3pdt = 0.0d0 sch3pdd = 0.0d0 sctt = 1.0d0 scttdt = 0.0d0 scttdd = 0.0d0 sc33 = 1.0d0 sc33dt = 0.0d0 sc33dd = 0.0d0 sche3p = 1.0d0 sche3pdt = 0.0d0 sche3pdd = 0.0d0 sche3d = 1.0d0 sche3ddt = 0.0d0 sche3ddd = 0.0d0 sche3t = 1.0d0 sche3tdt = 0.0d0 sche3tdd = 0.0d0 sche4p = 1.0d0 sche4pdt = 0.0d0 sche4pdd = 0.0d0 scli7d = 1.0d0 scli7ddt = 0.0d0 scli7ddd = 0.0d0 scli7t = 1.0d0 scli7tdt = 0.0d0 scli7tdd = 0.0d0 scli7he3 = 1.0d0 scli7he3dt = 0.0d0 scli7he3dd = 0.0d0 scbe7d = 1.0d0 scbe7ddt = 0.0d0 scbe7ddd = 0.0d0 scbe7t = 1.0d0 scbe7tdt = 0.0d0 scbe7tdd = 0.0d0 scbe7he3 = 1.0d0 scbe7he3dt = 0.0d0 scbe7he3dd = 0.0d0 c..if screening corrections are on if (screen_on .eq. 1) 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..get the proton and alfa screening corrections for each isotope jscr = 0 do j=ionbeg,ionend jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(j),aion(j),zion(iprot),aion(iprot), 2 jscr,init,scfacp(j),scfacpdt(j),scfacpdd(j)) jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(j),aion(j),zion(ihe4),aion(ihe4), 2 jscr,init,scfaca(j),scfacadt(j),scfacadd(j)) enddo c..now get the specials c..pp jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(iprot),aion(iprot),zion(iprot),aion(iprot), 2 jscr,init,scpp,scppdt,scppdd) 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 c..c12 + c12 if (ic12 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(ic12),aion(ic12), 2 jscr,init,sc1212,sc1212dt,sc1212dd) end if c..c12 + o16 if (ic12 .ne. 0 .and. io16 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(io16),aion(io16), 2 jscr,init,sc1216,sc1216dt,sc1216dd) end if c..o16 + o16 if (io16 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io16),aion(io16),zion(io16),aion(io16), 2 jscr,init,sc1616,sc1616dt,sc1616dd) end if c..d + t if (ih2 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ih2),aion(ih2),zion(ih3),aion(ih3), 2 jscr,init,scdt,scdtdt,scdtdd) end if c..h3 + p if (ih3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ih3),aion(ih3),zion(iprot),aion(iprot), 2 jscr,init,sch3p,sch3pdt,sch3pdd) jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ih3),aion(ih3),zion(ih3),aion(ih3), 2 jscr,init,sctt,scttdt,scttdd) end if c..he3 + he3 if (ihe3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(ihe3),aion(ihe3), 2 jscr,init,sc33,sc33dt,sc33dd) c..he3 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(iprot),aion(iprot), 2 jscr,init,sche3p,sche3pdt,sche3pdd) end if c..he3 + d if (ihe3 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(ih2),aion(ih2), 2 jscr,init,sche3d,sche3ddt,sche3ddd) jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe4),aion(ihe4),zion(iprot),aion(iprot), 2 jscr,init,sche4p,sche4pdt,sche4pdd) end if c..he3 + t if (ihe3 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(ih3),aion(ih3), 2 jscr,init,sche3t,sche3tdt,sche3tdd) jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe4),aion(ihe4),zion(ih2),aion(ih2), 2 jscr,init,sche4d,sche4ddt,sche4ddd) end if c..li7(d,n)2a if (ili7 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ili7),aion(ili7),zion(ih2),aion(ih2), 2 jscr,init,scli7d,scli7ddt,scli7ddd) end if c..li7(t,2n)2a if (ili7 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ili7),aion(ili7),zion(ih3),aion(ih3), 2 jscr,init,scli7t,scli7tdt,scli7tdd) end if c..li7(he3,np)2a if (ili7 .ne. 0 .and. ihe3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ili7),aion(ili7),zion(ihe3),aion(ihe3), 2 jscr,init,scli7he3,scli7he3dt,scli7he3dd) end if c..be7(d,p)2a if (ibe7 .ne. 0 .and. ih2 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ibe7),aion(ibe7),zion(ih2),aion(ih2), 2 jscr,init,scbe7d,scbe7ddt,scbe7ddd) end if c..be7(t,np)2a if (ibe7 .ne. 0 .and. ih3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ibe7),aion(ibe7),zion(ih3),aion(ih3), 2 jscr,init,scbe7t,scbe7tdt,scbe7tdd) end if c..be7(he3,2p)2a if (ibe7 .ne. 0 .and. ihe3 .ne. 0) then jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ibe7),aion(ibe7),zion(ihe3),aion(ihe3), 2 jscr,init,scbe7he3,scbe7he3dt,scbe7he3dd) end if c..reset the screen initialization flag init = 0 end if c..apply screening factors, store rates and screening factors i = 0 do j=ionbeg,ionend c..(n,g) and (g,n) reactions c..no screening here k = nrr(1,j) if (k .gt. 0) then i = i + 1 sig(1,j) = sigraw(1,j) sigdt(1,j) = sigrawdt(1,j) sigdd(1,j) = sigrawdd(1,j) ratraw(i) = sigraw(1,j) dratrawdt(i) = sigrawdt(1,j) dratrawdd(i) = sigrawdd(1,j) ratdum(i) = sig(1,j) dratdumdt(i) = sigdt(1,j) dratdumdd(i) = sigdd(1,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 i = i + 1 sig(2,j) = sigraw(2,j) sigdt(2,j) = sigrawdt(2,j) sigdd(2,j) = sigrawdd(2,j) ratraw(i) = sigraw(2,j) dratrawdt(i) = sigrawdt(2,j) dratrawdd(i) = sigrawdd(2,j) ratdum(i) = sig(2,j) dratdumdt(i) = sigdt(2,j) dratdumdd(i) = sigdd(2,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if c..set up the (p,n) beta- beta+ decay components c..screen the (p,n) reactions c..do not screen the (n,p) reactions, c..thielemann & truran, advances in nuclear astrophysics, 1986 k = nrr(2,j) if (k .gt. 0) then i = i + 1 sig(3,j) = sigraw(3,j) * scfacp(j) sigdt(3,j) = sigrawdt(3,j)*scfacp(j) + sigraw(3,j)*scfacpdt(j) sigdd(3,j) = sigrawdd(3,j)*scfacp(j) + sigraw(3,j)*scfacpdd(j) ratraw(i) = sigraw(3,j) dratrawdt(i) = sigrawdt(3,j) dratrawdd(i) = sigrawdd(3,j) ratdum(i) = sig(3,j) dratdumdt(i) = sigdt(3,j) dratdumdd(i) = sigdd(3,j) scfac(i) = scfacp(j) dscfacdt(i) = scfacpdt(j) dscfacdd(i) = scfacpdd(j) i = i + 1 sig(4,j) = sigraw(4,j) sigdt(4,j) = sigrawdt(4,j) sigdd(4,j) = sigrawdd(4,j) c sig(4,j) = sigraw(4,j) * scfacp(j) c sigdt(4,j) = sigrawdt(4,j)*scfacp(j) + sigraw(4,j)*scfacpdt(j) c sigdd(4,j) = sigrawdd(4,j)*scfacp(j) + sigraw(4,j)*scfacpdd(j) ratraw(i) = sigraw(4,j) dratrawdt(i) = sigrawdt(4,j) dratrawdd(i) = sigrawdd(4,j) ratdum(i) = sig(4,j) dratdumdt(i) = sigdt(4,j) dratdumdd(i) = sigdd(4,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 c scfac(i) = scfacp(j) c dscfacdt(i) = scfacpdt(j) c dscfacdd(i) = scfacpdd(j) i = i + 1 sig(5,j) = sigraw(5,j) sigdt(5,j) = sigrawdt(5,j) sigdd(5,j) = sigrawdd(5,j) ratraw(i) = sigraw(5,j) dratrawdt(i) = sigrawdt(5,j) dratrawdd(i) = sigrawdd(5,j) ratdum(i) = sig(5,j) dratdumdt(i) = sigdt(5,j) dratdumdd(i) = sigdd(5,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 i = i + 1 sig(6,j) = sigraw(6,j) sigdt(6,j) = sigrawdt(6,j) sigdd(6,j) = sigrawdd(6,j) ratraw(i) = sigraw(6,j) dratrawdt(i) = sigrawdt(6,j) dratrawdd(i) = sigrawdd(6,j) ratdum(i) = sig(6,j) dratdumdt(i) = sigdt(6,j) dratdumdd(i) = sigdd(6,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end if c..(p,g) and (g,p) reactions c..screen the (p,g) reactions c..do not screen (g,p) reactions k = nrr(3,j) if (k .gt. 0) then i = i + 1 sig(7,j) = sigraw(7,j) * scfacp(j) sigdt(7,j) = sigrawdt(7,j)*scfacp(j) + sigraw(7,j)*scfacpdt(j) sigdd(7,j) = sigrawdd(7,j)*scfacp(j) + sigraw(7,j)*scfacpdd(j) ratraw(i) = sigraw(7,j) dratrawdt(i) = sigrawdt(7,j) dratrawdd(i) = sigrawdd(7,j) ratdum(i) = sig(7,j) dratdumdt(i) = sigdt(7,j) dratdumdd(i) = sigdd(7,j) scfac(i) = scfacp(j) dscfacdt(i) = scfacpdt(j) dscfacdd(i) = scfacpdd(j) i = i + 1 sig(8,j) = sigraw(8,j) sigdt(8,j) = sigrawdt(8,j) sigdd(8,j) = sigrawdd(8,j) c sig(8,j) = sigraw(8,j) * scfacp(j) c sigdt(8,j) = sigrawdt(8,j)*scfacp(j) + sigraw(8,j)*scfacpdt(j) c sigdd(8,j) = sigrawdd(8,j)*scfacp(j) + sigraw(8,j)*scfacpdd(j) ratraw(i) = sigraw(8,j) dratrawdt(i) = sigrawdt(8,j) dratrawdd(i) = sigrawdd(8,j) ratdum(i) = sig(8,j) dratdumdt(i) = sigdt(8,j) dratdumdd(i) = sigdd(8,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 c scfac(i) = scfacp(j) c dscfacdt(i) = scfacpdt(j) c dscfacdd(i) = scfacpdd(j) end if c..(a,p) and (p,a) reactions c..this case is complicated because of two charged particles in c..the entrance and exit channels. for now we will c..screen the (a,p) reactions with scfaca(j) c..screen the (p,a) reactions with scfaca(k) k = nrr(4,j) if (k .gt. 0) then i = i + 1 sig(9,j) = sigraw(9,j) * scfaca(j) sigdt(9,j) = sigrawdt(9,j)*scfaca(j)+sigraw(9,j)*scfacadt(j) sigdd(9,j) = sigrawdd(9,j)*scfaca(j)+sigraw(9,j)*scfacadd(j) ratraw(i) = sigraw(9,j) dratrawdt(i) = sigrawdt(9,j) dratrawdd(i) = sigrawdd(9,j) ratdum(i) = sig(9,j) dratdumdt(i) = sigdt(9,j) dratdumdd(i) = sigdd(9,j) scfac(i) = scfaca(j) dscfacdt(i) = scfacadt(j) dscfacdd(i) = scfacadd(j) i = i + 1 sig(10,j) = sigraw(10,j) * scfacp(j) sigdt(10,j) = sigrawdt(10,j)*scfacp(j)+sigraw(10,j)*scfacpdt(j) sigdd(10,j) = sigrawdd(10,j)*scfacp(j)+sigraw(10,j)*scfacpdd(j) c sig(10,j) = sigraw(10,j) * scfacp(k) c sigdt(10,j) = sigrawdt(10,j)*scfacp(k)+sigraw(10,j)*scfacpdt(k) c sigdd(10,j) = sigrawdd(10,j)*scfacp(k)+sigraw(10,j)*scfacpdd(k) c sig(10,j) = sigraw(10,j) * scfaca(j) c sigdt(10,j) = sigrawdt(10,j)*scfaca(j)+sigraw(10,j)*scfacadt(j) c sigdd(10,j) = sigrawdd(10,j)*scfaca(j)+sigraw(10,j)*scfacadd(j) ratraw(i) = sigraw(10,j) dratrawdt(i) = sigrawdt(10,j) dratrawdd(i) = sigrawdd(10,j) ratdum(i) = sig(10,j) dratdumdt(i) = sigdt(10,j) dratdumdd(i) = sigdd(10,j) scfac(i) = scfacp(j) dscfacdt(i) = scfacpdt(j) dscfacdd(i) = scfacpdd(j) c scfac(i) = scfacp(k) c dscfacdt(i) = scfacpdt(k) c dscfacdd(i) = scfacpdd(k) c scfac(i) = scfaca(j) c dscfacdt(i) = scfacadt(j) c dscfacdd(i) = scfacadd(j) end if c..(a,n) and (n,a) reactions c..screen the (a,n) reactions c..do not screen the (n,a) reactions k = nrr(5,j) if (k .gt. 0) then i = i + 1 sig(11,j) = sigraw(11,j) * scfaca(j) sigdt(11,j) = sigrawdt(11,j)*scfaca(j)+sigraw(11,j)*scfacadt(j) sigdd(11,j) = sigrawdd(11,j)*scfaca(j)+sigraw(11,j)*scfacadd(j) ratraw(i) = sigraw(11,j) dratrawdt(i) = sigrawdt(11,j) dratrawdd(i) = sigrawdd(11,j) ratdum(i) = sig(11,j) dratdumdt(i) = sigdt(11,j) dratdumdd(i) = sigdd(11,j) scfac(i) = scfaca(j) dscfacdt(i) = scfacadt(j) dscfacdd(i) = scfacadd(j) i = i + 1 sig(12,j) = sigraw(12,j) sigdt(12,j) = sigrawdt(12,j) sigdd(12,j) = sigrawdd(12,j) c sig(12,j) = sigraw(12,j) * scfaca(j) c sigdt(12,j) = sigrawdt(12,j)*scfaca(j)+sigraw(12,j)*scfacadt(j) c sigdd(12,j) = sigrawdd(12,j)*scfaca(j)+sigraw(12,j)*scfacadd(j) ratraw(i) = sigraw(12,j) dratrawdt(i) = sigrawdt(12,j) dratrawdd(i) = sigrawdd(12,j) ratdum(i) = sig(12,j) dratdumdt(i) = sigdt(12,j) dratdumdd(i) = sigdd(12,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 c scfac(i) = scfaca(j) c dscfacdt(i) = scfacadt(j) c dscfacdd(i) = scfacadd(j) end if c..(a,g) and (g,a) reactions c..screen the (a,g) reactions c..do not screen (g,a) reactions k = nrr(6,j) if (k .gt. 0) then i = i + 1 sig(13,j) = sigraw(13,j) * scfaca(j) sigdt(13,j) = sigrawdt(13,j)*scfaca(j)+sigraw(13,j)*scfacadt(j) sigdd(13,j) = sigrawdd(13,j)*scfaca(j)+sigraw(13,j)*scfacadd(j) ratraw(i) = sigraw(13,j) dratrawdt(i) = sigrawdt(13,j) dratrawdd(i) = sigrawdd(13,j) ratdum(i) = sig(13,j) dratdumdt(i) = sigdt(13,j) dratdumdd(i) = sigdd(13,j) scfac(i) = scfaca(j) dscfacdt(i) = scfacadt(j) dscfacdd(i) = scfacadd(j) i = i + 1 sig(14,j) = sigraw(14,j) sigdt(14,j) = sigrawdt(14,j) sigdd(14,j) = sigrawdd(14,j) c sig(14,j) = sigraw(14,j)*scfaca(j) c sigdt(14,j) = sigrawdt(14,j)*scfaca(j)+sigraw(14,j)*scfacadt(j) c sigdd(14,j) = sigrawdd(14,j)*scfaca(j)+sigraw(14,j)*scfacadd(j) ratraw(i) = sigraw(14,j) dratrawdt(i) = sigrawdt(14,j) dratrawdd(i) = sigrawdd(14,j) ratdum(i) = sig(14,j) dratdumdt(i) = sigdt(14,j) dratdumdd(i) = sigdd(14,j) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 c scfac(i) = scfaca(j) c dscfacdt(i) = scfacadt(j) c dscfacdd(i) = scfacadd(j) end if enddo c..finish recording the rates and multipliers c..for p(e-,nu)n and n(e+,nub)p reactions i = i + 1 ratdum(irpen) = ratraw(irpen) dratdumdt(irpen) = dratrawdt(irpen) dratdumdd(irpen) = dratrawdd(irpen) scfac(irpen) = 1.0d0 dscfacdt(irpen) = 0.0d0 dscfacdd(irpen) = 0.0d0 i = i + 1 ratdum(irnep) = ratraw(irnep) dratdumdt(irnep) = dratrawdt(irnep) dratdumdd(irnep) = dratrawdd(irnep) scfac(irnep) = 1.0d0 dscfacdt(irnep) = 0.0d0 dscfacdd(irnep) = 0.0d0 c..c12 reactions, first triple alpha if (ic12 .ne. 0) then i = i + 1 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 i = i + 1 ratdum(irg3a) = ratraw(irg3a) * sc3a dratdumdt(irg3a) = dratrawdt(irg3a)*sc3a + ratraw(irg3a)*sc3adt dratdumdd(irg3a) = dratrawdd(irg3a)*sc3a + ratraw(irg3a)*sc3add scfac(irg3a) = sc3a dscfacdt(irg3a) = sc3adt dscfacdd(irg3a) = sc3add c ratdum(irg3a) = ratraw(irg3a) c dratdumdt(irg3a) = dratrawdt(irg3a) c dratdumdd(irg3a) = dratrawdd(irg3a) c scfac(irg3a) = 1.0d0 c dscfacdt(irg3a) = 0.0d0 c dscfacdd(irg3a) = 0.0d0 c..c12+c12 reactions; must have ne20, na23, mg23 in the network if (ine20 .ne. 0 .and. ina23 .ne. 0 .and. img23 .ne. 0) then i = i + 1 ratdum(ir1212n) = ratraw(ir1212n) * sc1212 dratdumdt(ir1212n) = dratrawdt(ir1212n) * sc1212 1 + ratraw(ir1212n) * sc1212dt dratdumdd(ir1212n) = dratrawdd(ir1212n) * sc1212 1 + ratraw(ir1212n) * sc1212dd scfac(ir1212n) = sc1212 dscfacdt(ir1212n) = sc1212dt dscfacdd(ir1212n) = sc1212dd i = i + 1 ratdum(irmg23nc) = ratraw(irmg23nc) * sc1212 dratdumdt(irmg23nc) = dratrawdt(irmg23nc) * sc1212 1 + ratraw(irmg23nc) * sc1212dt dratdumdd(irmg23nc) = dratrawdd(irmg23nc) * sc1212 1 + ratraw(irmg23nc) * sc1212dd scfac(irmg23nc) = sc1212 dscfacdt(irmg23nc) = sc1212dt dscfacdd(irmg23nc) = sc1212dd i = i + 1 ratdum(ir1212p) = ratraw(ir1212p) * sc1212 dratdumdt(ir1212p) = dratrawdt(ir1212p) * sc1212 1 + ratraw(ir1212p) * sc1212dt dratdumdd(ir1212p) = dratrawdd(ir1212p) * sc1212 1 + ratraw(ir1212p) * sc1212dd scfac(ir1212p) = sc1212 dscfacdt(ir1212p) = sc1212dt dscfacdd(ir1212p) = sc1212dd i = i + 1 ratdum(irna23pc) = ratraw(irna23pc) * sc1212 dratdumdt(irna23pc) = dratrawdt(irna23pc) * sc1212 1 + ratraw(irna23pc) * sc1212dt dratdumdd(irna23pc) = dratrawdd(irna23pc) * sc1212 1 + ratraw(irna23pc) * sc1212dd scfac(irna23pc) = sc1212 dscfacdt(irna23pc) = sc1212dt dscfacdd(irna23pc) = sc1212dd i = i + 1 ratdum(ir1212a) = ratraw(ir1212a) * sc1212 dratdumdt(ir1212a) = dratrawdt(ir1212a) * sc1212 1 + ratraw(ir1212a) * sc1212dt dratdumdd(ir1212a) = dratrawdd(ir1212a) * sc1212 1 + ratraw(ir1212a) * sc1212dd scfac(ir1212a) = sc1212 dscfacdt(ir1212a) = sc1212dt dscfacdd(ir1212a) = sc1212dd i = i + 1 ratdum(irne20ac) = ratraw(irne20ac) * sc1212 dratdumdt(irne20ac) = dratrawdt(irne20ac) * sc1212 1 + ratraw(irne20ac) * sc1212dt dratdumdd(irne20ac) = dratrawdd(irne20ac) * sc1212 1 + ratraw(irne20ac) * sc1212dd scfac(irne20ac) = sc1212 dscfacdt(irne20ac) = sc1212dt dscfacdd(irne20ac) = sc1212dd end if end if c..o16+o16 reactions; must have si28, p 30, p31 and s31 in the network if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then i = i + 1 ratdum(ir1616n) = ratraw(ir1616n) * sc1616 dratdumdt(ir1616n) = dratrawdt(ir1616n) * sc1616 + 1 ratraw(ir1616n) * sc1616dt dratdumdd(ir1616n) = dratrawdd(ir1616n) * sc1616 + 1 ratraw(ir1616n) * sc1616dd scfac(ir1616n) = sc1616 dscfacdt(ir1616n) = sc1616dt dscfacdd(ir1616n) = sc1616dd i = i + 1 ratdum(irs31no) = ratraw(irs31no) * sc1616 dratdumdt(irs31no) = dratrawdt(irs31no) * sc1616 + 1 ratraw(irs31no) * sc1616dt dratdumdd(irs31no) = dratrawdd(irs31no) * sc1616 + 1 ratraw(irs31no) * sc1616dd scfac(irs31no) = sc1616 dscfacdt(irs31no) = sc1616dt dscfacdd(irs31no) = sc1616dd i = i + 1 ratdum(ir1616p) = ratraw(ir1616p) * sc1616 dratdumdt(ir1616p) = dratrawdt(ir1616p) * sc1616 + 1 ratraw(ir1616p) * sc1616dt dratdumdd(ir1616p) = dratrawdd(ir1616p) * sc1616 + 1 ratraw(ir1616p) * sc1616dd scfac(ir1616p) = sc1616 dscfacdt(ir1616p) = sc1616dt dscfacdd(ir1616p) = sc1616dd i = i + 1 ratdum(irp31po) = ratraw(irp31po) * sc1616 dratdumdt(irp31po) = dratrawdt(irp31po) * sc1616 + 1 ratraw(irp31po) * sc1616dt dratdumdd(irp31po) = dratrawdd(irp31po) * sc1616 + 1 ratraw(irp31po) * sc1616dd scfac(irp31po) = sc1616 dscfacdt(irp31po) = sc1616dt dscfacdd(irp31po) = sc1616dd i = i + 1 ratdum(ir1616a) = ratraw(ir1616a) * sc1616 dratdumdt(ir1616a) = dratrawdt(ir1616a) * sc1616 + 1 ratraw(ir1616a) * sc1616dt dratdumdd(ir1616a) = dratrawdd(ir1616a) * sc1616 + 1 ratraw(ir1616a) * sc1616dd scfac(ir1616a) = sc1616 dscfacdt(ir1616a) = sc1616dt dscfacdd(ir1616a) = sc1616dd i = i + 1 ratdum(irsi28ao) = ratraw(irsi28ao) * sc1616 dratdumdt(irsi28ao) = dratrawdt(irsi28ao) * sc1616 + 1 ratraw(irsi28ao) * sc1616dt dratdumdd(irsi28ao) = dratrawdd(irsi28ao) * sc1616 + 1 ratraw(irsi28ao) * sc1616dd scfac(irsi28ao) = sc1616 dscfacdt(irsi28ao) = sc1616dt dscfacdd(irsi28ao) = sc1616dd i = i + 1 ratdum(ir1616d) = ratraw(ir1616d) * sc1616 dratdumdt(ir1616d) = dratrawdt(ir1616d) * sc1616 + 1 ratraw(ir1616d) * sc1616dt dratdumdd(ir1616d) = dratrawdd(ir1616d) * sc1616 + 1 ratraw(ir1616d) * sc1616dd scfac(ir1616d) = sc1616 dscfacdt(ir1616d) = sc1616dt dscfacdd(ir1616d) = sc1616dd i = i + 1 ratdum(irp30do) = ratraw(irp30do) * sc1616 dratdumdt(irp30do) = dratrawdt(irp30do) * sc1616 + 1 ratraw(irp30do) * sc1616dt dratdumdd(irp30do) = dratrawdd(irp30do) * sc1616 + 1 ratraw(irp30do) * sc1616dd scfac(irp30do) = sc1616 dscfacdt(irp30do) = sc1616dt dscfacdd(irp30do) = sc1616dd end if c..c12+o16 reactions; must have mg24, al27, si27 in the network if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then i = i + 1 ratdum(ir1216n) = ratraw(ir1216n) * sc1216 dratdumdt(ir1216n) = dratrawdt(ir1216n) * sc1216 1 + ratraw(ir1216n) * sc1216dt dratdumdd(ir1216n) = dratrawdd(ir1216n) * sc1216 1 + ratraw(ir1216n) * sc1216dd scfac(ir1216n) = sc1216 dscfacdt(ir1216n) = sc1216dt dscfacdd(ir1216n) = sc1216dd i = i + 1 ratdum(irsi27no) = ratraw(irsi27no) * sc1216 dratdumdt(irsi27no) = dratrawdt(irsi27no) * sc1216 1 + ratraw(irsi27no) * sc1216dt dratdumdd(irsi27no) = dratrawdd(irsi27no) * sc1216 1 + ratraw(irsi27no) * sc1216dd scfac(irsi27no) = sc1216 dscfacdt(irsi27no) = sc1216dt dscfacdd(irsi27no) = sc1216dd i = i + 1 ratdum(ir1216p) = ratraw(ir1216p) * sc1216 dratdumdt(ir1216p) = dratrawdt(ir1216p) * sc1216 1 + ratraw(ir1216p) * sc1216dt dratdumdd(ir1216p) = dratrawdd(ir1216p) * sc1216 1 + ratraw(ir1216p) * sc1216dd scfac(ir1216p) = sc1216 dscfacdt(ir1216p) = sc1216dt dscfacdd(ir1216p) = sc1216dd i = i + 1 ratdum(iral27po) = ratraw(iral27po) * sc1216 dratdumdt(iral27po) = dratrawdt(iral27po) * sc1216 1 + ratraw(iral27po) * sc1216dt dratdumdd(iral27po) = dratrawdd(iral27po) * sc1216 1 + ratraw(iral27po) * sc1216dd scfac(iral27po) = sc1216 dscfacdt(iral27po) = sc1216dt dscfacdd(iral27po) = sc1216dd i = i + 1 ratdum(ir1216a) = ratraw(ir1216a) * sc1216 dratdumdt(ir1216a) = dratrawdt(ir1216a) * sc1216 1 + ratraw(ir1216a) * sc1216dt dratdumdd(ir1216a) = dratrawdd(ir1216a) * sc1216 1 + ratraw(ir1216a) * sc1216dd scfac(ir1216a) = sc1216 dscfacdt(ir1216a) = sc1216dt dscfacdd(ir1216a) = sc1216dd i = i + 1 ratdum(irmg24ao) = ratraw(irmg24ao) * sc1216 dratdumdt(irmg24ao) = dratrawdt(irmg24ao) * sc1216 1 + ratraw(irmg24ao) * sc1216dt dratdumdd(irmg24ao) = dratrawdd(irmg24ao) * sc1216 1 + ratraw(irmg24ao) * sc1216dd scfac(irmg24ao) = sc1216 dscfacdt(irmg24ao) = sc1216dt dscfacdd(irmg24ao) = sc1216dd end if c..if we have deuterium if (ih2 .ne. 0) then c..pp i = i + 1 ratdum(irpp) = ratraw(irpp) * scpp dratdumdt(irpp) = dratrawdt(irpp)*scpp + ratraw(irpp)*scppdt dratdumdd(irpp) = dratrawdd(irpp)*scpp + ratraw(irpp)*scppdd scfac(irpp) = scpp dscfacdt(irpp) = scppdt dscfacdd(irpp) = scppdd i = i + 1 ratdum(irpep) = ratraw(irpep) * scpp dratdumdt(irpep) = dratrawdt(irpep)*scpp + ratraw(irpep)*scppdt dratdumdd(irpep) = dratrawdd(irpep)*scpp + ratraw(irpep)*scppdd scfac(irpep) = scpp dscfacdt(irpep) = scppdt dscfacdd(irpep) = scppdd c..p(n,g)d i = i + 1 ratdum(irpng) = ratraw(irpng) dratdumdt(irpng) = dratrawdt(irpng) dratdumdd(irpng) = dratrawdd(irpng) scfac(irpng) = 1.0d0 dscfacdt(irpng) = 0.0d0 dscfacdd(irpng) = 0.0d0 i = i + 1 ratdum(irdgn) = ratraw(irdgn) dratdumdt(irdgn) = dratrawdt(irdgn) dratdumdd(irdgn) = dratrawdd(irdgn) scfac(irdgn) = 1.0d0 dscfacdt(irdgn) = 0.0d0 dscfacdd(irdgn) = 0.0d0 c..d(p,n)2p i = i + 1 ratdum(irdpn) = ratraw(irdpn) dratdumdt(irdpn) = dratrawdt(irdpn) dratdumdd(irdpn) = dratrawdd(irdpn) scfac(irdpn) = 1.0d0 dscfacdt(irdpn) = 0.0d0 dscfacdd(irdpn) = 0.0d0 i = i + 1 ratdum(ir2pnp) = ratraw(ir2pnp) dratdumdt(ir2pnp) = dratrawdt(ir2pnp) dratdumdd(ir2pnp) = dratrawdd(ir2pnp) scfac(ir2pnp) = 1.0d0 dscfacdt(ir2pnp) = 0.0d0 dscfacdd(ir2pnp) = 0.0d0 c..d(d,g)he4 i = i + 1 ratdum(irddg) = ratraw(irddg) dratdumdt(irddg) = dratrawdt(irddg) dratdumdd(irddg) = dratrawdd(irddg) scfac(irddg) = 1.0d0 dscfacdt(irddg) = 0.0d0 dscfacdd(irddg) = 0.0d0 i = i + 1 ratdum(irhe4gd) = ratraw(irhe4gd) dratdumdt(irhe4gd) = dratrawdt(irhe4gd) dratdumdd(irhe4gd) = dratrawdd(irhe4gd) scfac(irhe4gd) = 1.0d0 dscfacdt(irhe4gd) = 0.0d0 dscfacdd(irhe4gd) = 0.0d0 end if if (ih3 .ne. 0) then c..d(d,p)t i = i + 1 ratdum(irddp) = ratraw(irddp) dratdumdt(irddp) = dratrawdt(irddp) dratdumdd(irddp) = dratrawdd(irddp) scfac(irddp) = 1.0d0 dscfacdt(irddp) = 0.0d0 dscfacdd(irddp) = 0.0d0 i = i + 1 ratdum(irtpd) = ratraw(irtpd) dratdumdt(irtpd) = dratrawdt(irtpd) dratdumdd(irtpd) = dratrawdd(irtpd) scfac(irtpd) = 1.0d0 dscfacdt(irtpd) = 0.0d0 dscfacdd(irtpd) = 0.0d0 c..t(p,g)he4 i = i + 1 ratdum(irh3pg) = ratraw(irh3pg) dratdumdt(irh3pg) = dratrawdt(irh3pg) dratdumdd(irh3pg) = dratrawdd(irh3pg) scfac(irh3pg) = 1.0d0 dscfacdt(irh3pg) = 0.0d0 dscfacdd(irh3pg) = 0.0d0 i = i + 1 ratdum(irhe4gp) = ratraw(irhe4gp) dratdumdt(irhe4gp) = dratrawdt(irhe4gp) dratdumdd(irhe4gp) = dratrawdd(irhe4gp) scfac(irhe4gp) = 1.0d0 dscfacdt(irhe4gp) = 0.0d0 dscfacdd(irhe4gp) = 0.0d0 c..t(d,n)he4 i = i + 1 ratdum(irtdn) = ratraw(irtdn) * scdt dratdumdt(irtdn) = dratrawdt(irtdn)*scdt + ratraw(irtdn)*scdtdt dratdumdd(irtdn) = dratrawdd(irtdn)*scdt + ratraw(irtdn)*scdtdd scfac(irtdn) = scdt dscfacdt(irtdn) = scdtdt dscfacdd(irtdn) = scdtdd i = i + 1 ratdum(irhe4nd) = ratraw(irhe4nd) dratdumdt(irhe4nd) = dratrawdt(irhe4nd) dratdumdd(irhe4nd) = dratrawdd(irhe4nd) scfac(irhe4nd) = 1.0d0 dscfacdt(irhe4nd) = 0.0d0 dscfacdd(irhe4nd) = 0.0d0 c..t(t,2n)he4 i = i + 1 ratdum(irtt2n) = ratraw(irtt2n) * sctt dratdumdt(irtt2n) = dratrawdt(irtt2n)*sctt 1 + ratraw(irtt2n)*scttdt dratdumdd(irtt2n) = dratrawdd(irtt2n)*sctt 1 + ratraw(irtt2n)*scttdd scfac(irtt2n) = sctt dscfacdt(irtt2n) = scttdt dscfacdd(irtt2n) = scttdd i = i + 1 ratdum(irhe42nt) = ratraw(irhe42nt) dratdumdt(irhe42nt) = dratrawdt(irhe42nt) dratdumdd(irhe42nt) = dratrawdd(irhe42nt) scfac(irhe42nt) = 1.0d0 dscfacdt(irhe42nt) = 0.0d0 dscfacdd(irhe42nt) = 0.0d0 end if if (ihe3 .ne. 0) then c..he3(he3,2p)he4 i = i + 1 ratdum(ir33) = ratraw(ir33) * sc33 dratdumdt(ir33) = dratrawdt(ir33) * sc33 1 + ratraw(ir33) * sc33dt dratdumdd(ir33) = dratrawdd(ir33) * sc33 1 + ratraw(ir33) * sc33dd scfac(ir33) = sc33 dscfacdt(ir33) = sc33dt dscfacdd(ir33) = sc33dd i = i + 1 ratdum(ir33inv) = ratraw(ir33inv) dratdumdt(ir33inv) = dratrawdt(ir33inv) dratdumdd(ir33inv) = dratrawdd(ir33inv) scfac(ir33inv) = 1.0d0 dscfacdt(ir33inv) = 0.0d0 dscfacdd(ir33inv) = 0.0d0 c..he3(p,e-nu)he4 i = i + 1 ratdum(irhep) = ratraw(irhep) * sche3p dratdumdt(irhep) = dratrawdt(irhep) * sche3p 1 + ratraw(irhep) * sche3pdt dratdumdd(irhep) = dratrawdd(irhep) * sche3p 1 + ratraw(irhep) * sche3pdd scfac(irhep) = sche3p dscfacdt(irhep) = sche3pdt dscfacdd(irhep) = sche3pdd c..he3(n,g)he4 i = i + 1 ratdum(irhe3ng) = ratraw(irhe3ng) dratdumdt(irhe3ng) = dratrawdt(irhe3ng) dratdumdd(irhe3ng) = dratrawdd(irhe3ng) scfac(irhe3ng) = 1.0d0 dscfacdt(irhe3ng) = 0.0d0 dscfacdd(irhe3ng) = 0.0d0 i = i + 1 ratdum(irhe4gn) = ratraw(irhe4gn) dratdumdt(irhe4gn) = dratrawdt(irhe4gn) dratdumdd(irhe4gn) = dratrawdd(irhe4gn) scfac(irhe4gn) = 1.0d0 dscfacdt(irhe4gn) = 0.0d0 dscfacdd(irhe4gn) = 0.0d0 c..he3(d,p)he4 i = i + 1 ratdum(irhe3dp) = ratraw(irhe3dp) * sche3d dratdumdt(irhe3dp) = dratrawdt(irhe3dp) * sche3d 1 + ratraw(irhe3dp) * sche3ddt dratdumdd(irhe3dp) = dratrawdd(irhe3dp) * sche3d 1 + ratraw(irhe3dp) * sche3ddd scfac(irhe3dp) = sche3d dscfacdt(irhe3dp) = sche3ddt dscfacdd(irhe3dp) = sche3ddd i = i + 1 ratdum(irhe4pd) = ratraw(irhe4pd) * sche4p dratdumdt(irhe4pd) = dratrawdt(irhe4pd) * sche4p 1 + ratraw(irhe4pd) * sche4pdt dratdumdd(irhe4pd) = dratrawdd(irhe4pd) * sche4p 1 + ratraw(irhe4pd) * sche4pdd scfac(irhe4pd) = sche4p dscfacdt(irhe4pd) = sche4pdt dscfacdd(irhe4pd) = sche4pdd c..d(d,n)he3 i = i + 1 ratdum(irddn) = ratraw(irddn) dratdumdt(irddn) = dratrawdt(irddn) dratdumdd(irddn) = dratrawdd(irddn) scfac(irddn) = 1.0d0 dscfacdt(irddn) = 0.0d0 dscfacdd(irddn) = 0.0d0 i = i + 1 ratdum(irhe3nd) = ratraw(irhe3nd) dratdumdt(irhe3nd) = dratrawdt(irhe3nd) dratdumdd(irhe3nd) = dratrawdd(irhe3nd) scfac(irhe3nd) = 1.0d0 dscfacdt(irhe3nd) = 0.0d0 dscfacdd(irhe3nd) = 0.0d0 c..he3(t,d)he4 i = i + 1 ratdum(irhe3td) = ratraw(irhe3td) * sche3t dratdumdt(irhe3td) = dratrawdt(irhe3td) * sche3t 1 + ratraw(irhe3td) * sche3tdt dratdumdd(irhe3td) = dratrawdd(irhe3td) * sche3t 1 + ratraw(irhe3td) * sche3tdd scfac(irhe3td) = sche3t dscfacdt(irhe3td) = sche3tdt dscfacdd(irhe3td) = sche3tdd i = i + 1 ratdum(irhe4dt) = ratraw(irhe4dt) * sche4d dratdumdt(irhe4dt) = dratrawdt(irhe4dt) * sche4d 1 + ratraw(irhe4dt) * sche4ddt dratdumdd(irhe4dt) = dratrawdd(irhe4dt) * sche4d 1 + ratraw(irhe4dt) * sche4ddd scfac(irhe4dt) = sche4d dscfacdt(irhe4dt) = sche4ddt dscfacdd(irhe4dt) = sche4ddd c..he3(t,np)he4 i = i + 1 ratdum(irhe3tnp) = ratraw(irhe3tnp) * sche3t dratdumdt(irhe3tnp) = dratrawdt(irhe3tnp) * sche3t 1 + ratraw(irhe3tnp) * sche3tdt dratdumdd(irhe3tnp) = dratrawdd(irhe3tnp) * sche3t 1 + ratraw(irhe3tnp) * sche3tdd scfac(irhe3tnp) = sche3t dscfacdt(irhe3tnp) = sche3tdt dscfacdd(irhe3tnp) = sche3tdd end if if (ili7 .ne. 0) then c..li7(t,2n)2a i = i + 1 ratdum(irli7t2n) = ratraw(irli7t2n) * scli7t dratdumdt(irli7t2n) = dratrawdt(irli7t2n) * scli7t 1 + ratraw(irli7t2n) * scli7tdt dratdumdd(irli7t2n) = dratrawdd(irli7t2n) * scli7t 1 + ratraw(irli7t2n) * scli7tdd scfac(irli7t2n) = scli7t dscfacdt(irli7t2n) = scli7tdt dscfacdd(irli7t2n) = scli7tdd c..li7(p,g)be8 and li7(p,a)he4 i = i + 1 ratdum(irli7pag) = ratraw(irli7pag) dratdumdt(irli7pag) = dratrawdt(irli7pag) dratdumdd(irli7pag) = dratrawdd(irli7pag) scfac(irli7pag) = 1.0d0 dscfacdt(irli7pag) = 0.0d0 dscfacdd(irli7pag) = 0.0d0 i = i + 1 ratdum(ir2he4ga) = ratraw(ir2he4ga) dratdumdt(ir2he4ga) = dratrawdt(ir2he4ga) dratdumdd(ir2he4ga) = dratrawdd(ir2he4ga) scfac(ir2he4ga) = 1.0d0 dscfacdt(ir2he4ga) = 0.0d0 dscfacdd(ir2he4ga) = 0.0d0 c..li7(d,n)2a i = i + 1 ratdum(irli7dn) = ratraw(irli7dn) * scli7d dratdumdt(irli7dn) = dratrawdt(irli7dn) * scli7d 1 + ratraw(irli7dn) * scli7ddt dratdumdd(irli7dn) = dratrawdd(irli7dn) * scli7d 1 + ratraw(irli7dn) * scli7ddd scfac(irli7dn) = scli7d dscfacdt(irli7dn) = scli7ddt dscfacdd(irli7dn) = scli7ddd c..li7(he3,np)2a i = i + 1 ratdum(irli7he3np) = ratraw(irli7he3np) * scli7he3 dratdumdt(irli7he3np) = dratrawdt(irli7he3np) * scli7he3 1 + ratraw(irli7he3np) * scli7he3dt dratdumdd(irli7he3np) = dratrawdd(irli7he3np) * scli7he3 1 + ratraw(irli7he3np) * scli7he3dd scfac(irli7he3np) = scli7he3 dscfacdt(irli7he3np) = scli7he3dt dscfacdd(irli7he3np) = scli7he3dd end if if (ibe7 .ne. 0) then c..be7(d,p)2a i = i + 1 ratdum(irbe7dp) = ratraw(irbe7dp) * scbe7d dratdumdt(irbe7dp) = dratrawdt(irbe7dp) * scbe7d 1 + ratraw(irbe7dp) * scbe7ddt dratdumdd(irbe7dp) = dratrawdd(irbe7dp) * scbe7d 1 + ratraw(irbe7dp) * scbe7ddd scfac(irbe7dp) = scbe7d dscfacdt(irbe7dp) = scbe7ddt dscfacdd(irbe7dp) = scbe7ddd c..be7(t,np)2a i = i + 1 ratdum(irbe7tnp) = ratraw(irbe7tnp) * scbe7t dratdumdt(irbe7tnp) = dratrawdt(irbe7tnp) * scbe7t 1 + ratraw(irbe7tnp) * scbe7tdt dratdumdd(irbe7tnp) = dratrawdd(irbe7tnp) * scbe7t 1 + ratraw(irbe7tnp) * scbe7tdd scfac(irbe7tnp) = scbe7t dscfacdt(irbe7tnp) = scbe7tdt dscfacdd(irbe7tnp) = scbe7tdd c..be7(he3,2p)2a i = i + 1 ratdum(irbe7he32p) = ratraw(irbe7he32p) * scbe7he3 dratdumdt(irbe7he32p) = dratrawdt(irbe7he32p) * scbe7he3 1 + ratraw(irbe7he32p) * scbe7he3dt dratdumdd(irbe7he32p) = dratrawdd(irbe7he32p) * scbe7he3 1 + ratraw(irbe7he32p) * scbe7he3dd scfac(irbe7he32p) = scbe7he3 dscfacdt(irbe7he32p) = scbe7he3dt dscfacdd(irbe7he32p) = scbe7he3dd end if if (ibe9 .ne. 0) then c..a(an,g)be9 i = i + 1 ratdum(iraan) = ratraw(iraan) * sc1a dratdumdt(iraan) = dratrawdt(iraan)*sc1a + ratraw(iraan)*sc1adt dratdumdd(iraan) = dratrawdd(iraan)*sc1a + ratraw(iraan)*sc1add scfac(iraan) = sc1a dscfacdt(iraan) = sc1adt dscfacdd(iraan) = sc1add i = i + 1 ratdum(irgaan) = ratraw(irgaan) dratdumdt(irgaan) = dratrawdt(irgaan) dratdumdd(irgaan) = dratrawdd(irgaan) scfac(irgaan) = 1.0d0 dscfacdt(irgaan) = 0.0d0 dscfacdd(irgaan) = 0.0d0 c..be9(p,d)be8 =>2a i = i + 1 ratdum(irbe9pd) = ratraw(irbe9pd) dratdumdt(irbe9pd) = dratrawdt(irbe9pd) dratdumdd(irbe9pd) = dratrawdd(irbe9pd) scfac(irbe9pd) = 1.0d0 dscfacdt(irbe9pd) = 0.0d0 dscfacdd(irbe9pd) = 0.0d0 end if if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions i = i + 1 ratdum(irb8ep) = ratraw(irb8ep) dratdumdt(irb8ep) = dratrawdt(irb8ep) dratdumdd(irb8ep) = dratrawdd(irb8ep) scfac(irb8ep) = 1.0d0 dscfacdt(irb8ep) = 0.0d0 dscfacdd(irb8ep) = 0.0d0 end if if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions i = i + 1 ratdum(irb11pa) = ratraw(irb11pa) dratdumdt(irb11pa) = dratrawdt(irb11pa) dratdumdd(irb11pa) = dratrawdd(irb11pa) scfac(irb11pa) = 1.0d0 dscfacdt(irb11pa) = 1.0d0 dscfacdd(irb11pa) = 1.0d0 i = i + 1 ratdum(ir3ap) = ratraw(ir3ap) dratdumdt(ir3ap) = dratrawdt(ir3ap) dratdumdd(ir3ap) = dratrawdd(ir3ap) scfac(ir3ap) = 1.0d0 dscfacdt(ir3ap) = 0.0d0 dscfacdd(ir3ap) = 0.0d0 end if c..c11(na)be8 => 2a if (ic11 .ne. 0) then i = i + 1 ratdum(irc11na) = ratraw(irc11na) dratdumdt(irc11na) = dratrawdt(irc11na) dratdumdd(irc11na) = dratrawdd(irc11na) scfac(irc11na) = 1.0d0 dscfacdt(irc11na) = 0.0d0 dscfacdd(irc11na) = 0.0d0 end if c..bullet check the counting if (i .ne. nrat) then write(6,*) write(6,*) 'in screen_torch i=',i write(6,*) 'in screen_torch nrat=',nrat write(6,*) 'i is not equal to nrat' write(6,*) 'fatal counting error' write(6,*) stop 'fatal counting error in screen_torch' end if c..debugs c do i=1,nrat c if (ratdum(i) .lt. 0.0) then c write(6,110) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c 110 format(1x,i4,' ',a,' ',1p3e12.4) c stop 'negative rate' c end if c enddo c read(5,*) c open(unit=22,file='rate_chek.dat',status='unknown') c write(6,109) btemp,bden,nrat c write(22,109) btemp,bden,nrat c 109 format(1x,1p2e14.6,i6) c do i=1,nrat c if (ratraw(i) .gt. 0.0) then c write(6,111) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c write(22,111) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c write(6,111) i,ratnam(i),ratraw(i),dratrawdt(i),dratrawdd(i) c write(22,111) i,ratnam(i),ratraw(i),dratrawdt(i),dratrawdd(i) c 111 format(1x,i4,' ',a,' ',1p8e10.2) c end if c enddo c close(unit=22) c write(6,*) 'wrote rates to rate_chek.dat' c read(5,*) c write(6,117) ratraw(irpen),scfac(irpen),ratdum(irpen) c write(6,117) ratraw(irnep),scfac(irnep),ratdum(irnep) c write(6,117) ratraw(ir3a),scfac(ir3a),ratdum(ir3a) c write(6,117) ratraw(irg3a),scfac(irg3a),ratdum(irg3a) c write(6,117) ratdum(ir3a),ratdum(irg3a) c write(6,117) sigraw(13,img24),sigraw(14,img24) c write(6,117) sigraw(9,iti44),sigraw(10,iti44) 117 format(1x,1p3e14.6) c read(5,*) return end subroutine init_torch include 'implno.dek' include 'const.dek' include 'network.dek' c.. c..this routine initializes stuff for the torch network c.. c..declare logical ibhere integer zmax,fil14 parameter (zmax=85) parameter (fil14=14) character*132 string,word character*2 zsymb(zmax) character*10 aname integer i,j,k,l,ii,jj,ll,llmin,llmax,mm,j1,nz,na,nn,kk, 1 aidmin(zmax),aidmax(zmax),inta,intz 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) double precision dum,qful,xx c..here are the root isotope names data zsymb/'h ','he','li','be','b ','c ','n ','o ','f ','ne', 1 'na','mg','al','si','p ','s ','cl','ar','k ','ca', 2 'sc','ti','v ','cr','mn','fe','co','ni','cu','zn', 3 'ga','ge','as','se','br','kr','rb','sr','y ','zr', 4 'nb','mo','tc','ru','rh','pd','ag','cd','in','sn', 5 'sb','te','i' ,'xe','cs','ba','la','ce','pr','nd', 6 'pm','sm','eu','gd','tb','dy','ho','er','tm','yb', 7 'lu','hf','ta','w' ,'re','os','ir','pt','au','hg', 8 'tl','pb','bi','po','at'/ c..here are the min and max a's for each z data aidmin/ 2, 3, 6, 7, 8, 9, 11, 13, 14, 16, 1 17, 18, 20, 22, 23, 24, 25, 27, 30, 30, 2 34, 34, 38, 38, 42, 42, 46, 46, 50, 51, 3 55, 55, 59, 59, 63, 63, 68, 68, 72, 72, 4 76, 77, 81, 81, 85, 86, 88, 90, 92, 94, 5 97, 99, 101, 103, 106, 108, 110, 113, 115, 118, 6 120, 123, 125, 128, 130, 133, 136, 138, 141, 143, 7 146, 150, 153, 154, 160, 160, 164, 165, 168, 170, 8 172, 174, 176, 182, 188/ data aidmax/ 3, 6, 9, 12, 14, 18, 21, 22, 26, 31, 1 44, 47, 51, 54, 57, 60, 63, 67, 70, 73, 2 76, 80, 83, 86, 89, 92, 96, 99, 102, 105, 3 108, 112, 115, 118, 121, 124, 128, 131, 134, 137, 4 140, 144, 147, 150, 153, 156, 160, 163, 166, 169, 5 171, 173, 175, 177, 179, 181, 183, 185, 187, 189, 6 191, 193, 195, 197, 199, 201, 203, 205, 207, 209, 7 213, 214, 219, 220, 225, 226, 231, 234, 237, 240, 8 245, 246, 251, 237, 239/ c..popular format statements 01 format(a,i4) 06 format(2i5,f10.4) 07 format(f10.3) 08 format(6f10.3) 09 format(1x,i4,i4,i4,' ',a5) 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..decide on the arrow orientation c..downarrow true puts neutron, protons, alfa to the end c..downarrow false (i.e uparrow) puts neutron, protons, alfa at the beginning c..in general downarrowtrue is faster for dense linear algebra, and either c..orientation for sparse linear algebra. gift routines, however, do c..much better with uparrow (downarrow false). downarrow = .true. c downarrow = .false. c..set the beginning isotope index if (downarrow) then ionbeg = 1 else ionbeg = 4 end if c..open the nuclear recation rate data file c..use a soft link to connect bdat to the desired burn data file open(unit=fil14,file='BDAT',status='old') c..now start reading the nuclear reaction rate data file c..i is the code number of element z(i),n(i). c..j = 1 = ng j = 6 = an c..j = 2 = pn j = 7 = ag c..j = 3 = ground state b- j = 8 for semi-empirical electron captur c..j = 4 = pg j = 9 for semi-empirical positron decay c..j = 5 = ap j = 10 for semi-empirical beta decay c..ic1(j,i) = type formula to be used to calculate rate c..ic2(j,i) = number of constants in fitting reaction j on species i c..ic3(j,i) = where to start counting ic2 from c..initialize counters nful = 0 nfulnot = 0 k = 1 i = ionbeg - 1 do nn=1,ionmax icode2(nn) = 0 enddo c..put neutrons, protons and alfa first for up-arrow orientation if (.not.downarrow) then ineut = 1 aion(ineut) = 1.0d0 nion(ineut) = 1.0d0 zion(ineut) = 0.0d0 bion(ineut) = 0.0d0 c mion(ineut) = nion(ineut)*mn + zion(ineut)*mp + zion(ineut)*me c 1 -bion(ineut)*mev2gr mion(ineut) = nion(ineut)*mn +zion(ineut)*mp -bion(ineut)*mev2gr wion(ineut) = avo * mion(ineut) wpart(ineut) = 2.0d0 ionam(ineut) = 'neut' iprot = 2 aion(iprot) = 1.0d0 nion(iprot) = 0.0d0 zion(iprot) = 1.0d0 bion(iprot) = 0.0d0 c mion(iprot) = nion(iprot)*mn + zion(iprot)*mp + zion(iprot)*me c 1 - bion(iprot)*mev2gr mion(iprot) = nion(iprot)*mn +zion(iprot)*mp -bion(iprot)*mev2gr wion(iprot) = avo * mion(iprot) wpart(iprot) = 2.0d0 ionam(iprot) = 'prot' ihe4 = 3 aion(ihe4) = 4.0d0 nion(ihe4) = 2.0d0 zion(ihe4) = 2.0d0 bion(ihe4) = 28.29603d0 c mion(ihe4) = nion(ihe4)*mn + zion(ihe4)*mp + zion(ihe4)*me c 1 - bion(ihe4)*mev2gr mion(ihe4) = nion(ihe4)*mn + zion(ihe4)*mp - bion(ihe4)*mev2gr wion(ihe4) = avo * mion(ihe4) wpart(ihe4) = 1.0d0 ionam(ihe4) = 'he4' end if c..we keep returning here from various goto and loop constructions 60 i = i+1 c..read in the z and a and any fitting constants c write(6,*) 'reading', i read(fil14,02) nz,na,(ic1(j,i),ic2(j,i), j=1,10) 02 format(2i6,20i3) c write(6,*) 'read', nz,na zion(i) = nz aion(i) = na if (nz .eq. 99) go to 120 c..temperature dependent partition function information llmin = 5*(i-1)+1 llmax = llmin + 4 if (llmax .gt. 6*abignet) stop 'past as bounds' read(fil14,03) nz,nn,bion(i),(as(ll),ll=llmin,llmax),ist(i),aname 03 format(2i3,f11.4,f5.1,4e12.3,i2,a10) nion(i) = nn if (ist(i).ne.0) then if (6*i-6+2*ist(i) .gt. 6*abignet) stop 'past gs bounds' read(fil14,04) (gs(ll),ll=6*i-5,6*i-6+2*ist(i)) end if 04 format(f10.4,f10.3,f10.4,f10.3,f10.4,f10.3,f10.4,f10.3) c..decide if this isotope is in the network and branch accordingly do jj=1,inetin if (int(zion(i)) .eq. izzz(jj) .and. 1 int(nion(i)) .ge. inmin(jj) .and. 2 int(nion(i)) .le. inmax(jj)) goto 90 enddo c..not using this isotope, but c..do the read, backup i by one, and go back to 60 for another isotope do jj=1,10 if (ic1(jj,i) .gt. 0) then c..bdat921 takes format 05, rath_005.bdat takes format 240 c read(fil14,05) (dum,j1=1,ic2(jj,i)) read(fil14,240) (dum,j1=1,ic2(jj,i)) 05 format(7e10.3) 240 format (7e13.6) end if enddo i = i - 1 go to 60 c..using this isotope, read parameters for reaction j on species i 90 continue if (i .gt. abignet) stop 'abignet too small in init_torch' c..here are the isotopes we are using c call sqeeze(aname) c write(6,117) i,int(zion(i)),int(aion(i)),aname c 117 format(1x,3i4,' ',a) do j=1,8 ic3(j,i) = k if (ic1(j,i) .gt. 0) then kmax = k + ic2(j,i)-1 if (kmax .gt. cxdim) then write(6,*) 'kmax =', kmax,' cxdim =',cxdim stop 'kmax > cxdim in routine init_torch' end if c..bdat921 takes format 05, rath_005.bdat takes format 240 c read(fil14,05) (cx(j1), j1=k,kmax) read(fil14,240) (cx(j1), j1=k,kmax) k = kmax + 1 end if enddo c..and go back for another isotope go to 60 c..all done with the this part of the loading 120 continue c..append neutrons, protons and alfa if down arrow c..set the ending isotope index ionend if (downarrow) then ionmax = i ineut = ionmax aion(ineut) = 1.0d0 nion(ineut) = 1.0d0 zion(ineut) = 0.0d0 bion(ineut) = 0.0d0 c mion(ineut) = nion(ineut)*mn + zion(ineut)*mp + zion(ineut)*me c 1 - bion(ineut)*mev2gr mion(ineut) = nion(ineut)*mn +zion(ineut)*mp -bion(ineut)*mev2gr wion(ineut) = avo * mion(ineut) wpart(ineut) = 2.0d0 ionam(ineut) = 'neut' c.. ionmax = ionmax + 1 iprot = ionmax aion(iprot) = 1.0d0 nion(iprot) = 0.0d0 zion(iprot) = 1.0d0 bion(iprot) = 0.0d0 c mion(iprot) = nion(iprot)*mn + zion(iprot)*mp + zion(iprot)*me c 1 - bion(iprot)*mev2gr mion(iprot) = nion(iprot)*mn +zion(iprot)*mp -bion(iprot)*mev2gr wion(iprot) = avo * mion(iprot) wpart(iprot) = 2.0d0 ionam(iprot) = 'prot' c.. ionmax = ionmax + 1 ihe4 = ionmax aion(ihe4) = 4.0d0 nion(ihe4) = 2.0d0 zion(ihe4) = 2.0d0 bion(ihe4) = 28.29603d0 c mion(ihe4) = nion(ihe4)*mn + zion(ihe4)*mp + zion(ihe4)*me c 1 - bion(ihe4)*mev2gr mion(ihe4) = nion(ihe4)*mn + zion(ihe4)*mp - bion(ihe4)*mev2gr wion(ihe4) = avo * mion(ihe4) wpart(ihe4) = 1.0d0 ionam(ihe4) = 'he4' ionend = ionmax - 3 c..for up-arrow configurations else ionmax = i - 1 ionend = ionmax end if c..for either orientation, append energy, temperature, and denisty pointers iener = ionmax + 1 itemp = ionmax + 2 iden = ionmax + 3 ivelx = ionmax + 4 iposx = ionmax + 5 neqs = iposx ionam(iener) = 'ener ' ionam(itemp) = 'temp ' ionam(iden) = 'den ' ionam(ivelx) = 'velx ' ionam(iposx) = 'posx ' c..number of neutrons and do i = ionbeg,ionend nion(i) = aion(i) - zion(i) enddo c..mass of each isotope assuming fully ionized do i = ionbeg,ionend c mion(i) = nion(i)*mn + zion(i)*mp + zion(i)*me - bion(i)*mev2gr mion(i) = nion(i)*mn + zion(i)*mp - bion(i)*mev2gr enddo c..molar mass of each isotope do i = ionbeg,ionend wion(i) = avo * mion(i) enddo c..here is a common approximation do i=1,ionmax wion(i) = aion(i) enddo c..read data for electron capture on proton and positron capture on neutron c read(fil14,05) ((rrpen(j,i),i=1,7),j=1,6) c read(fil14,05) ((rrnep(j,i),i=1,7),j=1,6) read(fil14,05) ((xx,i=1,7),j=1,6) read(fil14,05) ((xx,i=1,7),j=1,6) c..build the links between the isotopes in the network c..before reading the weak reaction rates call naray c..read data for fuller weak rates. data is ordered in sequence of c..decreasing q-value for electron capture (in electron rest masses). icode c..keeps the matrix location of the isotope that is beta-decaying. data is c..tabular with 6 values of density and 7 of temperature. five quantities are c..tabulated: positron decay rate, effective electron capture ft value, beta c..decay rate, neutrino loss rate, and anti-neutrino loss rate. 140 read(fil14,06) nz,nn,qful if (nz.eq.99) go to 190 c..see if the isotope is in the network do i=ionbeg,ionend if (int(zion(i)) .eq. nz .and. int(nion(i)) .eq. nn 1 .and. nrr(2,i) .ne. 0) then nful = nful + 1 if (qful .gt. -1.0) nfulnot = nfulnot + 1 read(fil14,08) ((datful(nful,j,k),j=1,6),k=1,7) read(fil14,08) ((datful(nfuldim+nful,j,k),j=1,6),k=1,7) read(fil14,08) ((datful(2*nfuldim+nful,j,k),j=1,6),k=1,7) read(fil14,08) ((datful(3*nfuldim+nful,j,k),j=1,6),k=1,7) read(fil14,08) ((datful(4*nfuldim+nful,j,k),j=1,6),k=1,7) icode(nful) = i icode2(i) = nful qn(nful) = qful goto 140 end if enddo c..didn't find the isotope, or isotope in list but no link, still do the read do mm=1,35 read(fil14,07) xx enddo goto 140 c..finally all done reading the nuclear reaction rate file 190 continue close(unit=fil14) c..set the isotope names and pointers c write(6,*) ' ' c write(6,*) ' using isotopes:' c write(6,*) ' i z a name' if (.not.downarrow) then i = ineut inta = aion(i) intz = zion(i) c write(6,09) ineut,intz,inta,ineut,ionam(i) i = iprot inta = aion(i) intz = zion(i) c write(6,09) iprot,intz,inta,ionam(i) i = ihe4 inta = aion(i) intz = zion(i) c write(6,09) ihe4,intz,inta,ionam(i) endif do i=ionbeg,ionend inta = aion(i) intz = zion(i) if (intz .ge. 1 .and. intz .le. zmax) then if (inta .ge. aidmin(intz) .and. inta .le. aidmax(intz)) then do ii = aidmin(intz),aidmax(intz) if (ii .eq. inta) then write(string,01) zsymb(intz),inta call sqeeze(string) ionam(i) = string c write(6,09) i,intz,inta,ionam(i) end if enddo else write(6,*) ' bad aion',inta,' in routine init_torch' write(6,*) ' zion=',intz write(6,*) ' amin=',aidmin(intz),' amax=',aidmax(intz) stop 'error: bad inta in routine init_torch' end if else write(6,*) 'bad zion',intz,' in routine init_torch' write(6,*) 'inta =',inta,' zmax=', zmax stop 'error: bad intz in routine init_torch' end if enddo if (downarrow) then i = ineut inta = aion(i) intz = zion(i) c write(6,09) ionmax-2,intz,inta,ionam(i) i = iprot inta = aion(i) intz = zion(i) c write(6,09) ionmax-1,intz,inta,ionam(i) i = ihe4 inta = aion(i) intz = zion(i) c write(6,09) ionmax,intz,inta,ionam(i) endif c..check some things c do i=1,ionmax c write(6,888) ionam(i), c 1 int(zion(i)),int(nion(i)),int(aion(i)), c 1 mion(i)*avo,(mion(i)*avo-aion(i)), c 2 (mion(i)*avo-aion(i))/(mev2gr*avo) c 888 format(1x,a,3i4,1p5e18.10) c enddo c..set the id numbers of certain key isotopes do i=ionbeg,ionend if (ionam(i) .eq. 'h2 ') then ih2 = i else if (ionam(i) .eq. 'h3 ') then ih3 = i else if (ionam(i) .eq. 'he3 ') then ihe3 = i else if (ionam(i) .eq. 'li6 ') then ili6 = i else if (ionam(i) .eq. 'li7 ') then ili7 = i else if (ionam(i) .eq. 'li8 ') then ili8 = i else if (ionam(i) .eq. 'be7 ') then ibe7 = i else if (ionam(i) .eq. 'be9 ') then ibe9 = i else if (ionam(i) .eq. 'b8 ') then ib8 = i else if (ionam(i) .eq. 'b9 ') then ib9 = i else if (ionam(i) .eq. 'b10 ') then ib10 = i else if (ionam(i) .eq. 'b11 ') then ib11 = i else if (ionam(i) .eq. 'c11 ') then ic11 = i else if (ionam(i) .eq. 'c12 ') then ic12 = i else if (ionam(i) .eq. 'c13 ') then ic13 = i else if (ionam(i) .eq. 'c14 ') then ic14 = i else if (ionam(i) .eq. 'n12 ') then in12 = i else if (ionam(i) .eq. 'n13 ') then in13 = i else if (ionam(i) .eq. 'n14 ') then in14 = i else if (ionam(i) .eq. 'n15 ') then in15 = i else if (ionam(i) .eq. 'o14 ') then io14 = i else if (ionam(i) .eq. 'o15 ') then io15 = i else if (ionam(i) .eq. 'o16 ') then io16 = i else if (ionam(i) .eq. 'o17 ') then io17 = i else if (ionam(i) .eq. 'o18 ') then io18 = i else if (ionam(i) .eq. 'f17 ') then if17 = i else if (ionam(i) .eq. 'f18 ') then if18 = i else if (ionam(i) .eq. 'f19 ') then if19 = i else if (ionam(i) .eq. 'ne18 ') then ine18 = i else if (ionam(i) .eq. 'ne19 ') then ine19 = i else if (ionam(i) .eq. 'ne20 ') then ine20 = i else if (ionam(i) .eq. 'ne21 ') then ine21 = i else if (ionam(i) .eq. 'ne22 ') then ine22 = i else if (ionam(i) .eq. 'na20 ') then ina20 = i else if (ionam(i) .eq. 'na21 ') then ina21 = i else if (ionam(i) .eq. 'na22 ') then ina22 = i else if (ionam(i) .eq. 'na23 ') then ina23 = i else if (ionam(i) .eq. 'mg22 ') then img22 = i else if (ionam(i) .eq. 'mg23 ') then img23 = i else if (ionam(i) .eq. 'mg24 ') then img24 = i else if (ionam(i) .eq. 'mg25 ') then img25 = i else if (ionam(i) .eq. 'mg26 ') then img26 = i else if (ionam(i) .eq. 'al25 ') then ial25 = i else if (ionam(i) .eq. 'al26 ') then ial26 = i else if (ionam(i) .eq. 'al27 ') then ial27 = i else if (ionam(i) .eq. 'si27 ') then isi27 = i else if (ionam(i) .eq. 'si28 ') then isi28 = i else if (ionam(i) .eq. 'si29 ') then isi29 = i else if (ionam(i) .eq. 'si30 ') then isi30 = i else if (ionam(i) .eq. 'p30 ') then ip30 = i else if (ionam(i) .eq. 'p31 ') then ip31 = i else if (ionam(i) .eq. 's30 ') then is30 = i else if (ionam(i) .eq. 's31 ') then is31 = i else if (ionam(i) .eq. 's32 ') then is32 = i else if (ionam(i) .eq. 'cl35 ') then icl35 = i else if (ionam(i) .eq. 'ar36 ') then iar36 = i else if (ionam(i) .eq. 'k39 ') then ik39 = i else if (ionam(i) .eq. 'ca40 ') then ica40 = i else if (ionam(i) .eq. 'sc43 ') then isc43 = i else if (ionam(i) .eq. 'sc45 ') then isc45 = i else if (ionam(i) .eq. 'ti44 ') then iti44 = i else if (ionam(i) .eq. 'ti46 ') then iti46 = i else if (ionam(i) .eq. 'ti48 ') then iti48 = i else if (ionam(i) .eq. 'ti50 ') then iti50 = i else if (ionam(i) .eq. 'v46 ') then iv46 = i else if (ionam(i) .eq. 'v47 ') then iv47 = i else if (ionam(i) .eq. 'v48 ') then iv48 = i else if (ionam(i) .eq. 'v51 ') then iv51 = i else if (ionam(i) .eq. 'cr47 ') then icr47 = i else if (ionam(i) .eq. 'cr48 ') then icr48 = i else if (ionam(i) .eq. 'cr49 ') then icr49 = i else if (ionam(i) .eq. 'cr50 ') then icr50 = i else if (ionam(i) .eq. 'cr51 ') then icr51 = i else if (ionam(i) .eq. 'cr52 ') then icr52 = i else if (ionam(i) .eq. 'cr53 ') then icr53 = i else if (ionam(i) .eq. 'cr54 ') then icr54 = i else if (ionam(i) .eq. 'mn50 ') then imn50 = i else if (ionam(i) .eq. 'mn51 ') then imn51 = i else if (ionam(i) .eq. 'mn52 ') then imn52 = i else if (ionam(i) .eq. 'mn55 ') then imn55 = i else if (ionam(i) .eq. 'fe52 ') then ife52 = i else if (ionam(i) .eq. 'fe54 ') then ife54 = i else if (ionam(i) .eq. 'fe55 ') then ife55 = i else if (ionam(i) .eq. 'fe56 ') then ife56 = i else if (ionam(i) .eq. 'fe57 ') then ife57 = i else if (ionam(i) .eq. 'fe58 ') then ife58 = i else if (ionam(i) .eq. 'co54 ') then ico54 = i else if (ionam(i) .eq. 'co55 ') then ico55 = i else if (ionam(i) .eq. 'co56 ') then ico56 = i else if (ionam(i) .eq. 'co59 ') then ico59 = i else if (ionam(i) .eq. 'ni56 ') then ini56 = i else if (ionam(i) .eq. 'ni58 ') then ini58 = i else if (ionam(i) .eq. 'ni59 ') then ini59 = i else if (ionam(i) .eq. 'ni64 ') then ini64 = i else if (ionam(i) .eq. 'ni66 ') then ini66 = i else if (ionam(i) .eq. 'cu63 ') then icu63 = i else if (ionam(i) .eq. 'zn60 ') then izn60 = i else if (ionam(i) .eq. 'zn64 ') then izn64 = i end if enddo c..set reaction rate names and pointers nrat = 0 do j=ionbeg,ionend if (nrat+14 .gt. abigrat) stop 'nrat > abigrat in init_torch' c..set up the (n,g) and (g,n) names and a few reaction rate pointers k = nrr(1,j) if (k .gt. 0) then string = ionam(j)//'(n,g)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string string = ionam(k)//'(g,n)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ih2 .and. k .eq. ih3) then irdng = nrat-1 irtgn = nrat else if (j .eq. ili6 .and. k .eq. ili7) then irli6ng = nrat-1 irli7gn = nrat else if (j .eq. ili7 .and. k .eq. ili8) then irli7ng = nrat-1 irli8gn = nrat else if (j .eq. ine20 .and. k .eq. ine21) then irne20ng = nrat-1 irne21gn = nrat end if end if c..set up the (p,n) (n,p) beta- beta+ decay names and a few reaction rate pointers k = nrr(2,j) if (k .gt. 0) then string = ionam(j)//'(p,n)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string string = ionam(k)//'(n,p)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ih3 .and. k .eq. ihe3) then irtpn = nrat - 1 irhe3np = nrat else if (j .eq. ili7 .and. k .eq. ibe7) then irli7pn = nrat - 1 irbe7np = nrat else if (j .eq. ibe9 .and. k .eq. ib9) then irbe9pn = nrat - 1 irb9np = nrat else if (j .eq. ib11 .and. k .eq. ic11) then irb11pn = nrat - 1 irc11np = nrat else if (j .eq. ic13 .and. k .eq. in13) then irc13pn = nrat - 1 irn13np = nrat else if (j .eq. ic14 .and. k .eq. in14) then irc14pn = nrat - 1 irn13np = nrat else if (j .eq. in14 .and. k .eq. io14) then irn14pn = nrat - 1 iro14np = nrat else if (j .eq. in15 .and. k .eq. io15) then irn15pn = nrat - 1 iro15np = nrat else if (j .eq. if19 .and. k .eq. ine19) then irf19pn = nrat - 1 irne19np = nrat else if (j .eq. ine22 .and. k .eq. ina22) then irne22pn = nrat - 1 irna22np = nrat else if (j .eq. ina23 .and. k .eq. img23) then irna23pn = nrat - 1 irmg23np = nrat end if string = ionam(j)//'(n=>p)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ibe7 .and. k .eq. ili7) irbeec = nrat string = ionam(k)//'(p=>n)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string end if c..set up the (p,g) and (g,p) names and a few reaction rate pointers k = nrr(3,j) if (k .gt. 0) then string = ionam(j)//'(p,g)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string string = ionam(k)//'(g,p)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ih2 .and. k .eq. ihe3) then irdpg = nrat - 1 irhe3gp = nrat else if (j .eq. ili6 .and. k .eq. ibe7) then irli6pg = nrat - 1 irbe7gp = nrat else if (j .eq. ibe7 .and. k .eq. ib8) then irbe7pg = nrat - 1 irb8gp = nrat else if (j .eq. ibe9 .and. k .eq. ib10) then irbe9pg = nrat - 1 irb10gp = nrat else if (j .eq. ib10 .and. k .eq. ic11) then irb10pg = nrat - 1 irc11gp = nrat else if (j .eq. ib11 .and. k .eq. ic12) then irb11pg = nrat - 1 irc12gp = nrat else if (j .eq. ic11 .and. k .eq. in12) then irc11pg = nrat - 1 irn12gp = nrat else if (j .eq. ic14 .and. k .eq. in15) then irc14pg = nrat - 1 irn15gp = nrat else if (j .eq. in13 .and. k .eq. io14) then irn13pg = nrat - 1 iro14gp = nrat else if (j .eq. in14 .and. k .eq. io15) then irn14pg = nrat - 1 iro15gp = nrat else if (j .eq. in15 .and. k .eq. io16) then irn15pg = nrat - 1 iro16gp = nrat else if (j .eq. io16 .and. k .eq. if17) then iro16pg = nrat - 1 irf17gp = nrat else if (j .eq. io17 .and. k .eq. if18) then iro17pg = nrat - 1 irf18gp = nrat else if (j .eq. io18 .and. k .eq. if19) then iro18pg = nrat - 1 irf19gp = nrat else if (j .eq. if17 .and. k .eq. ine18) then irf17pg = nrat - 1 irne18gp = nrat else if (j .eq. if18 .and. k .eq. ine19) then irf18pg = nrat - 1 irne19gp = nrat else if (j .eq. if19 .and. k .eq. ine20) then irf19pg = nrat - 1 irne20gp = nrat else if (j .eq. ine19 .and. k .eq. ina20) then irne19pg = nrat - 1 irna20gp = nrat else if (j .eq. ine20 .and. k .eq. ina21) then irne20pg = nrat - 1 irna21gp = nrat else if (j .eq. ine21 .and. k .eq. ina22) then irne21pg = nrat - 1 irna22gp = nrat else if (j .eq. ine22 .and. k .eq. ina23) then irne22pg = nrat - 1 irna23gp = nrat else if (j .eq. ina21 .and. k .eq. img22) then irna21pg = nrat - 1 irmg22gp = nrat else if (j .eq. ina22 .and. k .eq. img23) then irna22pg = nrat - 1 irmg23gp = nrat else if (j .eq. ina23 .and. k .eq. img24) then irna23pg = nrat - 1 irmg24gp = nrat else if (j .eq. img24 .and. k .eq. ial25) then irmg24pg = nrat - 1 iral25gp = nrat else if (j .eq. img25 .and. k .eq. ial26) then irmg25pg = nrat - 1 iral26gp = nrat else if (j .eq. img26 .and. k .eq. ial27) then irmg26pg = nrat - 1 iral27gp = nrat else if (j .eq. ial25 .and. k .eq. isi26) then iral25pg = nrat - 1 irsi26gp = nrat else if (j .eq. ial26 .and. k .eq. isi27) then iral26pg = nrat - 1 irsi27gp = nrat else if (j .eq. ial27 .and. k .eq. isi28) then iral27pg = nrat - 1 irsi28gp = nrat else if (j .eq. isi27 .and. k .eq. ip28) then irsi27pg = nrat - 1 irp28gp = nrat else if (j .eq. isi28 .and. k .eq. ip29) then irsi28pg = nrat - 1 irp29gp = nrat else if (j .eq. isi29 .and. k .eq. ip30) then irsi29pg = nrat - 1 irp30gp = nrat else if (j .eq. isi30 .and. k .eq. ip31) then irsi30pg = nrat - 1 irp31gp = nrat end if end if c..set up the (a,p) and (p,a) names and a few reaction rate pointers k = nrr(4,j) if (k .gt. 0) then string = ionam(j)//'(a,p)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string string = ionam(k)//'(p,a)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ihe3 .and. k .eq. ili6) then irhe3ap = nrat - 1 irli6pa = nrat else if (j .eq. ili6 .and. k .eq. ibe9) then irli6ap = nrat - 1 irbe9pa = nrat else if (j .eq. ibe7 .and. k .eq. ib10) then irbe7ap = nrat - 1 irb10pa = nrat else if (j .eq. ib8 .and. k .eq. ic11) then irb8ap = nrat - 1 irc11pa = nrat else if (j .eq. ib11 .and. k .eq. ic14) then irb11ap = nrat - 1 irc14pa = nrat else if (j .eq. ic11 .and. k .eq. in14) then irc11ap = nrat - 1 irn14pa = nrat else if (j .eq. in13 .and. k .eq. io16) then irn13ap = nrat - 1 iro16pa = nrat else if (j .eq. in14 .and. k .eq. io17) then irn14ap = nrat - 1 iro17pa = nrat else if (j .eq. in15 .and. k .eq. io18) then irn15ap = nrat - 1 iro18pa = nrat else if (j .eq. io14 .and. k .eq. if17) then iro14ap = nrat - 1 irf17pa = nrat else if (j .eq. io15 .and. k .eq. if18) then iro15ap = nrat - 1 irf18pa = nrat else if (j .eq. io16 .and. k .eq. if19) then iro16ap = nrat - 1 irf19pa = nrat else if (j .eq. if17 .and. k .eq. ine20) then irf17ap = nrat - 1 irne20pa = nrat else if (j .eq. if19 .and. k .eq. ine22) then irf19ap = nrat - 1 irne22pa = nrat else if (j .eq. ine20 .and. k .eq. ina23) then irne20ap = nrat - 1 irna23pa = nrat else if (j .eq. ina21 .and. k .eq. img24) then irna21ap = nrat - 1 irmg24pa = nrat else if (j .eq. img24 .and. k .eq. ial27) then irmg24ap = nrat - 1 iral27pa = nrat else if (j .eq. img25 .and. k .eq. ial28) then irmg25ap = nrat - 1 iral28pa = nrat end if end if c..set up the (a,n) and (n,a) names and a few reaction rate pointers k = nrr(5,j) if (k .gt. 0) then string = ionam(j)//'(a,n)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string string = ionam(k)//'(n,a)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ih3 .and. k .eq. ili6) then irtan = nrat irli6na = nrat else if (j .eq. ili7 .and. k .eq. ib10) then irli7an = nrat - 1 irb10na = nrat else if (j .eq. ibe9 .and. k .eq. ic12) then irbe9an = nrat - 1 irc12na = nrat else if (j .eq. ib10 .and. k .eq. in13) then irb10an = nrat - 1 irn13na = nrat else if (j .eq. ib11 .and. k .eq. in14) then irb11an = nrat - 1 irn14na = nrat else if (j .eq. ic12 .and. k .eq. io15) then irc12an = nrat - 1 iro15na = nrat else if (j .eq. ic13 .and. k .eq. io16) then irc13an = nrat - 1 iro16na = nrat else if (j .eq. in14 .and. k .eq. if17) then irn14an = nrat - 1 irf17na = nrat else if (j .eq. in15 .and. k .eq. if18) then irn15an = nrat - 1 irf18na = nrat else if (j .eq. io17 .and. k .eq. ine20) then iro17an = nrat - 1 irne20na = nrat else if (j .eq. io18 .and. k .eq. ine21) then iro18an = nrat - 1 irne21na = nrat else if (j .eq. if19 .and. k .eq. ina22) then irf19an = nrat - 1 irna22na = nrat else if (j .eq. ine21 .and. k .eq. img24) then irne21an = nrat - 1 irmg24na = nrat else if (j .eq. ine22 .and. k .eq. img25) then irne22an = nrat - 1 irmg25na = nrat else if (j .eq. img25 .and. k .eq. isi28) then irmg25an = nrat - 1 irsi28na = nrat else if (j .eq. img26 .and. k .eq. isi29) then irmg26an = nrat - 1 irsi29na = nrat else if (j .eq. ial27 .and. k .eq. ip30) then iral27an = nrat - 1 irp30na = nrat end if end if c..and the (a,g) and (g,a) names and a few reaction rate pointers k = nrr(6,j) if (k .gt. 0) then string = ionam(j)//'(a,g)'//ionam(k) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string string = ionam(k)//'(g,a)'//ionam(j) call sqeeze(string) nrat = nrat + 1 ratnam(nrat) = string if (j .eq. ih2 .and. k .eq. ili6) then irdag = nrat irli6ga = nrat else if (j .eq. ih3 .and. k .eq. ili7) then irtag = nrat - 1 irli7ga = nrat else if (j .eq. ihe3 .and. k .eq. ibe7) then irhe3ag = nrat - 1 irbe7ga = nrat else if (j .eq. ili6 .and. k .eq. ib10) then irli6ag = nrat - 1 irb10ga = nrat else if (j .eq. ili7 .and. k .eq. ib11) then irli7ag = nrat - 1 irb11ga = nrat else if (j .eq. ibe7 .and. k .eq. ic11) then irbe7ag = nrat - 1 irc11ga = nrat else if (j .eq. ic12 .and. k .eq. io16) then ircag = nrat - 1 iroga = nrat else if (j .eq. ic14 .and. k .eq. io18) then irc14ag = nrat - 1 iro18ga = nrat else if (j .eq. in14 .and. k .eq. if18) then irn14ag = nrat - 1 irf18ga = nrat else if (j .eq. in15 .and. k .eq. if19) then irn15ag = nrat - 1 irf19ga = nrat else if (j .eq. io14 .and. k .eq. ine18) then iro14ag = nrat - 1 irne18ga = nrat else if (j .eq. io15 .and. k .eq. ine19) then iro15ag = nrat - 1 irne19ga = nrat else if (j .eq. io16 .and. k .eq. ine20) then iroag = nrat - 1 irnega = nrat else if (j .eq. io17 .and. k .eq. ine21) then iro17ag = nrat - 1 irne21ga = nrat else if (j .eq. io18 .and. k .eq. ine22) then iro18ag = nrat - 1 irne22ga = nrat else if (j .eq. ine20 .and. k .eq. img24) then irneag = nrat - 1 irmgga = nrat else if (j .eq. ine21 .and. k .eq. img25) then irne21ag = nrat - 1 irmg25ga = nrat else if (j .eq. ine22 .and. k .eq. img26) then irne22ag = nrat - 1 irmg26ga = nrat else if (j .eq. img24 .and. k .eq. isi28) then irmgag = nrat - 1 irsiga = nrat else if (j .eq. img25 .and. k .eq. isi29) then irmg25ag = nrat - 1 irsi29ga = nrat else if (j .eq. img26 .and. k .eq. isi30) then irmg26ag = nrat - 1 irsi30ga = nrat else if (j .eq. isi28 .and. k .eq. is32) then irsiag = nrat - 1 irsga = nrat end if end if enddo c..make sure we have the space before adding in the hardcoded rates if (nrat + 67 .gt. abigrat) stop 'nrat > abigrat in init_torch' c..for p(e-,nu)n and n(e+,nub)p reactions nrat = nrat + 1 irpen = nrat ratnam(irpen) = 'rpen' nrat = nrat + 1 irnep = nrat ratnam(irnep) = 'rnep' c..c12 reactions, first half of triple alpha if (ic12 .ne. 0) then nrat = nrat + 1 ir3a = nrat ratnam(ir3a) = 'r3a' nrat = nrat + 1 irg3a = nrat ratnam(irg3a) = 'ral' c..c12+c12 reactions; must have ne20, na23, mg23 in the network if (ine20 .ne. 0 .and. ina23 .ne. 0 .and. img23 .ne. 0) then nrat = nrat + 1 ir1212n = nrat ratnam(ir1212n) = 'r1212n' nrat = nrat + 1 irmg23nc = nrat ratnam(irmg23nc) = 'rmg23nc' nrat = nrat + 1 ir1212p = nrat ratnam(ir1212p) = 'r1212p' nrat = nrat + 1 irna23pc = nrat ratnam(irna23pc) = 'rna23pc' nrat = nrat + 1 ir1212a = nrat ratnam(ir1212a) = 'r1212a' nrat = nrat + 1 irne20ac = nrat ratnam(irne20ac) = 'rne20ac' end if end if c..o16+o16 reactions; must have si28, p 30, p31 and s31 in the network if (io16 .ne. 0 .and. isi28 .ne. 0 .and. ip30 .ne. 0 .and. 1 ip31 .ne. 0 .and. is31 .ne. 0) then nrat = nrat + 1 ir1616n = nrat ratnam(nrat) = 'r1616n' nrat = nrat + 1 irs31no = nrat ratnam(irs31no) = 'rs31no' nrat = nrat + 1 ir1616p = nrat ratnam(ir1616p) = 'r1616p' nrat = nrat + 1 irp31po = nrat ratnam(irp31po) = 'rp31po' nrat = nrat + 1 ir1616a = nrat ratnam(ir1616a) = 'r1616a' nrat = nrat + 1 irsi28ao = nrat ratnam(irsi28ao) = 'rsi28ao' nrat = nrat + 1 ir1616d = nrat ratnam(ir1616d) = 'r1616d' nrat = nrat + 1 irp30do = nrat ratnam(irp30do) = 'rp30do' end if c..c12+o16 reactions; must have mg24, al27, si27 in the network if (ic12 .ne. 0 .and. io16 .ne. 0 .and. 1 img24 .ne. 0 .and. ial27 .ne. 0 .and. isi27 .ne. 0) then nrat = nrat + 1 ir1216n = nrat ratnam(ir1216n) = 'r1216n' nrat = nrat + 1 irsi27no = nrat ratnam(irsi27no) = 'rsi27no' nrat = nrat + 1 ir1216p = nrat ratnam(ir1216p) = 'r1216p' nrat = nrat + 1 iral27po = nrat ratnam(iral27po) = 'ral27po' nrat = nrat + 1 ir1216a = nrat ratnam(ir1216a) = 'r1216a' nrat = nrat + 1 irmg24ao = nrat ratnam(irmg24ao) = 'rmg24ao' end if c..if we have deuterium if (ih2 .ne. 0) then c..pp nrat = nrat + 1 irpp = nrat ratnam(irpp) = 'rpp' nrat = nrat + 1 irpep = nrat ratnam(irpep) = 'rpep' c..p(n,g)d nrat = nrat + 1 irpng = nrat ratnam(irpng) = 'rpng' nrat = nrat + 1 irdgn = nrat ratnam(irdgn) = 'rdgn' c..d(p,n)2p nrat = nrat + 1 irdpn = nrat ratnam(irdpn) = 'rdpn' nrat = nrat + 1 ir2pnp = nrat ratnam(ir2pnp) = 'r2pnp' c..d(d,g)he4 nrat = nrat + 1 irddg = nrat ratnam(irddg) = 'rddg' nrat = nrat + 1 irhe4gd = nrat ratnam(irhe4gd) = 'rhe4gd' end if c..if we have tritium if (ih3 .ne. 0) then c..d(d,p)t nrat = nrat + 1 irddp = nrat ratnam(irddp) = 'rddp' nrat = nrat + 1 irtpd = nrat ratnam(irtpd) = 'rtpd' c..t(p,g)he4 nrat = nrat + 1 irh3pg = nrat ratnam(irh3pg) = 'rh3pghe4' nrat = nrat + 1 irhe4gp = nrat ratnam(irhe4gp) = 'rhe4gph3' c..t(d,n)he4 reaction nrat = nrat + 1 irtdn = nrat ratnam(irtdn) = 'rtdn' nrat = nrat + 1 irhe4nd = nrat ratnam(irhe4nd) = 'rhe4nd' c..t(t,2n)he4 nrat = nrat + 1 irtt2n = nrat ratnam(irtt2n) = 'rtt2n' nrat = nrat + 1 irhe42nt = nrat ratnam(irhe42nt) = 'rhe42nt' end if c..if we have he3 if (ihe3 .ne. 0) then c..he3(he3,2p)he4 nrat = nrat + 1 ir33 = nrat ratnam(ir33) = 'r33' nrat = nrat + 1 ir33inv = nrat ratnam(ir33inv) = 'r33inv' c..he3(p,e+nu)he4 nrat = nrat + 1 irhep = nrat ratnam(irhep) = 'rhep' c..he3(n,g)he4 nrat = nrat + 1 irhe3ng = nrat ratnam(irhe3ng) = 'rhe3ng' nrat = nrat + 1 irhe4gn = nrat ratnam(irhe4gn) = 'rhe4gnhe3' c..he3(d,p)he4 nrat = nrat + 1 irhe3dp = nrat ratnam(irhe3dp) = 'rhe3dp' nrat = nrat + 1 irhe4pd = nrat ratnam(irhe4pd) = 'rhe4pd' c..d(d,n)he3 nrat = nrat + 1 irddn = nrat ratnam(irddn) = 'rddn' nrat = nrat + 1 irhe3nd = nrat ratnam(irhe3nd) = 'rhe3nd' c..he3(t,d)he4 nrat = nrat + 1 irhe3td = nrat ratnam(irhe3td) = 'rhe3td' nrat = nrat + 1 irhe4dt = nrat ratnam(irhe4dt) = 'rhe4dt' c..he3(t,np)he4 nrat = nrat + 1 irhe3tnp = nrat ratnam(irhe3tnp) = 'rhe3tnp' end if c..li7 reactions if (ili7 .ne. 0) then c..li7(t,2n)2a nrat = nrat + 1 irli7t2n = nrat ratnam(irli7t2n) = 'rli7t2n' c..li7(p,g)be8 and li7(p,a)he4 nrat = nrat + 1 irli7pag = nrat ratnam(irli7pag) = 'rli7pag' nrat = nrat + 1 ir2he4ga = nrat ratnam(ir2he4ga) = 'r2he4ga' c..li7(d,n)2a nrat = nrat + 1 irli7dn = nrat ratnam(irli7dn) = 'rli7dn' c..li7(he3,np)2a nrat = nrat + 1 irli7he3np = nrat ratnam(irli7he3np) = 'rli7he3np' end if if (ibe7 .ne. 0) then c..be7(d,p)2a nrat = nrat + 1 irbe7dp = nrat ratnam(irbe7dp) = 'rbe7dp' c..be7(t,np)2a nrat = nrat + 1 irbe7tnp = nrat ratnam(irbe7tnp) = 'rbe7tnp' c..be7(he3,2p)2a nrat = nrat + 1 irbe7he32p = nrat ratnam(irbe7he32p) = 'rbe7he32p' end if if (ibe9 .ne. 0) then c..a(an,g)be9 nrat = nrat + 1 iraan = nrat ratnam(iraan) = 'raan' nrat = nrat + 1 irgaan = nrat ratnam(irgaan) = 'rgaan' c..be9(p,d)be8 =>2a nrat = nrat + 1 irbe9pd = nrat ratnam(irbe9pd) = 'rbe9pd' end if if (ib8 .ne. 0) then c..b8(p=>n)be8 =>2a reactions nrat = nrat + 1 irb8ep = nrat ratnam(irb8ep) = 'rb8ep' end if if (ib11 .ne. 0) then c..b11(p,a)be8 => 2a reactions nrat = nrat + 1 irb11pa = nrat ratnam(irb11pa) = 'rb11pa' nrat = nrat + 1 ir3ap = nrat ratnam(ir3ap) = 'r3ap' end if if (ic11 .ne. 0) then c..c11(n,a)be8 => 2a nrat = nrat + 1 irc11na = nrat ratnam(irc11na) = 'rc11na' end if c..say how many isotopes and rates are in this network write(6,*) write(6,*) 'ionmax=',ionmax,' nrates=',nrat write(6,*) 'minimum size of cx array ',kmax write(6,*) return end subroutine naray include 'implno.dek' include 'network.dek' c..this routine builds the nrr(7,i) and nrrneut(7,i) arrays, which specify c..the location of isotopes coupled to i by various reactions. c..the first index on nrr refers to reactions of the form c.. 1=ng 2=pn 3=pg 4=ap 5=an 6=ag 7=b- c.. c..while the first index on nrrneut refers to reactions of the form c.. 1=nu,e-,n 2=nu,e- 3=nu,e-,p 4=nu e+,n 5=nu,e+ 6=nu,e+,p c..declare integer i,k,n,kz,kn,jz(7),jn(7) c..initialize for nrr jz(1) = 0 jz(2) = 1 jz(3) = 1 jz(4) = 1 jz(5) = 2 jz(6) = 2 jz(7) = -1 jn(1) = 1 jn(2) = -1 jn(3) = 0 jn(4) = 2 jn(5) = 1 jn(6) = 2 jn(7) = 1 c..build nrr do i=ionbeg,ionend do n=1,7 nrr(n,i) = 0 kz = int(zion(i)) + jz(n) kn = int(nion(i)) + jn(n) do k=ionbeg,ionend if (kz.eq.int(zion(k)) .and. kn.eq.int(nion(k))) nrr(n,i)=k enddo enddo enddo c..initialize for nrrneut jz(1) = 1 jz(2) = 1 jz(3) = 0 jz(4) = -1 jz(5) = -1 jz(6) = -2 jz(7) = -2 jn(1) = -2 jn(2) = -1 jn(3) = -1 jn(4) = 0 jn(5) = 1 jn(6) = 1 jn(7) = -2 c..build nrrneut do i=ionbeg,ionend do n=1,7 nrrneut(n,i) = 0 kz = int(zion(i)) + jz(n) kn = int(nion(i)) + jn(n) do k=ionbeg,ionend if (kz.eq.int(zion(k)) .and. kn.eq.int(nion(k))) nrrneut(n,i)=k enddo enddo enddo return end subroutine weak_rates(ys2) include 'implno.dek' include 'const.dek' include 'vector_eos.dek' include 'burn_common.dek' include 'network.dek' c..rates for n=>p and p=>n c..declare the pass double precision ys2(*) c..local variables integer i,j double precision zbarxx,ytot1,abar,zbar,rn1,rp1,sn1,sp1 c..initialize ratraw(irpen) = 0.0d0 dratrawdt(irpen) = 0.0d0 dratrawdd(irpen) = 0.0d0 ratraw(irnep) = 0.0d0 dratrawdt(irnep) = 0.0d0 dratrawdd(irnep) = 0.0d0 spen = 0.0d0 snep = 0.0d0 snuw = 0.0d0 c..this is the free decay of neutrons and its inverse c call rate_weaknp(btemp,bden, c 1 ratraw(irnep),dratrawdt(irnep),dratrawdd(irnep), c 2 ratraw(irpen),dratrawdt(irpen),dratrawdd(irpen)) c ratraw(irpen) = 0.0d0 c dratrawdt(irpen) = 0.0d0 c dratrawdd(irpen) = 0.0d0 c ratraw(irnep) = 0.0d0 c dratrawdt(irnep) = 0.0d0 c dratrawdd(irnep) = 0.0d0 c..add the electron capture rates zbarxx = 0.0d0 ytot1 = 0.0d0 do i=1,ionmax ytot1 = ytot1 + ys2(i) zbarxx = zbarxx + zion(i) * ys2(i) enddo abar = 1.0d0/ytot1 zbar = zbarxx * abar 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 call eosfxt c..get the electron capture rates on protons and neutrons call ecapnuc(etaele_row(1),btemp,rp1,rn1,sp1,sn1) c rp1 = 0.0d0 c rn1 = 0.0d0 c sp1 = 0.0d0 c sn1 = 0.0d0 c..sum the free decay and electron capture rates ratraw(irnep) = ratraw(irnep) + rn1 ratraw(irpen) = ratraw(irpen) + rp1 c..fill the common block electron capture neutrino loss rates in erg/g/sec spen = sp1 * ys2(iprot) * avo snep = sn1 * ys2(ineut) * avo c..get the weak reaction rates if we are larger the ffn lower table limits if (ffn_on.eq.1 .and. btemp.ge.1.0e9 .and. bden.ge.1.0e6) then call weak2(btemp,bden,abar,zbar,etaele_row(1),ys2) c..overwrite the sigraw rates with the ffn weak reaction rates do i=ionbeg,ionend j = icode2(i) if (j .ne. 0) then sigraw(6,i) = recful(j) + rpdful(j) sigrawdt(6,i) = 0.0d0 sigrawdd(6,i) = 0.0d0 sigraw(5,i) = redful(j) sigrawdt(5,i) = 0.0d0 sigrawdd(5,i) = 0.0d0 end if enddo end if c..no change from any weak reactions if (weak_on .eq. 0) then ratraw(irnep) = 0.0d0 dratrawdt(irnep) = 0.0d0 dratrawdd(irnep) = 0.0d0 ratraw(irpen) = 0.0d0 dratrawdt(irpen) = 0.0d0 dratrawdd(irpen) = 0.0d0 spen = 0.0d0 snep = 0.0d0 do i=ionbeg,ionend sigraw(5,i) = 0.0d0 sigrawdt(5,i) = 0.0d0 sigrawdd(5,i) = 0.0d0 sigraw(6,i) = 0.0d0 sigrawdt(6,i) = 0.0d0 sigrawdd(6,i) = 0.0d0 enddo end if return end subroutine weak2(tt,dd,abar,zbar,eta,ys2) include 'implno.dek' include 'network.dek' c..this subroutine calculates the net nuclear weak interaction rate c..(wrate, moles/g/sec) and the absolute value of the neutrino energy c..loss rate (sweaktot, erg/g/sec) associated with weak interactions c..involving nuclei. detailed weak reaction rate data by isotope c..is also calculated. c.. c..the rates for electron capture, positron decay, and their c..associated neutrino energy losses are calculated by interpolating c..the data of fuller, fowler, and newman (ap.j.suppl. 1982), as c..revised, fit, and tabulated in may, 1982. c.. c..for each isotope the base 10 logarithms of the following c..1) the positron decay rate (reactions per second per nucleus), c..2) the effective ft value for electron capture (dimensionless) c..3) the beta decay rate (reactions per second per nucleus) c..4) the mean energy of neutrinos emitted by positron decay c.. and electron capture combined (mev per second per nucleus) c..5) the mean energy of anti-neutrinos emitted by beta decay c.. c..each table consists of a grid of six density*ye points c..arrayed horizontally and seven temperature points arrayed vertically. c..electron capture q-value in units of electron masses is stored in qn. c..data for individual isotopes is stored in datful in reverse order of c..their q-values. c..input through the pass: c..dd = density c..tt = temperature c..abar = mean number of nuclei in the isotopic mixture c..zbar = mean charge of the isotopic mixture c..eta = chemical potential without electron rest mass added in c..ys2 = molar fractions of the isotopes c..input through common block: c..datful = table of coefficients, read in from bdat c..qn = q-values of the weak reaction rates, read in from bdat c..icode = isotope location pointer structure, read in from bdat c..output through pass c..sp1 = converted to erg/gr/sec c..sn1 = converted to erg/gr/sec c..sweaktot = neutrino loss from weak reactions on heavy nuclei c..output through common block: c..recful(j) = electron capture rate on element j (captures/nucleon/s) c..rpdful(j) = positron decay rate for element j (decays/nucl/s) c..redful(j) = electron decay rate for element j (decays/nuc/s) c..eec(j) = elec capture nu loss rate for element j (mec**2/nucl/s) c..eed(j) = elec decay nu loss rate for element j (mec**2/nucl/s) c..rectot = total electron capture rate. (moles/g/sec). c..eectot = total elec capt and positron decay neutrino loss rate (erg/g/s) c..rpdtot = total positron decay rate. (mole/g/sec) c..redtot = total electron decay rate. (mole/g/sec) c..eedtot = total electron decay neutrino loss rate (erg/g/s) c..declare the pass double precision tt,dd,abar,zbar,eta,ys2(*) c..local variables double precision datfuleq(5*nfuldim*6*7) equivalence (datful,datfuleq) integer j,k,ii,jj,jpf,kpf,lf,lrf,nfult,nfuln,nfuldeg, 1 nfulnodeg,nfulthres,iyed,iyec,idweak double precision t,d,tf,t9f,tme,tme2,tme3,tme4,tme5,tme6, 1 tmei,xlog2,r,rf,rffm,rff0,rff1,rff2,dfacfm, 2 dfacf1,dfacf2,tffm,tff1,tff2,tfacfm,tfacf0, 3 tfacf1,dfacf0,tff0,tfacf2,xx,yy,zz,sweaktot double precision pie,const1o3,constpi2o2,cons2pi2o3 parameter (pie=3.1415926536, const1o3=1./3.) parameter (constpi2o2=pie*pie/2.,cons2pi2o3=2.*pie*pie/3.) c..for the fermi integrals double precision etaf(nfuldim),ff0(nfuldim),f1(nfuldim), 1 f2(nfuldim),f3(nfuldim),f4(nfuldim) double precision zfermi1,zfermi2,zfermi3,fermi4 c..for the phase space factors double precision qc0(nfuldim),qc1(nfuldim),qc2(nfuldim), 1 qc3(nfuldim) c..for the cubic interpolant coefficients double precision rvf(6),tvf(7), 1 rffdm(4),rffd0(4),rffd1(4),rffd2(4), 2 tffdm(5),tffd0(5),tffd1(5),tffd2(5) c..for the interpolated values integer nif,nif2,nif3,ndif parameter (nif = 5*nfuldim, 1 nif2 = 2*nif, 2 nif3 = 3*nif, 3 ndif = 6*nif) double precision ratf(nif),ref(4*nif),rtf(nif) c..the density and temperature grid data rvf/6.0d0, 7.0d0, 8.0d0, 9.0d0, 10.0d0, 11.0d0/ data tvf/1.0d0, 1.5d0, 2.0d0, 3.0d0, 5.0d0, 10.0d0, 30.0d0/ c..initialization flag data idweak/0/ c..popular format statements 111 format(1x,2(a,1pe14.6)) c..the constant cubic interpolation parameters if (idweak .eq. 0) then idweak = 1 do k=2,4 rffdm(k)=1.0d0/((rvf(k-1)-rvf(k))*(rvf(k-1)-rvf(k+1))* 1 (rvf(k-1)-rvf(k+2))) rffd0(k)=1.0d0/((rvf(k)-rvf(k-1))*(rvf(k)-rvf(k+1))* 1 (rvf(k)-rvf(k+2))) rffd1(k)=1.0d0/((rvf(k+1)-rvf(k-1))*(rvf(k+1)-rvf(k))* 1 (rvf(k+1)-rvf(k+2))) rffd2(k)=1.0d0/((rvf(k+2)-rvf(k-1))*(rvf(k+2)-rvf(k))* 1 (rvf(k+2)-rvf(k+1))) enddo do j=2,5 tffdm(j)=1.0d0/((tvf(j-1)-tvf(j))*(tvf(j-1)-tvf(j+1))* 1 (tvf(j-1)-tvf(j+2))) tffd0(j)=1.0d0/((tvf(j)-tvf(j-1))*(tvf(j)-tvf(j+1))* 1 (tvf(j)-tvf(j+2))) tffd1(j)=1.0d0/((tvf(j+1)-tvf(j-1))*(tvf(j+1)-tvf(j))* 1 (tvf(j+1)-tvf(j+2))) tffd2(j)=1.0d0/((tvf(j+2)-tvf(j-1))*(tvf(j+2)-tvf(j))* 1 (tvf(j+2)-tvf(j+1))) enddo c..coefficients of phase space fitting factors do j=1,nfulnot qc0(j)=(qn(j)+1.0d0)**2 qc1(j)=2.0d0*(qn(j)+1.0d0)*(qn(j)+2.0d0) qc2(j)=(qn(j)+1.0d0)**2+4.0d0*(qn(j)+1.0d0)+1.0d0 qc3(j)=2.0d0*(qn(j)+2.0d0) end do do j=nfulnot+1,nful qc0(j)=0.d0 qc1(j)=0.d0 qc2(j)=qn(j)*qn(j) qc3(j)=-2.0d0*qn(j) end do endif c..initialize do ii=1,nfuldim recful(ii) = 0.0d0 rpdful(ii) = 0.0d0 redful(ii) = 0.0d0 eec(ii) = 0.0d0 eed(ii) = 0.0d0 etaf(ii) = 0.0d0 ff0(ii) = 0.0d0 f1(ii) = 0.0d0 f2(ii) = 0.0d0 f3(ii) = 0.0d0 f4(ii) = 0.0d0 enddo do ii=1,nif c ratf(ii) = 0.0d0 rtf(ii) = 0.0d0 enddo do ii=1,4*nif ref(ii) = 0.0d0 enddo rectot = 0.0d0 rpdtot = 0.0d0 redtot = 0.0d0 eectot = 0.0d0 epdtot = 0.0d0 eedtot = 0.0d0 wrate = 0.0d0 t = tt d = dd tf = max(1.0d9,t) tf = min(3.0d10,tf) t9f = tf * 1.0d-9 tme = tf/5.93014d9 tme2 = tme * tme tme3 = tme2 * tme tme4 = tme3 * tme tme5 = tme4 * tme tme6 = tme5 * tme tmei = 1.0d0/tme xlog2 = 1.0d0/log10(2.0d0) r = log10(d * zbar/abar) rf = min(11.0d0,r) rf = max(6.0d0,rf) c..set the pointers jpf and kpf if (t9f.lt.2.) jpf=2 if ((t9f.ge.2.).and.(t9f.lt.3.)) jpf=3 if ((t9f.ge.3.).and.(t9f.lt.5.)) jpf=4 if (t9f.ge.5.) jpf=5 kpf = min(max(2,int(rf)-5),4) c..interpolation constants rffm = rf - rvf(kpf-1) rff0 = rf - rvf(kpf) rff1 = rf - rvf(kpf+1) rff2 = rf - rvf(kpf+2) dfacfm = rff0 * rff1 * rff2 * rffdm(kpf) dfacf0 = rffm * rff1 * rff2 * rffd0(kpf) dfacf1 = rffm * rff0 * rff2 * rffd1(kpf) dfacf2 = rffm * rff0 * rff1 * rffd2(kpf) tffm = t9f - tvf(jpf-1) tff0 = t9f - tvf(jpf) tff1 = t9f - tvf(jpf+1) tff2 = t9f - tvf(jpf+2) tfacfm = tff0 * tff1 * tff2 * tffdm(jpf) tfacf0 = tffm * tff1 * tff2 * tffd0(jpf) tfacf1 = tffm * tff0 * tff2 * tffd1(jpf) tfacf2 = tffm * tff0 * tff1 * tffd2(jpf) c..cubic interpolation to find the base 10 logarithms of the: c..1) positron decay rates (per nucleus per second), c..2) effective ft values for electron capture (dimensionless), c..3) beta decay rate (per nucleus per second) c..4) combined average energy of the neutrinos emitted (mev per reaction) c..5) mean antineutrino energy from beta decay (mev per sec per nuc) c..store them sequentially in the ref array. c..ref(i,j) = dfacfm*ratf(i,kpf-1,j) c.. + dfacf0*ratf(i,kpf,j) c.. + dfacf1*ratf(i,kpf+1,j) c + dfacf2*ratf(i,kpf+2,j) for j=jpf-1 to j c..rtf(i) = tfacfm*ref(i,jpf-1) c.. + tfacf0*ref(i,jpf) c.. + tfacf1*ref(i,jpf+1) c.. + tfacf2+ref(i,jpf+2) lrf = 1 lf = ndif*(jpf-2) + nif*(kpf-2) + 1 do j = jpf-1,jpf+2 do ii = 1,nif jj = ii-1 ref(lrf + jj) = datfuleq(lf + jj) * dfacfm 1 + datfuleq(lf+nif + jj) * dfacf0 2 + datfuleq(lf+nif2 + jj) * dfacf1 3 + datfuleq(lf+nif3 + jj) * dfacf2 enddo lrf = lrf + nif lf = lf + ndif enddo do ii=1,nif jj = ii-1 rtf(ii) = ref(ii) * tfacfm 1 + ref(nif+1 + jj) * tfacf0 2 + ref(nif2+1 + jj) * tfacf1 3 + ref(nif3+1 + jj) * tfacf2 enddo c..threshold for degenerate phase space factor; etaf(j)=eta+(qn(j)+1.)/tme etaf(nfulnot) = eta nfult = nfulnot + 1 do ii=1,nful-nfulnot jj = ii-1 etaf(nfult+jj) = qn(nfult+jj) * tmei + eta + tmei enddo c..set the first fermi integral nfuln = nfulnot if (etaf(nfulnot) .lt. 0.0) go to 100 do j=nfulnot,nful if (etaf(j) .lt. 0.0) go to 80 f1(j) = exp(-etaf(j)) c f1(j) = zfermi1(-etaf(j)) c write(6,*) 'unknown non',j,etaf(j) c write(6,111) 'f1=',f1(j),' zfermi1=',zfermi1(-etaf(j)) c write(6,*) c read(5,*) enddo j = nful + 1 c..fermi integrals for degenerate matter, etaf(j).ge.0. c..f1(j)=expf(-etaf(j)) c..f2(j)=etaf(j)**3/3.+4.*etaf(j)+2.*f1(j) c..f3(j)=etaf(j)**4/4.+0.5*pie**2*etaf(j)**2+12.-6.*f1(j) c..f4(j)=etaf(j)**5/5.+2.*pie**2*etaf(j)**3/3.+48.*etaf(j)+24.*f1(j) 80 nfuln = j nfuldeg = j-nfulnot if(nfuldeg.le.0) go to 100 do ii=1,nfuldeg jj = ii-1 xx = etaf(nfulnot+jj) yy = xx * xx zz = f1(nfulnot+jj) ff0(nfulnot+jj) = yy f2(nfulnot+jj) = xx*(yy*const1o3 + 4.0d0)+ zz*2.0d0 f3(nfulnot+jj) = yy*(yy*0.25d0 + constpi2o2) +12.0d0 - zz*6.0d0 f4(nfulnot+jj) = xx*(yy*(yy*0.2d0+cons2pi2o3)+48.0d0)+zz*24.0d0 c ff0(nfulnot+jj) = xx * xx c f2(nfulnot+jj) = zfermi2(xx) c f3(nfulnot+jj) = zfermi3(xx) c f4(nfulnot+jj) = fermi4(xx) c write(6,*) 'degen',ii,xx c write(6,111) 'f2=',f2(nfulnot+jj),' zfermi2=',zfermi2(xx) c write(6,111) 'f3=',f3(nfulnot+jj),' zfermi3=',zfermi3(xx) c write(6,111) 'f4=',f4(nfulnot+jj),' zfermi4=',fermi4(xx) c write(6,*) c read(5,*) enddo if(nfuln .gt. nful) go to 90 c..fermi integrals for non-degenerate case matter, etaf(j).lt.0. c..f1(j)=expf(etaf(j)) f2(j)=2.*f1(j), f3(j)=6.*f1(j), f4(j)=24.*f1(j) 100 nfulnodeg = nful - nfuln + 1 do j=nfuln,nful f1(j) = exp(etaf(j)) c f1(j) = zfermi1(etaf(j)) c write(6,*) 'unknown non',j,etaf(j) c write(6,111) 'f1=',f1(j),' zfermi1=',zfermi1(etaf(j)) c write(6,*) c read(5,*) enddo do ii=1,nfulnodeg jj = ii-1 xx = f1(nfuln + jj) f2(nfuln + jj) = xx * 2.0d0 f3(nfuln + jj) = xx * 6.0d0 f4(nfuln + jj) = xx * 24.0d0 c xx = etaf(nfuln + jj) c f2(nfuln + jj) = zfermi2(xx) c f3(nfuln + jj) = zfermi3(xx) c f4(nfuln + jj) = fermi4(xx) c write(6,*) 'nondegen',ii,xx c write(6,111) 'f2=',f2(nfuln+jj),' zfermi2=',zfermi2(xx) c write(6,111) 'f3=',f3(nfuln+jj),' zfermi3=',zfermi3(xx) c write(6,111) 'f4=',f4(nfuln+jj),' zfermi4=',fermi4(xx) c write(6,*) c read(5,*) enddo c..fermi integral of order zero = log(1 + exp(eta)) is exact 90 if (eta .lt. -15.0) then ff0(nfulnot)= exp(eta) else if (eta .ge. -15.0 .and. eta .le. 100.0) then ff0(nfulnot)=log(1.0d0 + exp(eta)) else if (eta.gt.100.) then ff0(nfulnot) = eta endif c..polish off the fermi integral of order 1 if (eta.ge.0.) then f1(nfulnot) = 0.5d0*eta*eta +2.0d0 - f1(nfulnot) c f1(nfulnot) = zfermi1(eta) c write(6,*) 'eta > 0',nfulnot,eta c write(6,111) 'f1=',f1(nfulnot),' zfermi1=',zfermi1(eta) c write(6,*) c read(5,*) end if c..values of f/(alpha*gbar) for electron captures with thresholds c..f/(alpha*gbar) = ff0(j) = tme5*f4(etaf(j))+qc3(j)*tme4*f3(etaf(j)) c.. +qc2(j)*tme3*f2(etaf(j)) nfulthres = nful - nfulnot do ii=1,nfulthres jj = ii-1 f4(nfult + jj) = f4(nfult+jj) * tme5 f3(nfult + jj) = f3(nfult+jj) * tme4 * qc3(nfult+jj) f2(nfult + jj) = f2(nfult+jj) * tme3 * qc2(nfult+jj) ff0(nfult+jj) = f2(nfult+jj) + f3(nfult+jj) + f4(nfult+jj) enddo c..values of f/(alpha*gbar) for electron captures without thresholds c..note: f/(alpha*gbar) = ff0(j) do ii=1,nfulnot ff0(ii) = qc0(ii) * tme * ff0(nfulnot) 1 + qc1(ii) * tme2 * f1(nfulnot) 2 + qc2(ii) * tme3 * f2(nfulnot) 3 + qc3(ii) * tme4 * f3(nfulnot) 4 + tme5 * f4(nfulnot) enddo c..complete the calculation of the electron capture rates using the c..interpolated ft values and the f/(alpha*gbar) phase space fitting factors. c..finish electron and positron decay rates and neutrino energy loss rates c..this is the main output do ii=1,nful jj = ii-1 recful(ii) = ff0(ii) * 10.0d0**(-0.1591745d0 - rtf(nfuldim+1+jj)) rpdful(ii) = 10.0d0**( rtf(ii) ) redful(ii) = 10.0d0**( rtf(2*nfuldim+1 + jj) ) eec(ii) = (recful(ii) + rpdful(ii)) * 1.9569259d0 1 * 10.0d0**( rtf(3*nfuldim+1 + jj) ) eed(ii) = redful(ii) * 1.9569259d0 1 * 10.0d0**(rtf(4*nfuldim+1 + jj)) enddo c..get the total rates c..note neutrino energy loss from positron decay is included in c..eec and eectot, so epdtot must be set to 0. to avoid double counting c..note these totals depend on the present composition! do j=1,nful iyed = icode(j) iyec = nrr(2,iyed) if (iyec .ne. 0) then rectot = rectot + ys2(iyec) * recful(j) rpdtot = rpdtot + ys2(iyec) * rpdful(j) eectot = eectot + ys2(iyec) * eec(j) end if redtot = redtot + ys2(iyed) * redful(j) eedtot = eedtot + ys2(iyed) * eed(j) enddo wrate = rectot + rpdtot - redtot sweaktot = eectot + eedtot 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*d