From aaf40315c82347b17e968b4146f7ba07ae95ad93 Mon Sep 17 00:00:00 2001 From: Yohai Date: Sun, 25 Aug 2019 16:22:03 +0800 Subject: [PATCH] first commit --- Makefile | 30 + act_def_linklist.c | 376 +++ cmd.c | 76 + debug.h | 143 + def_DEN.c | 38 + def_DEN_STAR.c | 74 + def_H.c | 85 + drag_force.c | 185 ++ n_bh.c | 76 + phi-GRAPE.c | 7241 ++++++++++++++++++++++++++++++++++++++++++++ pn_bh.c | 765 +++++ pn_bh_spin.c | 765 +++++ sse_sse.f | 7109 +++++++++++++++++++++++++++++++++++++++++++ star_destr.c | 275 ++ star_destr_ext.c | 286 ++ 15 files changed, 17524 insertions(+) create mode 100644 Makefile create mode 100644 act_def_linklist.c create mode 100644 cmd.c create mode 100644 debug.h create mode 100644 def_DEN.c create mode 100644 def_DEN_STAR.c create mode 100644 def_H.c create mode 100644 drag_force.c create mode 100644 n_bh.c create mode 100644 phi-GRAPE.c create mode 100644 pn_bh.c create mode 100644 pn_bh_spin.c create mode 100644 sse_sse.f create mode 100644 star_destr.c create mode 100644 star_destr_ext.c diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..8921623 --- /dev/null +++ b/Makefile @@ -0,0 +1,30 @@ +CUDAHOME ?= /usr/local/cuda +CPPFLAGS += -DYEBISU -DETICS +OPTIMIZATION ?= 3 + +DTSCF ?= 0.015625 + +CUDAINC = -I$(CUDAHOME)/include -I$(CUDAHOME)/samples/common/inc/ +CUDALIB = -L$(CUDAHOME)/lib64 -lcudart -lcudadevrt + +GRAPEHOME = ../grapite +GRAPELIB = -L$(GRAPEHOME) -lgrapite +yebisu: GRAPEHOME = ../yebisu +yebisu: GRAPELIB = -L$(GRAPEHOME) -lyebisug6 +GRAPEINC = -I$(GRAPEHOME) + +CFLAGS ?= -mcmodel=large +CFLAGS += -O$(OPTIMIZATION) +INC = $(GRAPEINC) $(CUDAINC) +LIB = $(GRAPELIB) $(CUDALIB) -lm -lgcc -lgfortran -lstdc++ +MPICC ?= mpicc +EXECUTABLE ?= phi-GRAPE.exe + +default: + $(MPICC) $(CPPFLAGS) $(CFLAGS) $(INC) -DDTSCF=$(DTSCF) phi-GRAPE.c -o $(EXECUTABLE) $(LIB) + +yebisu: CPPFLAGS := $(filter-out -DETICS, $(CPPFLAGS)) +yebisu: default + +clean: + rm -f *.o phi-GRAPE.exe diff --git a/act_def_linklist.c b/act_def_linklist.c new file mode 100644 index 0000000..b879bc3 --- /dev/null +++ b/act_def_linklist.c @@ -0,0 +1,376 @@ +/************************************************************** + 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/cmd.c b/cmd.c new file mode 100644 index 0000000..8d99a68 --- /dev/null +++ b/cmd.c @@ -0,0 +1,76 @@ + +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/debug.h b/debug.h new file mode 100644 index 0000000..e307360 --- /dev/null +++ b/debug.h @@ -0,0 +1,143 @@ +/***************************************************************/ +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 new file mode 100644 index 0000000..7cb217b --- /dev/null +++ b/def_DEN.c @@ -0,0 +1,38 @@ + +/*************************************************************************/ +/*************************************************************************/ +/*************************************************************************/ + +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 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 +#define ETICS_DTSCF 0.125 +#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 + +/****************************************************************************/ +#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= 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 + + i_bh1 = 0; + i_bh2 = 1; + +#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"); + + i_bh1 = 0; + i_bh2 = 1; + + 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 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;im2) + { + 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 new file mode 100644 index 0000000..54822f3 --- /dev/null +++ b/pn_bh_spin.c @@ -0,0 +1,765 @@ +/***************************************************************************/ +/* + 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/sse_sse.f b/sse_sse.f new file mode 100644 index 0000000..d29b7fc --- /dev/null +++ b/sse_sse.f @@ -0,0 +1,7109 @@ +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 new file mode 100644 index 0000000..612d765 --- /dev/null +++ b/star_destr.c @@ -0,0 +1,275 @@ +/***************************************************************************** + 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