diff --git a/.gitignore b/.gitignore index 9f184f3..a83a44e 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,9 @@ *.cfg *.inp *.mask +grapite-dev-exec-threshold +phigrape +*.h5 +.* +CUDA +.gitignore diff --git a/Makefile b/Makefile index f8fe666..3ac4642 100644 --- a/Makefile +++ b/Makefile @@ -1,30 +1,34 @@ -CUDAHOME ?= /usr/local/cuda -CPPFLAGS += -DYEBISU -DETICS +CUDA_HOME ?= /usr/local/cuda +CPPFLAGS += -DETICS OPTIMIZATION ?= 3 -ETICS_DTSCF ?= 0.015625 +CUDAINC = -I$(CUDA_HOME)/include -I$(CUDA_HOME)/samples/common/inc/ +CUDALIB = -L$(CUDA_HOME)/lib64 -lcudart -lcudadevrt -lcuda -CUDAINC = -I$(CUDAHOME)/include -I$(CUDAHOME)/samples/common/inc/ -CUDALIB = -L$(CUDAHOME)/lib64 -lcudart -lcudadevrt +default: grapite +grapite: GRAPE_HOME = ../grapite +grapite: GRAPELIB = -L$(GRAPE_HOME) -lgrapite +yebisu: GRAPE_HOME = ../yebisu +yebisu: GRAPELIB = -L$(GRAPE_HOME) -lyebisug6 +sapporo: GRAPE_HOME = ../sapporo2/lib +sapporo: GRAPELIB = -L$(GRAPE_HOME) -lsapporo + GRAPEINC = -I$(GRAPE_HOME) -GRAPEHOME = ../grapite -GRAPELIB = -L$(GRAPEHOME) -lgrapite -yebisu: GRAPEHOME = ../yebisu -yebisu: GRAPELIB = -L$(GRAPEHOME) -lyebisug6 -GRAPEINC = -I$(GRAPEHOME) - -CFLAGS ?= -mcmodel=large -CFLAGS += -O$(OPTIMIZATION) +CXXFLAGS += -std=c++11 -O$(OPTIMIZATION) INC = $(GRAPEINC) $(CUDAINC) -LIB = $(GRAPELIB) $(CUDALIB) -lm -lgcc -lgfortran -lstdc++ -MPICC ?= mpicc -EXECUTABLE ?= phi-GRAPE.exe +LIB = $(GRAPELIB) $(CUDALIB) -lm +MPICXX ?= mpic++ +EXECUTABLE ?= phigrape + +# HDF5 +#CPPFLAGS += -DHAS_HDF5 +#LIB += -lhdf5 -lz -ldl default: - $(MPICC) $(CPPFLAGS) $(CFLAGS) -DETICS_DTSCF=$(ETICS_DTSCF) $(INC) phi-GRAPE.c -o $(EXECUTABLE) $(LIB) + $(MPICXX) $(CPPFLAGS) $(CXXFLAGS) $(INC) black_holes.cpp external.cpp io.cpp config.cpp phigrape.cpp -o $(EXECUTABLE) $(LIB) -yebisu: CPPFLAGS := $(filter-out -DETICS, $(CPPFLAGS)) -yebisu: default +yebisu sapporo: CPPFLAGS := $(filter-out -DETICS, $(CPPFLAGS)) +yebisu sapporo grapite: default clean: - rm -f *.o phi-GRAPE.exe + rm -f CUDA *.o phigrape diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..6effc24 --- /dev/null +++ b/TODO.md @@ -0,0 +1,8 @@ +TODO +==== + +* Break main() into smaller chunks; operations that are timed should become independent functions. + +* Const everything + +* OpenMP \ No newline at end of file diff --git a/act_def_linklist.c b/act_def_linklist.c deleted file mode 100644 index b879bc3..0000000 --- a/act_def_linklist.c +++ /dev/null @@ -1,376 +0,0 @@ -/************************************************************** - File : act_def_linklist.c - Func. : provide linear linking list functions - : for active particle def. - CODED BY : Zhong Shiyan - START : 2014-03-28, 12:30 -**************************************************************/ - -//***********************************************************// -/* Definition of T/P-node */ -//***********************************************************// -typedef struct PNODE -{ - int Pid; // Particle's real ID - struct PNODE *NextPNODE; -} PNODE; - -typedef struct TNODE -{ - double t_node; // t_node = t + dt - int n_node; // number of P-nodes under this node - - struct PNODE *PartList, *PartListEnd; - struct TNODE *NextTNODE; -} TNODE; - -struct TNODE *CurrT=NULL; - -//***********************************************************// -/* Operations on T/P-node */ -//***********************************************************// -struct TNODE *CreateTNODE( double t ){ - - struct TNODE *ptr; - - ptr = (TNODE*)malloc(sizeof(*ptr)); - if( ptr == NULL ){ - printf("Fail to create a node."); - exit(-1); - } - - ptr->t_node = t; - ptr->n_node = 0; - - ptr->NextTNODE = NULL; - - ptr->PartList = NULL; - ptr->PartListEnd = NULL; - - return ptr; -} -//***********************************************************// -struct PNODE *DeletePNODE( struct PNODE *ptr ){ - struct PNODE *next; - - next = ptr->NextPNODE; - free(ptr); - - return next; -} -//***********************************************************// -void DeleteTNODE( struct TNODE *Tptr ){ - - struct PNODE *Pptr; - - Pptr = Tptr->PartList; - - while( Pptr != NULL ){ - Pptr = DeletePNODE( Pptr ); - } - - free(Tptr); - return; -} -//***********************************************************// -struct PNODE *CreatePNODE( int id ){ - struct PNODE *ptr; - - ptr = (PNODE*)malloc(sizeof(*ptr)); - if( ptr == NULL ){ - printf("Fail to create a P-node."); - return NULL; - } - - ptr->Pid = id; - ptr->NextPNODE = NULL; - - return ptr; - -} -//***********************************************************// -void InsertTNODE( struct TNODE *front, - struct TNODE *rear, - struct TNODE *ptr ) -{ - front->NextTNODE = ptr; - ptr->NextTNODE = rear; - -} -//***********************************************************// - - - - -//***********************************************************// -/* Functions about act_def */ -//***********************************************************// -/************************************************************** -This function only called 1 time, at beginning of simulation. -After all particle's dt are computed -**************************************************************/ - -void CreateLinkList(){ - - struct TNODE *head,*tail,*Tp1,*Tp2,*newTNODE,*Tptr; - struct PNODE *Pptr,*Ptail; - - int i, iii; - double ttmp, t1, t2; - - head = CreateTNODE( -1.0 ); // will be discarded at the end of this routine - tail = CreateTNODE( 2.0*t_end ); - - head->NextTNODE = tail; - tail->NextTNODE = NULL; - - // building link list - -for(i=0;iNextTNODE; - t1 = Tp1->t_node; - t2 = Tp2->t_node; - - Pptr = CreatePNODE( iii ); - - while( Tp1->NextTNODE != NULL ){ - if( ttmp == t1 ){ // if T-node exist, add a P-node - - if( Tp1->PartListEnd == NULL ){ // This is the first P-node under current T-node - Tp1->PartList = Pptr; - Tp1->PartListEnd = Pptr; - Tp1->n_node = Tp1->n_node + 1; - } - else{ // There are already many P-nodes under this T-node - Ptail = Tp1->PartListEnd; - Ptail->NextPNODE = Pptr; - Tp1->PartListEnd = Pptr; - Tp1->n_node = Tp1->n_node + 1; - } - break; // jump out of this "while" loop - } - - if( ttmp > t1 && ttmp < t2 ){ // Create a new T-node and insert between *Tp1 and *Tp2, then add P-node to it - - newTNODE = CreateTNODE(ttmp); - InsertTNODE( Tp1, Tp2, newTNODE); - - newTNODE->n_node = 1; - newTNODE->PartList = Pptr; - newTNODE->PartListEnd = Pptr; - break; // jump out of this "while" loop - } - - // move to next T-node - Tp1 = Tp1->NextTNODE; - t1 = Tp1->t_node; - - if(Tp2->NextTNODE != NULL){ - Tp2 = Tp2->NextTNODE; - t2 = Tp2->t_node; - } - else{ break; } - - }// while( Tp1->NextTNODE != NULL ) - -}//for(i=0;iNextTNODE; - free(head); - -} - -//End of CreateLinkList() -/**************************************************************/ - - -/************************************************************** -This Function is used to modify the link list, -after get new dt for active particles. Then point *CurrT to next -T-node. -**************************************************************/ - -void ModifyLinkList(){ - - struct TNODE *Tp1,*Tp2,*newTNODE; - struct PNODE *Pptr,*Ptail; - - int i, iii; - double ttmp, t1, t2; - - for(i=0;iNextTNODE; - t1 = Tp1->t_node; - t2 = Tp2->t_node; - - Pptr = CreatePNODE( iii ); - - while( Tp1->NextTNODE != NULL ){ - if( ttmp == t1 ){ // if T-node exist, add a P-node - - if( Tp1->PartListEnd == NULL ){ // This is the first P-node under current T-node - Tp1->PartList = Pptr; - Tp1->PartListEnd = Pptr; - Tp1->n_node = Tp1->n_node + 1; - } - else{ // There are already many P-nodes under this T-node - Ptail = Tp1->PartListEnd; - Ptail->NextPNODE = Pptr; - Tp1->PartListEnd = Pptr; - Tp1->n_node = Tp1->n_node + 1; - } - break; // jump out of this "while" loop - } - - if( ttmp > t1 && ttmp < t2 ){ // Create a new T-node and insert between *Tp1 and *Tp2, then add P-node to it - - newTNODE = CreateTNODE(ttmp); - InsertTNODE( Tp1, Tp2, newTNODE); - - newTNODE->n_node = 1; - newTNODE->PartList = Pptr; - newTNODE->PartListEnd = Pptr; - - break; // jump out of this "while" loop - } - - // move to next T-node - Tp1 = Tp1->NextTNODE; - t1 = Tp1->t_node; - - if(Tp2->NextTNODE != NULL){ - Tp2 = Tp2->NextTNODE; - t2 = Tp2->t_node; - } - else{ break; } - - }//while( Tp1->NextTNODE != NULL ) - - }//for(i=0;iNextTNODE; - DeleteTNODE( Tp1 ); -} - -//End of ModifyLinkList() -/***************************************************************/ - - -/***************************************************************/ -/* -void i_swap(int *a, int *b) -{ -register int tmp; -tmp = *a; *a = *b; *b = tmp; -} -*/ -/***************************************************************/ -/***************************************************************/ -void ind_act_sort(int l, int r) -{ - -int i, j, cikl, tmp; - -i = l; j = r; -tmp = ind_act[(l+r)/2]; - -cikl = 1; - -while(cikl) - { - while (ind_act[i]PartList; - n_act = 0; - - min_t = CurrT->t_node; // IMPORTANT !! - - flag = 0; - - while(Pptr != NULL) - { - iii = Pptr->Pid; - Pptr = Pptr->NextPNODE; - if( m[iii] != 0.0 ) // Do not put zero mass part. in active plist - { - ind_act[i] = iii; -// if(ind_act[i]==N-1) flag=1; - i++; n_act++; - } - } - - if( n_act > 2 ) ind_act_sort( 0, n_act-1 ); - -// printf("last pid: %06d\n", ind_act_ll[n_act-1]); -// if( flag == 0 ) printf("Warning: BH not in the ind_act array!\n"); -// if( ind_act[n_act-1]!= N-1) printf("Warning: BH not in the last of ind_act array!\n"); - - }// End of get_act_plist() -/**************************************************************/ - - -#ifdef DEBUG_extra -/************************************************************** -Check link list -**************************************************************/ -void check_linklist(int Tstep) - { - FILE *listf; - struct TNODE *Tptr; - - listf = fopen("Check_linklist.dat","a"); - Tptr = CurrT; - fprintf(listf,"Timesteps = %04d\n", Tstep); - while(Tptr != NULL) - { - fprintf(listf,"% 8E %04d\n", Tptr->t_node, Tptr->n_node); - Tptr = Tptr->NextTNODE; - } - - fprintf(listf,"========================\n\n"); - - fclose(listf); - } -/**************************************************************/ -#endif - diff --git a/black_holes.cpp b/black_holes.cpp new file mode 100644 index 0000000..2e6f5f7 --- /dev/null +++ b/black_holes.cpp @@ -0,0 +1,180 @@ +#include +#include +#include "black_holes.h" + +/* BEGIN legacy inclusion */ +// I'm not going to touch this C file +#define SQR(x) ((x)*(x)) +double L[3]; // needed in pn_bh_spin.c +#include "pn_bh_spin.c" +#undef SQR +/* END legacy inclusion */ + +void two_body_gravity(const Particle_ref& j, const Particle_ref& i, const double eps, double& pot, double3& acc, double3& jrk) +{ + double3 dx = i.x - j.x; + double3 dv = i.v - j.v; + double r2 = dx.norm2() + eps*eps; + double r = sqrt(r2); + double r3 = r2*r; + double r4 = r2*r2; + double RP = 3*(dx*dv)/r; + + pot = -j.m/r; + acc = -j.m*dx/r3; + jrk = -j.m*(dv/r3 - RP*dx/r4); +} + +void Black_hole_physics::adjust_softening(const std::vector& particles) +{ + if (eps_new < 0) return; + double pot_old, pot_new; + double3 acc_old, acc_new, jrk_old, jrk_new; + for (int j = 0; j < particles.size(); j++) { + for (int i = 0; i < particles.size(); i++) { + if (i == j) continue; + two_body_gravity(particles[j], particles[i], eps_old, pot_old, acc_old, jrk_old); + two_body_gravity(particles[j], particles[i], eps_new, pot_new, acc_new, jrk_new); + particles[i].pot += pot_new - pot_old; + particles[i].acc += acc_new - acc_old; + particles[i].jrk += jrk_new - jrk_old; + } + } +} + +#if 0 +void Black_hole_physics::adjust_post_newtonian( + const double dt_bh, // pn_usage should be const + double3& acc1, double3& acc2, + double3& jrk1, double3& jrk2) +{ + // calculate and "plus" the new BH <-> BH : PN1, PN2, PN2.5, PN3, PN3.5 : acc, jerk + // TODO maybe have the PN terms as local variables here? + int tmp; + tmp = calc_force_pn_BH(masses[0], x1, v1, bbh_grav.spin1, + masses[1], x2, v2, bbh_grav.spin2, + c, dt_bh, pn_usage, + (double(*)[3])bbh_grav.a_pn1, (double(*)[3])bbh_grav.adot_pn1, + (double(*)[3])bbh_grav.a_pn2, (double(*)[3])bbh_grav.adot_pn2, myRank, rootRank); + if (tmp == 505) exit(-1); // Very ugly way to terminate + + // NOTE we have these _corr variables accumulating the corrections before + // applying it. It's almost the same but different from applying each + // correction term in a loop. + double3 acc1_corr(0,0,0), acc2_corr(0,0,0), jrk1_corr(0,0,0), jrk2_corr(0,0,0); + for (int i=1; i<7; i++) { + acc1_corr += bbh_grav.a_pn1[i]; + acc2_corr += bbh_grav.a_pn2[i]; + jrk1_corr += bbh_grav.adot_pn1[i]; + jrk2_corr += bbh_grav.adot_pn2[i]; + } + acc1 += acc1_corr; + acc2 += acc2_corr; + jrk1 += jrk1_corr; + jrk2 += jrk2_corr; +} +#endif + +void Black_hole_physics::write_bh_data(const double time_cur, const int count, const std::vector &m, const std::vector &x, const std::vector &v, const std::vector &pot, const std::vector &a, const std::vector &adot, const std::vector &dt) +{ + auto out = fopen("bh.dat", "a"); + for (int i = 0; i < count; i++) { + fprintf(out,"%.16E \t %.8E \t % .16E % .16E % .16E \t %.16E \t % .16E % .16E % .16E \t %.16E \t % .8E \t % .8E % .8E % .8E \t %.8E \t % .8E % .8E % .8E \t %.8E \t %.8E \n", + time_cur, m[i], + x[i][0], x[i][1], x[i][2], x[i].norm(), + v[i][0], v[i][1], v[i][2], v[i].norm(), + pot[i], + a[i][0], a[i][1], a[i][2], a[i].norm(), + adot[i][0], adot[i][1], adot[i][2], adot[i].norm(), + dt[i]); + } + fprintf(out, "\n"); + fclose(out); +} + +void Write_bh_nb_data::operator()(double time_cur) +{ + for (int i_bh=0; i_bh < smbh_count; i_bh++) { + for (int i=0; i& ind_act, int n_act, double timesteps, double time_cur) +{ + double m_bh1 = m[0]; + double m_bh2 = m[1]; + double3 x_bh1 = x[0]; + double3 x_bh2 = x[1]; + double3 v_bh1 = v[0]; + double3 v_bh2 = v[1]; + + double3 x_bbhc = (m_bh1*x_bh1 + m_bh2*x_bh2)/(m_bh1 + m_bh2); + double3 v_bbhc = (m_bh1*v_bh1 + m_bh2*v_bh2)/(m_bh1 + m_bh2); + + double DR2 = (x_bh1 - x_bh2).norm2(); + double DV2 = (v_bh1 - v_bh2).norm2(); + double EB = -(m_bh1 + m_bh2) / sqrt(DR2) + 0.5 * DV2; + double SEMI_a = -0.5 * (m_bh1 + m_bh2)/EB; + double SEMI_a2 = SEMI_a*SEMI_a; + + for (int i=0; i +#include +#include +#include "double3.h" + +struct Particle_ref { + Particle_ref(double& m, double3& x, double3& v, double& pot, double3& acc, double3& jrk) : + m(m), x(x), v(v), pot(pot), acc(acc), jrk(jrk) {} + const double& m; + const double3& x; + const double3& v; + double& pot; + double3& acc; + double3& jrk; +}; + +struct Bbh_gravity { + double pot1, pot2; + double3 a1, a2, adot1, adot2, a_pn1[7], a_pn2[7], adot_pn1[7], adot_pn2[7]; + double spin1[3], spin2[3]; +}; + +class Black_hole_physics { +public: + Black_hole_physics() + : count(0), c(0) {} + Black_hole_physics(const int count, const int myRank, const int rootRank) + : count(count), c(0), myRank(myRank), rootRank(rootRank) {} + void set_post_newtonian(const double c, const int pn_usage[7]) + { + this->c = c; + std::copy(pn_usage, pn_usage+7, this->pn_usage); + } + void set_spins(const double spin1[3], const double spin2[3]) + { + std::copy(spin1, spin1+3, this->bbh_grav.spin1); + std::copy(spin2, spin2+3, this->bbh_grav.spin2); + } + void set_softening(const double eps_old, const double eps_new) + { + this->eps_old = eps_old; + this->eps_new = eps_new; + } + void adjust_softening(const std::vector& particles); + + void adjust_post_newtonian( + const double dt_bh, // pn_usage should be const + double3& acc1, double3& acc2, + double3& jrk1, double3& jrk2); + void write_bh_data(const double time_cur, const int count, const std::vector &m, const std::vector &x, const std::vector &v, const std::vector &pot, const std::vector &a, const std::vector &adot, const std::vector &dt); +public: //TODO make private + /////////////std::vector masses; + int count; + int myRank, rootRank; + double eps_old, eps_new; + double c; + int pn_usage[7]; + Bbh_gravity bbh_grav; +}; + +class Write_bh_nb_data { +public: + Write_bh_nb_data(int nb, int smbh_count, int N, const std::vector &m, const std::vector &x, const std::vector &v) + : nb(nb), smbh_count(smbh_count), N(N), m(m), x(x), v(v) + { + ind_sort.resize(N); + var_sort.resize(N); + out = fopen("bh_neighbors.dat", "w"); + } + ~Write_bh_nb_data() + { + fclose(out); + } + void operator()(double time_cur); +private: + int nb, smbh_count, N; + const std::vector &m; + const std::vector &x, &v; + std::vector ind_sort; + std::vector var_sort; + FILE *out; +}; + +class Binary_smbh_influence_sphere_output { +public: + Binary_smbh_influence_sphere_output(double factor, int N, const std::vector &m, const std::vector &x, const std::vector &v, const std::vector &pot, const std::vector &dt) + : factor(factor), m(m), x(x), v(v), pot(pot), dt(dt) + { + inf_event.assign(N, 0); + out = fopen("bbh_inf.dat", "w"); + } + + ~Binary_smbh_influence_sphere_output() + { + fclose(out); + } + void operator()(const std::vector& ind_act, int n_act, double timesteps, double time_cur); +private: + double factor; + const std::vector &pot, &m, &dt; + const std::vector &x, &v; + std::vector inf_event; + FILE *out; +}; diff --git a/cmd.c b/cmd.c deleted file mode 100644 index 8d99a68..0000000 --- a/cmd.c +++ /dev/null @@ -1,76 +0,0 @@ - -int cmd(int kstar, double rstar, double lstar, double Rgal, double *abvmag, double *vmag, double *BV, double *Teff, double *dvmag, double *dBV) - { - - double lTeff, BC, kb; - double bvc[8], bcc[8]; - double dbmag; - double BCsun, abvmagsun; - double rand1, rand2, prand; - - kb = 5.6704E-08*0.5*1.3914E9*0.5*1.3914E9/3.846E26; //Stefan-Boltzmann constant in Lsun Rsun^-2 K^-4 - - bvc[0] = -654597.405559323; - bvc[1] = 1099118.61158915; - bvc[2] = -789665.995692672; - bvc[3] = 314714.220932623; - bvc[4] = -75148.4728506455; - bvc[5] = 10751.803394526; - bvc[6] = -853.487897283685; - bvc[7] = 28.9988730655392; - - bcc[0] = -4222907.80590972; - bcc[1] = 7209333.13326442; - bcc[2] = -5267167.04593882; - bcc[3] = 2134724.55938336; - bcc[4] = -518317.954642773; - bcc[5] = 75392.2372207101; - bcc[6] = -6082.7301194776; - bcc[7] = 209.990478646363; - - BCsun = 0.11; //sun's bolometric correction - abvmagsun = 4.83; //sun's absolute V magnitude - - if( rstar && (kstar<14) ) - { - *Teff = pow(lstar/(4.0*Pi*rstar*rstar*kb),0.25); - - if( (*Teff>3000.0) && (*Teff<55000.0) ) - { - lTeff = log10(*Teff); - *BV = bvc[0] + bvc[1]*lTeff + bvc[2]*pow(lTeff,2) + bvc[3]*pow(lTeff,3) + bvc[4]*pow(lTeff,4) + bvc[5]*pow(lTeff,5) + bvc[6]*pow(lTeff,6) + bvc[7]*pow(lTeff,7); - BC = bcc[0] + bcc[1]*lTeff + bcc[2]*pow(lTeff,2) + bcc[3]*pow(lTeff,3) + bcc[4]*pow(lTeff,4) + bcc[5]*pow(lTeff,5) + bcc[6]*pow(lTeff,6) + bcc[7]*pow(lTeff,7); - if(lstar) *abvmag = -2.5*log10(lstar)-BC+BCsun+abvmagsun; - *vmag = *abvmag + 5.0*log10(Rgal) - 5.0; - - do{ - rand1 = 2.0*drand48()-1.0; - rand2 = 2.0*drand48()-1.0; - } while (rand1*rand1+rand2*rand2 > 1.0); - - prand = sqrt(-2.0*log(rand1*rand1+rand2*rand2)/(rand1*rand1+rand2*rand2)); - *dvmag = rand1*prand*sqrt(pow(0.02,2) + pow(0.07*pow(10.0, 0.4*(*vmag-25.0)),2)); - dbmag = rand2*prand*sqrt(pow(0.02,2) + pow(0.07*pow(10.0, 0.4*(*vmag-25.0)),2)); - *dBV = *dvmag + dbmag; - } - else - { - *vmag = 9999.9; - *abvmag = 9999.9; - *BV = 9999.9; - *dvmag = 0.0; - *dBV = 0.0; - } - } - else - { - *Teff = 0.0; - *vmag = 9999.9; - *abvmag = 9999.9; - *BV = 9999.9; - *dvmag = 0.0; - *dBV = 0.0; - } - - return(0); -} diff --git a/config.cpp b/config.cpp new file mode 100644 index 0000000..86e704e --- /dev/null +++ b/config.cpp @@ -0,0 +1,245 @@ +#include "config.h" +#include +#include +#include +#include +#include + +// Would be a bit more elegant to do the whole thing with std::variant. + +using Dictionary = std::unordered_map; + +static constexpr double nix = -std::numeric_limits::max(); // avoid nans + +std::string Config::strip(const std::string str) +{ + std::string str_new = str; + auto pos = str_new.find_first_not_of(" \t"); + if (pos != std::string::npos) str_new = str_new.substr(pos, str_new.size()); + pos = str_new.find_last_not_of(" \t"); + if (pos != std::string::npos) str_new = str_new.substr(0, pos+1); + return str_new; +} + +Dictionary Config::read_config_file(const std::string file_name) +{ + std::unordered_map dictionary; + std::ifstream file(file_name); + if (!file.good()) throw std::runtime_error("File not found."); + std::string str; + int line_number = 0; + while (std::getline(file, str)) { + line_number++; + auto pos = str.find('#'); + if (pos != std::string::npos) str = str.substr(0, pos); + str = strip(str); + if (str.size() == 0) continue; + pos = str.find_first_of("="); + if (pos == std::string::npos) throw std::runtime_error("Error: expected a key-value pair in line " + std::to_string(line_number) + " of file " + file_name); + std::string key = strip(str.substr(0, pos)); + pos = str.find_first_not_of(" \t", pos+1); + std::string val = strip(str.substr(pos, str.size())); + dictionary[key] = val; + } + return dictionary; +} + +template<> std::string Config::string_cast(const std::string str) +{ + return str; +} + +template<> double Config::string_cast(const std::string str) +{ + size_t idx; + auto value = std::stod(str, &idx); + if (idx == str.size()) return value; + else throw std::runtime_error("Cannot convert \"" + str + "\" into a double"); +} + +template<> int Config::string_cast(const std::string str) +{ + size_t idx; + auto value = std::stoi(str, &idx); // WARNING stoi can throw + if (idx == str.size()) return value; + else throw std::runtime_error("Cannot convert \"" + str + "\" into an int"); +} + +template<> bool Config::string_cast(const std::string str) +{ + if ((str=="true") || (str=="True") || (str=="yes") || (str=="Yes") || (str=="1")) return true; + else if ((str=="false") || (str=="False") || (str=="no") || (str=="No") || (str=="0")) return false; + throw std::runtime_error("Cannot convert \"" + str + "\" into a bool"); +} + +template<> std::vector Config::string_cast(const std::string str) +{ + auto error = std::runtime_error("Cannot convert \"" + str + "\" into an integer array"); + if (!( (str.front()=='{') && (str.back()=='}'))) throw error; + std::string new_str = strip(str.substr(1, str.length()-2)); + std::replace(new_str.begin(), new_str.end(), ',', ' '); + + std::vector result; + while (new_str.length() > 0) { + size_t idx; + auto value = std::stoi(new_str, &idx); + result.push_back(value); + new_str = new_str.substr(idx, new_str.length()-idx); + } + return result; +} + +template<> std::vector Config::string_cast(const std::string str) +{ + auto error = std::runtime_error("Cannot convert \"" + str + "\" into an integer array"); + if (!( (str.front()=='{') && (str.back()=='}'))) throw error; + std::string new_str = strip(str.substr(1, str.length()-2)); + std::replace(new_str.begin(), new_str.end(), ',', ' '); + + std::vector result; + while (new_str.length() > 0) { + size_t idx; + auto value = std::stod(new_str, &idx); + result.push_back(value); + new_str = new_str.substr(idx, new_str.length()-idx); + } + return result; +} + + +// For mandatory parameters +template +T Config::get_parameter(Dictionary dictionary, std::string name) +{ + auto item = dictionary.find(name); + if (item==dictionary.end()) throw std::runtime_error("Mandatory parameter " + name + " must be defined"); + else return string_cast((*item).second); +} + +// For optional parameters +template +T Config::get_parameter(Dictionary dictionary, std::string name, T default_value) +{ + auto item = dictionary.find(name); + if (item==dictionary.end()) return default_value; + else return string_cast((*item).second); +} + +#include + +void Config::error_checking() +{ +#ifndef HAS_HDF5 + if (output_hdf5) + throw std::runtime_error("HDF5 output format (output_hdf5=true) requires the code to be compiled with HAS_HDF5"); +#endif + if (live_smbh_count < 0) + throw std::runtime_error("The number of live black holes (live_smbh_count) has to be greater than or equals to zero"); + if (binary_smbh_pn && (live_smbh_count!=2)) + throw std::runtime_error("Post-Newtonian gravity (binary_smbh_pn=true) requires live_smbh_count=2"); + if (binary_smbh_pn && (pn_c <= 0)) + throw std::runtime_error("Post-Newtonian gravity (binary_smbh_pn=true) requires pn_c > 0"); + if (live_smbh_custom_eps == eps) live_smbh_custom_eps = -1; + if (live_smbh_output && (live_smbh_count == 0)) + throw std::runtime_error("Black hole output (live_smbh_output=true) requires at least one live black hole (live_smbh_count)"); + if (live_smbh_neighbor_output && (live_smbh_count == 0)) + throw std::runtime_error("Black hole neighbour output (live_smbh_neighbor_output=true) requires at least one live black hole (live_smbh_count)"); + if (binary_smbh_influence_sphere_output && (live_smbh_count != 2)) + throw std::runtime_error("Binary black hole influence sphere output (binary_smbh_influence_sphere_output=true) requires exactly two live black holes (live_smbh_count=2)"); + if (pn_usage.size() != 7) + throw std::runtime_error("PN usage array (pn_usage) must have exactly seven components"); + if (binary_smbh_pn) + for (int i=0; i<7; i++) + if (!((pn_usage[i] == 0) || (pn_usage[i] == 1))) + throw std::runtime_error("PN usage array (pn_usage) must be a 7-component vector filled with ones and zeros only"); + if ((smbh1_spin.size()!=3) || (smbh2_spin.size()!=3)) + throw std::runtime_error("Spins must be three-component vectors"); + if ((pn_usage[6]==1) && ((smbh1_spin[0]==nix) || (smbh2_spin[0]==nix))) + throw std::runtime_error("Please define smbh1_spin and smbh2_spin or disable the spin by setting the last component of pn_usage to zero"); + std::cout << smbh1_spin[0] << std::endl; + std::cout << smbh1_spin[1] << std::endl; + std::cout << smbh1_spin[2] << std::endl; + if ((pn_usage[6]==0) && ((smbh1_spin[0]!=nix) || (smbh2_spin[0]!=nix))) + throw std::runtime_error("Spins (smbh1_spin and smbh2_spin) may not be defined if the last element of pn_usage is set to zero"); + + + if (ext_units_physical && ((unit_mass == 0) || (unit_length == 0))) + throw std::runtime_error("Physical units for external gravity (ext_units_physical) requires ext_unit_mass and ext_unit_length to be positive numbers"); + if ((ext_m_bulge > 0) && (ext_b_bulge < 0)) + throw std::runtime_error("To use external bulge gravity, please specify positive ext_m_bulge and ext_b_bulge"); + if ((ext_m_halo_plummer > 0) && (ext_b_halo_plummer < 0)) + throw std::runtime_error("To use external Plummer halo gravity, please specify positive ext_m_halo_plummer and ext_b_halo_plummer"); + if ((ext_m_disk > 0) && ((ext_a_disk < 0) || (ext_b_disk < 0))) + throw std::runtime_error("To use external disk gravity, please specify positive ext_m_disk, ext_a_disk and ext_b_disk"); + if (((ext_log_halo_r > 0) && (ext_log_halo_v <= 0)) || ((ext_log_halo_r <= 0) && (ext_log_halo_v > 0))) + throw std::runtime_error("To use external logarithmic halo gravity, please specify positive ext_log_halo_r and ext_log_halo_v"); + if ((ext_dehnen_m > 0) && ((ext_dehnen_r <= 0) || (ext_dehnen_gamma <= 0))) + throw std::runtime_error("To use external Dehnen model, please specify positive ext_dehnen_r and ext_dehnen_gamma"); +} + +Config::Config(std::string file_name) +{ + auto dictionary = read_config_file(file_name); + + // TODO check if dt_disk and dt_contr are powers of two + eps = get_parameter(dictionary, "eps"); + t_end = get_parameter(dictionary, "t_end"); + dt_disk = get_parameter(dictionary, "dt_disk"); + dt_contr = get_parameter(dictionary, "dt_contr"); + dt_bh = get_parameter(dictionary, "dt_bh", dt_contr); + eta = get_parameter(dictionary, "eta"); + input_file_name = get_parameter(dictionary, "input_file_name", "data.con"); + devices_per_node = get_parameter(dictionary, "devices_per_node", 0); + dt_max_power = get_parameter(dictionary, "dt_max_power", -3); + dt_min_power = get_parameter(dictionary, "dt_min_power", -36); + eta_s_corr = get_parameter(dictionary, "eta_s_corr", 4); + eta_bh_corr = get_parameter(dictionary, "eta_bh_corr", 4); + + output_hdf5 = get_parameter(dictionary, "output_hdf5", false); + output_hdf5_double_precision = get_parameter(dictionary, "output_hdf5_double_precision", true); + output_ascii_precision = get_parameter(dictionary, "output_ascii_precision", 10); + output_extra_mode = get_parameter(dictionary, "output_extra_mode", 10); + dt_min_warning = get_parameter(dictionary, "dt_min_warning", false); + + live_smbh_count = get_parameter(dictionary, "live_smbh_count", 0); + live_smbh_custom_eps = get_parameter(dictionary, "live_smbh_custom_eps", -1); + live_smbh_output = get_parameter(dictionary, "live_smbh_output", false); + live_smbh_neighbor_output = get_parameter(dictionary, "live_smbh_neighbor_output", false); + live_smbh_neighbor_number = get_parameter(dictionary, "live_smbh_neighbor_number", 10); + + binary_smbh_influence_sphere_output = get_parameter(dictionary, "binary_smbh_influence_sphere_output", false); + binary_smbh_influence_radius_factor = get_parameter(dictionary, "binary_smbh_influence_radius_factor", 10.); + + binary_smbh_pn = get_parameter(dictionary, "binary_smbh_pn", false); + pn_usage = get_parameter>(dictionary, "pn_usage", std::vector({-1,-1,-1,-1,-1,-1,-1})); + pn_c = get_parameter(dictionary, "pn_c", 0); + smbh1_spin = get_parameter>(dictionary, "smbh1_spin", std::vector({nix,nix,nix})); + smbh2_spin = get_parameter>(dictionary, "smbh2_spin", std::vector({nix,nix,nix})); + + ext_units_physical = get_parameter(dictionary, "ext_units_physical", false); + unit_mass = get_parameter(dictionary, "unit_mass", !ext_units_physical); + unit_length = get_parameter(dictionary, "unit_length", !ext_units_physical); + ext_m_bulge = get_parameter(dictionary, "ext_m_bulge", 0); + ext_b_bulge = get_parameter(dictionary, "ext_b_bulge", -1); + ext_m_disk = get_parameter(dictionary, "ext_m_disk", 0); + ext_a_disk = get_parameter(dictionary, "ext_a_disk", -1); + ext_b_disk = get_parameter(dictionary, "ext_b_disk", -1); + ext_m_halo_plummer = get_parameter(dictionary, "ext_m_halo_plummer", 0); + ext_b_halo_plummer = get_parameter(dictionary, "ext_b_halo_plummer", -1); + ext_log_halo_v = get_parameter(dictionary, "ext_log_halo_v", 0); + ext_log_halo_r = get_parameter(dictionary, "ext_log_halo_r", 0); + ext_dehnen_m = get_parameter(dictionary, "ext_dehnen_m", 0); + ext_dehnen_r = get_parameter(dictionary, "ext_dehnen_r", -1); + ext_dehnen_gamma = get_parameter(dictionary, "ext_dehnen_gamma", -1); + +#ifdef ETICS + dt_scf = get_parameter(dictionary, "dt_scf"); + grapite_mask_file_name = get_parameter(dictionary, "grapite_mask_file_name", "grapite.mask"); + etics_dump_coeffs = get_parameter(dictionary, "etics_dump_coeffs", false); + grapite_active_search = get_parameter(dictionary, "grapite_active_search", false); + grapite_smbh_star_eps = get_parameter(dictionary, "grapite_smbh_star_eps", -1); + grapite_dev_exec_threshold = get_parameter(dictionary, "grapite_dev_exec_threshold", 32); +#endif + + error_checking(); +} diff --git a/config.h b/config.h new file mode 100644 index 0000000..93c0fa6 --- /dev/null +++ b/config.h @@ -0,0 +1,76 @@ +#pragma once +#include +#include +#include + +class Config { +public: + Config(std::string file_name); + + double eps; + double t_end; + double dt_disk; + double dt_contr; + double dt_bh; + double eta; + std::string input_file_name; + int devices_per_node; + int dt_max_power; + int dt_min_power; + double eta_s_corr; + double eta_bh_corr; + + bool output_hdf5; + bool output_hdf5_double_precision; + int output_ascii_precision; + int output_extra_mode; + bool dt_min_warning; + + int live_smbh_count; + double live_smbh_custom_eps; + bool live_smbh_output; + bool live_smbh_neighbor_output; + int live_smbh_neighbor_number; + + bool binary_smbh_pn; + bool binary_smbh_influence_sphere_output; + double binary_smbh_influence_radius_factor; + std::vector pn_usage; + double pn_c; + std::vector smbh1_spin; + std::vector smbh2_spin; + + bool ext_units_physical; + double unit_mass; + double unit_length; + double ext_m_bulge; + double ext_b_bulge; + double ext_m_disk; + double ext_a_disk; + double ext_b_disk; + double ext_m_halo_plummer; + double ext_b_halo_plummer; + double ext_log_halo_r; + double ext_log_halo_v; + double ext_dehnen_m; + double ext_dehnen_r; + double ext_dehnen_gamma; + +#ifdef ETICS + double dt_scf; + std::string grapite_mask_file_name; + bool etics_dump_coeffs; + bool grapite_active_search; + double grapite_smbh_star_eps; + int grapite_dev_exec_threshold; +#endif + +private: + using Dictionary = std::unordered_map; + Dictionary read_config_file(const std::string file_name); + std::string strip(const std::string str); + template T string_cast(const std::string str); + template T get_parameter(Dictionary dictionary, std::string name); + template T get_parameter(Dictionary dictionary, std::string name, T default_value); + void error_checking(); +}; 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/def_DEN.c b/def_DEN.c deleted file mode 100644 index 7cb217b..0000000 --- a/def_DEN.c +++ /dev/null @@ -1,38 +0,0 @@ - -/*************************************************************************/ -/*************************************************************************/ -/*************************************************************************/ - -void DEF_DEN(double x_gas[][3], double m_gas[], double h_gas[], int sosed_gas[][NB], double DEN_gas[]) -{ - -double Xij, Yij, Zij, Rij, tmp; - -/* SPH style */ - -for(i=0;i= 0.0) && (v <= 1.0) ) - { - tmp = 1.0 - 1.5*v2 + 0.75*v3; - } - else - { - if( (v > 1.0) && (v < 2.0) ) - { - tmp = 0.25*(2.0-v)*(2.0-v)*(2.0-v); - } - else - { - tmp = 0.0; /* if ( v >= 2.0 ) */ - } - } - - tmp = 1.0/(Pi*h*h*h)*tmp; - - return(tmp); - -} - -/*************************************************************************/ - -void DEF_H(double x_gas[][3], double h_gas[], int sosed_gas[][NB]) -{ - -int sosed_tmp[N_GAS_MAX]; -double Xij, Yij, Zij; - -for(i=0;i + +struct double3 { + union { + struct {double x, y, z;}; + double data[3]; // For legacy access + }; + double3() {} + double3(const double x, const double y, const double z) + : x(x), y(y), z(z) {} + double& operator[](int i) {return data[i];} + const double operator[](int i) const {return data[i];} + double3& operator=(const double3& a) + { + x = a.x; + y = a.y; + z = a.z; + return *this; + } + double3& operator+=(const double3& a) + { + x += a.x; + y += a.y; + z += a.z; + return *this; + } + double3& operator-=(const double3& a) + { + x -= a.x; + y -= a.y; + z -= a.z; + return *this; + } + double3& operator/=(const double& c) + { + x /= c; + y /= c; + z /= c; + return *this; + } + double norm2() const + { + return x*x + y*y + z*z; + } + double norm() const + { + return sqrt(x*x + y*y + z*z); + } + operator double*() {return data;} +}; + +inline double3 operator*(const double& c, const double3& a) +{ + return double3(a.x*c, a.y*c, a.z*c); +} + +inline double3 operator*(const double3& a, const double& c) +{ + return double3(a.x*c, a.y*c, a.z*c); +} + +inline double operator*(const double3& a, const double3& b) +{ + return a.x*b.x+a.y*b.y+a.z*b.z; +} + +inline double3 operator/(const double3& a, const double& c) +{ + return double3(a.x/c, a.y/c, a.z/c); +} + +inline double3 operator+(const double3& a, const double3& b) +{ + return double3(a.x+b.x, a.y+b.y, a.z+b.z); +} + +inline double3 operator-(const double3& a, const double3& b) +{ + return double3(a.x-b.x, a.y-b.y, a.z-b.z); +} diff --git a/drag_force.c b/drag_force.c deleted file mode 100644 index 7b6c3e8..0000000 --- a/drag_force.c +++ /dev/null @@ -1,185 +0,0 @@ -/***************************************************************************** - File Name : "Drag Force.c" - Contents : Drag force calculus. - : Converted & optimized from Chingis Omarov Fortran code. - Coded by : Taras Panamarev, - : Denis Yurin, Maxim Makukov & Peter Berczik :-) - Last redaction : 2012-11-15 15:33 -*****************************************************************************/ - -// main parameters - -const double Md = 0.01; -const double s=4, beta_s=0.7, alpha=0.75, h=0.001; -const double r_lim2=(0.5*0.5), h_lim2=(5e-3*5e-3); -const double gradP_rho = 0.90; // account for -grad(P)/rho in gas disk... - -const double Qtot = 0.01; // 16e3 - -/* -const double Qtot = 0.00547000; // 8e3 -const double Qtot = 0.00296975; // 16e3 -const double Qtot = 0.00193372; // 32e3 -const double Qtot = 0.00054215; // 128KB -*/ - -int K; - -double RDISC, //projection of radius vector to the disc plane - h_z, // disc profile - RDISC2, Z2, RDISC_3over2, R, RR0, RR02, RR0_s, RDISC_5over2, R_zeta, R0_zeta, RRcrit, RRcrit_zeta,Rcrit_zeta, R_zetaR, - inner_hole, temp, sqrt_m_bh, pot_drag, - sigma0, R02, hR02, Rcrit, R0, zeta, - R_DOT, //the first derivative of absolute value of projection - COEFDENS, - RHO, RHODOT, //disc density and it's firs derivative with respect to time - VXDISC, VYDISC,//disc particle velocity components - VXRE, VYRE, VZRE, VRE,//the absolute value of relative (star-disc) velocity and it's components - coef, - FDRAGX, FDRAGY, FDRAGZ,//drag force components - DVXRE, DVYRE, DVZRE, DVRE,//first derivative of relative velocity and it's absolute value - KFDOT; - -void init_drag_force() - { - R0 = R_0; - Rcrit = R_CRIT; - - sigma0 = (2-alpha)*Md/(TWOPi*sqrt_TWOPi*h*R0); - R02 = SQR(R0); - hR02 = SQR(h*R0); - } - -void calc_drag_force() - { - - if (min_t < t_diss_on) return; -// if (min_t == t_diss_on) init_drag_force(); - init_drag_force(); - - for (i=0; i +#include +#include "double3.h" + +class External_gravity { +public: + void apply(const int n_act, const std::vector &x, const std::vector &v, std::vector &pot, std::vector &a, std::vector &adot) + { + for (int i=0; iset_coordinates(x[i], v[i]); + this->calc_gravity(); + pot[i] += potential; + a[i] += acceleration; + adot[i] += jerk; + } + } + virtual void calc_gravity() = 0; + virtual void print_info() {} + void set_name(const std::string &name) + { + this->name = name; + } + bool is_active = false; +protected: + double potential; + double3 acceleration, jerk; + double3 x, v; + std::string name = "ext"; + void set_coordinates(double3 x, double3 v) + { + this->x = x; + this->v = v; + } +}; + +class Plummer : public External_gravity { +public: + Plummer(double m, double b) : m(m), b(b) {is_active=(m>0);} + void calc_gravity() override; + void print_info() override + { + if (!is_active) return; + printf("m_%-5s = %.4E b_%-5s = %.4E\n", name.c_str(), m, name.c_str(), b); + } +private: + double m, b; +}; + +class Miyamoto_Nagai : public External_gravity { +public: + Miyamoto_Nagai(double m, double a, double b) : m(m), a(a), b(b) {is_active=(m>0); this->set_name("disk");} + void calc_gravity(); + void print_info() override + { + if (!is_active) return; + printf("m_%-5s = %.4E a_%-5s = %.4E b_%-5s = %.4E\n", name.c_str(), m, name.c_str(), a, name.c_str(), b); + } +private: + double m, a, b; +}; + +class Logarithmic_halo : public External_gravity { +public: + Logarithmic_halo(double v_halo, double r_halo) : v2_halo(v_halo*v_halo), r2_halo(r_halo*r_halo) {is_active=(r_halo>0); this->set_name("halo");} + void calc_gravity() override; + void print_info() override + { + if (!is_active) return; + printf("v_%-4s = %.6E r_%-4s = %.4E\n", name.c_str(), sqrt(v2_halo), name.c_str(), sqrt(r2_halo)); + } +private: + double v2_halo, r2_halo; +}; + +class Dehnen : public External_gravity { +public: + Dehnen(double m, double r, double gamma) : m(m), r(r), gamma(gamma) {is_active=(m>0);} + void calc_gravity() override; + void print_info() override + { + if (!is_active) return; + printf("m_%-5s = %.4E r_%-5s = %.4E g_%-5s = %.4E\n", name.c_str(), m, name.c_str(), r, name.c_str(), gamma); + } +private: + double m, r, gamma; +}; diff --git a/init.py b/init.py index e5aa76c..d6b1f34 100644 --- a/init.py +++ b/init.py @@ -13,7 +13,7 @@ def gen_plum(N, seed=None, RMAX=10): X = np.sqrt(R**2 - Z**2) * np.cos(2*np.pi*X3) Y = np.sqrt(R**2 - Z**2) * np.sin(2*np.pi*X3) - Ve = np.sqrt(2)*(1.0 + R**2)**(-0.25); + Ve = np.sqrt(2)*(1.0 + R**2)**(-0.25) X4, X5 = 0, 0 while 0.1*X5 >= X4**2*(1-X4**2)**3.5: @@ -22,9 +22,9 @@ def gen_plum(N, seed=None, RMAX=10): V = Ve*X4 X6, X7 = np.random.random(2) - Vz = (1 - 2*X6)*V; - Vx = np.sqrt(V**2 - Vz**2) * np.cos(2*np.pi*X7); - Vy = np.sqrt(V**2 - Vz**2) * np.sin(2*np.pi*X7); + Vz = (1 - 2*X6)*V + Vx = np.sqrt(V**2 - Vz**2) * np.cos(2*np.pi*X7) + Vy = np.sqrt(V**2 - Vz**2) * np.sin(2*np.pi*X7) X, Y, Z = np.array([X, Y, Z])*3*np.pi/16 Vx, Vy, Vz = np.array([Vx, Vy, Vz])/np.sqrt(3*np.pi/16) @@ -33,6 +33,38 @@ def gen_plum(N, seed=None, RMAX=10): i += 1 return particle_list +def kepler_to_cartesian(a, e, i, Omega, w, nu, G=1.0, M=1.0): + def to_arrays(*args): + result = [] + for arg in args: result.append(np.atleast_1d(arg)) + return result + a, e, i, Omega, w, nu = to_arrays(a, e, i, Omega, w, nu) # pylint: disable=unbalanced-tuple-unpacking + P = [np.cos(w)*np.cos(Omega) - np.sin(w)*np.cos(i)*np.sin(Omega), + np.cos(w)*np.sin(Omega) + np.sin(w)*np.cos(i)*np.cos(Omega), + np.sin(w)*np.sin(i)] + Q = [-np.sin(w)*np.cos(Omega) - np.cos(w)*np.cos(i)*np.sin(Omega), + -np.sin(w)*np.sin(Omega) + np.cos(w)*np.cos(i)*np.cos(Omega), + np.sin(i)*np.cos(w)] + cosnu = np.cos(nu) + cosE = (e+cosnu)/(1+e*cosnu) + E = np.arccos(cosE) + E[nu > np.pi] = 2*np.pi - E[nu > np.pi] + X = a*((np.cos(E)-e)*P + np.sqrt(1-e**2)*np.sin(E)*Q) + V = (np.sqrt(G*M/a)/(1-e*np.cos(E)))*(-np.sin(E)*P + np.sqrt(1-e**2)*np.cos(E)*Q) + if X.shape[1]==1: + X=X[:,0] + V=V[:,0] + return X.T, V.T + +def generate_binary(a, e, i, Omega, w, nu, m1, m2): + X, V = kepler_to_cartesian(a, e, i, Omega, w, nu, M=m1+m2) + q = np.double(m2)/np.double(m1) + X1 = -q/(q+1)*X + V1 = -q/(q+1)*V + X2 = 1/(q+1)*X + V2 = 1/(q+1)*V + return X1, V1, X2, V2 + def write_phi_grape_config(**kargs): if 'file_name' in kargs: file_name = kargs['file_name'] else: file_name = 'phi-GRAPE.cfg' @@ -59,6 +91,8 @@ def gen_mask(particle_list, frac): mask = np.ones(N, dtype=int) elif frac==1: mask = np.zeros(N, dtype=int) + elif (frac < 0) or (1 < frac): + raise RuntimeError('Fraction has to be between 0 and 1') else: X = particle_list[:,:3] V = particle_list[:,3:] @@ -86,6 +120,7 @@ if __name__=='__main__': parser.add_argument('--dt_bh', type=np.double, default=.125, help='interval for BH output (bh.dat & bh_nb.dat)') parser.add_argument('--eta', type=np.double, default=.01, help='parameter for timestep determination (0.02 or 0.01)') parser.add_argument('--frac', type=np.double, default=0, help='fraction of collisional particles (by angular momentum)') + parser.add_argument('--bsmbh', type=bool, default=0, help='generate a binary supermassive black hole (parameters hardcoded in the script)') args = parser.parse_args() try: @@ -97,9 +132,23 @@ if __name__=='__main__': write_phi_grape_config(**vars(args)) particle_list = gen_plum(N, seed=args.seed) + m = np.ones(N)/N - write_particles(particle_list) + if args.bsmbh: + m1, m2 = 0.075, 0.025 + a, e, i, Omega, w, nu = 0.001, 0.5, 0, 0, 0, 0 + X1, V1, X2, V2 = generate_binary(a, e, i, Omega, w, nu, m1, m2) + m[:2] = m1, m2 + m[2:] = 1/(N-2) + particle_list[0,:3] = X1 + particle_list[0,3:] = V1 + particle_list[1,:3] = X2 + particle_list[1,3:] = V2 + + write_particles(particle_list, m=m) mask = gen_mask(particle_list, args.frac) + if args.bsmbh: + mask[:2] = 3 write_mask(mask) diff --git a/io.cpp b/io.cpp new file mode 100644 index 0000000..34c4bbf --- /dev/null +++ b/io.cpp @@ -0,0 +1,204 @@ +#ifdef HAS_HDF5 +#include "hdf5.h" +#endif + +#include "double3.h" +#include "io.h" +#include +#include +#include +#include +#include +#include +#include + + +bool is_hdf5(std::string file_name) +{ + std::ifstream file(file_name, std::ifstream::binary); + const char hdf5_magic[] = "\x89HDF\x0d\x0a\x1a\x0a"; + char buffer[8]; + file.read(buffer, 8); + if (!file) throw std::runtime_error("Unable to read file " + file_name); + bool result = (memcmp(buffer, hdf5_magic, 8)==0); + file.close(); + return result; +} + +Input_data ascii_read(const std::string &file_name) +{ + Input_data input_data; + char rest[512]; + int result; + + std::ifstream file(file_name); + if (!file.good()) throw std::runtime_error("File " + file_name + " not found."); + std::string str; + + std::getline(file, str); + result = sscanf(str.c_str(), "%d%s", &input_data.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", &input_data.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", &input_data.t, rest); + if (result!=1) throw std::runtime_error("Error parsing line 3: expected one real number"); + + input_data.m.resize(input_data.N); + input_data.x.resize(input_data.N); + input_data.v.resize(input_data.N); + + int i = -1; + while (std::getline(file, str)) { + if (++i > input_data.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", &input_data.m[i], &(input_data.x[i].x), &(input_data.x[i].y), &(input_data.x[i].z), &(input_data.v[i].x), &(input_data.v[i].y), &(input_data.v[i].z), rest); + } + file.close(); + return input_data; +} + +void ascii_write(const std::string file_name, const int step_num, const int N, const double t, const std::vector &m, const std::vector &x, const std::vector &v, int precision) +{ + auto file = std::ofstream(file_name); + if (!file.is_open()) throw std::runtime_error("Cannot open file for output"); + int id_width = (int)log10(N-1) + 1; + char string_template[256], output_string[256]; + file << step_num << '\n'; + file << N << '\n'; + file.precision(16); + file << std::scientific << t << '\n'; + sprintf(string_template, "%%0%dd%%%d.%dE%%%d.%dE%%%d.%dE%%%d.%dE%%%d.%dE%%%d.%dE%%%d.%dE\n", id_width, precision+7, precision, precision+8, precision, precision+8, precision, precision+8, precision, precision+8, precision, precision+8, precision, precision+8, precision); + for (int i=0; i step_num_arr; + for (unsigned int i=0; i &m, const std::vector &x, const std::vector &v, const std::vector &pot, const std::vector &acc, const std::vector &jrk, const int extra_mode, const bool use_double_precision) +{ +#ifdef HAS_HDF5 + hid_t file_id, group_id, attribute_id, dataspace_id; + hsize_t dims[2] = {(hsize_t)N, 3}; + + hid_t h5_float_type; + if (use_double_precision) h5_float_type = H5T_IEEE_F64LE; + else h5_float_type = H5T_IEEE_F32LE; + file_id = H5Fcreate(file_name.c_str(), H5F_ACC_TRUNC, H5P_DEFAULT, H5P_DEFAULT); + char group_name[32]; + sprintf(group_name, "/Step#%d", step_num); + group_id = H5Gcreate2(file_id, group_name, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT); + dataspace_id = H5Screate(H5S_SCALAR); + attribute_id = H5Acreate2 (group_id, "Time", H5T_IEEE_F64LE, dataspace_id, H5P_DEFAULT, H5P_DEFAULT); + H5Awrite(attribute_id, H5T_NATIVE_DOUBLE, &t); + H5Sclose(dataspace_id); + + auto write_dataset = [&](const char dataset_name[], int ndims, double *data) { + hid_t dataspace_id = H5Screate_simple(ndims, dims, NULL); + char dataset_path[32]; + sprintf(dataset_path, "%s/%s", group_name, dataset_name); + hid_t dataset_id = H5Dcreate2(file_id, dataset_path, h5_float_type, dataspace_id, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT); + H5Dwrite(dataset_id, H5T_NATIVE_DOUBLE, H5S_ALL, H5S_ALL, H5P_DEFAULT, data); + H5Dclose(dataset_id); + H5Sclose(dataspace_id); + }; + + write_dataset("MASS", 1, (double*)m.data()); // casting away const... + write_dataset("X", 2, (double*)x.data()); + write_dataset("V", 2, (double*)v.data()); + + bool write_pot = (extra_mode ) & 1; + bool write_acc = (extra_mode >> 1) & 1; + bool write_jrk = (extra_mode >> 2) & 1; + if (write_pot) write_dataset("POT", 1, (double*)pot.data()); + if (write_acc) write_dataset("ACC", 2, (double*)acc.data()); + if (write_jrk) write_dataset("JRK", 2, (double*)jrk.data()); + + H5Gclose(group_id); + H5Fclose(file_id); + H5close(); // If we don't do that (HDF5 1.10.5) then the file isn't really closed... +#else + throw std::runtime_error("h5_write was called but compiled without HDF5 support"); +#endif +} diff --git a/io.h b/io.h new file mode 100644 index 0000000..097ebb9 --- /dev/null +++ b/io.h @@ -0,0 +1,24 @@ +#pragma once +#include +#include +#include "double3.h" + +struct Input_data { + int N, step_num; + double t; + std::vector m; + std::vector x, v; +}; + +bool is_hdf5(std::string file_name); +// This function is implemented independently of the HDF5 library + +Input_data ascii_read(const std::string &file_name); + +void ascii_write(const std::string file_name, const int step_num, const int N, const double t, const std::vector &m, const std::vector &x, const std::vector &v, int precision=10); + +Input_data h5_read(const std::string &file_name); +// In case the code is compiled without HDF5 support, the implementation of this function just throws an error + +void h5_write(const std::string file_name, const int step_num, const int N, const double t, const std::vector &m, const std::vector &x, const std::vector &v, const std::vector &pot, const std::vector &acc, const std::vector &jrk, const int extra_mode=0, const bool use_double_precision=true); +// In case the code is compiled without HDF5 support, the implementation of this function just throws an error diff --git a/n_bh.c b/n_bh.c deleted file mode 100644 index 2e389c2..0000000 --- a/n_bh.c +++ /dev/null @@ -1,76 +0,0 @@ -/***************************************************************************/ -/* - Coded by : Peter Berczik - Version number : 1.0 - Last redaction : 2011.II.20. 13:00 -*/ - -int calc_force_n_BH(double m1, double xx1[], double vv1[], - double m2, double xx2[], double vv2[], - double eps_BH, - double *pot_n1, double a_n1[], double adot_n1[], - double *pot_n2, double a_n2[], double adot_n2[]) -{ - -/* - INPUT - -m1 - mass of the 1 BH -xx1[0,1,2] - coordinate of the 1 BH -vv1[0,1,2] - velocity of the 1 BH - -m2 - mass of the 2 BH -xx2[0,1,2] - coordinate of the 2 BH -vv2[0,1,2] - velocity of the 2 BH - -eps_BH - force softening, can be even exactly 0.0 ! - - OUTPUT - -pot_n1 for the 1 BH -a_n1 [0,1,2] for the 1 BH -adot_n1 [0,1,2] for the 1 BH - -pot_n2 for the 2 BH -a_n2 [0,1,2] for the 2 BH -adot_n2 [0,1,2] for the 2 BH -*/ - - -int k; - -double r, r2, r3, r4, RP, x[3], v[3]; - - -for(k=0;k<3;k++) - { - x[k] = xx1[k] - xx2[k]; - v[k] = vv1[k] - vv2[k]; - } - -r2 = SQR(x[0]) + SQR(x[1]) + SQR(x[2]) + SQR(eps_BH); - -r = sqrt(r2); -r3 = r2*r; -r4 = r2*r2; - -RP = 3.0*(x[0]*v[0]+x[1]*v[1]+x[2]*v[2])/r; - -// Newton pot + acc & jerks - -*pot_n1 = -m2/r; -*pot_n2 = -m1/r; - -for(k=0;k<3;k++) - { - a_n1[k] = -m2*x[k]/r3; - a_n2[k] = m1*x[k]/r3; - - adot_n1[k] = -m2*(v[k]/r3 - RP*x[k]/r4); - adot_n2[k] = m1*(v[k]/r3 - RP*x[k]/r4); - } - -return(0); - -} -/***************************************************************************/ diff --git a/phi-GRAPE.c b/phi-GRAPE.c deleted file mode 100644 index 236ee7e..0000000 --- a/phi-GRAPE.c +++ /dev/null @@ -1,7293 +0,0 @@ -/***************************************************************************** - File Name : "phi-GRAPE/GPU.c" // BH (1 || 2) + ACC + EJECT - : - Contents : N-body code with integration by individual block time step - : together with the parallel using of GRAPE6a board's. - : - : Added the GPU support via SAPPORO library. - : - : Normalization to the physical units!!! - : - : External Potential added - : Plummer-Kuzmin: Bulge, Disk, Halo - : Kharchenko+Andreas... - : - : SC extra POT for Bek SC test runs... - : - : Rebuced to the Single BH -> Plummer - : Andreas+Fazeel... - : - : Stellar evolution added - : Stellar lifetimes: Raiteri, Villata & Navarro (1996) - : IMS mass loss: van den Hoeg & Groenewegen (1997) - : - : STARDESTR_EXT: Tidal disruption of stars by external BH... - : Chingis, Denis & Maxim... - : - : STARDESTR: Tidal disruption of stars by BH... - : Jose, Li Shuo & Shiyan Zhong - : - : STARDISK: Drag force... - : Chingis, Denis & Maxim... - : - : STARDISK: variable hz = HZ*(R/R_crit) up to R_crit... - : Taras, Andreas... - : - : Live BH (1 || 2) + ACC + EJECT... - : Li Shuo & Shiyan Zhong - : - : dt_min for BH (1 || 2)... - : - : added the PN calculus for the BBH - : PN0, PN1, PN2, PN2.5 (coded on the base of - : Gabor Kupi original routine) - : - : added the "name" array... - : - : added the GMC's calculus (GMC on CPU; GMC2 on GPU) - : for Alexey SC runs... and also for Fazeel Zurich runs... - : - : CPU_TIMELIMIT added for the Julich MW cluster runs... - : - Coded by : Peter Berczik - Version number : 19.04 - Last redaction : 2019.04.16 12:55 -*****************************************************************************/ -//#define CPU_RUNLIMIT 28000 // 24h = 24*60*60 = 86400 -#define CPU_RUNLIMIT 255000 // 3 days = 3*24*60*60 = 259200 -//#define CPU_RUNLIMIT 100 // 9.5 min -//#define CPU_RUNLIMIT 100 // 9.5 min - -//#define GMC // add the GMC's to the run -//#define GMC2 // add the GMC's to the run - -//#define NORM // Physical normalization -//#define STEVOL // Stellar evolution Do not tuch! Defined inside the Makefiles !!! -//#define STEVOL_SSE // Stellar evolution with SSE Do not tuch! Defined inside the Makefiles !!! - -//#define ADD_BH1 // add the Single BH - -#define ADD_BH2 // add the Binary BH's -#define ADD_N_BH // eps_BH = 0.0, but added only the Newtonian forces -// #define ADD_PN_BH // extra - added also the Post-Newton forces -// #define ADD_SPIN_BH // extra - added the SPIN for the BH's - DEFAULT !!! - -// #define BH_OUT // extra output for BH's (live) -// #define BH_OUT_NB // extra output for the BH's neighbours (live) - -// #define BBH_INF // BBH influence sphere... -// #define R_INF 10.0 // Factor for the influence sphere... if( R < R_INF * DR_BBH ) -// #define R_INF2 (R_INF*R_INF) - -// #define DT_MIN_WARNING // dt < dt_min warning !!! - -//#define BH_OUT_NB_EXT // extra output for the BH's neighbours (external) - -//#define SAPPORO // Gaburov. Do not tuch! Defined inside the Makefiles !!! -//#define YEBISU // Nitadori. Do not tuch! Defined inside the Makefiles !!! -//#define GUINNESS // Nakasato. Do not tuch! Defined inside the Makefiles !!! - -//#define STARDESTR // disruption of stars by BH tidal forces -//#define R_TIDAL 1.0E-03 // Tidal radius of the BH's -//#define RMAX_OUT // extra data for def. r_max... - -//#define STARDESTR_EXT // disruption of stars by external BH tidal forces -//#define R_0 0.22 // Outer cut of the disk -//#define R_ACCR 0.0050 // Tidal Accr. rad of the BH's in units of R_0 -//#define R_TIDAL (R_0*R_ACCR) // Tidal radius of the BH's in NB units - -//#define STARDISK // analytic gas disk around BH + drag -//#define HZ (0.001*R_0) // Disk thickness... in NB units -//#define R_CRIT 0.0257314 // Critical radius of the disk (vert SG = vert BH force) -//#define R_CRIT 0.0 // i.e. hz=HZ=const... - -//#define SPH_GAS // SPH gas disk around BH + drag; experimental stuff !!! - -//#define EXTPOT // external potential (BH? or galactic?) -//#define EXTPOT_BH // BH - usually NB units - -//#define EXTPOT_GAL // Galactic B+D+H PK - usually physical units - -//#define EXTPOT_GAL_DEH // Dehnen Galactic - usually physical units -//#define EXTPOT_GAL_LOG // Log Galactic - usually physical units - -//#define EXTPOT_SC // SC extra POT for Bek test runs... -//#define DATAFILE eff0.05.tsf10.00.tab -//#define M_SC_DIM 100001 - -//#define CMCORR // CM correction in the zero step and in every dt_contr - -//#define DEBUG // debug information to files & screen -// #define DEBUG_extra // extra debug information to files & screen -//#define LAGR_RAD // write out lagr-rad.dat - -//#define LIMITS // for "0" mass particles !!! -//#define R_LIMITS 1.0E+03 // for "0" mass particles !!! -//#define COORDS 1010.0 // for "0" mass particles !!! - -//#define LIMITS_NEW // for "0" mass particles !!! - -//#define LIMITS_ALL_BEG // for ALL particles at the beginning... -//#define LIMITS_ALL // for ALL particles -//#define R_LIMITS_ALL 1.0E+03 // for ALL particles - -#ifdef ETICS -#include "grapite.h" -// why do we need CEP as a compilaion flag... just have it always on when ETICS is on. IF there is no CEP, there should be a graceful skipping of those operations. -//#define ETICS_CEP -#ifndef ETICS_DTSCF -#error "ETICS_DTSCF must be defined" -#endif -#endif - -#define TIMING - -#define ETA_S_CORR 4.0 -#define ETA_BH_CORR 4.0 - -#define DTMAXPOWER -3.0 -#define DTMINPOWER -36.0 - -/* - -3.0 0.125 - -4.0 0.0625 - -5.0 0.03125 - -7.0 ~1e-2 --10.0 ~1e-3 -............. --20.0 ~1e-6 --23.0 ~1e-7 --26.0 ~1e-8 --30.0 ~1e-9 -*/ - -//#define AMD - -// #define ACT_DEF_LL - -#if defined(ACT_DEF_LL) && defined(ACT_DEF_GRAPITE) -#error "Contradicting preprocessor flags!" -#endif - -/****************************************************************************/ -#include -#include -#include -#include -#include -#include -#include - -/* -double aaa; -double aaapars[5]; - -extern void qwerty_(double *aaa, double *aaapars); -*/ - -#ifdef SAPPORO -#include -#include -#define GPU_PIPE 256 -#else -# ifdef YEBISU -# define G6_NPIPE 2048 -# else -# define G6_NPIPE 48 -# endif -#include "grape6.h" -#endif - -#ifdef GUINNESS -#define GPU_PIPE 128 -#endif - -#include - -/* Some "good" functions and constants... */ -#define SIG(x) ( ((x)<0) ? (-1):(1) ) -#define ABS(x) ( ((x)<0) ? (-x):(x) ) -#define MAX(a,b) ( ((a)>(b)) ? (a):(b) ) -#define MIN(a,b) ( ((a)<(b)) ? (a):(b) ) -#define SQR(x) ( (x)*(x) ) -#define POW3(x) ( (x)*SQR(x) ) - -#define Pi 3.14159265358979323846 -#define TWOPi 6.283185307179 -#define sqrt_TWOPi 2.506628274631 - -#ifdef NORM -//http://pdg.lbl.gov/2015/reviews/rpp2015-rev-astrophysical-constants.pdf - -#define G 6.67388E-11 // (m/s^2) * (m^2/kg) -#define Msol 1.988489E+30 // kg -#define Rsol 6.957E+08 // m -#define AU 149597870700.0 // m -#define pc 3.08567758149E+16 // m -#define Year 31556925.2 // s -#define c_feny 299792458.0 // m/s - -#define kpc (1.0E+03*pc) // m -#define km 1.0E+03 // km -> m -#define cm3 1.0E-06 // cm^3 -> m^3 -#define Myr (1.0E+06*Year) // s -#define Gyr (1.0E+09*Year) // s -#define R_gas 8.31447215 // J/(K*mol) -#define k_gas 1.380650424E-23 // J/K -#define N_A 6.022141510E+23 // 1/mol -#define mu 1.6605388628E-27 // kg -#define mp 1.67262163783E-27 // kg -#define me 9.1093821545E-31 // kg - -#define pc2 (pc*pc) -#define pc3 (pc*pc*pc) -#define kpc2 (kpc*kpc) -#define kpc3 (kpc*kpc*kpc) -#endif - -/* - 1KB = 1024 - 2KB = 2048 - 4KB = 4096 - 8KB = 8192 - 16KB = 16384 - 32KB = 32768 - 64KB = 65536 - 128KB = 131072 - 256KB = 262144 - 512KB = 524288 - 1024KB = 1048576 -> 1MB -*/ - -#define KB 1024 -#define MB (KB*KB) - -#define N_MAX (6*MB) -#define N_MAX_loc (2*MB) - -//#define N_MAX (1200000) -//#define N_MAX_loc (1200000) - -//#define P_MAX 32 - -//#ifdef DEBUG - -/* extra code & data for DEBUG... */ - -#include "debug.h" - -//#ifdef DEBUG_extra -int ind_sort[N_MAX]; -double var_sort[N_MAX]; -//#endif - -//#endif - -#ifdef LAGR_RAD -int lagr_rad_N = 22; -double mass_frac[] = { 0.0001, 0.0003, 0.0005, 0.001, 0.003, 0.005, 0.01, 0.03, 0.05, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 0.95, 0.99, 0.9999, 1.0 }; -double lagr_rad[22]; -double m_tot, m_cum, n_cum; -#endif - -int name_proc, n_proc=1, myRank=0, rootRank=0, cur_rank, - i, j, k, ni, nj, diskstep=0, power, jjj, iii, - skip_con=0, tmp_i; - -double dt_disk, dt_contr, t_disk=0.0, t_contr=0.0, - dt_bh, t_bh=0.0, dt_bh_tmp, - t_end, time_cur, dt_min, dt_max, min_t, min_t_loc, dt_new, min_dt, - eta_s, eta, eta_bh, - E_pot, E_pot_ext, E_kin, E_tot, E_tot_0, DE_tot, - E_tot_corr, E_tot_corr_0, DE_tot_corr, - E_tot_corr_sd, E_tot_corr_sd_0, DE_tot_corr_sd, - E_corr = 0.0, E_sd = 0.0, t_diss_on = 0.125, - e_kin_corr = 0.0, e_pot_corr = 0.0, e_pot_BH_corr = 0.0, - e_summ_corr = 0.0, - mcm, rcm_mod, vcm_mod, - rcm_sum=0.0, vcm_sum=0.0, - eps=0.0, eps2, - xcm[3], vcm[3], mom[3], - xdc[3], vdc[2], - over2=(1.0/2.0), over3=(1.0/3.0), over6=(1.0/6.0), - a2_mod, adot2_mod, - dt_tmp, dt2half, dt3over6, dt4over24, dt5over120, - dtinv, dt2inv, dt3inv, - a0mia1, ad04plad12, ad0plad1, - a2[3], a3[3], a2dot1[3], - a1abs, adot1abs, a2dot1abs, a3dot1abs, - Timesteps=0.0, n_act_sum=0.0, n_act_distr[N_MAX], g6_calls=0.0, g6_calls_sum=0.0, - tmp, tmp_r, tmp_v, tmp_rv, tmp_cpu, - tmp_pot, tmp_a, tmp_adot, - tmp_a_bh, tmp_adot_bh, - tmp_a_bh_pn0, tmp_a_bh_pn1, tmp_a_bh_pn2, tmp_a_bh_pn2_5, tmp_a_bh_pn3, tmp_a_bh_pn3_5, tmp_a_bh_spin, - tmp_adot_bh_pn0, tmp_adot_bh_pn1, tmp_adot_bh_pn2, tmp_adot_bh_pn2_5, tmp_adot_bh_pn3, tmp_adot_bh_pn3_5, tmp_adot_bh_spin; - -double R[3], V[3], L[3], mju, dr2, dr, dv2, dv, dl2, dl, pot_eff; - -char processor_name[MPI_MAX_PROCESSOR_NAME], - inp_fname[30], inp_fname_gmc[30], - out_fname[30], dbg_fname[30]; - -/* global variables */ - -int N, N_star, N_gmc, N_bh, - ind[N_MAX], name[N_MAX]; -double m[N_MAX], x[N_MAX][3], v[N_MAX][3], - pot[N_MAX], a[N_MAX][3], adot[N_MAX][3], - t[N_MAX], dt[N_MAX]; - -/* local variables */ - -int n_loc, ind_loc[N_MAX_loc]; -double m_loc[N_MAX_loc], x_loc[N_MAX_loc][3], v_loc[N_MAX_loc][3], - pot_loc[N_MAX_loc], a_loc[N_MAX_loc][3], adot_loc[N_MAX_loc][3], - t_loc[N_MAX_loc], dt_loc[N_MAX_loc]; - -/* data for active particles */ - -int n_act, ind_act[N_MAX]; -double m_act[N_MAX], - x_act[N_MAX][3], v_act[N_MAX][3], - pot_act[N_MAX], a_act[N_MAX][3], adot_act[N_MAX][3], - t_act[N_MAX], dt_act[N_MAX], - x_act_new[N_MAX][3], v_act_new[N_MAX][3], - pot_act_new[N_MAX], a_act_new[N_MAX][3], adot_act_new[N_MAX][3], - pot_act_tmp[N_MAX], a_act_tmp[N_MAX][3], adot_act_tmp[N_MAX][3], - pot_act_tmp_loc[N_MAX], a_act_tmp_loc[N_MAX][3], adot_act_tmp_loc[N_MAX][3]; - -FILE *inp, *out, *tmp_file, *dbg; - -double CPU_time_real0, CPU_time_user0, CPU_time_syst0; -double CPU_time_real, CPU_time_user, CPU_time_syst; - - -#ifdef TIMING - -double CPU_tmp_real0, CPU_tmp_user0, CPU_tmp_syst0; -double CPU_tmp_real, CPU_tmp_user, CPU_tmp_syst; - -double DT_TOT, - DT_ACT_DEF1, DT_ACT_DEF2, DT_ACT_DEF3, DT_ACT_PRED, - DT_ACT_GRAV, DT_EXT_GRAV, - 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 - -/* some local settings for G6a board's */ - -int clusterid, ii, nn, numGPU; - -//#ifdef SAPPORO -#if defined(SAPPORO) || defined(GUINNESS) - -int npipe=GPU_PIPE, index_i[GPU_PIPE]; -double h2_i[GPU_PIPE], x_i[GPU_PIPE][3], v_i[GPU_PIPE][3], - p_i[GPU_PIPE], a_i[GPU_PIPE][3], jerk_i[GPU_PIPE][3]; -double new_tunit=51.0, new_xunit=51.0; - -#elif defined YEBISU - -int npipe=G6_NPIPE, index_i[G6_NPIPE]; -double h2_i[G6_NPIPE], x_i[G6_NPIPE][3], v_i[G6_NPIPE][3], - p_i[G6_NPIPE], a_i[G6_NPIPE][3], jerk_i[G6_NPIPE][3]; -int new_tunit=51, new_xunit=51; -#else - -int npipe=48, index_i[48]; -double h2_i[48], x_i[48][3], v_i[48][3], - p_i[48], a_i[48][3], jerk_i[48][3]; -int new_tunit=51, new_xunit=51; - -#endif - -int aflag=1, jflag=1, pflag=1; - -double ti=0.0, a2by18[3], a1by6[3], aby2[3]; - -/* normalization... */ - -#ifdef NORM -double m_norm, r_norm, v_norm, t_norm; -#endif - -double eps_BH=0.0; - -/* external potential... */ - -#ifdef EXTPOT - -#ifdef EXTPOT_GAL -double m_bulge, a_bulge, b_bulge, - m_disk, a_disk, b_disk, - m_halo, a_halo, b_halo, -// x_ext, y_ext, z_ext, -// vx_ext, vy_ext, vz_ext, -// x_ij, y_ij, z_ij, -// vx_ij, vy_ij, vz_ij, rv_ij, - x2_ij, y2_ij, z2_ij, - r_tmp, r2_tmp, z_tmp, z2_tmp; -#endif - -#ifdef EXTPOT_GAL_DEH -double m_ext, r_ext, g_ext, - tmp_r2, tmp_r3, dum, dum2, dum3, dum_g, tmp_g; -#endif - -#ifdef EXTPOT_GAL_LOG -double v_halo, r_halo, - v2_halo, r2_halo, r2_r2_halo, - x2_ij, y2_ij, z2_ij; -#endif - -#ifdef EXTPOT_BH -double r2, rv_ij, - m_bh, b_bh, eps_bh; -#endif - -#ifdef EXTPOT_SC -int M_SC=M_SC_DIM; -double r_sc[M_SC_DIM], m_sc[M_SC_DIM], p_sc[M_SC_DIM]; -double M_R, pot_out_R; -#endif - - -double pot_ext[N_MAX], pot_act_ext[N_MAX]; // for all EXTPOT - -#endif - - -int i_bh, i_bh1, i_bh2, - num_bh = 0, num_bh1 = 0, num_bh2 = 0; - -double m_bh, m_bh1, m_bh2, b_bh, - r, r2, - x_ij, y_ij, z_ij, - vx_ij, vy_ij, vz_ij, rv_ij; - -#ifdef STEVOL -int num_dead, event[N_MAX]; -double dt_stevol, t_stevol; -double m0[N_MAX], ZZZ[N_MAX], t0[N_MAX]; -#endif - - -#ifdef STEVOL_SSE - -int num_dead, event[N_MAX], event_old[N_MAX]; -double dt_stevol, t_stevol; -double m0[N_MAX], ZZZ[N_MAX], t0[N_MAX]; -double SSEMass[N_MAX], SSESpin[N_MAX], SSERad[N_MAX], - SSELum[N_MAX], SSETemp[N_MAX]; -double SSEMV[N_MAX], SSEBV[N_MAX]; - -double Rgal = 10000.0; //Distance of star from sun for artificial CMD with observational errors [pc] - -int van_kick=0; - -extern void zcnsts_(double *z, double *zpars); -extern void evolv1_(int *kw, double *mass, double *mt, double *r, double *lum, double *mc, double *rc, double *menv, double *renv, double *ospin, double *epoch, double *tms, double *tphys, double *tphysf, double *dtp, double *z, double *zpars, double *vkick, double *vs); -extern int cmd(int kstar, double rstar, double lstar, double Rgal, double *abvmag, double *vmag, double *BV, double *Teff, double *dvmag, double *dBV); - -struct{ - double neta; - double bwind; - double hewind; - double mxns; -} value1_; - -struct{ - double pts1; - double pts2; - double pts3; -} points_; - -struct{ - double sigma; - int bhflag; -} value4_; - -struct{ - int idum; -} value3_; - -struct{ - int ceflag; - int tflag; - int ifflag; - int nsflag; - int wdflag; -} flags_; - -struct{ - double beta; - double xi; - double acc2; - double epsnov; - double eddfac; - double gamma; -} value5_; - -struct{ - double alpha1; - double lambda; -} value2_; - -#include "cmd.c" - -#endif - - - -#ifdef BBH_INF -int inf_event[N_MAX]; -double x_bbhc[3], v_bbhc[3], DR2, tmp_r2; -double DV2, EB, SEMI_a, SEMI_a2; -#endif - - - -/* STARDISK Drag force... */ - -#ifdef STARDISK - -double a_drag[N_MAX][3], adot_drag[N_MAX][3]; -//double a_drag[N_MAX][3], adot_drag[N_MAX][3]; - -double z_new_drag, r_new_drag2, hz; - -#ifdef SPH_GAS - -#define N_GAS_MAX (128*KB) -#define NB 50 - -int N_GAS, ind_gas[N_GAS_MAX], sosed_gas[N_GAS_MAX][NB]; -double m_gas[N_GAS_MAX], x_gas[N_GAS_MAX][3], v_gas[N_GAS_MAX][3], h_gas[N_GAS_MAX], DEN_gas[N_GAS_MAX]; - -//int sosed[NB]; -double d[N_MAX]; // podrazumevajem chto: N_MAX > N_GAS_MAX vsegda ! -double x_star, y_star, z_star, DEN_star; -double h_min = 1.0E-04, h_max = 1.0; - -#include "def_H.c" -#include "def_DEN.c" -#include "def_DEN_STAR.c" - -#endif // SPH_GAS - -#include "drag_force.c" - -// calculate the SG for the set of active particles which is deepley INSIDE the EXT BH infl. rad. -// EXPERIMENTAL feature !!! - -//int SG_CALC = 0; -//double summ_tmp_r = 0.0, aver_tmp_r = 0.0, R_INT_CUT = 1.0E-03; - -#endif // STARDISK - - - -/* GMC data... */ - -#ifdef GMC - -double dt_gmc, E_pot_gmc, E_pot_gmc_gmc, E_pot_ext_gmc, E_kin_gmc; - -#define N_gmc_MAX (500) - -int N_gmc, ind_gmc[N_gmc_MAX], name_gmc[N_gmc_MAX]; - -double m_gmc[N_gmc_MAX], pot_gmc_gmc[N_gmc_MAX], pot_ext_gmc[N_gmc_MAX], - x_gmc[N_gmc_MAX][3], v_gmc[N_gmc_MAX][3], a_gmc[N_gmc_MAX][3], - eps_gmc[N_gmc_MAX]; - -double pot_gmc[N_MAX]; - -#endif // GMC - - -/****************************************************************************/ - -/****************************************************************************/ -#ifdef ADD_N_BH - -double x_bh1[3], x_bh2[3], v_bh1[3], v_bh2[3]; - -double pot_bh1, a_bh1[3], adot_bh1[3], - pot_bh2, a_bh2[3], adot_bh2[3]; - -//double eps_BH = 0.0; - -#include "n_bh.c" - -/* -int calc_force_n_BH(double m1, double xx1[], double vv1[], - double m2, double xx2[], double vv2[], - double eps_BH, - double pot_n1, double a_n1[], double adot_n1[], - double pot_n2, double a_n2[], double adot_n2[]) -*/ - -/* - INPUT - -m1 - mass of the 1 BH -xx1[0,1,2] - coordinate of the 1 BH -vv1[0,1,2] - velocity of the 1 BH - -m2 - mass of the 2 BH -xx2[0,1,2] - coordinate of the 2 BH -vv2[0,1,2] - velocity of the 2 BH - -eps_BH - force softening, can be even exactly 0.0 ! - - OUTPUT - -pot_n1 for the 1 BH -a_n1 [0,1,2] for the 1 BH -adot_n1 [0,1,2] for the 1 BH - -pot_n2 for the 2 BH -a_n2 [0,1,2] for the 2 BH -adot_n2 [0,1,2] for the 2 BH - -return - 0 if everything OK -*/ - -#endif -/****************************************************************************/ - -/****************************************************************************/ -#ifdef ADD_PN_BH - -double C_NB = 477.12; - -int usedOrNot[7] = {1, 1, 1, 1, 0, 0, 0}; - -double a_pn1[7][3], adot_pn1[7][3], - a_pn2[7][3], adot_pn2[7][3]; - -double s_bh1[3] = {0.0, 0.0, 1.0}; -double s_bh2[3] = {0.0, 0.0, 1.0}; - -#ifdef ADD_SPIN_BH // eto rabotajet vsegda !!! -#include "pn_bh_spin.c" -#else -#include "pn_bh.c" // eto staraja versija, bolshe ne rabotajet !!! -#endif - -/* -int calc_force_pn_BH(double m1, double xx1[], double vv1[], double ss1[], - double m2, double xx2[], double vv2[], double ss2[], - double CCC_NB, double dt_bh, - int usedOrNot[], - double a_pn1[][3], double adot_pn1[][3], - double a_pn2[][3], double adot_pn2[][3]) -*/ - -/* - INPUT - -m1 - mass of the 1 BH -xx1[0,1,2] - coordinate of the 1 BH -vv1[0,1,2] - velocity of the 1 BH -spin1[0,1,2] - normalized spin of the 1 BH - -m2 - mass of the 2 BH -xx2[0,1,2] - coordinate of the 2 BH -vv2[0,1,2] - velocity of the 2 BH -spin2[0,1,2] - normalized spin of the 2 BH - -CCC_NB - Speed of light "c" in internal units -dt_BH - timestep of the BH's, needed for the SPIN integration - -usedOrNot[PN0, PN1, PN2, PN2.5, PN3, PN3.5, SPIN] - different PN term usage: PN1, PN2, PN2.5, PN3, PN3.5, SPIN - 0 1 2 3 4 5 6 - - OUTPUT - -a_pn1 [0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 1 BH -adot_pn1[0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 1 BH - -a_pn2 [0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 2 BH -adot_pn2[0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 2 BH - -return - 0 if everything OK - - 505 if BH's separation < 4 x (RSwarch1 + RSwarch2) -*/ - -#endif - -/****************************************************************************/ - -/****************************************************************************/ -/* RAND_MAX = 2147483647 */ -/* my_rand : 0.0 - 1.0 */ -/* my_rand2 : -1.0 - 1.0 */ - -double my_rand(void) -{ -return( (double)(rand()/(double)RAND_MAX) ); -} - -double my_rand2(void) -{ -return (double)(2.0)*((rand() - RAND_MAX/2)/(double)RAND_MAX); -} -/****************************************************************************/ - -#ifdef STARDESTR -#include "star_destr.c" -#endif - -#ifdef STARDESTR_EXT -#include "star_destr_ext.c" -#endif - -#ifdef ACT_DEF_LL -#include "act_def_linklist.c" -#endif - -#ifdef ETICS -double t_exp, dt_exp=ETICS_DTSCF; // t_exp is just the initial value -#ifdef ETICS_CEP -int grapite_cep_index; -#endif -#endif - -/****************************************************************************/ -void get_CPU_time(double *time_real, double *time_user, double *time_syst) - { - struct rusage xxx; - double sec_u, microsec_u, sec_s, microsec_s; - struct timeval tv; - - - getrusage(RUSAGE_SELF,&xxx); - - sec_u = xxx.ru_utime.tv_sec; - sec_s = xxx.ru_stime.tv_sec; - - microsec_u = xxx.ru_utime.tv_usec; - microsec_s = xxx.ru_stime.tv_usec; - - *time_user = sec_u + microsec_u * 1.0E-06; - *time_syst = sec_s + microsec_s * 1.0E-06; - -// *time_real = time(NULL); - - gettimeofday(&tv, NULL); - *time_real = tv.tv_sec + 1.0E-06 * tv.tv_usec; - - *time_user = *time_real; - - } -/****************************************************************************/ - -#ifdef STEVOL -/****************************************************************************/ -double t_dead(double m, double Z) -/* -m - mass of the star (in Msol) -Z - metallicity (absolut values - i.e. Zsol = 0.0122) -t - return value of star lifetime (in Year) - -Raiteri, Villata & Navarro, 1996, A&A, 315, 105 -*/ -{ - double a0, a1, a2, lZ, lm, tmp=0.0; - - m *= (m_norm/Msol); - - lZ = log10(Z); - lm = log10(m); - - a0 = 10.130 + 0.07547*lZ - 0.008084*lZ*lZ; - a1 = -4.424 - 0.79390*lZ - 0.118700*lZ*lZ; - a2 = 1.262 + 0.33850*lZ + 0.054170*lZ*lZ; - - tmp = a0 + a1*lm + a2*lm*lm; - - tmp = pow(10.0,tmp); - - tmp *= (Year/t_norm); - - return(tmp); -} -/****************************************************************************/ - -/****************************************************************************/ -double m_loss_old(double m, double Z) -/* -m - initial mass of the star (in Msol) -Z - metallicity (e.g. Zsol = 0.02) -m_ret - returned maass to ISM from the star (in Msol) - -approx. from data of van den Hoek & Groenewegen, 1997, A&AS, 123, 305 -*/ -{ - double tmp=0.0; - - m *= (m_norm/Msol); - -// tmp = (-0.46168 + 0.912274 * m); // first approx. - - tmp = -0.420542*pow(Z, -0.0176601) + (0.901495 + 0.629441*Z) * m; - - tmp *= (Msol/m_norm); - - return(tmp); -} -/****************************************************************************/ - -/****************************************************************************/ -double m_curr_old(double m0, double Z, double t0, double t) -{ - double td, ml, tmp=0.0; - - td = t_dead(m0, Z); - ml = m_loss_old(m0, Z); - - if( (t-t0) < td ) - { - tmp = m0; // instant mass loss -// tmp = m0 - (t-t0)/(td-t0) * ml; // linear mass loss - } - else - { - tmp = m0 - ml; - - if(event[i] == 0) - { - num_dead++; - event[i] = 1; - } - - } /* if( (t-t0) < td ) */ - - return(tmp); -} -/****************************************************************************/ - -/****************************************************************************/ -double m_loss(double m, double Z) -/* -m - initial mass of the star (in norm. units) -Z - metallicity (absolut value - i.e. Zsol = 0.0122) -m_loss - returned maass to ISM from the star (in norm. units) -*/ -{ - double tmp=0.0; - - m *= (m_norm/Msol); - - if( m < 8.0) - { -// approx. from data of van den Hoek & Groenewegen, 1997, A&AS, 123, 305 - -// tmp = (-0.46168 + 0.912274 * m); // first approx. - tmp = -0.420542*pow(Z, -0.0176601) + (0.901495 + 0.629441*Z) * m; // second approx. - } - else - { -// approx. from data of Woosley & Weaver, 1995, ApJS, 110, 181 - -// tmp = 0.813956*pow(m, 1.04214); - tmp = 0.813956*pow(m, 1.04); - } - - tmp *= (Msol/m_norm); - - return(tmp); -} -/****************************************************************************/ - -/****************************************************************************/ -double m_curr(double m0, double Z, double t0, double t) -{ - double td, ml, tmp=0.0; - - tmp = m0; - - if( event[i] == 0 ) - { - - td = t_dead(m0, Z); - - if( (t-t0) > td ) - { - - ml = m_loss(m0, Z); - - tmp = m0 - ml; - - num_dead++; - -// wd http://en.wikipedia.org/wiki/Chandrasekhar_limit 1.38 - - if( tmp * (m_norm/Msol) < 1.38 ) - { - event[i] = 1; - } - else - { - -// ns http://en.wikipedia.org/wiki/Neutron_stars 1.38 - ~2.0 ??? - - if( tmp * (m_norm/Msol) > 1.38 ) event[i] = 2; - -// bh http://en.wikipedia.org/wiki/Tolman-Oppenheimer-Volkoff_limit ~1.5 - ~3.0 ??? - - if( tmp * (m_norm/Msol) > 2.00 ) event[i] = 3; - - } - - } /* if( (t-t0) > td ) */ - - } /* if( event[i] == 0 ) */ - - return(tmp); -} -/****************************************************************************/ -#endif - - -#ifdef STEVOL_SSE -/****************************************************************************/ -double m_curr(int ipart, double m0, double Z, double t0, double t) -{ - //set up parameters and variables for SSE (Hurley, Pols & Tout 2002) - int kw=0; //stellar type - double mass; //initial mass - double mt=0.0; //actual mass - double r=0.0; //radius - double lum=0.0; //luminosity - double mc=0.0; //core mass - double rc=0.0; //core radius - double menv=0.0; //envelope mass - double renv=0.0; //envelope radius - double ospin=0.0; //spin - double epoch=0.0; //time spent in current evolutionary state - double tms=0.0; //main-sequence lifetime - double tphys; //initial age - double tphysf; //final age - double dtp=0.0; //data store value, if dtp>tphys no data will be stored - double z; //metallicity - double zpars[20]; //metallicity parameters - double vkick=0.0; //kick velocity for compact remnants - double vs[3]; //kick velocity componets - - // M_V_[mag] V_[mag] B-V_[mag] T_eff_[K] dV_[mag] d(B-V) - double abvmag, vmag, BV, Teff, dvmag, dBV; - - mass = m0*(m_norm/Msol); // m0[i] initial mass of the stars Msol - mt = mass; // current mass for output in Msol - tphys = t0*(t_norm/Myr); // t0[i] time of the star formation Myr - tphysf = t*(t_norm/Myr); // t[i] current time for the star Myr - dtp = 0.0; // output parameter, just set to 0.0 !!! - z = Z; // ZZZ[i] of the star - -/* - if(ipart > 9995) - { - printf("Initial parameters: \n"); - printf("M = %g [Mo] \n", mass); - printf("Z = %g \n", z); - printf("kw = %d \n", kw); - printf("spin = %g \n", ospin); - printf("epoch = %g [Myr] \n", epoch); - printf("t_beg = %g [Myr] \n", tphys); - printf("t_end = %g [Myr] \n", tphysf); - printf("R = %g [R_o] \n", r); - printf("L = %g [L_o] \n", lum); - printf("V_kick = %g [km/s] \n", vkick); - } -*/ - - for (k=0; k<20; k++) zpars[k] = 0; - zcnsts_(&z,zpars); //get metallicity parameters - - evolv1_(&kw, &mass, &mt, &r, &lum, &mc, &rc, &menv, &renv, &ospin, &epoch, &tms, &tphys, &tphysf, &dtp, &z, zpars, &vkick, vs); - cmd(kw, r, lum, Rgal, &abvmag, &vmag, &BV, &Teff, &dvmag, &dBV); - -/* - if(ipart > 9995) - { - printf("Final parameters: \n"); - printf("M = %g [Mo] \n", mt); - printf("Z = %g \n", z); - printf("kw = %d \n", kw); - printf("spin = %g \n", ospin); - printf("epoch = %g [Myr] \n", epoch); - printf("t_beg = %g [Myr] \n", tphys); - printf("t_end = %g [Myr] \n", tphysf); - printf("R = %g [R_o] \n", r); - printf("L = %g [L_o] \n", lum); - printf("V_kick = %g [km/s] \n", vkick); - printf("M_V_[mag]\tV_[mag]\t\tB-V_[mag]\tT_eff_[K]\tdV_[mag]\td(B-V)\n"); - printf("%.3E\t%.3E\t%.3E\t%.3E\t%.3E\t%.3E\n", abvmag, vmag, BV, Teff, dvmag, dBV); -// printf("%g\t%g\t%g\t%g\t%g\t%g\n", abvmag, vmag, BV, Teff, dvmag, dBV); - } -*/ - - event[ipart] = kw; // Evolution type (0 - 15). - SSEMass[ipart] = mt; // Mass in Msol - SSESpin[ipart] = ospin; // Spin in SI ??? [kg*m*m/s] - SSERad[ipart] = r; // Radius in Rsol - SSELum[ipart] = lum; // Luminosity in Lsol - SSETemp[ipart] = Teff; // Temperature - - SSEMV[ipart] = abvmag; // M_V absolute V magnitude - SSEBV[ipart] = BV; // B-V color index - -/* -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 -*/ - - if( van_kick == 1 ) // we have a kick ??? - { - - if( (event_old[ipart] < 10) && ( (event[ipart] == 13) || (event[ipart] == 14) ) ) // NS or BH - { - - if(myRank == rootRank) - { -// printf("KICK: %06d %.6E [Myr] %02d (%02d) %.6E [Mo] %.6E [km/s] [% .3E, % .3E, % .3E] OLD: [% .3E, % .3E, % .3E] %.6E [Mo] \n", ipart, tphysf, kw, event_old[ipart], mt, vkick, vs[0], vs[1], vs[2], v[ipart][0]*(v_norm/km), v[ipart][1]*(v_norm/km), v[ipart][2]*(v_norm/km), mass); - printf("KICK: %06d %.6E %02d %02d %.6E %.6E % .3E % .3E % .3E % .3E % .3E % .3E %.6E \n", ipart, tphysf, kw, event_old[ipart], mt, vkick, vs[0], vs[1], vs[2], v[ipart][0]*(v_norm/km), v[ipart][1]*(v_norm/km), v[ipart][2]*(v_norm/km), mass); - fflush(stdout); - } /* if(myRank == rootRank) */ - - v[ipart][0] += vs[0]*(km/v_norm); - v[ipart][1] += vs[1]*(km/v_norm); - v[ipart][2] += vs[2]*(km/v_norm); - } - - } // we have a kick ??? - - - event_old[ipart] = event[ipart]; - - - tmp = mt*(Msol/m_norm); // return the current mass(t-t0) of the star in NB units - - return(tmp); -} -/****************************************************************************/ -#endif - - -/****************************************************************************/ -void read_data() -{ - inp = fopen(inp_fname,"r"); - fscanf(inp,"%d \n", &diskstep); - -//#ifdef STEVOL -// fscanf(inp,"%d \n", &N); -//#endif -// fscanf(inp,"%d %d %d %d \n", &N, &N_bh, &N_gmc, &N_star); - - fscanf(inp,"%d \n", &N); - - fscanf(inp,"%lE \n", &time_cur); - - for(i=0; i= (mass_frac[k]*m_tot) ) - { - lagr_rad[k] = var_sort[j]; - k++; - } -#endif - } - - fclose(out); - -// write out lagr-rad.dat - -#ifdef LAGR_RAD - out = fopen("lagr-rad.dat","a"); - fprintf(out,"%.6E ", time_cur); - for(k=0; k 100.0) jerk_i[ii][0] = 100.0; - if(ABS(jerk_i[ii][1]) > 100.0) jerk_i[ii][1] = 100.0; - if(ABS(jerk_i[ii][2]) > 100.0) jerk_i[ii][2] = 100.0; - } - -#ifdef SAPPORO - g6calc_firsthalf_(&clusterid, &n_loc, &nn, index_i, x_i, v_i , a_i, jerk_i, p_i, &eps2, h2_i); - g6calc_lasthalf_(&clusterid, &n_loc, &nn, index_i, x_i, v_i, &eps2, h2_i, a_i, jerk_i, p_i); -#else - g6calc_firsthalf(clusterid, n_loc, nn, index_i, x_i, v_i , a_i, jerk_i, p_i, eps2, h2_i); - g6calc_lasthalf(clusterid, n_loc, nn, index_i, x_i, v_i, eps2, h2_i, a_i, jerk_i, p_i); -#endif - - for(ii=0; ii r) ) - { - r1 = r_sc[ii]; r2 = r_sc[ii+1]; - m1 = m_sc[ii]; m2 = m_sc[ii+1]; - p1 = p_sc[ii]; p2 = m_sc[ii+1]; - break; - } - } - - m_tmp = m1 + (r-r1)*(m2-m1)/(r2-r1); - p_tmp = p1 + (r-r1)*(p2-p1)/(r2-r1); - -// if(myRank == rootRank) -// { -// printf("\t \t \t %.6E %.6E \n", r1, r2); -// printf("\t \t \t %.6E %.6E \n", m1, m2); -// printf("\t \t \t %.6E %.6E \n", p1, p2); -// printf("\t \t \t %06d %.6E %.6E %.6E \n", ii, r, m_tmp, p_tmp); -// fflush(stdout); -// } /* if(myRank == rootRank) */ - - *M_R = m_tmp; - *pot_out_R = p_tmp; - -//exit(-1); - - } -#endif -/****************************************************************************/ - -/****************************************************************************/ -void calc_ext_grav_zero() -{ - -#ifdef EXTPOT - - /* Define the external potential for all particles on all nodes */ - - ni = n_act; - - for(i=0; i 100.0) jerk_i[ii][0] = 100.0; - if(ABS(jerk_i[ii][1]) > 100.0) jerk_i[ii][1] = 100.0; - if(ABS(jerk_i[ii][2]) > 100.0) jerk_i[ii][2] = 100.0; - } - - g6calc_firsthalf(clusterid, n_loc, nn, index_i, x_i, v_i , a_i, jerk_i, p_i, eps2, h2_i); - g6calc_lasthalf(clusterid, n_loc, nn, index_i, x_i, v_i, eps2, h2_i, a_i, jerk_i, p_i); - - g6_calls++; -*/ - - for(ii=0; ii R_LIMITS_ALL) && (m[i] != 0.0) ) - if( (tmp_r > R_LIMITS_ALL) && (tmp_rv > 0.0) ) - { - - for(k=0;k<3;k++) - { -// x[i][k] = R_LIMITS_ALL + 1.0*my_rand2(); - v[i][k] *= 1.0E-01; - } /* k */ - - } /* if */ - - } /* i */ - -#endif - - -#ifdef CMCORR - - /* possible CM correction of the initial datafile... */ - - if( (diskstep == 0) && (time_cur == 0.0) ) cm_corr(); -// if( (time_cur = 0.0) ) cm_corr(); - -#endif - - - printf("\n"); - printf("Begin the calculation of phi-GRAPE program on %03d processors\n", n_proc); - printf("\n"); -#ifdef GMC - printf("N = %06d \t N_GMC = %06d \t eps = %.6E \n", N, N_gmc, eps); -#else - printf("N = %07d \t eps = %.6E \n", N, eps); -#endif - printf("t_beg = %.6E \t t_end = %.6E \n", time_cur, t_end); - printf("dt_disk = %.6E \t dt_contr = %.6E \n", dt_disk, dt_contr); - printf("dt_bh = %.6E \n", dt_bh); - printf("eta = %.6E \n", eta); - printf("\n"); - -#ifdef NORM - printf("Normalization: \n"); - printf("\n"); - printf("m_norm = %.4E [Msol] r_norm = %.4E [pc] \n", m_norm/Msol, r_norm/pc); - printf("v_morm = %.4E [km/s] t_morm = %.4E [Myr] \n", v_norm/km, t_norm/Myr); - printf("\n"); -#endif - -#ifdef EXTPOT - printf("External Potential: \n"); - printf("\n"); - -#ifdef EXTPOT_GAL - printf("m_bulge = %.4E [Msol] a_bulge = %.4E b_bulge = %.4E [kpc] \n", m_bulge*m_norm/Msol, a_bulge*r_norm/kpc, b_bulge*r_norm/kpc); - printf("m_disk = %.4E [Msol] a_disk = %.4E b_disk = %.4E [kpc] \n", m_disk*m_norm/Msol, a_disk*r_norm/kpc, b_disk*r_norm/kpc); - printf("m_halo = %.4E [Msol] a_halo = %.4E b_halo = %.4E [kpc] \n", m_halo*m_norm/Msol, a_halo*r_norm/kpc, b_halo*r_norm/kpc); -#endif - -#ifdef EXTPOT_BH - printf("m_bh = %.4E b_bh = %.4E \n", m_bh, b_bh); -// printf("m_bh = %.4E [Msol] b_bh = %.4E [kpc] \n", m_bh*m_norm/Msol, b_bh*r_norm/kpc); -#endif - -#ifdef EXTPOT_GAL_DEH - printf("m_ext = %.6E r_ext = %.6E \t g_ext = %.3E \n", m_ext, r_ext, g_ext); -#endif - -#ifdef EXTPOT_GAL_LOG - printf("v_halo = %.6E r_halo = %.6E \n", v_halo, r_halo); -#endif - -#ifdef EXTPOT_SC - read_SC_mass(); - - printf("EXTPOT_SC: # of points %06d \t M_SC_TOT = %.6E \n", M_SC_DIM-1, m_sc[M_SC_DIM-1]); -// printf("EXTPOT_SC: %.6E \t %.6E \n", m_sc[0], m_sc[M_SC_DIM-1]); -// printf("EXTPOT_SC: %.6E \t %.6E \n", p_sc[0], p_sc[M_SC_DIM-1]); -#endif - - printf("\n"); -#endif - - - - fflush(stdout); - - - if( (diskstep == 0) && (time_cur == 0.0) ) -// if( (time_cur = 0.0) ) - { - -#ifdef SPH_GAS - write_data_SPH(); -#endif - -#ifdef GMC - write_snap_GMC(); - write_cont_GMC(); -#endif - -// write_snap_data(); -// write_cont_data(); - - out = fopen("contr.dat","w"); - fclose(out); - -#ifdef TIMING - out = fopen("timing.dat","w"); - fclose(out); -#endif - -#ifdef ADD_BH2 - -#ifdef BH_OUT - out = fopen("bh.dat","w"); - fclose(out); -#endif - -#ifdef BH_OUT_NB - out = fopen("bh_nb.dat","w"); - fclose(out); -#endif - -#else - -#ifdef ADD_BH1 - -#ifdef BH_OUT - out = fopen("bh.dat","w"); - fclose(out); -#endif - -#ifdef BH_OUT_NB - out = fopen("bh_nb.dat","w"); - fclose(out); -#endif - -#endif // ADD_BH1 - -#endif // ADD_BH2 - - -#ifdef STARDESTR - -#ifdef ADD_BH2 - - out = fopen("mass-bh.dat","w"); - m_bh1 = m[0]; - m_bh2 = m[1]; - num_bh1 = 0; - num_bh2 = 0; - fprintf(out,"%.8E \t %.8E %06d \t %.8E %06d \n", - time_cur, m_bh1, num_bh1, m_bh2, num_bh2); - fclose(out); - - out = fopen("mass-bh.con","w"); - m_bh1 = m[0]; - m_bh2 = m[1]; - num_bh1 = 0; - num_bh2 = 0; - fprintf(out,"%.8E \t %.8E %06d \t %.8E %06d \n", - time_cur, m_bh1, num_bh1, m_bh2, num_bh2); - fclose(out); - -#else - -#ifdef ADD_BH1 - - out = fopen("mass-bh.dat","w"); - m_bh1 = m[0]; - num_bh1 = 0; - fprintf(out,"%.8E \t %.8E %06d \n", - time_cur, m_bh1, num_bh1); - fclose(out); - - out = fopen("mass-bh.con","w"); - m_bh1 = m[0]; - num_bh1 = 0; - fprintf(out,"%.8E \t %.8E %06d \n", - time_cur, m_bh1, num_bh1); - fclose(out); - -#endif // ADD_BH1 - -#endif // ADD_BH2 - -#endif // STARDESTR - - -#ifdef STARDESTR_EXT - - num_bh = 0; - out = fopen("mass-bh.dat","w"); - fprintf(out,"%.8E \t %.8E \t %06d \n", time_cur, m_bh, num_bh); - fclose(out); - - num_bh = 0; - out = fopen("mass-bh.con","w"); - fprintf(out,"%.8E \t %.8E \t %06d \n", time_cur, m_bh, num_bh); - fclose(out); - -#ifdef BH_OUT_NB_EXT - out = fopen("bh_nb.dat","w"); - fclose(out); -#endif - -#endif // STARDESTR_EXT - - -#ifdef DEBUG_extra -#ifdef LAGR_RAD - out = fopen("lagr-rad.dat","w"); - fclose(out); -#endif -#endif - - -#ifdef BBH_INF - out = fopen("bbh.inf","w"); - fclose(out); -#endif - - - } - else // if(diskstep == 0) - { - -//#ifdef LAGR_RAD -// out = fopen("lagr-rad.dat","a"); -// fclose(out); -//#endif - -/* -#ifdef SPH_GAS - write_data_SPH(); -#endif - -#ifdef GMC - write_snap_GMC(); - write_cont_GMC(); -#endif - - write_snap_data(); - write_cont_data(); -*/ - -#ifdef STARDESTR - -#ifdef ADD_BH2 - -/* - inp = fopen("mass-bh.dat","r"); - while(feof(inp) == NULL) - { - fscanf(inp,"%lE %lE %d %lE %d", &tmp, &m_bh1, &num_bh1, &m_bh2, &num_bh2); - } - fclose(inp); - printf("%.8E \t %.8E %06d \t %.8E %06d \n", tmp, m_bh1, num_bh1, m_bh2, num_bh2); - fflush(stdout); -*/ - - inp = fopen("mass-bh.con","r"); - fscanf(inp,"%lE %lE %d %lE %d", &tmp, &m_bh1, &num_bh1, &m_bh2, &num_bh2); - fclose(inp); - printf("%.8E \t %.8E %06d \t %.8E %06d \n", tmp, m_bh1, num_bh1, m_bh2, num_bh2); - fflush(stdout); - -#else - -#ifdef ADD_BH1 - -/* - inp = fopen("mass-bh.dat","r"); - while(feof(inp) == NULL) - { - fscanf(inp,"%lE %lE %d", &tmp, &m_bh1, &num_bh1); - } - fclose(inp); - printf("%.8E \t %.8E \t %06d \n", tmp, m_bh1, num_bh1); - fflush(stdout); -*/ - - inp = fopen("mass-bh.con","r"); - fscanf(inp,"%lE %lE %d", &tmp, &m_bh1, &num_bh1); - fclose(inp); - printf("%.8E \t %.8E \t %06d \n", tmp, m_bh1, num_bh1); - fflush(stdout); - -#endif // ADD_BH1 - -#endif // ADD_BH2 - -#endif // STARDESTR - - -#ifdef STARDESTR_EXT - -/* - inp = fopen("mass-bh.dat","r"); - while(feof(inp) == NULL) - { - fscanf(inp,"%lE %lE %d", &tmp, &m_bh, &num_bh); - } - fclose(inp); - printf("%.8E \t %.8E \t %06d \n", tmp, m_bh, num_bh); - fflush(stdout); -*/ - - inp = fopen("mass-bh.con","r"); - fscanf(inp,"%lE %lE %d", &tmp, &m_bh, &num_bh); - fclose(inp); - printf("%.8E \t %.8E \t %06d \n", tmp, m_bh, num_bh); - fflush(stdout); - -#endif // STARDESTR_EXT - - - } // if(diskstep == 0) - - - get_CPU_time(&CPU_time_real0, &CPU_time_user0, &CPU_time_syst0); - - } /* if(myRank == rootRank) */ - - - - -#ifdef STEVOL_SSE -//SSE internal parameters (see Hurley, Pols & Tout 2000) - -value1_.neta = 0.5; //Reimers mass-loss coefficent (neta*4x10^-13; 0.5 normally) -value1_.bwind = 0.0; //Binary enhanced mass loss parameter (inactive for single) -value1_.hewind = 1.0; //Helium star mass loss factor (1.0 normally) -value1_.mxns = 3.0; //Maximum NS mass (1.8, nsflag=0; 3.0, nsflag=1) - -points_.pts1 = 0.05; //Time-step parameter in evolution phase: MS (0.05) -points_.pts2 = 0.01; //Time-step parameter in evolution phase: GB, CHeB, AGB, HeGB (0.01) -points_.pts3 = 0.02; //Time-step parameter in evolution phase: HG, HeMS (0.02) - -//value4_.sigma = 190.0; //Kick velocities - standard values... -value4_.sigma = 265.0; //Kick velocities - Hobbs++2005 values... -value4_.bhflag = 1; //bhflag > 0 allows velocity kick at BH formation - -value3_.idum = 19640916; // random number seed !!! - -//BSE internal parameters (see Hurley, Pols & Tout 2002) - -flags_.ceflag = 0; //ceflag > 0 activates spin-energy correction in common-envelope (0) #defunct# -flags_.tflag = 1; //tflag > 0 activates tidal circularisation (1) -flags_.ifflag = 0; //ifflag > 0 uses WD IFMR of HPE, 1995, MNRAS, 272, 800 (0) -flags_.nsflag = 1; //nsflag > 0 takes NS/BH mass from Belczynski et al. 2002, ApJ, 572, 407 (1) -flags_.wdflag = 1; //wdflag > 0 uses modified-Mestel cooling for WDs (0) - -value5_.beta = 0.125; //beta is wind velocity factor: proportional to vwind**2 (1/8) -value5_.xi = 1.0; //xi is the wind accretion efficiency factor (1.0) -value5_.acc2 = 1.5; //acc2 is the Bondi-Hoyle wind accretion factor (3/2) -value5_.epsnov = 0.001; //epsnov is the fraction of accreted matter retained in nova eruption (0.001) -value5_.eddfac = 1.0; //eddfac is Eddington limit factor for mass transfer (1.0) -value5_.gamma = -1.0; //gamma is the angular momentum factor for mass lost during Roche (-1.0) - -value2_.alpha1 = 1.0; //alpha1 is the common-envelope efficiency parameter (1.0) -value2_.lambda = 0.5; //lambda is the binding energy factor for common envelope evolution (0.5) - -#endif // STEVOL_SSE - - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - /* Broadcast all useful values to all processors... */ - MPI_Bcast(&N, 1, MPI_INT, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&eps, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&eta, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&t_end, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&dt_disk, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&dt_contr, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&dt_bh, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&time_cur, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - -#ifdef NORM - MPI_Bcast(&m_norm, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&r_norm, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&v_norm, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&t_norm, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); -#endif // NORM - -#ifdef EXTPOT - -#ifdef EXTPOT_GAL - MPI_Bcast(&m_bulge, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&a_bulge, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&b_bulge, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - - MPI_Bcast(&m_disk, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&a_disk, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&b_disk, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - - MPI_Bcast(&m_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&a_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&b_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - -/* - MPI_Bcast(&x_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&y_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&z_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - - MPI_Bcast(&vx_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&vy_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&vz_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); -*/ -#endif - -#ifdef EXTPOT_BH - MPI_Bcast(&m_bh, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&b_bh, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); -#endif - -#ifdef EXTPOT_GAL_DEH - MPI_Bcast(&m_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&r_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&g_ext, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); -#endif - -#ifdef EXTPOT_GAL_LOG - MPI_Bcast(&v_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&r_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - - MPI_Bcast(&v2_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&r2_halo, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); -#endif - -#endif // EXTPOT - - -#ifdef STARDESTR - MPI_Bcast(&m_bh1, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&num_bh1, 1, MPI_INT, rootRank, MPI_COMM_WORLD); - - MPI_Bcast(&m_bh2, 1, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - MPI_Bcast(&num_bh2, 1, MPI_INT, rootRank, MPI_COMM_WORLD); -#endif // STARDESTR - - -#ifdef STARDESTR_EXT - MPI_Bcast(&num_bh, 1, MPI_INT, rootRank, MPI_COMM_WORLD); -#endif // STARDESTR_EXT - - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - - - eta_s = eta/ETA_S_CORR; - eta_bh = eta/ETA_BH_CORR; - - eps2 = SQR(eps); - - dt_min = 1.0*pow(2.0, DTMINPOWER); - dt_max = 1.0*pow(2.0, DTMAXPOWER); - - if(dt_disk == dt_contr) - dt_max = dt_contr; - else - dt_max = MIN(dt_disk, dt_contr); - - if(dt_max > 1.0) dt_max = 1.0; - - t_disk = dt_disk*(1.0+floor(time_cur/dt_disk)); - t_contr = dt_contr*(1.0+floor(time_cur/dt_contr)); - t_bh = dt_bh*(1.0+floor(time_cur/dt_bh)); - - -if(myRank == rootRank) - { - printf("t_disk = %.6E t_contr = %.6E t_bh = %.6E \n", t_disk, t_contr, t_bh); - printf("\n"); - fflush(stdout); - } /* if(myRank == rootRank) */ - -/* - t_disk = time_cur + dt_disk; - t_contr = time_cur + dt_contr; - t_bh = time_cur + dt_bh; -*/ - -#ifdef STEVOL - dt_stevol = dt_max; - t_stevol = dt_stevol*(1.0 + floorl(time_cur/dt_stevol)); - -if(myRank == rootRank) - { - printf("t_stevol = %.6E dt_stevol = %.6E \n", t_stevol, dt_stevol); - printf("\n"); - fflush(stdout); - } /* if(myRank == rootRank) */ -#endif - -#ifdef STEVOL_SSE - dt_stevol = dt_max; - t_stevol = dt_stevol*(1.0 + floorl(time_cur/dt_stevol)); - -if(myRank == rootRank) - { - printf("t_stevol = %.6E dt_stevol = %.6E \n", t_stevol, dt_stevol); - printf("\n"); - fflush(stdout); - } /* if(myRank == rootRank) */ -#endif - - - for(i=0; i BH _softened_ pot, acc & jerk - - tmp_i = calc_force_n_BH(m_bh1, x_bh1, v_bh1, - m_bh2, x_bh2, v_bh2, - eps, - &pot_bh1, a_bh1, adot_bh1, - &pot_bh2, a_bh2, adot_bh2); - - pot[i_bh1] -= pot_bh1; - pot[i_bh2] -= pot_bh2; - - for(k=0;k<3;k++) - { - a[i_bh1][k] -= a_bh1[k]; - a[i_bh2][k] -= a_bh2[k]; - - adot[i_bh1][k] -= adot_bh1[k]; - adot[i_bh2][k] -= adot_bh2[k]; - } - -// calculate and "plus" the new BH <-> BH _unsoftened_ pot, acc, jerk - - tmp_i = calc_force_n_BH(m_bh1, x_bh1, v_bh1, - m_bh2, x_bh2, v_bh2, - eps_BH, - &pot_bh1, a_bh1, adot_bh1, - &pot_bh2, a_bh2, adot_bh2); - - pot[i_bh1] += pot_bh1; - pot[i_bh2] += pot_bh2; - - for(k=0;k<3;k++) - { - a[i_bh1][k] += a_bh1[k]; - a[i_bh2][k] += a_bh2[k]; - - adot[i_bh1][k] += adot_bh1[k]; - adot[i_bh2][k] += adot_bh2[k]; - } - -#endif // ADD_N_BH - - -#ifdef ADD_PN_BH - -// calculate and "plus" the new BH <-> BH : PN1, PN2, PN2.5, PN3, PN3.5 : acc, jerk - - -/* - printf("PN: % .8E \t % .8E \t % .8E \n", x_bh1[0], x_bh1[1], x_bh1[2]); - printf("PN: % .8E \t % .8E \t % .8E \n", x_bh2[0], x_bh2[1], x_bh2[2]); - fflush(stdout); -*/ - - dt_bh_tmp = dt[0]; - - tmp_i = calc_force_pn_BH(m_bh1, x_bh1, v_bh1, s_bh1, - m_bh2, x_bh2, v_bh2, s_bh2, - C_NB, dt_bh_tmp, usedOrNot, - a_pn1, adot_pn1, - a_pn2, adot_pn2); - - for(k=0;k<3;k++) - { - a[i_bh1][k] += a_pn1[1][k] + a_pn1[2][k] + a_pn1[3][k] + a_pn1[4][k] + a_pn1[5][k] + a_pn1[6][k]; - a[i_bh2][k] += a_pn2[1][k] + a_pn2[2][k] + a_pn2[3][k] + a_pn2[4][k] + a_pn2[5][k] + a_pn2[6][k]; - - adot[i_bh1][k] += adot_pn1[1][k] + adot_pn1[2][k] + adot_pn1[3][k] + adot_pn1[4][k] + adot_pn1[5][k] + adot_pn1[6][k]; - adot[i_bh2][k] += adot_pn2[1][k] + adot_pn2[2][k] + adot_pn2[3][k] + adot_pn2[4][k] + adot_pn2[5][k] + adot_pn2[6][k]; - } - - if(myRank == rootRank) - { - if(tmp_i == 505) - { - printf("PN RSDIST: %.8E \t %.8E \n", Timesteps, time_cur); - fflush(stdout); - exit(-1); - } - } - -#endif // ADD_PN_BH - -#endif // ADD_BH2 - - - -#if defined(EXTPOT) || defined(GMC) - calc_ext_grav_zero(); -#endif - -#ifdef GMC - calc_gmc_self_grav(); - calc_ext_gmc_grav(); -#endif - - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - - -// sjuda stavim DRAG... - -#ifdef STARDISK - - for(i=0; i dt_max) dt_tmp = dt_max; - -// dt_tmp = dt_min; - - -#ifdef STARDESTR - if(m[i] == 0.0) dt_tmp = dt_max; -#endif - -#ifdef STARDESTR_EXT - if(m[i] == 0.0) dt_tmp = dt_max; -#endif - - dt[i] = dt_tmp; - - -#ifdef DT_MIN_WARNING - if(myRank == 0) - { - if(dt[i] == dt_min) - { - printf("!!! Warning0: dt = dt_min = %.6E \t ind = %07d \n", dt[i], ind[i]); - fflush(stdout); - } - } -#endif - - } /* i */ - - - - -#ifdef ADD_BH2 - -/* define the min. dt over all the part. and set it also for the BH... */ - - min_dt = dt[0]; - - for(i=1; i 0.1) dt[i] = min_dt; - } /* i */ - -#endif // GMC2 - - -#ifdef GMC2222 - -/* define the max. dt for the GMC... */ - - for(i=1; i 0.1) dt[i] = dt_max; - } /* i */ - -#endif // GMC2 - - - -#ifdef ACT_DEF_LL - CreateLinkList(); -#ifdef DEBUG111 - if( myRank == rootRank ) check_linklist(0); -#endif -#endif - - - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - /* Scatter the "local" vectors from "global" */ - MPI_Scatter(dt, n_loc, MPI_DOUBLE, dt_loc, n_loc, MPI_DOUBLE, rootRank, MPI_COMM_WORLD); - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - /* load the new values for particles to the local GRAPE's */ - - nj=n_loc; - - /* load the nj particles to the G6 */ - - for(j=0; j 0) - for(int i=0; i= t_contr) -// { - MPI_Allreduce(pot_act_tmp, pot_act_new, n_act, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); -// } /* if(min_t >= t_contr) */ - -// MPI_Allreduce(pot_act_tmp, pot_act_new, n_act, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - MPI_Allreduce(a_act_tmp, a_act_new, 3*n_act, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - MPI_Allreduce(adot_act_tmp, adot_act_new, 3*n_act, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - -#ifdef TIMING - get_CPU_time(&CPU_tmp_real, &CPU_tmp_user, &CPU_tmp_syst); - DT_ACT_REDUCE += (CPU_tmp_user - CPU_tmp_user0); -#endif - - - -#ifdef ADD_BH2 - -#ifdef ADD_N_BH - - m_bh1 = m_act[i_bh1]; - m_bh2 = m_act[i_bh2]; - - for(k=0;k<3;k++) - { - x_bh1[k] = x_act_new[i_bh1][k]; - v_bh1[k] = v_act_new[i_bh1][k]; - - x_bh2[k] = x_act_new[i_bh2][k]; - v_bh2[k] = v_act_new[i_bh2][k]; - } - -// calculate and "minus" the BH <-> BH softened pot, acc & jerk - - tmp_i = calc_force_n_BH(m_bh1, x_bh1, v_bh1, - m_bh2, x_bh2, v_bh2, - eps, - &pot_bh1, a_bh1, adot_bh1, - &pot_bh2, a_bh2, adot_bh2); - - pot_act_new[i_bh1] -= pot_bh1; - pot_act_new[i_bh2] -= pot_bh2; - - for(k=0;k<3;k++) - { - a_act_new[i_bh1][k] -= a_bh1[k]; - a_act_new[i_bh2][k] -= a_bh2[k]; - - adot_act_new[i_bh1][k] -= adot_bh1[k]; - adot_act_new[i_bh2][k] -= adot_bh2[k]; - } - -// calculate and "plus" the new BH <-> BH unsoftened pot, acc, jerk - - tmp_i = calc_force_n_BH(m_bh1, x_bh1, v_bh1, - m_bh2, x_bh2, v_bh2, - eps_BH, - &pot_bh1, a_bh1, adot_bh1, - &pot_bh2, a_bh2, adot_bh2); - - pot_act_new[i_bh1] += pot_bh1; - pot_act_new[i_bh2] += pot_bh2; - - for(k=0;k<3;k++) - { - a_act_new[i_bh1][k] += a_bh1[k]; - a_act_new[i_bh2][k] += a_bh2[k]; - - adot_act_new[i_bh1][k] += adot_bh1[k]; - adot_act_new[i_bh2][k] += adot_bh2[k]; - } - -#endif // ADD_N_BH - - -#ifdef ADD_PN_BH - -// calculate and "plus" the new BH <-> BH : PN1, PN2, PN2.5, PN3, PN3.5 : acc, jerk - - dt_bh_tmp = dt[0]; - - tmp_i = calc_force_pn_BH(m_bh1, x_bh1, v_bh1, s_bh1, - m_bh2, x_bh2, v_bh2, s_bh2, - C_NB, dt_bh_tmp, usedOrNot, - a_pn1, adot_pn1, - a_pn2, adot_pn2); - - for(k=0;k<3;k++) - { - a_act_new[i_bh1][k] += a_pn1[1][k] + a_pn1[2][k] + a_pn1[3][k] + a_pn1[4][k] + a_pn1[5][k] + a_pn1[6][k]; - a_act_new[i_bh2][k] += a_pn2[1][k] + a_pn2[2][k] + a_pn2[3][k] + a_pn2[4][k] + a_pn2[5][k] + a_pn2[6][k]; - - adot_act_new[i_bh1][k] += adot_pn1[1][k] + adot_pn1[2][k] + adot_pn1[3][k] + adot_pn1[4][k] + adot_pn1[5][k] + adot_pn1[6][k]; - adot_act_new[i_bh2][k] += adot_pn2[1][k] + adot_pn2[2][k] + adot_pn2[3][k] + adot_pn2[4][k] + adot_pn2[5][k] + adot_pn2[6][k]; - } - - if(myRank == rootRank) - { - if(tmp_i == 505) - { - printf("PN RSDIST: TS = %.8E \t t = %.8E \n", Timesteps, time_cur); - fflush(stdout); - exit(-1); - } - } - -#endif // ADD_PN_BH - -#endif // ADD_BH2 - -#ifdef EXTPOT - calc_ext_grav(); -#endif - -#ifdef GMC - calc_gmc_self_grav(); - calc_ext_gmc_grav(); -#endif - - -// sjuda stavim DRAG... - -#ifdef STARDISK - -#ifdef TIMING - get_CPU_time(&CPU_tmp_real0, &CPU_tmp_user0, &CPU_tmp_syst0); -#endif - - calc_drag_force(); - - /* E_sd tut opjaty pljusujetsja... */ - - for(i=0; i dt_min) ) - { - power = log(dt_new)/log(2.0) - 1; -// power = log(dt_new)/log(2.0); - - dt_tmp = pow(2.0, (double)power); - } - - -#ifdef STARDISK - - // accretion disk criteria -// sjuda stavim izmenenija DT za schot DRAG pri priblizhenii k ploskosti Z=0 ... - - z_new_drag = x_act_new[i][2] + dt_tmp * v_act_new[i][2]; - r_new_drag2 = SQR(x_act_new[i][0]) + SQR(x_act_new[i][1]); - - if(r_new_drag2 > (R_CRIT*R_CRIT)) - { - hz = HZ; - } - else - { - hz = HZ*(sqrt(r_new_drag2)/R_CRIT); - } - -// if (fabs(x_act_new[i][2]) > HZ*2.2) - if (fabs(x_act_new[i][2]) > hz*2.2) - { - - if (z_new_drag * x_act_new[i][2] < 0.0) - { - dt_tmp *= 0.125; - } - else - { -// if (fabs(z_new_drag) < HZ*1.8) - if (fabs(z_new_drag) < hz*1.8) - { - dt_tmp *= 0.5; - } - } - - } - -#endif - - - if( (dt_new > 2.0*dt_tmp) && - (fmod(min_t, 2.0*dt_tmp) == 0.0) && - (2.0*dt_tmp <= dt_max) ) - { - dt_tmp *= 2.0; - } - - dt_act[i] = dt_tmp; - - t_act[i] = min_t; - - pot_act[i] = pot_act_new[i]; - - for(k=0; k<3; k++) - { - x_act[i][k] = x_act_new[i][k]; - v_act[i][k] = v_act_new[i][k]; - a_act[i][k] = a_act_new[i][k]; - adot_act[i][k] = adot_act_new[i][k]; - } /* k */ - -/* - if(myRank == rootRank) - { - tmp_r = sqrt( SQR(x_act_new[i][0]) + SQR(x_act_new[i][1]) + SQR(x_act_new[i][2]) ); - - if(ind_act[i] == 4232) - { - printf("SOS: TS = %.8E \t i = %06d \t n_act = %06d \t R = %.8E \n", Timesteps, ind_act[i], n_act, tmp_r); - printf(" x = % .6E % .6E % .6E \n", x_act_new[i][0], x_act_new[i][1], x_act_new[i][2]); - printf(" v = % .6E % .6E % .6E \n", v_act_new[i][0], v_act_new[i][1], v_act_new[i][2]); - printf(" a = % .6E % .6E % .6E \n", a_act_new[i][0], a_act_new[i][1], a_act_new[i][2]); - printf(" adot = % .6E % .6E % .6E \n", adot_act_new[i][0], adot_act_new[i][1], adot_act_new[i][2]); - printf(" t = %.6E %.6E \n", t_act[i], dt_act[i]); - fflush(stdout); -// exit(-1); - } - } -*/ - - -#ifdef DT_MIN_WARNING - if(myRank == 0) - { - if(dt_act[i] == dt_min) - { - printf("!!! Warning1: dt_act = dt_min = %.6E \t ind_act = %07d \n", dt[i], ind_act[i]); - fflush(stdout); - } - } -#endif - - - - } /* i */ - - - - -/* define the min. dt over all the act. part. and set it also for the BH... */ - -#ifdef ADD_BH2 - - min_dt = dt_act[0]; - - for(i=1; i 0.1) dt_act[i] = min_dt; - } /* i */ - - -#endif // GMC2 - - -#ifdef GMC2222 - -/* define the max. dt for the GMC... */ - - for(i=1; i 0.1) dt_act[i] = dt_max; - } /* i */ - -#endif // GMC2 - - - - - - -#ifdef BBH_INF - if(myRank == rootRank) - { - - out = fopen("bbh.inf","a"); - - m_bh1 = m_act[i_bh1]; - m_bh2 = m_act[i_bh2]; - - for(k=0;k<3;k++) - { - x_bh1[k] = x_act[i_bh1][k]; - x_bh2[k] = x_act[i_bh2][k]; - - v_bh1[k] = v_act[i_bh1][k]; - v_bh2[k] = v_act[i_bh2][k]; - } - - for(k=0;k<3;k++) - { - x_bbhc[k] = (m_bh1*x_bh1[k] + m_bh2*x_bh2[k])/(m_bh1 + m_bh2); - v_bbhc[k] = (m_bh1*v_bh1[k] + m_bh2*v_bh2[k])/(m_bh1 + m_bh2); - } - - DR2 = SQR(x_bh1[0] - x_bh2[0]) + SQR(x_bh1[1] - x_bh2[1]) + SQR(x_bh1[2] - x_bh2[2]); - DV2 = SQR(v_bh1[0] - v_bh2[0]) + SQR(v_bh1[1] - v_bh2[1]) + SQR(v_bh1[2] - v_bh2[2]); - -// mju = m_bh1*m_bh2/(m_bh1 + m_bh2); - - EB = -(m_bh1 + m_bh2) / sqrt(DR2) + 0.5 * DV2; - - SEMI_a = -0.5 * (m_bh1 + m_bh2)/EB; - SEMI_a2 = SQR(SEMI_a); - - -// printf("INF: %.6E %.16E %.6E %.6E % .6E % .6E % .6E % .6E % .6E % .6E %.6E % .6E % .6E % .6E % .6E % .6E % .6E % .6E %.6E % .6E % .6E % .6E % .6E % .6E % .6E % .6E \n", -// Timesteps, time_cur, SEMI_a, -// sqrt(DR2), x_bbhc[0], x_bbhc[1], x_bbhc[2], v_bbhc[0], v_bbhc[1], v_bbhc[2], -// m_bh1, x_bh1[0], x_bh1[1], x_bh1[2], v_bh1[0], v_bh1[1], v_bh1[2], pot_act[0], -// m_bh2, x_bh2[0], x_bh2[1], x_bh2[2], v_bh2[0], v_bh2[1], v_bh2[2], pot_act[1]); -// fflush(stdout); - - - - for(i=2; i= t_stevol) - { - - /* Define the current mass of all star particles... */ - - for(i=0; i= t_stevol) */ - -#ifdef TIMING - get_CPU_time(&CPU_tmp_real, &CPU_tmp_user, &CPU_tmp_syst); - DT_STEVOL += (CPU_tmp_user - CPU_tmp_user0); -#endif - -#endif - - - /* STEVOL_SSE routine on all the nodes */ - -#ifdef STEVOL_SSE - - -#ifdef TIMING - get_CPU_time(&CPU_tmp_real0, &CPU_tmp_user0, &CPU_tmp_syst0); -#endif - - if(time_cur >= t_stevol) - { - - /* Define the current mass of all star particles... */ - - for(i=0; i= t_stevol) */ - -#ifdef TIMING - get_CPU_time(&CPU_tmp_real, &CPU_tmp_user, &CPU_tmp_syst); - DT_STEVOL += (CPU_tmp_user - CPU_tmp_user0); -#endif - - - - -/* Update ALL the new m,r,v "j" part. to the GRAPE/GPU memory */ - - - for(j=0; j= t_bh) - { - - if(myRank == rootRank) - { - -#ifdef BH_OUT - /* Write BH data... */ - write_bh_data(); -#endif - -#ifdef BH_OUT_NB - /* Write BH NB data... */ - write_bh_nb_data(); -#endif - -#ifdef BH_OUT_NB_EXT - /* Write BH NB data... */ - write_bh_nb_data_ext(); -#endif - - } /* if(myRank == rootRank) */ - - t_bh += dt_bh; - } /* if(time_cur >= t_bh) */ - - - - - - if(time_cur >= t_contr) - { - - if(myRank == rootRank) - { - -#ifdef STARDESTR - -/* - out = fopen("phi-GRAPE.ext","w"); - fprintf(out,"%.8E \t %.8E \n", m_bh, b_bh); - fclose(out); -*/ -/* - out = fopen("mass-bh.dat","a"); - fprintf(out,"%.8E \t %.8E \t %06d \n", time_cur, m_bh, num_bh); - fclose(out); -*/ - -#ifdef ADD_BH2 - - out = fopen("mass-bh.dat","a"); - fprintf(out,"%.8E \t %.8E %06d \t %.8E %06d \n", - time_cur, m_bh1, num_bh1, m_bh2, num_bh2); - fclose(out); - - out = fopen("mass-bh.con","w"); - fprintf(out,"%.8E \t %.8E %06d \t %.8E %06d \n", - time_cur, m_bh1, num_bh1, m_bh2, num_bh2); - fclose(out); - -#else - -#ifdef ADD_BH1 - - out = fopen("mass-bh.dat","a"); - fprintf(out,"%.8E \t %.8E %06d \n", - time_cur, m_bh1, num_bh1); - fclose(out); - - out = fopen("mass-bh.con","w"); - fprintf(out,"%.8E \t %.8E %06d \n", - time_cur, m_bh1, num_bh1); - fclose(out); - -#endif // ADD_BH1 - -#endif // ADD_BH2 - -#endif // STARDESTR - -#ifdef STARDESTR_EXT - - out = fopen("phi-GRAPE.ext","w"); - fprintf(out,"%.8E \t %.8E \n", m_bh, b_bh); - fclose(out); - - out = fopen("mass-bh.dat","a"); - fprintf(out,"%.8E \t %.8E \t %06d \n", time_cur, m_bh, num_bh); - fclose(out); - - out = fopen("mass-bh.con","w"); - fprintf(out,"%.8E \t %.8E \t %06d \n", time_cur, m_bh, num_bh); - fclose(out); - -#endif // STARDESTR_EXT - - - -#ifdef ACT_DEF_LL -#ifdef DEBUG111 - if(myRank == rootRank) check_linklist((int)Timesteps); -#endif -#endif - - - energy_contr(); - -#ifdef CMCORR111 - for(i=0; i R_LIMITS_ALL) && (m[i] != 0.0) ) - if( (tmp_r > R_LIMITS_ALL) && (tmp_rv > 0.0) ) - { - -// tmp_v = sqrt( SQR(v[i][0]) + SQR(v[i][1]) + SQR(v[i][2]) ); -// E_corr += 0.5*m[i]*SQR(tmp_v); - -// pot[i] = 0.0; - -#ifdef EXTPOT -// pot_ext[i] = 0.0; -#endif - - for(k=0;k<3;k++) - { -// x[i][k] = R_LIMITS_ALL + 1.0*my_rand2(); - v[i][k] *= 1.0E-01; -// a[i][k] = 1.0E-06*my_rand2(); -// adot[i][k] = 1.0E-06*my_rand2(); - } /* k */ - -// t[i] = min_t; -// dt[i] = 0.125; - - } /* if */ - - } /* i */ - - - - for(j=0; j= t_contr) */ - - - - - - - - - if(time_cur >= t_disk) - { - - - if(myRank == rootRank) - { - - diskstep++; - - write_snap_data(); -// write_cont_data(); - -#ifdef DEBUG_extra - write_snap_extra(); -#endif - -#ifdef SPH_GAS - write_data_SPH(); -#endif - -#ifdef GMC - write_snap_GMC(); -#endif - - } /* if(myRank == rootRank) */ - -#ifdef ETICS_DUMP - sprintf(out_fname, "coeffs.%06d.%02d.dat", diskstep, myRank); - grapite_dump(out_fname, 2); -#endif - - - - -#ifdef LIMITS_NEW - - for(i=0; i 900.0 ) - { - - m[i] = 0.0; - - pot[i] = 0.0; - -#ifdef EXTPOT - pot_ext[i] = 0.0; -#endif - - for(k=0;k<3;k++) - { - x[i][k] = 1000.0 + 1.0*my_rand2(); - v[i][k] = 1.0E-06*my_rand2(); - a[i][k] = 1.0E-06*my_rand2(); - adot[i][k] = 1.0E-06*my_rand2(); - } /* k */ - - t[i] = 2.0*t_end; - - dt[i] = 0.125; - - } /* if */ - - } /* i */ - - - - for(j=0; j= t_disk) */ - - - -#ifdef CPU_TIMELIMIT - if(myRank == rootRank) - { - get_CPU_time(&CPU_time_real, &CPU_time_user, &CPU_time_syst); - tmp_cpu = CPU_time_real-CPU_time_real0; - } /* if(myRank == rootRank) */ -#endif - - -#ifdef ACT_DEF_LL - //printf("At tsteps= %04d . t+dt for BH = % 08E\n", int(Timesteps), t[N-1]+dt[N-1]); - ModifyLinkList(); - -#ifdef DEBUG111 - if( (((int)Timesteps)%10000 == 0) && (myRank == rootRank) ) check_linklist((int)Timesteps); -#endif -#endif - - } /* while(time_cur < t_end) */ - - - - /* close the local GRAPE's */ - -#ifdef SAPPORO - g6_close_(&clusterid); -#else - g6_close(clusterid); -#endif - - - /* Wait to all processors to finish his works... */ - MPI_Barrier(MPI_COMM_WORLD); - - MPI_Reduce(&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... */ - - printf("\n"); - printf("Timesteps = %.0f Total sum of integrated part. = %.0f g6_calls on all nodes = %.0f \n", Timesteps, n_act_sum, g6_calls); - printf("\n"); - printf("Real Speed = %.3f GFlops \n", 57.0*N*n_act_sum/(CPU_time_user-CPU_time_user0)/1.0E+09); - fflush(stdout); - - -#ifdef DEBUG111 - tmp_file = fopen("n_act_distr.dat","w"); - - fprintf(tmp_file,"\n"); - fprintf(tmp_file,"Total Timesteps = %.0f Total sum of integrated part. = %.0f g6_calls on all nodes = %.0f \n", Timesteps, n_act_sum, g6_calls); - fprintf(tmp_file,"\n"); - fprintf(tmp_file,"Real Speed = %.3f GFlops \n", 57.0*N*n_act_sum/(CPU_time_user-CPU_time_user0)/1.0E+09); - - for(i=1;i dt_contr, the maximum timestep +# is dt_contr. [default: -3] +#dt_max_power = -3 + +# The power of 2 of the minimum timestep. [default: -36] +#dt_min_power = -36 + +# Eta correction factor for the first step (the timestep will be calculated with +# eta divided by eta_s_corr) [default: 4] +#eta_s_corr = 4.0 + +# Eta correction factor for the black holes (the timestep for the black holes +# will be calculated with eta divided by eta_bh_corr). [default: 4] +#eta_bh_corr = 4.0 + + +########## +# OUTPUT # +########## + +# Whether to use HDF5 format for snapshot and restart; regular ASCII snapshorts +# are saved if false [default: false] +#output_hdf5 = true + +# If using HDF5 output, use double precision or not [default: true] Consider +# setting to false to save disk space. Restart file is always saved in double +# precision. +#output_hdf5_double_precision = true + +# If using ASCII output, the number of digits after the decimal point [default: 10] +# Restart file is saved with 16 digits after the decimal point. +#output_ascii_precision = 6 + +# Extra output: optionally save potential, acceleration and jerk in snapshot +# files [default: 0] +# This is a number between 0 and 7 that encodes the output options in the +# following way: +# [value] = [save jerk]*4 + [save acceleration]*2 + [save potential] +# Example: choose 5 if it is needed to save the jerk and the potential, but not +# the acceleration for some reason. +# Currently implemented in HDF5 output only. +#output_extra_mode = 7 + +# Whether to output a warning on the screen when the minimum time step is +# encountered. [default: false] +#dt_min_warning = false + + +#################### +# EXTERNAL GRAVITY # +#################### + +# Remember that external gravity models are applied at the same coordinate +# system as the particles. If the idea is to simulate a globular cluster +# orbiting in an external field, be sure to set the initial conditions +# appropriately (applying a shift to the coordinates and velocities). + +# Whether the parameters for the external gravitational field given below are in +# physical units or Hénon units. If true, the system used is {kiloparsec, solar +# mass, kilometre per second} [default: false] +#ext_units_physical = true + +# If Physical units were selected, specify the simulation's unit mass (is solar +# masses) and unit lenght (in parsec; not kiloparsec) +# TODO: add the option to normalize using other units. +#unit_mass = 4E5 # MSun +#unit_length = 15 # pc + + +# The bulge is a Plummer potential with the following total mass and radius. +#ext_m_bulge = 5E9 # MSun +#ext_b_bulge = 1.9 # kpc + + +# The disk is a Miyamoto-Nagai potential with the following total mass, scale +# length, and scale height +#ext_m_disk = 6.8E10 # MSun +#ext_a_disk = 3.00 # kpc +#ext_b_disk = 0.28 # kpc + + +# This halo option is yet another Plummer potential with the following total +# mass and radius. +#ext_m_halo_plummer = 8E11 # MSun +#ext_b_halo_plummer = 245 # kpc + + +# This halo option is a logarithmic potential with the following velocity and +# radius parameters. +#ext_log_halo_v = 240 # km/s +#ext_log_halo_r = 1 # kpc + +# This is a spherical Dehnen model. +#ext_dehnen_m = 1E11 # MSun +#ext_dehnen_r = 2 # kpc +#ext_dehnen_gamma = 0.5 + + +################################### +# LIVE SUPERMASSIVE BLACK HOLE(S) # +################################### + +# There is special treatment for particles representing supermassive black holes +# (SMBHs): they are integrated at every time step, they can have custom +# softening in SMBH-SMBH interactions, and post Newtonian terms can be added to +# the gravity. + +# The number of SMBH particles. Can be 0 (no SMBH), 1, or 2. [default: 0] +#live_smbh_count = 2 + +# Custom softening length for SMBH-SMBH interactions (can also be zero). If +# non-negative, the custom softening is applied. [default: -1] +#live_smbh_custom_eps = 0 +#TODO this is actually related only to BINARY smbh! + +# Output additional diagnostics about live SMBHs. [default: false] +#live_smbh_output = true + +# Output additional diagnostics about the SMBH's (or SMBHs') nearest neighbours +# (number could be set as shown below). [default: false] +#live_smbh_neighbor_output = true + +# Number of nearest neighbours to the SMBH (or SMBHs) to include in output. [default: 10] +#live_smbh_neighbor_number = 10 + + +################################## +# BINARY SUPERMASSIVE BLACK HOLE # +################################## + +# The following parameters can be set when live_smbh_count is 2. + +# Output additional diagnostics about the sphere of influence (size could be set +# as shown below). [default: false] +#binary_smbh_influence_sphere_output = true + +# The influence sphere is centred at the binary SMBH's centre of mass, and its +# radius is the semi-major axis of the binary times the factor below. [default: 10] +#binary_smbh_influence_radius_factor = 3.162277660168379497918067e+03 + +# Add post Newtonian terms to SMBH-SMBH gravity. [default: false] +#binary_smbh_pn = true + +# A mask array (zeros and ones) determining whether or not to use specific +# post-Newtonian terms. +# The elements represent {Newtonian, 1, 2, 2.5, 3, 3.5, spin} +# Note: the first element in the array has no effect, the Newtonian force is +# always included. +#pn_usage = {1, 1, 1, 1, 0, 0, 0} + +# The speed of light in N-body units +#pn_c = 477.12 + +# The spin vectors of the two SMBHs. Only define these if the last component of +# pn_usage is set to one. +#smbh1_spin = {0, 0, 1} +#smbh2_spin = {0, 0, 1} + + +############### +# HYBRID CODE # +############### + +# The hybridization with the SCF code is enabled if the ETICS preprocessor flag +# is defined in the when compiling. + +# Time intervals to calculate the SCF series expansion. +dt_scf = 0.015625 + +# Name of the mask file for GRAPite [default: grapite.mask] +#grapite_mask_file_name = grapite.mask + +# Whether to write to disk a list of SCF coefficients at every dt_disk. [default: false] +#etics_dump_coeffs = true + +# Whether to use an alternative procedure for active particle search that is +# available in the GRAPite library. This requires the number of particles in +# each MPI process to be exactly divisible by 32. This can substantially +# accelerate the calculation in some circumstances [default: false] +#grapite_active_search = true + +# Custom softening length for SMBH-star interactions in the hybrid scheme only. +# This value (can also be zero) is used in the direct gravity calculation +# between SMBHs (tag=3) and both core (tag=0) and halo (tag=1) stars. If +# negative, the Plummer softening parameter (`eps`) is used in these +# interactions. Do not confuse with `live_smbh_custom_eps`, which is the +# softening length for SMBH-SMBH interactions, and works both in the normal and +# hybrid schemes. [default: -1] +#grapite_smbh_star_eps = 1E-6 + +# If the number of active particles in a particular bunch is bigger than this +# threshold, then the execution is on the GPU, otherwise on the CPU. When the +# active bunch is small, the overhead of calculating the SCF gravity on the GPU +# makes the operation more expensive than if it is done on the CPU. [default: 32] +#grapite_dev_exec_threshold = 512 + +# TODO +######## +# etics dump mode +# scaling parameter override + + +#################################### +# Negative powers of two # +#################################### +# -1 1/2 0.5 # +# -2 1/4 0.25 # +# -3 1/8 0.125 # +# -4 1/16 0.0625 # +# -5 1/32 0.03125 # +# -6 1/64 0.015625 # +# -7 1/128 0.0078125 # +# -8 1/256 0.00390625 # +# -9 1/512 0.001953125 # +# -10 1/1024 0.0009765625 # +# -11 1/2048 0.00048828125 # +# -12 1/4096 0.000244140625 # +# -13 1/8192 0.0001220703125 # +# -14 1/16384 0.00006103515625 # +# -15 1/32768 0.000030517578125 # +# -16 1/65536 0.0000152587890625 # +#################################### diff --git a/phigrape.cpp b/phigrape.cpp new file mode 100644 index 0000000..52ec687 --- /dev/null +++ b/phigrape.cpp @@ -0,0 +1,731 @@ +#include +#include +#include +#include +#include + +#include "black_holes.h" +#include "config.h" +#include "double3.h" +#include "external.h" +#include "grape6.h" +#include "io.h" + +#ifdef ETICS +#include "grapite.h" +#endif + +namespace std::chrono { + struct Timer { + void start() + { + t_start = steady_clock::now(); + } + void stop() + { + t_stop = steady_clock::now(); + time = duration_cast(t_stop - t_start).count()*1E-9; + } + double time; // seconds + steady_clock::time_point t_start, t_stop; + }; +} +std::chrono::Timer timer; + +class Calc_self_grav { +public: + Calc_self_grav(const int N, const int n_loc, const int clusterid, const int npipe, const double eps) + : g6_calls(0), n_loc(n_loc), clusterid(clusterid), npipe(npipe), eps2(eps*eps) + { + h2.assign(N, eps2); + pot_loc.resize(N); + acc_loc.resize(N); + jrk_loc.resize(N); + } + void operator()(const double t, const int n_act, std::vector &ind_act, std::vector &x_act, std::vector &v_act, + std::vector& pot, std::vector &acc, std::vector &jrk) + { + g6_set_ti(clusterid, t); + for (int i=0; i h2; + std::vector pot_loc; // the _loc variables are for this node only. + std::vector acc_loc, jrk_loc; +}; + +class Calc_ext_grav { +public: + void add_component(External_gravity &component) + { + components.push_back(&component); + if (component.is_active) any_active = true; + } + void operator()(int n, const std::vector &x, const std::vector &v, std::vector &pot, std::vector &acc, std::vector &jrk) + { + for (auto component : components) { + if (component->is_active) + component->apply(n, x, v, pot, acc, jrk); + } + } + void print_info() + { + for (auto component : components) { + component->print_info(); + } + fflush(stdout); + } + bool any_active = false; +private: + std::vector components; +}; + +void energy_contr(const double time_cur, const double timesteps, const double n_act_sum, const double g6_calls, int N, const std::vector &m, const std::vector &x, const std::vector &v, const std::vector &pot, const std::vector &pot_ext) +{ + double E_pot = 0; + for (int i=0; i &t, const std::vector &dt) + { + double min_t_loc, min_t; +#ifdef ETICS + if (grapite_active_search_flag) { + min_t_loc = grapite_get_minimum_time(); + } else +#endif + { + min_t_loc = t[myRank*n_loc]+dt[myRank*n_loc]; + for (int j=myRank*n_loc+1; j<(myRank+1)*n_loc; j++) { + double tmp = t[j] + dt[j]; + if (tmp < min_t_loc) min_t_loc = tmp; + } + } + /* Reduce the "global" min_t from min_t_loc "local" on all processors) */ + MPI_Allreduce(&min_t_loc, &min_t, 1, MPI_DOUBLE, MPI_MIN, MPI_COMM_WORLD); + return min_t; + } + void get_active_indices(const double min_t, const std::vector &t, const std::vector &dt, std::vector &ind_act, int &n_act) + { +#ifdef ETICS + if (grapite_active_search_flag) { + int n_act_loc; + grapite_active_search(min_t, ind_act_loc.data(), &n_act_loc); + if (myRank > 0) + for (int i=0; i ind_act_loc; + bool grapite_active_search_flag; +}; + +inline void calc_high_derivatives(const double dt_tmp, const double3 &a_old, const double3 &a_new, const double3 &a1_old, const double3 &a1_new, double3 &a2, double3 &a3) +{ + double dtinv = 1/dt_tmp; + double dt2inv = dtinv*dtinv; + double dt3inv = dt2inv*dtinv; + + double3 a0mia1 = a_old-a_new; + double3 ad04plad12 = 4*a1_old + 2*a1_new; + double3 ad0plad1 = a1_old + a1_new; + + a2 = -6*a0mia1*dt2inv - ad04plad12*dtinv; + a3 = 12*a0mia1*dt3inv + 6*ad0plad1*dt2inv; +} + +inline void corrector(const double dt_tmp, const double3 &a2, const double3 &a3, double3 &x, double3 &v) +{ + double dt3over6 = dt_tmp*dt_tmp*dt_tmp/6.0; + double dt4over24 = dt3over6*dt_tmp/4.0; + double dt5over120 = dt4over24*dt_tmp/5.0; + + x += dt4over24*a2 + dt5over120*a3; + v += dt3over6*a2 + dt4over24*a3; +} + +inline double aarseth_step(const double eta, const double dt, const double3 &a, const double3 &a1, const double3 &a2, const double3 &a3) +{ + double a1abs = a.norm(); + double adot1abs = a1.norm(); + double3 a2dot1 = a2 + dt*a3; + double a2dot1abs = a2dot1.norm(); + double a3dot1abs = a3.norm(); + return sqrt(eta*(a1abs*a2dot1abs+adot1abs*adot1abs)/(adot1abs*a3dot1abs+a2dot1abs*a2dot1abs)); +} + +inline double blockize_step(double dt, double dt_prev, double min_t, double dt_min, double dt_max) +{ + double dt_new = dt_prev; + if (dt < dt_min) dt_prev = dt_min; + if ((dt < dt_prev) && (dt > dt_min)) { + int power = log(dt)/M_LN2 - 1; + dt_new = pow(2.0, power); + } + if ((dt > 2*dt_new) && (fmod(min_t, 2*dt_new) == 0) && (2*dt_new <= dt_max)) dt_new *= 2; + return dt_new; +} + +inline void predictor(double min_t, const int n_act, const std::vector &ind_act, const std::vector &t, const std::vector &x, const std::vector &v, const std::vector &a, const std::vector &adot, std::vector &x_act_new, std::vector &v_act_new) +{ + for (int i=0; i 0)) { + out = fopen("bh.dat", "w"); + fclose(out); + } + if ((config.live_smbh_neighbor_output) && (config.live_smbh_count > 0)) { + out = fopen("bh_neighbors.dat", "w"); + fclose(out); + } + } + } /* if (myRank == rootRank) */ + + double normalization_mass=1, normalization_length=1, normalization_velocity=1; + if (config.ext_units_physical) { + normalization_mass = 1/config.unit_mass; + normalization_length = 1000/config.unit_length; + normalization_velocity = 1.52484071426404437233e+01*sqrt(config.unit_length/config.unit_mass); + } + Calc_ext_grav calc_ext_grav; + Plummer ext_bulge(config.ext_m_bulge*normalization_mass, config.ext_b_bulge*normalization_length); + ext_bulge.set_name("bulge"); + calc_ext_grav.add_component(ext_bulge); + Miyamoto_Nagai ext_disk(config.ext_m_disk*normalization_mass, config.ext_a_disk*normalization_length, config.ext_b_disk*normalization_length); + calc_ext_grav.add_component(ext_disk); + Plummer ext_halo_plummer(config.ext_m_halo_plummer*normalization_mass, config.ext_b_halo_plummer*normalization_length); + ext_halo_plummer.set_name("halo"); + calc_ext_grav.add_component(ext_halo_plummer); + Logarithmic_halo ext_log_halo(config.ext_log_halo_v*normalization_velocity, config.ext_log_halo_r*normalization_length); + calc_ext_grav.add_component(ext_log_halo); + Dehnen ext_dehnen(config.ext_dehnen_m*normalization_mass, config.ext_dehnen_r*normalization_length, config.ext_dehnen_gamma); + calc_ext_grav.add_component(ext_dehnen); + if (myRank == rootRank) calc_ext_grav.print_info(); + + /* some local settings for G6a boards */ + int clusterid, numGPU; + if (config.devices_per_node==0) { + MPI_Comm shmcomm; + MPI_Comm_split_type(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, &shmcomm); + MPI_Comm_size(shmcomm, &numGPU); + MPI_Comm_rank(shmcomm, &clusterid); + } else { + numGPU = config.devices_per_node; + clusterid = myRank % numGPU; + } + printf("Rank of the processor %03d : Number of GPUs %01d : Cluster ID %01d \n", myRank, numGPU, clusterid); + fflush(stdout); + + /* init the local GRAPEs */ + g6_open(clusterid); + int npipe = g6_npipes(); + g6_set_tunit(51); + g6_set_xunit(51); + + bool grapite_active_search_flag = false; +#ifdef ETICS + grapite_set_dev_exec_threshold(config.grapite_dev_exec_threshold); + grapite_active_search_flag = config.grapite_active_search; +#endif + + int n_loc = N/n_proc; +#ifdef ETICS + grapite_read_particle_tags(N, config.grapite_mask_file_name.c_str(), myRank, n_loc); + grapite_set_dt_exp(config.dt_scf); + grapite_set_t_exp(time_cur); +#endif + + const double dt_min = pow(2, config.dt_min_power); + std::vector ind(N); + std::iota(begin(ind), end(ind), 0); + /* load the nj particles to the G6 */ + double3 zeros = {0, 0, 0}; // Dummy; can't really be const because of the GRAPE interface. + for (int k=0; k= 0) { + double3 xcm, vcm, xdc, vdc; + grapite_calc_center(N, m.data(), (double(*)[3])x.data(), (double(*)[3])v.data(), xcm, vcm, xdc, vdc); + x[grapite_cep_index] = xdc; + v[grapite_cep_index] = vdc; + grapite_update_cep(time_cur, xdc, vdc, zeros, zeros); + } + + if (config.grapite_smbh_star_eps >= 0) grapite_set_eps_bh(config.grapite_smbh_star_eps); +#endif + + std::vector a(N), adot(N); + std::vector pot(N); + + /* define the all particles as a active on all the processors for the first time grav calc. */ + Calc_self_grav calc_self_grav(N, n_loc, clusterid, npipe, config.eps); + calc_self_grav(time_cur, N, ind, x, v, pot, a, adot); + + Black_hole_physics black_hole_physics; + std::vector smbh_list; + if (config.live_smbh_count >= 1) + black_hole_physics = Black_hole_physics(config.live_smbh_count, myRank, rootRank); + else if (config.live_smbh_count >= 2) { + if (config.live_smbh_custom_eps >= 0) { +#ifdef ETICS + double eps = (config.grapite_smbh_star_eps >= 0)?config.grapite_smbh_star_eps:config.eps; +#else + double eps = config.eps; +#endif + black_hole_physics.set_softening(eps, config.live_smbh_custom_eps); + for (int i = 0; i < config.live_smbh_count; i++) + smbh_list.emplace_back(m[i], x[i], v[i], pot[i], a[i], adot[i]); + black_hole_physics.adjust_softening(smbh_list); + } + } + if (config.binary_smbh_pn) { + throw std::runtime_error("This is the triple+ SMBH version, it cannot do PN yet!"); + #if 0 + black_hole_physics.set_post_newtonian(config.pn_c, config.pn_usage.data()); + if (config.pn_usage[6]) black_hole_physics.set_spins(config.smbh1_spin.data(), config.smbh2_spin.data()); + black_hole_physics.adjust_post_newtonian(dt_min, a[0], a[1], adot[0], adot[1]); + #endif + } + + std::vector pot_ext(N, 0.); + calc_ext_grav(N, x, v, pot_ext, a, adot); + + double timesteps=0, n_act_sum=0; + /* Energy control... */ + 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)) { + char out_fname[256]; + sprintf(out_fname, "coeffs.%06d.%02d.dat", 0, myRank); + grapite_dump(out_fname, 2); + } + + if (grapite_cep_index >= 0) { + double3 xcm, vcm, xdc, vdc; + grapite_calc_center(N, m.data(), (double(*)[3])x.data(), (double(*)[3])v.data(), xcm, vcm, xdc, vdc); + x[grapite_cep_index] = xdc; + v[grapite_cep_index] = vdc; + grapite_update_cep(time_cur, xdc, vdc, a[grapite_cep_index], adot[grapite_cep_index]); + } +#endif + + const double dt_max = std::min({config.dt_disk, config.dt_contr, pow(2, config.dt_max_power)}); + std::vector dt(N); + /* Define initial timestep for all particles on all nodes */ + for (int j=0; j dt_max) dt_tmp = dt_max; + + dt[j] = dt_tmp; + + if (config.dt_min_warning && (myRank == 0)) { + if (dt[j] == dt_min) { + printf("!!! Warning0: dt = dt_min = %.6E \t ind = %07d \n", dt[j], ind[j]); + fflush(stdout); + } + } + } /* j */ + + if (config.live_smbh_count > 0) { + double min_dt = *std::min_element(begin(dt), end(dt)); + for (int i=0; i ind_act(N); + std::vector x_act_new(N), v_act_new(N), a_act_new(N), adot_act_new(N); + std::vector t(N, time_cur), pot_act_new(N); + std::vector pot_act_ext(N, 0.); + + // Functors for the main integration loop + Active_search active_search(myRank, n_proc, n_loc, N, grapite_active_search_flag); + Binary_smbh_influence_sphere_output binary_smbh_influence_sphere_output(config.binary_smbh_influence_radius_factor, N, m, x, v, pot, dt); + Write_bh_nb_data write_bh_nb_data(config.live_smbh_neighbor_number, config.live_smbh_count, N, m, x, v); + if (myRank == rootRank) { + if (config.live_smbh_output) black_hole_physics.write_bh_data(time_cur, config.live_smbh_count, m, x, v, pot, a, adot, dt); + if (config.live_smbh_neighbor_output) write_bh_nb_data(time_cur); + } /* if (myRank == rootRank) */ + + /* The main integration loop */ + while (time_cur <= config.t_end) { + + /* Define the minimal time and the active particles on all the nodes */ + double min_t = active_search.get_minimum_time(t, dt); + + /* Get indices of all particles that will be active in this bunch */ + int n_act; + active_search.get_active_indices(min_t, t, dt, ind_act, n_act); + + /* Find the BH(s) indices in the active list */ + smbh_list.clear(); +#ifdef ETICS + /* Unlike with the simple active search, with GPU accelerated GRAPite + active search, the list of active indices is not sorted. */ + int n_bh = config.live_smbh_count; + if (config.grapite_active_search && (n_bh>0)) { + int act_def_grapite_bh_count = 0; + for (int i=0; i= 2) { + if (config.live_smbh_custom_eps >= 0) black_hole_physics.adjust_softening(smbh_list); + #if 0 + if (config.binary_smbh_pn) black_hole_physics.adjust_post_newtonian(dt[i_bh1], a_act_new[i_bh1], a_act_new[i_bh2], adot_act_new[i_bh1], adot_act_new[i_bh2]); + #endif + } + + /* Calculate gravity on active particles due to external forces */ + if (calc_ext_grav.any_active) { + std::fill_n(begin(pot_act_ext), n_act, 0); + calc_ext_grav(n_act, x_act_new, v_act_new, pot_act_ext, a_act_new, adot_act_new); + } + + /* correct the active particles positions etc... on all the nodes */ + double min_dt = dt_max; // notice that min_dt is not the same as dt_min; this one is to store the minimum timestep among currently active particles + for (int i=0; i 0) && (ind_act[i] < config.live_smbh_count)) eta_curr = config.eta/config.eta_bh_corr; + else eta_curr = config.eta; + + double dt_new = aarseth_step(eta_curr, dt_cur, a_act_new[i], adot_act_new[i], a2, a3); + + dt_new = blockize_step(dt_new, dt_cur, min_t, dt_min, dt_max); + + if (config.dt_min_warning && (myRank == 0)) { + if (dt_new == dt_min) { + printf("!!! Warning1: dt_act = dt_min = %.6E \t ind_act = %07d time_cur=%.16E\n", dt_cur, ind_act[i], time_cur); + fflush(stdout); + } + } + if (dt_new < min_dt) min_dt = dt_new; + + x[j_act] = x_act_new[i]; + v[j_act] = v_act_new[i]; + t[j_act] = min_t; + dt[j_act] = dt_new; + pot[j_act] = pot_act_new[i]; + pot_ext[j_act] = pot_act_ext[i]; + a[j_act] = a_act_new[i]; + adot[j_act] = adot_act_new[i]; + } /* i */ + + /* define the min. dt over all the act. part. and set it also for the BH... */ + for (int i=0; i < config.live_smbh_count; i++) dt[i] = min_dt; + + if (config.binary_smbh_influence_sphere_output && (myRank == rootRank)) + binary_smbh_influence_sphere_output(ind_act, n_act, timesteps, time_cur); + + /* load the new values for active particles to the local GRAPE's */ + for (int i=0; i= t_bh) { + if (myRank == rootRank) { + /* Write BH data... */ + if (config.live_smbh_output) black_hole_physics.write_bh_data(time_cur, config.live_smbh_count, m, x, v, pot, a, adot, dt); + + /* Write BH NB data... */ + if (config.live_smbh_neighbor_output) write_bh_nb_data(time_cur); + + } /* if (myRank == rootRank) */ + + t_bh += config.dt_bh; + } /* if (time_cur >= t_bh) */ + + if (time_cur >= t_contr) { + if (myRank == rootRank) { + 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); + } /* if (myRank == rootRank) */ + +#ifdef ETICS + // We are /inside/ a control step, so all particles must be + // synchronized; we can safely calculate their density centre. The + // acceleration and jerk currently in the memory are for the + // predicted position of the CEP, by calling grapite_calc_center we + // "correct" the position and velocity, but not the gravity at that + // point. + if (grapite_cep_index >= 0) { + double3 xcm, vcm, xdc, vdc; + grapite_calc_center(N, m.data(), (double(*)[3])x.data(), (double(*)[3])v.data(), xcm, vcm, xdc, vdc); + x[grapite_cep_index] = xdc; + v[grapite_cep_index] = vdc; + grapite_update_cep(time_cur, xdc, vdc, a[grapite_cep_index], adot[grapite_cep_index]); + } +#endif + + t_contr += config.dt_contr; + } /* if (time_cur >= t_contr) */ + + if (time_cur >= t_disk) { + char out_fname[256]; + diskstep++; + if (myRank == rootRank) { + sprintf(out_fname, "%06d", diskstep); + if (config.output_hdf5) h5_write(std::string(out_fname) + ".h5", diskstep, N, time_cur, m, x, v, pot, a, adot, config.output_extra_mode, config.output_hdf5_double_precision); + else ascii_write(std::string(out_fname) + ".dat", diskstep, N, time_cur, m, x, v, config.output_ascii_precision); + } /* if (myRank == rootRank) */ + +#ifdef ETICS + if (config.etics_dump_coeffs) { + sprintf(out_fname, "coeffs.%06d.%02d.dat", diskstep, myRank); + grapite_dump(out_fname, 2); + } +#endif + t_disk += config.dt_disk; + } /* if (time_cur >= t_disk) */ + } /* while (time_cur < t_end) */ + + /* close the local GRAPEs */ + timer.stop(); + g6_close(clusterid); + + double g6_calls_sum; + MPI_Reduce(&calc_self_grav.g6_calls, &g6_calls_sum, 1, MPI_DOUBLE, MPI_SUM, rootRank, MPI_COMM_WORLD); + if (myRank == rootRank) { + /* Write some output for the timestep annalize... */ + printf("\n"); + printf("timesteps = %.0f Total sum of integrated part. = %.0f g6_calls on all nodes = %.0f \n", timesteps, n_act_sum, g6_calls_sum); + printf("\n"); + printf("Real Speed = %.3f GFlops \n", 57.0*N*n_act_sum/(timer.time)/1.0E+09); + fflush(stdout); + } /* if (myRank == rootRank) */ + + /* Finalize the MPI work */ + MPI_Finalize(); +} diff --git a/pn_bh.c b/pn_bh.c deleted file mode 100644 index 54822f3..0000000 --- a/pn_bh.c +++ /dev/null @@ -1,765 +0,0 @@ -/***************************************************************************/ -/* - Coded by : Peter Berczik (on the base of Gabor Kupi original PN code) - Version number : 2.0 SPIN - Last redaction : 2012.V.07. 11:16 -*/ - -int calc_force_pn_BH(double m1, double xx1[], double vv1[], double spin1[], - double m2, double xx2[], double vv2[], double spin2[], - double CCC_NB, double dt_bh, - int usedOrNot[], - double a_pn1[][3], double adot_pn1[][3], - double a_pn2[][3], double adot_pn2[][3]) -{ - -/* - INPUT - -m1 - mass of the 1 BH -xx1[0,1,2] - coordinate of the 1 BH -vv1[0,1,2] - velocity of the 1 BH -spin1[0,1,2] - normalized spin of the 1 BH - -m2 - mass of the 2 BH -xx2[0,1,2] - coordinate of the 2 BH -vv2[0,1,2] - velocity of the 2 BH -spin2[0,1,2] - normalized spin of the 2 BH - -CCC_NB - Speed of light "c" in internal units -dt_BH - timestep of the BH's, needed for the SPIN integration - -usedOrNot[PN0, PN1, PN2, PN2.5, PN3, PN3.5, SPIN] - different PN term usage: PN1, PN2, PN2.5, PN3, PN3.5, SPIN - 0 1 2 3 4 5 6 - - OUTPUT - -a_pn1 [0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 1 BH -adot_pn1[0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 1 BH - -a_pn2 [0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 2 BH -adot_pn2[0 - PN0; 1 - PN1; 2 - PN2; 3 - PN2.5, 4 - PN3, 5 - PN3.5, 6 - SPIN] [3] for the 2 BH - -return - 0 if everything OK - - 505 if BH's separation < 4 x (RSwarch1 + RSwarch2) -*/ - - - -int j, k; -double PI2 = 9.86960440108935; - -double c_1, c_2, c_4, c_5, c_6, c_7, RS_DIST; - -double M, eta, r, r2, r3, MOR; -double V1_V22,VWHOLE, RP, RPP, VA; -double N[3], x[3], v[3], A[3]; -double A1, B1, A2, B2, A2_5, B2_5, AK2, BK2, AK4, BK4, AK5, BK5; -double A1D, A2D, A2_5D, B1D, B2D, B2_5D, ADK2, BDK2, ADK4, BDK4, ADK5, BDK5; - -double A3, B3, A3_5, B3_5, AK6, BK6, AK7, BK7; -double A3D, A3_5D, B3D, B3_5D, ADK6, BDK6, ADK7, BDK7; - -int Van_Spin=0; -int Van_QM=0; - -double DM, S1[3], SPIN[3][2], S2[3], KSS[3], KSSIG[3], XS[3], XA[3], NCV[3], NCS[3], NCSIG[3], - VCS[3], VCSIG[3], SDNCV, SIGDNCV, NDV, XS2, XA2, NXA, NXS, VDS, VDSIG, NDS, NDSIG, - C1_5[3], C2[3], C2_5[3]; -double LABS, LU[3], S1DLU, S2DLU, SU1[3], SV1[3], SS1[3], SS2[3], SU2[3], SV2[3]; -double AT[3], NDOT[3], NVDOT, NDOTCV[3], NCA[3]; -double SS1aux[3],SS2aux[3],SU[3],SV[3],XAD[3],XSD[3]; -double NDOTCS[3], NCSU[3], NDOTCSIG[3], NCSV[3], ACS[3], VCSU[3], ACSIG[3], VCSV[3], SNVDOT, - SIGNVDOT, NSDOT, NSIGDOT, VSDOT, VSIGDOT, NXSDOT, NXADOT; -double C1_5D[3],C2D[3], C2_5D[3]; -double ADK, BDK, AD[3], KSAK, KSBK; -double nu, Spin1Abs2, Spin2Abs2, rS1, rS2, S1Dir[3], S2Dir[3], QM[3]; -double Spin1Abs, Spin2Abs, QMAux2_1[3], QMAux2_2[3], QMAux1[3] , QMD[3], SPINPrev[3][2], SpinPrev2_1, - SpinPrev2_2, SPSPP1, SPSPP2, Spin1AbsNew2, Spin2AbsNew2, Spin1AbsNew, Spin2AbsNew, S1DirNew[3], - S2DirNew[3], rS1p, rS2p, S1p[3], S2p[3], Np[3]; - - -Van_Spin = usedOrNot[6]; // Van vagy nincs SPIN szamolas... - - -for(k=0;k<3;k++) - { - SPIN[k][0] = spin1[k]; - SPIN[k][1] = spin2[k]; - } - - -for(j=0;j<7;j++) - { -for(k=0;k<3;k++) - { - a_pn1[j][k] = 0.0; adot_pn1[j][k] = 0.0; - a_pn2[j][k] = 0.0; adot_pn2[j][k] = 0.0; - } - } - - -// Speed of light "c" and its powers - -c_1 = CCC_NB; - -c_2 = SQR(c_1); -c_4 = SQR(c_2); -c_5 = c_4*c_1; -c_6 = c_5*c_1; -c_7 = c_6*c_1; - - -// Mass parameters - -M = m1+m2; -eta = m1*m2/(M*M); -nu = m1/m2; - -for(k=0;k<3;k++) - { - x[k] = xx1[k] - xx2[k]; - v[k] = vv1[k] - vv2[k]; - } - - -r2 = SQR(x[0]) + SQR(x[1]) + SQR(x[2]); -r = sqrt(r2); -r3 = r2*r; - -MOR = M/r; -V1_V22 = v[0]*v[0]+v[1]*v[1]+v[2]*v[2]; -VWHOLE = sqrt(V1_V22); -RP = (x[0]*v[0]+x[1]*v[1]+x[2]*v[2])/r; - - -// Newton accelerations - -for(k=0;k<3;k++) N[k] = x[k]/r; - -// PN accelerations - -AK2 = 0.0; BK2 = 0.0; -AK4 = 0.0; BK4 = 0.0; -AK5 = 0.0; BK5 = 0.0; -AK6 = 0.0; BK6 = 0.0; -AK7 = 0.0; BK7 = 0.0; - -for(k=0;k<3;k++) - { - C1_5[k] = 0.0; - C2[k] = 0.0; - C2_5[k] = 0.0; - QM[k] = 0.0; - } - - -if(usedOrNot[1] == 1) // PN1 ~1/c^2 - { - A1 = 2.0*(2.0+eta)*MOR-(1.0+3.0*eta)*V1_V22 +1.5*eta*RP*RP; - B1 = 2.0*(2.0-eta)*RP; - - AK2 = A1/c_2; - BK2 = B1/c_2; - } - -if(usedOrNot[2] == 1) // PN2 ~1/c^4 - { - A2 = -0.75*(12.0+29.0*eta)*MOR*MOR-eta*(3.0-4.0*eta)*V1_V22*V1_V22-1.875*eta*(1.0-3.0*eta)*RP*RP*RP*RP+0.5*eta*(13.0-4.0*eta)*MOR*V1_V22+(2.0+25.0*eta+2.0*eta*eta)*MOR*RP*RP+1.5*eta*(3.0-4.0*eta)*V1_V22*RP*RP; - B2 = -0.5*RP*((4.0+41.0*eta+8.0*eta*eta)*MOR-eta*(15.0+4.0*eta)*V1_V22+3.0*eta*(3.0+2.0*eta)*RP*RP); - - AK4 = A2/c_4; - BK4 = B2/c_4; - } - -if(usedOrNot[3] == 1) // PN2.5 ~1/c^5 - { - A2_5 = 1.6*eta*MOR*RP*(17.0*MOR/3.0+3.0*V1_V22); - B2_5 = -1.6*eta*MOR*(3.0*MOR+V1_V22); - - AK5 = A2_5/c_5; - BK5 = B2_5/c_5; - } - -if(usedOrNot[4] == 1) // PN3 ~1/c^6 - { - A3 = MOR*MOR*MOR*(16.0+(1399.0/12.0-41.0*PI2/16.0)*eta+ - 71.0*eta*eta/2.0)+eta*(20827.0/840.0+123.0*PI2/64.0-eta*eta) - *MOR*MOR*V1_V22-(1.0+(22717.0/168.0+615.0*PI2/64.0)*eta+ - 11.0*eta*eta/8.0-7.0*eta*eta*eta)*MOR*MOR*RP*RP- - 0.25*eta*(11.0-49.0*eta+52.0*eta*eta)*V1_V22*V1_V22*V1_V22+ - 35.0*eta*(1.0-5.0*eta+5.0*eta*eta)*RP*RP*RP*RP*RP*RP/16.0- - 0.25*eta*(75.0+32.0*eta-40.0*eta*eta)*MOR*V1_V22*V1_V22- - 0.5*eta*(158.0-69.0*eta-60.0*eta*eta)*MOR*RP*RP*RP*RP+ - eta*(121.0-16.0*eta-20.0*eta*eta)*MOR*V1_V22*RP*RP+ - 3.0*eta*(20.0-79.0*eta+60.0*eta*eta)*V1_V22*V1_V22*RP*RP/8.0- - 15.0*eta*(4.0-18.0*eta+17.0*eta*eta)*V1_V22*RP*RP*RP*RP/8.0; - - B3 = RP*((4.0+(5849.0/840.0+123.0*PI2/32.0)*eta-25.0*eta*eta- - 8.0*eta*eta*eta)*MOR*MOR+eta*(65.0-152.0*eta-48.0*eta*eta)* - V1_V22*V1_V22/8.0+15.0*eta*(3.0-8.0*eta-2.0*eta*eta)*RP*RP*RP*RP/8.0+ - eta*(15.0+27.0*eta+10.0*eta*eta)*MOR*V1_V22-eta*(329.0+177.0*eta+ - 108.0*eta*eta)*MOR*RP*RP/6.0- - 3.0*eta*(16.0-37.0*eta-16.0*eta*eta)*V1_V22*RP*RP/4.0); - - AK6 = A3/c_6; - BK6 = B3/c_6; - } - -if(usedOrNot[5] == 1) // PN3.5 ~1/c^7 - { - A3_5 = MOR*eta*(V1_V22*V1_V22*(-366.0/35.0-12.0*eta)+V1_V22*RP*RP*(114.0+12.0*eta)-112.0*RP*RP*RP*RP+MOR*(V1_V22*(-692.0/35.0+724.0*eta/15.0)+RP*RP*(-294.0/5.0-376.0*eta/5.0)+MOR*(-3956.0/35.0-184.0*eta/5.0))); - B3_5 = 8.0*eta*MOR*((1325.0+546.0*eta)*MOR*MOR/42.0+(313.0+42.0*eta)*V1_V22*V1_V22/28.0+75.0*RP*RP*RP*RP-(205.0+777.0*eta)*MOR*V1_V22/42.0+(205.0+424.0*eta)*MOR*RP*RP/12.0-3.0*(113.0+2.0*eta)*V1_V22*RP*RP/4.0)/5.0; - - AK7 = A3_5/c_7; - BK7 = B3_5/c_7; - } - - -// Spin accelerations - - if(Van_Spin==1) - { - DM = m1 - m2; - - Spin1Abs2 = 0.0; - Spin2Abs2 = 0.0; - rS1 = 0.0; - rS2 = 0.0; - - for(k=0;k<3;k++) - { - Spin1Abs2 += SPIN[k][0]*SPIN[k][0]; // normalizalt spin - Spin2Abs2 += SPIN[k][1]*SPIN[k][1]; - rS1 += N[k]*S1Dir[k]; - rS2 += N[k]*S2Dir[k]; - - S1[k] = SPIN[k][0]*m1*m1/c_1; // fizikai spin - S2[k] = SPIN[k][1]*m2*m2/c_1; - KSS[k] = S1[k]+S2[k]; - KSSIG[k] = M*(S2[k]/m2-S1[k]/m1); - XS[k] = 0.5*(SPIN[k][0]+SPIN[k][1]); - XA[k] = 0.5*(SPIN[k][0]-SPIN[k][1]); - } - - Spin1Abs = sqrt(Spin1Abs2); - Spin2Abs = sqrt(Spin2Abs2); - - for(k=0;k<3;k++) - { - S1Dir[k] = SPIN[k][0]/Spin1Abs; - S2Dir[k] = SPIN[k][1]/Spin2Abs; - } - - - //NCV crossproduct of N[k] and relative v = N[k]Xv[j] - NCV[0] = N[1]*v[2] - N[2]*v[1]; - NCV[1] = N[2]*v[0] - N[0]*v[2]; - NCV[2] = N[0]*v[1] - N[1]*v[0]; - - //NCS crossproduct of N[k] and KSS = N[k]XKSS - NCS[0] = N[1]*KSS[2] - N[2]*KSS[1]; - NCS[1] = N[2]*KSS[0] - N[0]*KSS[2]; - NCS[2] = N[0]*KSS[1] - N[1]*KSS[0]; - - //NCSIG crossproduct of N[k] and KSSIG = N[k]XKSSIG - NCSIG[0] = N[1]*KSSIG[2] - N[2]*KSSIG[1]; - NCSIG[1] = N[2]*KSSIG[0] - N[0]*KSSIG[2]; - NCSIG[2] = N[0]*KSSIG[1] - N[1]*KSSIG[0]; - - //VCS crossproduct of v[k] and KSS = v[k]XKSS - VCS[0] = v[1]*KSS[2] - v[2]*KSS[1]; - VCS[1] = v[2]*KSS[0] - v[0]*KSS[2]; - VCS[2] = v[0]*KSS[1] - v[1]*KSS[0]; - - //VCSIG crossproduct of v[k] and KSSIG = v[k]XKSSIG - VCSIG[0] = v[1]*KSSIG[2] - v[2]*KSSIG[1]; - VCSIG[1] = v[2]*KSSIG[0] - v[0]*KSSIG[2]; - VCSIG[2] = v[0]*KSSIG[1] - v[1]*KSSIG[0]; - - SDNCV = KSS[0]*NCV[0]+KSS[1]*NCV[1]+KSS[2]*NCV[2]; - - SIGDNCV = KSSIG[0]*NCV[0]+KSSIG[1]*NCV[1]+KSSIG[2]*NCV[2]; - - NDV = N[0]*v[0] + N[1]*v[1] + N[2]*v[2]; - - XS2 = XS[0]*XS[0]+XS[1]*XS[1]+XS[2]*XS[2]; - XA2 = XA[0]*XA[0]+XA[1]*XA[1]+XA[2]*XA[2]; - - NXA = N[0]*XA[0]+N[1]*XA[1]+N[2]*XA[2]; - NXS = N[0]*XS[0]+N[1]*XS[1]+N[2]*XS[2]; - - VDS = v[0]*KSS[0]+v[1]*KSS[1]+v[2]*KSS[2]; - VDSIG = v[0]*KSSIG[0]+v[1]*KSSIG[1]+v[2]*KSSIG[2]; - - NDS = N[0]*KSS[0]+N[1]*KSS[1]+N[2]*KSS[2]; - NDSIG = N[0]*KSSIG[0]+N[1]*KSSIG[1]+N[2]*KSSIG[2]; - - for(k=0;k<3;k++) - { - C1_5[k] = (N[k]*(12.0*SDNCV+6.0*DM*SIGDNCV/M)+9.0*NDV*NCS[k]+3.0*DM*NDV*NCSIG[k]/M -7.0*VCS[k]-3.0*DM*VCSIG[k]/M)/r3; - C2[k] = -MOR*MOR*MOR/r*3.0*eta*(N[k]*(XS2-XA2-5.0*NXS*NXS+5.0*NXA*NXA)+2.0*(XS[k]*NXS-XA[k]*NXA)); - C2_5[k] = (N[k]*(SDNCV*(-30.0*eta*NDV*NDV+24.0*eta*V1_V22-MOR*(38.0+25.0*eta))+DM/M*SIGDNCV*(-15.0*eta*NDV*NDV+12.0*eta*V1_V22 - -MOR*(18.0+14.5*eta)))+NDV*v[k]*(SDNCV*(-9.0+9.0*eta)+DM/M* SIGDNCV*(-3.0+6.0*eta))+NCV[k]*(NDV*VDS*(-3.0+3.0*eta) - -8.0*MOR*eta*NDS-DM/M*(4.0*MOR*eta*NDSIG+3.0*NDV*VDSIG))+NDV*NCS[k]*(-22.5*eta*NDV*NDV+21.0*eta*V1_V22-MOR*(25.0+15.0*eta)) - +DM/M*NDV*NCSIG[k]*(-15.0*eta*NDV*NDV+12.0*eta*V1_V22-MOR*(9.0+8.5*eta))+VCS[k]*(16.5*eta*NDV*NDV+MOR*(21.0+9.0*eta) - -14.0*eta*V1_V22)+DM/M*VCSIG[k]*(9.0*eta*NDV*NDV-7.0*eta*V1_V22+MOR*(9.0+4.5*eta)))/r3; - - if(Van_QM==1) - { - - if(m1>m2) - { - QMAux2_1[k] = (1.0-5.0*rS1*rS1)*N[k]+2.0*rS1*S1Dir[k]; - QMAux2_2[k] = (1.0-5.0*rS2*rS2)*N[k]+2.0*rS2*S2Dir[k]; - QMAux1[k] = Spin1Abs2*QMAux2_1[k]/nu+Spin2Abs2*QMAux2_2[k]*nu; - QM[k] = -1.5*MOR*MOR*MOR*eta*QMAux1[k]/r; - } - else - { - QMAux2_1[k] = (1.0-5.0*rS2*rS2)*N[k]+2.0*rS2*S2Dir[k]; - QMAux2_2[k] = (1.0-5.0*rS1*rS1)*N[k]+2.0*rS1*S1Dir[k]; - QMAux1[k] = Spin2Abs2*QMAux2_1[k]/nu+Spin1Abs2*QMAux2_2[k]*nu; - QM[k] = -1.5*MOR*MOR*MOR*eta*QMAux1[k]/r; - } - - } /* if(Van_QM==1) */ - - } /* k */ - - } /* if(Van_Spin==1) */ - - - - - -for(k=0;k<3;k++) - { - -if(usedOrNot[0] == 1) // PN0 (Newton) ~1/c^0 - { - a_pn1[0][k] = -m2*x[k]/r3; - a_pn2[0][k] = m1*x[k]/r3; - } - -if(usedOrNot[1] == 1) // PN1 ~1/c^2 - { - a_pn1[1][k] = ((AK2*N[k] + BK2*v[k])/r2)*m2; - a_pn2[1][k] = -((AK2*N[k] + BK2*v[k])/r2)*m1; - } - -if(usedOrNot[2] == 1) // PN2 ~1/c^4 - { - a_pn1[2][k] = ((AK4*N[k] + BK4*v[k])/r2)*m2; - a_pn2[2][k] = -((AK4*N[k] + BK4*v[k])/r2)*m1; - } - -if(usedOrNot[3] == 1) // PN2.5 ~1/c^5 - { - a_pn1[3][k] = ((AK5*N[k] + BK5*v[k])/r2)*m2; - a_pn2[3][k] = -((AK5*N[k] + BK5*v[k])/r2)*m1; - } - -if(usedOrNot[4] == 1) // PN3 ~1/c^6 - { - a_pn1[4][k] = ((AK6*N[k] + BK6*v[k])/r2)*m2; - a_pn2[4][k] = -((AK6*N[k] + BK6*v[k])/r2)*m1; - } - -if(usedOrNot[5] == 1) // PN3.5 ~1/c^7 - { - a_pn1[5][k] = ((AK7*N[k] + BK7*v[k])/r2)*m2; - a_pn2[5][k] = -((AK7*N[k] + BK7*v[k])/r2)*m1; - } - -if(Van_Spin == 1) // All the SPIN terms - { - a_pn1[6][k] += (C1_5[k]/c_2 + C2[k]/c_4 + C2_5[k]/c_4 + QM[k]/c_4)*m2/M; - a_pn2[6][k] += -(C1_5[k]/c_2 + C2[k]/c_4 + C2_5[k]/c_4 + QM[k]/c_4)*m1/M; - } - - A[k] = MOR*((AK2+AK4+AK5+AK6+AK7)*N[k] + (BK2+BK4+BK5+BK6+BK7)*v[k])/r + C1_5[k]/c_2 + C2[k]/c_4 + C2_5[k]/c_4 + QM[k]/c_4; - } - -// PN accelerations - - - - -// PN jerks - -for(k=0;k<3;k++) - { - AT[k] = A[k] - MOR*N[k]/r; // miert van AT - ? - } - -/* -AT[0] = A[0]; -AT[1] = A[1]; -AT[2] = A[2]; -*/ - -RPP = V1_V22/r + AT[0]*N[0]+AT[1]*N[1] + AT[2]*N[2] - RP*RP/r; -VA = AT[0]*v[0] + AT[1]*v[1] + AT[2]*v[2]; - -for(k=0;k<3;k++) NDOT[k] = (v[k]-N[k]*RP)/r; - -NVDOT = NDOT[0]*v[0]+NDOT[1]*v[1]+NDOT[2]*v[2]+N[0]*AT[0]+N[1]*AT[1]+N[2]*AT[2]; - -//NDOTCV crossproduct of NDOT[k] and relative v = NDOT[k]Xv[j] -NDOTCV[0] = NDOT[1]*v[2] - NDOT[2]*v[1]; -NDOTCV[1] = NDOT[2]*v[0] - NDOT[0]*v[2]; -NDOTCV[2] = NDOT[0]*v[1] - NDOT[1]*v[0]; - -//NCA crossproduct of N and AT = N[k]XAT[j] -NCA[0] = N[1]*AT[2] - N[2]*AT[1]; -NCA[1] = N[2]*AT[0] - N[0]*AT[2]; -NCA[2] = N[0]*AT[1] - N[1]*AT[0]; - -ADK2 = 0.0; BDK2 = 0.0; -ADK4 = 0.0; BDK4 = 0.0; -ADK5 = 0.0; BDK5 = 0.0; -ADK6 = 0.0; BDK6 = 0.0; -ADK7 = 0.0; BDK7 = 0.0; - - -for(k=0;k<3;k++) - { - C1_5D[k] = 0.0; - C2D[k] = 0.0; - C2_5D[k] = 0.0; - QMD[k] = 0.0; - } - -if(usedOrNot[1] == 1) // PN1 ~1/c^2 - { - A1D = -2.0*(2.0+eta)*MOR*RP/r - 2.0*(1.0+3.0*eta)*VA + 3.0*eta*RP*RPP; - B1D = 2.0*(2.0-eta)*RPP; - - ADK2 = A1D/c_2; - BDK2 = B1D/c_2; - } - -if(usedOrNot[2] == 1) // PN2 ~1/c^4 - { - A2D = 1.5*(12.0+29.0*eta)*MOR*MOR*RP/r -eta*(3.0-4.0*eta)*4.0*V1_V22*VA - 7.5*eta*(1.0-3.0*eta)*RPP -0.5*eta*(13.0-4.0*eta)*MOR*RP*V1_V22/r+eta*(13.0-4.0*eta)*MOR*VA -(2.0+25.0*eta+2.0*eta*eta)*MOR*RP*RP*RP/r+2.0*(2.0+25.0*eta+2.0*eta*eta)*MOR*RP*RPP + 3.0*eta*(3.0-4.0*eta)*VA*RP*RP + 3.0*eta*(3.0-4.0*eta)*V1_V22*RP*RPP; - B2D = -0.5*RPP*((4.0+41.0*eta+8.0*eta*eta)*MOR - eta*(15.0+4.0*eta)*V1_V22+3.0*eta*(3.0+2.0*eta)*RP*RP) - 0.5*RP*(-(4.0+41.0*eta+8.0*eta*eta)*MOR*RP/r - 2.0*eta*(15.0+4.0*eta)*VA + 6.0*eta*(3.0+2.0*eta)*RP*RPP); - - ADK4 = A2D/c_4; - BDK4 = B2D/c_4; - } - -if(usedOrNot[3] == 1) // PN2.5 ~1/c^5 - { - A2_5D = -1.6*eta*MOR*RP*RP*(17.0/3.0*MOR+3.0*V1_V22)/r +1.6*eta*MOR*RPP*(17.0/3.0*MOR+3.0*V1_V22)+1.6*eta*MOR*RP*(-17.0*MOR*RP/3.0/r+6.0*VA); - B2_5D = 1.6*eta*MOR*RP*(3.0*MOR+V1_V22)/r - 1.6*eta*MOR*(-3.0*MOR*RP/r+2.0*VA); - - ADK5 = A2_5D/c_5; - BDK5 = B2_5D/c_5; - } - -if(usedOrNot[4] == 1) // PN3 ~1/c^6 - { - A3D = 6.0*eta*RP*RP*RP*RP*RP*RPP*(35.0-175.0*eta+175.0*eta*eta)/16.0 + eta*(4.0*RP*RP*RP*RPP*V1_V22 + 2.0*RP*RP*RP*RP*VA)*(-15.0+135.0*eta/2.0-255.0*eta*eta/4.0)/2.0 + eta*(2.0*RP*RPP*V1_V22*V1_V22+4.0*RP*RP*V1_V22*VA)/2.0*(15.0-237.0*eta/2.0+45.0*eta*eta) + 6.0*V1_V22*V1_V22*VA*eta*(-11.0/4.0-49.0*eta/4.0-13.0*eta*eta) + MOR*(4.0*RP*RP*RP*RPP*eta*(-79.0+69.0/2.0*eta+30.0*eta*eta) + eta*(2.0*RP*RPP*V1_V22+2.0*RP*RP*VA)*(121.0-16.0*eta-20.0*eta*eta)+4.0*V1_V22*VA*eta*(-75.0/4.0-8.0*eta+10.0*eta*eta)) - MOR*RP*((-79.0+69.0*eta/2.0+30.0*eta*eta)*RP*RP*RP*RP*eta+eta*RP*RP*V1_V22*(121.0-16.0*eta-20.0*eta*eta)+eta*V1_V22*V1_V22*(-75.0/4.0-8.0*eta+10.0*eta*eta))/r - 2.0*MOR*MOR*RP*(RP*RP*((-1.0-615.0*PI2*eta/64.0)-22717.0*eta/168.0-11.0*eta*eta/8.0+7.0*eta*eta*eta)+eta*V1_V22*((20827.0/840.0+123.0*PI2/64.0)-eta*eta))/r + MOR*MOR*(2.0*RP*RPP*((-1.0-615*PI2*eta/64.0)-22717.0*eta/168.0-11.0*eta*eta/8.0+7*eta*eta*eta)+2.0*eta*VA*((20827.0/840.0 +123.0*PI2/64.0)-eta*eta)) - 3.0*MOR*MOR*MOR*RP*(16.0+(1399.0/12.0-41.0*PI2/16.0)*eta+71.0*eta*eta/2.0)/r; - B3D = 75.0*RP*RP*RP*RP*RPP*eta*(3.0/8.0-eta-.25*eta*eta)+eta*(3.0*RP*RP*RPP*V1_V22+2.0*RP*RP*RP*VA)*(-12.0+111.0*eta/4.0+12.0*eta*eta)+eta*(RPP*V1_V22*V1_V22+4.0*RP*V1_V22*VA)*(65.0/8.0-19.0*eta-6.0*eta*eta)-MOR*RP*(RP*RP*RP*eta*(-329.0/6.0-59.0*eta/2.0-18.0*eta*eta)+RP*V1_V22*eta*(15.0+27.0*eta+10.0*eta*eta))/r+MOR*(3.0*RP*RP*RPP*eta*(-329.0/6.0-59.0*eta/2.0-18.0*eta*eta)+eta*(RPP*V1_V22+2.0*RP*VA)*(15.0+27.0*eta+10.0*eta*eta))-2.0*MOR*MOR*RP*(RP*((4.0+123.0*PI2*eta/32.0)+5849.0*eta/840.0-25.0*eta*eta-8.0*eta*eta*eta))/r+MOR*MOR*(RPP*((4.0+123.0*PI2*eta/32.0)+5849.0/840.0*eta-25.0*eta*eta-8.0*eta*eta*eta)); - - ADK6 = A3D/c_6; - BDK6 = B3D/c_6; - } - -if(usedOrNot[5] == 1) // PN3.5 ~1/c^7 - { - A3_5D = MOR*eta*(-RP*(V1_V22*V1_V22*(-366.0/35.0-12.0*eta)+V1_V22*RP*RP*(114.0+12.0*eta)+RP*RP*RP*RP*(-112.0))/r+4.0*V1_V22*VA*(-366.0/35.0-12.0*eta)+2.0*(VA*RP*RP+RP*RPP*V1_V22)*(114.0+12.0*eta)+4.0*RP*RP*RP*RPP*(-112.0)+MOR*(2.0*VA*(-692.0/35.0+724.0*eta/15.0)+2.0*RP*RPP*(-294.0/5.0-376.0*eta/5.0)-2.0*RP*(V1_V22*(-692.0/35.0+724.0*eta/15.0)+RP*RP*(-294.0/5.0-376.0*eta/5.0))/r-3.0*MOR*RP*(-3956.0/35.0-184.0*eta/5.0)/r)); - B3_5D = MOR*eta*(4.0*V1_V22*VA*(626.0/35.0+12.0*eta/5.0)+2.0*(VA*RP*RP+V1_V22*RP*RPP)*(-678.0/5.0-12.0*eta/5.0)+4.0*RP*RP*RP*RPP*120.0-RP*(V1_V22*V1_V22*(626.0/35.0+12.0*eta/5.0)+V1_V22*RP*RP*(-678.0/5.0-12.0*eta/5.0)+120.0*RP*RP*RP*RP)/r+MOR*(2.0*VA*(-164.0/21.0-148.0*eta/5.0)+2*RP*RPP*(82.0/3.0+848.0*eta/15.0)-2.0*RP*(V1_V22*(-164.0/21-148.0*eta/5.0)+RP*RP*(82.0/3.0+848.0*eta/15.0))/r-3.0*MOR*RP*(1060.0/21.0+104.0*eta/5.0)/r)); - - ADK7 = A3_5D/c_7; - BDK7 = B3_5D/c_7; - } - - - - - - if(Van_Spin==1) - { - - //L crossproduct of x[k] and relative v = x[k]Xv[j] - L[0] = x[1]*v[2] - x[2]*v[1]; - L[1] = x[2]*v[0] - x[0]*v[2]; - L[2] = x[0]*v[1] - x[1]*v[0]; - - LABS = sqrt(L[0]*L[0]+L[1]*L[1]+L[2]*L[2]); - - LU[0] = L[0]/LABS; - LU[1] = L[1]/LABS; - LU[2] = L[2]/LABS; - - S1DLU = S1[0]*LU[0]+S1[1]*LU[1]+S1[2]*LU[2]; - S2DLU = S2[0]*LU[0]+S2[1]*LU[1]+S2[2]*LU[2]; - - for(k=0;k<3;k++) - { - SU1[k] = MOR*eta*(N[k]*(-4.0*VDS-2.0*DM/M*VDSIG)+ v[k]*(3.0*NDS+DM/M*NDSIG)+NDV*(2.0*KSS[k]+DM/M*KSSIG[k])) /r; - SV1[k] = MOR*(N[k]*(VDSIG*(-2.0+4.0*eta)-2.0*DM/M*VDS)+ v[k]*(NDSIG*(1.0-eta)+DM/M*NDS)+NDV*(KSSIG[k]*(1.0- 2.0*eta)+ DM/M*KSS[k]))/r; - - SS1[k] = 0.5*(L[k]*(4.0+3.0*(m2/m1))+ (S2[k]-3.0*S2DLU*LU[k]))/r3; - SS2[k] = 0.5*(L[k]*(4.0+3.0*(m1/m2))+ (S1[k]-3.0*S1DLU*LU[k]))/r3; - - SU2[k] = MOR*eta/r*(N[k]*(VDS*(-2.0*V1_V22+3.0*NDV*NDV- 6.0*eta*NDV*NDV+7.0*MOR-8.0*eta*MOR)-14.0*MOR*NDS*NDV+ DM/M*VDSIG*eta*(-3.0*NDV*NDV-4.0*MOR)+DM/M*MOR*NDSIG*NDV* (2.0-eta/2.))+v[k]*(NDS*(2.0*V1_V22-4.0*eta*V1_V22-3.0*NDV* NDV+7.5*eta*NDV*NDV+4.0*MOR-6.0*eta*MOR)+VDS*NDV*(2.0- 6.0*eta)+ DM/M*NDSIG*(-1.5*eta*V1_V22+3.0*eta*NDV*NDV-MOR-3.5*eta* MOR)-3.0*DM/M*VDSIG*NDV*eta)+KSS[k]*NDV*(V1_V22-2.0*eta* V1_V22-1.5*NDV*NDV+3.0*eta*NDV*NDV-MOR+2.0*eta*MOR)+ DM/M*KSSIG[k]*NDV*(-eta*V1_V22+1.5*eta*NDV*NDV+ (eta-1.)*MOR)); - SV2[k] = MOR/r*(N[k]*(VDSIG*eta*(-2.0*V1_V22+6.0*eta*NDV* NDV+(3.0+8.0*eta)*MOR)+MOR*NDSIG*NDV*(2.0-22.5*eta+2.0* eta*eta)+ DM/M*VDS*eta*(-3.0*NDV*NDV-4.0*MOR)+DM/M*MOR*NDS*NDV*(2.0- 0.5*eta))+v[k]*(NDSIG*(0.5*eta*V1_V22+2.0*eta*eta*V1_V22- 4.5*eta*eta*NDV*NDV+(4.5*eta-1.0+8.0*eta*eta)*MOR)+VDSIG*NDV* eta*(6.0*eta-1.)-3.0*DM/M*VDS*NDV*eta+DM/M*NDS*(-1.5* eta*V1_V22+ 3.0*eta*NDV*NDV-(1.0+3.5*eta)*MOR))+KSSIG[k]*NDV*(2.0*eta*eta* V1_V22-3.0*eta*eta*NDV*NDV+(-1.0+4.0*eta-2.0*eta*eta)*MOR)+ DM/M*KSS[k]*NDV*(-eta*V1_V22+1.5*eta*NDV*NDV+(-1.0+eta)* MOR)); - } - - //SS1 crossproduct of SS1 and S1 = SS1[k]XS1[j] - SS1aux[0] = SS1[1]*S1[2] - SS1[2]*S1[1]; - SS1aux[1] = SS1[2]*S1[0] - SS1[0]*S1[2]; - SS1aux[2] = SS1[0]*S1[1] - SS1[1]*S1[0]; - - SS1[0] = SS1aux[0]; - SS1[1] = SS1aux[1]; - SS1[2] = SS1aux[2]; - - //SS2 crossproduct of SS2 and S2 = SS2[k]XS2[j] - SS2aux[0] = SS2[1]*S2[2] - SS2[2]*S2[1]; - SS2aux[1] = SS2[2]*S2[0] - SS2[0]*S2[2]; - SS2aux[2] = SS2[0]*S2[1] - SS2[1]*S2[0]; - - SS2[0] = SS2aux[0]; - SS2[1] = SS2aux[1]; - SS2[2] = SS2aux[2]; - - SPINPrev[0][0] = SPIN[0][0]; - SPINPrev[1][0] = SPIN[1][0]; - SPINPrev[2][0] = SPIN[2][0]; - - SPINPrev[0][1] = SPIN[0][1]; - SPINPrev[1][1] = SPIN[1][1]; - SPINPrev[2][1] = SPIN[2][1]; - - SpinPrev2_1 = SPINPrev[0][0]*SPINPrev[0][0] + SPINPrev[1][0]*SPINPrev[1][0] + SPINPrev[2][0]*SPINPrev[2][0]; - SpinPrev2_2 = SPINPrev[0][1]*SPINPrev[0][1] + SPINPrev[1][1]*SPINPrev[1][1] + SPINPrev[2][1]*SPINPrev[2][1]; - - SPSPP1 = 0.0; - SPSPP2 = 0.0; - - Spin1AbsNew2 = 0.0; - Spin2AbsNew2 = 0.0; - - for(k=0;k<3;k++) - { - SU[k] = SU1[k]/c_2 + SU2[k]/c_4 + (SS1[k] + SS2[k])/c_2; - SV[k] = SV1[k]/c_2 + SV2[k]/c_4+M*(SS2[k]/m2-SS1[k]/ m1)/c_2; - - KSS[k] = KSS[k] + SU[k]*dt_bh; // integrate for dt_bh timestep - KSSIG[k] = KSSIG[k] + SV[k]*dt_bh; - - SPIN[k][0] = m1*(M*KSS[k]-m2*KSSIG[k])/M/M/m1/m1*c_1; - SPIN[k][1] = m2*(M*KSS[k]+m1*KSSIG[k])/M/M/m2/m2*c_1; - Spin1AbsNew2 += SPIN[k][0]*SPIN[k][0]; - Spin2AbsNew2 += SPIN[k][1]*SPIN[k][1]; - XAD[k] = 0.5/(M*M*m1*m2)*(-SU[k]*M*DM-SV[k]*(m1*m1+m2*m2)); - XSD[k] = 0.5/(M*M*m1*m2)*(SU[k]*M*M+SV[k]*(m1*m1-m2*m2)); - - if(m1>m2) - { - SPSPP1 += SPINPrev[k][0]*(SPIN[k][0]-SPINPrev[k][0])/dt_bh; - SPSPP2 += SPINPrev[k][1]*(SPIN[k][1]-SPINPrev[k][1])/dt_bh; - } - else - { - SPSPP1 += SPINPrev[k][1]*(SPIN[k][1]-SPINPrev[k][1])/dt_bh; - SPSPP2 += SPINPrev[k][0]*(SPIN[k][0]-SPINPrev[k][0])/dt_bh; - } - } - - Spin1AbsNew = sqrt(Spin1AbsNew2); - Spin2AbsNew = sqrt(Spin2AbsNew2); - - for(k=0;k<3;k++) - { - S1DirNew[k] = SPIN[k][0]/Spin1AbsNew; - S2DirNew[k] = SPIN[k][1]/Spin2AbsNew; - } - - - //NDOTCS crossproduct of NDOT and KSS = NDOT[k]XKSS[j] - NDOTCS[0] = NDOT[1]*KSS[2] - NDOT[2]*KSS[1]; - NDOTCS[1] = NDOT[2]*KSS[0] - NDOT[0]*KSS[2]; - NDOTCS[2] = NDOT[0]*KSS[1] - NDOT[1]*KSS[0]; - //NCSU crossproduct of N and SU = N[k]XSU[j] - NCSU[0] = N[1]*SU[2] - N[2]*SU[1]; - NCSU[1] = N[2]*SU[0] - N[0]*SU[2]; - NCSU[2] = N[0]*SU[1] - N[1]*SU[0]; - //NDOTCSIG crossproduct of NDOT and KSSIG = NDOT[k]XKSSIG[j] - NDOTCSIG[0] = NDOT[1]*KSSIG[2] - NDOT[2]*KSSIG[1]; - NDOTCSIG[1] = NDOT[2]*KSSIG[0] - NDOT[0]*KSSIG[2]; - NDOTCSIG[2] = NDOT[0]*KSSIG[1] - NDOT[1]*KSSIG[0]; - //NCSV crossproduct of N and SV = N[k]XSV[j] - NCSV[0] = N[1]*SV[2] - N[2]*SV[1]; - NCSV[1] = N[2]*SV[0] - N[0]*SV[2]; - NCSV[2] = N[0]*SV[1] - N[1]*SV[0]; - //ACS crossproduct of AT and KSS = AT[k]XKSS[j] - ACS[0] = AT[1]*KSS[2] - AT[2]*KSS[1]; - ACS[1] = AT[2]*KSS[0] - AT[0]*KSS[2]; - ACS[2] = AT[0]*KSS[1] - AT[1]*KSS[0]; - //VCSU crossproduct of relative v and SU = v[k]XSU[j] - VCSU[0] = v[1]*SU[2] - v[2]*SU[1]; - VCSU[1] = v[2]*SU[0] - v[0]*SU[2]; - VCSU[2] = v[0]*SU[1] - v[1]*SU[0]; - //ACSIG crossproduct of AT and KSSIG = AT[k]XKSSIG[j] - ACSIG[0] = AT[1]*KSSIG[2] - AT[2]*KSSIG[1]; - ACSIG[1] = AT[2]*KSSIG[0] - AT[0]*KSSIG[2]; - ACSIG[2] = AT[0]*KSSIG[1] - AT[1]*KSSIG[0]; - //VCSV crossproduct of relative v and SV = v[k]XSV[j] - VCSV[0] = v[1]*SV[2] - v[2]*SV[1]; - VCSV[1] = v[2]*SV[0] - v[0]*SV[2]; - VCSV[2] = v[0]*SV[1] - v[1]*SV[0]; - - SNVDOT = SU[0]*NCV[0]+SU[1]*NCV[1]+SU[2]*NCV[2]+ KSS[0]*NDOTCV[0]+KSS[1]*NDOTCV[1]+KSS[2]*NDOTCV[2]+ KSS[0]*NCA[0]+KSS[1]*NCA[1]+KSS[2]*NCA[2]; - - SIGNVDOT = SV[0]*NCV[0]+SV[1]*NCV[1]+SV[2]*NCV[2]+ KSSIG[0]*NDOTCV[0]+KSSIG[1]*NDOTCV[1]+KSSIG[2]*NDOTCV[2]+ KSSIG[0]*NCA[0]+KSSIG[1]*NCA[1]+KSSIG[2]*NCA[2]; - - NSDOT = NDOT[0]*KSS[0]+NDOT[1]*KSS[1]+NDOT[2]*KSS[2]+ N[0]*SU[0]+N[1]*SU[1]+N[2]*SU[2]; - NSIGDOT = NDOT[0]*KSSIG[0]+NDOT[1]*KSSIG[1]+NDOT[2]*KSSIG[2]+ N[0]*SV[0]+N[1]*SV[1]+N[2]*SV[2]; - VSDOT = AT[0]*KSS[0]+AT[1]*KSS[1]+AT[2]*KSS[2]+ v[0]*SU[0]+v[1]*SU[1]+v[2]*SU[2]; - VSIGDOT = AT[0]*KSSIG[0]+AT[1]*KSSIG[1]+AT[2]*KSSIG[2]+ v[0]*SV[0]+v[1]*SV[1]+v[2]*SV[2]; - - NXSDOT = NDOT[0]*XS[0]+NDOT[1]*XS[1]+NDOT[2]*XS[2]+ N[0]*XSD[0]+N[1]*XSD[1]+N[2]*XSD[2]; - NXADOT = NDOT[0]*XA[0]+NDOT[1]*XA[1]+NDOT[2]*XA[2]+ N[0]*XAD[0]+N[1]*XAD[1]+N[2]*XAD[2]; - - rS1p = -rS1*NDV/r; - rS2p = -rS2*NDV/r; - - for(k=0;k<3;k++) - { - S1p[k] = (S1DirNew[k] - S1Dir[k])/dt_bh; - S2p[k] = (S2DirNew[k] - S2Dir[k])/dt_bh; - - rS1p += v[k]*S1Dir[k]/r + N[k]*S1p[k]; - rS2p += v[k]*S2Dir[k]/r + N[k]*S2p[k]; - - Np[k] = (v[k] - N[k]*NDV)/r; - } - - for(k=0;k<3;k++) - { - C1_5D[k] = -3.0*RP/r*C1_5[k]+(NDOT[k]*(12.0*SDNCV+6.0*DM/M* SIGDNCV)+N[k]*(12.0*SNVDOT+6.0*DM/M*SIGNVDOT)+9.0*NVDOT* NCS[k]+9.0*NDV*(NDOTCS[k]+NCSU[k])+3.0*DM/M*(NVDOT*NCSIG[k]+ NDV*(NDOTCSIG[k]+NCSV[k]))-7.0*(ACS[k]+VCSU[k])-3.0*DM/M* (ACSIG[k]+VCSV[k]))/(r3); - C2D[k] = -4.0*RP/r*C2[k]-MOR*MOR*MOR*3.0*eta/r*(NDOT[k]* (XS2-XA2-5.0*NXS*NXS+5.0*NXA*NXA)+N[k]*(2.0*(XS[0]*XSD[0]+ XS[1]*XSD[1]+XS[2]*XSD[2]-XA[0]*XAD[0]-XA[1]*XAD[1]- XA[2]*XAD[2])-10.0*NXS*NXSDOT+10.0*NXA*NXADOT)+2.0*(XSD[k]* NXS+XS[k]*NXSDOT-XAD[k]*NXA-XA[k]*NXADOT)); - C2_5D[k] = -3.0*RP/r*C2_5[k]+(NDOT[k]*(SDNCV*(-30.0*eta* NDV*NDV+24.0*eta*V1_V22-MOR*(38.0+25.0*eta))+DM/M*SIGDNCV* (-15.0*eta*NDV*NDV+12.0*eta*V1_V22-MOR*(18.0+14.5*eta)))+ N[k]*(SNVDOT*(-30.0*eta*NDV*NDV+24.0*eta*V1_V22-MOR* (38.0+25.0*eta))+SDNCV*(-60.0*eta*NDV*NVDOT+48.0*eta*VA+ MOR*RP/r*(38.0+25.0*eta))+DM/M*SIGNVDOT*(-15.0*eta*NDV* NDV+12.0*eta*V1_V22-MOR*(18.0+14.5*eta))+DM/M*SIGDNCV* (-30.0*eta*NDV*NVDOT+24.0*eta*VA+MOR*RP/r*(18.0+14.5*eta)))+ (NVDOT*v[k]+NDV*AT[k])*(SDNCV*(-9.0+9.0*eta)+DM/M*SIGDNCV* (-3.0+6.0*eta))+NDV*v[k]*(SNVDOT*(-9.0+9.0*eta)+DM/M* SIGNVDOT*(-3.0+6.0*eta))+(NDOTCV[k]+NCA[k])*(NDV*VDS*(-3.0+ 3.0*eta)-8.0*MOR*eta*NDS-DM/M*(4.0*MOR*eta*NDSIG+3.0*NDV*VDSIG) )+NCV[k]*((NVDOT*VDS+NDV*VSDOT)*(-3.0+3.0*eta)-8.0*eta*MOR* (NSDOT-RP/r*NDS)-DM/M*(4.0*eta*MOR*(NSIGDOT-RP/r*NDSIG)+ 3.0*(NVDOT*VDSIG+NDV*VSIGDOT)))+(NVDOT*NCS[k]+NDV* (NDOTCS[k]+NCSU[k]))*(-22.5*eta*NDV*NDV+21.0*eta*V1_V22- MOR*(25.0+15.0*eta))+NDV*NCS[k]*(-45.0*eta*NDV*NVDOT+42.0*eta* VA+MOR*RP/r*(25.0+15.0*eta))+DM/M*(NVDOT*NCSIG[k]+NDV* (NDOTCSIG[k]+NCSV[k]))*(-15.0*eta*NDV*NDV+12.0*eta*V1_V22- MOR*(9.0+8.5*eta))+DM/M*NDV*NCSIG[k]*(-30.0*eta*NDV*NVDOT+ 24.0*eta*VA+MOR*RP/r*(9.0+8.5*eta))+(ACS[k]+VCSU[k])* (16.5*eta*NDV*NDV+MOR*(21.0+9.0*eta)-14.0*eta*V1_V22)+ VCS[k]*(33.0*eta*NDV*NVDOT-MOR*RP/r*(21.0+9.0*eta)- 28.0*eta*VA)+DM/M*(ACSIG[k]+VCSV[k])*(9.0*eta*NDV*NDV- 7.0*eta*V1_V22+MOR*(9.0+4.5*eta))+DM/M*VCSIG[k]*(18.0* eta*NDV*NVDOT-14.0*eta*VA-MOR*RP/r*(9.0+4.5*eta)))/ (r3); - - - if(Van_QM==1) - { - - if(m1>m2) - { - QMD[k] = -1.5*MOR*MOR*MOR*eta*(-4.0*RP*QMAux1[k]/r2+( 2.0*(SPSPP1*QMAux2_1[k]/nu+SPSPP2*QMAux2_2[k]*nu) + SpinPrev2_1*(-10.0*rS1*rS1p*N[k]+(1.0-5.0*rS1*rS1)*Np[k]+2.0*rS1p*S1Dir[k]+2.0*rS1*S1p[k])/nu + SpinPrev2_2*(-10.0*rS2*rS2p*N[k]+(1.0-5.0*rS2*rS2)*Np[k]+2.0*rS2p*S2Dir[k]+2.0*rS2*S2p[k])*nu )/r); - } - else - { - QMD[k] = -1.5*MOR*MOR*MOR*eta*(-4.0*RP*QMAux1[k]/r2+( 2.0*(SPSPP2*QMAux2_1[k]/nu+SPSPP1*QMAux2_2[k]*nu) + SpinPrev2_2*(-10.0*rS2*rS2p*N[k]+(1.0-5.0*rS2*rS2)*Np[k]+2.0*rS2p*S2Dir[k]+2.0*rS2*S2p[k])/nu + SpinPrev2_1*(-10.0*rS1*rS1p*N[k]+(1.0-5.0*rS1*rS1)*Np[k]+2.0*rS1p*S1Dir[k]+2.0*rS1*S1p[k])*nu )/r); - } - - } /* if(Van_QM==1) */ - - } /* k */ - - - } /* if(Van_Spin==1) */ - - - ADK = ADK2+ADK4+ADK5+ADK6+ADK7; - BDK = BDK2+BDK4+BDK5+BDK6+BDK7; - - KSAK = AK2+AK4+AK5+AK6+AK7; - KSBK = BK2+BK4+BK5+BK6+BK7; - - for(k=0;k<3;k++) AD[k] = -2.0*MOR*RP*(KSAK*N[k]+KSBK*v[k])/r2 + MOR*(ADK*N[k]+BDK*v[k])/r + MOR*(KSAK*(v[k]-N[k]*RP)/r+KSBK*AT[k])/r + C1_5D[k]/c_2 + C2D[k]/c_4 +C2_5D[k]/c_4 + QMD[k]/c_4; - - -for(k=0;k<3;k++) // new values of the BH's spins, returned back to the main program... - { - spin1[k] = SPIN[k][0]; - spin2[k] = SPIN[k][1]; - } - - - - - - - -for(k=0;k<3;k++) - { - -if(usedOrNot[0] == 1) // PN0 (Newton) ~1/c^0 - { - adot_pn1[0][k] = -m2*(v[k]/r3 - 3.0*RP*x[k]/r2/r2); - adot_pn2[0][k] = m1*(v[k]/r3 - 3.0*RP*x[k]/r2/r2); - } - -if(usedOrNot[1] == 1) // PN1 ~1/c^2 - { - adot_pn1[1][k] = (-2.0*MOR*RP*(AK2*N[k]+BK2*v[k])/r2 + MOR*(ADK2*N[k]+BDK2*v[k])/r + MOR*(AK2*(v[k]-N[k]*RP)/r+BK2*A[k])/r)*m2/M; - adot_pn2[1][k] = -(-2.0*MOR*RP*(AK2*N[k]+BK2*v[k])/r2 + MOR*(ADK2*N[k]+BDK2*v[k])/r + MOR*(AK2*(v[k]-N[k]*RP)/r+BK2*A[k])/r)*m1/M; - } - -if(usedOrNot[2] == 1) // PN2 ~1/c^4 - { - adot_pn1[2][k] = (-2.0*MOR*RP*(AK4*N[k]+BK4*v[k])/r2 + MOR*(ADK4*N[k]+BDK4*v[k])/r + MOR*(AK4*(v[k]-N[k]*RP)/r+BK4*A[k])/r)*m2/M; - adot_pn2[2][k] = -(-2.0*MOR*RP*(AK4*N[k]+BK4*v[k])/r2 + MOR*(ADK4*N[k]+BDK4*v[k])/r + MOR*(AK4*(v[k]-N[k]*RP)/r+BK4*A[k])/r)*m1/M; - } - -if(usedOrNot[3] == 1) // PN2.5 ~1/c^5 - { - adot_pn1[3][k] = (-2.0*MOR*RP*(AK5*N[k]+BK5*v[k])/r2 + MOR*(ADK5*N[k]+BDK5*v[k])/r + MOR*(AK5*(v[k]-N[k]*RP)/r+BK5*A[k])/r)*m2/M; - adot_pn2[3][k] = -(-2.0*MOR*RP*(AK5*N[k]+BK5*v[k])/r2 + MOR*(ADK5*N[k]+BDK5*v[k])/r + MOR*(AK5*(v[k]-N[k]*RP)/r+BK5*A[k])/r)*m1/M; - } - -if(usedOrNot[4] == 1) // PN3 ~1/c^6 - { - adot_pn1[4][k] = (-2.0*MOR*RP*(AK6*N[k]+BK6*v[k])/r2 + MOR*(ADK6*N[k]+BDK6*v[k])/r + MOR*(AK6*(v[k]-N[k]*RP)/r+BK6*A[k])/r)*m2/M; - adot_pn2[4][k] = -(-2.0*MOR*RP*(AK6*N[k]+BK6*v[k])/r2 + MOR*(ADK6*N[k]+BDK6*v[k])/r + MOR*(AK6*(v[k]-N[k]*RP)/r+BK6*A[k])/r)*m1/M; - } - -if(usedOrNot[5] == 1) // PN3.5 ~1/c^7 - { - adot_pn1[5][k] = (-2.0*MOR*RP*(AK7*N[k]+BK7*v[k])/r2 + MOR*(ADK7*N[k]+BDK7*v[k])/r + MOR*(AK7*(v[k]-N[k]*RP)/r+BK7*A[k])/r)*m2/M; - adot_pn2[5][k] = -(-2.0*MOR*RP*(AK7*N[k]+BK7*v[k])/r2 + MOR*(ADK7*N[k]+BDK7*v[k])/r + MOR*(AK7*(v[k]-N[k]*RP)/r+BK7*A[k])/r)*m1/M; - } - - -if(Van_Spin == 1) // All the SPIN terms - { - adot_pn1[6][k] += (C1_5D[k]/c_2 + C2D[k]/c_4 +C2_5D[k]/c_4 + QMD[k]/c_4)*m2/M; - adot_pn2[6][k] += -(C1_5D[k]/c_2 + C2D[k]/c_4 +C2_5D[k]/c_4 + QMD[k]/c_4)*m1/M; - } - - - } - -// PN jerks - - - - -// Check RS_DIST conditions !!! - -RS_DIST = 4.0*(2.0*m1/c_2 + 2.0*m2/c_2); - -if(r < RS_DIST) - { - if(myRank == rootRank) - { - fprintf(stdout,"PN RSDIST: r = %.8E \t RS = %.8E \n", r, RS_DIST); - fflush(stdout); - } - return(505); - } -else - { - return(0); - } - - -} -/***************************************************************************/ diff --git a/pn_bh_spin.c b/pn_bh_spin.c index 54822f3..c0e54da 100644 --- a/pn_bh_spin.c +++ b/pn_bh_spin.c @@ -10,7 +10,7 @@ int calc_force_pn_BH(double m1, double xx1[], double vv1[], double spin1[], double CCC_NB, double dt_bh, int usedOrNot[], double a_pn1[][3], double adot_pn1[][3], - double a_pn2[][3], double adot_pn2[][3]) + double a_pn2[][3], double adot_pn2[][3], int myRank, int rootRank) { /* @@ -52,7 +52,7 @@ double PI2 = 9.86960440108935; double c_1, c_2, c_4, c_5, c_6, c_7, RS_DIST; double M, eta, r, r2, r3, MOR; -double V1_V22,VWHOLE, RP, RPP, VA; +double V1_V22, RP, RPP, VA; double N[3], x[3], v[3], A[3]; double A1, B1, A2, B2, A2_5, B2_5, AK2, BK2, AK4, BK4, AK5, BK5; double A1D, A2D, A2_5D, B1D, B2D, B2_5D, ADK2, BDK2, ADK4, BDK4, ADK5, BDK5; @@ -72,7 +72,6 @@ double SS1aux[3],SS2aux[3],SU[3],SV[3],XAD[3],XSD[3]; double NDOTCS[3], NCSU[3], NDOTCSIG[3], NCSV[3], ACS[3], VCSU[3], ACSIG[3], VCSV[3], SNVDOT, SIGNVDOT, NSDOT, NSIGDOT, VSDOT, VSIGDOT, NXSDOT, NXADOT; double C1_5D[3],C2D[3], C2_5D[3]; -double ADK, BDK, AD[3], KSAK, KSBK; double nu, Spin1Abs2, Spin2Abs2, rS1, rS2, S1Dir[3], S2Dir[3], QM[3]; double Spin1Abs, Spin2Abs, QMAux2_1[3], QMAux2_2[3], QMAux1[3] , QMD[3], SPINPrev[3][2], SpinPrev2_1, SpinPrev2_2, SPSPP1, SPSPP2, Spin1AbsNew2, Spin2AbsNew2, Spin1AbsNew, Spin2AbsNew, S1DirNew[3], @@ -129,7 +128,6 @@ r3 = r2*r; MOR = M/r; V1_V22 = v[0]*v[0]+v[1]*v[1]+v[2]*v[2]; -VWHOLE = sqrt(V1_V22); RP = (x[0]*v[0]+x[1]*v[1]+x[2]*v[2])/r; @@ -667,15 +665,6 @@ if(usedOrNot[5] == 1) // PN3.5 ~1/c^7 } /* if(Van_Spin==1) */ - ADK = ADK2+ADK4+ADK5+ADK6+ADK7; - BDK = BDK2+BDK4+BDK5+BDK6+BDK7; - - KSAK = AK2+AK4+AK5+AK6+AK7; - KSBK = BK2+BK4+BK5+BK6+BK7; - - for(k=0;k<3;k++) AD[k] = -2.0*MOR*RP*(KSAK*N[k]+KSBK*v[k])/r2 + MOR*(ADK*N[k]+BDK*v[k])/r + MOR*(KSAK*(v[k]-N[k]*RP)/r+KSBK*AT[k])/r + C1_5D[k]/c_2 + C2D[k]/c_4 +C2_5D[k]/c_4 + QMD[k]/c_4; - - for(k=0;k<3;k++) // new values of the BH's spins, returned back to the main program... { spin1[k] = SPIN[k][0]; 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 -*** - - diff --git a/star_destr.c b/star_destr.c deleted file mode 100644 index 612d765..0000000 --- a/star_destr.c +++ /dev/null @@ -1,275 +0,0 @@ -/***************************************************************************** - File Name : "Star Destr.c" - Contents : star "destruction" by tidal field of "live" BH (1 or 2) - Coded by : Peter Berczik - Last redaction : 2010.IX.14 1:43PM -*****************************************************************************/ - -void star_destr(double time, - int n, - int ind[], - double m[], - double x[][3], - double v[][3], - double pot[], - double a[][3], - double adot[][3], - double t[], - double dt[], - int N, - double m_N[], - double x_N[][3], - double v_N[][3], - double a_N[][3], - double adot_N[][3], - double t_N[], - double *m_bh, - int *num_bh, - int i_bh) -{ - -int n_end, k_act, N_end; - -double R_t, e_kin=0.0, e_pot_BH=0.0, e_pot=0.0, e_corr=0.0; - -double eps_bh, eps2, eps_bh2, rsb, rkb2, rks2, xp[3], v_bh[3]; - -//double vir = 0.6, gamma = 1000.0; - -double x_max = 1.0E+03, v_max = 1.0E-08, - a_max = 1.0E-08, adot_max = 1.0E-08; - - -if( time < t_diss_on ) return; - - -eps_bh = eps; - -eps2 = SQR(eps); -eps_bh2 = SQR(eps_bh); - -/* -m_s = 1.0/N; -R_s = 2.52E-08/2.507328103; -R_t = gamma * R_s * pow( 2.0*(*m_bh/m_s), over3 ); -*/ - -R_t = R_TIDAL; - -/* -if(myRank == rootRank) - { - printf("%.6E \t %06d %06d %06d \t %.6E \t %.6E %06d \n", time, n, i_bh, ind[i_bh], R_t, *m_bh, *num_bh); - fflush(stdout); - } -*/ - -#ifdef ADD_BH2 - n_end = n-2; - N_end = N-2; -#else -#ifdef ADD_BH1 - n_end = n-1; - N_end = N-1; -#endif // ADD_BH1 -#endif // ADD_BH2 - -/* -if(myRank == rootRank) - { - printf("%.6E \t %06d %06d %06d %06d \t %.6E \t %.6E %06d \n", time, n, n_end, i_bh, ind[i_bh], R_t, *m_bh, *num_bh); - fflush(stdout); - } -*/ - -for(i=0; i