diff --git a/debug.h b/debug.h deleted file mode 100644 index e307360..0000000 --- a/debug.h +++ /dev/null @@ -1,143 +0,0 @@ -/***************************************************************/ -void d_swap(double *a, double *b) -{ -register double tmp; -tmp = *a; *a = *b; *b = tmp; -} - -void i_swap(int *a, int *b) -{ -register int tmp; -tmp = *a; *a = *b; *b = tmp; -} -/***************************************************************/ - -/***************************************************************/ -void my_sort(int l, int r, double *arr, int *ind) -{ - -int i, j, cikl; -double tmp; - -i = l; j = r; -tmp = arr[(l+r)/2]; - -cikl = 1; - -while (cikl) - { - while (arr[i]> 1; - - d_swap(&arr[mid],&arr[l+1]); - i_swap(&ind[mid],&ind[l+1]); - - if (arr[l+1] > arr[ir]) - { - d_swap(&arr[l+1],&arr[ir]); - i_swap(&ind[l+1],&ind[ir]); - } - - if (arr[l] > arr[ir]) - { - d_swap(&arr[l],&arr[ir]); - i_swap(&ind[l],&ind[ir]); - } - - if (arr[l+1] > arr[l]) - { - d_swap(&arr[l+1],&arr[l]); - i_swap(&ind[l+1],&ind[l]); - } - - i = l+1; - j = ir; - a = arr[l]; - a_ind = ind[l]; - - for (;;) - { - do i++; while (arr[i] < a); - do j--; while (arr[j] > a); - if (j < i) break; - d_swap(&arr[i],&arr[j]); - i_swap(&ind[i],&ind[j]); - } - - arr[l] = arr[j]; - ind[l] = ind[j]; - arr[j] = a; - ind[j] = a_ind; - if (j >= k) ir = j-1; - if (j <= k) l = i; - - } - } -} -/***************************************************************/ - -/***************************************************************/ -/* -double lagrange_radius(double percent) -{ -int Nb; -double tmp; - -Nb = (int)(percent * N); - -my_sort(0, N-1, d, ind); - -tmp = my_select(0, N-1, Nb-1, d, ind); d[Nb-1] = tmp; - -return(tmp); -} -*/ -/***************************************************************/ diff --git a/io.cpp b/io.cpp index ea496c4..2ca64c8 100644 --- a/io.cpp +++ b/io.cpp @@ -24,7 +24,7 @@ bool is_hdf5(std::string file_name) return result; } -void ascii_read(const std::string file_name, int *step_num, int *N, double *t, double *m, double3 *x, double3 *v) +void ascii_read(const std::string file_name, int& step_num, int& N, double& t, double **m, double3 **x, double3 **v) { char rest[512]; int result; @@ -34,21 +34,25 @@ void ascii_read(const std::string file_name, int *step_num, int *N, double *t, d std::string str; std::getline(file, str); - result = sscanf(str.c_str(), "%d%s", step_num, rest); + result = sscanf(str.c_str(), "%d%s", &step_num, rest); if (result!=1) throw std::runtime_error("Error parsing line 1: expected one integer"); std::getline(file, str); - result = sscanf(str.c_str(), "%d%s", N, rest); + result = sscanf(str.c_str(), "%d%s", &N, rest); if (result!=1) throw std::runtime_error("Error parsing line 2: expected one integer"); std::getline(file, str); - result = sscanf(str.c_str(), "%lf%s", t, rest); + result = sscanf(str.c_str(), "%lf%s", &t, rest); if (result!=1) throw std::runtime_error("Error parsing line 3: expected one real number"); + *m = new double[N]; + *x = new double3[N]; + *v = new double3[N]; + int i = -1; while (std::getline(file, str)) { - if (++i > *N) throw std::runtime_error("Error parsing line " + std::to_string(i+4) + ": particle out of range"); - result = sscanf(str.c_str(), "%*s %lf %lf %lf %lf %lf %lf %lf%s", &m[i], &x[i][0], &x[i][1], &x[i][2], &v[i][0], &v[i][1], &v[i][2], rest); + if (++i > N) throw std::runtime_error("Error parsing line " + std::to_string(i+4) + ": particle out of range"); + result = sscanf(str.c_str(), "%*s %lf %lf %lf %lf %lf %lf %lf%s", &(*m)[i], &(*x)[i][0], &(*x)[i][1], &(*x)[i][2], &(*v)[i][0], &(*v)[i][1], &(*v)[i][2], rest); } file.close(); } @@ -145,7 +149,7 @@ void h5_read(const std::string file_name, int *step_num, int *N, double *t, doub void h5_write(const std::string file_name, const int step_num, const int N, const double t, const double *m, const double3 *x, const double3 *v, const double *pot, const double3 *acc, const double3 *jrk, const int extra_mode=0, const bool use_double_precision=true) { #ifdef HAS_HDF5 - hid_t file_id, group_id, attribute_id, dataset_id, dataspace_id; + hid_t file_id, group_id, attribute_id, dataspace_id; hsize_t dims[2] = {(hsize_t)N, 3}; hid_t h5_float_type; diff --git a/phigrape.cpp b/phigrape.cpp index da5b8d9..69f6d93 100644 --- a/phigrape.cpp +++ b/phigrape.cpp @@ -53,18 +53,6 @@ Coded by : Peter Berczik Version number : 19.04 Last redaction : 2019.04.16 12:55 *****************************************************************************/ -#include "double3.h" -#include "black_holes.h" -#include "config.h" -#include "io.h" -#include "external.h" - -Config *config; - -#ifdef ETICS -#include "grapite.h" -#endif - #define TIMING #define ETA_S_CORR 4.0 @@ -73,42 +61,37 @@ Config *config; #define DTMAXPOWER -3.0 #define DTMINPOWER -36.0 -#include -#include -#include -#include -#include -#include -#include - #include +#include +#include #include #include +#include +#include +#include +#include +#include +#include +#include "black_holes.h" +#include "config.h" +#include "double3.h" +#include "external.h" #include "grape6.h" +#include "io.h" -#include +#ifdef ETICS +#include "grapite.h" +#endif -/* Some "good" functions and constants... */ -// TODO replace with inline functions -#define MIN(a,b) (((a)<(b)) ? (a):(b) ) -#define SQR(x) ((x)*(x) ) - - -#define KB 1024 -#define MB (KB*KB) - -#define N_MAX (32*KB) - -// double L[3]; // needed in pn_bh_spin.c -// Needed for things related to BHs -#include "debug.h" +Config *config; +// These are used in the energy control, could be static but will probably be removed in the end anyway double CPU_time_real0, CPU_time_user0, CPU_time_syst0; double CPU_time_real, CPU_time_user, CPU_time_syst; #ifdef TIMING - +// TODO clean up here double CPU_tmp_real0, CPU_tmp_user0, CPU_tmp_syst0; double CPU_tmp_real, CPU_tmp_user, CPU_tmp_syst; @@ -118,14 +101,7 @@ double DT_TOT, DT_GMC_GRAV, DT_GMC_GMC_GRAV, DT_EXT_GMC_GRAV, DT_ACT_CORR, DT_ACT_LOAD, DT_STEVOL, DT_STARDISK, DT_STARDESTR; - double DT_ACT_REDUCE; - -#endif - - -#ifdef ETICS -int grapite_cep_index; #endif void get_CPU_time(double *time_real, double *time_user, double *time_syst) @@ -178,110 +154,66 @@ private: std::vector h2; }; -void calc_ext_grav(std::vector &external_gravity_components, int n_act, double3 *x_act_new, double3 *v_act_new, double *pot_act_ext, double3 *a_act_new, double3* adot_act_new) +void calc_ext_grav(std::vector &external_gravity_components, int n, double3 *x, double3 *v, double *pot, double3 *acc, double3* jrk) +// TODO should just be a class that has this pointer array as a member { #ifdef TIMING get_CPU_time(&CPU_tmp_real0, &CPU_tmp_user0, &CPU_tmp_syst0); #endif - /* Define the external potential for all active particles on all nodes */ - - std::fill(pot_act_ext, pot_act_ext+n_act, 0.); - + std::fill(pot, pot+n, 0.); for (auto component : external_gravity_components) { if (component->is_active) - component->apply(n_act, x_act_new, v_act_new, pot_act_ext, a_act_new, adot_act_new); + component->apply(n, x, v, pot, acc, jrk); } - /* For simple Plummer potential... */ - #ifdef TIMING get_CPU_time(&CPU_tmp_real, &CPU_tmp_user, &CPU_tmp_syst); DT_EXT_GRAV += (CPU_tmp_user - CPU_tmp_user0); #endif - } -void energy_contr(const double time_cur, const double timesteps, const double n_act_sum, const double g6_calls, double& rcm_sum, double& vcm_sum, double& E_tot_0, double& E_tot_corr_0, double& E_tot_corr_sd_0, int &skip_con, int N, double m[], double3 x[], double3 v[], double pot[], double pot_ext[]) +void energy_contr(const double time_cur, const double timesteps, const double n_act_sum, const double g6_calls, int N, double m[], double3 x[], double3 v[], double pot[], double pot_ext[]) { - // TODO maybe use static variables here for the previous step energy? - double E_pot = 0.0; + double E_pot = 0; for (int i=0; iinput_file_name)) { #ifndef HAS_HDF5 fprintf(stderr, "ERROR: input file is in HDF5 format, but the code was compiled without HDF5 support\n"); @@ -522,8 +371,20 @@ int main(int argc, char *argv[]) h5_read(config->input_file_name, &diskstep, &N, &time_cur, m, x, v); } else - ascii_read(config->input_file_name, &diskstep, &N, &time_cur, m, x, v); + ascii_read(config->input_file_name, diskstep, N, time_cur, &m, &x, &v); + + int *ind = new int[N]; std::iota(ind, ind+N, 0); + double3 *a = new double3[N], *adot = new double3[N]; + double *pot = new double[N], *pot_ext = new double[N], *t = new double[N], *dt = new double[N]; + + /* data for active particles */ + // x_act_new and v_act_new arrays hold the predicted position and velocity of i-particles, which is later corrected before moving into the j-particle memory. The [pot,a,adot]_act_tmp arrays hold the calculation results from each node. The [pot,a,adot]_act_new arrays hold the reduced calculation results from all nodes. + int n_act, *ind_act = new int[N]; + double *pot_act_new = new double[N], *pot_act_tmp = new double[N], *pot_act_ext = new double[N]; + double3 *x_act_new = new double3[N], *v_act_new = new double3[N], + *a_act_tmp = new double3[N], *adot_act_tmp = new double3[N], + *a_act_new = new double3[N], *adot_act_new = new double3[N]; double eps = config->eps; double eta = config->eta; @@ -558,19 +419,12 @@ int main(int argc, char *argv[]) out = fopen("bh_neighbors.dat", "w"); fclose(out); } - // if (config->binary_smbh_influence_sphere_output) { - // out = fopen("bbh_inf.dat", "w"); - // fclose(out); - // } } get_CPU_time(&CPU_time_real0, &CPU_time_user0, &CPU_time_syst0); } /* if (myRank == rootRank) */ - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - double normalization_mass=1, normalization_length=1, normalization_velocity=1; if (config->ext_units_physical) { normalization_mass = 1/config->unit_mass; @@ -624,10 +478,6 @@ int main(int argc, char *argv[]) std::fill(t, t+N, time_cur); std::fill(dt, dt+N, dt_min); - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - /* some local settings for G6a boards */ int clusterid, numGPU; if (config->devices_per_node==0) { @@ -645,8 +495,8 @@ int main(int argc, char *argv[]) /* init the local GRAPEs */ g6_open(clusterid); int npipe = g6_npipes(); - g6_set_tunit(new_tunit); - g6_set_xunit(new_xunit); + g6_set_tunit(51); + g6_set_xunit(51); int n_loc = N/n_proc; Calc_self_grav calc_self_grav(N, n_loc, clusterid, npipe, eps); @@ -685,7 +535,7 @@ int main(int argc, char *argv[]) MPI_Bcast(&etics_length_scale, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); grapite_set_length_scale(etics_length_scale); - grapite_cep_index = grapite_get_cep_index(); + int grapite_cep_index = grapite_get_cep_index(); if (grapite_cep_index >= 0) { grapite_calc_center(N, m, (double(*)[3])x, (double(*)[3])v, xcm, vcm, xdc, vdc); x[grapite_cep_index] = xdc; @@ -695,20 +545,14 @@ int main(int argc, char *argv[]) #endif /* define the all particles as a active on all the processors for the first time grav calc. */ - calc_self_grav(time_cur, N, ind, x, v, pot_act_tmp, a_act_tmp, adot_act_tmp); - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - /* Reduce the "global" vectors from "local" on all processors) */ + // TODO why won't we do the MPI_Allreduce inside the calc_self_grav function, and get rid of these _tmp arrays? MPI_Allreduce(pot_act_tmp, pot, N, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); MPI_Allreduce(a_act_tmp, a, 3*N, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); MPI_Allreduce(adot_act_tmp, adot, 3*N, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - if (config->live_smbh_count == 2) { black_hole_physics.set_xv(x[0], x[1], v[0], v[1]); if (config->live_smbh_custom_eps >= 0) black_hole_physics.adjust_softening(pot[0], pot[1], a[0], a[1], adot[0], adot[1]); @@ -717,14 +561,8 @@ int main(int argc, char *argv[]) calc_ext_grav(external_gravity_components, N, x, v, pot_ext, a, adot); - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - /* Energy control... */ - if (myRank == rootRank) { - energy_contr(time_cur, timesteps, n_act_sum, calc_self_grav.g6_calls, rcm_sum, vcm_sum, E_tot_0, E_tot_corr_0, E_tot_corr_sd_0, skip_con, N, m, x, v, pot, pot_ext); - } /* if (myRank == rootRank) */ + if (myRank == rootRank) energy_contr(time_cur, timesteps, n_act_sum, calc_self_grav.g6_calls, N, m, x, v, pot, pot_ext); #ifdef ETICS if (config->etics_dump_coeffs && (diskstep==0)) { @@ -741,9 +579,6 @@ int main(int argc, char *argv[]) } #endif - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - /* Define initial timestep for all particles on all nodes */ for (int j=0; jlive_smbh_count; i++) dt[i] = min_dt; } - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - /* load the new values for particles to the local GRAPE's */ - /* load the nj particles to the G6 */ + /* load the new values for particles to the local GRAPEs */ for (int k=0; k= t_bh) { if (myRank == rootRank) { @@ -1098,15 +898,13 @@ int main(int argc, char *argv[]) if (time_cur >= t_contr) { if (myRank == rootRank) { - energy_contr(time_cur, timesteps, n_act_sum, calc_self_grav.g6_calls, rcm_sum, vcm_sum, E_tot_0, E_tot_corr_0, E_tot_corr_sd_0, skip_con, N, m, x, v, pot, pot_ext); + energy_contr(time_cur, timesteps, n_act_sum, calc_self_grav.g6_calls, N, m, x, v, pot, pot_ext); /* write cont data */ - if (config->output_hdf5) h5_write("data.con", diskstep, N, time_cur, m, x, v, pot, a, adot, 0, true); else ascii_write("data.con", diskstep, N, time_cur, m, x, v, 16); /* possible OUT for timing !!! */ - #ifdef TIMING FILE *out = fopen("timing.dat", "a"); @@ -1168,15 +966,9 @@ int main(int argc, char *argv[]) /* close the local GRAPEs */ g6_close(clusterid); - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - double g6_calls_sum; MPI_Reduce(&calc_self_grav.g6_calls, &g6_calls_sum, 1, MPI_DOUBLE, MPI_SUM, rootRank, MPI_COMM_WORLD); - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - if (myRank == rootRank) { /* Write some output for the timestep annalize... */ @@ -1189,8 +981,7 @@ int main(int argc, char *argv[]) } /* if (myRank == rootRank) */ - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); + delete[] m; delete[] x; delete[] v; delete[] ind; delete[] a; delete[] adot; delete[] pot; delete[] pot_ext; delete[] t; delete[] dt; delete[] ind_act; delete[] pot_act_new; delete[] pot_act_tmp; delete[] x_act_new; delete[] v_act_new; delete[] a_act_tmp; delete[] adot_act_tmp; delete[] a_act_new; delete[] adot_act_new; delete[] pot_act_ext; /* Finalize the MPI work */ MPI_Finalize(); diff --git a/sse_sse.f b/sse_sse.f deleted file mode 100644 index d29b7fc..0000000 --- a/sse_sse.f +++ /dev/null @@ -1,7109 +0,0 @@ -cc// deltat.f - -*** - SUBROUTINE deltat(kw,age,tm,tn,tscls,dt,dtr) - implicit none -* - INTEGER kw - REAL*8 age,tm,tn,tscls(20) - REAL*8 dt,dtr - REAL*8 pts1,pts2,pts3 - COMMON /POINTS/ pts1,pts2,pts3 -* -* Base new time scale for changes in radius & mass on stellar type. -* - if(kw.le.1)then - dt = pts1*tm - dtr = tm - age - elseif(kw.eq.2)then - dt = pts1*(tscls(1) - tm) - dtr = tscls(1) - age - elseif(kw.eq.3)then - if(age.lt.tscls(6))then - dt = pts2*(tscls(4) - age) - else - dt = pts2*(tscls(5) - age) - endif - dtr = MIN(tscls(2),tn) - age - elseif(kw.eq.4)then - dt = pts2*tscls(3) - dtr = MIN(tn,tscls(2) + tscls(3)) - age - elseif(kw.eq.5)then - if(age.lt.tscls(9))then - dt = pts3*(tscls(7) - age) - else - dt = pts3*(tscls(8) - age) - endif - dtr = MIN(tn,tscls(13)) - age - elseif(kw.eq.6)then - if(age.lt.tscls(12))then - dt = pts3*(tscls(10) - age) - else - dt = pts3*(tscls(11) - age) - endif - dt = MIN(dt,0.005d0) - dtr = tn - age - elseif(kw.eq.7)then - dt = pts1*tm - dtr = tm - age - elseif(kw.eq.8.or.kw.eq.9)then - if(age.lt.tscls(6))then - dt = pts2*(tscls(4) - age) - else - dt = pts2*(tscls(5) - age) - endif - dtr = tn - age - else -* dt = MAX(0.1d0,age*10.d0) - dt = MAX(0.1d0,dt*10.d0) - dt = MIN(dt,5.0d+02) - dtr = dt - endif -* - RETURN - END -*** - - -cc//evolv1.f - -*** - SUBROUTINE evolv1(kw,mass,mt,r,lum,mc,rc,menv,renv,ospin, - & epoch,tm,tphys,tphysf,dtp,z,zpars,vkick,vs) -c-------------------------------------------------------------c -c -c Evolves a single star. -c Mass loss is an option. -c The timestep is not constant but determined by certain criteria. -c Plots the HRD and variables as a function of time. -c -c Written by Jarrod Hurley 26/08/97 at the Institute of -c Astronomy, Cambridge. -c -c-------------------------------------------------------------c -c -c STELLAR TYPES - KW -c -c 0 - deeply or fully convective low mass MS star -c 1 - Main Sequence star -c 2 - Hertzsprung Gap -c 3 - First Giant Branch -c 4 - Core Helium Burning -c 5 - First Asymptotic Giant Branch -c 6 - Second Asymptotic Giant Branch -c 7 - Main Sequence Naked Helium star -c 8 - Hertzsprung Gap Naked Helium star -c 9 - Giant Branch Naked Helium star -c 10 - Helium White Dwarf -c 11 - Carbon/Oxygen White Dwarf -c 12 - Oxygen/Neon White Dwarf -c 13 - Neutron Star -c 14 - Black Hole -c 15 - Massless Supernova -c -c-------------------------------------------------------------c - implicit none -* - integer kw,it,ip,jp,j,kwold,rflag - integer nv - parameter(nv=50000) -* - real*8 mass,z,aj - real*8 epoch,tphys,tphys2,tmold,tbgold - real*8 mt,tm,tn,tphysf,dtp,tsave - real*8 tscls(20),lums(10),GB(10),zpars(20) - real*8 r,lum,mc,teff,rc,menv,renv,vs(3) - real*8 ospin,jspin,djt,djmb,k2,k3,vkick - parameter(k3=0.21d0) - real*8 m0,r1,lum1,mc1,rc1,menv1,renv1,k21 - real*8 dt,dtm,dtr,dr,dtdr,dms,dml,mt2,rl - real*8 tol,tiny - parameter(tol=1.0d-10,tiny=1.0d-14) - real*8 ajhold,rm0,eps,alpha2 - parameter(eps=1.0d-06,alpha2=0.09d0) - real*8 mlwind,vrotf - external mlwind,vrotf - logical iplot,isave - REAL*8 neta,bwind,hewind,mxns - COMMON /VALUE1/ neta,bwind,hewind,mxns - REAL*8 pts1,pts2,pts3 - COMMON /POINTS/ pts1,pts2,pts3 - REAL scm(50000,14),spp(20,3) - COMMON /SINGLE/ scm,spp -* - dtm = 0.d0 - r = 0.d0 - lum = 0.d0 - mc = 0.d0 - mc1 = 0.d0 - rc = 0.d0 - rl = 0.d0 - if(ospin.le.0.d0)then - ospin = 1.0d-10 - jspin = 1.0d-10 - endif - k2 = 0.15d0 - rflag = 0 - -* -* Setup variables which control the output (if it is required). -* - ip = 0 - jp = 0 - tsave = tphys - isave = .true. - iplot = .false. - if(dtp.le.0.d0)then - iplot = .true. - isave = .false. - tsave = tphysf - elseif(dtp.gt.tphysf)then - isave = .false. - tsave = tphysf - endif -* - do 10 , j = 1,nv -* - if(neta.gt.tiny.and.j.gt.1)then -* -* Calculate mass loss from the previous timestep. -* - dt = 1.0d+06*dtm - dms = mlwind(kw,lum,r,mt,mc,rl,z)*dt - if(kw.lt.10)then - dml = mt - mc - if(dml.lt.dms)then - dtm = (dml/dms)*dtm - dms = dml - endif - endif - else - dms = 0.d0 - endif -* -* Limit to 1% mass loss. -* - if(dms.gt.0.01d0*mt)then - dtm = 0.01d0*mt*dtm/dms - dms = 0.01d0*mt - endif -* -* Calculate the rate of angular momentum loss due to magnetic braking -* and/or mass loss. -* - if(j.gt.1)then - djt = (2.d0/3.d0)*(dms/(1.0d+06*dtm))*r*r*ospin - if(mt.gt.0.35d0.and.kw.lt.10)then - djmb = 5.83d-16*menv*(r*ospin)**3/mt - djt = djt + djmb - endif - endif -* -* Update mass and time and reset epoch for a MS (and possibly a HG) star. -* - if(dms.gt.0.d0)then - mt = mt - dms - if(kw.le.2.or.kw.eq.7)then - m0 = mass - mc1 = mc - mass = mt - tmold = tm - tbgold = tscls(1) - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - if(kw.eq.2)then - if(GB(9).lt.mc1.or.m0.gt.zpars(3))then - mass = m0 - else - epoch = tm + (tscls(1) - tm)*(ajhold-tmold)/ - & (tbgold - tmold) - epoch = tphys - epoch - endif - else - epoch = tphys - ajhold*tm/tmold - endif - endif - endif - tphys2 = tphys - tphys = tphys + dtm -* -* Find the landmark luminosities and timescales as well as setting -* the GB parameters. -* - aj = tphys - epoch - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) -* -* Find the current radius, luminosity, core mass and stellar type -* given the initial mass, current mass, metallicity and age -* - kwold = kw - CALL hrdiag(mass,aj,mt,tm,tn,tscls,lums,GB,zpars, - & r,lum,kw,mc,rc,menv,renv,k2) -* -* If mass loss has occurred and no type change then check that we -* have indeed limited the radius change to 10%. -* - if(kw.eq.kwold.and.dms.gt.0.d0.and.rflag.ne.0)then - mt2 = mt + dms - dml = dms/dtm - it = 0 - 20 dr = r - rm0 - if(ABS(dr).gt.0.1d0*rm0)then - it = it + 1 - if(it.eq.20.and.kw.eq.4) goto 30 - if(it.gt.30)then - WRITE(99,*)' DANGER1! ',it,kw,mass,dr,rm0 - WRITE(*,*)' STOP: EVOLV1 FATAL ERROR ' - CALL exit(0) - STOP - endif - dtdr = dtm/ABS(dr) - dtm = alpha2*MAX(rm0,r)*dtdr - if(it.ge.20) dtm = 0.5d0*dtm - if(dtm.lt.1.0d-07*aj) goto 30 - dms = dtm*dml - mt = mt2 - dms - if(kw.le.2.or.kw.eq.7)then - mass = mt - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - if(kw.eq.2)then - if(GB(9).lt.mc1.or.m0.gt.zpars(3))then - mass = m0 - else - epoch = tm + (tscls(1) - tm)*(ajhold-tmold)/ - & (tbgold - tmold) - epoch = tphys2 - epoch - endif - else - epoch = tphys2 - ajhold*tm/tmold - endif - endif - tphys = tphys2 + dtm - aj = tphys - epoch - mc = mc1 - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - CALL hrdiag(mass,aj,mt,tm,tn,tscls,lums,GB,zpars, - & r,lum,kw,mc,rc,menv,renv,k2) - goto 20 - endif - 30 continue - endif -* -* Initialize or adjust the spin of the star. -* - if(j.eq.1)then - if(tphys.lt.tiny.and.ospin.lt.0.001d0)then - ospin = 45.35d0*vrotf(mt)/r - endif - jspin = ospin*(k2*r*r*(mt-mc)+k3*rc*rc*mc) - else - jspin = MAX(1.0d-10,jspin - djt*1.0d+06*dtm) - ospin = jspin/(k2*r*r*(mt-mc)+k3*rc*rc*mc) - endif -* -* Test for changes in evolution type. -* - if(j.eq.1.or.kw.ne.kwold)then -* -* Force new NS or BH to have a one second period. -* - if(kw.eq.13.or.kw.eq.14)then - ospin = 2.0d+08 - jspin = k3*rc*rc*mc*ospin - CALL kick(kw,mass,mt,0.d0,0.d0,-1.d0,0.d0,vs) - vkick = dsqrt(vs(1)*vs(1)+vs(2)*vs(2)+vs(3)*vs(3)) - endif - jp = jp + 1 - spp(jp,1) = tphys - spp(jp,2) = float(kw) - if(kw.eq.15)then - spp(jp,3) = mass - goto 90 - else - spp(jp,3) = mt - endif - endif -* -* Record values for plotting and reset epoch. -* - epoch = tphys - aj - if((isave.and.tphys.ge.tsave).or.iplot)then - ip = ip + 1 - scm(ip,1) = tphys - scm(ip,2) = float(kw) - scm(ip,3) = mass - scm(ip,4) = mt - scm(ip,5) = log10(lum) - scm(ip,6) = log10(r) - teff = 1000.d0*((1130.d0*lum/(r**2.d0))**(1.d0/4.d0)) - scm(ip,7) = log10(teff) - scm(ip,8) = mc - scm(ip,9) = rc - scm(ip,10) = menv - scm(ip,11) = renv - scm(ip,12) = epoch - scm(ip,13) = ospin - if(isave) tsave = tsave + dtp - if(tphysf.lt.tiny)then - ip = ip + 1 - do 35 , it = 1,13 - scm(ip,it) = scm(ip-1,it) - 35 continue - endif - endif -* - if(tphys.ge.tphysf)then - jp = jp + 1 - spp(jp,1) = tphys - spp(jp,2) = float(kw) - spp(jp,3) = mt - goto 90 - endif -* -* Record radius and current age. -* - rm0 = r - ajhold = aj - if(kw.ne.kwold) kwold = kw - CALL deltat(kw,aj,tm,tn,tscls,dtm,dtr) -* -* Check for type change. -* - it = 0 - m0 = mass - if((dtr-dtm).le.tol.and.kw.le.9)then -* -* Check final radius for too large a jump. -* - aj = MAX(aj,aj*(1.d0-eps)+dtr) - mc1 = mc - CALL hrdiag(mass,aj,mt,tm,tn,tscls,lums,GB,zpars, - & r1,lum1,kw,mc1,rc1,menv1,renv1,k21) - dr = r1 - rm0 - if(ABS(dr).gt.0.1d0*rm0)then - dtm = dtr - ajhold*eps - dtdr = dtm/ABS(dr) - dtm = alpha2*MAX(r1,rm0)*dtdr - goto 40 - else - dtm = dtr - goto 50 - endif - endif -* -* Limit to a 10% increase in radius assuming no further mass loss -* and thus that the pertubation functions due to small envelope mass -* will not change the radius. -* - 40 aj = ajhold + dtm - mc1 = mc - CALL hrdiag(mass,aj,mt,tm,tn,tscls,lums,GB,zpars, - & r1,lum1,kw,mc1,rc1,menv1,renv1,k21) - dr = r1 - rm0 - it = it + 1 - if(it.eq.20.and.kw.eq.4) goto 50 - if(it.gt.30)then - WRITE(99,*)' DANGER2! ',it,kw,mass,dr,rm0 - WRITE(*,*)' STOP: EVOLV1 FATAL ERROR ' - CALL exit(0) - STOP - endif - if(ABS(dr).gt.0.1d0*rm0)then - dtdr = dtm/ABS(dr) - dtm = alpha2*MAX(rm0,r1)*dtdr - if(it.ge.20) dtm = 0.5d0*dtm - goto 40 - endif -* - 50 continue -* -* Ensure that change of type has not occurred during radius check. -* This is rare but may occur for HG stars of ZAMS mass > 50 Msun. -* - if(kw.ne.kwold)then - kw = kwold - mass = m0 - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - endif -* -* Choose minimum of time-scale and remaining interval (> 100 yrs). -* - dtm = MAX(dtm,1.0d-07*aj) - dtm = MIN(dtm,tsave-tphys) -* - 10 continue -* - 90 continue -* - tphysf = tphys - scm(ip+1,1) = -1.0 - spp(jp+1,1) = -1.0 - if(ip.ge.nv)then - WRITE(99,*)' EVOLV1 ARRAY ERROR ',mass - WRITE(*,*)' STOP: EVOLV1 ARRAY ERROR ' - CALL exit(0) - STOP - endif -* - RETURN - END -*** - - -cc//hrdiag.f - -*** - SUBROUTINE hrdiag(mass,aj,mt,tm,tn,tscls,lums,GB,zpars, - & r,lum,kw,mc,rc,menv,renv,k2) -* -* -* H-R diagram for population I stars. -* ----------------------------------- -* -* Computes the new mass, luminosity, radius & stellar type. -* Input (MASS, AJ, TM, TN, LUMS & TSCLS) supplied by routine STAR. -* Ref: P.P. Eggleton, M.J. Fitchett & C.A. Tout (1989) Ap.J. 347, 998. -* -* Revised 27th March 1995 by C. A. Tout; -* 24th October 1995 to include metallicity; -* 14th November 1996 to include naked helium stars; -* 28th February 1997 to allow accretion induced supernovae. -* -* Revised 5th April 1997 by J. R. Hurley -* to include Z=0.001 as well as Z=0.02, convective overshooting, -* MS hook and more elaborate CHeB -* - implicit none -* - integer kw,kwp - INTEGER ceflag,tflag,ifflag,nsflag,wdflag - COMMON /FLAGS/ ceflag,tflag,ifflag,nsflag,wdflag -* - -CCC added by Long Wang & Peter Berczik 2014.10. - real*8 fallback - common /fall/fallback - - real*8 mass,aj,mt,tm,tn,tscls(20),lums(10),GB(10),zpars(20) - real*8 r,lum,mc,rc,menv,renv,k2 - real*8 mch,mlp,tiny - parameter(mch=1.44d0,mlp=12.d0,tiny=1.0d-14) - real*8 mass0,mt0,mtc - REAL*8 neta,bwind,hewind,mxns - COMMON /VALUE1/ neta,bwind,hewind,mxns -* - real*8 thook,thg,tbagb,tau,tloop,taul,tauh,tau1,tau2,dtau,texp - real*8 lx,ly,dell,alpha,beta,eta - real*8 rx,ry,delr,rzams,rtms,gamma,rmin,taumin,rg - parameter(taumin=5.0d-08) - real*8 mcmax,mcx,mcy,mcbagb,lambda - real*8 am,xx,fac,rdgen,mew,lum0,kap,zeta,ahe,aco - parameter(lum0=7.0d+04,kap=-0.5d0,ahe=4.d0,aco=16.d0) -* - real*8 thookf,tblf - real*8 lalphf,lbetaf,lnetaf,lhookf,lgbtf,lmcgbf,lzhef,lpertf - real*8 rzamsf,rtmsf,ralphf,rbetaf,rgammf,rhookf - real*8 rgbf,rminf,ragbf,rzahbf,rzhef,rhehgf,rhegbf,rpertf - real*8 mctmsf,mcgbtf,mcgbf,mcheif,mcagbf,lzahbf - external thookf,tblf - external lalphf,lbetaf,lnetaf,lhookf,lgbtf,lmcgbf,lzhef,lpertf - external rzamsf,rtmsf,ralphf,rbetaf,rgammf,rhookf - external rgbf,rminf,ragbf,rzahbf,rzhef,rhehgf,rhegbf,rpertf - external mctmsf,mcgbtf,mcgbf,mcheif,mcagbf,lzahbf -* -* -* --------------------------------------------------------------------- -* MASS Stellar mass in solar units (input: old; output: new value). -* AJ Current age in Myr. -* MT Current mass in solar units (used for R). -* TM Main sequence time. -* TN Nuclear burning time. -* TSCLS Time scale for different stages. -* LUMS Characteristic luminosity. -* GB Giant Branch parameters -* ZPARS Parameters for distinguishing various mass intervals. -* R Stellar radius in solar units. -* TE Effective temperature (suppressed). -* KW Classification type (0 - 15). -* MC Core mass. -* --------------------------------------------------------------------- -* -* -* Make evolutionary changes to stars that have not reached KW > 5. -* - -CCC added by Long Wang & Peter Berczik 2014.10. - fallback = 0.0d0 - - mass0 = mass - if(mass0.gt.100.d0) mass = 100.d0 - mt0 = mt - if(mt0.gt.100.d0) mt = 100.d0 -* - if(kw.gt.6) goto 90 -* - tbagb = tscls(2) + tscls(3) - thg = tscls(1) - tm -* - rzams = rzamsf(mass) - rtms = rtmsf(mass) -* - if(aj.lt.tscls(1))then -* -* Either on MS or HG -* - rg = rgbf(mt,lums(3)) -* - if(aj.lt.tm)then -* -* Main sequence star. -* - mc = 0.d0 - tau = aj/tm - thook = thookf(mass)*tscls(1) - zeta = 0.01d0 - tau1 = MIN(1.d0,aj/thook) - tau2 = MAX(0.d0, - & MIN(1.d0,(aj-(1.d0-zeta)*thook)/(zeta*thook))) -* - dell = lhookf(mass,zpars(1)) - dtau = tau1**2 - tau2**2 - alpha = lalphf(mass) - beta = lbetaf(mass) - eta = lnetaf(mass) - lx = LOG10(lums(2)/lums(1)) - if(tau.gt.taumin)then - xx = alpha*tau + beta*tau**eta + - & (lx - alpha - beta)*tau**2 - dell*dtau - else - xx = alpha*tau + (lx - alpha)*tau**2 - dell*dtau - endif - lum = lums(1)*10.d0**xx -* - delr = rhookf(mass,zpars(1)) - dtau = tau1**3 - tau2**3 - alpha = ralphf(mass) - beta = rbetaf(mass) - gamma = rgammf(mass) - rx = LOG10(rtms/rzams) -* Note that the use of taumin is a slightly pedantic attempt to -* avoid floating point underflow. It IS overkill! - if(tau.gt.taumin)then - xx = alpha*tau + beta*tau**10 + gamma*tau**40 + - & (rx - alpha - beta - gamma)*tau**3 - delr*dtau - else - xx = alpha*tau + (rx - alpha)*tau**3 - delr*dtau - endif - r = rzams*10.d0**xx -* - if(mass.lt.(zpars(1)-0.3d0))then - kw = 0 -* This following is given by Chris for low mass MS stars which will be -* substantially degenerate. We need the Hydrogen abundance, X, which we -* calculate from Z assuming that the helium abundance, Y, is calculated -* according to Y = 0.24 + 2*Z - rdgen = 0.0258d0*((1.d0+zpars(11))**(5.d0/3.d0))* - & (mass**(-1.d0/3.d0)) - r = MAX(rdgen,r) - else - kw = 1 - endif -* - else -* -* Star is on the HG -* - mcx = mc - if(mass.le.zpars(2))then - mc = mcgbf(lums(3),GB,lums(6)) - elseif(mass.le.zpars(3))then - mc = mcheif(mass,zpars(2),zpars(9)) - else - mc = mcheif(mass,zpars(2),zpars(10)) - endif - eta = mctmsf(mass) - tau = (aj - tm)/thg - mc = ((1.d0 - tau)*eta + tau)*mc - mc = MAX(mc,mcx) -* -* Test whether core mass has reached total mass. -* - if(mc.ge.mt)then - aj = 0.d0 - if(mass.gt.zpars(2))then -* -* Zero-age helium star -* - mc = 0.d0 - mass = mt - kw = 7 - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - else -* -* Zero-age helium white dwarf. -* - mc = mt - mass = mt - kw = 10 - endif - else - lum = lums(2)*(lums(3)/lums(2))**tau - if(mass.le.zpars(3))then - rx = rg - else -* He-ignition and end of HG occur at Rmin - rmin = rminf(mass) - ry = ragbf(mt,lums(4),zpars(2)) - rx = MIN(rmin,ry) - if(mass.le.mlp)then - texp = log(mass/mlp)/log(zpars(3)/mlp) - rx = rg - rx = rmin*(rx/rmin)**texp - endif - tau2 = tblf(mass,zpars(2),zpars(3)) - if(tau2.lt.tiny) rx = ry - endif - r = rtms*(rx/rtms)**tau - kw = 2 - endif -* - endif -* -* Now the GB, CHeB and AGB evolution. -* - elseif(aj.lt.tscls(2))then -* -* Red Giant. -* - kw = 3 - lum = lgbtf(aj,GB(1),GB,tscls(4),tscls(5),tscls(6)) - if(mass.le.zpars(2))then -* Star has a degenerate He core which grows on the GB - mc = mcgbf(lum,GB,lums(6)) - else -* Star has a non-degenerate He core which may grow, but -* only slightly, on the GB - tau = (aj - tscls(1))/(tscls(2) - tscls(1)) - mcx = mcheif(mass,zpars(2),zpars(9)) - mcy = mcheif(mass,zpars(2),zpars(10)) - mc = mcx + (mcy - mcx)*tau - endif - r = rgbf(mt,lum) - rg = r - if(mc.ge.mt)then - aj = 0.d0 - if(mass.gt.zpars(2))then -* -* Zero-age helium star -* - mc = 0.d0 - mass = mt - kw = 7 - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - else -* -* Zero-age helium white dwarf. -* - mc = mt - mass = mt - kw = 10 - endif - endif -* - elseif(aj.lt.tbagb)then -* -* Core helium burning star. -* - if(kw.eq.3.and.mass.le.zpars(2))then - mass = mt - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - aj = tscls(2) - endif - if(mass.le.zpars(2))then - mcx = mcgbf(lums(4),GB,lums(6)) - else - mcx = mcheif(mass,zpars(2),zpars(10)) - endif - tau = (aj - tscls(2))/tscls(3) - mc = mcx + (mcagbf(mass) - mcx)*tau -* - if(mass.le.zpars(2))then - lx = lums(5) - ly = lums(7) - rx = rzahbf(mt,mc,zpars(2)) - rg = rgbf(mt,lx) - rmin = rg*zpars(13)**(mass/zpars(2)) - texp = MIN(MAX(0.4d0,rmin/rx),2.5d0) - ry = ragbf(mt,ly,zpars(2)) - if(rmin.lt.rx)then - taul = (log(rx/rmin))**(1.d0/3.d0) - else - rmin = rx - taul = 0.d0 - endif - tauh = (log(ry/rmin))**(1.d0/3.d0) - tau2 = taul*(tau - 1.d0) + tauh*tau - r = rmin*exp(abs(tau2)**3) - rg = rg + tau*(ry - rg) - lum = lx*(ly/lx)**(tau**texp) - elseif(mass.gt.zpars(3))then -* -* For HM stars He-ignition takes place at Rmin in the HG, and CHeB -* consists of a blue phase (before tloop) and a RG phase (after tloop). -* - tau2 = tblf(mass,zpars(2),zpars(3)) - tloop = tscls(2) + tau2*tscls(3) - rmin = rminf(mass) - rg = rgbf(mt,lums(4)) - rx = ragbf(mt,lums(4),zpars(2)) - rmin = MIN(rmin, rx) - if(mass.le.mlp) then - texp = log(mass/mlp)/log(zpars(3)/mlp) - rx = rg - rx = rmin*(rx/rmin)**texp - else - rx = rmin - end if - texp = MIN(MAX(0.4d0,rmin/rx),2.5d0) - lum = lums(4)*(lums(7)/lums(4))**(tau**texp) - if(aj.lt.tloop)then - ly = lums(4)*(lums(7)/lums(4))**(tau2**texp) - ry = ragbf(mt,ly,zpars(2)) - taul = 0.d0 - if(ABS(rmin-rx).gt.tiny)then - taul = (log(rx/rmin))**(1.d0/3.d0) - endif - tauh = 0.d0 - if(ry.gt.rmin) tauh = (log(ry/rmin))**(1.d0/3.d0) - tau = (aj - tscls(2))/(tau2*tscls(3)) - tau2 = taul*(tau - 1.d0) + tauh*tau - r = rmin*exp(abs(tau2)**3) - rg = rg + tau*(ry - rg) - else - r = ragbf(mt,lum,zpars(2)) - rg = r - end if - else -* -* For IM stars CHeB consists of a RG phase (before tloop) and a blue -* loop (after tloop). -* - tau2 = 1.d0 - tblf(mass,zpars(2),zpars(3)) - tloop = tscls(2) + tau2*tscls(3) - if(aj.lt.tloop)then - tau = (tloop - aj)/(tau2*tscls(3)) - lum = lums(5)*(lums(4)/lums(5))**(tau**3) - r = rgbf(mt,lum) - rg = r - else - lx = lums(5) - ly = lums(7) - rx = rgbf(mt,lx) - rmin = rminf(mt) - texp = MIN(MAX(0.4d0,rmin/rx),2.5d0) - ry = ragbf(mt,ly,zpars(2)) - if(rmin.lt.rx)then - taul = (log(rx/rmin))**(1.d0/3.d0) - else - rmin = rx - taul = 0.d0 - endif - tauh = (log(ry/rmin))**(1.d0/3.d0) - tau = (aj - tloop)/(tscls(3) - (tloop - tscls(2))) - tau2 = taul*(tau - 1.d0) + tauh*tau - r = rmin*exp(abs(tau2)**3) - rg = rx + tau*(ry - rx) - lum = lx*(ly/lx)**(tau**texp) - endif - endif -* -* Test whether core mass exceeds total mass. -* - if(mc.ge.mt)then -* -* Evolved MS naked helium star. -* - kw = 7 - xx = (aj - tscls(2))/tscls(3) - mass = mt - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - aj = xx*tm - else - kw = 4 - endif -* - else -* -* Asymptotic Red Giant. -* -* On the AGB the He core mass remains constant until at Ltp it -* is caught by the C core mass and they grow together. -* - mcbagb = mcagbf(mass) - mcx = mcgbtf(tbagb,GB(8),GB,tscls(7),tscls(8),tscls(9)) - mcmax = MAX(MAX(mch,0.773d0*mcbagb-0.35d0),1.05d0*mcx) -* - if(aj.lt.tscls(13))then - mcx = mcgbtf(aj,GB(8),GB,tscls(7),tscls(8),tscls(9)) - mc = mcbagb - lum = lmcgbf(mcx,GB) - if(mt.le.mc)then -* -* Evolved naked helium star as the envelope is lost but the -* star has not completed its interior burning. The star becomes -* a post-HeMS star. -* - kw = 9 - mt = mc - mass = mt - mc = mcx - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - if(mc.le.GB(7))then - aj = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))* - & (mc**(1.d0-GB(5))) - else - aj = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))* - & (mc**(1.d0-GB(6))) - endif - aj = MAX(aj,tm) - goto 90 - else - kw = 5 - endif - else - kw = 6 - mc = mcgbtf(aj,GB(2),GB,tscls(10),tscls(11),tscls(12)) - lum = lmcgbf(mc,GB) -* -* Approximate 3rd Dredge-up on AGB by limiting Mc. -* - lambda = MIN(0.9d0,0.3d0+0.001d0*mass**5) - tau = tscls(13) - mcx = mcgbtf(tau,GB(2),GB,tscls(10),tscls(11),tscls(12)) - mcy = mc - mc = mc - lambda*(mcy-mcx) - mcx = mc - mcmax = MIN(mt,mcmax) - endif - r = ragbf(mt,lum,zpars(2)) - rg = r -* -* Mc,x represents the C core mass and we now test whether it -* exceeds either the total mass or the maximum allowed core mass. -* - if(mcmax-mcx.lt.tiny)then - aj = 0.d0 - mc = mcmax - if(mc.lt.mch)then - if(ifflag.ge.1)then -* -* Invoke WD IFMR from HPE, 1995, MNRAS, 272, 800. -* - if(zpars(14).ge.1.0d-08)then - mc = MIN(0.36d0+0.104d0*mass,0.58d0+0.061d0*mass) - mc = MAX(0.54d0+0.042d0*mass,mc) - if(mass.lt.1.d0) mc = 0.46d0 - else - mc = MIN(0.29d0+0.178d0*mass,0.65d0+0.062d0*mass) - mc = MAX(0.54d0+0.073d0*mass,mc) - endif - mc = MIN(mch,mc) - endif -* - mt = mc - if(mcbagb.lt.1.6d0)then -* -* Zero-age Carbon/Oxygen White Dwarf -* - kw = 11 - else -* -* Zero-age Oxygen/Neon White Dwarf -* - kw = 12 - endif - mass = mt -* - else - if(mcbagb.lt.1.6d0)then -* -* Star is not massive enough to ignite C burning. -* so no remnant is left after the SN -* - kw = 15 - aj = 0.d0 - mt = 0.d0 - lum = 1.0d-10 - r = 1.0d-10 - else - if(nsflag.eq.0)then - mt = 1.17d0 + 0.09d0*mc - elseif(nsflag.ge.1)then -* -* Use NS/BH mass given by Belczynski et al. 2002, ApJ, 572, 407. -* - if(mc.lt.2.5d0) then - mcx = 0.161767d0*mc + 1.067055d0 - else - mcx = 0.314154d0*mc + 0.686088d0 - endif - - if(mc.le.5.d0) then - mt = mcx - elseif(mc.lt.7.6d0) then - mt = mcx + (mc - 5.d0)*(mt - mcx)/2.6d0 -CCC added by Long Wang & Peter Berczik 2014.10. - fallback = (mc - 5.0d0)/2.6d0 - endif -CCC added by Long Wang & Peter Berczik 2014.10. - if(mc.gt.7.6d0) fallback = 1.0d0 - - endif - mc = mt - if(mt.le.mxns)then -* -* Zero-age Neutron star -* - kw = 13 - else -* -* Zero-age Black hole -* - kw = 14 - endif - endif - endif - endif -* - endif -* - 90 continue -* - if(kw.ge.7.and.kw.le.9)then -* -* Naked Helium Star -* - rzams = rzhef(mt) - rx = rzams - if(aj.lt.tm)then -* -* Main Sequence -* - kw = 7 - tau = aj/tm - am = MAX(0.d0,0.85d0-0.08d0*mass) - lum = lums(1)*(1.d0+0.45d0*tau+am*tau**2) - am = MAX(0.d0,0.4d0-0.22d0*LOG10(mt)) - r = rx*(1.d0+am*(tau-tau**6)) - rg = rx -* Star has no core mass and hence no memory of its past -* which is why we subject mass and mt to mass loss for -* this phase. - mc = 0.d0 - if(mt.lt.zpars(10)) kw = 10 - else -* -* Helium Shell Burning -* - kw = 8 - lum = lgbtf(aj,GB(8),GB,tscls(4),tscls(5),tscls(6)) - r = rhehgf(mt,lum,rx,lums(2)) - rg = rhegbf(lum) - if(r.ge.rg)then - kw = 9 - r = rg - endif - mc = mcgbf(lum,GB,lums(6)) - mtc = MIN(mt,1.45d0*mt-0.31d0) - mcmax = MIN(mtc,MAX(mch,0.773d0*mass-0.35d0)) - if(mcmax-mc.lt.tiny)then - aj = 0.d0 - mc = mcmax - if(mc.lt.mch)then - if(mass.lt.1.6d0)then -* -* Zero-age Carbon/Oxygen White Dwarf -* - mt = MAX(mc,(mc+0.31d0)/1.45d0) - kw = 11 - else -* -* Zero-age Oxygen/Neon White Dwarf -* - mt = mc - kw = 12 - endif - mass = mt - else - if(mass.lt.1.6d0)then -* -* Star is not massive enough to ignite C burning. -* so no remnant is left after the SN -* - kw = 15 - aj = 0.d0 - mt = 0.d0 - lum = 1.0d-10 - r = 1.0d-10 - else - if(nsflag.eq.0)then - mt = 1.17d0 + 0.09d0*mc - elseif(nsflag.ge.1)then - if(mc.lt.2.5d0)then - mcx = 0.161767d0*mc + 1.067055d0 - else - mcx = 0.314154d0*mc + 0.686088d0 - endif - if(mc.le.5.d0)then - mt = mcx - elseif(mc.lt.7.6d0)then - mt = mcx + (mc - 5.d0)*(mt - mcx)/2.6d0 - endif - endif - mc = mt - if(mt.le.mxns)then -* -* Zero-age Neutron star -* - kw = 13 - else -* -* Zero-age Black hole -* - kw = 14 - endif - endif - endif - endif - endif - endif -* - if(kw.ge.10.and.kw.le.12)then -* -* White dwarf. -* - mc = mt - if(mc.ge.mch)then -* -* Accretion induced supernova with no remnant -* unless WD is ONe in which case we assume a NS -* of minimum mass is the remnant. -* - if(kw.eq.12)then - kw = 13 - aj = 0.d0 - mt = 1.3d0 - else - kw = 15 - aj = 0.d0 - mt = 0.d0 - lum = 1.0d-10 - r = 1.0d-10 - endif - else -* - if(kw.eq.10)then - xx = ahe - else - xx = aco - endif -* - if(wdflag.eq.0)then -* -* Mestel cooling -* - lum = 635.d0*mt*zpars(14)/(xx*(aj+0.1d0))**1.4d0 -* - elseif(wdflag.ge.1)then -* -* modified-Mestel cooling -* - if(aj.lt.9000.0)then - lum = 300.d0*mt*zpars(14)/(xx*(aj+0.1d0))**1.18d0 - else - fac = (9000.1d0*xx)**5.3d0 - lum = 300.d0*fac*mt*zpars(14)/(xx*(aj+0.1d0))**6.48d0 - endif -* - endif -* - r = 0.0115d0*SQRT(MAX(1.48204d-06,(mch/mt)**(2.d0/3.d0) - & - (mt/mch)**(2.d0/3.d0))) - r = MIN(0.1d0,r) - if(mt.lt.0.0005d0) r = 0.09d0 - if(mt.lt.0.000005d0) r = 0.009d0 -* - endif - endif -* - if(kw.eq.13)then -* -* Neutron Star. -* - mc = mt - if(mc.gt.mxns)then -* -* Accretion induced Black Hole? -* - kw = 14 - aj = 0.d0 - else - lum = 0.02d0*(mt**0.67d0)/(MAX(aj,0.1d0))**2 - r = 1.4d-05 - endif - endif -* - if(kw.eq.14)then -* -* Black hole -* - mc = mt - lum = 1.0d-10 - r = 4.24d-06*mt - endif -* -* Calculate the core radius and the luminosity and radius of the -* remnant that the star will become. -* - tau = 0.d0 - if(kw.le.1.or.kw.eq.7)then - rc = 0.d0 - elseif(kw.le.3)then - if(mass.gt.zpars(2))then - lx = lzhef(mc) - rx = rzhef(mc) - rc = rx - else - if(wdflag.eq.0)then - lx = 635.d0*mc*zpars(14)/((ahe*0.1d0)**1.4d0) - elseif(wdflag.ge.1)then - lx = 300.d0*mc*zpars(14)/((ahe*0.1d0)**1.18d0) - endif - rx = 0.0115d0*SQRT(MAX(1.48204d-06, - & (mch/mc)**(2.d0/3.d0)-(mc/mch)**(2.d0/3.d0))) - rc = 5.d0*rx - endif - elseif(kw.eq.4)then - tau = (aj - tscls(2))/tscls(3) - kwp = 7 - CALL star(kwp,mc,mc,tm,tn,tscls,lums,GB,zpars) - am = MAX(0.d0,0.85d0-0.08d0*mc) - lx = lums(1)*(1.d0+0.45d0*tau+am*tau**2) - rx = rzhef(mc) - am = MAX(0.d0,0.4d0-0.22d0*LOG10(mc)) - rx = rx*(1.d0+am*(tau-tau**6)) - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - rc = rx - elseif(kw.eq.5)then - kwp = 9 - if(tn.gt.tbagb) tau = 3.d0*(aj-tbagb)/(tn-tbagb) - CALL star(kwp,mc,mc,tm,tn,tscls,lums,GB,zpars) - lx = lmcgbf(mcx,GB) - if(tau.lt.1.d0) lx = lums(2)*(lx/lums(2))**tau - rx = rzhef(mc) - rx = MIN(rhehgf(mc,lx,rx,lums(2)),rhegbf(lx)) - CALL star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) - rc = rx - elseif(kw.le.9)then - if(wdflag.eq.0)then - lx = 635.d0*mc*zpars(14)/((aco*0.1d0)**1.4d0) - elseif(wdflag.ge.1)then - lx = 300.d0*mc*zpars(14)/((aco*0.1d0)**1.18d0) - endif - rx = 0.0115d0*SQRT(MAX(1.48204d-06, - & (mch/mc)**(2.d0/3.d0) - (mc/mch)**(2.d0/3.d0))) - rc = 5.d0*rx - else - rc = r - menv = 1.0d-10 - renv = 1.0d-10 - k2 = 0.21d0 - endif -* -* Perturb the luminosity and radius due to small envelope mass. -* - if(kw.ge.2.and.kw.le.9.and.kw.ne.7)then - mew = ((mt-mc)/mt)*MIN(5.d0,MAX(1.2d0,(lum/lum0)**kap)) - if(kw.ge.8) mew = ((mtc-mc)/mtc)*5.d0 - if(mew.lt.1.d0)then - xx = lpertf(mt,mew) - lum = lx*(lum/lx)**xx - if(r.le.rx)then - xx = 0.d0 - else - xx = rpertf(mt,mew,r,rx) - endif - r = rx*(r/rx)**xx - endif - rc = MIN(rc,r) - endif -* -* Calculate mass and radius of convective envelope, and envelope -* gyration radius. -* - if(kw.lt.10)then - CALL mrenv(kw,mass,mt,mc,lum,r,rc,aj,tm,lums(2),lums(3), - & lums(4),rzams,rtms,rg,menv,renv,k2) - endif -* - if(mass.gt.99.99d0)then - mass = mass0 - endif - if(mt.gt.99.99d0)then - mt = mt0 - endif -* - return - end -*** - -cc//kick.f - -*** - SUBROUTINE kick(kw,m1,m1n,m2,ecc,sep,jorb,vs) - implicit none -* - integer kw,k - INTEGER idum - COMMON /VALUE3/ idum - INTEGER idum2,iy,ir(32) - COMMON /RAND3/ idum2,iy,ir - integer bhflag - real*8 m1,m2,m1n,ecc,sep,jorb,ecc2 - real*8 pi,twopi,gmrkm,yearsc,rsunkm - parameter(yearsc=3.1557d+07,rsunkm=6.96d+05) - real*8 mm,em,dif,der,del,r - real*8 u1,u2,vk,v(4),s,theta,phi - real*8 sphi,cphi,stheta,ctheta,salpha,calpha - real*8 vr,vr2,vk2,vn2,hn2 - real*8 mu,cmu,vs(3),v1,v2,mx1,mx2 - real*8 sigma - COMMON /VALUE4/ sigma,bhflag - real ran3,xx - external ran3 - -CCC added by Long Wang & Peter Berczik 2014.10. - real*8 fallback - common /fall/fallback - -* - do k = 1,3 - vs(k) = 0.d0 - enddo -* if(kw.eq.14.and.bhflag.eq.0) goto 95 -* - pi = ACOS(-1.d0) - twopi = 2.d0*pi - -* Conversion factor to ensure velocities are in km/s using mass and -* radius in solar units. - gmrkm = 1.906125d+05 - -* -* Find the initial separation by randomly choosing a mean anomaly. - if(sep.gt.0.d0.and.ecc.ge.0.d0)then - xx = RAN3(idum) - mm = xx*twopi - em = mm - 2 dif = em - ecc*SIN(em) - mm - if(ABS(dif/mm).le.1.0d-04) goto 3 - der = 1.d0 - ecc*COS(em) - del = dif/der - em = em - del - goto 2 - 3 continue - r = sep*(1.d0 - ecc*COS(em)) -* -* Find the initial relative velocity vector. - salpha = SQRT((sep*sep*(1.d0-ecc*ecc))/(r*(2.d0*sep-r))) - calpha = (-1.d0*ecc*SIN(em))/SQRT(1.d0-ecc*ecc*COS(em)*COS(em)) - vr2 = gmrkm*(m1+m2)*(2.d0/r - 1.d0/sep) - vr = SQRT(vr2) - else - vr = 0.d0 - vr2 = 0.d0 - salpha = 0.d0 - calpha = 0.d0 - endif -* -* Generate Kick Velocity using Maxwellian Distribution (Phinney 1992). -* Use Henon's method for pairwise components (Douglas Heggie 22/5/97). - do 20 k = 1,2 - u1 = RAN3(idum) - u2 = RAN3(idum) - -* Generate two velocities from polar coordinates S & THETA. - s = sigma*SQRT(-2.d0*LOG(1.d0 - u1)) - theta = twopi*u2 - v(2*k-1) = s*COS(theta) - v(2*k) = s*SIN(theta) - 20 continue - - vk2 = v(1)**2 + v(2)**2 + v(3)**2 - vk = SQRT(vk2) - -CCC added by Long Wang & Peter Berczik 2014.10. - if(kw.eq.14) then - vk = vk*(1.0d0-fallback) - vk2 = vk*vk - endif - - if((kw.eq.14.and.bhflag.eq.0).or.kw.lt.0)then - vk2 = 0.d0 - vk = 0.d0 - if(kw.lt.0) kw = 13 - endif - - sphi = -1.d0 + 2.d0*u1 - phi = ASIN(sphi) - cphi = COS(phi) - stheta = SIN(theta) - ctheta = COS(theta) - -* WRITE(66,*)' KICK VK PHI THETA ',vk,phi,theta - if(sep.le.0.d0.or.ecc.lt.0.d0) goto 90 -* -* Determine the magnitude of the new relative velocity. - vn2 = vk2+vr2-2.d0*vk*vr*(ctheta*cphi*salpha-stheta*cphi*calpha) - -* Calculate the new semi-major axis. - sep = 2.d0/r - vn2/(gmrkm*(m1n+m2)) - sep = 1.d0/sep - -* if(sep.le.0.d0)then -* ecc = 1.1d0 -* goto 90 -* endif - -* Determine the magnitude of the cross product of the separation vector -* and the new relative velocity. - - v1 = vk2*sphi*sphi - v2 = (vk*ctheta*cphi-vr*salpha)**2 - hn2 = r*r*(v1 + v2) - -* Calculate the new eccentricity. - ecc2 = 1.d0 - hn2/(gmrkm*sep*(m1n+m2)) - ecc2 = MAX(ecc2,0.d0) - ecc = SQRT(ecc2) - -* Calculate the new orbital angular momentum taking care to convert -* hn to units of Rsun^2/yr. - jorb = (m1n*m2/(m1n+m2))*SQRT(hn2)*(yearsc/rsunkm) - -* Determine the angle between the new and old orbital angular -* momentum vectors. - cmu = (vr*salpha-vk*ctheta*cphi)/SQRT(v1 + v2) - mu = ACOS(cmu) - -* Calculate the components of the velocity of the new centre-of-mass. - 90 continue - - if(ecc.le.1.0)then -* Calculate the components of the velocity of the new centre-of-mass. - mx1 = vk*m1n/(m1n+m2) - mx2 = vr*(m1-m1n)*m2/((m1n+m2)*(m1+m2)) - vs(1) = mx1*ctheta*cphi + mx2*salpha - vs(2) = mx1*stheta*cphi + mx2*calpha - vs(3) = mx1*sphi - else -* Calculate the relative hyperbolic velocity at infinity (simple method). - sep = r/(ecc-1.d0) -* cmu = SQRT(ecc-1.d0) -* mu = ATAN(cmu) - mu = ACOS(1.d0/ecc) - vr2 = gmrkm*(m1n+m2)/sep - vr = SQRT(vr2) - vs(1) = vr*SIN(mu) - vs(2) = vr*COS(mu) - vs(3) = 0.d0 - ecc = MIN(ecc,99.99d0) - endif -* - 95 continue -* - RETURN - END -*** - -cc//mlwind.f - -*** - real*8 FUNCTION mlwind(kw,lum,r,mt,mc,rl,z) - implicit none - integer kw - real*8 lum,r,mt,mc,rl,z - real*8 dml,dms,dmt,p0,x,mew,lum0,kap,neta,bwind,hewind,mxns - parameter(lum0=7.0d+04,kap=-0.5d0) - common /value1/ neta,bwind,hewind,mxns -* -* Calculate stellar wind mass loss. -* -* Apply mass loss of Nieuwenhuijzen & de Jager, A&A, 1990, 231, 134, -* for massive stars over the entire HRD. - dms = 0.d0 - if(lum.gt.4000.d0)then - x = MIN(1.d0,(lum-4000.d0)/500.d0) - dms = 9.6d-15*x*(r**0.81d0)*(lum**1.24d0)*(mt**0.16d0) - dms = dms*(z/0.02d0)**(1.d0/2.d0) - endif - if(kw.ge.2.and.kw.le.9)then -* 'Reimers' mass loss - dml = neta*4.0d-13*r*lum/mt - if(rl.gt.0.d0) dml = dml*(1.d0 + bwind*(MIN(0.5d0,(r/rl)))**6) -* Apply mass loss of Vassiliadis & Wood, ApJ, 1993, 413, 641, -* for high pulsation periods on AGB. - if(kw.eq.5.or.kw.eq.6)then - p0 = -2.07d0 - 0.9d0*log10(mt) + 1.94d0*log10(r) - p0 = 10.d0**p0 - p0 = MIN(p0,2000.d0) - dmt = -11.4d0+0.0125d0*(p0-100.d0*MAX(mt-2.5d0,0.d0)) - dmt = 10.d0**dmt - dmt = 1.d0*MIN(dmt,1.36d-09*lum) - dml = MAX(dml,dmt) - endif - if(kw.gt.6)then - dms = MAX(dml,1.0d-13*hewind*lum**(3.d0/2.d0)) - else - dms = MAX(dml,dms) - mew = ((mt-mc)/mt)*MIN(5.d0,MAX(1.2d0,(lum/lum0)**kap)) -* reduced WR-like mass loss for small H-envelope mass - if(mew.lt.1.d0)then - dml = 1.0d-13*lum**(3.d0/2.d0)*(1.d0 - mew) - dms = MAX(dml,dms) - end if -* LBV-like mass loss beyond the Humphreys-Davidson limit. - x = 1.0d-5*r*sqrt(lum) - if(lum.gt.6.0d+05.and.x.gt.1.d0)then - dml = 0.1d0*(x-1.d0)**3*(lum/6.0d+05-1.d0) - dms = dms + dml - endif - endif - endif -* - mlwind = dms -* - return - end -*** - - -cc//mrenv.f - -*** - SUBROUTINE mrenv(kw,mass,mt,mc,lum,rad,rc,aj,tm,ltms,lbgb,lhei, - & rzams,rtms,rg,menv,renv,k2e) - implicit none - integer kw - real*8 mass,mt,mc,lum,rad,rc,aj,tm - real*8 k2e,menv,menvg,menvt,menvz,renv,renvg,renvt,renvz - real*8 A,B,C,D,E,F,x,y - real*8 k2bgb,k2g,k2z,logm,logmt,lbgb,ltms,lhei,rg,rtms,rzams - real*8 teff,tebgb,tetms,tau,tauenv,tautms -* -* A function to estimate the mass and radius of the convective envelope, -* as well as the gyration radius of the envelope. -* N.B. Valid only for Z=0.02! -* -* The following input is needed from HRDIAG: -* kw = stellar type -* mass = zero-age stellar mass -* mt = actual mass -* mc = core mass (not really needed, can also be done outside subroutine) -* lum = luminosity -* rad = radius -* rc = core radius (not really needed...) -* aj = age -* tm = main-sequence lifetime -* ltms = luminosity at TMS, lums(2) -* lbgb = luminosity at BGB, lums(3) -* lhei = luminosity at He ignition, lums(4) -* rzams = radius at ZAMS -* rtms = radius at TMS -* rg = giant branch or Hayashi track radius, approporaite for the type. -* For kw=1 or 2 this is radius at BGB, and for kw=4 either GB or -* AGB radius at present luminosity. -* - logm = log10(mass) - A = MIN(0.81d0,MAX(0.68d0,0.68d0+0.4d0*logm)) - C = MAX(-2.5d0,MIN(-1.5d0,-2.5d0+5.d0*logm)) - D = -0.1d0 - E = 0.025d0 -* -* Zero-age and BGB values of k^2. -* - k2z = MIN(0.21d0,MAX(0.09d0-0.27d0*logm,0.037d0+0.033d0*logm)) - if(logm.gt.1.3d0) k2z = k2z - 0.055d0*(logm-1.3d0)**2 - k2bgb = MIN(0.15d0,MIN(0.147d0+0.03d0*logm,0.162d0-0.04d0*logm)) -* - if(kw.ge.3.and.kw.le.6)then -* -* Envelope k^2 for giant-like stars; this will be modified for non-giant -* CHeB stars or small envelope mass below. -* Formula is fairly accurate for both FGB and AGB stars if M <= 10, and -* gives reasonable values for higher masses. Mass dependence is on actual -* rather than ZA mass, expected to work for mass-losing stars (but not -* tested!). The slightly complex appearance is to insure continuity at -* the BGB, which depends on the ZA mass. -* - logmt = log10(mt) - F = 0.208d0 + 0.125d0*logmt - 0.035d0*logmt**2 - B = 1.0d+04*mt**(3.d0/2.d0)/(1.d0+0.1d0*mt**(3.d0/2.d0)) - x = ((lum-lbgb)/B)**2 - y = (F - 0.033d0*log10(lbgb))/k2bgb - 1.d0 - k2g = (F - 0.033d0*log10(lum) + 0.4d0*x)/(1.d0+y*(lbgb/lum)+x) - elseif(kw.eq.9)then -* -* Rough fit for for HeGB stars... -* - B = 3.0d+04*mt**(3.d0/2.d0) - x = (MAX(0.d0,lum/B-0.5d0))**2 - k2g = (k2bgb + 0.4d0*x)/(1.d0 + 0.4d0*x) - else - k2g = k2bgb - endif -* - if(kw.le.2)then - menvg = 0.5d0 - renvg = 0.65d0 - elseif(kw.eq.3.and.lum.lt.3.d0*lbgb)then -* -* FGB stars still close to the BGB do not yet have a fully developed CE. -* - x = MIN(3.d0,lhei/lbgb) - tau = MAX(0.d0,MIN(1.d0,(x-lum/lbgb)/(x-1.d0))) - menvg = 1.d0 - 0.5d0*tau**2 - renvg = 1.d0 - 0.35d0*tau**2 - else - menvg = 1.d0 - renvg = 1.d0 - endif -* - if(rad.lt.rg)then -* -* Stars not on the Hayashi track: MS and HG stars, non-giant CHeB stars, -* HeMS and HeHG stars, as well as giants with very small envelope mass. -* - - if(kw.le.6)then -* -* Envelope k^2 fitted for MS and HG stars. -* Again, pretty accurate for M <= 10 but less so for larger masses. -* [Note that this represents the whole star on the MS, so there is a -* discontinuity in stellar k^2 between MS and HG - okay for stars with a -* MS hook but low-mass stars should preferably be continous...] -* -* For other types of star not on the Hayashi track we use the same fit as -* for HG stars, this is not very accurate but has the correct qualitative -* behaviour. For CheB stars this is an overestimate because they appear -* to have a more centrally concentrated envelope than HG stars. -* - k2e = (k2z-E)*(rad/rzams)**C + E*(rad/rzams)**D - elseif(kw.eq.7)then -* Rough fit for naked He MS stars. - tau = aj/tm - k2e = 0.08d0 - 0.03d0*tau - elseif(kw.le.9)then -* Rough fit for HeHG stars. - k2e = 0.08d0*rzams/rad - endif -* -* tauenv measures proximity to the Hayashi track in terms of Teff. -* If tauenv>0 then an appreciable convective envelope is present, and -* k^2 needs to be modified. -* - if(kw.le.2)then - teff = sqrt(sqrt(lum)/rad) - tebgb = sqrt(sqrt(lbgb)/rg) - tauenv = MAX(0.d0,MIN(1.d0,(tebgb/teff-A)/(1.d0-A))) - else - tauenv = MAX(0.d0,MIN(1.d0,(sqrt(rad/rg)-A)/(1.d0-A))) - endif -* - if(tauenv.gt.0.d0)then - menv = menvg*tauenv**5 - renv = renvg*tauenv**(5.d0/4.d0) - if(kw.le.1)then -* Zero-age values for CE mass and radius. - x = MAX(0.d0,MIN(1.d0,(0.1d0-logm)/0.55d0)) - menvz = 0.18d0*x + 0.82d0*x**5 - renvz = 0.4d0*x**(1.d0/4.d0) + 0.6d0*x**10 - y = 2.d0 + 8.d0*x -* Values for CE mass and radius at start of the HG. - tetms = sqrt(sqrt(ltms)/rtms) - tautms = MAX(0.d0,MIN(1.d0,(tebgb/tetms-A)/(1.d0-A))) - menvt = menvg*tautms**5 - renvt = renvg*tautms**(5.d0/4.d0) -* Modified expressions during MS evolution. - tau = aj/tm - if(tautms.gt.0.d0)then - menv = menvz + tau**y*menv*(menvt - menvz)/menvt - renv = renvz + tau**y*renv*(renvt - renvz)/renvt - else - menv = 0.d0 - renv = 0.d0 - endif - k2e = k2e + tau**y*tauenv**3*(k2g - k2e) - else - k2e = k2e + tauenv**3*(k2g - k2e) - endif - else - menv = 0.d0 - renv = 0.d0 - endif - else -* -* All other stars should be true giants. -* - menv = menvg - renv = renvg - k2e = k2g - endif -* - menv = menv*(mt - mc) - renv = renv*(rad - rc) - menv = MAX(menv,1.0d-10) - renv = MAX(renv,1.0d-10) -* - return - end -*** - - -cc//ran3.f - -*** - REAL FUNCTION ran3(IDUM) -* -* Random number generator from Numerical Recipes, Press et al. pg 272. -* - IMPLICIT NONE - INTEGER j,k,im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv - PARAMETER(im1=2147483563,im2=2147483399,ia1=40014,ia2=40692) - PARAMETER(iq1=53668,iq2=52774,ir1=12211,ir2=3791,ntab=32) - INTEGER idum - INTEGER idum2,iy,ir(ntab) - COMMON /RAND3/ idum2,iy,ir - DATA idum2/123456789/, iy/0/, ir/ntab*0/ - REAL am -* - am = 1.0/float(im1) - imm1 = im1 - 1 - ndiv = 1 + imm1/ntab -* - if(idum.le.0)then - idum = MAX(-idum,1) - idum2 = idum - do 11 , j = ntab+8,1,-1 - k = idum/iq1 - idum = ia1*(idum-k*iq1)-k*ir1 - if(idum.lt.0) idum = idum + im1 - if(j.le.ntab) ir(j) = idum - 11 continue - iy = ir(1) - endif - k = idum/iq1 - idum = ia1*(idum-k*iq1)-k*ir1 - if(idum.lt.0) idum = idum + im1 - k = idum2/iq2 - idum2 = ia2*(idum2-k*iq2)-k*ir2 - if(idum2.lt.0) idum2 = idum2 + im2 - j = 1 + iy/ndiv - iy = ir(j) - idum2 - ir(j) = idum - if(iy.lt.1) iy = iy + imm1 - ran3 = am*iy -* - RETURN - END -*** - - - -cc//star.f - -*** - SUBROUTINE star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars) -* -* -* Stellar luminosity & evolution time. -* ------------------------------------ -* - implicit none -* - integer kw -* - real*8 mass,mt,tm,tn,tscls(20),lums(10),GB(10),zpars(20) - real*8 tgb,tbagb,mch,mcmax,mc1,mc2,mcbagb,dx,am - real*8 lambda,tau,mtc,mass0 - parameter(mch=1.44d0) -* - real*8 lzamsf,lzahbf,lzhef - real*8 tbgbf,thookf,tHef,themsf,mcgbf,mcagbf,mcheif,mcgbtf - real*8 ltmsf,lbgbf,lHeIf,lHef,lbagbf,lmcgbf - external lzamsf,lzahbf,lzhef - external tbgbf,thookf,tHef,themsf,mcgbf,mcagbf,mcheif,mcgbtf - external ltmsf,lbgbf,lHeIf,lHef,lbagbf,lmcgbf -* -* Computes the characteristic luminosities at different stages (LUMS), -* and various timescales (TSCLS). -* Ref: P.P. Eggleton, M.J. Fitchett & C.A. Tout (1989) Ap.J. 347, 998. -* -* Revised 27th March 1995 by C. A. Tout -* and 24th October 1995 to include metallicity -* and 13th December 1996 to include naked helium stars -* -* Revised 5th April 1997 by J. R. Hurley -* to include Z=0.001 as well as Z=0.02, convective overshooting, -* MS hook and more elaborate CHeB. It now also sets the Giant -* Branch parameters relevant to the mass of the star. -* -* ------------------------------------------------------------ -* Times: 1; BGB 2; He ignition 3; He burning -* 4; Giant t(inf1) 5; Giant t(inf2) 6; Giant t(Mx) -* 7; FAGB t(inf1) 8; FAGB t(inf2) 9; FAGB t(Mx) -* 10; SAGB t(inf1) 11; SAGB t(inf2) 12; SAGB t(Mx) -* 13; TP 14; t(Mcmax) -* -* LUMS: 1; ZAMS 2; End MS 3; BGB -* 4; He ignition 5; He burning 6; L(Mx) -* 7; BAGB 8; TP -* -* GB: 1; effective A(H) 2; A(H,He) 3; B -* 4; D 5; p 6; q -* 7; Mx 8; A(He) 9; Mc,BGB -* -* ------------------------------------------------------------ -* -* - mass0 = mass - if(mass0.gt.100.d0) mass = 100.d0 -* - if(kw.ge.7.and.kw.le.9) goto 90 - if(kw.ge.10) goto 95 -* -* MS and BGB times -* - tscls(1) = tbgbf(mass) - tm = MAX(zpars(8),thookf(mass))*tscls(1) -* -* Zero- and terminal age main sequence luminosity -* - lums(1) = lzamsf(mass) - lums(2) = ltmsf(mass) -* -* Set the GB parameters -* - GB(1) = MAX(-4.8d0,MIN(-5.7d0+0.8d0*mass,-4.1d0+0.14d0*mass)) - GB(1) = 10.d0**GB(1) - GB(2) = 1.27d-05 - GB(8) = 8.0d-05 - GB(3) = MAX(3.0d+04,500.d0 + 1.75d+04*mass**0.6d0) - if(mass.le.2.0)then - GB(4) = zpars(6) - GB(5) = 6.d0 - GB(6) = 3.d0 - elseif(mass.lt.2.5)then - dx = zpars(6) - (0.975d0*zpars(6) - 0.18d0*2.5d0) - GB(4) = zpars(6) - dx*(mass - 2.d0)/(0.5d0) - GB(5) = 6.d0 - (mass - 2.d0)/(0.5d0) - GB(6) = 3.d0 - (mass - 2.d0)/(0.5d0) - else - GB(4) = MAX(-1.d0,0.5d0*zpars(6) - 0.06d0*mass) - GB(4) = MAX(GB(4),0.975d0*zpars(6) - 0.18d0*mass) - GB(5) = 5.d0 - GB(6) = 2.d0 - endif - GB(4) = 10.d0**GB(4) - GB(7) = (GB(3)/GB(4))**(1.d0/(GB(5)-GB(6))) -* -* Change in slope of giant L-Mc relation. - lums(6) = GB(4)*GB(7)**GB(5) -* -* HeI ignition luminosity - lums(4) = lHeIf(mass,zpars(2)) - lums(7) = lbagbf(mass,zpars(2)) -* - if(mass.lt.0.1d0.and.kw.le.1)then - tscls(2) = 1.1d0*tscls(1) - tscls(3) = 0.1d0*tscls(1) - lums(3) = lbgbf(mass) - goto 96 - endif -* - if(mass.le.zpars(3))then -* Base of the giant branch luminosity - lums(3) = lbgbf(mass) -* Set GB timescales - tscls(4) = tscls(1) + (1.d0/((GB(5)-1.d0)*GB(1)*GB(4)))* - & ((GB(4)/lums(3))**((GB(5)-1.d0)/GB(5))) - tscls(6) = tscls(4) - (tscls(4) - tscls(1))*((lums(3)/lums(6)) - & **((GB(5)-1.d0)/GB(5))) - tscls(5) = tscls(6) + (1.d0/((GB(6)-1.d0)*GB(1)*GB(3)))* - & ((GB(3)/lums(6))**((GB(6)-1.d0)/GB(6))) -* Set Helium ignition time - if(lums(4).le.lums(6))then - tscls(2) = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(1)*GB(4)))* - & ((GB(4)/lums(4))**((GB(5)-1.d0)/GB(5))) - else - tscls(2) = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(1)*GB(3)))* - & ((GB(3)/lums(4))**((GB(6)-1.d0)/GB(6))) - endif - tgb = tscls(2) - tscls(1) - if(mass.le.zpars(2))then - mc1 = mcgbf(lums(4),GB,lums(6)) - mc2 = mcagbf(mass) - lums(5) = lzahbf(mass,mc1,zpars(2)) - tscls(3) = tHef(mass,mc1,zpars(2)) - else - lums(5) = lHef(mass)*lums(4) - tscls(3) = tHef(mass,1.d0,zpars(2))*tscls(1) - endif - else -* Note that for M>zpars(3) there is no GB as the star goes from -* HG -> CHeB -> AGB. So in effect tscls(1) refers to the time of -* Helium ignition and not the BGB. - tscls(2) = tscls(1) - tscls(3) = tHef(mass,1.d0,zpars(2))*tscls(1) -* This now represents the luminosity at the end of CHeB, ie. BAGB - lums(5) = lums(7) -* We set lums(3) to be the luminosity at the end of the HG - lums(3) = lums(4) - endif -* -* Set the core mass at the BGB. -* - if(mass.le.zpars(2))then - GB(9) = mcgbf(lums(3),GB,lums(6)) - elseif(mass.le.zpars(3))then - GB(9) = mcheif(mass,zpars(2),zpars(9)) - else - GB(9) = mcheif(mass,zpars(2),zpars(10)) - endif -* -* FAGB time parameters -* - tbagb = tscls(2) + tscls(3) - tscls(7) = tbagb + (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))* - & ((GB(4)/lums(7))**((GB(5)-1.d0)/GB(5))) - tscls(9) = tscls(7) - (tscls(7) - tbagb)*((lums(7)/lums(6)) - & **((GB(5)-1.d0)/GB(5))) - tscls(8) = tscls(9) + (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))* - & ((GB(3)/lums(6))**((GB(6)-1.d0)/GB(6))) -* -* Now to find Ltp and ttp using Mc,He,tp -* - mcbagb = mcagbf(mass) - mc1 = mcbagb - if(mc1.ge.0.8d0.and.mc1.lt.2.25d0)then -* The star undergoes dredge-up at Ltp causing a decrease in Mc,He - mc1 = 0.44d0*mc1 + 0.448d0 - endif - lums(8) = lmcgbf(mc1,GB) - if(mc1.le.GB(7))then - tscls(13) = tscls(7) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))* - & (mc1**(1.d0-GB(5))) - else - tscls(13) = tscls(8) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))* - & (mc1**(1.d0-GB(6))) - endif -* -* SAGB time parameters -* - if(mc1.le.GB(7))then - tscls(10) = tscls(13) + (1.d0/((GB(5)-1.d0)*GB(2)*GB(4)))* - & ((GB(4)/lums(8))**((GB(5)-1.d0)/GB(5))) - tscls(12) = tscls(10) - (tscls(10) - tscls(13))* - & ((lums(8)/lums(6))**((GB(5)-1.d0)/GB(5))) - tscls(11) = tscls(12) + (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))* - & ((GB(3)/lums(6))**((GB(6)-1.d0)/GB(6))) - else - tscls(10) = tscls(7) - tscls(12) = tscls(9) - tscls(11) = tscls(13) + (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))* - & ((GB(3)/lums(8))**((GB(6)-1.d0)/GB(6))) - endif -* -* Get an idea of when Mc,C = Mc,C,max on the AGB - tau = tscls(2) + tscls(3) - mc2 = mcgbtf(tau,GB(8),GB,tscls(7),tscls(8),tscls(9)) - mcmax = MAX(MAX(mch,0.773d0*mcbagb - 0.35d0),1.05d0*mc2) -* - if(mcmax.le.mc1)then - if(mcmax.le.GB(7))then - tscls(14) = tscls(7) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))* - & (mcmax**(1.d0-GB(5))) - else - tscls(14) = tscls(8) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))* - & (mcmax**(1.d0-GB(6))) - endif - else -* Star is on SAGB and we need to increase mcmax if any 3rd -* dredge-up has occurred. - lambda = MIN(0.9d0,0.3d0+0.001d0*mass**5) - mcmax = (mcmax - lambda*mc1)/(1.d0 - lambda) - if(mcmax.le.GB(7))then - tscls(14) = tscls(10) - (1.d0/((GB(5)-1.d0)*GB(2)*GB(4)))* - & (mcmax**(1.d0-GB(5))) - else - tscls(14) = tscls(11) - (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))* - & (mcmax**(1.d0-GB(6))) - endif - endif - tscls(14) = MAX(tbagb,tscls(14)) - if(mass.ge.100.d0)then - tn = tscls(2) - goto 100 - endif -* -* Calculate the nuclear timescale - the time of exhausting -* nuclear fuel without further mass loss. -* This means we want to find when Mc = Mt which defines Tn and will -* be used in determining the timestep required. Note that after some -* stars reach Mc = Mt there will be a Naked Helium Star lifetime -* which is also a nuclear burning period but is not included in Tn. -* - if(ABS(mt-mcbagb).lt.1.0d-14.and.kw.lt.5)then - tn = tbagb - else -* Note that the only occurence of Mc being double-valued is for stars -* that have a dredge-up. If Mt = Mc where Mc could be the value taken -* from CHeB or from the AGB we need to check the current stellar type. - if(mt.gt.mcbagb.or.(mt.ge.mc1.and.kw.gt.4))then - if(kw.eq.6)then - lambda = MIN(0.9d0,0.3d0+0.001d0*mass**5) - mc1 = (mt - lambda*mc1)/(1.d0 - lambda) - else - mc1 = mt - endif - if(mc1.le.GB(7))then - tn = tscls(10) - (1.d0/((GB(5)-1.d0)*GB(2)*GB(4)))* - & (mc1**(1.d0-GB(5))) - else - tn = tscls(11) - (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))* - & (mc1**(1.d0-GB(6))) - endif - else - if(mass.gt.zpars(3))then - mc1 = mcheif(mass,zpars(2),zpars(10)) - if(mt.le.mc1)then - tn = tscls(2) - else - tn = tscls(2) + tscls(3)*((mt - mc1)/(mcbagb - mc1)) - endif - elseif(mass.le.zpars(2))then - mc1 = mcgbf(lums(3),GB,lums(6)) - mc2 = mcgbf(lums(4),GB,lums(6)) - if(mt.le.mc1)then - tn = tscls(1) - elseif(mt.le.mc2)then - if(mt.le.GB(7))then - tn = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(1)*GB(4)))* - & (mt**(1.d0-GB(5))) - else - tn = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(1)*GB(3)))* - & (mt**(1.d0-GB(6))) - endif - else - tn = tscls(2) + tscls(3)*((mt - mc2)/(mcbagb - mc2)) - endif - else - mc1 = mcheif(mass,zpars(2),zpars(9)) - mc2 = mcheif(mass,zpars(2),zpars(10)) - if(mt.le.mc1)then - tn = tscls(1) - elseif(mt.le.mc2)then - tn = tscls(1) + tgb*((mt - mc1)/(mc2 - mc1)) - else - tn = tscls(2) + tscls(3)*((mt - mc2)/(mcbagb - mc2)) - endif - endif - endif - endif - tn = MIN(tn,tscls(14)) -* - goto 100 -* - 90 continue -* -* Calculate Helium star Main Sequence lifetime. -* - tm = themsf(mass) - tscls(1) = tm -* -* Zero- and terminal age Helium star main sequence luminosity -* - lums(1) = lzhef(mass) - am = MAX(0.d0,0.85d0-0.08d0*mass) - lums(2) = lums(1)*(1.d0+0.45d0+am) -* -* Set the Helium star GB parameters -* - GB(8) = 8.0d-05 - GB(3) = 4.1d+04 - GB(4) = 5.5d+04/(1.d0+0.4d0*mass**4) - GB(5) = 5.d0 - GB(6) = 3.d0 - GB(7) = (GB(3)/GB(4))**(1.d0/(GB(5)-GB(6))) -* Change in slope of giant L-Mc relation. - lums(6) = GB(4)*GB(7)**GB(5) -* -*** Set Helium star GB timescales -* - mc1 = mcgbf(lums(2),GB,lums(6)) - tscls(4) = tm + (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))* - & mc1**(1.d0-GB(5)) - tscls(6) = tscls(4) - (tscls(4) - tm)*((GB(7)/mc1) - & **(1.d0-GB(5))) - tscls(5) = tscls(6) + (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))* - & GB(7)**(1.d0-GB(6)) -* -* Get an idea of when Mc = MIN(Mt,Mc,C,max) on the GB - mtc = MIN(mt,1.45d0*mt-0.31d0) - if(mtc.le.0.d0) mtc = mt - mcmax = MIN(mtc,MAX(mch,0.773d0*mass-0.35d0)) - if(mcmax.le.GB(7))then - tscls(14) = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))* - & (mcmax**(1.d0-GB(5))) - else - tscls(14) = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))* - & (mcmax**(1.d0-GB(6))) - endif - tscls(14) = MAX(tscls(14),tm) - tn = tscls(14) -* - goto 100 -* - 95 continue - tm = 1.0d+10 - tscls(1) = tm - 96 continue - tn = 1.0d+10 -* - 100 continue - mass = mass0 -* - return - end -*** - - -cc//zcnsts.f - -*** - SUBROUTINE zcnsts(z,zpars) -* - implicit none - integer kw -* - real*8 z,zpars(20) - real*8 tm,tn,tscls(20),lums(10),GB(10) - real*8 lzs,dlzs,lz,lzd,dum1,m1,m2,rr,rb,mhefl,lhefl,thefl,lx - real*8 tbgbf,thef,lbagbf,lheif,lhef,lzahbf - real*8 rgbf,ragbf,rminf,mcgbf - external tbgbf,thef,lbagbf,lheif,lhef,lzahbf - external rgbf,ragbf,rminf,mcgbf -* -cc// include 'zdata.h' - -* -* Initialization data set for fitting formulae. -* ----------------------------------------------------------- -* - real*8 xz(76),xt(31),xl(72),xr(119),xg(112),xh(99) -* -* data for Lzams(1->35) and Rzams(36->76) -* - data xz / - & 3.970417d-01, -3.2913574d-01, 3.4776688d-01, 3.7470851d-01, - & 9.011915d-02, - & 8.527626d+00,-2.441225973d+01, 5.643597107d+01, 3.706152575d+01, - & 5.4562406d+00, - & 2.5546d-04, -1.23461d-03, -2.3246d-04, 4.5519d-04, - & 1.6176d-04, - & 5.432889d+00, -8.62157806d+00, 1.344202049d+01, - & 1.451584135d+01, 3.39793084d+00, - & 5.563579d+00,-1.032345224d+01, 1.944322980d+01, - & 1.897361347d+01, 4.16903097d+00, - & 7.8866060d-01, -2.90870942d+00, 6.54713531d+00, - & 4.05606657d+00, 5.3287322d-01, - & 5.86685d-03, -1.704237d-02, 3.872348d-02, 2.570041d-02, - & 3.83376d-03, - & 1.715359d+00, 6.2246212d-01, -9.2557761d-01, -1.16996966d+00, - & -3.0631491d-01, - & 6.597788d+00, -4.2450044d-01,-1.213339427d+01,-1.073509484d+01, - & -2.51487077d+00, - & 1.008855000d+01, -7.11727086d+00,-3.167119479d+01, - & -2.424848322d+01,-5.33608972d+00, - & 1.012495d+00, 3.2699690d-01, -9.23418d-03, -3.876858d-02, - & -4.12750d-03, - & 7.490166d-02, 2.410413d-02, 7.233664d-02, 3.040467d-02, - & 1.97741d-03, 1.077422d-02, - & 3.082234d+00, 9.447205d-01, -2.15200882d+00, -2.49219496d+00, - & -6.3848738d-01, - & 1.784778d+01, -7.4534569d+00,-4.896066856d+01,-4.005386135d+01, - & -9.09331816d+00, - & 2.2582d-04, -1.86899d-03, 3.88783d-03, 1.42402d-03,-7.671d-05/ -* -* data for Tbgb(1->17) and Thook(18->31) -* - data xt /1.593890d+03, 2.053038d+03, 1.231226d+03, - & 2.327785d+02, 2.706708d+03, 1.483131d+03, - & 5.772723d+02, 7.411230d+01, 1.466143d+02, - & -1.048442d+02,-6.795374d+01,-1.391127d+01, - & 4.141960d-02, 4.564888d-02, 2.958542d-02, - & 5.571483d-03, 3.426349d-01, - & 1.949814d+01, 1.758178d+00,-6.008212d+00, - & -4.470533d+00, 4.903830d+00, 5.212154d-02, - & 3.166411d-02,-2.750074d-03,-2.271549d-03, - & 1.312179d+00,-3.294936d-01, 9.231860d-02, - & 2.610989d-02, 8.073972d-01/ -* -* data for Ltms(1->27), Lalpha(28->43), Lbeta(44->56) and Lhook(57->72) -* - data xl /1.031538d+00,-2.434480d-01, 7.732821d+00, - & 6.460705d+00, 1.374484d+00, 1.043715d+00, - & -1.577474d+00,-5.168234d+00,-5.596506d+00, - & -1.299394d+00, 7.859573d+02,-8.542048d+00, - & -2.642511d+01,-9.585707d+00, 3.858911d+03, - & 2.459681d+03,-7.630093d+01,-3.486057d+02, - & -4.861703d+01, 2.888720d+02, 2.952979d+02, - & 1.850341d+02, 3.797254d+01, 7.196580d+00, - & 5.613746d-01, 3.805871d-01, 8.398728d-02, - & 2.321400d-01, 1.828075d-03,-2.232007d-02, - & -3.378734d-03, 1.163659d-02, 3.427682d-03, - & 1.421393d-03,-3.710666d-03, 1.048020d-02, - & -1.231921d-02,-1.686860d-02,-4.234354d-03, - & 1.555590d+00,-3.223927d-01,-5.197429d-01, - & -1.066441d-01, - & 3.855707d-01,-6.104166d-01, 5.676742d+00, - & 1.060894d+01, 5.284014d+00, 3.579064d-01, - & -6.442936d-01, 5.494644d+00, 1.054952d+01, - & 5.280991d+00, 9.587587d-01, 8.777464d-01, - & 2.017321d-01, - & 1.910302d-01, 1.158624d-01, 3.348990d-02, - & 2.599706d-03, 3.931056d-01, 7.277637d-02, - & -1.366593d-01,-4.508946d-02, 3.267776d-01, - & 1.204424d-01, 9.988332d-02, 2.455361d-02, - & 5.990212d-01, 5.570264d-02, 6.207626d-02, - & 1.777283d-02/ -* -* data for Rtms(1->40), Ralpha(41->64), Rbeta(65->83), Rgamma(84->103) -* and Rhook(104->119) -* - data xr /2.187715d-01,-2.154437d+00,-3.768678d+00, - & -1.975518d+00,-3.021475d-01, 1.466440d+00, - & 1.839725d+00, 6.442199d+00, 4.023635d+00, - & 6.957529d-01, 2.652091d+01, 8.178458d+01, - & 1.156058d+02, 7.633811d+01, 1.950698d+01, - & 1.472103d+00,-2.947609d+00,-3.312828d+00, - & -9.945065d-01, 3.071048d+00,-5.679941d+00, - & -9.745523d+00,-3.594543d+00,-8.672073d-02, - & 2.617890d+00, 1.019135d+00,-3.292551d-02, - & -7.445123d-02, 1.075567d-02, 1.773287d-02, - & 9.610479d-03, 1.732469d-03, 1.476246d+00, - & 1.899331d+00, 1.195010d+00, 3.035051d-01, - & 5.502535d+00,-6.601663d-02, 9.968707d-02, - & 3.599801d-02, - & 4.907546d-01,-1.683928d-01,-3.108742d-01, - & -7.202918d-02, 4.537070d+00,-4.465455d+00, - & -1.612690d+00,-1.623246d+00, 1.796220d+00, - & 2.814020d-01, 1.423325d+00, 3.421036d-01, - & 2.256216d+00, 3.773400d-01, 1.537867d+00, - & 4.396373d-01, 1.564231d-03, 1.653042d-03, - & -4.439786d-03,-4.951011d-03,-1.216530d-03, - & 5.210157d+00,-4.143695d+00,-2.120870d+00, - & 1.071489d+00,-1.164852d-01,-8.623831d-02, - & -1.582349d-02, 7.108492d-01, 7.935927d-01, - & 3.926983d-01, 3.622146d-02, 3.478514d+00, - & -2.585474d-02,-1.512955d-02,-2.833691d-03, - & 3.969331d-03, 4.539076d-03, 1.720906d-03, - & 1.897857d-04, 9.132108d-01,-1.653695d-01, - & 3.636784d-02, - & 1.192334d-02, 1.083057d-02, 1.230969d+00, - & 1.551656d+00,-1.668868d-01, 5.818123d-01, - & -1.105027d+01,-1.668070d+01, 7.615495d-01, - & 1.068243d-01,-2.011333d-01,-9.371415d-02, - & -1.015564d-01,-2.161264d-01,-5.182516d-02, - & -3.868776d-01,-5.457078d-01,-1.463472d-01, - & 9.409838d+00, 1.522928d+00, - & 7.330122d-01, 5.192827d-01, 2.316416d-01, - & 8.346941d-03, 1.172768d+00,-1.209262d-01, - & -1.193023d-01,-2.859837d-02, 3.982622d-01, - & -2.296279d-01,-2.262539d-01,-5.219837d-02, - & 3.571038d+00,-2.223625d-02,-2.611794d-02, - & -6.359648d-03/ -* -* data for Lbgb(1->24), Lbagb(25->44), Rgb(45->66), Ragb(67->100), -* Mchei(101->102) and Mcbagb(103->112) -* - data xg /9.511033d+01, 6.819618d+01,-1.045625d+01, - & -1.474939d+01, 3.113458d+01, 1.012033d+01, - & -4.650511d+00,-2.463185d+00, 1.413057d+00, - & 4.578814d-01,-6.850581d-02,-5.588658d-02, - & 3.910862d+01, 5.196646d+01, 2.264970d+01, - & 2.873680d+00, 4.597479d+00,-2.855179d-01, - & 2.709724d-01, 6.682518d+00, 2.827718d-01, - & -7.294429d-02, 4.637345d+00, 9.301992d+00, - & 1.626062d+02,-1.168838d+01,-5.498343d+00, - & 3.336833d-01,-1.458043d-01,-2.011751d-02, - & 7.425137d+01, 1.790236d+01, 3.033910d+01, - & 1.018259d+01, 9.268325d+02,-9.739859d+01, - & -7.702152d+01,-3.158268d+01, 1.127018d+01, - & 1.622158d+00,-1.443664d+00,-9.474699d-01, - & 2.474401d+00, 3.892972d-01, - & 9.960283d-01, 8.164393d-01, 2.383830d+00, - & 2.223436d+00, 8.638115d-01, 1.231572d-01, - & 2.561062d-01, 7.072646d-02,-5.444596d-02, - & -5.798167d-02,-1.349129d-02, 1.157338d+00, - & 1.467883d+00, 4.299661d+00, 3.130500d+00, - & 6.992080d-01, 1.640687d-02, 4.022765d-01, - & 3.050010d-01, 9.962137d-01, 7.914079d-01, - & 1.728098d-01, - & 1.125124d+00, 1.306486d+00, 3.622359d+00, - & 2.601976d+00, 3.031270d-01,-1.343798d-01, - & 3.349489d-01, 4.531269d-03, 1.131793d-01, - & 2.300156d-01, 7.632745d-02, 1.467794d+00, - & 2.798142d+00, 9.455580d+00, 8.963904d+00, - & 3.339719d+00, 4.426929d-01, 4.658512d-01, - & 2.597451d-01, 9.048179d-01, 7.394505d-01, - & 1.607092d-01, 1.110866d+00, 9.623856d-01, - & 2.735487d+00, 2.445602d+00, 8.826352d-01, - & 1.140142d-01,-1.584333d-01,-1.728865d-01, - & -4.461431d-01,-3.925259d-01,-1.276203d-01, - & -1.308728d-02, - & 9.796164d-02, 1.350554d+00, - & 1.445216d-01,-6.180219d-02, 3.093878d-02, - & 1.567090d-02, 1.304129d+00, 1.395919d-01, - & 4.142455d-03,-9.732503d-03, 5.114149d-01, - & -1.160850d-02/ -* -* data for Lhei(1->14), Lhe(15->25) Rmin(26->43), The(44->65), -* Tbl(66->79), Lzahb(80->87) and Rzahb(88->99) -* - data xh /2.751631d+03, 3.557098d+02, - & -3.820831d-02, 5.872664d-02, 1.5d+01, - & 1.071738d+02,-8.970339d+01,-3.949739d+01, - & 7.348793d+02,-1.531020d+02,-3.793700d+01, - & 9.219293d+00,-2.005865d+00,-5.561309d-01, - & 2.917412d+00, 1.575290d+00, 5.751814d-01, - & 6.371760d-01, 3.880523d-01, 4.916389d+00, - & 2.862149d+00, 7.844850d-01, 3.629118d+00, - & -9.112722d-01, 1.042291d+00, - & 1.609901d+01, 7.391573d+00, 2.277010d+01, - & 8.334227d+00, 1.747500d-01, 6.271202d-02, - & -2.324229d-02,-1.844559d-02, 2.752869d+00, - & 2.729201d-02, 4.996927d-01, 2.496551d-01, - & -9.138012d-02,-3.671407d-01, 3.518506d+00, - & 1.112440d+00,-4.556216d-01,-2.179426d-01, - & 1.314955d+02, 2.009258d+01,-5.143082d-01, - & -1.379140d+00, 1.823973d+01,-3.074559d+00, - & -4.307878d+00, 1.5d1, - & 2.327037d+00, 2.403445d+00, 1.208407d+00, - & 2.087263d-01, 1.079113d-01, 1.762409d-02, - & 1.096601d-02, 3.058818d-03, 2.327409d+00, - & 6.901582d-01,-2.158431d-01,-1.084117d-01, - & 1.997378d+00,-8.126205d-01, - & 2.214315d+00,-1.975747d+00, 4.805428d-01, - & 2.471620d+00,-5.401682d+00, 3.247361d+00, - & 5.072525d+00, 1.146189d+01, 6.961724d+00, - & 1.316965d+00, 5.139740d+00, 1.127733d+00, - & 2.344416d-01,-3.793726d-01, - & 5.496045d+01,-1.289968d+01, 6.385758d+00, - & 1.832694d+00,-5.766608d-02, 5.696128d-02, - & 1.211104d+02, 1.647903d+00, - & 2.063983d+00, 7.363827d-01, 2.654323d-01, - & -6.140719d-02, 2.214088d+02, 2.187113d+02, - & 1.170177d+01,-2.635340d+01, 2.003160d+00, - & 9.388871d-01, 9.656450d-01, 2.362266d-01/ -* -*** - - real*8 msp(200),gbp(200),c(5) - common /MSCFF/ msp - common /GBCFF/ gbp - data c /3.040581d-01, 8.049509d-02, 8.967485d-02, - & 8.780198d-02, 2.219170d-02/ -* -* ------------------------------------------------------------ -* -* zpars: 1; M below which hook doesn't appear on MS, Mhook. -* 2; M above which He ignition occurs non-degenerately, Mhef. -* 3; M above which He ignition occurs on the HG, Mfgb. -* 4; M below which C/O ignition doesn't occur, Mup. -* 5; M above which C ignites in the centre, Mec. -* 6; value of log D for M<= zpars(3) -* 7; value of x for Rgb propto M^(-x) -* 8; value of x for tMS = MAX(tHOOK,x*tBGB) -* 9; constant for McHeIf when computing Mc,BGB, mchefl. -* 10; constant for McHeIf when computing Mc,HeI, mchefl. -* 11; hydrogen abundance. -* 12; helium abundance. -* 13; constant x in rmin = rgb*x**y used by LM CHeB. -* 14; z**0.4 to be used for WD L formula. -* -* ------------------------------------------------------------ -* - lzs = log10(z/0.02d0) - dlzs = 1.d0/(z*log(10.d0)) - lz = log10(z) - lzd = lzs + 1.d0 -* - zpars(1) = 1.0185d0 + lzs*(0.16015d0 + lzs*0.0892d0) - zpars(2) = 1.995d0 + lzs*(0.25d0 + lzs*0.087d0) - zpars(3) = 16.5d0*z**0.06d0/(1.d0 + (1.0d-04/z)**1.27d0) - zpars(4) = MAX(6.11044d0 + 1.02167d0*lzs, 5.d0) - zpars(5) = zpars(4) + 1.8d0 - zpars(6) = 5.37d0 + lzs*0.135d0 - zpars(7) = c(1) + lzs*(c(2) + lzs*(c(3) + lzs*(c(4) + lzs*c(5)))) - zpars(8) = MAX(0.95d0,MAX(0.95d0-(10.d0/3.d0)*(z-0.01d0), - & MIN(0.99d0,0.98d0-(100.d0/7.d0)*(z-0.001d0)))) -*** -* Lzams - msp(1) = xz(1)+lzs*(xz(2)+lzs*(xz(3)+lzs*(xz(4)+lzs*xz(5)))) - msp(2) = xz(6)+lzs*(xz(7)+lzs*(xz(8)+lzs*(xz(9)+lzs*xz(10)))) - msp(3) = xz(11)+lzs*(xz(12)+lzs*(xz(13)+lzs*(xz(14)+lzs*xz(15)))) - msp(4) = xz(16)+lzs*(xz(17)+lzs*(xz(18)+lzs*(xz(19)+lzs*xz(20)))) - msp(5) = xz(21)+lzs*(xz(22)+lzs*(xz(23)+lzs*(xz(24)+lzs*xz(25)))) - msp(6) = xz(26)+lzs*(xz(27)+lzs*(xz(28)+lzs*(xz(29)+lzs*xz(30)))) - msp(7) = xz(31)+lzs*(xz(32)+lzs*(xz(33)+lzs*(xz(34)+lzs*xz(35)))) -* Rzams - msp(8) = xz(36)+lzs*(xz(37)+lzs*(xz(38)+lzs*(xz(39)+lzs*xz(40)))) - msp(9) = xz(41)+lzs*(xz(42)+lzs*(xz(43)+lzs*(xz(44)+lzs*xz(45)))) - msp(10) = xz(46)+lzs*(xz(47)+lzs*(xz(48)+lzs*(xz(49)+lzs*xz(50)))) - msp(11) = xz(51)+lzs*(xz(52)+lzs*(xz(53)+lzs*(xz(54)+lzs*xz(55)))) - msp(12) = xz(56)+lzs*(xz(57)+lzs*(xz(58)+lzs*(xz(59)+lzs*xz(60)))) - msp(13) = xz(61) - msp(14) = xz(62)+lzs*(xz(63)+lzs*(xz(64)+lzs*(xz(65)+lzs*xz(66)))) - msp(15) = xz(67)+lzs*(xz(68)+lzs*(xz(69)+lzs*(xz(70)+lzs*xz(71)))) - msp(16) = xz(72)+lzs*(xz(73)+lzs*(xz(74)+lzs*(xz(75)+lzs*xz(76)))) -* Tbgb - msp(17) = xt(1)+lzs*(xt(2)+lzs*(xt(3)+lzs*xt(4))) - msp(18) = xt(5)+lzs*(xt(6)+lzs*(xt(7)+lzs*xt(8))) - msp(19) = xt(9)+lzs*(xt(10)+lzs*(xt(11)+lzs*xt(12))) - msp(20) = xt(13)+lzs*(xt(14)+lzs*(xt(15)+lzs*xt(16))) - msp(21) = xt(17) -* dTbgb/dz - msp(117) = dlzs*(xt(2)+lzs*(2.d0*xt(3)+3.d0*lzs*xt(4))) - msp(118) = dlzs*(xt(6)+lzs*(2.d0*xt(7)+3.d0*lzs*xt(8))) - msp(119) = dlzs*(xt(10)+lzs*(2.d0*xt(11)+3.d0*lzs*xt(12))) - msp(120) = dlzs*(xt(14)+lzs*(2.d0*xt(15)+3.d0*lzs*xt(16))) -* Thook - msp(22) = xt(18)+lzs*(xt(19)+lzs*(xt(20)+lzs*xt(21))) - msp(23) = xt(22) - msp(24) = xt(23)+lzs*(xt(24)+lzs*(xt(25)+lzs*xt(26))) - msp(25) = xt(27)+lzs*(xt(28)+lzs*(xt(29)+lzs*xt(30))) - msp(26) = xt(31) -* Ltms - msp(27) = xl(1)+lzs*(xl(2)+lzs*(xl(3)+lzs*(xl(4)+lzs*xl(5)))) - msp(28) = xl(6)+lzs*(xl(7)+lzs*(xl(8)+lzs*(xl(9)+lzs*xl(10)))) - msp(29) = xl(11)+lzs*(xl(12)+lzs*(xl(13)+lzs*xl(14))) - msp(30) = xl(15)+lzs*(xl(16)+lzs*(xl(17)+lzs*(xl(18)+lzs*xl(19)))) - msp(27) = msp(27)*msp(30) - msp(28) = msp(28)*msp(30) - msp(31) = xl(20)+lzs*(xl(21)+lzs*(xl(22)+lzs*xl(23))) - msp(32) = xl(24)+lzs*(xl(25)+lzs*(xl(26)+lzs*xl(27))) -* Lalpha - m2 = 2.d0 - msp(33) = xl(28)+lzs*(xl(29)+lzs*(xl(30)+lzs*xl(31))) - msp(34) = xl(32)+lzs*(xl(33)+lzs*(xl(34)+lzs*xl(35))) - msp(35) = xl(36)+lzs*(xl(37)+lzs*(xl(38)+lzs*xl(39))) - msp(36) = xl(40)+lzs*(xl(41)+lzs*(xl(42)+lzs*xl(43))) - msp(37) = MAX(0.9d0,1.1064d0+lzs*(0.415d0+0.18d0*lzs)) - msp(38) = MAX(1.d0,1.19d0+lzs*(0.377d0+0.176d0*lzs)) - if(z.gt.0.01d0)then - msp(37) = MIN(msp(37),1.d0) - msp(38) = MIN(msp(38),1.1d0) - endif - msp(39) = MAX(0.145d0,0.0977d0-lzs*(0.231d0+0.0753d0*lzs)) - msp(40) = MIN(0.24d0+lzs*(0.18d0+0.595d0*lzs),0.306d0+0.053d0*lzs) - msp(41) = MIN(0.33d0+lzs*(0.132d0+0.218d0*lzs), - & 0.3625d0+0.062d0*lzs) - msp(42) = (msp(33)+msp(34)*m2**msp(36))/ - & (m2**0.4d0+msp(35)*m2**1.9d0) -* Lbeta - msp(43) = xl(44)+lzs*(xl(45)+lzs*(xl(46)+lzs*(xl(47)+lzs*xl(48)))) - msp(44) = xl(49)+lzs*(xl(50)+lzs*(xl(51)+lzs*(xl(52)+lzs*xl(53)))) - msp(45) = xl(54)+lzs*(xl(55)+lzs*xl(56)) - msp(46) = MIN(1.4d0,1.5135d0+0.3769d0*lzs) - msp(46) = MAX(0.6355d0-0.4192d0*lzs,MAX(1.25d0,msp(46))) -* Lhook - msp(47) = xl(57)+lzs*(xl(58)+lzs*(xl(59)+lzs*xl(60))) - msp(48) = xl(61)+lzs*(xl(62)+lzs*(xl(63)+lzs*xl(64))) - msp(49) = xl(65)+lzs*(xl(66)+lzs*(xl(67)+lzs*xl(68))) - msp(50) = xl(69)+lzs*(xl(70)+lzs*(xl(71)+lzs*xl(72))) - msp(51) = MIN(1.4d0,1.5135d0+0.3769d0*lzs) - msp(51) = MAX(0.6355d0-0.4192d0*lzs,MAX(1.25d0,msp(51))) -* Rtms - msp(52) = xr(1)+lzs*(xr(2)+lzs*(xr(3)+lzs*(xr(4)+lzs*xr(5)))) - msp(53) = xr(6)+lzs*(xr(7)+lzs*(xr(8)+lzs*(xr(9)+lzs*xr(10)))) - msp(54) = xr(11)+lzs*(xr(12)+lzs*(xr(13)+lzs*(xr(14)+lzs*xr(15)))) - msp(55) = xr(16)+lzs*(xr(17)+lzs*(xr(18)+lzs*xr(19))) - msp(56) = xr(20)+lzs*(xr(21)+lzs*(xr(22)+lzs*xr(23))) - msp(52) = msp(52)*msp(54) - msp(53) = msp(53)*msp(54) - msp(57) = xr(24) - msp(58) = xr(25)+lzs*(xr(26)+lzs*(xr(27)+lzs*xr(28))) - msp(59) = xr(29)+lzs*(xr(30)+lzs*(xr(31)+lzs*xr(32))) - msp(60) = xr(33)+lzs*(xr(34)+lzs*(xr(35)+lzs*xr(36))) - msp(61) = xr(37)+lzs*(xr(38)+lzs*(xr(39)+lzs*xr(40))) -* - msp(62) = MAX(0.097d0-0.1072d0*(lz+3.d0),MAX(0.097d0,MIN(0.1461d0, - & 0.1461d0+0.1237d0*(lz+2.d0)))) - msp(62) = 10.d0**msp(62) - m2 = msp(62) + 0.1d0 - msp(63) = (msp(52)+msp(53)*msp(62)**msp(55))/ - & (msp(54)+msp(62)**msp(56)) - msp(64) = (msp(57)*m2**3+msp(58)*m2**msp(61)+ - & msp(59)*m2**(msp(61)+1.5d0))/(msp(60)+m2**5) -* Ralpha - msp(65) = xr(41)+lzs*(xr(42)+lzs*(xr(43)+lzs*xr(44))) - msp(66) = xr(45)+lzs*(xr(46)+lzs*(xr(47)+lzs*xr(48))) - msp(67) = xr(49)+lzs*(xr(50)+lzs*(xr(51)+lzs*xr(52))) - msp(68) = xr(53)+lzs*(xr(54)+lzs*(xr(55)+lzs*xr(56))) - msp(69) = xr(57)+lzs*(xr(58)+lzs*(xr(59)+lzs*(xr(60)+lzs*xr(61)))) - msp(70) = MAX(0.9d0,MIN(1.d0,1.116d0+0.166d0*lzs)) - msp(71) = MAX(1.477d0+0.296d0*lzs,MIN(1.6d0,-0.308d0-1.046d0*lzs)) - msp(71) = MAX(0.8d0,MIN(0.8d0-2.d0*lzs,msp(71))) - msp(72) = xr(62)+lzs*(xr(63)+lzs*xr(64)) - msp(73) = MAX(0.065d0,0.0843d0-lzs*(0.0475d0+0.0352d0*lzs)) - msp(74) = 0.0736d0+lzs*(0.0749d0+0.04426d0*lzs) - if(z.lt.0.004d0) msp(74) = MIN(0.055d0,msp(74)) - msp(75) = MAX(0.091d0,MIN(0.121d0,0.136d0+0.0352d0*lzs)) - msp(76) = (msp(65)*msp(71)**msp(67))/(msp(66) + msp(71)**msp(68)) - if(msp(70).gt.msp(71))then - msp(70) = msp(71) - msp(75) = msp(76) - endif -* Rbeta - msp(77) = xr(65)+lzs*(xr(66)+lzs*(xr(67)+lzs*xr(68))) - msp(78) = xr(69)+lzs*(xr(70)+lzs*(xr(71)+lzs*xr(72))) - msp(79) = xr(73)+lzs*(xr(74)+lzs*(xr(75)+lzs*xr(76))) - msp(80) = xr(77)+lzs*(xr(78)+lzs*(xr(79)+lzs*xr(80))) - msp(81) = xr(81)+lzs*(xr(82)+lzs*lzs*xr(83)) - if(z.gt.0.01d0) msp(81) = MAX(msp(81),0.95d0) - msp(82) = MAX(1.4d0,MIN(1.6d0,1.6d0+lzs*(0.764d0+0.3322d0*lzs))) -* Rgamma - msp(83) = MAX(xr(84)+lzs*(xr(85)+lzs*(xr(86)+lzs*xr(87))), - & xr(96)+lzs*(xr(97)+lzs*xr(98))) - msp(84) = MIN(0.d0,xr(88)+lzs*(xr(89)+lzs*(xr(90)+lzs*xr(91)))) - msp(84) = MAX(msp(84),xr(99)+lzs*(xr(100)+lzs*xr(101))) - msp(85) = xr(92)+lzs*(xr(93)+lzs*(xr(94)+lzs*xr(95))) - msp(85) = MAX(0.d0,MIN(msp(85),7.454d0+9.046d0*lzs)) - msp(86) = MIN(xr(102)+lzs*xr(103),MAX(2.d0,-13.3d0-18.6d0*lzs)) - msp(87) = MIN(1.5d0,MAX(0.4d0,2.493d0+1.1475d0*lzs)) - msp(88) = MAX(1.d0,MIN(1.27d0,0.8109d0-0.6282d0*lzs)) - msp(88) = MAX(msp(88),0.6355d0-0.4192d0*lzs) - msp(89) = MAX(5.855420d-02,-0.2711d0-lzs*(0.5756d0+0.0838d0*lzs)) -* Rhook - msp(90) = xr(104)+lzs*(xr(105)+lzs*(xr(106)+lzs*xr(107))) - msp(91) = xr(108)+lzs*(xr(109)+lzs*(xr(110)+lzs*xr(111))) - msp(92) = xr(112)+lzs*(xr(113)+lzs*(xr(114)+lzs*xr(115))) - msp(93) = xr(116)+lzs*(xr(117)+lzs*(xr(118)+lzs*xr(119))) - msp(94) = MIN(1.25d0, - & MAX(1.1d0,1.9848d0+lzs*(1.1386d0+0.3564d0*lzs))) - msp(95) = 0.063d0 + lzs*(0.0481d0 + 0.00984d0*lzs) - msp(96) = MIN(1.3d0,MAX(0.45d0,1.2d0+2.45d0*lzs)) -* Lneta - if(z.gt.0.0009d0)then - msp(97) = 10.d0 - else - msp(97) = 20.d0 - endif -* Lbgb - gbp(1) = xg(1)+lzs*(xg(2)+lzs*(xg(3)+lzs*xg(4))) - gbp(2) = xg(5)+lzs*(xg(6)+lzs*(xg(7)+lzs*xg(8))) - gbp(3) = xg(9)+lzs*(xg(10)+lzs*(xg(11)+lzs*xg(12))) - gbp(4) = xg(13)+lzs*(xg(14)+lzs*(xg(15)+lzs*xg(16))) - gbp(5) = xg(17)+lzs*(xg(18)+lzs*xg(19)) - gbp(6) = xg(20)+lzs*(xg(21)+lzs*xg(22)) - gbp(3) = gbp(3)**gbp(6) - gbp(7) = xg(23) - gbp(8) = xg(24) -* Lbagb -* set gbp(16) = 1.d0 until it is reset later with an initial -* call to Lbagbf using mass = zpars(2) and mhefl = 0.0 - gbp(9) = xg(25) + lzs*(xg(26) + lzs*xg(27)) - gbp(10) = xg(28) + lzs*(xg(29) + lzs*xg(30)) - gbp(11) = 15.d0 - gbp(12) = xg(31)+lzs*(xg(32)+lzs*(xg(33)+lzs*xg(34))) - gbp(13) = xg(35)+lzs*(xg(36)+lzs*(xg(37)+lzs*xg(38))) - gbp(14) = xg(39)+lzs*(xg(40)+lzs*(xg(41)+lzs*xg(42))) - gbp(15) = xg(43)+lzs*xg(44) - gbp(12) = gbp(12)**gbp(15) - gbp(14) = gbp(14)**gbp(15) - gbp(16) = 1.d0 -* Rgb - gbp(17) = -4.6739d0-0.9394d0*lz - gbp(17) = 10.d0**gbp(17) - gbp(17) = MAX(gbp(17),-0.04167d0+55.67d0*z) - gbp(17) = MIN(gbp(17),0.4771d0-9329.21d0*z**2.94d0) - gbp(18) = MIN(0.54d0,0.397d0+lzs*(0.28826d0+0.5293d0*lzs)) - gbp(19) = MAX(-0.1451d0,-2.2794d0-lz*(1.5175d0+0.254d0*lz)) - gbp(19) = 10.d0**gbp(19) - if(z.gt.0.004d0)then - gbp(19) = MAX(gbp(19),0.7307d0+14265.1d0*z**3.395d0) - endif - gbp(20) = xg(45)+lzs*(xg(46)+lzs*(xg(47)+lzs*(xg(48)+ - & lzs*(xg(49)+lzs*xg(50))))) - gbp(21) = xg(51)+lzs*(xg(52)+lzs*(xg(53)+lzs*(xg(54)+lzs*xg(55)))) - gbp(22) = xg(56)+lzs*(xg(57)+lzs*(xg(58)+lzs*(xg(59)+ - & lzs*(xg(60)+lzs*xg(61))))) - gbp(23) = xg(62)+lzs*(xg(63)+lzs*(xg(64)+lzs*(xg(65)+lzs*xg(66)))) -* Ragb - gbp(24) = MIN(0.99164d0-743.123d0*z**2.83d0, - & 1.0422d0+lzs*(0.13156d0+0.045d0*lzs)) - gbp(25) = xg(67)+lzs*(xg(68)+lzs*(xg(69)+lzs*(xg(70)+ - & lzs*(xg(71)+lzs*xg(72))))) - gbp(26) = xg(73)+lzs*(xg(74)+lzs*(xg(75)+lzs*(xg(76)+lzs*xg(77)))) - gbp(27) = xg(78)+lzs*(xg(79)+lzs*(xg(80)+lzs*(xg(81)+ - & lzs*(xg(82)+lzs*xg(83))))) - gbp(28) = xg(84)+lzs*(xg(85)+lzs*(xg(86)+lzs*(xg(87)+lzs*xg(88)))) - gbp(29) = xg(89)+lzs*(xg(90)+lzs*(xg(91)+lzs*(xg(92)+ - & lzs*(xg(93)+lzs*xg(94))))) - gbp(30) = xg(95)+lzs*(xg(96)+lzs*(xg(97)+lzs*(xg(98)+ - & lzs*(xg(99)+lzs*xg(100))))) - m1 = zpars(2) - 0.2d0 - gbp(31) = gbp(29) + gbp(30)*m1 - gbp(32) = MIN(gbp(25)/zpars(2)**gbp(26),gbp(27)/zpars(2)**gbp(28)) -* Mchei - gbp(33) = xg(101)**4 - gbp(34) = xg(102)*4.d0 -* Mcagb - gbp(35) = xg(103)+lzs*(xg(104)+lzs*(xg(105)+lzs*xg(106))) - gbp(36) = xg(107)+lzs*(xg(108)+lzs*(xg(109)+lzs*xg(110))) - gbp(37) = xg(111)+lzs*xg(112) - gbp(35) = gbp(35)**4 - gbp(36) = gbp(36)*4.d0 - gbp(37) = gbp(37)**4 -* Lhei -* set gbp(41) = -1.d0 until it is reset later with an initial -* call to Lheif using mass = zpars(2) and mhefl = 0.0 - gbp(38) = xh(1)+lzs*xh(2) - gbp(39) = xh(3)+lzs*xh(4) - gbp(40) = xh(5) - gbp(41) = -1.d0 - gbp(42) = xh(6)+lzs*(xh(7)+lzs*xh(8)) - gbp(43) = xh(9)+lzs*(xh(10)+lzs*xh(11)) - gbp(44) = xh(12)+lzs*(xh(13)+lzs*xh(14)) - gbp(42) = gbp(42)**2 - gbp(44) = gbp(44)**2 -* Lhe - gbp(45) = xh(15)+lzs*(xh(16)+lzs*xh(17)) - if(lzs.gt.-1.d0)then - gbp(46) = 1.d0 - xh(19)*(lzs+1.d0)**xh(18) - else - gbp(46) = 1.d0 - endif - gbp(47) = xh(20)+lzs*(xh(21)+lzs*xh(22)) - gbp(48) = xh(23)+lzs*(xh(24)+lzs*xh(25)) - gbp(45) = gbp(45)**gbp(48) - gbp(47) = gbp(47)**gbp(48) - gbp(46) = gbp(46)/zpars(3)**0.1d0+(gbp(46)*gbp(47)-gbp(45))/ - & zpars(3)**(gbp(48)+0.1d0) -* Rmin - gbp(49) = xh(26)+lzs*(xh(27)+lzs*(xh(28)+lzs*xh(29))) - gbp(50) = xh(30)+lzs*(xh(31)+lzs*(xh(32)+lzs*xh(33))) - gbp(51) = xh(34)+lzs*(xh(35)+lzs*(xh(36)+lzs*xh(37))) - gbp(52) = 5.d0+xh(38)*z**xh(39) - gbp(53) = xh(40)+lzs*(xh(41)+lzs*(xh(42)+lzs*xh(43))) - gbp(49) = gbp(49)**gbp(53) - gbp(51) = gbp(51)**(2.d0*gbp(53)) -* The -* set gbp(57) = -1.d0 until it is reset later with an initial -* call to Thef using mass = zpars(2), mc = 0.0 and mhefl = 0.0 - gbp(54) = xh(44)+lzs*(xh(45)+lzs*(xh(46)+lzs*xh(47))) - gbp(55) = xh(48)+lzs*(xh(49)+lzs*xh(50)) - gbp(55) = MAX(gbp(55),1.d0) - gbp(56) = xh(51) - gbp(57) = -1.d0 - gbp(58) = xh(52)+lzs*(xh(53)+lzs*(xh(54)+lzs*xh(55))) - gbp(59) = xh(56)+lzs*(xh(57)+lzs*(xh(58)+lzs*xh(59))) - gbp(60) = xh(60)+lzs*(xh(61)+lzs*(xh(62)+lzs*xh(63))) - gbp(61) = xh(64)+lzs*xh(65) - gbp(58) = gbp(58)**gbp(61) - gbp(60) = gbp(60)**5 -* Tbl - dum1 = zpars(2)/zpars(3) - gbp(62) = xh(66)+lzs*xh(67) - gbp(62) = -gbp(62)*log10(dum1) - gbp(63) = xh(68) - if(lzd.gt.0.d0) then - gbp(64) = 1.d0-lzd*(xh(69)+lzd*(xh(70)+lzd*xh(71))) - else - gbp(64) = 1.d0 - end if - gbp(65) = 1.d0-gbp(64)*dum1**gbp(63) - gbp(66) = 1.d0 - lzd*(xh(77) + lzd*(xh(78) + lzd*xh(79))) - gbp(67) = xh(72) + lzs*(xh(73) + lzs*(xh(74) + lzs*xh(75))) - gbp(68) = xh(76) -* Lzahb - gbp(69) = xh(80) + lzs*(xh(81) + lzs*xh(82)) - gbp(70) = xh(83) + lzs*(xh(84) + lzs*xh(85)) - gbp(71) = 15.d0 - gbp(72) = xh(86) - gbp(73) = xh(87) -* Rzahb - gbp(75) = xh(88) + lzs*(xh(89) + lzs*(xh(90) + lzs*xh(91))) - gbp(76) = xh(92) + lzs*(xh(93) + lzs*(xh(94) + lzs*xh(95))) - gbp(77) = xh(96) + lzs*(xh(97) + lzs*(xh(98) + lzs*xh(99))) -*** -* finish Lbagb - mhefl = 0.d0 - lx = lbagbf(zpars(2),mhefl) - gbp(16) = lx -* finish LHeI - dum1 = 0.d0 - lhefl = lheif(zpars(2),mhefl) - gbp(41) = (gbp(38)*zpars(2)**gbp(39)-lhefl)/ - & (EXP(zpars(2)*gbp(40))*lhefl) -* finish THe - thefl = thef(zpars(2),dum1,mhefl)*tbgbf(zpars(2)) - gbp(57) = (thefl-gbp(54))/(gbp(54)*EXP(gbp(56)*zpars(2))) -* finish Tblf - rb = ragbf(zpars(3),lheif(zpars(3),zpars(2)),mhefl) - rr = 1.d0 - rminf(zpars(3))/rb - rr = MAX(rr,1.0d-12) - gbp(66) = gbp(66)/(zpars(3)**gbp(67)*rr**gbp(68)) -* finish Lzahb - gbp(74) = lhefl*lHef(zpars(2)) -*** - kw = 0 - tm = 0.d0 - tn = 0.d0 - CALL star(kw,zpars(2),zpars(2),tm,tn,tscls,lums,GB,zpars) - zpars(9) = mcgbf(lums(3),GB,lums(6)) - zpars(10) = mcgbf(lums(4),GB,lums(6)) -* set the hydrogen and helium abundances - zpars(11) = 0.76d0 - 3.d0*z - zpars(12) = 0.24d0 + 2.d0*z -* set constant for low-mass CHeB stars - zpars(13) = rminf(zpars(2))/ - & rgbf(zpars(2),lzahbf(zpars(2),zpars(9),zpars(2))) -* - zpars(14) = z**0.4d0 -* - return - end -*** - - -cc//zfuncs.f - -*** - real*8 FUNCTION lzamsf(m) - implicit none - real*8 m,mx,a(200) - common /MSCFF/ a -* -* A function to evaluate Lzams -* ( from Tout et al., 1996, MNRAS, 281, 257 ). -* - mx = SQRT(m) - lzamsf = (a(1)*m**5*mx + a(2)*m**11)/ - & (a(3) + m**3 + a(4)*m**5 + a(5)*m**7 + - & a(6)*m**8 + a(7)*m**9*mx) -* - return - end -*** - real*8 FUNCTION rzamsf(m) - implicit none - real*8 m,mx,a(200) - common /MSCFF/ a -* -* A function to evaluate Rzams -* ( from Tout et al., 1996, MNRAS, 281, 257 ). -* - mx = SQRT(m) - rzamsf = ((a(8)*m**2 + a(9)*m**6)*mx + a(10)*m**11 + - & (a(11) + a(12)*mx)*m**19)/ - & (a(13) + a(14)*m**2 + - & (a(15)*m**8 + m**18 + a(16)*m**19)*mx) -* - return - end -*** - real*8 FUNCTION tbgbf(m) - implicit none - real*8 m,a(200) - common /MSCFF/ a -* -* A function to evaluate the lifetime to the BGB or to -* Helium ignition if no FGB exists. -* (JH 24/11/97) -* - tbgbf = (a(17) + a(18)*m**4 + a(19)*m**(11.d0/2.d0) + m**7)/ - & (a(20)*m**2 + a(21)*m**7) -* - return - end -*** - real*8 FUNCTION tbgbdf(m) - implicit none - real*8 m,mx,f,df,g,dg,a(200) - common /MSCFF/ a -* -* A function to evaluate the derivitive of the lifetime to the BGB -* (or to Helium ignition if no FGB exists) wrt mass. -* (JH 24/11/97) -* - mx = SQRT(m) - f = a(17) + a(18)*m**4 + a(19)*m**5*mx + m**7 - df = 4.d0*a(18)*m**3 + 5.5d0*a(19)*m**4*mx + 7.d0*m**6 - g = a(20)*m**2 + a(21)*m**7 - dg = 2.d0*a(20)*m + 7.d0*a(21)*m**6 - tbgbdf = (df*g - f*dg)/(g*g) -* - return - end -*** - real*8 FUNCTION tbgdzf(m) - implicit none - real*8 m,mx,f,df,g,dg,a(200) - common /MSCFF/ a -* -* A function to evaluate the derivitive of the lifetime to the BGB -* (or to Helium ignition if no FGB exists) wrt Z. -* (JH 14/12/98) -* - mx = m**5*SQRT(m) - f = a(17) + a(18)*m**4 + a(19)*mx + m**7 - df = a(117) + a(118)*m**4 + a(119)*mx - g = a(20)*m**2 + a(21)*m**7 - dg = a(120)*m**2 - tbgdzf = (df*g - f*dg)/(g*g) -* - return - end -*** - real*8 FUNCTION thookf(m) - implicit none - real*8 m,a(200) - common /MSCFF/ a -* -* A function to evaluate the lifetime to the end of the MS -* hook ( for those models that have one ) as a fraction of -* the lifetime to the BGB -* Note that this function is only valid for M > Mhook. -* (JH 24/11/97) -* - thookf = 1.d0 - 0.01d0*MAX(a(22)/m**a(23),a(24)+a(25)/m**a(26)) - thookf = MAX(thookf,0.5d0) -* - return - end -*** - real*8 FUNCTION ltmsf(m) - implicit none - real*8 m,a(200) - common /MSCFF/ a -* -* A function to evaluate the luminosity at the end of the MS -* (JH 24/11/97) -* - ltmsf = (a(27)*m**3 + a(28)*m**4 + a(29)*m**(a(32)+1.8d0))/ - & (a(30) + a(31)*m**5 + m**a(32)) -* - return - end -*** - real*8 FUNCTION lalphf(m) - implicit none - real*8 m,mcut,a(200) - common /MSCFF/ a -* -* A function to evaluate the Luminosity alpha coefficent. -* (JH 24/11/97) -* - mcut = 2.d0 - if(m.ge.mcut)then - lalphf = (a(33) + a(34)*m**a(36))/(m**0.4d0 + a(35)*m**1.9d0) - else - if(m.le.0.5d0)then - lalphf = a(39) - elseif(m.le.0.7d0)then - lalphf = a(39) + ((0.3d0 - a(39))/0.2d0)*(m - 0.5d0) - elseif(m.le.a(37))then - lalphf = 0.3d0 + ((a(40)-0.3d0)/(a(37)-0.7d0))*(m - 0.7d0) - elseif(m.le.a(38))then - lalphf = a(40) + ((a(41)-a(40))/(a(38)-a(37)))*(m - a(37)) - else - lalphf = a(41) + ((a(42)-a(41))/(mcut-a(38)))*(m - a(38)) - endif - endif -* - return - end -*** - real*8 FUNCTION lbetaf(m) - implicit none - real*8 m,a1,a(200) - common /MSCFF/ a -* -* A function to evaluate the Luminosity beta coefficent. -* (JH 24/11/97) -* - lbetaf = a(43) - a(44)*m**a(45) - lbetaf = MAX(lbetaf,0.d0) - if(m.gt.a(46).and.lbetaf.gt.0.d0)then - a1 = a(43) - a(44)*a(46)**a(45) - lbetaf = a1 - 10.d0*a1*(m - a(46)) - lbetaf = MAX(lbetaf,0.d0) - endif -* - return - end -*** - real*8 FUNCTION lnetaf(m) - implicit none - real*8 m,a(200) - common /MSCFF/ a -* -* A function to evaluate the Luminosity neta exponent. -* (JH 24/11/97) -* - if(m.le.1.d0)then - lnetaf = 10.d0 - elseif(m.ge.1.1d0)then - lnetaf = 20.d0 - else - lnetaf = 10.d0 + 100.d0*(m - 1.d0) - endif - lnetaf = MIN(lnetaf,a(97)) -* - return - end -*** - real*8 FUNCTION lhookf(m,mhook) - implicit none - real*8 m,mhook,a2,a(200) - common /MSCFF/ a -* -* A function to evalute the luminosity at the start of -* the MS hook ( for those stars that have one ). -* Note that this function is only valid for M > Mhook. -* (JH 24/11/97) -* - if(m.le.mhook)then - lhookf = 0.d0 - elseif(m.ge.a(51))then - lhookf = MIN(a(47)/m**a(48),a(49)/m**a(50)) - else - a2 = MIN(a(47)/a(51)**a(48),a(49)/a(51)**a(50)) - lhookf = a2*((m-mhook)/(a(51)-mhook))**0.4d0 - endif -* - return - end -*** - real*8 FUNCTION rtmsf(m) - implicit none - real*8 m,m2,rchk,a(200) - common /MSCFF/ a - real*8 rzamsf - external rzamsf -* -* A function to evaluate the radius at the end of the MS -* Note that a safety check is added to ensure Rtms > Rzams -* when extrapolating the function to low masses. -* (JH 24/11/97) -* - m2 = a(62) + 0.1d0 - if(m.le.a(62))then - rchk = 1.5d0*rzamsf(m) - rtmsf = MAX(rchk,(a(52) + a(53)*m**a(55))/(a(54) + m**a(56))) - elseif(m.ge.m2)then - rtmsf = (a(57)*m**3+a(58)*m**a(61)+a(59)*m**(a(61)+1.5d0))/ - & (a(60) + m**5) - else - rtmsf = a(63) + ((a(64) - a(63))/0.1d0)*(m - a(62)) - endif -* - return - end -*** - real*8 FUNCTION ralphf(m) - implicit none - real*8 m,a5,a(200) - common /MSCFF/ a -* -* A function to evaluate the radius alpha coefficent. -* (JH 24/11/97) -* - if(m.le.0.5d0)then - ralphf = a(73) - elseif(m.le.0.65d0)then - ralphf = a(73) + ((a(74) - a(73))/0.15d0)*(m - 0.5d0) - elseif(m.le.a(70))then - ralphf = a(74) + ((a(75)-a(74))/(a(70)-0.65d0))*(m - 0.65d0) - elseif(m.le.a(71))then - ralphf = a(75) + ((a(76) - a(75))/(a(71) - a(70)))*(m - a(70)) - elseif(m.le.a(72))then - ralphf = (a(65)*m**a(67))/(a(66) + m**a(68)) - else - a5 = (a(65)*a(72)**a(67))/(a(66) + a(72)**a(68)) - ralphf = a5 + a(69)*(m - a(72)) - endif -* - return - end -*** - real*8 FUNCTION rbetaf(m) - implicit none - real*8 m,m2,m3,b2,b3,a(200) - common /MSCFF/ a -* -* A function to evaluate the radius beta coefficent. -* (JH 24/11/97) -* - m2 = 2.d0 - m3 = 16.d0 - if(m.le.1.d0)then - rbetaf = 1.06d0 - elseif(m.le.a(82))then - rbetaf = 1.06d0 + ((a(81)-1.06d0)/(a(82)-1.d0))*(m-1.d0) - elseif(m.le.m2)then - b2 = (a(77)*m2**(7.d0/2.d0))/(a(78) + m2**a(79)) - rbetaf = a(81) + ((b2-a(81))/(m2-a(82)))*(m-a(82)) - elseif(m.le.m3)then - rbetaf = (a(77)*m**(7.d0/2.d0))/(a(78) + m**a(79)) - else - b3 = (a(77)*m3**(7.d0/2.d0))/(a(78) + m3**a(79)) - rbetaf = b3 + a(80)*(m - m3) - endif - rbetaf = rbetaf - 1.d0 -* - return - end -*** - real*8 FUNCTION rgammf(m) - implicit none - real*8 m,m1,b1,a(200) - common /MSCFF/ a -* -* A function to evaluate the radius gamma coefficent. -* (JH 24/11/97) -* - m1 = 1.d0 - if(m.gt.(a(88)+0.1d0))then - rgammf = 0.d0 - else - b1 = MAX(0.d0,a(83) + a(84)*(m1-a(85))**a(86)) - if(m.le.m1)then - rgammf = a(83) + a(84)*ABS(m-a(85))**a(86) - elseif(m.le.a(88))then - rgammf = b1 + (a(89) - b1)*((m - m1)/(a(88) - m1))**a(87) - else - if(a(88).gt.m1) b1 = a(89) - rgammf = b1 - 10.d0*b1*(m - a(88)) - endif - rgammf = MAX(rgammf,0.d0) - endif -* - return - end -*** - real*8 FUNCTION rhookf(m,mhook) - implicit none - real*8 m,mhook,m2,b2,a(200) - common /MSCFF/ a -* -* A function to evalute the radius at the start of -* the MS hook ( for those stars that have one ). -* Note that this function is only valid for M > Mhook. -* (JH 24/11/97) -* - if(m.le.mhook)then - rhookf = 0.d0 - elseif(m.le.a(94))then - rhookf = a(95)*SQRT((m-mhook)/(a(94)-mhook)) - elseif(m.le.2.d0)then - m2 = 2.d0 - b2 = (a(90) + a(91)*m2**(7.d0/2.d0))/ - & (a(92)*m2**3 + m2**a(93)) - 1.d0 - rhookf = a(95) + (b2-a(95))*((m-a(94))/(m2-a(94)))**a(96) - else - rhookf = (a(90) + a(91)*m**(7.d0/2.d0))/ - & (a(92)*m**3 + m**a(93)) - 1.d0 - endif -* - return - end -*** - real*8 FUNCTION lbgbf(m) - real*8 m,a(200) - common /GBCFF/ a -* -* A function to evaluate the luminosity at the end of the -* FGB ( for those models that have one ) -* Note that this function is only valid for LM & IM stars -* (JH 24/11/97) -* - lbgbf = (a(1)*m**a(5) + a(2)*m**a(8))/ - & (a(3) + a(4)*m**a(7) + m**a(6)) -* - return - end -*** - real*8 FUNCTION lbgbdf(m) - real*8 m,a(200) - real*8 f,df,g,dg - common /GBCFF/ a -* -* A function to evaluate the derivitive of the Lbgb function. -* Note that this function is only valid for LM & IM stars -* (JH 24/11/97) -* - f = a(1)*m**a(5) + a(2)*m**a(8) - df = a(5)*a(1)*m**(a(5)-1.d0) + a(8)*a(2)*m**(a(8)-1.d0) - g = a(3) + a(4)*m**a(7) + m**a(6) - dg = a(7)*a(4)*m**(a(7)-1.d0) + a(6)*m**(a(6)-1.d0) -* - lbgbdf = (df*g - f*dg)/(g*g) -* - return - end -*** - real*8 FUNCTION lbagbf(m,mhefl) - implicit none - real*8 m,mhefl,a4,a(200) - common /GBCFF/ a -* -* A function to evaluate the BAGB luminosity. (OP 21/04/98) -* Continuity between LM and IM functions is ensured by setting -* gbp(16) = lbagbf(mhefl,0.0) with gbp(16) = 1.0. -* - a4 = (a(9)*mhefl**a(10) - a(16))/(exp(mhefl*a(11))*a(16)) -* - if(m.lt.mhefl)then - lbagbf = a(9)*m**a(10)/(1.d0 + a4*exp(m*a(11))) - else - lbagbf = (a(12) + a(13)*m**(a(15)+1.8d0))/(a(14) + m**a(15)) - endif -* - return - end -*** - real*8 FUNCTION rgbf(m,lum) - implicit none - real*8 m,lum,a1,a(200) - common /GBCFF/ a -* -* A function to evaluate radius on the GB. -* (JH 24/11/97) -* - a1 = MIN(a(20)/m**a(21),a(22)/m**a(23)) - rgbf = a1*(lum**a(18) + a(17)*lum**a(19)) -* - return - end -*** - real*8 FUNCTION rgbdf(m,lum) - implicit none - real*8 m,lum,a1,a(200) - common /GBCFF/ a -* -* A function to evaluate radius derivitive on the GB (as f(L)). -* (JH 24/11/97) -* - a1 = MIN(a(20)/m**a(21),a(22)/m**a(23)) - rgbdf = a1*(a(18)*lum**(a(18)-1.d0) + - & a(17)*a(19)*lum**(a(19)-1.d0)) -* - return - end -*** - real*8 FUNCTION ragbf(m,lum,mhelf) - implicit none - real*8 m,lum,mhelf,m1,a1,a4,xx,a(200) - common /GBCFF/ a -* -* A function to evaluate radius on the AGB. -* (JH 24/11/97) -* - m1 = mhelf - 0.2d0 - if(m.ge.mhelf)then - xx = a(24) - elseif(m.ge.m1)then - xx = 1.d0 + 5.d0*(a(24)-1.d0)*(m-m1) - else - xx = 1.d0 - endif - a4 = xx*a(19) - if(m.le.m1)then - a1 = a(29) + a(30)*m - elseif(m.ge.mhelf)then - a1 = MIN(a(25)/m**a(26),a(27)/m**a(28)) - else - a1 = a(31) + 5.d0*(a(32)-a(31))*(m-m1) - endif -* - ragbf = a1*(lum**a(18) + a(17)*lum**a4) -* - return - end -*** - real*8 FUNCTION ragbdf(m,lum,mhelf) - implicit none - real*8 m,lum,mhelf,m1,a1,a4,xx,a(200) - common /GBCFF/ a -* -* A function to evaluate radius derivitive on the AGB (as f(L)). -* (JH 24/11/97) -* - m1 = mhelf - 0.2d0 - if(m.ge.mhelf)then - xx = a(24) - elseif(m.ge.m1)then - xx = 1.d0 + 5.d0*(a(24)-1.d0)*(m-m1) - else - xx = 1.d0 - endif - a4 = xx*a(19) - if(m.le.m1)then - a1 = a(29) + a(30)*m - elseif(m.ge.mhelf)then - a1 = MIN(a(25)/m**a(26),a(27)/m**a(28)) - else - a1 = a(31) + 5.d0*(a(32)-a(31))*(m-m1) - endif -* - ragbdf = a1*(a(18)*lum**(a(18)-1.d0) + - & a(17)*a4*lum**(a4-1.d0)) -* - return - end -*** - real*8 FUNCTION mctmsf(m) - implicit none - real*8 m,m525 -* -* A function to evaluate core mass at the end of the MS as a -* fraction of the BGB value, i.e. this must be multiplied by -* the BGB value (see below) to give the actual core mass (JH 5/9/99) -* - m525 = m**(21.d0/4.d0) - mctmsf = (1.586d0 + m525)/(2.434d0 + 1.02d0*m525) -* - return - end -*** - real*8 FUNCTION mcheif(m,mhefl,mchefl) - implicit none - real*8 m,mhefl,mchefl,mcbagb,a3,a(200) - common /GBCFF/ a - real*8 mcagbf - external mcagbf -* -* A function to evaluate core mass at BGB or He ignition -* (depending on mchefl) for IM & HM stars (OP 25/11/97) -* - mcbagb = mcagbf(m) - a3 = mchefl**4 - a(33)*mhefl**a(34) - mcheif = MIN(0.95d0*mcbagb,(a3 + a(33)*m**a(34))**(1.d0/4.d0)) -* - return - end -*** - real*8 FUNCTION mheif(mc,mhefl,mchefl) - implicit none - real*8 mc,mhefl,mchefl,m1,m2,a3,a(200) - common /GBCFF/ a - real*8 mbagbf - external mbagbf -* -* A function to evaluate mass at BGB or He ignition -* (depending on mchefl) for IM & HM stars by inverting -* mcheif -* - m1 = mbagbf(mc/0.95d0) - a3 = mchefl**4 - a(33)*mhefl**a(34) - m2 = ((mc**4 - a3)/a(33))**(1.d0/a(34)) - mheif = MAX(m1,m2) -* - return - end -*** - real*8 FUNCTION mcagbf(m) - implicit none - real*8 m,a(200) - common /GBCFF/ a -* -* A function to evaluate core mass at the BAGB (OP 25/11/97) -* - mcagbf = (a(37) + a(35)*m**a(36))**(1.d0/4.d0) -* - return - end -*** - real*8 FUNCTION mbagbf(mc) - implicit none - real*8 mc,mc4,a(200) - common /GBCFF/ a -* -* A function to evaluate mass at the BAGB by inverting mcagbf. -* - mc4 = mc**4 - if(mc4.gt.a(37))then - mbagbf = ((mc4 - a(37))/a(35))**(1.d0/a(36)) - else - mbagbf = 0.d0 - endif -* - return - end -*** - real*8 FUNCTION mcgbtf(t,A,GB,tinf1,tinf2,tx) - implicit none - real*8 t,A,GB(10),tinf1,tinf2,tx -* -* A function to evaluate Mc given t for GB, AGB and NHe stars -* - if(t.le.tx)then - mcgbtf = ((GB(5)-1.d0)*A*GB(4)*(tinf1 - t))** - & (1.d0/(1.d0-GB(5))) - else - mcgbtf = ((GB(6)-1.d0)*A*GB(3)*(tinf2 - t))** - & (1.d0/(1.d0-GB(6))) - endif -* - return - end -*** - real*8 FUNCTION lgbtf(t,A,GB,tinf1,tinf2,tx) - implicit none - real*8 t,A,GB(10),tinf1,tinf2,tx -* -* A function to evaluate L given t for GB, AGB and NHe stars -* - if(t.le.tx)then - lgbtf = GB(4)*(((GB(5)-1.d0)*A*GB(4)*(tinf1 - t))** - & (GB(5)/(1.d0-GB(5)))) - else - lgbtf = GB(3)*(((GB(6)-1.d0)*A*GB(3)*(tinf2 - t))** - & (GB(6)/(1.d0-GB(6)))) - endif -* - return - end -*** - real*8 FUNCTION mcgbf(lum,GB,lx) - implicit none - real*8 lum,GB(10),lx -* -* A function to evaluate Mc given L for GB, AGB and NHe stars -* - if(lum.le.lx)then - mcgbf = (lum/GB(4))**(1.d0/GB(5)) - else - mcgbf = (lum/GB(3))**(1.d0/GB(6)) - endif -* - return - end -*** - real*8 FUNCTION lmcgbf(mc,GB) - implicit none - real*8 mc,GB(10) -* -* A function to evaluate L given Mc for GB, AGB and NHe stars -* - if(mc.le.GB(7))then - lmcgbf = GB(4)*(mc**GB(5)) - else - lmcgbf = GB(3)*(mc**GB(6)) - endif -* - return - end -*** - real*8 FUNCTION lHeIf(m,mhefl) - implicit none - real*8 m,mhefl,a(200) - common /GBCFF/ a -* -* A function to evaluate He-ignition luminosity (OP 24/11/97) -* Continuity between the LM and IM functions is ensured with a first -* call setting lhefl = lHeIf(mhefl,0.0) -* - if(m.lt.mhefl)then - lHeIf = a(38)*m**a(39)/(1.d0 + a(41)*EXP(m*a(40))) - else - lHeIf = (a(42) + a(43)*m**3.8d0)/(a(44) + m**2) - endif -* - return - end -*** - real*8 FUNCTION lHef(m) - implicit none - real*8 m,a(200) - common /GBCFF/ a -* -* A function to evaluate the ratio LHe,min/LHeI (OP 20/11/97) -* Note that this function is everywhere <= 1, and is only valid -* for IM stars -* - lHef = (a(45) + a(46)*m**(a(48)+0.1d0))/(a(47) + m**a(48)) -* - return - end -*** - real*8 FUNCTION rminf(m) - implicit none - real*8 m,mx,a(200) - common /GBCFF/ a -* -* A function to evaluate the minimum radius during He-burning -* for IM & HM stars (OP 20/11/97) -* - mx = m**a(53) - rminf = (a(49)*m + (a(50)*m)**a(52)*mx)/(a(51) + mx) -* - return - end -*** - real*8 FUNCTION tHef(m,mc,mhefl) - implicit none - real*8 m,mc,mhefl,mm,a(200) - common /GBCFF/ a - real*8 themsf - external themsf -* -* A function to evaluate the He-burning lifetime. (OP 26/11/97) -* For IM & HM stars, tHef is relative to tBGB. -* Continuity between LM and IM stars is ensured by setting -* thefl = tHef(mhefl,0.0,,0.0), and the call to themsf ensures -* continuity between HB and NHe stars as Menv -> 0. -* - if(m.le.mhefl)then - mm = MAX((mhefl - m)/(mhefl - mc),1.0d-12) - tHef = (a(54) + (themsf(mc) - a(54))*mm**a(55))* - & (1.d0 + a(57)*EXP(m*a(56))) - else - mm = m**5 - tHef = (a(58)*m**a(61) + a(59)*mm)/(a(60) + mm) - endif -* - return - end -*** - real*8 FUNCTION tblf(m,mhefl,mfgb) - implicit none - real*8 m,mhefl,mfgb,mr,m1,m2,r1,a(200) - common /GBCFF/ a - real*8 lheif,rminf,ragbf - external lheif,rminf,ragbf -* -* A function to evaluate the blue-loop fraction of the He-burning -* lifetime for IM & HM stars (OP 28/01/98) -* - mr = mhefl/mfgb - if(m.le.mfgb) then - m1 = m/mfgb - m2 = log10(m1)/log10(mr) - m2 = max(m2,1.0d-12) - tblf = a(64)*m1**a(63) + a(65)*m2**a(62) - else - r1 = 1.d0 - rminf(m)/ragbf(m,lheif(m,mhefl),mhefl) - r1 = max(r1,1.0d-12) - tblf = a(66)*m**a(67)*r1**a(68) - end if - tblf = MIN(1.d0,MAX(0.d0,tblf)) - if(tblf.lt.1.0d-10) tblf = 0.d0 -* - return - end -*** - real*8 FUNCTION lzahbf(m,mc,mhefl) - implicit none - real*8 m,mc,mhefl,mm,a4,a5,a(200) - common /GBCFF/ a - real*8 lzhef - external lzhef -* -* A function to evaluate the ZAHB luminosity for LM stars. (OP 28/01/98) -* Continuity with LHe,min for IM stars is ensured by setting -* lx = lHeif(mhefl,z,0.0,1.0)*lHef(mhefl,z,mfgb), and the call to lzhef -* ensures continuity between the ZAHB and the NHe-ZAMS as Menv -> 0. -* - a5 = lzhef(mc) - a4 = (a(69) + a5 - a(74))/((a(74) - a5)*exp(a(71)*mhefl)) - mm = MAX((m-mc)/(mhefl - mc),1.0d-12) - lzahbf = a5 + (1.d0 + a(72))*a(69)*mm**a(70)/ - & ((1.d0 + a(72)*mm**a(73))*(1.d0 + a4*EXP(m*a(71)))) -* - return - end -*** - real*8 FUNCTION rzahbf(m,mc,mhefl) - implicit none - real*8 m,mc,mhefl,rx,ry,mm,f,a(200) - common /GBCFF/ a - real*8 rzhef,rgbf,lzahbf -* -* A function to evaluate the ZAHB radius for LM stars. (OP 28/01/98) -* Continuity with R(LHe,min) for IM stars is ensured by setting -* lx = lHeif(mhefl,z,0.0,1.0)*lHef(mhefl,z,mfgb), and the call to rzhef -* ensures continuity between the ZAHB and the NHe-ZAMS as Menv -> 0. -* - rx = rzhef(mc) - ry = rgbf(m,lzahbf(m,mc,mhefl)) - mm = MAX((m-mc)/(mhefl - mc),1.0d-12) - f = (1.d0 + a(76))*mm**a(75)/(1.d0 + a(76)*mm**a(77)) - rzahbf = (1.d0 - f)*rx + f*ry -* - return - end -*** - real*8 FUNCTION lzhef(m) - implicit none - real*8 m,m15 -* -* A function to evaluate Naked Helium star 'ZAMS' luminosity -* - m15 = m*SQRT(m) - lzhef = 1.5262d+04*m**(41.d0/4.d0)/ - & (0.0469d0 + m**6*(31.18d0 + m15*(29.54d0 + m15))) -* - return - end -*** - real*8 FUNCTION rzhef(m) - implicit none - real*8 m -* -* A function to evaluate Helium star 'ZAMS' radius -* - rzhef = 0.2391d0*m**4.6d0/(0.0065d0 + (0.162d0 + m)*m**3) -* - return - end -*** - real*8 FUNCTION themsf(m) - implicit none - real*8 m -* -* A function to evaluate Helium star main sequence lifetime -* - themsf = (0.4129d0 + 18.81d0*m**4 + 1.853d0*m**6)/m**(13.d0/2.d0) -* - return - end -*** - real*8 FUNCTION rhehgf(m,lum,rx,lx) - implicit none - real*8 m,lum,rx,lx,cm -* -* A function to evaluate Helium star radius on the Hertzsprung gap -* from its mass and luminosity. -* - cm = 2.0d-03*m**(5.d0/2.d0)/(2.d0 + m**5) - rhehgf = rx*(lum/lx)**0.2d0 + 0.02d0*(EXP(cm*lum) - EXP(cm*lx)) -* - return - end -*** - real*8 FUNCTION rhegbf(lum) - implicit none - real*8 lum -* -* A function to evaluate Helium star radius on the giant branch. -* - rhegbf = 0.08d0*lum**(3.d0/4.d0) -* - return - end -*** - real*8 FUNCTION lpertf(m,mew) - implicit none - real*8 m,mew - real*8 b,c -* -* A function to obtain the exponent that perturbs luminosity. -* - b = 0.002d0*MAX(1.d0,2.5d0/m) - c = 3.d0 - lpertf = ((1.d0 + b**c)*((mew/b)**c))/(1.d0+(mew/b)**c) -* - return - end -*** - real*8 FUNCTION rpertf(m,mew,r,rc) - implicit none - real*8 m,mew,r,rc - real*8 a,b,c,q,fac,facmax -* -* A function to obtain the exponent that perturbs radius. -* - if(mew.le.0.d0)then - rpertf = 0.d0 - else - a = 0.1d0 - b = 0.006d0*MAX(1.d0,2.5d0/m) - c = 3.d0 - q = log(r/rc) - fac = a/q - facmax = -14.d0/log10(mew) - fac = MIN(fac,facmax) - rpertf = ((1.d0 + b**c)*((mew/b)**c)*(mew**fac))/ - & (1.d0+(mew/b)**c) - endif -* - return - end -*** - real*8 FUNCTION vrotf(m) - implicit none - real*8 m -* - vrotf = 330.d0*m**3.3d0/(15.d0 + m**3.45d0) -* - return - end -*** - real*8 FUNCTION celamf(kw,m,lum,rad,rzams,menv,fac) - implicit none - integer kw - real*8 m,lum,rad,rzams,menv,fac - real*8 lam1,lam2,m1,logm,logl - real*8 aa,bb,cc,dd -* -* A function to estimate lambda for common-envelope. -* - if(fac.ge.0.d0)then -* -* No fits yet for naked He stars... -* - if(kw.gt.6)then - celamf = 0.5d0 - goto 90 - endif -* - if(menv.gt.0.d0)then -* Formulae for giant-like stars; also used for HG and CHeB stars close -* to the Hayashi track. - logl = log10(lum) - logm = log10(m) - if(kw.le.5)then - m1 = m - if(kw.gt.3) m1 = 100.d0 - lam1 = 3.d0/(2.4d0 + 1.d0/m1**(3.d0/2.d0)) - 0.15d0*logl - lam1 = MIN(lam1,0.8d0) - else - lam1 = -3.5d0 - 0.75d0*logm + logl - endif - if(kw.gt.3)then - lam2 = MIN(0.9d0,0.58d0 + 0.75d0*logm) - 0.08d0*logl - if(kw.lt.6)then - lam1 = MIN(lam2,lam1) - else - lam1 = MAX(lam2,lam1) - lam1 = MIN(lam1,1.d0) - endif - endif - lam1 = 2.d0*lam1 - if(fac.gt.0.d0)then -* Use a fraction FAC of the ionization energy in the energy balance. - if(kw.le.3)then - aa = MIN(1.2d0*(logm - 0.25d0)**2 - 0.7d0,-0.5d0) - else - aa = MAX(-0.2d0 - logm,-0.5d0) - endif - bb = MAX(3.d0 - 5.d0*logm,1.5d0) - cc = MAX(3.7d0 + 1.6d0*logm,3.3d0 + 2.1d0*logm) - lam2 = aa + ATAN(bb*(cc - logl)) - if(kw.le.3)then - dd = MAX(0.d0,MIN(0.15d0,0.15d0 - 0.25d0*logm)) - lam2 = lam2 + dd*(logl - 2.d0) - endif - lam2 = MAX(lam2,1.d-2) - lam2 = MAX(1.d0/lam2,lam1) - if(fac.ge.1.d0)then - lam1 = lam2 - else - lam1 = lam1 + fac*(lam2 - lam1) - endif - endif - endif -* - if(menv.lt.1.d0)then -* Formula for HG stars; also reasonable for CHeB stars in blue loop. - lam2 = 0.42d0*(rzams/rad)**0.4d0 -* Alternatively: -* lam2 = 0.3d0*(rtms/rad)**0.4d0 - lam2 = 2.d0*lam2 - endif -* - if(menv.le.0.d0)then - celamf = lam2 - elseif(menv.ge.1.d0)then - celamf = lam1 - else -* Interpolate between HG and GB values depending on conv. envelope mass. - celamf = lam2 + sqrt(menv)*(lam1 - lam2) - endif -* - 90 continue -* - else - celamf = -1.d0*fac - endif -* - return - end -*** - - -cc//comenv.f - -*** - SUBROUTINE COMENV(M01,M1,MC1,AJ1,JSPIN1,KW1, - & M02,M2,MC2,AJ2,JSPIN2,KW2, - & ZPARS,ECC,SEP,JORB,COEL) -* -* Common Envelope Evolution. -* -* Author : C. A. Tout -* Date : 18th September 1996 -* -* Redone : J. R. Hurley -* Date : 7th July 1998 -* - IMPLICIT NONE -* - INTEGER KW1,KW2,KW - INTEGER KTYPE(0:14,0:14) - COMMON /TYPES/ KTYPE - INTEGER ceflag,tflag,ifflag,nsflag,wdflag - COMMON /FLAGS/ ceflag,tflag,ifflag,nsflag,wdflag -* - REAL*8 M01,M1,MC1,AJ1,JSPIN1,R1,L1,K21 - REAL*8 M02,M2,MC2,AJ2,JSPIN2,R2,L2,K22,MC22 - REAL*8 TSCLS1(20),TSCLS2(20),LUMS(10),GB(10),TM1,TM2,TN,ZPARS(20) - REAL*8 EBINDI,EBINDF,EORBI,EORBF,ECIRC,SEPF,SEPL,MF,XX - REAL*8 CONST,DELY,DERI,DELMF,MC3,FAGE1,FAGE2 - REAL*8 ECC,SEP,JORB,TB,OORB,OSPIN1,OSPIN2,TWOPI - REAL*8 RC1,RC2,Q1,Q2,RL1,RL2,LAMB1,LAMB2 - REAL*8 MENV,RENV,MENVD,RZAMS,VS(3) - REAL*8 AURSUN,K3,ALPHA1,LAMBDA - PARAMETER (AURSUN = 214.95D0,K3 = 0.21D0) - COMMON /VALUE2/ ALPHA1,LAMBDA - LOGICAL COEL - REAL*8 CELAMF,RL,RZAMSF - EXTERNAL CELAMF,RL,RZAMSF -* -* Common envelope evolution - entered only when KW1 = 2, 3, 4, 5, 6, 8 or 9. -* -* For simplicity energies are divided by -G. -* - TWOPI = 2.D0*ACOS(-1.D0) - COEL = .FALSE. -* -* Obtain the core masses and radii. -* - KW = KW1 - CALL star(KW1,M01,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS) - CALL hrdiag(M01,AJ1,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS, - & R1,L1,KW1,MC1,RC1,MENV,RENV,K21) - OSPIN1 = JSPIN1/(K21*R1*R1*(M1-MC1)+K3*RC1*RC1*MC1) - MENVD = MENV/(M1-MC1) - RZAMS = RZAMSF(M01) - LAMB1 = CELAMF(KW,M01,L1,R1,RZAMS,MENVD,LAMBDA) - KW = KW2 - CALL star(KW2,M02,M2,TM2,TN,TSCLS2,LUMS,GB,ZPARS) - CALL hrdiag(M02,AJ2,M2,TM2,TN,TSCLS2,LUMS,GB,ZPARS, - & R2,L2,KW2,MC2,RC2,MENV,RENV,K22) - OSPIN2 = JSPIN2/(K22*R2*R2*(M2-MC2)+K3*RC2*RC2*MC2) -* -* Calculate the binding energy of the giant envelope (multiplied by lambda). -* - EBINDI = M1*(M1-MC1)/(LAMB1*R1) -* -* If the secondary star is also giant-like add its envelopes's energy. -* - EORBI = M1*M2/(2.D0*SEP) - IF(KW2.GE.2.AND.KW2.LE.9.AND.KW2.NE.7)THEN - MENVD = MENV/(M2-MC2) - RZAMS = RZAMSF(M02) - LAMB2 = CELAMF(KW,M02,L2,R2,RZAMS,MENVD,LAMBDA) - EBINDI = EBINDI + M2*(M2-MC2)/(LAMB2*R2) -* -* Calculate the initial orbital energy -* - IF(CEFLAG.NE.3) EORBI = MC1*MC2/(2.D0*SEP) - ELSE - IF(CEFLAG.NE.3) EORBI = MC1*M2/(2.D0*SEP) - ENDIF -* -* Allow for an eccentric orbit. -* - ECIRC = EORBI/(1.D0 - ECC*ECC) -* -* Calculate the final orbital energy without coalescence. -* - EORBF = EORBI + EBINDI/ALPHA1 -* -* If the secondary is on the main sequence see if it fills its Roche lobe. -* - IF(KW2.LE.1.OR.KW2.EQ.7)THEN - SEPF = MC1*M2/(2.D0*EORBF) - Q1 = MC1/M2 - Q2 = 1.D0/Q1 - RL1 = RL(Q1) - RL2 = RL(Q2) - IF(RC1/RL1.GE.R2/RL2)THEN -* -* The helium core of a very massive star of type 4 may actually fill -* its Roche lobe in a wider orbit with a very low-mass secondary. -* - IF(RC1.GT.RL1*SEPF)THEN - COEL = .TRUE. - SEPL = RC1/RL1 - ENDIF - ELSE - IF(R2.GT.RL2*SEPF)THEN - COEL = .TRUE. - SEPL = R2/RL2 - ENDIF - ENDIF - IF(COEL)THEN -* - KW = KTYPE(KW1,KW2) - 100 - MC3 = MC1 - IF(KW2.EQ.7.AND.KW.EQ.4) MC3 = MC3 + M2 -* -* Coalescence - calculate final binding energy. -* - EORBF = MAX(MC1*M2/(2.D0*SEPL),EORBI) - EBINDF = EBINDI - ALPHA1*(EORBF - EORBI) - ELSE -* -* Primary becomes a black hole, neutron star, white dwarf or helium star. -* - MF = M1 - M1 = MC1 - CALL star(KW1,M01,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS) - CALL hrdiag(M01,AJ1,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS, - & R1,L1,KW1,MC1,RC1,MENV,RENV,K21) - IF(KW1.GE.13)THEN - CALL kick(KW1,MF,M1,M2,ECC,SEPF,JORB,VS) - IF(ECC.GT.1.D0) GOTO 30 - ENDIF - ENDIF - ELSE -* -* Degenerate or giant secondary. Check if the least massive core fills its -* Roche lobe. -* - SEPF = MC1*MC2/(2.D0*EORBF) - Q1 = MC1/MC2 - Q2 = 1.D0/Q1 - RL1 = RL(Q1) - RL2 = RL(Q2) - IF(RC1/RL1.GE.RC2/RL2)THEN - IF(RC1.GT.RL1*SEPF)THEN - COEL = .TRUE. - SEPL = RC1/RL1 - ENDIF - ELSE - IF(RC2.GT.RL2*SEPF)THEN - COEL = .TRUE. - SEPL = RC2/RL2 - ENDIF - ENDIF -* - IF(COEL)THEN -* -* If the secondary was a neutron star or black hole the outcome -* is an unstable Thorne-Zytkow object that leaves only the core. -* - SEPF = 0.D0 - IF(KW2.GE.13)THEN - MC1 = MC2 - M1 = MC1 - MC2 = 0.D0 - M2 = 0.D0 - KW1 = KW2 - KW2 = 15 - AJ1 = 0.D0 -* -* The envelope mass is not required in this case. -* - GOTO 30 - ENDIF -* - KW = KTYPE(KW1,KW2) - 100 - MC3 = MC1 + MC2 -* -* Calculate the final envelope binding energy. -* - EORBF = MAX(MC1*MC2/(2.D0*SEPL),EORBI) - EBINDF = EBINDI - ALPHA1*(EORBF - EORBI) -* -* Check if we have the merging of two degenerate cores and if so -* then see if the resulting core will survive or change form. -* - IF(KW1.EQ.6.AND.(KW2.EQ.6.OR.KW2.GE.11))THEN - CALL dgcore(KW1,KW2,KW,MC1,MC2,MC3,EBINDF) - ENDIF - IF(KW1.LE.3.AND.M01.LE.ZPARS(2))THEN - IF((KW2.GE.2.AND.KW2.LE.3.AND.M02.LE.ZPARS(2)).OR. - & KW2.EQ.10)THEN - CALL dgcore(KW1,KW2,KW,MC1,MC2,MC3,EBINDF) - IF(KW.GE.10)THEN - KW1 = KW - M1 = MC3 - MC1 = MC3 - IF(KW.LT.15) M01 = MC3 - AJ1 = 0.D0 - MC2 = 0.D0 - M2 = 0.D0 - KW2 = 15 - GOTO 30 - ENDIF - ENDIF - ENDIF -* - ELSE -* -* The cores do not coalesce - assign the correct masses and ages. -* - MF = M1 - M1 = MC1 - CALL star(KW1,M01,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS) - CALL hrdiag(M01,AJ1,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS, - & R1,L1,KW1,MC1,RC1,MENV,RENV,K21) - IF(KW1.GE.13)THEN - CALL kick(KW1,MF,M1,M2,ECC,SEPF,JORB,VS) - IF(ECC.GT.1.D0) GOTO 30 - ENDIF - MF = M2 - KW = KW2 - M2 = MC2 - CALL star(KW2,M02,M2,TM2,TN,TSCLS2,LUMS,GB,ZPARS) - CALL hrdiag(M02,AJ2,M2,TM2,TN,TSCLS2,LUMS,GB,ZPARS, - & R2,L2,KW2,MC2,RC2,MENV,RENV,K22) - IF(KW2.GE.13.AND.KW.LT.13)THEN - CALL kick(KW2,MF,M2,M1,ECC,SEPF,JORB,VS) - IF(ECC.GT.1.D0) GOTO 30 - ENDIF - ENDIF - ENDIF -* - IF(COEL)THEN - MC22 = MC2 - IF(KW.EQ.4.OR.KW.EQ.7)THEN -* If making a helium burning star calculate the fractional age -* depending on the amount of helium that has burnt. - IF(KW1.LE.3)THEN - FAGE1 = 0.D0 - ELSEIF(KW1.GE.6)THEN - FAGE1 = 1.D0 - ELSE - FAGE1 = (AJ1 - TSCLS1(2))/(TSCLS1(13) - TSCLS1(2)) - ENDIF - IF(KW2.LE.3.OR.KW2.EQ.10)THEN - FAGE2 = 0.D0 - ELSEIF(KW2.EQ.7)THEN - FAGE2 = AJ2/TM2 - MC22 = M2 - ELSEIF(KW2.GE.6)THEN - FAGE2 = 1.D0 - ELSE - FAGE2 = (AJ2 - TSCLS2(2))/(TSCLS2(13) - TSCLS2(2)) - ENDIF - ENDIF - ENDIF -* -* Now calculate the final mass following coelescence. This requires a -* Newton-Raphson iteration. -* - IF(COEL)THEN -* -* Calculate the orbital spin just before coalescence. -* - TB = (SEPL/AURSUN)*SQRT(SEPL/(AURSUN*(MC1+MC2))) - OORB = TWOPI/TB -* - XX = 1.D0 + ZPARS(7) - IF(EBINDF.LE.0.D0)THEN - MF = MC3 - GOTO 20 - ELSE - CONST = ((M1+M2)**XX)*(M1-MC1+M2-MC22)*EBINDF/EBINDI - ENDIF -* -* Initial Guess. -* - MF = MAX(MC1 + MC22,(M1 + M2)*(EBINDF/EBINDI)**(1.D0/XX)) - 10 DELY = (MF**XX)*(MF - MC1 - MC22) - CONST -* IF(ABS(DELY/MF**(1.D0+XX)).LE.1.0D-02) GOTO 20 - IF(ABS(DELY/MF).LE.1.0D-03) GOTO 20 - DERI = MF**ZPARS(7)*((1.D0+XX)*MF - XX*(MC1 + MC22)) - DELMF = DELY/DERI - MF = MF - DELMF - GOTO 10 -* -* Set the masses and separation. -* - 20 IF(MC22.EQ.0.D0) MF = MAX(MF,MC1+M2) - M2 = 0.D0 - M1 = MF - KW2 = 15 -* -* Combine the core masses. -* - IF(KW.EQ.2)THEN - CALL star(KW,M1,M1,TM2,TN,TSCLS2,LUMS,GB,ZPARS) - IF(GB(9).GE.MC1)THEN - M01 = M1 - AJ1 = TM2 + (TSCLS2(1) - TM2)*(AJ1-TM1)/(TSCLS1(1) - TM1) - CALL star(KW,M01,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS) - ENDIF - ELSEIF(KW.EQ.7)THEN - M01 = M1 - CALL star(KW,M01,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS) - AJ1 = TM1*(FAGE1*MC1 + FAGE2*MC22)/(MC1 + MC22) - ELSEIF(KW.EQ.4.OR.MC2.GT.0.D0.OR.KW.NE.KW1)THEN - IF(KW.EQ.4) AJ1 = (FAGE1*MC1 + FAGE2*MC22)/(MC1 + MC22) - MC1 = MC1 + MC2 - MC2 = 0.D0 -* -* Obtain a new age for the giant. -* - CALL gntage(MC1,M1,KW,ZPARS,M01,AJ1) - CALL star(KW,M01,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS) - ENDIF - CALL hrdiag(M01,AJ1,M1,TM1,TN,TSCLS1,LUMS,GB,ZPARS, - & R1,L1,KW,MC1,RC1,MENV,RENV,K21) - JSPIN1 = OORB*(K21*R1*R1*(M1-MC1)+K3*RC1*RC1*MC1) - KW1 = KW - ECC = 0.D0 - ELSE -* -* Check if any eccentricity remains in the orbit by first using -* energy to circularise the orbit before removing angular momentum. -* (note this should not be done in case of CE SN ... fix). -* - IF(EORBF.LT.ECIRC)THEN - ECC = SQRT(1.D0 - EORBF/ECIRC) - ELSE - ECC = 0.D0 - ENDIF -* -* Set both cores in co-rotation with the orbit on exit of CE, -* - TB = (SEPF/AURSUN)*SQRT(SEPF/(AURSUN*(M1+M2))) - OORB = TWOPI/TB - JORB = M1*M2/(M1+M2)*SQRT(1.D0-ECC*ECC)*SEPF*SEPF*OORB -* JSPIN1 = OORB*(K21*R1*R1*(M1-MC1)+K3*RC1*RC1*MC1) -* JSPIN2 = OORB*(K22*R2*R2*(M2-MC2)+K3*RC2*RC2*MC2) -* -* or, leave the spins of the cores as they were on entry. -* Tides will deal with any synchronization later. -* - JSPIN1 = OSPIN1*(K21*R1*R1*(M1-MC1)+K3*RC1*RC1*MC1) - JSPIN2 = OSPIN2*(K22*R2*R2*(M2-MC2)+K3*RC2*RC2*MC2) - ENDIF - 30 SEP = SEPF - RETURN - END -*** - - -cc//corerd.f - -*** - REAL*8 FUNCTION CORERD(KW,MC,M0,MFLASH) -* -* A function to determine the radius of the core of a giant-like star. -* NOTE: this is out of date so rc should be obtained using HRDIAG! -* It is still OK to use but bear in mind that the core radius calculated -* for non-degenerate giant cores is only a rough estimate. -* -* Author : C. A. Tout -* Date : 26th February 1997 -* Updated 6/1/98 by J. Hurley -* - IMPLICIT NONE - INTEGER KW - REAL*8 MC,MCH,M0,MFLASH - PARAMETER (MCH = 1.44d0) -* -* First do the black holes and neutron stars. -* - IF(KW.EQ.14)THEN - CORERD = 4.24d-06*MC - ELSEIF(KW.EQ.13)THEN - CORERD = 1.4d-05 -* -* Main sequence stars. -* - ELSEIF(KW.LE.1.OR.KW.EQ.7)THEN - CORERD = 0.d0 -* -* Core-helium-burning stars, FAGB stars and non-degenerate giant cores. -* - ELSEIF(KW.EQ.4.OR.KW.EQ.5.OR.(KW.LE.3.AND.M0.GT.MFLASH))THEN - CORERD = 0.2239d0*MC**0.62d0 -* -* The degenerate giants and white dwarfs. -* - ELSE - CORERD = 0.0115d0*SQRT(MAX(1.48204d-06,(MCH/MC)**(2.d0/3.d0) - & - (MC/MCH)**(2.d0/3.d0))) -* -* Degenerate giants have hot subdwarf cores. -* - IF(KW.LE.9) CORERD = 5.d0*CORERD - ENDIF -* - RETURN - END -*** - - - -cc//dgcore.f - -*** - SUBROUTINE dgcore(kw1,kw2,kw3,m1,m2,m3,ebinde) -* -* A routine to determine the outcome of a collision or coalescence -* of two degenerate cores. -* Entered with kw1,kw2 = 2 or 3 with M <= Mflash, 6, 10, 11 or 12 -* - implicit none -* - integer kw1,kw2,kw3 -* - real*8 m1,m2,m3,ebinde - real*8 r1,r2,r3,mhe,mc,mne,ebindi,ebindf,deleb,de,enuc - real*8 temp,x,y,m0,mflash - real*8 cvhe,cvc,cvne - parameter(cvhe=3.1d+07,cvc=8.27d+06,cvne=7.44d+06) - real*8 ehe,ec,ene - parameter(ehe=5.812d+17,ec=2.21d+17,ene=2.06d+17) - real*8 the,tc,gmr,mch - parameter(the=1.0d+08,tc=1.0d+09,gmr=1.906d+15,mch=1.44d0) -* - real*8 corerd - external corerd -* -* Calculate the core radii setting m0 < mflash using dummy values as we -* know it to be true if kw = 2 or 3. - m0 = 1.d0 - mflash = 2.d0 - r1 = corerd(kw1,m1,m0,mflash) - r2 = corerd(kw2,m2,m0,mflash) - r3 = corerd(kw3,m3,m0,mflash) -* Calculate the initial binding energy of the two seperate cores and the -* difference between this and the final binding energy of the new core. - ebindi = m1*m1/r1 + m2*m2/r2 - ebindf = m3*m3/r3 - deleb = ABS(ebindi - ebindf) -* If an envelope is present reduce its binding energy by the amount -* of energy liberated by the coalescence. - ebinde = MAX(0.d0,ebinde - deleb) - if(kw1.gt.3) goto 90 -* Distribute the mass into core mass groups where mhe represents Helium -* core mass, mc represents Carbon core mass and mne represents a Neon -* core mass or any mass that is all converted Carbon. - mhe = 0.d0 - mc = 0.d0 - mne = 0.d0 - if(kw1.le.3.or.kw1.eq.10)then - mhe = mhe + m1 - elseif(kw1.eq.12)then - mne = mne + m1 - else - mc = mc + m1 - endif - if(kw2.le.3.or.kw2.eq.10)then - mhe = mhe + m2 - elseif(kw2.eq.12)then - mne = mne + m2 - else - mc = mc + m2 - endif -* Calculate the temperature generated by the merging of the cores. - temp = (deleb/(cvhe*mhe+cvc*mc+cvne*mne))*gmr -* -* To decide if He is converted to C we use: -* 3He4 -> C12 , T > 10^8 K , 7.274 Mev released, -* to decide if C is converted further we use: -* 2C12 -> Ne20 + alpha , T > 10^9 K , 4.616 Mev released. -* and to decide if O is converted further we use: -* 2O16 -> P31 + p , T > 10^9 K , 7.677 Mev released. -* To obtain the heat capacity of an O/Ne WD and to gain an idea of the -* energy released from the further processing of an O/Ne WD we use: -* 2Ne20 + gamma -> O16 + Mg24 +gamma , T > 10^9 K , 4.583 Mev released. -* For a CO core the composition is assumed to be 20% C, 80% O and for -* an ONe core 80% O, 20% Ne. -* -* Decide if conversion of elements can take place. -* if(temp.gt.the)then - x = 1.d0 -* else -* x = 0.d0 -* endif -* if(temp.gt.tc)then -* y = 1.d0 -* else - y = 0.d0 -* endif -* Calculate the nuclear energy generated from any element conversion. - enuc = (x*ehe*mhe + y*(ec*mc + ene*mne))/gmr -* Calculate the difference between the binding energy of the star -* (core + envelope) and the nuclear energy. The new star will be -* destroyed in a SN if dE < 0. - de = (ebindf + ebinde) - enuc -* If the star survives and an envelope is present then reduce the -* envelope binding energy by the amount of liberated nuclear energy. -* The envelope will not survive if its binding energy is reduced to <= 0. - if(de.ge.0.d0) ebinde = MAX(0.d0,ebinde - enuc) -* Now determine the final evolution state of the merged core. - if(de.lt.0.d0) kw3 = 15 - if(kw3.eq.3)then - if(x.gt.0.5d0)then - kw3 = 6 - elseif(ebinde.le.0.d0)then - kw3 = 10 - endif - elseif(kw3.eq.4)then - if(x.gt.0.5d0)then - kw3 = 6 - elseif(ebinde.le.0.d0)then - kw3 = 7 - endif - endif - if(kw3.eq.6.and.y.lt.0.5d0)then - if(ebinde.le.0.d0) kw3 = 11 - elseif(kw3.eq.6.and.y.gt.0.5d0)then - if(ebinde.le.0.d0) kw3 = 12 - endif - if(kw3.eq.10.and.x.gt.0.5d0) kw3 = 11 - if(kw3.eq.11.and.y.gt.0.5d0) kw3 = 12 - if(kw3.ge.10.and.kw3.le.12.and.m3.ge.mch) kw3 = 15 -* - if(kw3.eq.15) m3 = 0.d0 - 90 continue -* - return - end -*** - - -cc//evolv2.f - -*** - SUBROUTINE evolv2(kstar,mass0,mass,rad,lumin,massc,radc, - & menv,renv,ospin,epoch,tms, - & tphys,tphysf,dtp,z,zpars,tb,ecc,vkick) - implicit none -*** -* -* B I N A R Y -* *********** -* -* Roche lobe overflow. -* -------------------- -* -* Developed by Jarrod Hurley, IOA, Cambridge. -* ......................................................... -* -* Advice by Christopher Tout, Onno Pols & Sverre Aarseth. -* ++++++++++++++++++++++++++++++++++++++++++++++++++ -* -* Adapted from Aarseth's code 21st September 1996. -* Fully revised on 27th November 1996 to remove vestiges of N-body code and -* incorporate corrections. -* Fully revised on 1st April 1998 to include new stellar evolution formulae -* and associated binary evolution changes. -* Fully revised on 4th July 1998 to include eccentricity, tidal -* circularization, wind accretion, velocity kicks for supernovae and all -* associated orbital momentum changes. -* Revised on 31st October 2000 to upgrade restrictions imposed on the -* timestep owing to magnetic braking and orbital angular momentum changes. -* -*** -* -* See Tout et al., 1997, MNRAS, 291, 732 for a description of many of the -* processes in this code as well as the relevant references mentioned -* within the code. -* -* Reference for the stellar evolution formulae is Hurley, Pols & Tout, -* 2000, MNRAS, 315, 543 (SSE paper). -* Reference for the binary evolution algorithm is Hurley, Tout & Pols, -* 2002, MNRAS, 329, 897 (BSE paper). -* -*** -* -* March 2001 * -* Changes since version 3, i.e. since production of Paper3: -* -* 1) The Eddington limit flag (on/off) has been replaced by an -* Eddington limit multiplicative factor (eddfac). So if you -* want to neglect the Eddington limit you would set eddfac -* to a large value. -* -* 2) To determine whether material transferred during RLOF forms -* an accretion disk around the secondary or hits the secondary -* in a direct stream we calculate a minimum radial distance, rmin, -* of the mass stream from the secondary. This is taken from eq.(1) -* of Ulrich & Burger (1976, ApJ, 206, 509) which they fitted to -* the calculations of Lubow & Shu (1974, ApJ, 198, 383). -* If rmin is less than the radius of the secondary then an -* accretion disk is not formed. -* Note that the formula for rmin given by Ulrich & Burger is valid -* for all q whereas that given by Nelemans et al. (2001, A&A, -* submitted) in their eq.(6) is only valid for q < 1 where -* they define q = Mdonor/Maccretor, i.e. DD systems. -* -* 3) The changes to orbital and spin angular momentum owing to -* RLOF mass transfer have been improved, and an new input option -* now exists. -* When mass is lost from the system during RLOF there are now -* three choices as to how the orbital angular momentum is -* affected: a) the lost material carries with it a fraction -* gamma of the orbital angular momentum, i.e. -* dJorb = gamma*dm*a^2*omega_orb; b) the material carries with it -* the specific angular momentum of the primary, i.e. -* dJorb = dm*a_1^2*omega_orb; or c) assume the material is lost -* from the system as if a wind from the secondary, i.e. -* dJorb = dm*a_2^2*omega_orb. -* The parameter gamma is an input option. -* Choice c) is used if the mass transfer is super-Eddington -* or the system is experiencing novae eruptions. -* In all other cases choice a) is used if gamma > 0.0, b) if -* gamma = -1.0 and c) is used if gamma = -2.0. -* The primary spin angular momentum is reduced by an amount -* dm1*r_1^2*omega_1 when an amount of mass dm1 is transferred -* from the primary. -* If the secondary accretes through a disk then its spin -* angular momentum is altered by assuming that the material -* falls onto the star from the inner edge of a Keplerian -* disk and that the system is in a steady state, i.e. -* an amount dm2*SQRT(G*m_2*r_2). -* If there is no accretion disk then we calculate the angular -* momentum of the transferred material by using the radius at -* at which the disk would have formed (rdisk = 1.7*rmin, see -* Ulrich & Burger 1976) if allowed, i.e. the angular momentum -* of the inner Lagrangian point, and add this directly to -* the secondary, i.e. an amount dm2*SQRT(G*m_2*rdisk). -* Total angular momentum is conserved in this model. -* -* 4) Now using q_crit = 3.0 for MS-MS Roche systems (previously we -* had nothing). This corresponds roughly to R proportional to M^5 -* which should be true for the majority of the MS (varies from -* (M^17 -> M^2). If q > q_crit then contact occurs. -* For CHeB primaries we also take q_crit = 3.0 and allow -* common-envelope to occur if this is exceeded. -* -* 5) The value of lambda used in calculations of the envelope binding -* energy for giants in common-envelope is now variable (see function -* in zfuncs). The lambda function has been fitted by Onno to detailed -* models ... he will write about this soon! -* -* 6) Note that eq.42 in the paper is missing a SQRT around the -* MR^2/a^5 part. This needs to be corrected in any code update -* paper with a thanks to Jeremy Sepinsky (student at NorthWestern). -* It is ok in the code. -* -* March 2003 * -* New input options added: -* -* ifflag - for the mass of a WD you can choose to use the mass that -* results from the evolution algorithm (basically a competition -* between core-mass growth and envelope mass-loss) or use the IFMR -* proposed by Han, Podsiadlowski & Eggleton, 1995, MNRAS, 272, 800 -* [>0 activates HPE IFMR]. -* -* wdflag - for the cooling of WDs you can choose to use either the standard -* Mestel cooling law (see SSE paper) or a modified-Mestel law that -* is better matched to detailed models (provided by Brad Hansen -* ... see Hurley & Shara, 2003, ApJ, May 20, in press) -* [>0 activates modified-Mestel]. -* -* bhflag - choose whether or not black holes should get velocity kicks -* at formation -* [0= no kick; >0 kick]. -* -* nsflag - for the mass of neutron stars and black holes you can use either -* the SSE prescription or the prescription presented by -* Belczynski et al. 2002, ApJ, 572, 407 who found that SSE was -* underestimating the masses of these stars. In either case you also -* need to set the maximum NS mass (mxns) for the prescription -* [0= SSE, mxns=1.8; >0 Belczynski, mxns=3.0]. -* -* Sept 2004 * -* Input options added/changed: -* -* ceflag - set to 3 this uses de Kool (or Podsiadlowski) CE prescription, -* other options, such as Yungelson, could be added as well. -* -* hewind - factor to control the amount of He star mass-loss, i.e. -* 1.0e-13*hewind*L^(2/3) gives He star mass-loss. -* -* -* ++++++++++++++++++++++++++++++++++++++++++++++++++ -*** -* - INTEGER loop,iter,intpol,k,ip,jp,j1,j2 - PARAMETER(loop=20000) - INTEGER kstar(2),kw,kst,kw1,kw2,kmin,kmax - INTEGER ktype(0:14,0:14) - COMMON /TYPES/ ktype - INTEGER ceflag,tflag,ifflag,nsflag,wdflag - COMMON /FLAGS/ ceflag,tflag,ifflag,nsflag,wdflag -* - REAL*8 km,km0,tphys,tphys0,dtm0,tphys00 - REAL*8 tphysf,dtp,tsave - REAL*8 aj(2),aj0(2),epoch(2),tms(2),tbgb(2),tkh(2),dtmi(2) - REAL*8 mass0(2),mass(2),massc(2),menv(2),mass00(2),mcxx(2) - REAL*8 rad(2),rol(2),rol0(2),rdot(2),radc(2),renv(2),radx(2) - REAL*8 lumin(2),k2str(2),q(2),dms(2),dmr(2),dmt(2),vkick(2) - REAL*8 dml,vorb2,vwind2,omv2,ivsqm,lacc,vs(3) - REAL*8 sep,dr,tb,dme,tdyn,taum,dm1,dm2,dmchk,qc,dt,pd,rlperi - REAL*8 m1ce,m2ce,mch,tmsnew,dm22,mew - PARAMETER(mch=1.44d0) - REAL*8 yeardy,aursun - PARAMETER(yeardy=365.24d0,aursun=214.95d0) - REAL*8 acc1,tiny - PARAMETER(acc1=3.920659d+08,tiny=1.0d-14) - REAL*8 ecc,ecc1,tc,tcirc,ttid,ecc2,omecc2,sqome2,sqome3,sqome5 - REAL*8 f1,f2,f3,f4,f5,f,raa2,raa6,eqspin,rg2,tcqr - REAL*8 k3,mr23yr,twopi - PARAMETER(k3=0.21d0,mr23yr=0.4311d0) - REAL*8 jspin(2),ospin(2),jorb,oorb,jspbru,ospbru - REAL*8 delet,delet1,dspint(2),djspint(2),djtx(2) - REAL*8 dtj,djorb,djgr,djmb,djt,djtt,rmin,rdisk - REAL*8 neta,bwind,hewind,mxns - COMMON /VALUE1/ neta,bwind,hewind,mxns - REAL*8 beta,xi,acc2,epsnov,eddfac,gamma - COMMON /VALUE5/ beta,xi,acc2,epsnov,eddfac,gamma -* - REAL*8 z,tm,tn,m0,mt,rm,lum,mc,rc,me,re,k2,age,dtm,dtr - REAL*8 tscls(20),lums(10),GB(10),zpars(20) - REAL*8 zero,ngtv,ngtv2,mt2,rrl1,rrl2,mcx,teff1,teff2 - REAL*8 mass1i,mass2i,tbi,ecci - LOGICAL coel,com,prec,inttry,change,snova,sgl,bsymb,esymb,bss - LOGICAL supedd,novae,disk - LOGICAL isave,iplot - REAL*8 rl,mlwind,vrotf,corerd - EXTERNAL rl,mlwind,vrotf,corerd - REAL bcm(50000,34),bpp(80,10) - COMMON /BINARY/ bcm,bpp -* -* Save the initial state. -* - mass1i = mass0(1) - mass2i = mass0(2) - tbi = tb - ecci = ecc -* - zero = 0.d0 - ngtv = -1.d0 - ngtv2 = -2.d0 - twopi = 2.d0*ACOS(-1.d0) -* -* Initialize the parameters. -* - kmin = 1 - kmax = 2 - sgl = .false. - mt2 = MIN(mass(1),mass(2)) - kst = 0 -* - if(mt2.lt.tiny.or.tb.le.0.d0)then - sgl = .true. - if(mt2.lt.tiny)then - mt2 = 0.d0 - if(mass(1).lt.tiny)then - if(tphys.lt.tiny)then - mass0(1) = 0.01d0 - mass(1) = mass0(1) - kst = 1 - else - kmin = 2 - lumin(1) = 1.0d-10 - rad(1) = 1.0d-10 - massc(1) = 0.d0 - dmt(1) = 0.d0 - dmr(1) = 0.d0 - endif - ospin(1) = 1.0d-10 - jspin(1) = 1.0d-10 - else - if(tphys.lt.tiny)then - mass0(2) = 0.01d0 - mass(2) = mass0(2) - kst = 2 - else - kmax = 1 - lumin(2) = 1.0d-10 - rad(2) = 1.0d-10 - massc(2) = 0.d0 - dmt(2) = 0.d0 - dmr(2) = 0.d0 - endif - ospin(2) = 1.0d-10 - jspin(2) = 1.0d-10 - endif - endif - ecc = -1.d0 - tb = 0.d0 - sep = 1.0d+10 - oorb = 0.d0 - jorb = 0.d0 - if(ospin(1).lt.0.0) ospin(1) = 1.0d-10 - if(ospin(2).lt.0.0) ospin(2) = 1.0d-10 - q(1) = 1.0d+10 - q(2) = 1.0d+10 - rol(1) = 1.0d+10 - rol(2) = 1.0d+10 - else - tb = tb/yeardy - sep = aursun*(tb*tb*(mass(1) + mass(2)))**(1.d0/3.d0) - oorb = twopi/tb - jorb = mass(1)*mass(2)/(mass(1)+mass(2)) - & *SQRT(1.d0-ecc*ecc)*sep*sep*oorb - if(ospin(1).lt.0.d0) ospin(1) = oorb - if(ospin(2).lt.0.d0) ospin(2) = oorb - endif -* - do 500 , k = kmin,kmax - age = tphys - epoch(k) - CALL star(kstar(k),mass0(k),mass(k),tm,tn,tscls,lums,GB,zpars) - CALL hrdiag(mass0(k),age,mass(k),tm,tn,tscls,lums,GB,zpars, - & rm,lum,kstar(k),mc,rc,me,re,k2) - aj(k) = age - epoch(k) = tphys - age - rad(k) = rm - lumin(k) = lum - massc(k) = mc - radc(k) = rc - menv(k) = me - renv(k) = re - k2str(k) = k2 - tms(k) = tm - tbgb(k) = tscls(1) -* - if(tphys.lt.tiny.and.ospin(k).le.0.001d0)then - ospin(k) = 45.35d0*vrotf(mass(k))/rm - endif - jspin(k) = ospin(k)*(k2*rm*rm*(mass(k)-mc)+k3*rc*rc*mc) - if(.not.sgl)then - q(k) = mass(k)/mass(3-k) - rol(k) = rl(q(k))*sep - endif - rol0(k) = rol(k) - dmr(k) = 0.d0 - dmt(k) = 0.d0 - djspint(k) = 0.d0 - dtmi(k) = 1.0d+06 -* - 500 continue -* - if(mt2.lt.tiny)then - sep = 0.d0 - if(kst.gt.0)then - mass0(kst) = 0.d0 - mass(kst) = 0.d0 - kmin = 3 - kst - kmax = kmin - endif - endif -* -* On the first entry the previous timestep is zero to prevent mass loss. -* - dtm = 0.d0 - delet = 0.d0 - djorb = 0.d0 - bss = .false. -* -* Setup variables which control the output (if it is required). -* - ip = 0 - jp = 0 - tsave = tphys - isave = .true. - iplot = .false. - if(dtp.le.0.d0)then - iplot = .true. - isave = .false. - tsave = tphysf - elseif(dtp.gt.tphysf)then - isave = .false. - tsave = tphysf - endif - if(tphys.ge.tphysf) goto 140 -* - 4 iter = 0 - intpol = 0 - inttry = .false. - change = .false. - prec = .false. - snova = .false. - coel = .false. - com = .false. - bsymb = .false. - esymb = .false. - tphys0 = tphys - ecc1 = ecc - j1 = 1 - j2 = 2 - if(kstar(1).ge.10.and.kstar(1).le.14) dtmi(1) = 0.01d0 - if(kstar(2).ge.10.and.kstar(2).le.14) dtmi(2) = 0.01d0 - dm1 = 0.d0 - dm2 = 0.d0 -* - 5 kw1 = kstar(1) - kw2 = kstar(2) -* - dt = 1.0d+06*dtm - eqspin = 0.d0 - djtt = 0.d0 -* - if(intpol.eq.0.and.ABS(dtm).gt.tiny.and..not.sgl)then - vorb2 = acc1*(mass(1)+mass(2))/sep - ivsqm = 1.d0/SQRT(1.d0-ecc*ecc) - do 501 , k = 1,2 -* -* Calculate wind mass loss from the previous timestep. -* - if(neta.gt.tiny)then - rlperi = rol(k)*(1.d0-ecc) - dmr(k) = mlwind(kstar(k),lumin(k),rad(k),mass(k), - & massc(k),rlperi,z) -* -* Calculate how much of wind mass loss from companion will be -* accreted (Boffin & Jorissen, A&A 1988, 205, 155). -* - vwind2 = 2.d0*beta*acc1*mass(k)/rad(k) - omv2 = (1.d0 + vorb2/vwind2)**(3.d0/2.d0) - dmt(3-k) = ivsqm*acc2*dmr(k)*((acc1*mass(3-k)/vwind2)**2) - & /(2.d0*sep*sep*omv2) - dmt(3-k) = MIN(dmt(3-k),0.8d0*dmr(k)) - else - dmr(k) = 0.d0 - dmt(3-k) = 0.d0 - endif - 501 continue -* -* Diagnostic for Symbiotic-type stars. -* - if(neta.gt.tiny.and..not.esymb)then - lacc = 3.14d+07*mass(j2)*dmt(j2)/rad(j2) - lacc = lacc/lumin(j1) - if((lacc.gt.0.01d0.and..not.bsymb).or. - & (lacc.lt.0.01d0.and.bsymb))then - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - if(bsymb)then - bpp(jp,10) = 13.0 - esymb = .true. - else - bpp(jp,10) = 12.0 - bsymb = .true. - endif - endif - endif -* -* Calculate orbital angular momentum change due to wind mass loss. -* - ecc2 = ecc*ecc - omecc2 = 1.d0 - ecc2 - sqome2 = SQRT(omecc2) -* - djorb = ((dmr(1)+q(1)*dmt(1))*mass(2)*mass(2) + - & (dmr(2)+q(2)*dmt(2))*mass(1)*mass(1))* - & sep*sep*sqome2*oorb/(mass(1)+mass(2))**2 - delet = ecc*(dmt(1)*(0.5d0/mass(1) + 1.d0/(mass(1)+mass(2))) + - & dmt(2)*(0.5d0/mass(2) + 1.d0/(mass(1)+mass(2)))) -* -* For very close systems include angular momentum loss owing to -* gravitational radiation. -* - if(sep.le.10.d0)then - djgr = 8.315d-10*mass(1)*mass(2)*(mass(1)+mass(2))/ - & (sep*sep*sep*sep) - f1 = (19.d0/6.d0) + (121.d0/96.d0)*ecc2 - sqome5 = sqome2**5 - delet1 = djgr*ecc*f1/sqome5 - djgr = djgr*jorb*(1.d0+0.875d0*ecc2)/sqome5 - djorb = djorb + djgr - delet = delet + delet1 - endif -* - do 502 , k = 1,2 -* -* Calculate change in the intrinsic spin of the star. -* - djtx(k) = (2.d0/3.d0)*xi*dmt(k)*rad(3-k)*rad(3-k)*ospin(3-k) - djspint(k) = (2.d0/3.d0)*(dmr(k)*rad(k)*rad(k)*ospin(k)) - - & djtx(k) -* -* Include magnetic braking for stars that have appreciable convective -* envelopes. This includes MS stars with M < 1.25, HG stars near the GB -* and giants. MB is not allowed for fully convective MS stars. -* - if(mass(k).gt.0.35d0.and.kstar(k).lt.10)then - djmb = 5.83d-16*menv(k)*(rad(k)*ospin(k))**3/mass(k) - djspint(k) = djspint(k) + djmb -* -* Limit to a 3% angular momentum change for the star owing to MB. -* This is found to work best with the maximum iteration of 20000, -* i.e. does not create an excessive number of iterations, while not -* affecting the evolution outcome when compared with a 2% restriction. -* - if(djmb.gt.tiny)then - dtj = 0.03d0*jspin(k)/ABS(djmb) - dt = MIN(dt,dtj) - endif - endif -* -* Calculate circularization, orbital shrinkage and spin up. -* - dspint(k) = 0.d0 - if(((kstar(k).le.9.and.rad(k).ge.0.01d0*rol(k)).or. - & (kstar(k).ge.10.and.k.eq.j1)).and.tflag.gt.0)then -* - raa2 = (rad(k)/sep)**2 - raa6 = raa2**3 -* -* Hut's polynomials. -* - f5 = 1.d0+ecc2*(3.d0+ecc2*0.375d0) - f4 = 1.d0+ecc2*(1.5d0+ecc2*0.125d0) - f3 = 1.d0+ecc2*(3.75d0+ecc2*(1.875d0+ecc2*7.8125d-02)) - f2 = 1.d0+ecc2*(7.5d0+ecc2*(5.625d0+ecc2*0.3125d0)) - f1 = 1.d0+ecc2*(15.5d0+ecc2*(31.875d0+ecc2*(11.5625d0 - & +ecc2*0.390625d0))) -* - if((kstar(k).eq.1.and.mass(k).ge.1.25d0).or. - & kstar(k).eq.4.or.kstar(k).eq.7)then -* -* Radiative damping (Zahn, 1977, A&A, 57, 383 and 1975, A&A, 41, 329). -* - tc = 1.592d-09*(mass(k)**2.84d0) - f = 1.9782d+04*SQRT((mass(k)*rad(k)*rad(k))/sep**5)* - & tc*(1.d0+q(3-k))**(5.d0/6.d0) - tcqr = f*q(3-k)*raa6 - rg2 = k2str(k) - elseif(kstar(k).le.9)then -* -* Convective damping (Hut, 1981, A&A, 99, 126). -* - tc = mr23yr*(menv(k)*renv(k)*(rad(k)-0.5d0*renv(k))/ - & (3.d0*lumin(k)))**(1.d0/3.d0) - ttid = twopi/(1.0d-10 + ABS(oorb - ospin(k))) - f = MIN(1.d0,(ttid/(2.d0*tc)**2)) - tcqr = 2.d0*f*q(3-k)*raa6*menv(k)/(21.d0*tc*mass(k)) - rg2 = (k2str(k)*(mass(k)-massc(k)))/mass(k) - else -* -* Degenerate damping (Campbell, 1984, MNRAS, 207, 433) -* - f = 7.33d-09*(lumin(k)/mass(k))**(5.d0/7.d0) - tcqr = f*q(3-k)*q(3-k)*raa2*raa2/(1.d0+q(3-k)) - rg2 = k3 - endif -* -* Circularization. -* - sqome3 = sqome2**3 - delet1 = 27.d0*tcqr*(1.d0+q(3-k))*raa2*(ecc/sqome2**13)* - & (f3 - (11.d0/18.d0)*sqome3*f4*ospin(k)/oorb) - tcirc = ecc/(ABS(delet1) + 1.0d-20) - delet = delet + delet1 -* -* Spin up of star. -* - dspint(k) = (3.d0*q(3-k)*tcqr/(rg2*omecc2**6))* - & (f2*oorb - sqome3*f5*ospin(k)) -* -* Calculate the equilibrium spin at which no angular momentum -* can be transferred. -* - eqspin = oorb*f2/(sqome3*f5) -* -* Calculate angular momentum change for the star owing to tides. -* - djt = (k2str(k)*(mass(k)-massc(k))*rad(k)*rad(k) + - & k3*massc(k)*radc(k)*radc(k))*dspint(k) - if(kstar(k).le.6.or.ABS(djt)/jspin(k).gt.0.1d0)then - djtt = djtt + djt - endif - endif - 502 continue -* -* Limit to 2% orbital angular momentum change. -* - djtt = djtt + djorb - if(ABS(djtt).gt.tiny)then - dtj = 0.02d0*jorb/ABS(djtt) - dt = MIN(dt,dtj) - endif - dtm = dt/1.0d+06 -* - elseif(ABS(dtm).gt.tiny.and.sgl)then - do 503 , k = kmin,kmax - if(neta.gt.tiny)then - rlperi = 0.d0 - dmr(k) = mlwind(kstar(k),lumin(k),rad(k),mass(k), - & massc(k),rlperi,z) - else - dmr(k) = 0.d0 - endif - dmt(k) = 0.d0 - djspint(k) = (2.d0/3.d0)*dmr(k)*rad(k)*rad(k)*ospin(k) - if(mass(k).gt.0.35d0.and.kstar(k).lt.10)then - djmb = 5.83d-16*menv(k)*(rad(k)*ospin(k))**3/mass(k) - djspint(k) = djspint(k) + djmb - if(djmb.gt.tiny)then - dtj = 0.03d0*jspin(k)/ABS(djmb) - dt = MIN(dt,dtj) - endif - endif - 503 continue - dtm = dt/1.0d+06 - endif -* - do 504 , k = kmin,kmax -* - dms(k) = (dmr(k) - dmt(k))*dt - if(kstar(k).lt.10)then - dml = mass(k) - massc(k) - if(dml.lt.dms(k))then - dml = MAX(dml,2.d0*tiny) - dtm = (dml/dms(k))*dtm - if(k.eq.2) dms(1) = dms(1)*dml/dms(2) - dms(k) = dml - dt = 1.0d+06*dtm - endif -* -* Limit to 1% mass loss. -* - if(dms(k).gt.0.01d0*mass(k))then - dtm = 0.01d0*mass(k)*dtm/dms(k) - if(k.eq.2) dms(1) = dms(1)*0.01d0*mass(2)/dms(2) - dms(k) = 0.01d0*mass(k) - dt = 1.0d+06*dtm - endif - endif -* - 504 continue -* -* Update mass and intrinsic spin (checking that the star is not spun -* past the equilibrium) and reset epoch for a MS (and possibly a HG) star. -* - do 505 , k = kmin,kmax -* - if(eqspin.gt.0.d0.and.ABS(dspint(k)).gt.tiny)then - if(intpol.eq.0)then - if(dspint(k).ge.0.d0)then - dspint(k) = MIN(dspint(k),(eqspin-ospin(k))/dt) - else - dspint(k) = MAX(dspint(k),(eqspin-ospin(k))/dt) - endif - djt = (k2str(k)*(mass(k)-massc(k))*rad(k)*rad(k) + - & k3*massc(k)*radc(k)*radc(k))*dspint(k) - djorb = djorb + djt - djspint(k) = djspint(k) - djt - endif - endif -* - jspin(k) = MAX(1.0d-10,jspin(k) - djspint(k)*dt) -* -* Ensure that the star does not spin up beyond break-up. -* - ospbru = twopi*SQRT(mass(k)*aursun**3/rad(k)**3) - jspbru = (k2str(k)*(mass(k)-massc(k))*rad(k)*rad(k) + - & k3*massc(k)*radc(k)*radc(k))*ospbru - if(jspin(k).gt.jspbru.and.ABS(dtm).gt.tiny)then - mew = 1.d0 - if(djtx(k).gt.0.d0)then - mew = MIN(mew,(jspin(k) - jspbru)/djtx(k)) - endif - jspin(k) = jspbru -* If excess material should not be accreted, activate next line. -* dms(k) = dms(k) + (1.d0 - mew)*dmt(k)*dt - endif -* - if(ABS(dms(k)).gt.tiny)then - mass(k) = mass(k) - dms(k) - if(kstar(k).le.2.or.kstar(k).eq.7)then - m0 = mass0(k) - mass0(k) = mass(k) - CALL star(kstar(k),mass0(k),mass(k),tm,tn,tscls, - & lums,GB,zpars) - if(kstar(k).eq.2)then - if(GB(9).lt.massc(k).or.m0.gt.zpars(3))then - mass0(k) = m0 - else - epoch(k) = tm + (tscls(1) - tm)*(aj(k)-tms(k))/ - & (tbgb(k) - tms(k)) - epoch(k) = tphys - epoch(k) - endif - else - epoch(k) = tphys - aj(k)*tm/tms(k) - endif - endif - endif -* - 505 continue -* - if(.not.sgl)then -* - ecc1 = ecc1 - delet*dt - ecc = MAX(ecc1,0.d0) - if(ecc.lt.1.0d-10) ecc = 0.d0 -* - if(ecc.ge.1.d0) goto 135 -* - jorb = jorb - djorb*dt - sep = (mass(1) + mass(2))*jorb*jorb/ - & ((mass(1)*mass(2)*twopi)**2*aursun**3*(1.d0-ecc*ecc)) - tb = (sep/aursun)*SQRT(sep/(aursun*(mass(1)+mass(2)))) - oorb = twopi/tb - endif -* -* Advance the time. -* - if(intpol.eq.0)then - tphys0 = tphys - dtm0 = dtm - endif - tphys = tphys + dtm -* - do 6 , k = kmin,kmax -* -* Acquire stellar parameters (M, R, L, Mc & K*) at apparent evolution age. -* - age = tphys - epoch(k) - aj0(k) = age - kw = kstar(k) - m0 = mass0(k) - mt = mass(k) - mc = massc(k) - if(intpol.eq.0) mcxx(k) = mc - if(intpol.gt.0) mc = mcxx(k) - mass00(k) = m0 -* -* Masses over 100Msun should probably not be trusted in the -* evolution formulae. -* - if(mt.gt.100.d0)then - WRITE(99,*)' MASS EXCEEDED ',mass1i,mass2i,tbi,ecci,mt - goto 140 - endif -* - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - CALL hrdiag(m0,age,mt,tm,tn,tscls,lums,GB,zpars, - & rm,lum,kw,mc,rc,me,re,k2) -* - if(kw.ne.15)then - ospin(k) = jspin(k)/(k2*(mt-mc)*rm*rm+k3*mc*rc*rc) - endif -* -* At this point there may have been a supernova. -* - if(kw.ne.kstar(k).and.kstar(k).le.12.and. - & (kw.eq.13.or.kw.eq.14))then - if(sgl)then - CALL kick(kw,mass(k),mt,0.d0,0.d0,-1.d0,0.d0,vs) - vkick(k) = dsqrt(vs(1)*vs(1)+vs(2)*vs(2)+vs(3)*vs(3)) - else - CALL kick(kw,mass(k),mt,mass(3-k),ecc,sep,jorb,vs) - vkick(k) = dsqrt(vs(1)*vs(1)+vs(2)*vs(2)+vs(3)*vs(3)) - if(ecc.gt.1.d0)then - kstar(k) = kw - mass(k) = mt - epoch(k) = tphys - age - goto 135 - endif - tb = (sep/aursun)*SQRT(sep/(aursun*(mt+mass(3-k)))) - oorb = twopi/tb - endif - snova = .true. - endif -* - if(kw.ne.kstar(k))then - change = .true. - mass(k) = mt - dtmi(k) = 0.01d0 - if(kw.eq.15)then - kstar(k) = kw - goto 135 - endif - mass0(k) = m0 - epoch(k) = tphys - age - if(kw.gt.6.and.kstar(k).le.6)then - bsymb = .false. - esymb = .false. - endif - endif -* -* Force new NS or BH to have a second period. -* - if(kstar(k).eq.13.or.kstar(k).eq.14)then - if(tphys-epoch(k).lt.tiny)then - ospin(k) = 2.0d+08 - jspin(k) = k3*rc*rc*mc*ospin(k) - endif - endif -* -* Set radius derivative for later interpolation. -* - if(ABS(dtm).gt.tiny)then - rdot(k) = ABS(rm - rad(k))/dtm - else - rdot(k) = 0.d0 - endif -* -* Base new time scale for changes in radius & mass on stellar type. -* - dt = dtmi(k) - CALL deltat(kw,age,tm,tn,tscls,dt,dtr) -* -* Choose minimum of time-scale and remaining interval. -* - dtmi(k) = MIN(dt,dtr) -* -* Save relevent solar quantities. -* - aj(k) = age - kstar(k) = kw - rad(k) = rm - lumin(k) = lum - massc(k) = mc - radc(k) = rc - menv(k) = me - renv(k) = re - k2str(k) = k2 - tms(k) = tm - tbgb(k) = tscls(1) -* -* Check for blue straggler formation. -* - if(kw.le.1.and.tm.lt.tphys.and..not.bss)then - bss = .true. - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 14.0 - endif -* - 6 continue -* - if(.not.sgl)then -* -* Determine the mass ratios. -* - do 506 , k = 1,2 - q(k) = mass(k)/mass(3-k) - 506 continue -* -* Determine the Roche lobe radii and adjust the radius derivative. -* - do 507 , k = 1,2 - rol(k) = rl(q(k))*sep - if(ABS(dtm).gt.tiny)then - rdot(k) = rdot(k) + (rol(k) - rol0(k))/dtm - rol0(k) = rol(k) - endif - 507 continue - else - do 508 , k = kmin,kmax - rol(k) = 10000.d0*rad(k) - 508 continue - endif -* - if((tphys.lt.tiny.and.ABS(dtm).lt.tiny.and. - & (mass2i.lt.0.1d0.or..not.sgl)).or.snova)then - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 1.0 - if(snova)then - bpp(jp,10) = 2.0 - dtm = 0.d0 - goto 4 - endif - endif -* - if((isave.and.tphys.ge.tsave).or.iplot)then - if(sgl.or.(rad(1).lt.rol(1).and.rad(2).lt.rol(2)). - & or.tphys.lt.tiny)then - ip = ip + 1 - bcm(ip,1) = tphys - bcm(ip,2) = float(kstar(1)) - bcm(ip,3) = mass0(1) - bcm(ip,4) = mass(1) - bcm(ip,5) = log10(lumin(1)) - bcm(ip,6) = log10(rad(1)) - teff1 = 1000.d0*((1130.d0*lumin(1)/ - & (rad(1)**2.d0))**(1.d0/4.d0)) - bcm(ip,7) = log10(teff1) - bcm(ip,8) = massc(1) - bcm(ip,9) = radc(1) - bcm(ip,10) = menv(1) - bcm(ip,11) = renv(1) - bcm(ip,12) = epoch(1) - bcm(ip,13) = ospin(1) - bcm(ip,14) = dmt(1) - dmr(1) - bcm(ip,15) = rad(1)/rol(1) - bcm(ip,16) = float(kstar(2)) - bcm(ip,17) = mass0(2) - bcm(ip,18) = mass(2) - bcm(ip,19) = log10(lumin(2)) - bcm(ip,20) = log10(rad(2)) - teff2 = 1000.d0*((1130.d0*lumin(2)/ - & (rad(2)**2.d0))**(1.d0/4.d0)) - bcm(ip,21) = log10(teff2) - bcm(ip,22) = massc(2) - bcm(ip,23) = radc(2) - bcm(ip,24) = menv(2) - bcm(ip,25) = renv(2) - bcm(ip,26) = epoch(2) - bcm(ip,27) = ospin(2) - bcm(ip,28) = dmt(2) - dmr(2) - bcm(ip,29) = rad(2)/rol(2) - bcm(ip,30) = tb - bcm(ip,31) = sep - bcm(ip,32) = ecc - if(isave) tsave = tsave + dtp - endif - endif -* -* If not interpolating set the next timestep. -* - if(intpol.eq.0)then - dtm = MAX(1.0d-07*tphys,MIN(dtmi(1),dtmi(2))) - dtm = MIN(dtm,tsave-tphys) - if(iter.eq.0) dtm0 = dtm - endif - if(sgl) goto 98 -* -* Set j1 to the donor - the primary -* and j2 to the accretor - the secondary. -* - if(intpol.eq.0)then - if(rad(1)/rol(1).ge.rad(2)/rol(2))then - j1 = 1 - j2 = 2 - else - j1 = 2 - j2 = 1 - endif - endif -* -* Test whether Roche lobe overflow has begun. -* - if(rad(j1).gt.rol(j1))then -* -* Interpolate back until the primary is just filling its Roche lobe. -* - if(rad(j1).ge.1.002d0*rol(j1))then - if(intpol.eq.0) tphys00 = tphys - intpol = intpol + 1 - if(iter.eq.0) goto 7 - if(inttry) goto 7 - if(intpol.ge.100)then - WRITE(99,*)' INTPOL EXCEEDED ',mass1i,mass2i,tbi,ecci - goto 140 - endif - dr = rad(j1) - 1.001d0*rol(j1) - if(ABS(rdot(j1)).lt.tiny.or.prec)then - goto 7 - endif - dtm = -dr/ABS(rdot(j1)) - if(ABS(tphys0-tphys).gt.tiny) dtm = MAX(dtm,tphys0-tphys) - if(kstar(1).ne.kw1)then - kstar(1) = kw1 - mass0(1) = mass00(1) - epoch(1) = tphys - aj0(1) - endif - if(kstar(2).ne.kw2)then - kstar(2) = kw2 - mass0(2) = mass00(2) - epoch(2) = tphys - aj0(2) - endif - change = .false. - else -* -* Enter Roche lobe overflow -* - if(tphys.ge.tphysf) goto 140 - goto 7 - endif - else -* -* Check if already interpolating. -* - if(intpol.gt.0)then - intpol = intpol + 1 - if(intpol.ge.80)then - inttry = .true. - endif - if(ABS(rdot(j1)).lt.tiny)then - prec = .true. - dtm = 1.0d-07*tphys - else - dr = rad(j1) - 1.001d0*rol(j1) - dtm = -dr/ABS(rdot(j1)) - endif - if((tphys+dtm).ge.tphys00)then -* -* If this occurs then most likely the star is a high mass type 4 -* where the radius can change very sharply or possibly there is a -* discontinuity in the radius as a function of time and HRDIAG -* needs to be checked! -* - dtm = 0.5d0*(tphys00 - tphys0) - dtm = MAX(dtm,1.0d-10) - prec = .true. - endif - tphys0 = tphys - endif - endif -* -* Check for collision at periastron. -* - pd = sep*(1.d0 - ecc) - if(pd.lt.(rad(1)+rad(2)).and.intpol.eq.0) goto 130 -* -* Go back for the next step or interpolation. -* - 98 continue - if(tphys.ge.tphysf.and.intpol.eq.0) goto 140 - if(change)then - change = .false. - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 2.0 - endif -* - iter = iter + 1 -* - if(iter.ge.loop)then - WRITE(99,*)' MAXIMUM ITER EXCEEDED ',mass1i,mass2i,tbi,ecci - goto 140 - endif - goto 5 -* -* Set the nuclear timescale in years and slow-down factor. -* - 7 km0 = dtm0*1.0d+03/tb - if(km0.lt.tiny) km0 = 0.5d0 -* -* Force co-rotation of primary and orbit to ensure that the tides do not -* lead to unstable Roche (not currently used). -* -* if(ospin(j1).gt.1.05d0*oorb)then -* ospin(j1) = oorb -* jspin(j1) = (k2str(j1)*rad(j1)*rad(j1)*(mass(j1)-massc(j1))+ -* & k3*radc(j1)*radc(j1)*massc(j1))*ospin(j1) -* endif -* - iter = 0 - coel = .false. - change = .false. - radx(j1) = MAX(radc(j1),rol(j1)) - radx(j2) = rad(j2) -* - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 3.0 -* - if(iplot.and.tphys.gt.tiny)then - ip = ip + 1 - bcm(ip,1) = tphys - bcm(ip,2) = float(kstar(1)) - bcm(ip,3) = mass0(1) - bcm(ip,4) = mass(1) - bcm(ip,5) = log10(lumin(1)) - bcm(ip,6) = log10(rad(1)) - teff1 = 1000.d0*((1130.d0*lumin(1)/ - & (rad(1)**2.d0))**(1.d0/4.d0)) - bcm(ip,7) = log10(teff1) - bcm(ip,8) = massc(1) - bcm(ip,9) = radc(1) - bcm(ip,10) = menv(1) - bcm(ip,11) = renv(1) - bcm(ip,12) = epoch(1) - bcm(ip,13) = ospin(1) - bcm(ip,14) = 0.0 - bcm(ip,15) = rad(1)/rol(1) - bcm(ip,16) = float(kstar(2)) - bcm(ip,17) = mass0(2) - bcm(ip,18) = mass(2) - bcm(ip,19) = log10(lumin(2)) - bcm(ip,20) = log10(rad(2)) - teff2 = 1000.d0*((1130.d0*lumin(2)/ - & (rad(2)**2.d0))**(1.d0/4.d0)) - bcm(ip,21) = log10(teff2) - bcm(ip,22) = massc(2) - bcm(ip,23) = radc(2) - bcm(ip,24) = menv(2) - bcm(ip,25) = renv(2) - bcm(ip,26) = epoch(2) - bcm(ip,27) = ospin(2) - bcm(ip,28) = 0.0 - bcm(ip,29) = rad(2)/rol(2) - bcm(ip,30) = tb - bcm(ip,31) = sep - bcm(ip,32) = ecc - endif -* -* Eddington limit for accretion on to the secondary in one orbit. -* - 8 dme = 2.08d-03*eddfac*(1.d0/(1.d0 + zpars(11)))*rad(j2)*tb - supedd = .false. - novae = .false. - disk = .false. -* -* Determine whether the transferred material forms an accretion -* disk around the secondary or hits the secondary in a direct -* stream, by using eq.(1) of Ulrich & Burger (1976, ApJ, 206, 509) -* fitted to the calculations of Lubow & Shu (1974, ApJ, 198, 383). -* -* if(kstar(j2).ge.10) disk = .true. - rmin = 0.0425d0*sep*(q(j2)*(1.d0+q(j2)))**(1.d0/4.d0) - if(rmin.gt.rad(j2)) disk = .true. -* -* Kelvin-Helmholtz time from the modified classical expression. -* - do 13 , k = 1,2 - tkh(k) = 1.0d+07*mass(k)/(rad(k)*lumin(k)) - if(kstar(k).le.1.or.kstar(k).eq.7.or.kstar(k).ge.10)then - tkh(k) = tkh(k)*mass(k) - else - tkh(k) = tkh(k)*(mass(k) - massc(k)) - endif - 13 continue -* -* Dynamical timescale for the primary. -* - tdyn = 5.05d-05*SQRT(rad(j1)**3/mass(j1)) -* -* Identify special cases. -* - if(kstar(j1).eq.2)then - qc = 4.d0 - elseif(kstar(j1).eq.3.or.kstar(j1).eq.5.or.kstar(j1).eq.6)then -* qc = (1.67d0-zpars(7)+2.d0*(massc(j1)/mass(j1))**5)/2.13d0 -* Alternatively use condition of Hjellming & Webbink, 1987, ApJ, 318, 794. - qc = 0.362 + 1.0/(3.0*(1.0 - massc(j1)/mass(j1))) -* Or allow all cases to avoid common-envelope. -* qc = 100.d0 - elseif(kstar(j1).eq.8.or.kstar(j1).eq.9)then - qc = 0.784d0 - else - qc = 3.d0 - endif -* - if(kstar(j1).eq.0.and.q(j1).gt.0.695d0)then -* -* This will be dynamical mass transfer of a similar nature to -* common-envelope evolution. The result is always a single -* star placed in *2. -* - taum = SQRT(tkh(j1)*tdyn) - dm1 = mass(j1) - if(kstar(j2).le.1)then -* -* Restrict accretion to thermal timescale of secondary. -* - dm2 = taum/tkh(j2)*dm1 - mass(j2) = mass(j2) + dm2 -* -* Rejuvenate if the star is still on the main sequence. -* - mass0(j2) = mass(j2) - CALL star(kstar(j2),mass0(j2),mass(j2),tmsnew,tn, - & tscls,lums,GB,zpars) -* If the star has no convective core then the effective age decreases, -* otherwise it will become younger still. - if(mass(j2).lt.0.35d0.or.mass(j2).gt.1.25d0)then - aj(j2) = tmsnew/tms(j2)*aj(j2)*(mass(j2) - dm2)/mass(j2) - else - aj(j2) = tmsnew/tms(j2)*aj(j2) - endif - epoch(j2) = tphys - aj(j2) - elseif(kstar(j2).le.6)then -* -* Add all the material to the giant's envelope. -* - dm2 = dm1 - mass(j2) = mass(j2) + dm2 - if(kstar(j2).eq.2)then - mass0(j2) = mass(j2) - CALL star(kstar(j2),mass0(j2),mass(j2),tmsnew,tn,tscls, - & lums,GB,zpars) - aj(j2) = tmsnew + tscls(1)*(aj(j2)-tms(j2))/tbgb(j2) - epoch(j2) = tphys - aj(j2) - endif - elseif(kstar(j2).le.12)then -* -* Form a new giant envelope. -* - dm2 = dm1 - kst = ktype(kstar(j1),kstar(j2)) - if(kst.gt.100) kst = kst - 100 - if(kst.eq.4)then - aj(j2) = aj(j2)/tms(j2) - massc(j2) = mass(j2) - endif -* -* Check for planets or low-mass WDs. -* - if((kstar(j2).eq.10.and.mass(j2).lt.0.05d0).or. - & (kstar(j2).ge.11.and.mass(j2).lt.0.5d0))then - kst = kstar(j1) - mass(j1) = mass(j2) + dm2 - mass(j2) = 0.d0 - else - mass(j2) = mass(j2) + dm2 - CALL gntage(massc(j2),mass(j2),kst,zpars, - & mass0(j2),aj(j2)) - epoch(j2) = tphys - aj(j2) - endif - kstar(j2) = kst - else -* -* The neutron star or black hole simply accretes at the Eddington rate. -* - dm2 = MIN(dme*taum/tb,dm1) - if(dm2.lt.dm1) supedd = .true. - mass(j2) = mass(j2) + dm2 - endif - coel = .true. - if(mass(j2).gt.0.d0)then - mass(j1) = 0.d0 - kstar(j1) = 15 - else - kstar(j1) = kstar(j2) - kstar(j2) = 15 - endif - goto 135 - elseif(((ABS(ABS(2*kstar(j1)-11)-3).eq.2.or.kstar(j1).eq.9). - & and.(q(j1).gt.qc.or.radx(j1).le.radc(j1))).or. - & (kstar(j1).eq.2.and.q(j1).gt.qc).or. - & (kstar(j1).eq.4.and.q(j1).gt.qc))then -* -* Common-envelope evolution. -* - m1ce = mass(j1) - m2ce = mass(j2) - CALL comenv(mass0(j1),mass(j1),massc(j1),aj(j1),jspin(j1), - & kstar(j1),mass0(j2),mass(j2),massc(j2),aj(j2), - & jspin(j2),kstar(j2),zpars,ecc,sep,jorb,coel) -* - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - if(kstar(1).eq.15) bpp(jp,2) = mass0(1) - bpp(jp,3) = mass(2) - if(kstar(2).eq.15) bpp(jp,3) = mass0(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 7.0 -* - epoch(j1) = tphys - aj(j1) - if(coel)then - com = .true. - goto 135 - endif - epoch(j2) = tphys - aj(j2) - if(ecc.gt.1.d0)then - if(kstar(1).ge.13)then - rc = corerd(kstar(1),mass(1),mass(1),zpars(2)) - ospin(1) = jspin(1)/(k3*rc*rc*mass(1)) - endif - if(kstar(2).ge.13)then - rc = corerd(kstar(2),mass(2),mass(2),zpars(2)) - ospin(2) = jspin(2)/(k3*rc*rc*mass(2)) - endif - goto 135 - endif -* -* Next step should be made without changing the time. -* - dm1 = m1ce - mass(j1) - dm2 = mass(j2) - m2ce - dm22 = dm2 - dtm = 0.d0 -* -* Reset orbital parameters as separation may have changed. -* - tb = (sep/aursun)*SQRT(sep/(aursun*(mass(1)+mass(2)))) - oorb = twopi/tb - elseif(kstar(j1).ge.10.and.kstar(j1).le.12.and. - & q(j1).gt.0.628d0)then -* -* Dynamic transfer from a white dwarf. Secondary will have KW > 9. -* - taum = SQRT(tkh(j1)*tdyn) - dm1 = mass(j1) - if(eddfac.lt.10.d0)then - dm2 = MIN(dme*taum/tb,dm1) - if(dm2.lt.dm1) supedd = .true. - else - dm2 = dm1 - endif - mass(j2) = mass(j2) + dm2 -* - if(kstar(j1).eq.10.and.kstar(j2).eq.10)then -* -* Assume the energy released by ignition of the triple-alpha reaction -* is enough to destroy the star. -* - kstar(j2) = 15 - mass(j2) = 0.d0 - elseif(kstar(j1).eq.10.or.kstar(j2).eq.10)then -* -* Should be helium overflowing onto a CO or ONe core in which case the -* helium swells up to form a giant envelope so a HeGB star is formed. -* Allowance for the rare case of CO or ONe flowing onto He is made. -* - kst = 9 - if(kstar(j2).eq.10) massc(j2) = dm2 - CALL gntage(massc(j2),mass(j2),kst,zpars,mass0(j2),aj(j2)) - kstar(j2) = kst - epoch(j2) = tphys - aj(j2) - elseif(kstar(j2).le.12)then - mass0(j2) = mass(j2) - if(kstar(j1).eq.12.and.kstar(j2).eq.11)then -* -* Mixture of ONe and CO will result in an ONe product. -* - kstar(j2) = 12 - endif - endif - kstar(j1) = 15 - mass(j1) = 0.d0 -* -* Might be a supernova that destroys the system. -* - if(kstar(j2).le.11.and.mass(j2).gt.mch)then - kstar(j2) = 15 - mass(j2) = 0.d0 - endif - coel = .true. - goto 135 - elseif(kstar(j1).eq.13)then -* -* Gamma ray burster? -* - dm1 = mass(j1) - mass(j1) = 0.d0 - kstar(j1) = 15 - dm2 = dm1 - mass(j2) = mass(j2) + dm2 - kstar(j2) = 14 - coel = .true. - goto 135 - elseif(kstar(j1).eq.14)then -* -* Both stars are black holes. Let them merge quietly. -* - dm1 = mass(j1) - mass(j1) = 0.d0 - kstar(j1) = 15 - dm2 = dm1 - mass(j2) = mass(j2) + dm2 - coel = .true. - goto 135 - else -* -* Mass transfer in one Kepler orbit. -* - dm1 = 3.0d-06*tb*(LOG(rad(j1)/rol(j1))**3)* - & MIN(mass(j1),5.d0)**2 - if(kstar(j1).eq.2)then - mew = (mass(j1) - massc(j1))/mass(j1) - dm1 = MAX(mew,0.01d0)*dm1 - elseif(kstar(j1).ge.10)then -* dm1 = dm1*1.0d+03/MAX(rad(j1),1.0d-04) - dm1 = dm1*1.0d+03*mass(j1)/MAX(rad(j1),1.0d-04) - endif - kst = kstar(j2) -* -* Possibly mass transfer needs to be reduced if primary is rotating -* faster than the orbit (not currently implemented). -* -* spnfac = MIN(3.d0,MAX(ospin(j1)/oorb,1.d0)) -* dm1 = dm1/spnfac**2 -* -* Limit mass transfer to the thermal rate for remaining giant-like stars -* and to the dynamical rate for all others. -* - if(kstar(j1).ge.2.and.kstar(j1).le.9.and.kstar(j1).ne.7)then -*** -* JH_temp ... this may be good for HG RLOF?? -* if(kstar(j1).eq.2)then -* mew = rad(j1)/rol(j1) - 1.d0 -* mew = 2.d0*mew -* dm1 = dm1*10.d0**mew -* endif -*** - dm1 = MIN(dm1,mass(j1)*tb/tkh(j1)) - elseif(rad(j1).gt.10.d0*rol(j1).or.(kstar(j1).le.1.and. - & kstar(j2).le.1.and.q(j1).gt.qc))then -* -* Allow the stars to merge with the product in *1. -* - m1ce = mass(j1) - m2ce = mass(j2) - CALL mix(mass0,mass,aj,kstar,zpars) - dm1 = m1ce - mass(j1) - dm2 = mass(j2) - m2ce -* -* Next step should be made without changing the time. -* - dtm = 0.d0 - epoch(1) = tphys - aj(1) - coel = .true. - goto 135 - else - dm1 = MIN(dm1,mass(j1)*tb/tdyn) - endif -* -* Calculate wind mass loss from the stars during one orbit. -* - vorb2 = acc1*(mass(1)+mass(2))/sep - ivsqm = 1.d0/SQRT(1.d0-ecc*ecc) - do 14 , k = 1,2 - if(neta.gt.tiny)then - rlperi = rol(k)*(1.d0-ecc) - dmr(k) = mlwind(kstar(k),lumin(k),radx(k), - & mass(k),massc(k),rlperi,z) - vwind2 = 2.d0*beta*acc1*mass(k)/radx(k) - omv2 = (1.d0 + vorb2/vwind2)**(3.d0/2.d0) - dmt(3-k) = ivsqm*acc2*dmr(k)*((acc1*mass(3-k)/vwind2)**2) - & /(2.d0*sep*sep*omv2) - dmt(3-k) = MIN(dmt(3-k),dmr(k)) - else - dmr(k) = 0.d0 - dmt(3-k) = 0.d0 - endif - 14 continue -* - do 15 , k = 1,2 - dms(k) = (dmr(k)-dmt(k))*tb - 15 continue -* -* Increase time-scale to relative mass loss of 0.5% but not more than twice. -* KM is the number of orbits for the timestep. -* - km = MIN(2.d0*km0,5.0d-03/ - & MAX(ABS(dm1+dms(j1))/mass(j1),dms(j2)/mass(j2))) - km0 = km -* -* Modify time-step & mass loss terms by speed-up factor. -* - dt = km*tb - dtm = dt/1.0d+06 -* -* Take the stellar evolution timestep into account but don't let it -* be overly restrictive for long lived phases. -* - if(iter.le.1000) dtm = MIN(dtm,dtmi(1),dtmi(2)) - dtm = MIN(dtm,tsave-tphys) - dt = dtm*1.0d+06 - km = dt/tb -* -* Decide between accreted mass by secondary and/or system mass loss. -* - taum = mass(j2)/dm1*tb - if(kstar(j2).le.2.or.kstar(j2).eq.4)then -* -* Limit according to the thermal timescale of the secondary. -* - dm2 = MIN(1.d0,10.d0*taum/tkh(j2))*dm1 - elseif(kstar(j2).ge.7.and.kstar(j2).le.9)then -* -* Naked helium star secondary swells up to a core helium burning star -* or SAGB star unless the primary is also a helium star. -* - if(kstar(j1).ge.7)then - dm2 = MIN(1.d0,10.d0*taum/tkh(j2))*dm1 - else - dm2 = dm1 - dmchk = dm2 - 1.05d0*dms(j2) - if(dmchk.gt.0.d0.and.dm2/mass(j2).gt.1.0d-04)then - kst = MIN(6,2*kstar(j2)-10) - if(kst.eq.4)then - aj(j2) = aj(j2)/tms(j2) - mcx = mass(j2) - else - mcx = massc(j2) - endif - mt2 = mass(j2) + km*(dm2 - dms(j2)) - CALL gntage(mcx,mt2,kst,zpars,mass0(j2),aj(j2)) - epoch(j2) = tphys + dtm - aj(j2) -* - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(j1) - bpp(jp,3) = mt2 - bpp(jp,4) = float(kstar(j1)) - bpp(jp,5) = float(kst) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 8.0 - if(j1.eq.2)then - bpp(jp,2) = mt2 - bpp(jp,3) = mass(j1) - bpp(jp,4) = float(kst) - bpp(jp,5) = float(kstar(j1)) - endif -* - endif - endif - elseif(kstar(j1).le.6.and. - & (kstar(j2).ge.10.and.kstar(j2).le.12))then -* -* White dwarf secondary. -* - if(dm1/tb.lt.2.71d-07)then - if(dm1/tb.lt.1.03d-07)then -* -* Accrete until a nova explosion blows away most of the accreted material. -* - novae = .true. - dm2 = MIN(dm1,dme) - if(dm2.lt.dm1) supedd = .true. - dm22 = epsnov*dm2 - else -* -* Steady burning at the surface -* - dm2 = dm1 - endif - else -* -* Make a new giant envelope. -* - dm2 = dm1 -* -* Check for planets or low-mass WDs. -* - if((kstar(j2).eq.10.and.mass(j2).lt.0.05d0).or. - & (kstar(j2).ge.11.and.mass(j2).lt.0.5d0))then - kst = kstar(j2) - else - kst = MIN(6,3*kstar(j2)-27) - mt2 = mass(j2) + km*(dm2 - dms(j2)) - CALL gntage(massc(j2),mt2,kst,zpars,mass0(j2),aj(j2)) - epoch(j2) = tphys + dtm - aj(j2) -* - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(j1) - bpp(jp,3) = mt2 - bpp(jp,4) = float(kstar(j1)) - bpp(jp,5) = float(kst) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 8.0 - if(j1.eq.2)then - bpp(jp,2) = mt2 - bpp(jp,3) = mass(j1) - bpp(jp,4) = float(kst) - bpp(jp,5) = float(kstar(j1)) - endif -* - endif -* - endif - elseif(kstar(j2).ge.10)then -* -* Impose the Eddington limit. -* - dm2 = MIN(dm1,dme) - if(dm2.lt.dm1) supedd = .true. -* - else -* -* We have a giant whose envelope can absorb any transferred material. -* - dm2 = dm1 - endif - if(.not.novae) dm22 = dm2 -* - if(kst.ge.10.and.kst.le.12)then - mt2 = mass(j2) + km*(dm22 - dms(j2)) - if(kstar(j1).le.10.and.kst.eq.10.and.mt2.ge.0.7d0)then -* -* HeWD can only accrete helium-rich material up to a mass of 0.7 when -* it is destroyed in a possible Type 1a SN. -* - mass(j1) = mass(j1) - km*(dm1 + dms(j1)) - mass(j2) = 0.d0 - kstar(j2) = 15 - goto 135 - elseif(kstar(j1).le.10.and.kst.ge.11)then -* -* CO and ONeWDs accrete helium-rich material until the accumulated -* material exceeds a mass of 0.15 when it ignites. For a COWD with -* mass less than 0.95 the system will be destroyed as an ELD in a -* possible Type 1a SN. COWDs with mass greater than 0.95 and ONeWDs -* will survive with all the material converted to ONe (JH 30/09/99). -* -** Now changed to an ELD for all COWDs when 0.15 accreted (JH 11/01/00). -* - if((mt2-mass0(j2)).ge.0.15d0)then - if(kst.eq.11)then - mass(j1) = mass(j1) - km*(dm1 + dms(j1)) - mass(j2) = 0.d0 - kstar(j2) = 15 - goto 135 - endif - mass0(j2) = mt2 - endif - else - mass0(j2) = mt2 - endif -* -* If the Chandrasekhar limit is exceeded for a white dwarf then destroy -* the white dwarf in a supernova. If the WD is ONe then a neutron star -* will survive the supernova and we let HRDIAG take care of this when -* the stars are next updated. -* - if(kst.eq.10.or.kst.eq.11)then - if(mt2.ge.mch)then - dm1 = mch - mass(j2) + km*dms(j2) - mass(j1) = mass(j1) - dm1 - km*dms(j1) - mass(j2) = 0.d0 - kstar(j2) = 15 - goto 135 - endif - endif - endif -* -* Modify mass loss terms by speed-up factor. -* - dm1 = km*dm1 - dm2 = km*dm2 - dm22 = km*dm22 - dme = km*dme -* -* Calculate orbital angular momentum change due to system mass loss. -* - djorb = ((dmr(1)+q(1)*dmt(1))*mass(2)*mass(2) + - & (dmr(2)+q(2)*dmt(2))*mass(1)*mass(1))/ - & (mass(1)+mass(2))**2 - djorb = djorb*dt -* -* For super-Eddington mass transfer rates, for gamma = -2.0, -* and for novae systems, assume that material is lost from -* the system as if a wind from the secondary. -* If gamma = -1.0 then assume the lost material carries with it -* the specific angular momentum of the primary and for all -* gamma > 0.0 assume that it takes away a fraction gamma of -* the orbital angular momentum. -* - if(supedd.or.novae.or.gamma.lt.-1.5d0)then - djorb = djorb + (dm1 - dm22)*mass(j1)*mass(j1)/ - & (mass(1)+mass(2))**2 - elseif(gamma.ge.0.d0)then - djorb = djorb + gamma*(dm1 - dm2) - else - djorb = djorb + (dm1 - dm2)*mass(j2)*mass(j2)/ - & (mass(1)+mass(2))**2 - endif -* - ecc2 = ecc*ecc - omecc2 = 1.d0 - ecc2 - sqome2 = SQRT(omecc2) -* - djorb = djorb*sep*sep*sqome2*oorb - delet = 0.d0 -* -* For very close systems include angular momentum loss mechanisms. -* - if(sep.le.10.d0)then - djgr = 8.315d-10*mass(1)*mass(2)*(mass(1)+mass(2))/ - & (sep*sep*sep*sep) - f1 = (19.d0/6.d0) + (121.d0/96.d0)*ecc2 - sqome5 = sqome2**5 - delet1 = djgr*ecc*f1/sqome5 - djgr = djgr*jorb*(1.d0+0.875d0*ecc2)/sqome5 - djorb = djorb + djgr*dt - delet = delet + delet1*dt - endif -* - do 602 , k = 1,2 -* - dms(k) = km*dms(k) - if(kstar(k).lt.10) dms(k) = MIN(dms(k),mass(k) - massc(k)) -* -* Calculate change in the intrinsic spin of the star. -* - djspint(k) = (2.d0/3.d0)*(dmr(k)*radx(k)*radx(k)*ospin(k) - - & xi*dmt(k)*radx(3-k)*radx(3-k)*ospin(3-k)) - djspint(k) = djspint(k)*dt -* - if(mass(k).gt.0.35d0.and.kstar(k).lt.10)then - djmb = 5.83d-16*menv(k)*(rad(k)*ospin(k))**3/mass(k) - djspint(k) = djspint(k) + djmb*dt - endif -* - 602 continue -* -* Adjust the spin angular momentum of each star owing to mass transfer -* and conserve total angular momentum. -* - djt = dm1*radx(j1)*radx(j1)*ospin(j1) - djspint(j1) = djspint(j1) + djt - djorb = djorb - djt - if(disk)then -* -* Alter spin of the degenerate secondary by assuming that material -* falls onto the star from the inner edge of a Keplerian accretion -* disk and that the system is in a steady state. -* - djt = dm2*twopi*aursun*SQRT(aursun*mass(j2)*radx(j2)) - djspint(j2) = djspint(j2) - djt - djorb = djorb + djt -* - else -* -* No accretion disk. -* Calculate the angular momentum of the transferred material by -* using the radius of the disk (see Ulrich & Burger) that would -* have formed if allowed. -* - rdisk = 1.7d0*rmin - djt = dm2*twopi*aursun*SQRT(aursun*mass(j2)*rdisk) - djspint(j2) = djspint(j2) - djt - djorb = djorb + djt -* - endif - djtx(2) = djt -* -* Adjust the secondary spin if a nova eruption has occurred. -* - if(novae)then - djt = (dm2 - dm22)*radx(j2)*radx(j2)*ospin(j2) - djspint(j2) = djspint(j2) + djt - djtx(2) = djtx(2) - djt - endif -* -* Calculate circularization, orbital shrinkage and spin up. -* - do 603 , k = 1,2 -* - dspint(k) = 0.d0 - if(((kstar(k).le.9.and.rad(k).ge.0.01d0*rol(k)).or. - & (kstar(k).ge.10.and.k.eq.j1)).and.tflag.gt.0)then -* - raa2 = (radx(k)/sep)**2 - raa6 = raa2**3 -* - f5 = 1.d0+ecc2*(3.d0+ecc2*0.375d0) - f4 = 1.d0+ecc2*(1.5d0+ecc2*0.125d0) - f3 = 1.d0+ecc2*(3.75d0+ecc2*(1.875d0+ecc2*7.8125d-02)) - f2 = 1.d0+ecc2*(7.5d0+ecc2*(5.625d0+ecc2*0.3125d0)) - f1 = 1.d0+ecc2*(15.5d0+ecc2*(31.875d0+ecc2*(11.5625d0 - & +ecc2*0.390625d0))) -* - if((kstar(k).eq.1.and.mass(k).ge.1.25d0).or. - & kstar(k).eq.4.or.kstar(k).eq.7)then - tc = 1.592d-09*(mass(k)**2.84d0) - f = 1.9782d+04*SQRT((mass(k)*radx(k)*radx(k))/sep**5)* - & tc*(1.d0+q(3-k))**(5.d0/6.d0) - tcqr = f*q(3-k)*raa6 - rg2 = k2str(k) - elseif(kstar(k).le.9)then - renv(k) = MIN(renv(k),radx(k)-radc(k)) - renv(k) = MAX(renv(k),1.0d-10) - tc = mr23yr*(menv(k)*renv(k)*(radx(k)-0.5d0*renv(k))/ - & (3.d0*lumin(k)))**(1.d0/3.d0) - ttid = twopi/(1.0d-10 + ABS(oorb - ospin(k))) - f = MIN(1.d0,(ttid/(2.d0*tc)**2)) - tcqr = 2.d0*f*q(3-k)*raa6*menv(k)/(21.d0*tc*mass(k)) - rg2 = (k2str(k)*(mass(k)-massc(k)))/mass(k) - else - f = 7.33d-09*(lumin(k)/mass(k))**(5.d0/7.d0) - tcqr = f*q(3-k)*q(3-k)*raa2*raa2/(1.d0+q(3-k)) - rg2 = k3 - endif - sqome3 = sqome2**3 - delet1 = 27.d0*tcqr*(1.d0+q(3-k))*raa2*(ecc/sqome2**13)* - & (f3 - (11.d0/18.d0)*sqome3*f4*ospin(k)/oorb) - tcirc = ecc/(ABS(delet1) + 1.0d-20) - delet = delet + delet1*dt - dspint(k) = (3.d0*q(3-k)*tcqr/(rg2*omecc2**6))* - & (f2*oorb - sqome3*f5*ospin(k)) - eqspin = oorb*f2/(sqome3*f5) - if(dt.gt.0.d0)then - if(dspint(k).ge.0.d0)then - dspint(k) = MIN(dt*dspint(k),eqspin-ospin(k))/dt - else - dspint(k) = MAX(dt*dspint(k),eqspin-ospin(k))/dt - endif - endif - djt = (k2str(k)*(mass(k)-massc(k))*radx(k)*radx(k) + - & k3*massc(k)*radc(k)*radc(k))*dspint(k) - djorb = djorb + djt*dt - djspint(k) = djspint(k) - djt*dt -* - endif -* - jspin(k) = MAX(1.0d-10,jspin(k) - djspint(k)) -* -* Ensure that the star does not spin up beyond break-up, and transfer -* the excess angular momentum back to the orbit. -* - ospbru = twopi*SQRT(mass(k)*aursun**3/radx(k)**3) - jspbru = (k2str(k)*(mass(k)-massc(k))*radx(k)*radx(k) + - & k3*massc(k)*radc(k)*radc(k))*ospbru - if(jspin(k).gt.jspbru)then - mew = 1.d0 - if(djtx(2).gt.0.d0)then - mew = MIN(mew,(jspin(k) - jspbru)/djtx(2)) - endif - djorb = djorb - (jspin(k) - jspbru) - jspin(k) = jspbru -* If excess material should not be accreted, activate next line. -* dm22 = (1.d0 - mew)*dm22 - endif -* - 603 continue -* -* Update the masses. -* - kstar(j2) = kst - mass(j1) = mass(j1) - dm1 - dms(j1) - if(kstar(j1).le.1.or.kstar(j1).eq.7) mass0(j1) = mass(j1) - mass(j2) = mass(j2) + dm22 - dms(j2) - if(kstar(j2).le.1.or.kstar(j2).eq.7) mass0(j2) = mass(j2) -* -* For a HG star check if the initial mass can be reduced. -* - if(kstar(j1).eq.2.and.mass0(j1).le.zpars(3))then - m0 = mass0(j1) - mass0(j1) = mass(j1) - CALL star(kstar(j1),mass0(j1),mass(j1),tmsnew,tn,tscls, - & lums,GB,zpars) - if(GB(9).lt.massc(j1))then - mass0(j1) = m0 - endif - endif - if(kstar(j2).eq.2.and.mass0(j2).le.zpars(3))then - m0 = mass0(j2) - mass0(j2) = mass(j2) - CALL star(kstar(j2),mass0(j2),mass(j2),tmsnew,tn,tscls, - & lums,GB,zpars) - if(GB(9).lt.massc(j2))then - mass0(j2) = m0 - endif - endif -* - ecc = ecc - delet - ecc = MAX(ecc,0.d0) - if(ecc.lt.1.0d-10) ecc = 0.d0 -* - if(ecc.ge.1.d0) goto 135 -* -* Ensure that Jorb does not become negative which could happen if the -* primary overfills its Roche lobe initially. In this case we simply -* allow contact to occur. -* - jorb = MAX(1.d0,jorb - djorb) - sep = (mass(1) + mass(2))*jorb*jorb/ - & ((mass(1)*mass(2)*twopi)**2*aursun**3*(1.d0-ecc*ecc)) - tb = (sep/aursun)*SQRT(sep/(aursun*(mass(1)+mass(2)))) - oorb = twopi/tb -* - endif -* -* Always rejuvenate the secondary and age the primary if they are on -* the main sequence. -* - if(kstar(j1).le.2.or.kstar(j1).eq.7)then - CALL star(kstar(j1),mass0(j1),mass(j1),tmsnew,tn,tscls, - & lums,GB,zpars) - if(kstar(j1).eq.2)then - aj(j1) = tmsnew + (tscls(1) - tmsnew)*(aj(j1)-tms(j1))/ - & (tbgb(j1) - tms(j1)) - else - aj(j1) = tmsnew/tms(j1)*aj(j1) - endif - epoch(j1) = tphys - aj(j1) - endif -* - if(kstar(j2).le.2.or.kstar(j2).eq.7)then - CALL star(kstar(j2),mass0(j2),mass(j2),tmsnew,tn,tscls, - & lums,GB,zpars) - if(kstar(j2).eq.2)then - aj(j2) = tmsnew + (tscls(1) - tmsnew)*(aj(j2)-tms(j2))/ - & (tbgb(j2) - tms(j2)) - elseif((mass(j2).lt.0.35d0.or.mass(j2).gt.1.25d0). - & and.kstar(j2).ne.7)then - aj(j2) = tmsnew/tms(j2)*aj(j2)*(mass(j2) - dm22)/mass(j2) - else - aj(j2) = tmsnew/tms(j2)*aj(j2) - endif - epoch(j2) = tphys - aj(j2) - endif -* -* Obtain the stellar parameters for the next step. -* - tphys = tphys + dtm - do 90 , k = 1,2 - age = tphys - epoch(k) - m0 = mass0(k) - mt = mass(k) - mc = massc(k) -* -* Masses over 100Msun should probably not be trusted in the -* evolution formulae. -* - if(mt.gt.100.d0)then - WRITE(99,*)' MASS EXCEEDED ',mass1i,mass2i,tbi,ecci,mt - goto 140 - endif - kw = kstar(k) - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - CALL hrdiag(m0,age,mt,tm,tn,tscls,lums,GB,zpars, - & rm,lum,kw,mc,rc,me,re,k2) -* -* Check for a supernova and correct the semi-major axis if so. -* - if(kw.ne.kstar(k).and.kstar(k).le.12.and. - & (kw.eq.13.or.kw.eq.14))then - dms(k) = mass(k) - mt - CALL kick(kw,mass(k),mt,mass(3-k),ecc,sep,jorb,vs) - vkick(k) = dsqrt(vs(1)*vs(1)+vs(2)*vs(2)+vs(3)*vs(3)) - if(ecc.gt.1.d0)then - kstar(k) = kw - mass(k) = mt - epoch(k) = tphys - age - goto 135 - endif - tb = (sep/aursun)*SQRT(sep/(aursun*(mt+mass(3-k)))) - oorb = twopi/tb - endif - if(kw.ne.kstar(k))then - change = .true. - if((kw.eq.13.or.kw.eq.14).and.kstar(k).le.12)then - snova = .true. - endif - mass(k) = mt - if(kw.eq.15)then - kstar(k) = kw - goto 135 - endif - mass0(k) = m0 - epoch(k) = tphys - age - endif -* -* Determine stellar evolution timescale for nuclear burning types. -* - if(kw.le.9)then - CALL deltat(kw,age,tm,tn,tscls,dt,dtr) - dtmi(k) = MIN(dt,dtr) -* dtmi(k) = dtr - dtmi(k) = MAX(1.0d-07,dtmi(k)) - else - dtmi(k) = 1.0d+10 - endif -* dtmi(k) = MAX((tn-age),1.0d-07) -* -* Save relevent solar quantities. -* - aj(k) = age - kstar(k) = kw - rad(k) = rm - radx(k) = rm - lumin(k) = lum - massc(k) = mc - radc(k) = rc - menv(k) = me - renv(k) = re - k2str(k) = k2 - tms(k) = tm - tbgb(k) = tscls(1) -* -* Check for blue straggler formation. -* - if(kw.le.1.and.tm.lt.tphys.and..not.bss)then - bss = .true. - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 14.0 - endif -* - 90 continue -* - do 100 , k = 1,2 - q(k) = mass(k)/mass(3-k) - rol(k) = rl(q(k))*sep - 100 continue - if(rad(j1).gt.rol(j1)) radx(j1) = MAX(radc(j1),rol(j1)) - do 110 , k = 1,2 - ospin(k) = jspin(k)/(k2str(k)*(mass(k)-massc(k))*radx(k)* - & radx(k) + k3*massc(k)*radc(k)*radc(k)) - 110 continue -* - if((isave.and.tphys.ge.tsave).or.iplot)then - ip = ip + 1 - bcm(ip,1) = tphys - bcm(ip,2) = float(kstar(1)) - bcm(ip,3) = mass0(1) - bcm(ip,4) = mass(1) - bcm(ip,5) = log10(lumin(1)) - bcm(ip,6) = log10(rad(1)) - teff1 = 1000.d0*((1130.d0*lumin(1)/ - & (rad(1)**2.d0))**(1.d0/4.d0)) - bcm(ip,7) = log10(teff1) - bcm(ip,8) = massc(1) - bcm(ip,9) = radc(1) - bcm(ip,10) = menv(1) - bcm(ip,11) = renv(1) - bcm(ip,12) = epoch(1) - bcm(ip,13) = ospin(1) - bcm(ip,15) = rad(1)/rol(1) - bcm(ip,16) = float(kstar(2)) - bcm(ip,17) = mass0(2) - bcm(ip,18) = mass(2) - bcm(ip,19) = log10(lumin(2)) - bcm(ip,20) = log10(rad(2)) - teff2 = 1000.d0*((1130.d0*lumin(2)/ - & (rad(2)**2.d0))**(1.d0/4.d0)) - bcm(ip,21) = log10(teff2) - bcm(ip,22) = massc(2) - bcm(ip,23) = radc(2) - bcm(ip,24) = menv(2) - bcm(ip,25) = renv(2) - bcm(ip,26) = epoch(2) - bcm(ip,27) = ospin(2) - bcm(ip,29) = rad(2)/rol(2) - bcm(ip,30) = tb - bcm(ip,31) = sep - bcm(ip,32) = ecc - dt = MAX(dtm,1.0d-12)*1.0d+06 - if(j1.eq.1)then - bcm(ip,14) = (-1.0*dm1 - dms(1))/dt - bcm(ip,28) = (dm2 - dms(2))/dt - else - bcm(ip,14) = (dm2 - dms(1))/dt - bcm(ip,28) = (-1.0*dm1 - dms(2))/dt - endif - if(isave) tsave = tsave + dtp - endif -* - if(tphys.ge.tphysf) goto 140 -* - if(change)then - change = .false. - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 2.0 - endif -* -* Test whether the primary still fills its Roche lobe. -* - if(rad(j1).gt.rol(j1).and..not.snova)then -* -* Test for a contact system -* - if(rad(j2).gt.rol(j2)) goto 130 - iter = iter + 1 - goto 8 - else - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 4.0 - dtm = 0.d0 - goto 4 - endif -* - 130 continue -* -* Contact system. -* - coel = .true. -* -* If *1 or *2 is giant-like this will be common-envelope evolution. -* - m1ce = mass(j1) - m2ce = mass(j2) - rrl1 = MIN(999.999d0,rad(1)/rol(1)) - rrl2 = MIN(999.999d0,rad(2)/rol(2)) -* - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - bpp(jp,3) = mass(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rrl1 - bpp(jp,9) = rrl2 - bpp(jp,10) = 5.0 -* - if(kstar(j1).ge.2.and.kstar(j1).le.9.and.kstar(j1).ne.7)then - CALL comenv(mass0(j1),mass(j1),massc(j1),aj(j1),jspin(j1), - & kstar(j1),mass0(j2),mass(j2),massc(j2),aj(j2), - & jspin(j2),kstar(j2),zpars,ecc,sep,jorb,coel) - com = .true. - elseif(kstar(j2).ge.2.and.kstar(j2).le.9.and.kstar(j2).ne.7)then - CALL comenv(mass0(j2),mass(j2),massc(j2),aj(j2),jspin(j2), - & kstar(j2),mass0(j1),mass(j1),massc(j1),aj(j1), - & jspin(j1),kstar(j1),zpars,ecc,sep,jorb,coel) - com = .true. - else - CALL mix(mass0,mass,aj,kstar,zpars) - endif - if(com)then - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - if(kstar(1).eq.15) bpp(jp,2) = mass0(1) - bpp(jp,3) = mass(2) - if(kstar(2).eq.15) bpp(jp,3) = mass0(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = sep - bpp(jp,7) = ecc - rrl1 = MIN(rrl1,0.99d0) - rrl2 = MIN(rrl2,0.99d0) - bpp(jp,8) = rrl1 - bpp(jp,9) = rrl2 - bpp(jp,10) = 7.0 - endif - epoch(1) = tphys - aj(1) - epoch(2) = tphys - aj(2) - if(.not.coel)then -* -* Next step should be made without changing the time. -* - if(ecc.gt.1.d0)then - if(kstar(1).ge.13)then - rc = corerd(kstar(1),mass(1),mass(1),zpars(2)) - ospin(1) = jspin(1)/(k3*rc*rc*mass(1)) - endif - if(kstar(2).ge.13)then - rc = corerd(kstar(2),mass(2),mass(2),zpars(2)) - ospin(2) = jspin(2)/(k3*rc*rc*mass(2)) - endif - goto 135 - endif - dtm = 0.d0 -* -* Reset orbital parameters as separation may have changed. -* - tb = (sep/aursun)*SQRT(sep/(aursun*(mass(1)+mass(2)))) - oorb = twopi/tb - goto 4 - endif -* - 135 continue -* - sgl = .true. - if(kstar(1).ne.15.or.kstar(2).ne.15)then - if(com)then - com = .false. - else - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - if(kstar(1).eq.15) bpp(jp,2) = mass0(1) - bpp(jp,3) = mass(2) - if(kstar(2).eq.15) bpp(jp,3) = mass0(2) - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = zero - bpp(jp,7) = zero - bpp(jp,8) = zero - bpp(jp,9) = ngtv - if(coel)then - bpp(jp,10) = 6.0 - elseif(ecc.gt.1.d0)then -* -* Binary dissolved by a supernova or tides. -* - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,9) = ngtv2 - bpp(jp,10) = 11.0 - else - bpp(jp,10) = 9.0 - endif - endif - if(kstar(2).eq.15)then - kmax = 1 - rol(2) = -1.d0*rad(2) - dtmi(2) = tphysf - elseif(kstar(1).eq.15)then - kmin = 2 - rol(1) = -1.d0*rad(1) - dtmi(1) = tphysf - endif - ecc = -1.d0 - sep = 0.d0 - dtm = 0.d0 - coel = .false. - goto 4 - endif -* - 140 continue -* - if(com)then - com = .false. - else - jp = MIN(80,jp + 1) - bpp(jp,1) = tphys - bpp(jp,2) = mass(1) - if(kstar(1).eq.15.and.bpp(jp-1,4).lt.15.0)then - bpp(jp,2) = mass0(1) - endif - bpp(jp,3) = mass(2) - if(kstar(2).eq.15.and.bpp(jp-1,5).lt.15.0)then - bpp(jp,3) = mass0(2) - endif - bpp(jp,4) = float(kstar(1)) - bpp(jp,5) = float(kstar(2)) - bpp(jp,6) = zero - bpp(jp,7) = zero - bpp(jp,8) = zero - if(coel)then - bpp(jp,9) = ngtv - bpp(jp,10) = 6.0 - elseif(kstar(1).eq.15.and.kstar(2).eq.15)then -* -* Cases of accretion induced supernova or single star supernova. -* No remnant is left in either case. -* - bpp(jp,9) = ngtv2 - bpp(jp,10) = 9.0 - else - bpp(jp,6) = sep - bpp(jp,7) = ecc - bpp(jp,8) = rad(1)/rol(1) - bpp(jp,9) = rad(2)/rol(2) - bpp(jp,10) = 10.0 - endif - endif -* - if((isave.and.tphys.ge.tsave).or.iplot)then - ip = ip + 1 - bcm(ip,1) = tphys - bcm(ip,2) = float(kstar(1)) - bcm(ip,3) = mass0(1) - bcm(ip,4) = mass(1) - bcm(ip,5) = log10(lumin(1)) - bcm(ip,6) = log10(rad(1)) - teff1 = 1000.d0*((1130.d0*lumin(1)/ - & (rad(1)**2.d0))**(1.d0/4.d0)) - bcm(ip,7) = log10(teff1) - bcm(ip,8) = massc(1) - bcm(ip,9) = radc(1) - bcm(ip,10) = menv(1) - bcm(ip,11) = renv(1) - bcm(ip,12) = epoch(1) - bcm(ip,13) = ospin(1) - bcm(ip,15) = rad(1)/rol(1) - bcm(ip,16) = float(kstar(2)) - bcm(ip,17) = mass0(2) - bcm(ip,18) = mass(2) - bcm(ip,19) = log10(lumin(2)) - bcm(ip,20) = log10(rad(2)) - teff2 = 1000.d0*((1130.d0*lumin(2)/ - & (rad(2)**2.d0))**(1.d0/4.d0)) - bcm(ip,21) = log10(teff2) - bcm(ip,22) = massc(2) - bcm(ip,23) = radc(2) - bcm(ip,24) = menv(2) - bcm(ip,25) = renv(2) - bcm(ip,26) = epoch(2) - bcm(ip,27) = ospin(2) - bcm(ip,29) = rad(2)/rol(2) - bcm(ip,30) = tb - bcm(ip,31) = sep - bcm(ip,32) = ecc - dt = MAX(dtm,1.0d-12)*1.0d+06 - if(j1.eq.1)then - bcm(ip,14) = (-1.0*dm1 - dms(1))/dt - bcm(ip,28) = (dm2 - dms(2))/dt - else - bcm(ip,14) = (dm2 - dms(1))/dt - bcm(ip,28) = (-1.0*dm1 - dms(2))/dt - endif - if(isave) tsave = tsave + dtp - if(tphysf.le.0.d0)then - ip = ip + 1 - do 145 , k = 1,32 - bcm(ip,k) = bcm(ip-1,k) - 145 continue - endif - endif -* - tphysf = tphys - if(sgl)then - if(ecc.ge.0.d0.and.ecc.le.1.d0) ecc = -1.d0 - tb = -1.d0 - endif - tb = tb*yeardy - if(jp.ge.80)then - WRITE(99,*)' EVOLV2 ARRAY ERROR ',mass1i,mass2i,tbi,ecci - WRITE(*,*)' STOP: EVOLV2 ARRAY ERROR ' - CALL exit(0) - STOP - elseif(jp.ge.40)then - WRITE(99,*)' EVOLV2 ARRAY WARNING ',mass1i,mass2i,tbi,ecci,jp - endif - bcm(ip+1,1) = -1.0 - bpp(jp+1,1) = -1.0 -* - RETURN - END -*** - - -cc//gntage.f - -*** - SUBROUTINE gntage(mc,mt,kw,zpars,m0,aj) -* -* A routine to determine the age of a giant from its core mass and type. -* -* Author : C. A. Tout -* Date : 24th September 1996 -* Revised: 21st February 1997 to include core-helium-burning stars -* -* Rewritten: 2nd January 1998 by J. R. Hurley to be compatible with -* the new evolution routines and to include new stellar -* types. -* - implicit none -* - integer kw - integer j,jmax - parameter(jmax=30) -* - real*8 mc,mt,m0,aj,tm,tn - real*8 tscls(20),lums(10),GB(10),zpars(20) - real*8 mmin,mmax,mmid,dm,f,fmid,dell,derl,lum - real*8 macc,lacc,tiny - parameter(macc=0.00001d0,lacc=0.0001d0,tiny=1.0d-14) - real*8 mcx,mcy -* - real*8 mcheif,mcagbf,mheif,mbagbf,mcgbf,lmcgbf,lbgbf,lbgbdf - external mcheif,mcagbf,mheif,mbagbf,mcgbf,lmcgbf,lbgbf,lbgbdf -* -* This should only be entered with KW = 3, 4, 5, 6 or 9 -* -* First we check that we don't have a CheB star -* with too small a core mass. - if(kw.eq.4)then -* Set the minimum CHeB core mass using M = Mflash - mcy = mcheif(zpars(2),zpars(2),zpars(10)) - if(mc.le.mcy) kw = 3 -* if(mc.le.mcy) WRITE(66,*)' GNTAGE4: changed to 3' - endif -* -* Next we check that we don't have a GB star for M => Mfgb - if(kw.eq.3)then -* Set the maximum GB core mass using M = Mfgb - mcy = mcheif(zpars(3),zpars(2),zpars(9)) - if(mc.ge.mcy)then - kw = 4 - aj = 0.d0 -* WRITE(66,*)' GNTAGE3: changed to 4' - endif - endif -* - if(kw.eq.6)then -* -* We try to start the star from the start of the SAGB by -* setting Mc = Mc,TP. -* - mcy = 0.44d0*2.25d0 + 0.448d0 - if(mc.gt.mcy)then -* A type 6 with this sized core mass cannot exist as it should -* already have become a NS or BH as a type 5. -* We set it up so that it will. - mcx = (mc + 0.35d0)/0.773d0 - elseif(mc.ge.0.8d0)then - mcx = (mc - 0.448d0)/0.44d0 - else - mcx = mc - endif - m0 = mbagbf(mcx) - if(m0.lt.tiny)then -* Carbon core mass is less then the minimum for the start of SAGB. -* This must be the case of a low-mass C/O or O/Ne WD with only a -* very small envelope added or possibly the merger of a helium star -* with a main sequence star. We will set m0 = mt and then reset the -* core mass to allow for some helium to be added to the C/O core. - kw = 14 -* WRITE(66,*)' GNTAGE6: changed to 4' - else - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - aj = tscls(13) - endif - endif -* - if(kw.eq.5)then -* -* We fit a Helium core mass at the base of the AGB. -* - m0 = mbagbf(mc) - if(m0.lt.tiny)then -* Helium core mass is less then the BAGB minimum. - kw = 14 -* WRITE(66,*)' GNTAGE5: changed to 4' - else - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - aj = tscls(2) + tscls(3) - endif - endif -* -* - if(kw.eq.4)then -* -* The supplied age is actually the fractional age, fage, of CHeB lifetime -* that has been completed, ie. 0 <= aj <= 1. -* - if(aj.lt.0.d0.or.aj.gt.1.d0)then -* WRITE(99,*)' FATAL ERROR! GNTAGE4: fage out of bounds ' -* WRITE(99,*)' FAGE ',aj -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - aj = 0.d0 - endif -* Get the minimum, fage=1, and maximum, fage=0, allowable masses - mcy = mcagbf(zpars(2)) - if(mc.ge.mcy)then - mmin = mbagbf(mc) - else - mmin = zpars(2) - endif - mmax = mheif(mc,zpars(2),zpars(10)) - if(aj.lt.tiny)then - m0 = mmax - goto 20 - elseif(aj.ge.1.d0)then - m0 = mmin - goto 20 - endif -* Use the bisection method to find m0 - fmid = (1.d0-aj)*mcheif(mmax,zpars(2),zpars(10)) + - & aj*mcagbf(mmax) - mc - f = (1.d0-aj)*mcheif(mmin,zpars(2),zpars(10)) + - & aj*mcagbf(mmin) - mc - if(f*fmid.ge.0.d0)then -* This will probably occur if mc is just greater than the minimum -* allowed mass for a CHeB star and fage > 0. - kw = 3 -* WRITE(66,*)' GNTAGE4: changed to 3' - goto 90 - endif - m0 = mmin - dm = mmax - mmin - do 10 , j = 1,jmax - dm = 0.5d0*dm - mmid = m0 + dm - fmid = (1.d0-aj)*mcheif(mmid,zpars(2),zpars(10)) + - & aj*mcagbf(mmid) - mc - if(fmid.lt.0.d0) m0 = mmid - if(ABS(dm).lt.macc.or.ABS(fmid).lt.tiny) goto 20 - if(j.eq.jmax)then -* WRITE(99,*)' FATAL ERROR! GNTAGE4: root not found ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - m0 = mt - aj = 0.d0 - endif - 10 continue - 20 continue -* - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - aj = tscls(2) + aj*tscls(3) -* - endif -* - 90 continue -* - if(kw.eq.3)then -* -* First we double check that we don't have a GB star for M => Mfgb - mcy = mcheif(zpars(3),zpars(2),zpars(9)) - if(mc.ge.mcy)then -* WRITE(99,*)' GNTAGE3: star too big for GB ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - mc = 0.99d0*mcy - endif -* Next we find an m0 so as to place the star at the BGB - mcx = mcheif(zpars(2),zpars(2),zpars(9)) - if(mc.gt.mcx)then - m0 = mheif(mc,zpars(2),zpars(9)) - else -* Use Newton-Raphson to find m0 from Lbgb - m0 = zpars(2) - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - lum = lmcgbf(mc,GB) - j = 0 - 30 continue - dell = lbgbf(m0) - lum - if(ABS(dell/lum).le.lacc) goto 40 - derl = lbgbdf(m0) - m0 = m0 - dell/derl - j = j + 1 - if(j.eq.jmax)then -* WRITE(99,*)' FATAL ERROR! GNTAGE3: root not found ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - m0 = zpars(2) - m0 = MAX(m0,mt) - goto 40 - endif - goto 30 - 40 continue - endif - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - aj = tscls(1) + 1.0d-06*(tscls(2) - tscls(1)) -* - endif -* - if(kw.eq.8.or.kw.eq.9)then -* -* We make a post-MS naked helium star. -* To make things easier we put the star at the TMS point -* so it actually begins as type 8. -* - kw = 8 - mmin = mc - CALL star(kw,mmin,mc,tm,tn,tscls,lums,GB,zpars) - mcx = mcgbf(lums(2),GB,lums(6)) - if(mcx.ge.mc)then -* WRITE(99,*)' FATAL ERROR! GNTAGE9: mmin too big ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - m0 = mt - goto 80 - endif - f = mcx - mc - mmax = mt - do 50 , j = 1,jmax - CALL star(kw,mmax,mc,tm,tn,tscls,lums,GB,zpars) - mcy = mcgbf(lums(2),GB,lums(6)) - if(mcy.gt.mc) goto 60 - mmax = 2.d0*mmax - if(j.eq.jmax)then -* WRITE(99,*)' FATAL ERROR! GNTAGE9: mmax not found ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - m0 = mt - goto 80 - endif - 50 continue - 60 continue - fmid = mcy - mc -* Use the bisection method to find m0 - if(f*fmid.ge.0.d0)then -* WRITE(99,*)' FATAL ERROR! GNTAGE9: root not bracketed ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - m0 = mt - goto 80 - endif - m0 = mmin - dm = mmax - mmin - do 70 , j = 1,jmax - dm = 0.5d0*dm - mmid = m0 + dm - CALL star(kw,mmid,mc,tm,tn,tscls,lums,GB,zpars) - mcy = mcgbf(lums(2),GB,lums(6)) - fmid = mcy - mc - if(fmid.lt.0.d0) m0 = mmid - if(ABS(dm).lt.macc.or.ABS(fmid).lt.tiny) goto 80 - if(j.eq.jmax)then -* WRITE(99,*)' FATAL ERROR! GNTAGE9: root not found ' -* WRITE(*,*)' STOP: FATAL ERROR ' -* CALL exit(0) -* STOP - m0 = mt - goto 80 - endif - 70 continue - 80 continue -* - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - aj = tm + 1.0d-10*tm -* - endif -* - if(kw.eq.14)then -* - kw = 4 - m0 = mt - mcy = mcagbf(m0) - aj = mc/mcy - CALL star(kw,m0,mt,tm,tn,tscls,lums,GB,zpars) - if(m0.le.zpars(2))then - mcx = mcgbf(lums(4),GB,lums(6)) - else - mcx = mcheif(m0,zpars(2),zpars(10)) - end if - mc = mcx + (mcy - mcx)*aj - aj = tscls(2) + aj*tscls(3) - endif -* - RETURN - END -*** - - - -cc//instar.f - -*** - SUBROUTINE instar -* -* -* Initialization of collision matrix. -* ------------------------ -* - implicit none - integer i,j,ktype(0:14,0:14) - common /TYPES/ ktype -* -* Initialize stellar collision matrix. -* - ktype(0,0) = 1 - do 10 , j = 1,6 - ktype(0,j) = j - ktype(1,j) = j - 10 continue - ktype(0,7) = 4 - ktype(1,7) = 4 - do 15 , j = 8,12 - if(j.ne.10)then - ktype(0,j) = 6 - else - ktype(0,j) = 3 - endif - ktype(1,j) = ktype(0,j) - 15 continue - ktype(2,2) = 3 - do 20 , i = 3,14 - ktype(i,i) = i - 20 continue - ktype(5,5) = 4 - ktype(7,7) = 1 - ktype(10,10) = 15 - ktype(13,13) = 14 - do 25 , i = 2,5 - do 30 j = i+1,12 - ktype(i,j) = 4 - 30 continue - 25 continue - ktype(2,3) = 3 - ktype(2,6) = 5 - ktype(2,10) = 3 - ktype(2,11) = 5 - ktype(2,12) = 5 - ktype(3,6) = 5 - ktype(3,10) = 3 - ktype(3,11) = 5 - ktype(3,12) = 5 - ktype(6,7) = 4 - ktype(6,8) = 6 - ktype(6,9) = 6 - ktype(6,10) = 5 - ktype(6,11) = 6 - ktype(6,12) = 6 - ktype(7,8) = 8 - ktype(7,9) = 9 - ktype(7,10) = 7 - ktype(7,11) = 9 - ktype(7,12) = 9 - ktype(8,9) = 9 - ktype(8,10) = 7 - ktype(8,11) = 9 - ktype(8,12) = 9 - ktype(9,10) = 7 - ktype(9,11) = 9 - ktype(9,12) = 9 - ktype(10,11) = 9 - ktype(10,12) = 9 - ktype(11,12) = 12 - do 35 , i = 0,12 - ktype(i,13) = 13 - ktype(i,14) = 14 - 35 continue - ktype(13,14) = 14 -* -* Increase common-envelope cases by 100. - do 40 , i = 0,9 - do 45 , j = i,14 - if(i.le.1.or.i.eq.7)then - if(j.ge.2.and.j.le.9.and.j.ne.7)then - ktype(i,j) = ktype(i,j) + 100 - endif - else - ktype(i,j) = ktype(i,j) + 100 - endif - 45 continue - 40 continue -* -* Assign the remaining values by symmetry. - do 50 , i = 1,14 - do 55 , j = 0,i-1 - ktype(i,j) = ktype(j,i) - 55 continue - 50 continue -* - return - end -*** - - -cc//mix.f - -*** - SUBROUTINE MIX(M0,M,AJ,KS,ZPARS) -* -* Author : J. R. Hurley -* Date : 7th July 1998 -* -* Evolution parameters for mixed star. -* ------------------------------------ -* - implicit none -* - INTEGER KS(2),I1,I2,K1,K2,KW,ICASE - INTEGER KTYPE(0:14,0:14) - COMMON /TYPES/ KTYPE - REAL*8 M0(2),M(2),AJ(2),ZPARS(20) - REAL*8 TSCLS(20),LUMS(10),GB(10),TMS1,TMS2,TMS3,TN - REAL*8 M01,M02,M03,M1,M2,M3,AGE1,AGE2,AGE3,MC3,MCH - PARAMETER(MCH=1.44D0) - REAL*8 NETA,BWIND,HEWIND,MXNS - COMMON /VALUE1/ NETA,BWIND,HEWIND,MXNS -* -* -* Define global indices with body #I1 being most evolved. - IF(KS(1).GE.KS(2))THEN - I1 = 1 - I2 = 2 - ELSE - I1 = 2 - I2 = 1 - END IF -* -* Specify case index for collision treatment. - K1 = KS(I1) - K2 = KS(I2) - ICASE = KTYPE(K1,K2) -* if(icase.gt.100) WRITE(66,*)' MIX ERROR ICASE>100 ',icase,k1,k2 -* -* Determine evolution time scales for first star. - M01 = M0(I1) - M1 = M(I1) - AGE1 = AJ(I1) - CALL star(K1,M01,M1,TMS1,TN,TSCLS,LUMS,GB,ZPARS) -* -* Obtain time scales for second star. - M02 = M0(I2) - M2 = M(I2) - AGE2 = AJ(I2) - CALL star(K2,M02,M2,TMS2,TN,TSCLS,LUMS,GB,ZPARS) -* -* Check for planetary systems - defined as HeWDs and low-mass WDs! - IF(K1.EQ.10.AND.M1.LT.0.05)THEN - ICASE = K2 - IF(K2.LE.1)THEN - ICASE = 1 - AGE1 = 0.D0 - ENDIF - ELSEIF(K1.GE.11.AND.M1.LT.0.5.AND.ICASE.EQ.6)THEN - ICASE = 9 - ENDIF - IF(K2.EQ.10.AND.M2.LT.0.05)THEN - ICASE = K1 - IF(K1.LE.1)THEN - ICASE = 1 - AGE2 = 0.D0 - ENDIF - ENDIF -* -* Specify total mass. - M3 = M1 + M2 - M03 = M01 + M02 - KW = ICASE - AGE3 = 0.d0 -* -* Restrict merged stars to masses less than 100 Msun. - IF(M3.GE.100.D0)THEN - M3 = 99.D0 - M03 = MIN(M03,M3) - ENDIF -* -* Evaluate apparent age and other parameters. -* - IF(ICASE.EQ.1)THEN -* Specify new age based on complete mixing. - IF(K1.EQ.7) KW = 7 - CALL star(KW,M03,M3,TMS3,TN,TSCLS,LUMS,GB,ZPARS) - AGE3 = 0.1d0*TMS3*(AGE1*M1/TMS1 + AGE2*M2/TMS2)/M3 - ELSEIF(ICASE.EQ.3.OR.ICASE.EQ.6.OR.ICASE.EQ.9)THEN - MC3 = M1 - CALL gntage(MC3,M3,KW,ZPARS,M03,AGE3) - ELSEIF(ICASE.EQ.4)THEN - MC3 = M1 - AGE3 = AGE1/TMS1 - CALL gntage(MC3,M3,KW,ZPARS,M03,AGE3) - ELSEIF(ICASE.EQ.7)THEN - CALL star(KW,M03,M3,TMS3,TN,TSCLS,LUMS,GB,ZPARS) - AGE3 = TMS3*(AGE2*M2/TMS2)/M3 - ELSEIF(ICASE.LE.12)THEN -* Ensure that a new WD has the initial mass set correctly. - M03 = M3 - IF(ICASE.LT.12.AND.M3.GE.MCH)THEN - M3 = 0.D0 - KW = 15 - ENDIF - ELSEIF(ICASE.EQ.13.OR.ICASE.EQ.14)THEN -* Set unstable Thorne-Zytkow object with fast mass loss of envelope -* unless the less evolved star is a WD, NS or BH. - IF(K2.LT.10)THEN - M03 = M1 - M3 = M1 - ENDIF - IF(ICASE.EQ.13.AND.M3.GT.MXNS) KW = 14 - ELSEIF(ICASE.EQ.15)THEN - M3 = 0.D0 - ELSEIF(ICASE.GT.100)THEN -* Common envelope case which should only be used after COMENV. - KW = K1 - AGE3 = AGE1 - M3 = M1 - M03 = M01 - ELSE -* This should not be reached. - KW = 1 - M03 = M3 - ENDIF -* -* Put the result in *1. -* - KS(1) = KW - KS(2) = 15 - M(1) = M3 - M(2) = 0.D0 - M0(1) = M03 - AJ(1) = AGE3 -* - RETURN - END -*** - - - -cc//rl.f - - -*** - REAL*8 FUNCTION RL(Q) - IMPLICIT NONE - REAL*8 Q,P -* -* A function to evaluate R_L/a(q), Eggleton 1983. -* - P = Q**(1.d0/3.d0) - RL = 0.49d0*P*P/(0.6d0*P*P + LOG(1.d0+P)) -* - RETURN - END -*** - -