diff --git a/README b/README new file mode 100644 index 0000000..4dbc6db --- /dev/null +++ b/README @@ -0,0 +1,94 @@ +********************************************************************** +This is an addon module for CAMB/cosmoMC which computes the +primordial power spectra by an exact numerical integration of some +standard one field inflationary models. It implements reheating +through the "reheating parameter" R allowing robust inflationary +parameter estimations and inference on the reheating energy scale. The +underlying perturbation code actually deals with N fields +minimally-coupled and/or non-minimally coupled to gravity. Works for +flat FLRW only. +********************************************************************** + +-These patches modify the cosmomc or camb codes and therefore may have +bugs that are not present in the originals. The authors of the +original versions should not be bothered with problems resulting in +the use of these patches. Feel free to insult me, or at least contact +me, in case of bugs! + +-Apply the patch in the cosmomc/ directory: + +patch -p1 < purpose_MMYY.patch + +-See astro-ph/0509727, astro-ph/0605367, astro-ph/0703486, arXiv:1004.5525 + +-Please note that the genuine Makefiles have been heavily changed and +may require edition to work on your system. They assume the existence +of a directory "cosmomc/WMAP" which points to the WMAP team likelihood +code directory. The WMAP data are also assumed to reside in the +"cosmomc/data" directory. + +********************************************************************** + +Basic controls are included in the cosmomc "params.ini" file and +consist on choosing an inflationary model and specifying the prior +range on its potential parameters. The CAMB control file, of the same +name, includes a detailed interface to the inflationary module. + +The inflation code itself is in the sub-directory "fieldinf" and a +short description of the relevant files is given in the following. + +*infbgmodel.f90 + +Contains the encoded inflationary potentials together with their +short-name. If you need to add a model, this starts there. + +*infsrmodel.F90 + +Contains routines to solve the slow-roll approximated equations for +each of the above mentioned model. This is used only to provide a +guess (optional) of the initial field values producing a numerically +optimal *total* number of e-folds of inflation (long enough to perform +computations on the attractor, but not too long to spare computing +time). Additional "hard" theoretical priors on the allowed field +values are coded in this file. + +*infbg.f90 + +Integrates the field and metric background from given values of the +potential parameters and initial conditions. The function +"set_infbg_ini" is precisely calling the routines of "infsrmodel.f90", +but only if you set all initial field value to 0. Otherwise, the +background is computed from the input initial field value. A lot of +tunable options can be set in the function "bg_field_evol" to specify +how inflation ends, to explore parametric oscillations... + +*infpert.f90 + +Integrates the perturbations in Fourier space over the previously +computed background. For each perturbation mode, you get the tensor +and scalar power spectra. + +*inftorad.f90 + +Contains all routines needed to relate the inflationary era to the +radiation era by means of the reheating parameter R. Extra assumptions +on reheating can be fixed there. + + +*power_inf.f90 + +This is the interface between CAMB and the inflationary code. It feeds +CAMB with each perturbation mode. It contains various optimisations, +tests for hard priors. A spline of the power spectra is switched on +by the boolean "useSplineDefault". The range and number of points are +set in the routine "SetDefPowerParams". + +********************************************************************** + +All source files contain the switches "display" and "dump_files" which +can be used for debugging. They output data at various stages of the +computation. Mind that they slow down a lot the execution and you +don't want to use them for production runs. + + + diff --git a/camb/Makefile b/camb/Makefile index 5c09a67..01ca343 100644 --- a/camb/Makefile +++ b/camb/Makefile @@ -1,83 +1,134 @@ -#CAMB Makefile +# >>> DESIGNED FOR GMAKE <<< +#CAMB System unified Makefile -#Set FISHER=Y to compile bispectrum fisher matrix code -FISHER= +ext=$(shell uname | cut -c1-3) -#Edit for your compiler -#Note there are many old ifc versions, some of which behave oddly +ifeq ($(ext),IRI) +F90C=f90 +FFLAGS = -Ofast=ip35 -n32 +LFLAGS= +endif + +ifeq ($(ext),Lin) +F90C=gfortran +FFLAGS= -O -fopenmp +LFLAGS= +endif + +ifeq ($(ext),OSF) +F90C=f90 +FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1 +LFLAGS= +endif +ifeq ($(ext),Sun) +F90C=f90 +FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none +LFLAGS= +endif -#Intel , -openmp toggles mutli-processor: -#note version 10.0 gives wrong result for lensed when compiled with -openmp [fixed in 10.1] -F90C = ifort -FFLAGS = -openmp -fast -W0 -WB -fpp2 -vec_report0 -ifneq ($(FISHER),) -FFLAGS += -mkl +ifeq ($(ext),AIX) +F90C=xlf90_r +FFLAGS= -O4 -q64 -qsmp=omp -qmaxmem=-1 -qstrict -qfree=f90 -qsuffix=f=f90:cpp=F90 +LFLAGS= endif -#Gfortran compiler: -#The options here work in v4.5, delete from RHS in earlier versions (15% slower) -#if pre v4.3 add -D__GFORTRAN__ -#With v4.6+ try -Ofast -march=native -fopenmp -#On my machine v4.5 is about 20% slower than ifort -#F90C = gfortran -#FFLAGS = -O3 -fopenmp -ffast-math -march=native -funroll-loops - - -#Old Intel ifc, add -openmp for multi-processor (some have bugs): -#F90C = ifc -#FFLAGS = -O2 -Vaxlib -ip -W0 -WB -quiet -fpp2 -#some systems can can also add e.g. -tpp7 -xW - -#G95 compiler -#F90C = g95 -#FFLAGS = -O2 - -#SGI, -mp toggles multi-processor. Use -O2 if -Ofast gives problems. -#F90C = f90 -#FFLAGS = -Ofast -mp - -#Digital/Compaq fortran, -omp toggles multi-processor -#F90C = f90 -#FFLAGS = -omp -O4 -arch host -math_library fast -tune host -fpe1 - -#Absoft ProFortran, single processor: -#F90C = f95 -#FFLAGS = -O2 -cpu:athlon -s -lU77 -w -YEXT_NAMES="LCS" -YEXT_SFX="_" - -#NAGF95, single processor: -#F90C = f95 -#FFLAGS = -DNAGF95 -O3 - -#PGF90 -#F90C = pgf90 -#FFLAGS = -O2 -DESCAPEBACKSLASH -Mpreprocess - -#Sun V880 -#F90C = mpf90 -#FFLAGS = -O4 -openmp -ftrap=%none -dalign -DMPI - -#Sun parallel enterprise: -#F90C = f95 -#FFLAGS = -O2 -xarch=native64 -openmp -ftrap=%none -#try removing -openmp if get bus errors. -03, -04 etc are dodgy. - -#IBM XL Fortran, multi-processor (run gmake) -#F90C = xlf90_r -#FFLAGS = -DESCAPEBACKSLASH -DIBMXL -qsmp=omp -qsuffix=f=f90:cpp=F90 -O3 -qstrict -qarch=pwr3 -qtune=pwr3 - -#Settings for building camb_fits -#Location of FITSIO and name of library -FITSDIR = /home/cpac/cpac-tools/lib -FITSLIB = cfitsio + +#Files containing evolution equations initial power spectrum module +EQUATIONS = equations +POWERSPECTRUM = power_inf +REIONIZATION = reionization +RECOMBINATION = recfast +BISPECTRUM = SeparableBispectrum +DENABLE_FISHER = + +#inf module +INFDIR = ../fieldinf +INFOBJ = infprec.o binfspline.o hyper2F1.o specialinf.o infinout.o inftools.o infbgmodel.o infsrmodel.o infbg.o infbgspline.o cosmopar.o inftorad.o infpert.o infpowspline.o + +#Module doing non-linear scaling +NONLINEAR = halofit + +#Driver program +DRIVER = inidriver.F90 +#DRIVER = sigma8.f90 +#DRIVER = tester.f90 + #Location of HEALPIX for building camb_fits -HEALPIXDIR = /home/cpac/cpac-tools/healpix +HEALPIXDIR = /usr -ifneq ($(FISHER),) +CAMBLIB = libcamb.a +INFLIB = libinf.a + +ifneq ($(DENABLE_FISHER),) FFLAGS += -DFISHER +LFLAGS += -llapack -lblas EXTCAMBFILES = Matrix_utils.o else EXTCAMBFILES = endif -include ./Makefile_main + +#Shouldn't need to change anything else... + +F90FLAGS = $(FFLAGS) -DPP5 +HEALPIXLD = -L$(HEALPIXDIR)/lib -lhealpix +FC = $(F90C) + +CAMBOBJ = constants.o utils.o subroutines.o inifile.o $(POWERSPECTRUM).o\ + $(RECOMBINATION).o $(REIONIZATION).o modules.o \ + bessels.o $(EQUATIONS).o $(NONLINEAR).o lensing.o $(BISPECTRUM).o \ + cmbmain.o camb.o + + +default: camb.$(ext) + +all: camb.$(ext) $(CAMBLIB) $(INFLIB) + + +subroutines.o: constants.o utils.o +$(POWERSPECTRUM): subroutines.o inifile.o +$(RECOMBINATION).o: subroutines.o inifile.o +$(REIONIZATION).o: constants.o inifile.o +modules.o: $(REIONIZATION).o $(POWERSPECTRUM).o $(RECOMBINATION).o +bessels.o: modules.o +$(EQUATIONS): bessels.o +$(NONLINEAR).o: modules.o +lensing.o: bessels.o +$(BISPECTRUM).o: lensing.o modules.o +cmbmain.o: lensing.o $(NONLINEAR).o $(EQUATIONS).o $(BISPECTRUM).o +camb.o: cmbmain.o +Matrix_utils.o: utils.o + +camb.$(ext): $(INFOBJ) $(CAMBOBJ) $(DRIVER) + $(F90C) $(F90FLAGS) $(INFOBJ) $(CAMBOBJ) $(DRIVER) $(LFLAGS) -o $@ + +$(CAMBLIB): $(CAMBOBJ) + ar -r $@ $? + +$(INFLIB): $(INFOBJ) + ar -r $@ $? + +camb_fits.$(ext): writefits.f90 $(CAMBOBJ) $(DRIVER) + $(F90C) $(F90FLAGS) -I$(HEALPIXDIR)/include $(CAMBOBJ) writefits.f90 $(DRIVER) $(HEALPIXLD) $(LFLAGS) -DWRITE_FITS -o $@ + +%.o: %.f90 + $(F90C) $(F90FLAGS) -c $< + +%.o: $(INFDIR)/%.f90 + $(F90C) $(F90FLAGS) -c $< + +%.o: $(INFDIR)/%.F90 + $(F90C) $(F90FLAGS) -c $< + +utils.o: + $(F90C) $(F90FLAGS) -c utils.F90 + +$(BISPECTRUM).o: + $(F90C) $(F90FLAGS) -c $(BISPECTRUM).F90 + +Matrix_utils.o: + $(F90C) $(F90FLAGS) -c Matrix_utils.F90 +clean: + -rm -f *.o *.a *.d core *.mod + diff --git a/camb/cmbmain.f90 b/camb/cmbmain.f90 index 90ce721..82a8aee 100644 --- a/camb/cmbmain.f90 +++ b/camb/cmbmain.f90 @@ -1991,13 +1991,17 @@ contains integer, intent(in) :: numks, pix real(dl) pows(numks), ks(numks) integer i - +!fields +!$omp parallel do & +!$omp default(shared) & +!$omp private(i) & +!$omp schedule(dynamic) do i = 1, numks !!change to vec... pows(i) = ScalarPower(ks(i) ,pix) - if (global_error_flag/=0) exit end do - +!$omp end parallel do +!end fields end subroutine GetInitPowerArrayVec @@ -2005,12 +2009,16 @@ contains integer, intent(in) :: numks, pix real(dl) pows(numks), ks(numks) integer i - +!fields +!$omp parallel do & +!$omp default(shared) & +!$omp private(i) & +!$omp schedule(dynamic) do i = 1, numks pows(i) = TensorPower(ks(i) ,pix) - if (global_error_flag/=0) exit end do - +!$omp end parallel do +!end fields end subroutine GetInitPowerArrayTens @@ -2026,7 +2034,11 @@ contains do pix=1,CP%InitPower%nn - +!field: calling ScalarPower is time consumming when it comes from inflation code. Better to parallelise +!$omp parallel do & +!$omp default(shared) & +!$omp private(q_ix) & +!$omp schedule(dynamic,1) do q_ix = 1, CTrans%q%npoints if (CP%flat) then @@ -2038,10 +2050,11 @@ contains end if pows(q_ix) = ScalarPower(ks(q_ix) ,pix) - if (global_error_flag/=0) return end do - +!$omp end parallel do + if (global_error_flag/=0) return +!end field !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) & !$OMP & PRIVATE(j,q_ix,dlnk,apowers,ctnorm,dbletmp) diff --git a/camb/inidriver.F90 b/camb/inidriver.F90 index b355761..db0c05a 100644 --- a/camb/inidriver.F90 +++ b/camb/inidriver.F90 @@ -332,6 +332,10 @@ call CAMB_cleanup +!fields + call FreePowers(P%InitPower) +!end fields + end program driver diff --git a/camb/params.ini b/camb/params.ini index cf5b821..32158e8 100644 --- a/camb/params.ini +++ b/camb/params.ini @@ -1,12 +1,12 @@ #Parameters for CAMB #output_root is prefixed to output file names -output_root = test +output_root = fields #What to do get_scalar_cls = T get_vector_cls = F -get_tensor_cls = F +get_tensor_cls = T get_transfer = F #if do_lensing then scalar_output_file contains additional columns of l^4 C_l^{pp} and l^3 C_l^{pT} @@ -65,19 +65,6 @@ nu_mass_degeneracies = 0 #Fraction of total omega_nu h^2 accounted for by each eigenstate, eg. 0.5 0.5 nu_mass_fractions = 1 -#Initial power spectrum, amplitude, spectral index and running. Pivot k in Mpc^{-1}. -initial_power_num = 1 -pivot_scalar = 0.05 -pivot_tensor = 0.05 -scalar_amp(1) = 2.1e-9 -scalar_spectral_index(1) = 0.96 -scalar_nrun(1) = 0 -tensor_spectral_index(1) = 0 -#ratio is that of the initial tens/scal power spectrum amplitudes -initial_ratio(1) = 1 -#note vector modes use the scalar settings above - - #Reionization, ignored unless reionization = T, re_redshift measures where x_e=0.5 reionization = T @@ -98,6 +85,63 @@ RECFAST_fudge_He = 0.86 RECFAST_Heswitch = 6 RECFAST_Hswitch = T +#inflationary model parameters (see infbgmodel.f90) +#param(1)=M; param(2)=p; param(3)=nu; param(4)=mu, param(5)=q +#largef: V = M^4 phi^p p > 0 +#smallf: V = M^4 [1 - (phi/mu)^p] p > 2 +#hybrid: V = M^4 [1 + (phi/mu)^p] +#runmas: V = M^4 {1 + nu [1/p + ln(phi/mu)]phi^p} +#kklmmt: V = M^4 [1 - q (phi/mu)^-p]^q p > 0; q=+-1 + +#number of read parameters +inf_param_number = 7 + +#should be consistent with the above defs +inf_model_name = largef +inf_param(1) = 2e-3 +inf_param(2) = 2 +inf_param(3) = 0 +inf_param(4) = 0 +inf_param(5) = 1 + + +#Hard prior that reject models with field values greater that +#field_bound. May be used for keeping models out of the +#self-reproducing regime, or constrain the branes to be inside the +#throat. In unit of kappa +inf_check_bound = F +inf_param(6) = 0 + + +#stops artificially inflation for this matter field value. Unit of +#kappa for large field and running mass; unit of mu for small fields +#and kklmmt; unit of a maximal field value that gives 120 efolds of +#hybrid inflation +inf_check_stop = F +inf_param(7) = 0 + +#initial fields value. Unit of kappa for large field and running; unit +#of mu for small field, hybrid and kklmmt. For inf_matter = 0, uses +#a slow-roll approximation to guess the relevant values +inf_conform(1) = 1 +inf_matter(1) = 0 + +#This is ln(aend/areh) - 1/4 ln(rhoreh kappa^4) + 1/2 ln(rhoend kappa^4) +inf_ln_reheat = 0 + + +#speed up A LOT the computations (only for featureless power spectra) +power_spectra_spline = T + +#if false then every k required are computed from their quantum birth +#during the inflationary era. Otherwise, only a few of them are +#computed and the others interpolated. The following parameters set +#the range and number (ln=log base e) +spline_lnkmpc_min = -14 +spline_lnkmpc_max = 0 +spline_lnkmpc_num = 12 + + #Initial scalar perturbation mode (adiabatic=1, CDM iso=2, Baryon iso=3, # neutrino density iso =4, neutrino velocity iso = 5) initial_condition = 1 diff --git a/camb/readme.html b/camb/readme.html index f5ada26..cff517b 100644 --- a/camb/readme.html +++ b/camb/readme.html @@ -112,7 +112,7 @@ where all quantities are in the synchronous gauge and evaluated at the requested

Version history

January 2012
December 2011
@@ -503,7 +503,7 @@ the Cls are normalized. Comments in the code explain this further. This file defines a module called Reionization that parameterizes the reionization history and supplies a function Reionization_xe that gives xe as a function of redshift. Optical depth input parameters are mapped into zre (defined as where xe is half its maximum (ex second He reionization)) using a binary search. See the CAMB notes for discussion. This module should be easily modifiable for alternative reionization models.

halofit.f90

-Implements the NonLinear module, to calculate non linear scalings of the matter power spectrum as a function of redshift. Uses HALOFIT (astro-ph/0207664, code thanks to Robert Smith. Note this is only reliable at the several percent level for standard ΛCDM models with power law initial power spectra. This module can be replaced to use a different non-linear fitting method. +Implements the NonLinear module, to calculate non linear scalings of the matter power spectrum as a function of redshift. Uses HALOFIT (astro-ph/0207664, code thanks to Robert Smith, with tweaks from arXiv:1109.4416. Note this is only reliable at the several percent level for standard ΛCDM models with power law initial power spectra. This module can be replaced to use a different non-linear fitting method.

@@ -563,7 +563,9 @@ Implements the NonLinear module, to calculate non linear scalings of the matter

Accuracy

-Scalar errors should rarely exceed 0.3% for min(2500, L well into the damping tail) at default accuracy setting, and 0.1% for 500<L<2000 with high_accuracy_default=T. Matter power spectrum errors are usually dominated by interpolation in the acoustic oscillations, with about 0.2% accuracy with high_accuracy_default (but much better rms accuracy). +Scalar numerical errors should rarely exceed 0.3% for min(2500, L well into the damping tail) at default accuracy setting, and 0.1% for 500<L<2000 with high_accuracy_default=T. Matter power spectrum errors are usually dominated by interpolation in the acoustic oscillations, with about 0.2% accuracy with high_accuracy_default (but much better rms accuracy). For a detailed study of numerical accuracy as of January 2012 see arXiv:1201.3654. + + See also comparison with CMBFAST. Accuracy of course assumes the model is correct, and is dependent on RECFAST being the correct ionization history. Lensed C_l TT, TE and EE are accurate at the same level (to within the approximation that the lensing potential is linear, or the accuracy of the the HALOFIT non-linear model).

Extreme models (e.g. scale > 4, h>1) may give errors of 5% or more. @@ -594,10 +596,15 @@ See also comparison with CMBFAST. Accuracy of course assu

REFERENCES

-Some notes and relevant Maple derivations are given here (see also the Appendix of astro-ph/0406096). The CAMB notes outline the equations and approximations used, and relation to standard synchronous-gauge and Newtonian-gauge variables. +Some notes and relevant Maple derivations are given here (see also the Appendix of astro-ph/0406096). The CAMB notes outline the equations and approximations used, and relation to standard synchronous-gauge and Newtonian-gauge variables; see also arXiv:1201.3654. There is a BibTex file of references (including CosmoMC).

+CMB power spectrum parameter degeneracies in the era of precision cosmology
+Cullan Howlett, Antony Lewis, Alex Hall, Anthony Challinor arXiv:1201.3654. +

Efficient computation of CMB anisotropies in closed FRW Models
Antony Lewis, Anthony Challinor and Anthony Lasenby astro-ph/9911177 Ap. J. 538:473-476, 2000. @@ -647,7 +654,8 @@ Antony Lewis, astro-ph/0403583HALOFIT

Stable clustering, the halo model and nonlinear cosmological power spectra
-Smith, R. E. and others, astro-ph/0207664 +Smith, R. E. and others, astro-ph/0207664. +

RECOMBINATION

@@ -696,13 +704,25 @@ The Cosmic Linear Anisotropy Solving System (CLASS) II: Blas, Diego and Lesgourgues, Julien and Tram, Thomas. arXiv:1104.2933

+Massive Neutrinos +

+CMB power spectrum parameter degeneracies in the era of precision cosmology +
+Cullan Howlett, Antony Lewis, Alex Hall, Anthony Challinor. +arXiv:1201.3654 +

+

Evolution of cosmological dark matter perturbations
+Antony Lewis and Anthony Challinor astro-ph/0203507 +Phys. Rev. D66, 023531 (2002) + +

Synchronous gauge theory and non-flat models

Complete treatment of CMB anisotropies in a FRW universe
Wayne Hu, Uros Seljak and Matias Zaldarriaga. Phys. Rev. D57:6, 3290-3301, 1998. astro-ph/9709066. -

WKB approx to hyperspherical Bessel functions @@ -719,10 +739,16 @@ Blas, Diego and Lesgourgues, Julien and Tram, Thomas. astro-ph/9603033 Ap.J. 469:2 437-444, 1996

+ +Integral solution for the microwave background + anisotropies in nonflat universes
+ Matias Zaldarriaga, Uros Seljak, Edmund Bertschinger. + ApJ. 494:491-501, 1998. astro-ph/9704265. + +

CMBFAST for spatially closed universes
Uros Seljak and Matias Zaldariaga, astro-ph/9911219 -

-See also the references on the CMBFAST home page. + diff --git a/fieldinf/README b/fieldinf/README new file mode 100644 index 0000000..c31ebdb --- /dev/null +++ b/fieldinf/README @@ -0,0 +1,94 @@ +********************************************************************** +This is an addon module for CAMB/cosmoMC which computes the +primordial power spectra by an exact numerical integration of some +standard one field inflationary models. It implements reheating +through the "reheating parameter" R allowing robust inflationary +parameter estimations and inference on the reheating energy scale. The +underlying perturbation code actually deals with N fields +minimally-coupled and/or non-minimally coupled to gravity. Works for +flat FLRW only. +********************************************************************** + +-These patches modify the cosmomc or camb codes and therefore may have +bugs that are not present in the originals. The authors of the +original versions should not be bothered with problems resulting in +the use of these patches. Feel free to insult me, or at least contact +me, in case of bugs! + +-Apply the patch in the cosmomc/ directory: + +patch -p1 < purpose_DDMMYY.patch + +-See astro-ph/0509727, astro-ph/0605367, astro-ph/0703486, arXiv:1004.5525 + +-Please note that the genuine Makefiles have been heavily changed and +may require edition to work on your system. They assume the existence +of a directory "cosmomc/WMAP" which points to the WMAP team likelihood +code directory. The WMAP data are also assumed to reside in the +"cosmomc/data" directory. + +********************************************************************** + +Basic controls are included in the cosmomc "params.ini" file and +consist on choosing an inflationary model and specifying the prior +range on its potential parameters. The CAMB control file, of the same +name, includes a detailed interface to the inflationary module. + +The inflation code itself is in the sub-directory "fieldinf" and a +short description of the relevant files is given in the following. + +*infbgmodel.f90 + +Contains the encoded inflationary potentials together with their +short-name. If you need to add a model, this starts there. + +*infsrmodel.F90 + +Contains routines to solve the slow-roll approximated equations for +each of the above mentioned model. This is used only to provide a +guess (optional) of the initial field values producing a numerically +optimal *total* number of e-folds of inflation (long enough to perform +computations on the attractor, but not too long to spare computing +time). Additional "hard" theoretical priors on the allowed field +values are coded in this file. + +*infbg.f90 + +Integrates the field and metric background from given values of the +potential parameters and initial conditions. The function +"set_infbg_ini" is precisely calling the routines of "infsrmodel.f90", +but only if you set all initial field value to 0. Otherwise, the +background is computed from the input initial field value. A lot of +tunable options can be set in the function "bg_field_evol" to specify +how inflation ends, to explore parametric oscillations... + +*infpert.f90 + +Integrates the perturbations in Fourier space over the previously +computed background. For each perturbation mode, you get the tensor +and scalar power spectra. + +*inftorad.f90 + +Contains all routines needed to relate the inflationary era to the +radiation era by means of the reheating parameter R. Extra assumptions +on reheating can be fixed there. + + +*power_inf.f90 + +This is the interface between CAMB and the inflationary code. It feeds +CAMB with each perturbation mode. It contains various optimisations, +tests for hard priors. A spline of the power spectra is switched on +by the boolean "useSplineDefault". The range and number of points are +set in the routine "SetDefPowerParams". + +********************************************************************** + +All source files contain the switches "display" and "dump_files" which +can be used for debugging. They output data at various stages of the +computation. Mind that they slow down a lot the execution and you +don't want to use them for production runs. + + + diff --git a/fieldinf/binfspline.f90 b/fieldinf/binfspline.f90 new file mode 100644 index 0000000..b65758f --- /dev/null +++ b/fieldinf/binfspline.f90 @@ -0,0 +1,524 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! +! VERSION 2.2 +! +! f90 VERSION +! +! This library contains routines for B-spline interpolation in +! one, two, and three dimensions. Part of the routines are based +! on the book by Carl de Boor: A practical guide to Splines (Springer, +! New-York 1978) and have the same calling sequence and names as +! the corresponding routines from the IMSL library. For documen- +! tation see the additional files. NOTE: The results in the demo +! routines may vary slightly on different architectures. +! +! by W. Schadow 12/04/99 +! last changed by W. Schadow 07/28/2000 +! +! +! Wolfgang Schadow +! TRIUMF +! 4004 Wesbrook Mall +! Vancouver, B.C. V6T 2A3 +! Canada +! +! email: schadow@triumf.ca or schadow@physik.uni-bonn.de +! +! www : http://www.triumf.ca/people/schadow +! +! +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! +! Copyright (C) 2000 Wolfgang Schadow +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Library General Public +! License as published by the Free Software Foundation; either +! version 2 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Library General Public License for more details. +! +! You should have received a copy of the GNU Library General Public +! License along with this library; if not, write to the +! Free Software Foundation, Inc., 59 Temple Place - Suite 330, +! Boston, MA 02111-1307, USA. +! +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +!infmod +!remove unused routines +!module numeric + +! integer, parameter :: sgl = kind(1.0) +! integer, parameter :: dbl = kind(1.0d0) + +!end module numeric + +module numeric + use infprec + integer, parameter :: sgl = kind(1.0) + integer, parameter :: dbl = kp +end module numeric +!end infmod + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +module bspline + +! +! ------------------------------------------------------------------ +! +! +! The following routines are included: +! +! dbsnak +! +! dbsint +! dbsval +! dbsder +! dbs1gd +! +! dbs2in +! dbs2dr +! dbs2vl +! dbs2gd +! +! dbs3in +! dbs3vl +! dbs3dr +! dbs3gd +! +! ------------------------------------------------------------------ +! + + private + + public dbsnak + public dbsint, dbsval + + +contains + + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine dbsnak(nx,xvec,kxord,xknot) + +! +! Compute the `not-a-knot' spline knot sequence. +! (see de Boor p. 167) +! +! nx - number of data points. (input) +! xvec - array of length ndata containing the location of the +! data points. (input) +! kxord - order of the spline. (input) +! xknot - array of length ndata+korder containing the knot +! sequence. (output) +! + + use numeric + + implicit none + + integer, intent(in) :: nx, kxord + + real(kind=dbl), dimension(nx), intent(in) :: xvec + real(kind=dbl), dimension(nx+kxord), intent(out) :: xknot + + real(kind=dbl) :: eps + integer :: ix + +!infmod +! logical :: first = .true. +! save first,eps + + +! if (first) then +! first=.false. + eps = epsilon(1.0_dbl) +! write(*,*) "subroutine dbsnak: " +! write(*,*) "eps = ",eps +! endif +!end infmod + + if((kxord .lt. 0) .or. (kxord .gt. nx)) then + write(*,*) "subroutine dbsnak: error" + write(*,*) "0 <= kxord <= nx is required." + write(*,*) "kxord = ", kxord, " and nx = ", nx, " is given." + stop + endif + + do ix = 1, kxord + xknot(ix) = xvec(1) + end do + + if(mod(kxord,2) .eq. 0) then + do ix = kxord+1, nx + xknot(ix) = xvec(ix-kxord/2) + end do + else + do ix = kxord+1, nx + xknot(ix) = 0.5_dbl * (xvec(ix-kxord/2) + xvec(ix-kxord/2-1)) + end do + endif + + do ix = nx+1, nx+kxord + xknot(ix) = xvec(nx) * (1.0_dbl + eps) + end do + + end subroutine dbsnak + + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine dbsint(nx,xvec,xdata,kx,xknot,bcoef) + +! +! Computes the spline interpolant, returning the B-spline coefficients. +! (see de Boor p. 204) +! +! nx - number of data points. (input) +! xvec - array of length nx containing the data point +! abscissas. (input) +! xdata - array of length ndata containing the data point +! ordinates. (input) +! kx - order of the spline. (input) +! korder must be less than or equal to ndata. +! xknot - array of length nx+kx containing the knot +! sequence. (input) +! xknot must be nondecreasing. +! bscoef - array of length ndata containing the B-spline +! coefficients. (output) +! + + use numeric + + implicit none + + integer, intent(in) :: nx, kx + real(kind=dbl), dimension(nx), intent(in) :: xdata, xvec + real(kind=dbl), dimension(nx+kx), intent(in) :: xknot + real(kind=dbl), dimension(nx), intent(out) :: bcoef + + integer :: nxp1, kxm1, kpkm2, leftx, lenq + integer :: ix, ik,ilp1mx, jj, iflag + real(kind=dbl) :: xveci + real(kind=dbl), dimension((2*kx-1)*nx) :: work + + + nxp1 = nx + 1 + kxm1 = kx - 1 + kpkm2 = 2 * kxm1 + leftx = kx + lenq = nx * (kx + kxm1) + + do ix = 1, lenq + work(ix) = 0.0_dbl + end do + + do ix = 1, nx + xveci = xvec(ix) + ilp1mx = min0(ix+kx,nxp1) + leftx = max0(leftx,ix) + if (xveci .lt. xknot(leftx)) goto 998 +30 if (xveci .lt. xknot(leftx+1)) go to 40 + leftx = leftx + 1 + if (leftx .lt. ilp1mx) go to 30 + leftx = leftx - 1 + if (xveci .gt. xknot(leftx+1)) goto 998 +40 call bsplvb (xknot,nx+kx,kx,1,xveci,leftx,bcoef) + jj = ix - leftx + 1 + (leftx - kx) * (kx + kxm1) + do ik = 1, kx + jj = jj + kpkm2 + work(jj) = bcoef(ik) + end do + end do + + call banfac(work,kx+kxm1,nx,kxm1,kxm1,iflag) + + if (iflag .ne. 1) then + write(*,*) "subroutine dbsint: error" + write(*,*) "no solution of linear equation system !!!" + stop + end if + + do ix = 1, nx + bcoef(ix) = xdata(ix) + end do + + call banslv(work,kx+kxm1,nx,kxm1,kxm1,bcoef) + + return + +998 write(*,*) "subroutine dbsint:" + write(*,*) "xknot(ix) <= xknot(ix+1) required." + write(*,*) ix,xknot(ix),xknot(ix+1) + + stop + + end subroutine dbsint + + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + function dbsval(x,kx,xknot,nx,bcoef) + +! +! Evaluates a spline, given its B-spline representation. +! +! x - point at which the spline is to be evaluated. (input) +! kx - order of the spline. (input) +! xknot - array of length nx+kx containing the knot +! sequence. (input) +! xknot must be nondecreasing. +! nx - number of B-spline coefficients. (input) +! bcoef - array of length nx containing the B-spline +! coefficients. (input) +! dbsval - value of the spline at x. (output) +! + + use numeric + + implicit none + + integer, intent(in) :: nx, kx + real(kind=dbl) :: dbsval + real(kind=dbl) :: x + real(kind=dbl), dimension(nx+kx), intent(in) :: xknot + real(kind=dbl), dimension(nx), intent(in) :: bcoef + + integer :: il, ik, ix, leftx + real(kind=dbl) :: save1, save2 + real(kind=dbl), dimension(kx) :: work, dl, dr + +! +! check if xknot(i) <= xknot(i+1) and calculation of i so that +! xknot(i) <= x < xknot(i+1) +! + + leftx = 0 + + do ix = 1,nx+kx-1 + if (xknot(ix) .gt. xknot(ix+1)) then + write(*,*) "subroutine dbsval:" + write(*,*) "xknot(ix) <= xknot(ix+1) required." + write(*,*) ix,xknot(ix),xknot(ix+1) + stop + endif + if((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) leftx = ix + end do + + if(leftx .eq. 0) then + write(*,*) "subroutine dbsval:" + write(*,*) "ix with xknot(ix) <= x < xknot(ix+1) required." + write(*,*) "x = ", x + stop + endif + + do ik = 1, kx-1 + work(ik) = bcoef(leftx+ik-kx) + dl(ik) = x - xknot(leftx+ik-kx) + dr(ik) = xknot(leftx+ik) - x + end do + + work(kx) = bcoef(leftx) + dl(kx) = x - xknot(leftx) + + do ik = 1, kx-1 + save2 = work(ik) + do il = ik+1, kx + save1 = work(il) + work(il) = (dl(il) * work(il) + dr(il-ik) * save2) & + & / (dl(il) + dr(il - ik)) + save2 = save1 + end do + end do + + dbsval = work(kx) + + end function dbsval + + + + + subroutine bsplvb(t,n,jhigh,index,x,left,biatx) + + use numeric + + implicit none + + integer, intent(in) :: n, jhigh, index, left + + real(kind=dbl), intent(in) :: x + real(kind=dbl), dimension(n), intent(in) :: t + real(kind=dbl), dimension(jhigh), intent(out) :: biatx + + integer :: j = 1 + integer :: i, jp1 + real(kind=dbl) :: saved, term + real(kind=dbl), dimension(jhigh) :: dl, dr + + + if (index .eq. 1) then + j = 1 + biatx(1) = 1.0_dbl + if (j .ge. jhigh) return + end if + +20 jp1 = j + 1 + + dr(j) = t(left+j) - x + dl(j) = x - t(left+1-j) + saved = 0._dbl + + do i = 1, j + term = biatx(i) / (dr(i) + dl(jp1-i)) + biatx(i) = saved + dr(i) * term + saved = dl(jp1-i) * term + end do + + biatx(jp1) = saved + j = jp1 + + if (j .lt. jhigh) go to 20 + + end subroutine bsplvb + + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine banfac(w,nroww,nrow,nbandl,nbandu,iflag) + + use numeric + + implicit none + + integer, intent(in) :: nroww,nrow + integer, intent(in) :: nbandl,nbandu + integer, intent(out) :: iflag + real(kind=dbl), dimension(nroww,nrow), intent(inout) :: w + + real(kind=dbl) :: pivot, factor + integer :: middle, nrowm1, jmax, kmax, ipk, midmk, i, j, k + + + iflag = 1 + middle = nbandu + 1 + nrowm1 = nrow - 1 + + if (nrowm1 .lt. 0) goto 999 + if (nrowm1 .eq. 0) goto 900 + if (nrowm1 .gt. 0) goto 10 + +10 if (nbandl .gt. 0) go to 30 + + do i = 1, nrowm1 + if (w(middle,i) .eq. 0._dbl) go to 999 + end do + + go to 900 + +30 if (nbandu .gt. 0) go to 60 + + do i = 1, nrowm1 + pivot = w(middle,i) + if(pivot .eq. 0._dbl) go to 999 + jmax = min0(nbandl, nrow - i) + do j = 1, jmax + w(middle+j,i) = w(middle+j,i) / pivot + end do + end do + + return + +60 do i = 1, nrowm1 + pivot = w(middle,i) + if (pivot .eq. 0._dbl) go to 999 + jmax = min0(nbandl,nrow - i) + do j = 1,jmax + w(middle+j,i) = w(middle+j,i) / pivot + end do + + kmax = min0(nbandu,nrow - i) + + do k = 1, kmax + ipk = i + k + midmk = middle - k + factor = w(midmk,ipk) + do j = 1, jmax + w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i) & + & * factor + end do + end do + end do + +900 if (w(middle,nrow) .ne. 0._dbl) return +999 iflag = 2 + + end subroutine banfac + + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine banslv(w,nroww,nrow,nbandl,nbandu,b) + + use numeric + + implicit none + + integer, intent(in) :: nroww,nrow + integer, intent(in) :: nbandl,nbandu + real(kind=dbl), dimension(nroww,nrow), intent(in) :: w + real(kind=dbl), dimension(nrow), intent(inout) :: b + + integer :: middle, nrowm1, jmax, i, j + + middle = nbandu + 1 + if (nrow .eq. 1) goto 99 + nrowm1 = nrow - 1 + if (nbandl .eq. 0) goto 30 + + do i = 1, nrowm1 + jmax = min0(nbandl, nrow - i) + do j = 1, jmax + b(i+j) = b(i+j) - b(i) * w(middle+j,i) + end do + end do + +30 if (nbandu .gt. 0) goto 50 + + do i = 1, nrow + b(i) = b(i) / w(1,i) + end do + + return + +50 do i = nrow, 2, -1 + b(i) = b(i)/w(middle,i) + jmax = min0(nbandu,i-1) + do j = 1, jmax + b(i-j) = b(i-j) - b(i) * w(middle-j,i) + end do + end do + +99 b(1) = b(1) / w(middle,1) + + end subroutine banslv + + + +end module bspline diff --git a/fieldinf/cosmopar.f90 b/fieldinf/cosmopar.f90 new file mode 100644 index 0000000..d22a1ea --- /dev/null +++ b/fieldinf/cosmopar.f90 @@ -0,0 +1,18 @@ +module cosmopar + use infprec, only : kp + implicit none + + public + + real(kp), parameter :: HubbleSquareRootOf3OmegaRad = 7.4585d-63 + real(kp), parameter :: HubbleSquareRootOf2OmegaRad = sqrt(2._kp/3._kp)*HubbleSquareRootOf3OmegaRad + + real(kp), parameter :: lnMpcToKappa = 130.282_kp +!1MeV +!! real(kp), parameter :: lnRhoNuc = -196.97 +!10MeV + real(kp), parameter :: lnRhoNuc = -187.747 +!100MeV +!! real(kp), parameter :: lnRhoNuc = -178.55 + +end module cosmopar diff --git a/fieldinf/hyper2F1.f90 b/fieldinf/hyper2F1.f90 new file mode 100644 index 0000000..4343119 --- /dev/null +++ b/fieldinf/hyper2F1.f90 @@ -0,0 +1,1871 @@ +!============== START HYP_2F1 FILE ==================================== +! +! Gamma_inv denotes the entire inverse of the Gamma function. +! F(z) means 2F1(a,b,c,z) with the a, b, c and z given as inputs +! in the routine. +! +! Elementary functions and standard constants +! are defined in the module. +! See N.J.~Higham, ``Accuracy and Stability of Numerical Algorithms'', +! SIAM, Philadelphia, 1996 for expm1 implementation. +! log1p follows instantly. +! +!---------------------------------------------------------------------- +MODULE HYP_2F1_MODULE + !-------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, PARAMETER :: PR=KIND(1.0D0),IPR=KIND(1) + REAL(PR) :: EPS15=1.0D-15 + REAL(PR) :: ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,HALF=0.50D0 + REAL(PR) :: M_PI=3.14159265358979323846D0 + REAL(PR) :: M_PI_2=1.57079632679489661923D0 + REAL(PR) :: M_1_PI=0.31830988618379067154D0 +CONTAINS + ! + FUNCTION INF_NORM(Z) + COMPLEX(PR),INTENT(IN) :: Z + REAL(PR) :: INF_NORM + INF_NORM=MAX(ABS(REAL(Z,PR)),ABS(AIMAG(Z))) + RETURN + END FUNCTION INF_NORM + ! + FUNCTION TANZ(Z) + COMPLEX(PR),INTENT(IN) :: Z + COMPLEX(PR) :: TANZ + TANZ=SIN(Z)/COS(Z) + RETURN + END FUNCTION TANZ + ! + FUNCTION LOG1P(Z) + COMPLEX(PR),INTENT(IN) :: Z + REAL(PR) :: X,XP1,LOG1P_X + REAL(PR) :: Y,YX,YX2,YX2P1,LOG1P_YX2 + REAL(PR) :: RE_LOG1P,IM_LOG1P + COMPLEX(PR) :: LOG1P + IF(INF_NORM(Z).LT.ONE) THEN + X = REAL(Z,PR); XP1 = X+ONE + IF(XP1.EQ.ONE) THEN + LOG1P_X = X + ELSE + LOG1P_X = LOG(XP1)*X/(XP1-ONE) + ENDIF + Y = AIMAG(Z) + YX = Y/XP1; YX2 = YX*YX; YX2P1 = YX2+ONE + IF(YX2P1.EQ.ONE) THEN + LOG1P_YX2 = YX2 + ELSE + LOG1P_YX2 = LOG(YX2P1)*YX2/(YX2P1-ONE) + ENDIF + RE_LOG1P = LOG1P_X + HALF*LOG1P_YX2 + IM_LOG1P = ATAN2(Y,XP1) + LOG1P = CMPLX(RE_LOG1P,IM_LOG1P,PR) + RETURN + ELSE + LOG1P=LOG(ONE+Z) + RETURN + ENDIF + END FUNCTION LOG1P + ! + FUNCTION EXPM1(Z) + COMPLEX(PR),INTENT(IN) :: Z + REAL(PR) :: X,EXPM1_X,EXP_X,Y,SIN_HALF_Y + REAL(PR) :: RE_EXPM1,IM_EXPM1 + COMPLEX(PR) :: EXPM1 + IF(INF_NORM(Z).LT.ONE) THEN + X = REAL(Z,PR); EXP_X = EXP(X) + Y = AIMAG(Z); SIN_HALF_Y=SIN(HALF*Y) + IF(EXP_X.EQ.ONE) THEN + EXPM1_X = X + ELSE + EXPM1_X = (EXP_X-ONE)*X/LOG(EXP_X) + ENDIF + RE_EXPM1 = EXPM1_X-TWO*EXP_X*SIN_HALF_Y*SIN_HALF_Y + IM_EXPM1 = EXP_X*SIN(Y) + EXPM1 = CMPLX(RE_EXPM1,IM_EXPM1,PR) + RETURN + ELSE + EXPM1=EXP(Z)-ONE + RETURN + ENDIF + END FUNCTION EXPM1 + ! +END MODULE HYP_2F1_MODULE +! +!---------------------------------------------------------------------- + +RECURSIVE FUNCTION LOG_GAMMA_CPLX(Z) RESULT(RES) +!---------------------------------------------------------------------- +! Logarithm of Gamma[z] and Gamma inverse function +! ------------------------------------------------ +! +! For log[Gamma[z]],if z is not finite +! or is a negative integer, the program +! returns an error message and stops. +! The Lanczos method is used. Precision : ~ 1E-15 +! The method works for Re[z]>0.5 . +! If Re[z]<=0.5, one uses the formula Gamma[z].Gamma[1-z]=Pi/sin(Pi.z) +! log[sin(Pi.z)] is calculated with the Kolbig method +! (K.S. Kolbig, Comp. Phys. Comm., Vol. 4, p.221(1972)): +! If z=x+iy and y>=0, log[sin(Pi.z)]=log[sin(Pi.eps)]-i.Pi.n, +! with z=n+eps so 0<=Re[eps]< 1 and n integer. +! If y>110, log[sin(Pi.z)]=-i.Pi.z+log[0.5]+i.Pi/2 +! numerically so that no overflow can occur. +! If z=x+iy and y< 0, log[Gamma(z)]=[log[Gamma(z*)]]*, +! so that one can use the previous formula with z*. +! +! For Gamma inverse, Lanczos method is also used +! with Euler reflection formula. +! sin (Pi.z) is calculated as sin (Pi.(z-n)) +! to avoid inaccuracy with z = n + eps +! with n integer and |eps| as small as possible. +! +! +! Variables: +! ---------- +! x,y: Re[z], Im[z] +! log_sqrt_2Pi,log_Pi : log[sqrt(2.Pi)], log(Pi). +! sum : Rational function in the Lanczos method +! log_Gamma_z : log[Gamma(z)] value. +! c : table containing the fifteen coefficients in the expansion +! used in the Lanczos method. +! eps,n : z=n+eps so 0<=Re[eps]< 1 and n integer for Log[Gamma]. +! z=n+eps and n integer +! so |eps| is as small as possible for Gamma_inv. +! log_const : log[0.5]+i.Pi/2 +! g : coefficient used in the Lanczos formula. It is here 607/128. +! z,z_m_0p5,z_p_g_m0p5,zm1 : argument of the Gamma function, +! z-0.5, z-0.5+g, z-1 +! res: returned value +!---------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: Z + INTEGER(IPR) :: N,I + REAL(PR) :: X,Y,LOG_SQRT_2PI,G,LOG_PI,M_LN2,C(0:14) + COMPLEX(PR) :: GAMMA_SUM,Z_M_0P5,Z_P_G_M0P5,ZM1 + COMPLEX(PR) :: LOG_CONST,I_PI,EPS,LOG_SIN_PI_Z,RES + ! + M_LN2=0.69314718055994530942D0; X=REAL(Z,PR); Y=AIMAG(Z) + IF((Z.EQ.NINT(X)).AND.(X.LE.ZERO)) & + STOP 'Z IS NEGATIVE INTEGER IN LOG_GAMMA_CPLX' + IF(X.GE.HALF) THEN + LOG_SQRT_2PI=0.91893853320467274177D0; G=4.7421875D0 + Z_M_0P5=Z-HALF; Z_P_G_M0P5=Z_M_0P5+G; ZM1=Z-ONE + C=(/ 0.99999999999999709182D0,57.156235665862923517D0, & + -59.597960355475491248D0, 14.136097974741747174D0, & + -0.49191381609762019978D0, 0.33994649984811888699D-4, & + 0.46523628927048575665D-4, -0.98374475304879564677D-4, & + 0.15808870322491248884D-3, -0.21026444172410488319D-3, & + 0.21743961811521264320D-3, -0.16431810653676389022D-3, & + 0.84418223983852743293D-4, -0.26190838401581408670D-4, & + 0.36899182659531622704D-5 /) + + GAMMA_SUM=C(0) + DO I=1,14 + GAMMA_SUM=GAMMA_SUM+C(I)/(ZM1+I) + ENDDO + RES=LOG_SQRT_2PI+LOG(GAMMA_SUM)+Z_M_0P5*LOG(Z_P_G_M0P5) & + -Z_P_G_M0P5 + RETURN + ELSE IF(Y.GE.ZERO) THEN + IF(X.LT.NINT(X)) THEN + N=NINT(X)-1 + ELSE + N=NINT(X) + ENDIF + LOG_PI=1.1447298858494002D0 + LOG_CONST=CMPLX(-M_LN2,M_PI_2,PR); I_PI=CMPLX(ZERO,M_PI,PR) + EPS=Z-N + IF(Y.GT.110.0D0) THEN + LOG_SIN_PI_Z=-I_PI*Z+LOG_CONST + ELSE + LOG_SIN_PI_Z=LOG(SIN(M_PI*EPS))-I_PI*N + ENDIF + RES=LOG_PI-LOG_SIN_PI_Z-LOG_GAMMA_CPLX(ONE-Z); + RETURN + ELSE + RES=CONJG(LOG_GAMMA_CPLX(CONJG(Z))) + RETURN + ENDIF +END FUNCTION LOG_GAMMA_CPLX +! +!---------------------------------------------------------------------- +! Inverse of the Gamma function [1/Gamma](z) +! ------------------------------------------ +! It is calculated with the Lanczos method for Re[z] >= 0.5 +! and is precise up to 10^{-15}. +! If Re[z] <= 0.5, one uses the formula +! Gamma[z].Gamma[1-z] = Pi/sin (Pi.z). +! sin (Pi.z) is calculated as sin (Pi.(z-n)) to avoid inaccuracy, +! with z = n + eps with n integer and |eps| as small as possible. +! +! Variables +! --------- +! z : argument of the function +! x: Re[z] +! eps,n : z = n + eps with n integer and |eps| as small as possible. +! res: returned value +!---------------------------------------------------------------------- +RECURSIVE FUNCTION GAMMA_INV(Z) RESULT(RES) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: Z + INTEGER(IPR) :: N,I + REAL(PR) :: X,LOG_SQRT_2PI,G,C(0:14) + COMPLEX(PR) :: RES,GAMMA_SUM,Z_M_0P5,Z_P_G_M0P5,ZM1,EPS + ! + X=REAL(Z,PR) + IF(X.GE.HALF) THEN + LOG_SQRT_2PI=0.91893853320467274177D0; G=4.7421875D0 + Z_M_0P5=Z-HALF; Z_P_G_M0P5=Z_M_0P5+G; ZM1=Z-ONE + C=(/ 0.99999999999999709182D0,57.156235665862923517D0, & + -59.597960355475491248D0, 14.136097974741747174D0, & + -0.49191381609762019978D0, 0.33994649984811888699D-4, & + 0.46523628927048575665D-4, -0.98374475304879564677D-4, & + 0.15808870322491248884D-3, -0.21026444172410488319D-3, & + 0.21743961811521264320D-3, -0.16431810653676389022D-3, & + 0.84418223983852743293D-4, -0.26190838401581408670D-4, & + 0.36899182659531622704D-5 /) + + GAMMA_SUM=C(0) + DO I=1,14 + GAMMA_SUM=GAMMA_SUM+C(I)/(ZM1+I); + ENDDO + RES=EXP(Z_P_G_M0P5-Z_M_0P5*LOG(Z_P_G_M0P5)-LOG_SQRT_2PI) & + /GAMMA_SUM + RETURN + ELSE + X=REAL(Z,PR); N=NINT(X) + EPS=Z-N + IF(MOD(N,2).EQ.0) THEN + RES=SIN(M_PI*EPS)*M_1_PI/GAMMA_INV (ONE-Z) + RETURN + ELSE + RES=-SIN(M_PI*EPS)*M_1_PI/GAMMA_INV (ONE-Z) + RETURN + ENDIF + ENDIF +END FUNCTION GAMMA_INV +!---------------------------------------------------------------------- +! +! Calculation of H(z,eps) = [Gamma(z+eps)/Gamma(z) - 1]/eps, with e and +! --------------------------------------------------------------------- +! z complex so z,z+eps are not negative integers and 0 <= |eps|oo < 0.1 +! --------------------------------------------------------------------- +! The function H(z,eps) = [Gamma(z+eps)/Gamma(z) - 1]/e is calculated +! here with the Lanczos method. +! For the Lanczos method, the gamma parameter, denoted as g, +! is 4.7421875 and one uses a sum of 15 numbers with the table c[15], +! so that it is precise up to machine accuracy. +! The H(z,eps) function is used in formulas occuring in1-z and 1/z +! transformations (see Comp. Phys. Comm. paper). +! +! One must have z and z+eps not negative integers as otherwise +! it is clearly not defined. +! As this function is meant to be precise for small |eps|oo, +! one has to have 0 <= |eps|oo < 0.1 . +! Indeed, a direct implementation of H(z,eps) with Gamma_inv or +! log_Gamma for |eps|oo >= 0.1 is numerically stable. +! The returned function has full numerical accuracy +! even if |eps|oo is very small. +! +! eps not equal to zero +! --------------------- +! If Re(z) >= 0.5 or Re(z+eps) >= 0.5, one clearly has Re(z) > 0.4 +! and Re(z+eps) > 0.4, +! so that the Lanczos summation can be used for both Gamma(z) +! and Gamma(z+eps). +! One then has: +! log[Gamma(z+eps)/Gamma(z)] = +! (z-0.5) log1p[eps/(z+g-0.5)] + eps log(z+g-0.5+eps) - eps +! + log1p[-eps \sum_{i=1}^{14} c[i]/((z-1+i)(z-1+i+eps)) +! / (c[0] + \sum_{i=1}^{14} c[i]/(z-1+i))] +! H(z,eps) = expm1[log[Gamma(z+eps)/Gamma(z)]]/eps . +! +! If Re(z) < 0.5 and Re(z+eps) < 0.5, +! Euler reflection formula is used for both Gamma(z) and Gamma(z+eps). +! One then has: +! H(z+eps,-eps) = [cos(pi.eps) + sin(pi.eps)/tan(pi(z-n))].H(1-z,-eps) +! + (2/eps).sin^2(eps.pi/2) - sin(pi.eps)/(eps.tan(pi.(z-n))) +! H(1-z,-eps) is calculated with the Lanczos summation +! as Re(1-z) >= 0.5 and Re(1-z-eps) >= 0.5 . +! z-n is used in tan(pi.z) instead of z to avoid inaccuracies +! due the finite number of digits of pi. +! H(z,eps) = H(z+eps,-eps)/(1 - eps.H(z+eps,-eps)) +! provides the final result. +! +! eps equal to zero +! ----------------- +! It is obtained with the previous case and eps -> 0 : +! If Re(z) >= 0.5, one has: +! H(z,eps) = (z-0.5)/(z+g-0.5) + log(z+g-0.5) - 1 - +! \sum_{i=1}^{14} c[i]/((z-1+i)^2)/(c[0]+\sum_{i=1}^{14} c[i]/(z-1+i)) +! +! If Re(z) < 0.5, one has: +! H(z,0) = H(1-z,0) - pi/tan(pi.(z-n)) +! +! Variables +! --------- +! z,eps: input variables of the function H(z,eps) +! g,c[15]: double and table of 15 doubles defining the Lanczos sum +! so that it provides the Gamma function +! precise up to machine accuracy. +! eps_pz,z_m_0p5,z_pg_m0p5,eps_pz_pg_m0p5,zm1,zm1_p_eps: +! z+eps,z-0.5,z+g-0.5,z+eps+g-0.5,z-1,z-1+eps +! x,eps_px: real parts of z and z+eps. +! n,m: closest integer ot the real part of z, same for z+eps. +! sum_num,sum_den: \sum_{i=1}^{14} c[i]/((z-1+i)(z-1+i+eps)) +! and (c[0] + \sum_{i=1}^{14} c[i]/(z-1+i)). +! They appear respectively as numerator and denominator in formulas. +! Pi_eps,term,T1_eps_z: pi.eps, sin (pi.eps)/tan(pi.(z-n)), +! [cos(pi.eps) + sin(pi.eps)/tan(pi(z-n))].H(1-z,-eps) +! sin_Pi_2_eps,T2_eps_z,T_eps_z: sin^2(eps.pi/2), +! (2/eps).sin^2(eps.pi/2) - sin(pi.eps)/(eps.tan(pi.(z-n))), +! H(z+eps,-eps) +! res: returned value +!---------------------------------------------------------------------- +RECURSIVE FUNCTION GAMMA_RATIO_DIFF_SMALL_EPS(Z,EPS) RESULT(RES) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: Z,EPS + INTEGER(IPR) :: N,M,I + REAL(PR) :: G,X,EPS_PX,C(0:14) + COMPLEX(PR) :: RES,SUM_NUM,SUM_DEN + COMPLEX(PR) :: EPS_PZ,Z_M_0P5,Z_PG_M0P5,EPS_PZ_PG_M0P5,ZM1 + COMPLEX(PR) :: CI_ZM1_PI_INV,PI_EPS,TT,T1_EPS_Z,SIN_PI_2_EPS + COMPLEX(PR) :: ZM1_P_EPS,T2_EPS_Z,T_EPS_Z + ! + G=4.74218750D0 + IF(INF_NORM(EPS).GT.0.1D0) & + STOP 'ONE MUST HAVE |EPS|< 0.1 IN GAMMA_RATIO_DIFF_SMALL_EPS' + EPS_PZ=Z+EPS; Z_M_0P5=Z-HALF; Z_PG_M0P5=Z_M_0P5+G + EPS_PZ_PG_M0P5=Z_PG_M0P5+EPS; ZM1=Z-ONE; ZM1_P_EPS=ZM1+EPS + X=REAL(Z,PR); EPS_PX=REAL(EPS_PZ,PR); N=NINT(X); M=NINT(EPS_PX) + IF((Z.EQ.N).AND.(N.LE.0)) THEN + STOP 'Z IS NEGATIVE INTEGER IN GAMMA_RATIO_DIFF_SMALL_EPS' + ENDIF + IF((EPS_PZ.EQ.M).AND.(M.LE.0)) THEN + STOP 'Z+EPS IS NEGATIVE INTEGER IN GAMMA_RATIO_DIFF_SMALL_EPS' + ENDIF + C=(/ 0.99999999999999709182D0,57.156235665862923517D0, & + -59.597960355475491248D0,14.136097974741747174D0, & + -0.49191381609762019978D0,0.33994649984811888699D-4, & + 0.46523628927048575665D-4,-0.98374475304879564677D-4, & + 0.15808870322491248884D-3,-0.21026444172410488319D-3, & + 0.21743961811521264320D-3,-0.16431810653676389022D-3, & + 0.84418223983852743293D-4,-0.26190838401581408670D-4, & + 0.36899182659531622704D-5 /) + IF((X.GE.HALF).OR.(EPS_PX.GE.HALF)) THEN + SUM_NUM=ZERO;SUM_DEN=C(0) + DO I=1,14 + CI_ZM1_PI_INV=C(I)/(ZM1+I) + SUM_NUM=SUM_NUM+CI_ZM1_PI_INV/(ZM1_P_EPS+I) + SUM_DEN=SUM_DEN+CI_ZM1_PI_INV + ENDDO + IF(EPS.NE.ZERO) THEN + RES=EXPM1(Z_M_0P5*LOG1P(EPS/Z_PG_M0P5) & + +EPS*LOG(EPS_PZ_PG_M0P5)-EPS+LOG1P(-EPS*SUM_NUM/SUM_DEN))& + /EPS + RETURN + ELSE + RES=Z_M_0P5/Z_PG_M0P5 & + +LOG(EPS_PZ_PG_M0P5)-ONE-SUM_NUM/SUM_DEN + RETURN + ENDIF + ELSE + IF(EPS.NE.ZERO) THEN + PI_EPS=M_PI*EPS + TT=SIN(PI_EPS)/TANZ(M_PI*(Z-N)) + T1_EPS_Z=(COS(PI_EPS)+TT)*& + GAMMA_RATIO_DIFF_SMALL_EPS(ONE-Z,-EPS) + SIN_PI_2_EPS=SIN(M_PI_2*EPS) + T2_EPS_Z=(TWO*SIN_PI_2_EPS*SIN_PI_2_EPS-TT)/EPS + T_EPS_Z=T1_EPS_Z+T2_EPS_Z + RES=(T_EPS_Z/(ONE-EPS*T_EPS_Z)) + RETURN + ELSE + RES=GAMMA_RATIO_DIFF_SMALL_EPS(ONE-Z,-EPS) & + -M_PI/TANZ(M_PI*(Z-N)) + RETURN + ENDIF + ENDIF +END FUNCTION GAMMA_RATIO_DIFF_SMALL_EPS +! +!---------------------------------------------------------------------- +! Calculation of G(z,eps) = [Gamma_inv(z) - Gamma_inv(z+eps)]/eps +! --------------------------------------------------------------- +! with e and z complex +!--------------------- +! The G(z,eps) function is used in formulas occuring in 1-z +! and 1/z transformations (see Comp. Phys. Comm. paper). +! Several case have to be considered for its evaluation. +! eps is considered equal to zero +! if z+eps and z are equal numerically. +! +! |eps|oo > 0.1 +! ------------- +! A direct evaluation with the values Gamma_inv(z) +! and Gamma_inv(z+eps) is stable and returned. +! +! |eps|oo <= 0.1 with z+eps and z numerically different +! ----------------------------------------------------- +! If z is a negative integer, z+eps is not, +! so that G(z,eps) = -Gamma_inv(z+eps)/eps, +! for which a direct evaluation is precise and returned. +! If z+eps is a negative integer, z is not, +! so that G(z,eps) = Gamma_inv(z)/eps, +! for which a direct evaluation is precise and returned. +! If both of them are not negative integers, +! one looks for the one of z and z+eps +! which is the closest to a negative integer. +! If it is z, one returns H(z,eps).Gamma_inv(z+eps). +! If it is z+eps, one returns H(z+eps,-eps).Gamma_inv(z). +! Both values are equal, so that one chooses the one +! which makes the Gamma ratio Gamma(z+eps)/Gamma(z) +! in H(z,eps) the smallest in modulus. +! +! z+eps and z numerically equal +! ----------------------------- +! If z is negative integer, G(z,0) = (-1)^(n+1) n!, +! where z = -n, n integer, which is returned. +! If z is not negative integer, one returns H(z,eps).Gamma_inv(z+eps) +! +! Variables +! --------- +! z,eps: input variables of the function G(z,eps) +! eps_pz,x,eps_px: z+eps,real parts of z and z+eps. +! n,m: closest integer ot the real part of z, same for z+eps. +! fact,k: (-1)^(n+1) n!, returned when z = -n, n integer +! and z and z+eps identical numerically (eps ~ 0). +! It is calculated with integer index k. +! is_z_negative_integer,is_eps_pz_negative_integer: +! true if z is a negative integer, false if not, same for z+eps. +! z_neg_int_distance, eps_pz_neg_int_distance: +! |z + |n||oo, |z + eps + |m||oo. +! If |z + |n||oo < |z + eps + |m||oo, +! z is closer to the set of negative integers than z+eps. +! Gamma_inv(z+eps) is then of moderate modulus +! if Gamma_inv(z) is very small. +! If z ~ n, H(z,eps) ~ -1/eps, +! that so returning +! G(z,eps) = H(z,eps).Gamma_inv(z+eps) here is preferred. +! Same for |z + |n||oo > |z + eps + |m||oo with z <-> z+eps. +! +!---------------------------------------------------------------------- +FUNCTION GAMMA_INV_DIFF_EPS(Z,EPS) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: Z,EPS + INTEGER(IPR) :: M,N,K + REAL(PR) :: X,EPS_PX,FACT + REAL(PR) :: Z_NEG_INT_DISTANCE + REAL(PR) :: EPS_PZ_NEG_INT_DISTANCE + COMPLEX(PR) :: GAMMA_INV_DIFF_EPS,EPS_PZ,GAMMA_INV + COMPLEX(PR) :: GAMMA_RATIO_DIFF_SMALL_EPS + LOGICAL :: IS_Z_NEG_INT,IS_EPS_PZ_NEG_INT + + EPS_PZ=Z+EPS; X=REAL(Z,PR); EPS_PX=REAL(EPS_PZ,PR) + N=NINT(X); M=NINT(EPS_PX) + IS_Z_NEG_INT=(Z.EQ.N).AND.(N.LE.0) + IS_EPS_PZ_NEG_INT=(EPS_PZ.EQ.M).AND.(M.LE.0) + IF(INF_NORM(EPS).GT.0.10D0) THEN + GAMMA_INV_DIFF_EPS = (GAMMA_INV (Z) - GAMMA_INV (EPS_PZ))/EPS + RETURN + ELSE IF(EPS_PZ.NE.Z) THEN + IF(IS_Z_NEG_INT) THEN + GAMMA_INV_DIFF_EPS = (-GAMMA_INV (EPS_PZ)/EPS) + RETURN + ELSE IF(IS_EPS_PZ_NEG_INT) THEN + GAMMA_INV_DIFF_EPS = (GAMMA_INV (Z)/EPS) + RETURN + ELSE + Z_NEG_INT_DISTANCE = INF_NORM (Z + ABS (N)) + EPS_PZ_NEG_INT_DISTANCE = INF_NORM (EPS_PZ + ABS (M)) + IF(Z_NEG_INT_DISTANCE.LT.EPS_PZ_NEG_INT_DISTANCE) THEN + GAMMA_INV_DIFF_EPS= & + GAMMA_RATIO_DIFF_SMALL_EPS (Z,EPS)*GAMMA_INV (EPS_PZ) + RETURN + ELSE + GAMMA_INV_DIFF_EPS= & + GAMMA_RATIO_DIFF_SMALL_EPS (EPS_PZ,-EPS)*GAMMA_INV (Z) + RETURN + ENDIF + ENDIF + ELSE IF(IS_Z_NEG_INT.AND.IS_EPS_PZ_NEG_INT) THEN + FACT = -ONE;K=-1 + DO WHILE (K.GE.N) + FACT=FACT*K + K=K-1 + ENDDO + GAMMA_INV_DIFF_EPS = FACT + RETURN + ELSE + GAMMA_INV_DIFF_EPS = & + GAMMA_RATIO_DIFF_SMALL_EPS (Z,EPS)*GAMMA_INV (EPS_PZ) + RETURN + ENDIF +END FUNCTION GAMMA_INV_DIFF_EPS +!---------------------------------------------------------------------- +! +! Calculation of Gamma_inv(1-m-eps)/eps of the A(z) polynomial in 1-z +! ------------------------------------------------------------------- +! and 1/z transformations +! ----------------------- +! This value occurs in A(z) in 1-z and 1/z transformations +! (see Comp. Phys. Comm. paper) for m > 0. +! Both cases of 1-m-eps numerically negative integer +! or not have to be considered +! +! 1-eps-m and 1-m numerically different +! ------------------------------------- +! One returns Gamma_inv(1-m-eps)/eps directly +! as its value is accurate. +! To calculate Gamma_inv(1-m-eps), +! one uses the value Gamma_inv(1-eps), +! needed in considered transformations, +! and one uses the equality +! Gamma_inv(1-m-eps) = Gamma_inv(1-eps) \prod_{i=1}^{m} (1-eps-i) +! for m > 0. +! It is trivially demonstrated +! from the equality Gamma(x+1) = x.Gamma(x). +! One Gamma function evaluation is removed this way +! from the calculation. +! +! 1-eps-m and 1-m numerically equal +! --------------------------------- +! This implies that 1-m-eps is negative integer numerically. +! Here, eps~0, so that one returns the limit of Gamma_inv(1-m-eps)/eps +! for eps -> 0, which is (-1)^m (m-1)! +! +! Variables +! --------- +! m,eps: variable inputs of the function +! (m,eps) -> Gamma_inv(1-m-eps)/eps +! Gamma_inv_one_meps: Gamma_inv(1-eps), +! previously calculated and here recycled +! to quickly calculate Gamma_inv(1-m-eps). +! one_meps: 1-eps +!---------------------------------------------------------------------- +FUNCTION A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + INTEGER(IPR),INTENT(IN) :: M + COMPLEX(PR),INTENT(IN) :: EPS,GAMMA_INV_ONE_MEPS + INTEGER(IPR) :: N,I + REAL(PR) :: FACT + COMPLEX(PR) :: A_SUM_INIT,ONE_MEPS + COMPLEX(PR) :: GAMMA_INV_ONE_MEPS_MM + ! + ONE_MEPS = ONE - EPS + IF(ONE_MEPS-M.NE.1-M) THEN + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS + DO I=1,M + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS-I) + ENDDO + A_SUM_INIT=GAMMA_INV_ONE_MEPS_MM/EPS + RETURN + ELSE + FACT=ONE + DO N=2,M-1 + FACT=FACT*N + ENDDO + IF(MOD(M,2).EQ.0) THEN + A_SUM_INIT=FACT + ELSE + A_SUM_INIT=-FACT + ENDIF + RETURN + ENDIF +END FUNCTION A_SUM_INIT +! +!---------------------------------------------------------------------- +! Calculation of the log of Gamma_inv(1-m-eps)/eps +! ------------------------------------------------ +! See previous function. +! It is used in case Gamma_inv(1-m-eps)/eps might overflow. +! +! Variables +! --------- +! m,eps: variable inputs of the function +! (m,eps) -> log[Gamma_inv(1-m-eps)/eps] +! one_meps_mm: 1-eps-m +! i_Pi: i.Pi +! log_fact: logarithm of (-1)^m (m-1)!, +! here defined as log((m-1)!) + i.Pi if m is odd. +!---------------------------------------------------------------------- +FUNCTION LOG_A_SUM_INIT(M,EPS) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + INTEGER(IPR),INTENT(IN) :: M + COMPLEX(PR),INTENT(IN) :: EPS + INTEGER(IPR) :: N + REAL(PR) :: LOG_FACT + COMPLEX(PR) :: ONE_MEPS_MM,LOG_A_SUM_INIT,LOG_GAMMA_CPLX + ! + ONE_MEPS_MM=ONE-EPS-M + IF(ONE_MEPS_MM.NE.1-M) THEN + LOG_A_SUM_INIT=(-LOG_GAMMA_CPLX(ONE_MEPS_MM) - LOG(EPS)) + RETURN + ELSE + LOG_FACT=ZERO + DO N=2,M-1 + LOG_FACT=LOG_FACT + LOG(DBLE(N)) + ENDDO + IF(MOD(M,2).EQ.0) THEN + LOG_A_SUM_INIT=LOG_FACT + ELSE + LOG_A_SUM_INIT=CMPLX(LOG_FACT,M_PI,PR) + ENDIF + RETURN + ENDIF +END FUNCTION LOG_A_SUM_INIT +!---------------------------------------------------------------------- +! Calculation of the first term of the B(z) power series +! ------------------------------------------------------ +! in the 1-z transformation, divided by (1-z)^m +! ---------------------------------------------- +! In the 1-z transformation, +! the power series B(z) = \sum_{n=0}^{+oo} \beta_n (1-z)^n occurs +! (see Comp. Phys. Comm. paper). +! The first term \beta_0, divided by (1-z)^m, is calculated here. +! m is the closest integer to Re(c-a-b) >= 0 and eps = c-a-b-m. +! +! One has to consider |eps|oo > 0.1 and |eps|oo <= 0.1, +! where 1-m-eps and 1-m can be different or equal numerically, +! leading to some changes in this last case. +! +! |eps|oo > 0.1 +! ------------- +! One has \beta_0/(1-z)^m = [(a)_m (b)_m Gamma_inv(1-eps) +! Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) Gamma_inv(m+1) +! - (1-z)^eps Gamma_inv(a) Gamma_inv(b) Gamma_inv(1+m+eps)] +! [Gamma(c)/eps], stable in this regime for a direct evaluation. +! +! The values of Gamma(c), Gamma_inv(a+m+eps) +! and Gamma_inv(b+m+eps) were already calculated and recycled here. +! Gamma_inv(m+1) is calculated as 1/(m!). +! +! Gamma_inv(1+m+eps) is calculated from Gamma_inv(1-eps), +! using the equalities: +! Gamma_inv(1-m-eps) = Gamma_inv(1-eps) \prod_{i=1}^{m} (1-eps-i), +! where the product is 1 by definition if m = 0, +! Gamma_inv(1+m+eps) = (-1)^m sin (pi.eps) +! /[pi.(eps+m).Gamma_inv(1-m-eps)] +! from Euler reflection formula, Gamma(x+1) = x.Gamma(x) equality, +! and m+eps no zero. +! This scheme is much faster than +! to recalculate Gamma_inv(1+m+eps) directly. +! +! |eps|oo <= 0.1 +! -------------- +! The \beta_0/(1-z)^m expression is rewritten +! so that it contains no instabilities: +! \beta_0/(1-z)^m = Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) +! [(G(1,-eps) Gamma_inv(m+1) + G(m+1,eps)) +! - Gamma_inv(1+m+eps) (G(a+m,eps) Gamma_inv(b+m+eps) +! + G(b+m,eps) Gamma_inv(a+m)) +! - E(log(1-z),eps) Gamma_inv(a+m) Gamma_inv(b+m) Gamma_inv(1+m+eps)] +! (a)_m (b)_m Gamma(c) +! +! E(log(1-z),eps) is [(1-z)^eps - 1]/eps +! if 1-m-eps and 1-m are different numerically, +! and log(1-z) otherwise (eps ~ 0). +! If 1-m-eps and 1-m are equal numerically, +! Gamma_inv(1+m+eps) is numerically equal to Gamma_inv(1+m), +! already calculated as 1/(m!). +! See |eps|oo > 0.1 case for data recycling of other values +! or for 1-m-eps and 1-m different numerically. +! +!---------------------------------------------------------------------- +! Variables +! --------- +! a,b,c,one_minus_z: a,b,c and 1-z parameters and arguments +! of the 2F1(a,b,c,z) function. +! m,eps: closest integer to c-a-b, with Re(c-a-b) >= 0 +! and eps = c-a-b-m +! Gamma_c,Gamma_inv_one_meps,Gamma_inv_eps_pa_pm, Gamma_inv_eps_pb_pm: +! recycled values of Gamma(c), Gamma_inv(1-eps), +! Gamma_inv(a+m+eps) and Gamma_inv(b+m+eps). +! inf_norm_eps,phase,a_pm,b_pm,one_meps,Pi_eps,Pi_eps_pm: +! |eps|oo,(-1)^m,a+m,b+m,1-eps,pi.eps,pi.(eps+m) +! Gamma_inv_one_meps_mm,Gamma_inv_eps_pm_p1: +! Gamma_inv(1-m-eps) and Gamma_inv(1+m+eps) +! calculated with the recycling scheme. +! prod1: (a)_m (b)_m Gamma_inv(1-eps) Gamma_inv(a+m+eps) +! x Gamma_inv(b+m+eps) Gamma_inv(m+1) in |eps|oo > 0.1 case. +! prod2: (1-z)^eps Gamma_inv(a) Gamma_inv(b) Gamma_inv(1+m+eps) +! in |eps|oo > 0.1 case. +! Gamma_inv_mp1,prod_ab: Gamma_inv(m+1) calculated as 1/(m!) +! and (a)_m (b)_m in |eps|oo <= 0.1 case. +! is_eps_non_zero: true if 1-m-eps and 1-m are different numerically, +! false if not. +! Gamma_inv_a_pm,Gamma_inv_b_pm,z_term: Gamma_inv(a+m),Gamma_inv(b+m), +! E(eps,log(1-z)) +! prod1: Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) +! x [(G(1,-eps) Gamma_inv(m+1) + G(m+1,eps)) in |eps|oo <= 0.1 case. +! prod2: Gamma_inv(1+m+eps) (G(a+m,eps) Gamma_inv(b+m+eps) +! + G(b+m,eps) Gamma_inv(a+m)) +! prod3: E(eps,log(1-z)) Gamma_inv(a+m) Gamma_inv(b+m) +! Gamma_inv(1+m+eps) +! res: returned \beta_0/(1-z)^m value in all cases. +!---------------------------------------------------------------------- +FUNCTION B_SUM_INIT_PS_ONE(A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, & + GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,M,EPS) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + INTEGER(IPR),INTENT(IN) :: M + COMPLEX(PR),INTENT(IN) :: A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, & + GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,EPS + INTEGER(IPR) :: M_M1,N,I,PHASE + REAL(PR) :: INF_NORM_EPS,GAMMA_INV_MP1 + COMPLEX(PR) :: A_PM,B_SUM_INIT_PS_ONE,PI_EPS,GAMMA_INV_ONE_MEPS_MM + COMPLEX(PR) :: B_PM,TMP1,TMP2 + COMPLEX(PR) :: Z_TERM,PROD1,PROD2,PROD3,ONE_MEPS,PI_EPS_PM + COMPLEX(PR) :: GAMMA_INV_A_PM,PROD_AB,GAMMA_INV,GAMMA_INV_B_PM + COMPLEX(PR) :: GAMMA_INV_DIFF_EPS,GAMMA_INV_EPS_PM_P1 + ! + INF_NORM_EPS=INF_NORM(EPS); M_M1=M-1; A_PM=A+M; B_PM=B+M + ONE_MEPS=ONE-EPS; PI_EPS=M_PI*EPS; PI_EPS_PM = M_PI*(EPS+M) + IF(MOD(M,2).EQ.0) THEN + PHASE = 1 + ELSE + PHASE = -1 + ENDIF + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS + DO I=1,M + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS - I) + ENDDO + IF(INF_NORM_EPS.GT.0.10D0) THEN + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + PROD1=GAMMA_INV_ONE_MEPS*GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM + DO N=0,M_M1 + PROD1=PROD1*(A+N)*(B+N)/(N+ONE) + ENDDO + PROD2=GAMMA_INV(A)*GAMMA_INV(B)*GAMMA_INV_EPS_PM_P1*(MZP1**EPS) + B_SUM_INIT_PS_ONE=GAMMA_C*(PROD1-PROD2)/EPS + RETURN + ELSE + GAMMA_INV_MP1=ONE;PROD_AB=ONE + DO N=0,M_M1 + GAMMA_INV_MP1 = GAMMA_INV_MP1/(N+ONE) + PROD_AB = PROD_AB*(A+N)*(B+N) + ENDDO + IF(ONE_MEPS-M.NE.1-M) THEN + Z_TERM=EXPM1(EPS*LOG(MZP1))/EPS + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + ELSE + Z_TERM=LOG(MZP1) + GAMMA_INV_EPS_PM_P1 = GAMMA_INV_MP1 + ENDIF + GAMMA_INV_A_PM=GAMMA_INV(A_PM);GAMMA_INV_B_PM=GAMMA_INV(B_PM) + TMP1=ONE; TMP2=M+1; + PROD1 = GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM & + *(GAMMA_INV_MP1*GAMMA_INV_DIFF_EPS(TMP1,-EPS) & + +GAMMA_INV_DIFF_EPS(TMP2,EPS)) + PROD2 = GAMMA_INV_EPS_PM_P1 & + *(GAMMA_INV_EPS_PB_PM*GAMMA_INV_DIFF_EPS(A_PM,EPS) & + +GAMMA_INV_A_PM*GAMMA_INV_DIFF_EPS (B_PM,EPS)) + PROD3 = GAMMA_INV_A_PM*GAMMA_INV_B_PM*GAMMA_INV_EPS_PM_P1*Z_TERM + B_SUM_INIT_PS_ONE=GAMMA_C*PROD_AB*(PROD1-PROD2-PROD3) + RETURN + ENDIF +END FUNCTION B_SUM_INIT_PS_ONE +! +!---------------------------------------------------------------------- +! Calculation of the first term of the B(z) power series +! ------------------------------------------------------ +! in the 1/z transformation, divided by z^{-m} +!--------------------------------------------- +! In the 1/z transformation, the power series +! B(z) = \sum_{n=0}^{+oo} \beta_n z^{-n} occurs +! (see Comp. Phys. Comm. paper). +! The first term \beta_0, divided by z^{-m}, is calculated here. +! m is the closest integer to Re(b-a) >= 0 and eps = b-a-m. +! +! One has to consider |eps|oo > 0.1 and |eps|oo <= 0.1, +! where 1-m-eps and 1-m can be different or equal numerically, +! leading to some changes in this last case. +! +! |eps|oo > 0.1 +! ------------- +! One has \beta_0/z^{-m} = [(a)_m (1-c+a)_m Gamma_inv(1-eps) +! Gamma_inv(a+m+eps) Gamma_inv(c-a) Gamma_inv(m+1) +! - (-z)^{-eps} (1-c+a+eps)_m Gamma_inv(a) Gamma_inv(c-a-eps) +! Gamma_inv(1+m+eps)].[Gamma(c)/eps], +! stable in this regime for a direct evaluation. +! +! The values of Gamma(c), Gamma_inv(c-a) and Gamma_inv(a+m+eps) +! were already calculated and recycled here. +! Gamma_inv(m+1) is calculated as 1/(m!). +! Gamma_inv(1+m+eps) is calculated from Gamma_inv(1-eps) +! as in the 1-z transformation routine. +! +! |eps|oo <= 0.1 +! -------------- +! The \beta_0/z^{-m} expression is rewritten +! so that it contains no instabilities: +! \beta_0/z^{-m} = [((1-c+a+eps)_m G(1,-eps) - P(m,eps,1-c+a) +! Gamma_inv(1-eps)) Gamma_inv(c-a) Gamma_inv(a+m+eps) Gamma_inv(m+1) +! + (1-c+a+eps)_m [G(m+1,eps) Gamma_inv(c-a) Gamma_inv(a+m+eps) +! - G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)] +! - (G(c-a,-eps) - E(log(-z),-eps)) Gamma_inv(m+1+eps) +! Gamma_inv(a+m)]] (a)_m Gamma(c) +! +! Definitions and method are the same +! as in the 1-z transformation routine, except for P(m,eps,1-c+a). +! P(m,eps,s) = [(s+eps)_m - (s)_m]/eps +! for eps non zero and has a limit for eps -> 0. +! Let n0 be the closest integer to -Re(s) for s complex. +! A stable formula available for eps -> 0 for P(m,eps,s) is: +! P(m,eps,s) = (s)_m E(\sum_{n=0}^{m-1} L(1/(s+n),eps),eps) +! if n0 is not in [0:m-1], +! P(m,eps,s) = \prod_{n=0, n not equal to n0}^{m-1} (s+eps+n) +! + (s)_m E(\sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps),eps) +! if n0 is in [0:m-1]. +! L(s,eps) is log1p(s eps)/eps if eps is not zero, +! and L(s,0) = s. +! This expression is used in the code. +! +! Variables +! --------- +! a,b,c,z: a,b,c and z parameters +! and arguments of the 2F1(a,b,c,z) function. +! m,eps: closest integer to b-a, with Re(b-a) >= 0 and eps = b-a-m. +! Gamma_c,Gamma_inv_cma,Gamma_inv_one_meps,Gamma_inv_eps_pa_pm: +! recycled values of Gamma(c), Gamma_inv(c-a), Gamma_inv(1-eps) +! and Gamma_inv(a+m+eps). +! inf_norm_eps,phase,cma,a_mc_p1,a_mc_p1_pm,cma_eps,eps_pa_mc_p1,a_pm: +! |eps|oo,(-1)^m,c-a,1-c+a+m,c-a-eps,1-c+a+eps,a+m +! Gamma_inv_cma_meps,one_meps,Pi_eps,Pi_eps_pm: +! Gamma_inv(c-a-eps),1-eps,pi.eps,pi.(eps+m) +! Gamma_inv_one_meps_mm,Gamma_inv_eps_pm_p1: Gamma_inv(1-m-eps) +! and Gamma_inv(1+m+eps) calculated with the recycling scheme. +! prod1: (a)_m (1-c+a)_m Gamma_inv(1-eps) Gamma_inv(a+m+eps) +! x Gamma_inv(c-a) Gamma_inv(m+1) in |eps|oo > 0.1 case. +! prod2: (-z)^{-eps} (1-c+a+eps)_m Gamma_inv(a) +! x Gamma_inv(c-a-eps) Gamma_inv(1+m+eps) in |eps|oo > 0.1 case. +! n0: closest integer to -Re(1-c+a) +! is_n0_here: true is n0 belongs to [0:m-1], false if not. +! is_eps_non_zero: true if 1-m-eps and 1-m are different numerically, +! false if not. +! Gamma_inv_mp1,prod_a,prod_a_mc_p1: +! Gamma_inv(m+1) calculated as 1/(m!), +! (a)_m and (1-c+a)_m in |eps|oo <= 0.1 case. +! prod_eps_pa_mc_p1_n0: +! \prod_{n=0, n not equal to n0}^{m-1} (1-c+a+eps+n) +! if n0 belongs to [0:m-1], 0.0 if not, in |eps|oo <= 0.1 case. +! prod_eps_pa_mc_p1: (1-c+a+eps)_m in |eps|oo <= 0.1 case. +! sum: \sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps) if 1-m-eps +! and 1-m are different numerically, +! \sum_{n=0, n not equal to n0}^{m-1} 1/(s+n) if not. +! a_pn,a_mc_p1_pn,eps_pa_mc_p1_pn: a+n,1-c+a+n,1-c+a+eps+n values +! used in (a)_m, (1-c+a)_m and (1-c+a+eps)_m evaluations. +! sum_term,prod_diff_eps,z_term: +! E(\sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps),eps), +! P(m,eps,1-c+a), -E(-eps,log(-z)) +! Gamma_inv_a_pm,Gamma_prod1: Gamma_inv(a+m), +! Gamma_inv(c-a).Gamma_inv(a+m+eps) +! prod1: ((1-c+a+eps)_m G(1,-eps) +! - P(m,eps,1-c+a) Gamma_inv(1-eps)) Gamma_inv(c-a) +! x Gamma_inv(a+m+eps) Gamma_inv(m+1) +! prod_2a: Gamma_inv(c-a).Gamma_inv(a+m+eps).G(m+1,eps) +! prod_2b: G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps) +! prod_2c: (G(c-a,-eps) +! - E(log(-z),-eps)) Gamma_inv(m+1+eps) Gamma_inv(a+m) +! prod2: (1-c+a+eps)_m [G(m+1,eps) Gamma_inv(c-a) Gamma_inv(a+m+eps) +! - G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)] +! - (G(c-a,-eps) - E(log(-z),-eps)) +! x Gamma_inv(m+1+eps) Gamma_inv(a+m)]] +! res: returned \beta_0/z^{-m} value in all cases. +!---------------------------------------------------------------------- +FUNCTION B_SUM_INIT_PS_INFINITY(A,C,GAMMA_C,GAMMA_INV_CMA, & + GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM,Z,M,EPS) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + INTEGER(IPR),INTENT(IN) :: M + COMPLEX(PR),INTENT(IN) :: A,C,GAMMA_C,GAMMA_INV_CMA,Z,EPS + COMPLEX(PR),INTENT(IN) :: GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM + INTEGER(IPR) :: M_M1,I,N,N0,PHASE + LOGICAL :: IS_N0_HERE,IS_EPS_NON_ZERO + REAL(PR) :: INF_NORM_EPS,NP1,GAMMA_INV_MP1 + COMPLEX(PR) :: B_SUM_INIT_PS_INFINITY,GAMMA_INV,TMP1 + COMPLEX(PR) :: CMA,A_MC_P1,A_MC_P1_PM,CMA_MEPS,EPS_PA_MC_P1,A_PM + COMPLEX(PR) :: GAMMA_INV_EPS_PM_P1,GAMMA_INV_CMA_MEPS,PI_EPS + COMPLEX(PR) :: PROD1,PROD2,A_PN,A_MC_P1_PN,ONE_MEPS + COMPLEX(PR) :: PROD_A,PROD_A_MC_P1,PROD_EPS_PA_MC_P1_N0,PI_EPS_PM + COMPLEX(PR) :: PROD_EPS_PA_MC_P1,SUM_N0,Z_TERM,SUM_TERM + COMPLEX(PR) :: PROD_DIFF_EPS,GAMMA_INV_A_PM,GAMMA_PROD1 + COMPLEX(PR) :: PROD_2A,PROD_2B,PROD_2C,GAMMA_INV_DIFF_EPS + COMPLEX(PR) :: EPS_PA_MC_P1_PN,GAMMA_INV_ONE_MEPS_MM + ! + INF_NORM_EPS=INF_NORM(EPS); CMA=C-A; A_MC_P1=A-C+ONE + A_MC_P1_PM=A_MC_P1+M; CMA_MEPS=CMA-EPS; EPS_PA_MC_P1=EPS+A_MC_P1 + A_PM=A+M; M_M1=M-1; ONE_MEPS=ONE-EPS; PI_EPS=M_PI*EPS + PI_EPS_PM=M_PI*(EPS+M); GAMMA_INV_CMA_MEPS=GAMMA_INV(CMA_MEPS) + IF(MOD(M,2).EQ.0) THEN + PHASE = 1 + ELSE + PHASE = -1 + ENDIF + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS + DO I=1,M + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS - I) + ENDDO + IF(INF_NORM_EPS.GT.0.1D0) THEN + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + PROD1 = GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM*GAMMA_INV_ONE_MEPS + PROD2 = GAMMA_INV(A)*GAMMA_INV_CMA_MEPS*GAMMA_INV_EPS_PM_P1 & + *((-Z)**(-EPS)) + DO N=0,M_M1 + A_PN=A+N; A_MC_P1_PN=A_MC_P1+N + EPS_PA_MC_P1_PN=EPS+A_MC_P1_PN;NP1=N+ONE + PROD1 = PROD1*A_PN*A_MC_P1_PN/NP1 + PROD2 = PROD2*EPS_PA_MC_P1_PN + ENDDO + B_SUM_INIT_PS_INFINITY = GAMMA_C*(PROD1-PROD2)/EPS + RETURN + ELSE + N0=-NINT(REAL(A_MC_P1,PR)) + IS_EPS_NON_ZERO=ONE_MEPS-M.NE.1-M + IS_N0_HERE=(N0.GE.0).AND.(N0.LT.M) + GAMMA_INV_MP1=ONE; PROD_A=ONE; PROD_A_MC_P1=ONE + PROD_EPS_PA_MC_P1=ONE; SUM_N0=ZERO + IF(IS_N0_HERE) THEN + PROD_EPS_PA_MC_P1_N0 = ONE + ELSE + PROD_EPS_PA_MC_P1_N0 = ZERO + ENDIF + DO N=0,M_M1 + A_PN=A+N; A_MC_P1_PN=A_MC_P1+N + EPS_PA_MC_P1_PN=EPS+A_MC_P1_PN; NP1=N+ONE + PROD_A = PROD_A*A_PN + PROD_A_MC_P1 = PROD_A_MC_P1*A_MC_P1_PN + PROD_EPS_PA_MC_P1 = PROD_EPS_PA_MC_P1*EPS_PA_MC_P1_PN + GAMMA_INV_MP1 = GAMMA_INV_MP1/NP1 + IF(N.NE.N0) THEN + IF(IS_N0_HERE) THEN + PROD_EPS_PA_MC_P1_N0=PROD_EPS_PA_MC_P1_N0 & + *EPS_PA_MC_P1_PN + ENDIF + IF(IS_EPS_NON_ZERO) THEN + SUM_N0 = SUM_N0 + LOG1P(EPS/A_MC_P1_PN) + ELSE + SUM_N0 = SUM_N0 + ONE/A_MC_P1_PN + ENDIF + ENDIF + ENDDO + IF(IS_EPS_NON_ZERO) THEN + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + SUM_TERM = EXPM1(SUM_N0)/EPS + Z_TERM = EXPM1(-EPS*LOG(-Z))/EPS + ELSE + GAMMA_INV_EPS_PM_P1 = GAMMA_INV_MP1 + SUM_TERM = SUM_N0 + Z_TERM = -LOG(-Z) + ENDIF + PROD_DIFF_EPS = PROD_EPS_PA_MC_P1_N0 + PROD_A_MC_P1*SUM_TERM + GAMMA_INV_A_PM = GAMMA_INV(A_PM) + GAMMA_PROD1=GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM + TMP1=ONE + PROD1 = GAMMA_PROD1*GAMMA_INV_MP1*(GAMMA_INV_DIFF_EPS(TMP1,-EPS) & + *PROD_EPS_PA_MC_P1 - GAMMA_INV_ONE_MEPS*PROD_DIFF_EPS) + TMP1=M+1 + PROD_2A = GAMMA_PROD1*GAMMA_INV_DIFF_EPS(TMP1,EPS) + PROD_2B = GAMMA_INV_CMA*GAMMA_INV_EPS_PM_P1 & + *GAMMA_INV_DIFF_EPS(A_PM,EPS) + PROD_2C = GAMMA_INV_EPS_PM_P1*GAMMA_INV_A_PM & + *(GAMMA_INV_DIFF_EPS(CMA,-EPS) + GAMMA_INV_CMA_MEPS*Z_TERM) + PROD2 = PROD_EPS_PA_MC_P1*(PROD_2A - PROD_2B - PROD_2C) + B_SUM_INIT_PS_INFINITY = GAMMA_C*PROD_A*(PROD1+PROD2) + RETURN + ENDIF +END FUNCTION B_SUM_INIT_PS_INFINITY +! +!---------------------------------------------------------------------- +! Calculation of the derivative of the polynomial P(X) +! ---------------------------------------------------- +! testing power series convergence +! -------------------------------- +! P(X) = |z(a+X)(b+X)|^2 - |(c+X)(X+1)|^2 +! = \sum_{i=0}^{4} c[i] X^{i}, for |z| < 1. +! It is positive when the power series term modulus increases +! and negative when it decreases, +! so that its derivative provides information on its convergence +! (see Comp. Phys. Comm. paper). +! Its derivative components cv_poly_der_tab[i] = (i+1) c[i+1] +! for i in [0:3] +! so that P'(X) = \sum_{i=0}^{3} cv_poly_der_tab[i] X^{i} +! are calculated. +! +! Variables: +! ---------- +! a,b,c,z: a,b,c and z parameters and arguments +! of the 2F1(a,b,c,z) function. +! cv_poly_der_tab[3]: table of four doubles +! containing the P'(X) components. +! mod_a2,mod_b2,mod_c2,mod_z2,R_a,Re_b,Re_c: |a|^2, |b|^2, |c|^2, +! |z|^2, Re(a), Re(b), Re(c), with which P(X) can be expressed. +!---------------------------------------------------------------------- +SUBROUTINE CV_POLY_DER_TAB_CALC(A,B,C,Z,CV_POLY_DER_TAB) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: A,B,C,Z + REAL(PR),INTENT(OUT) :: CV_POLY_DER_TAB(0:3) + REAL(PR) :: MOD_A2,MOD_B2,MOD_C2,MOD_Z2 + REAL(PR) :: RE_A,RE_B,RE_C,IM_A,IM_B,IM_C,RE_Z,IM_Z + ! + RE_A=REAL(A,PR); IM_A=AIMAG(A); MOD_A2=RE_A*RE_A+IM_A*IM_A + RE_B=REAL(B,PR); IM_B=AIMAG(B); MOD_B2=RE_B*RE_B+IM_B*IM_B + RE_C=REAL(C,PR); IM_C=AIMAG(C); MOD_C2=RE_C*RE_C+IM_C*IM_C + RE_Z=REAL(Z,PR); IM_Z=AIMAG(Z); MOD_Z2=RE_Z*RE_Z+IM_Z*IM_Z + CV_POLY_DER_TAB(0)=TWO*((RE_A*MOD_B2+RE_B*MOD_A2)*MOD_Z2-RE_C-MOD_C2) + CV_POLY_DER_TAB(1)=TWO*((MOD_A2+MOD_B2+4.0D0*RE_A*RE_B)*MOD_Z2 & + -ONE-4.0D0*RE_C-MOD_C2) + CV_POLY_DER_TAB(2)=6.0D0*((RE_A+RE_B)*MOD_Z2-RE_C-ONE) + CV_POLY_DER_TAB(3)=4.0D0*(MOD_Z2-ONE) +END SUBROUTINE CV_POLY_DER_TAB_CALC +! +!---------------------------------------------------------------------- +! Calculation of the derivative of the polynomial P(X) +! ---------------------------------------------------- +! testing power series convergence at one x value +! ----------------------------------------------- +! P'(x) is calculated for a real x. +! See P'(X) components calculation routine for definitions. +!---------------------------------------------------------------------- +FUNCTION CV_POLY_DER_CALC(CV_POLY_DER_TAB,X) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + REAL(PR),INTENT(IN) :: X + REAL(PR),INTENT(IN) :: CV_POLY_DER_TAB(0:3) + REAL(PR) :: CV_POLY_DER_CALC + ! + CV_POLY_DER_CALC=CV_POLY_DER_TAB(0)+X*(CV_POLY_DER_TAB(1) & + +X*(CV_POLY_DER_TAB(2)+X*CV_POLY_DER_TAB(3))) + RETURN +END FUNCTION CV_POLY_DER_CALC +! +!---------------------------------------------------------------------- +! Calculation of an integer after which false convergence cannot occur +! -------------------------------------------------------------------- +! See cv_poly_der_tab_calc routine for definitions. +! If P'(x) < 0 and P''(x) < 0 for x > xc, it will be so for all x > xc +! as P(x) -> -oo for x -> +oo +! and P(x) can have at most one maximum for x > xc. +! It means that the 2F1 power series term modulus will increase +! or decrease to 0 for n > nc, +! with nc the smallest positive integer larger than xc. +! +! If P'(X) = C0 + C1.X + C2.X^2 + C3.X^3, +! the discriminant of P''(X) is Delta = C2^2 - 3 C1 C3. +! +! If Delta > 0, P''(X) has two different real roots +! and its largest root is -(C2 + sqrt(Delta))/(3 C3), +! because C3 = 4(|z|^2 - 1) < 0. +! One can take xc = -(C2 + sqrt(Delta))/(3 C3) +! and one returns its associated nc integer. +! +! If Delta <= 0, P''(X) has at most one real root, +! so that P'(X) has only one root and then P(X) only one maximum. +! In this case, one can choose xc = nc = 0, which is returned. +! +! Variables +! --------- +! cv_poly_der_tab: table of four doubles +! containing the P'(X) coefficients +! C1,C2,three_C3: cv_poly_der_tab[1], cv_poly_der_tab[2] +! and 3.0*cv_poly_der_tab[3], so that P''(X) = C1 + 2.C2.x + three_C3.x^2 +! Delta: discriminant of P''(X), equal to C2^2 - 3 C1 C3. +! largest_root: if Delta > 0, +! P''(X) largest real root equal to -(C2 + sqrt(Delta))/(3 C3). +!---------------------------------------------------------------------- +FUNCTION MIN_N_CALC(CV_POLY_DER_TAB) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + REAL(PR),INTENT(IN) :: CV_POLY_DER_TAB(0:3) + INTEGER(IPR) :: MIN_N_CALC + REAL(PR) :: C1,C2,THREE_C3,DELTA,LARGEST_ROOT + ! + C1=CV_POLY_DER_TAB(1); C2=CV_POLY_DER_TAB(2) + THREE_C3=3.0D0*CV_POLY_DER_TAB(3); DELTA = C2*C2 - THREE_C3*C1 + IF(DELTA.LE.ZERO) THEN + MIN_N_CALC = 0 + RETURN + ELSE + LARGEST_ROOT = -(C2 + SQRT (DELTA))/THREE_C3 + MIN_N_CALC = MAX(CEILING(LARGEST_ROOT),0) + RETURN + ENDIF +END FUNCTION MIN_N_CALC +! +!---------------------------------------------------------------------- +! Calculation of the 2F1 power series converging for |z| < 1 +! ---------------------------------------------------------- +! One has 2F1(a,b,c,z) +! = \sum_{n = 0}^{+oo} (a)_n (b)_n / ((c)_n n!) z^n, +! so that 2F1(a,b,c,z) = \sum_{n = 0}^{+oo} t[n] z^n, +! with t[0] = 1 and t[n+1] = (a+n)(b+n)/((c+n)(n+1)) t[n] for n >= 0. +! If a or b are negative integers, +! F(z) is a polynomial of degree -a or -b, evaluated directly. +! If not, one uses the test of convergence |t[n] z^n|oo < 1E-15 +! to truncate the series after it was checked +! that false convergence cannot occur. +! Variables: +! ---------- +! a,b,c,z: a,b,c and z parameters and arguments +! of the 2F1(a,b,c,z) function. One must have here |z| < 1. +! term,sum: term of the 2F1 power series equal to t[n] z^n, +! truncated sum at given n of the 2F1 power series. +! na,nb: absolute values of the closest integers to Re(a) and Re(b). +! a = -na or b = -nb means one is in the polynomial case. +! cv_poly_der_tab: coefficients of the derivative +! of the polynomial P(X) = |z(a+X)(b+X)|^2 - |(c+X)(X+1)|^2 +! min_n: smallest integer after which false convergence cannot occur. +! It is calculated in min_n_calc. +! possible_false_cv: always true if n < min_n. +! If n >= min_n, it is true if P'(n) > 0. +! If n >= min_n and P'(n) < 0, +! it becomes false and remains as such for the rest of the calculation. +! One can then check if |t[n] z^n|oo < 1E-15 to truncate the series. +!---------------------------------------------------------------------- +FUNCTION HYP_PS_ZERO(A,B,C,Z) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: A,B,C,Z + INTEGER(IPR) :: N,NA,NB,MIN_N,MIN_N_CALC + COMPLEX(PR) :: HYP_PS_ZERO,TERM + LOGICAL :: POSSIBLE_FALSE_CV + REAL(PR) :: CV_POLY_DER_TAB(0:3) + REAL(PR) :: CV_POLY_DER_CALC + ! + NA = ABS(NINT(REAL(A,PR))) + NB = ABS(NINT(REAL(B,PR))) + TERM=ONE; HYP_PS_ZERO=ONE + IF(A.EQ.(-NA)) THEN + DO N=0,NA-1 + TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N)) + HYP_PS_ZERO = HYP_PS_ZERO + TERM + ENDDO + RETURN + ELSE IF(B.EQ.(-NB)) THEN + DO N=0,NB-1 + TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N)) + HYP_PS_ZERO = HYP_PS_ZERO + TERM + ENDDO + RETURN + ELSE + CALL CV_POLY_DER_TAB_CALC(A,B,C,Z,CV_POLY_DER_TAB) + POSSIBLE_FALSE_CV=.TRUE. + MIN_N=MIN_N_CALC(CV_POLY_DER_TAB);N=0 + DO WHILE(POSSIBLE_FALSE_CV.OR.(INF_NORM(TERM).GT.EPS15)) + TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N)) + HYP_PS_ZERO = HYP_PS_ZERO + TERM + IF(POSSIBLE_FALSE_CV.AND.(N.GT.MIN_N)) THEN + POSSIBLE_FALSE_CV = & + (CV_POLY_DER_CALC (CV_POLY_DER_TAB,DBLE(N)).GT.ZERO) + ENDIF + N=N+1 + ENDDO + RETURN + ENDIF +END FUNCTION HYP_PS_ZERO +! +!---------------------------------------------------------------------- +! Calculation of the 2F1 power series +! ----------------------------------- +! converging with the 1-z transformation +! -------------------------------------- +! The formula for F(z) in the 1-z transformation holds: +! F(z) = (-1)^m (pi.eps)/sin (pi.eps) [A(z) + B(z)] +! for eps not equal to zero, F(z) = (-1)^m [A(z) + B(z)] for eps = 0 +! where m = |Re(c-a-b)], eps = c-a-b-m, +! A(z) = \sum_{n=0}^{m-1} alpha[n] (1-z)^n, +! B(z) = \sum_{n=0}^{+oo} beta[n] (1-z)^n, and: +! +! alpha[0] = [Gamma_inv(1-m-eps)/eps] Gamma_inv(a+m+eps) +! x Gamma_inv(b+m+eps) Gamma(c) +! [Gamma_inv(1-m-eps)/eps] is calculated in A_sum_init. +! alpha[0] is calculated with log[Gamma] +! if the previous expression might overflow, +! and its imaginary part removed if a, b and c are real. +! alpha[n+1] = (a+n)(b+n)/[(n+1)(1-m-eps+n)] alpha[n], n in [0:m-2]. +! +! beta[0] is defined in B_sum_init_PS_one function comments. +! gamma[0] = Gamma(c) (a)_m (b)_m (1-z)^m Gamma_inv(a+m+eps) +! x Gamma_inv(b+m+eps) Gamma_inv(m+1) Gamma_inv(1-eps) +! +! beta[n+1] = (a+m+n+eps)(b+m+n+eps)/[(m+n+1+eps)(n+1)] beta[n] +! + [(a+m+n)(b+m+n)/(m+n+1) - (a+m+n) - (b+m+n) - eps +! + (a+m+n+eps)(b+m+n+eps)/(n+1)] +! x gamma[n]/[(n+m+1+eps)(n+1+eps)], n >= 0. +! gamma[n+1] = (a+m+n)(b+m+n)/[(m+n+1)(n+1-eps)] gamma[n], n >= 0. +! +! B(z) converges <=> |1-z| < 1 +! The test of convergence is |beta[n] (1-z)^n|oo < 1E-15 |beta[0]|oo +! for n large enough so that false convergence cannot occur. +! +! Variables +! --------- +! a,b,c,one_minus_z: a,b,c parameters +! and 1-z from z argument of 2F1(a,b,c,z) +! m,phase,m_p1,eps,eps_pm,eps_pm_p1, +! a_pm,b_pm,one_meps,one_meps_pm: +! |Re(c-a-b)], (-1)^m, m+1, c-a-b-m, +! eps+m, eps+m+1, a+m, b+m, 1-eps, 1-eps-m +! eps_pa,eps_pb,eps_pa_pm,eps_pb_pm,Pi_eps,Gamma_c: +! eps+a, eps+b, eps+a+m, eps+b+m, pi.eps, Gamma(c) +! Gamma_inv_eps_pa_pm,Gamma_inv_eps_pb_pm,Gamma_prod: +! Gamma_inv(eps+a+m), Gamma_inv(eps+b+m), +! Gamma(c).Gamma_inv(eps+a+m).Gamma_inv(eps+b+m) +! Gamma_inv_one_meps,A_first_term,A_sum,A_term: +! Gamma_inv(1-eps), alpha[0], A(z), alpha[n] (1-z)^n +! pow_mzp1_m,B_first_term,prod_B,ratio: (1-z)^m, beta[0], +! (a)_m (b)_m (1-z)^m, (a+n)(b+n)/(n+1) for n in [0:m-2]. +! B_extra_term,B_term,B_sum,B_prec: +! gamma[n], beta[n] (1-z)^n, B(z), 1E-15 |beta[0|oo +! cv_poly1_der_tab,cv_poly2_der_tab: P1'(X) and P2'(X) coefficients +! of the potentials derivatives of P1(X) and P2(X) +! defined in cv_poly_der_tab_calc with parameters +! a1 = a, b1 = b, c1 = 1-m-eps, z1 = 1-z +! and a2 = eps+b+m, b2 = eps+a+m,c2 = eps+m+1, z2 = 1-z. +! min_n: smallest integer after which false convergence cannot occur. +! It is calculated in min_n_calc with both P1'(X) and P2'(X), +! so one takes the largest integer coming from both calculations. +! possible_false_cv: always true if n < min_n. +! If n >= min_n, it is true if P1'(n) > 0 or P2'(n) > 0. +! If n >= min_n and P1'(n) < 0 and P2'(n) < 0, +! it becomes false and remains as such for the rest of the calculation. +! One can then check if |beta[n] z^n|oo < 1E-15 to truncate the series. +! n,n_pm_p1,n_p1,a_pm_pn,b_pm_pn,eps_pm_p1_pn,n_p1_meps,eps_pa_pm_pn, +! eps_pb_pm_pn,eps_pm_pn: index of power series, n+m+1, n+1, +! a+m+n, b+m+n, eps+m+n+1, n+1-eps, eps+a+m+n, eps+b+m+n, eps+m+n, +! prod1,prod2,prod3: (eps+a+m+n)(eps+b+m+n), +! (eps+m+1+n)(n+1), (a+m+n)(b+m+n) +!---------------------------------------------------------------------- +FUNCTION HYP_PS_ONE(A,B,C,MZP1) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: A,B,C,MZP1 + INTEGER(IPR) :: N,M,PHASE,M_M2,MIN_N,MIN_N_CALC,M_P1 + REAL(PR) :: B_PREC,N_P1,N_PM_P1,CV_POLY_DER_CALC + COMPLEX(PR) :: HYP_PS_ONE,EPS,EPS_PM,EPS_PM_P1,A_PM + COMPLEX(PR) :: B_PM,ONE_MEPS_MM,EPS_PA,EPS_PB,PI_EPS,GAMMA_PROD + COMPLEX(PR) :: EPS_PA_PM,EPS_PB_PM,GAMMA_INV,B_SUM_INIT_PS_ONE + COMPLEX(PR) :: A_SUM_INIT,LOG_A_SUM_INIT,A_SUM,A_TERM,ONE_MEPS + COMPLEX(PR) :: B_EXTRA_TERM,B_TERM,B_SUM,GAMMA_C,LOG_GAMMA_CPLX,RATIO + COMPLEX(PR) :: A_PM_PN,B_PM_PN,EPS_PM_P1_PN,N_P1_MEPS + COMPLEX(PR) :: PROD1,PROD2,PROD3 + COMPLEX(PR) :: EPS_PA_PM_PN,EPS_PB_PM_PN,EPS_PM_PN,PROD_B,POW_MZP1_M + COMPLEX(PR) :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM + COMPLEX(PR) :: GAMMA_INV_ONE_MEPS + LOGICAL :: POSSIBLE_FALSE_CV + REAL(PR) :: CV_POLY1_DER_TAB(0:3),CV_POLY2_DER_TAB(0:3) + ! + M=NINT(REAL(C-A-B,PR)); M_M2=M-2; M_P1=M+1 + IF(MOD(M,2).EQ.0) THEN + PHASE=1 + ELSE + PHASE=-1 + ENDIF + EPS=C-A-B-M; EPS_PM=EPS+M; EPS_PM_P1=EPS_PM+ONE; A_PM=A+M;B_PM=B+M + ONE_MEPS=ONE-EPS; ONE_MEPS_MM=ONE_MEPS-M; EPS_PA=EPS+A; EPS_PB=EPS+B + PI_EPS=M_PI*EPS; EPS_PA_PM=EPS_PA+M; EPS_PB_PM=EPS_PB+M + GAMMA_C=ONE/GAMMA_INV(C) + GAMMA_INV_EPS_PA_PM=GAMMA_INV(EPS_PA_PM) + GAMMA_INV_EPS_PB_PM=GAMMA_INV(EPS_PB_PM) + GAMMA_PROD=GAMMA_C*GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM + GAMMA_INV_ONE_MEPS=GAMMA_INV(ONE_MEPS) + IF(M.EQ.0) THEN + A_TERM=ZERO + ELSE IF(INF_NORM(ONE_MEPS_MM & + *(LOG(ONE + ABS(ONE_MEPS_MM))-ONE)).LT.300.0d0) THEN + A_TERM=GAMMA_PROD*A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS) + ELSE + A_TERM=EXP(LOG_GAMMA_CPLX(C)-LOG_GAMMA_CPLX(EPS_PA_PM)& + -LOG_GAMMA_CPLX(EPS_PB_PM)+LOG_A_SUM_INIT(M,EPS)) + IF((AIMAG(A).EQ.ZERO).AND.(AIMAG(B).EQ.ZERO)& + .AND.(AIMAG(C).EQ.ZERO)) THEN + A_TERM=REAL(A_TERM,PR) + ENDIF + ENDIF + A_SUM=A_TERM + POW_MZP1_M = MZP1**M + B_TERM=B_SUM_INIT_PS_ONE(A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, & + GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,M,EPS)*POW_MZP1_M + PROD_B=POW_MZP1_M + DO N=0,M_M2 + RATIO=(A+N)*(B+N)/(N+ONE) + A_TERM=A_TERM*MZP1*RATIO/(N+ONE_MEPS_MM) + A_SUM=A_SUM+A_TERM + PROD_B = PROD_B*RATIO + ENDDO + IF(M.GT.0) THEN + PROD_B = PROD_B*(A+M-ONE)*(B+M-ONE)/DBLE(M) + ENDIF + B_EXTRA_TERM = PROD_B*GAMMA_PROD*GAMMA_INV_ONE_MEPS; B_SUM=B_TERM + B_PREC=EPS15*INF_NORM(B_TERM) + CALL CV_POLY_DER_TAB_CALC(A,B,ONE_MEPS_MM,MZP1,CV_POLY1_DER_TAB) + CALL CV_POLY_DER_TAB_CALC(EPS_PB_PM,EPS_PA_PM,EPS_PM_P1,MZP1, & + CV_POLY2_DER_TAB) + MIN_N=MAX(MIN_N_CALC(CV_POLY1_DER_TAB),MIN_N_CALC(CV_POLY2_DER_TAB)) + POSSIBLE_FALSE_CV=.TRUE.; N=0 + DO WHILE(POSSIBLE_FALSE_CV.OR.(INF_NORM(B_TERM).GT.B_PREC)) + N_PM_P1=N+M_P1; N_P1=N+ONE; A_PM_PN=A_PM+N; B_PM_PN=B_PM+N + EPS_PM_P1_PN=EPS_PM_P1+N; N_P1_MEPS=ONE_MEPS+N + EPS_PM_PN=EPS_PM+N; EPS_PA_PM_PN=EPS_PA_PM+N + EPS_PB_PM_PN=EPS_PB_PM+N + PROD1=EPS_PA_PM_PN*EPS_PB_PM_PN + PROD2=EPS_PM_P1_PN*N_P1 + PROD3=A_PM_PN*B_PM_PN + B_TERM = MZP1*(B_TERM*PROD1/PROD2+B_EXTRA_TERM*(PROD3/N_PM_P1 & + -A_PM_PN-B_PM_PN-EPS+PROD1/N_P1)/(EPS_PM_P1_PN*N_P1_MEPS)) + B_SUM=B_SUM+B_TERM + B_EXTRA_TERM=B_EXTRA_TERM*MZP1*PROD3/(N_PM_P1*N_P1_MEPS) + IF(POSSIBLE_FALSE_CV.AND.(N.GT.MIN_N)) THEN + POSSIBLE_FALSE_CV = & + (CV_POLY_DER_CALC(CV_POLY1_DER_TAB,DBLE(N)).GT.ZERO).OR. & + (CV_POLY_DER_CALC(CV_POLY2_DER_TAB,DBLE(N)).GT.ZERO) + ENDIF + N=N+1 + ENDDO + IF(EPS.EQ.ZERO) THEN + HYP_PS_ONE=PHASE*(A_SUM+B_SUM) + RETURN + ELSE + HYP_PS_ONE=PHASE*(A_SUM+B_SUM)*PI_EPS/SIN(PI_EPS) + RETURN + ENDIF +END FUNCTION HYP_PS_ONE +! +!---------------------------------------------------------------------- +! Calculation of the 2F1 power series +! ----------------------------------- +! converging with the 1/z transformation +! -------------------------------------- +! The formula for F(z) in the 1/z transformation holds: +! F(z) = (-1)^m (pi.eps)/sin (pi.eps) [A(z) + B(z)] +! for eps not equal to zero, +! F(z) = (-1)^m [A(z) + B(z)] for eps = 0 +! where m = |Re(b-a)], eps = b-a-m, +! A(z) = \sum_{n=0}^{m-1} alpha[n] z^{-n}, +! B(z) = \sum_{n=0}^{+oo} beta[n] z^{-n}, and: +! +! alpha[0] = [Gamma_inv(1-m-eps)/eps] Gamma_inv(c-a) +! x Gamma_inv(a+m+eps) Gamma(c) +! [Gamma_inv(1-m-eps)/eps] is calculated in A_sum_init. +! alpha[0] is calculated with log[Gamma] +! if the previous expression might overflow, +! and its imaginary part removed if a, b and c are real. +! alpha[n+1] = (a+n)(1-c+a+n)/[(n+1)(1-m-eps+n)] alpha[n], +! n in [0:m-2]. +! +! beta[0] is defined in B_sum_init_PS_infinity function comments. +! gamma[0] = Gamma(c) (a)_m (1-c+a)_m z^{-m} Gamma_inv(a+m+eps) +! x Gamma_inv(c-a) Gamma_inv(m+1) Gamma_inv(1-eps) +! +! beta[n+1] = (a+m+n+eps)(1-c+a+m+n+eps)/[(m+n+1+eps)(n+1)] beta[n] +! + [(a+m+n)(1-c+a+m+n)/(m+n+1) - (a+m+n) - (1-c+a+m+n) +! - eps + (a+m+n+eps)(1-c+a+m+n+eps)/(n+1)] +! x gamma[n]/[(n+m+1+eps)(n+1+eps)], n >= 0. +! gamma[n+1] = (a+m+n)(b+m+n)/[(m+n+1)(n+1-eps)] gamma[n], n >= 0. +! +! B(z) converges <=> |z| > 1 +! The test of convergence is |beta[n] z^{-n}|oo < 1E-15 |beta[0]|oo +! for n large enough so that false convergence cannot occur. +! +! Variables +! --------- +! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) +! m,phase,m_p1,eps,a_mc_p1,one_meps, +! one_meps_pm,a_pm,a_mc_p1_pm,cma: |Re(b-a)], (-1)^m, m+1, b-a-m, +! 1-c+a, 1-eps, 1-eps-m, a+m, 1-c+a+m, c-a +! eps_pa,eps_pm_p1,eps_pa_mc_p1_pm,Pi_eps,eps_pa_pm,eps_pm,Gamma_c: +! eps+a, eps+m+1, eps+1-c+a+m, pi.eps, eps+a+m, eps+m, Gamma(c) +! Gamma_inv_eps_pa_pm,Gamma_inv_cma,z_inv,pow_mz_ma, +! Gamma_inv_one_meps,Gamma_prod: Gamma_inv(eps+a+m), Gamma_inv(c-a), +! 1/z, (-z)^(-a), Gamma_inv(1-eps), +! Gamma(c) Gamma_inv(c-a) Gamma_inv(eps+a+m) +! A_first_term,A_sum,A_term: alpha[0], A(z), alpha[n] z^{-n} +! pow_z_inv_m,B_first_term,prod_B,ratio: z^{-m}, beta[0], +! (a)_m (1-c+a)_m z^{-m}, (a+n)(1-c+a+n)/(n+1) for n in [0:m-2]. +! B_extra_term,B_term,B_sum,B_prec: +! gamma[n], beta[n] z^{-n}, B(z), 1E-15 |beta[0|oo +! cv_poly1_der_tab,cv_poly2_der_tab: P1'(X) and P2'(X) coefficients +! of the potentials derivatives of P1(X) and P2(X) +! defined in cv_poly_der_tab_calc +! with parameters a1 = a, b1 = 1-c+a, c1 = 1-m-eps, z1 = 1/z +! and a2 = b, b2 = eps+1-c+a+m,c2 = eps+m+1, z2 = 1/z. +! min_n: smallest integer after which false convergence cannot occur. +! It is calculated in min_n_calc with both P1'(X) and P2'(X), +! so one takes the largest integer coming from both calculations. +! possible_false_cv: always true if n < min_n. If n >= min_n, +! it is true if P1'(n) > 0 or P2'(n) > 0. +! If n >= min_n and P1'(n) < 0 and P2'(n) < 0, +! it becomes false and remains as such for the rest of the calculation. +! One can then check if |beta[n] z^n|oo < 1E-15 to truncate the series. +! n,n_pm_p1,n_p1,a_pm_pn,a_mc_p1_pm_pn,eps_pm_p1_pn,n_p1_meps, +! eps_pa_pm_pn,eps_pa_mc_p1_pm_pn,eps_pm_pn: +! index of power series, n+m+1, n+1, a+m+n, 1-c+a+m+n, eps+m+n+1, +! n+1-eps, eps+a+m+n, eps+1-c+a+m+n, eps+m+n, +! prod1,prod2,prod3: (eps+a+m+n)(eps+1-c+a+m+n), +! (eps+m+1+n)(n+1), (a+m+n)(1-c+a+m+n) +!---------------------------------------------------------------------- +FUNCTION HYP_PS_INFINITY(A,B,C,Z) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: A,B,C,Z + INTEGER(IPR) :: N,M,PHASE,M_M2,MIN_N,MIN_N_CALC,M_P1 + REAL(PR) :: B_PREC,N_P1,N_PM_P1,CV_POLY_DER_CALC + COMPLEX(PR) :: B_SUM_INIT_PS_INFINITY,LOG_GAMMA_CPLX,POW_Z_INV_M + COMPLEX(PR) :: HYP_PS_INFINITY,Z_INV,GAMMA_INV,RATIO + COMPLEX(PR) :: EPS,A_MC_P1,ONE_MEPS,ONE_MEPS_MM,A_PM,A_MC_P1_PM + COMPLEX(PR) :: CMA,EPS_PA,EPS_PM_P1,EPS_PA_MC_P1_PM,PI_EPS + COMPLEX(PR) :: EPS_PA_PM,EPS_PM,GAMMA_C,GAMMA_INV_CMA,POW_MZ_MA + COMPLEX(PR) :: A_SUM_INIT,LOG_A_SUM_INIT,A_SUM,A_TERM + COMPLEX(PR) :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_ONE_MEPS + COMPLEX(PR) :: PROD_B,B_EXTRA_TERM,B_TERM,B_SUM,PROD1 + COMPLEX(PR) :: A_PM_PN,A_MC_P1_PM_PN,EPS_PM_P1_PN,N_P1_MEPS + COMPLEX(PR) :: PROD2,PROD3,GAMMA_PROD + COMPLEX(PR) :: EPS_PA_PM_PN,EPS_PA_MC_P1_PM_PN,EPS_PM_PN + LOGICAL :: POSSIBLE_FALSE_CV + REAL(PR) :: CV_POLY1_DER_TAB(0:3),CV_POLY2_DER_TAB(0:3) + ! + M=NINT(REAL(B-A,PR)); M_M2=M-2;M_P1=M+1 + IF(MOD(M,2).EQ.0) THEN + PHASE=1 + ELSE + PHASE=-1 + ENDIF + EPS=B-A-M; A_MC_P1=ONE-C+A; ONE_MEPS=ONE-EPS; ONE_MEPS_MM=ONE_MEPS-M + A_PM=A+M; A_MC_P1_PM=A_MC_P1+M; CMA=C-A; EPS_PA=EPS+A + EPS_PM=EPS+M; EPS_PM_P1=EPS_PM+ONE; EPS_PA_MC_P1_PM=EPS+A_MC_P1_PM + PI_EPS=M_PI*EPS; EPS_PA_PM=EPS_PA+M + GAMMA_C=ONE/GAMMA_INV(C); GAMMA_INV_EPS_PA_PM = GAMMA_INV(EPS_PA_PM) + GAMMA_INV_ONE_MEPS = GAMMA_INV(ONE_MEPS) + GAMMA_INV_CMA=GAMMA_INV(CMA); Z_INV=ONE/Z;POW_MZ_MA=(-Z)**(-A) + GAMMA_PROD=GAMMA_C*GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM + IF(M.EQ.0) THEN + A_TERM=ZERO + ELSE IF(INF_NORM(ONE_MEPS_MM & + *(LOG(ONE + ABS(ONE_MEPS_MM))-ONE)).LT.300.0d0) THEN + A_TERM=GAMMA_PROD*A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS) + ELSE + A_TERM=EXP(LOG_GAMMA_CPLX(C)-LOG_GAMMA_CPLX(CMA)-LOG_GAMMA_CPLX(B) & + + LOG_A_SUM_INIT(M,EPS)) + IF((AIMAG(A).EQ.ZERO).AND.(AIMAG(B).EQ.ZERO).AND. & + (AIMAG(C).EQ.ZERO)) THEN + A_TERM=REAL(A_TERM,PR) + ENDIF + ENDIF + A_SUM=A_TERM + POW_Z_INV_M=Z_INV**M + B_TERM=B_SUM_INIT_PS_INFINITY(A,C,GAMMA_C,GAMMA_INV_CMA, & + GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM,Z,M,EPS)*POW_Z_INV_M + PROD_B=POW_Z_INV_M + DO N=0,M_M2 + RATIO=(A+N)*(A_MC_P1+N)/(N+ONE) + A_TERM = A_TERM*Z_INV*RATIO/(N+ONE_MEPS_MM) + A_SUM = A_SUM+A_TERM + PROD_B = PROD_B*RATIO + ENDDO + IF (M.GT.0) THEN + PROD_B=PROD_B*(A+M-ONE)*(A_MC_P1+M-ONE)/DBLE(M) + ENDIF + B_EXTRA_TERM = PROD_B*GAMMA_PROD*GAMMA_INV_ONE_MEPS + B_SUM=B_TERM + B_PREC=EPS15*INF_NORM(B_TERM) + CALL CV_POLY_DER_TAB_CALC(A,A_MC_P1,ONE_MEPS_MM,Z_INV, & + CV_POLY1_DER_TAB) + CALL CV_POLY_DER_TAB_CALC(B,EPS_PA_MC_P1_PM,EPS_PM_P1, & + Z_INV,CV_POLY2_DER_TAB) + MIN_N=MAX(MIN_N_CALC(CV_POLY1_DER_TAB),MIN_N_CALC(CV_POLY2_DER_TAB)) + POSSIBLE_FALSE_CV=.TRUE.; N=0 + DO WHILE(POSSIBLE_FALSE_CV.OR.(INF_NORM(B_TERM).GT.B_PREC)) + N_PM_P1=N+M_P1; N_P1=N+ONE; A_PM_PN=A_PM+N + A_MC_P1_PM_PN=A_MC_P1_PM+N; EPS_PM_P1_PN=EPS_PM_P1+N + N_P1_MEPS=N_P1-EPS; EPS_PA_PM_PN=EPS_PA_PM+N + EPS_PA_MC_P1_PM_PN=EPS_PA_MC_P1_PM+N; EPS_PM_PN=EPS_PM+N + PROD1=EPS_PA_PM_PN*EPS_PA_MC_P1_PM_PN; PROD2=EPS_PM_P1_PN*N_P1 + PROD3=A_PM_PN*A_MC_P1_PM_PN + B_TERM = Z_INV*(B_TERM*PROD1/PROD2+B_EXTRA_TERM*(PROD3/N_PM_P1 & + -A_PM_PN-A_MC_P1_PM_PN-EPS+PROD1/N_P1) & + /(EPS_PM_P1_PN*N_P1_MEPS)) + B_SUM=B_SUM+B_TERM + B_EXTRA_TERM=B_EXTRA_TERM*Z_INV*PROD3/(N_PM_P1*N_P1_MEPS) + IF(POSSIBLE_FALSE_CV.AND.(N.GT.MIN_N)) THEN + POSSIBLE_FALSE_CV = (CV_POLY_DER_CALC( & + CV_POLY1_DER_TAB,DBLE(N)).GT.ZERO).OR.(& + CV_POLY_DER_CALC(CV_POLY2_DER_TAB,DBLE(N)).GT.ZERO) + ENDIF + N=N+1 + ENDDO + IF(EPS.EQ.ZERO) THEN + HYP_PS_INFINITY=PHASE*POW_MZ_MA*(A_SUM+B_SUM) + RETURN + ELSE + HYP_PS_INFINITY=PHASE*POW_MZ_MA*(A_SUM+B_SUM)*PI_EPS & + /SIN(PI_EPS) + RETURN + ENDIF +END FUNCTION HYP_PS_INFINITY +! +!---------------------------------------------------------------------- +! Calculation of F(z) in transformation theory missing zones +! ---------------------------------------------------------- +! of the complex plane with a Taylor series +! ----------------------------------------- +! If z is close to exp(+/- i.pi/3), no transformation in 1-z, z, +! z/(z-1) or combination of them can transform z in a complex number +! of modulus smaller than a given Rmax < 1 . +! Rmax is a radius for which one considers power series summation +! for |z| > Rmax is too slow to be processed. One takes Rmax = 0.9 . +! Nevertheless, for Rmax = 0.9, +! these zones are small enough to be handled +! with a Taylor series expansion around a point z0 close to z +! where transformation theory can be used to calculate F(z). +! One then chooses z0 to be 0.9 z/|z| if |z| < 1, and 1.1 z/|z| +! if |z| > 1, +! so that hyp_PS_zero or hyp_PS_infinity can be used +! (see comments of these functions above). +! For this z0, F(z) = \sum_{n=0}^{+oo} q[n] (z-z0)^n, with: +! q[0] = F(z0), q[1] = F'(z0) = (a b/c) 2F1(a+1,b+1,c+1,z0) +! q[n+2] = [q[n+1] (n (2 z0 - 1) - c + (a+b+c+1) z0) +! + q[n] (a+n)(b+n)/(n+1)]/(z0(1-z0)(n+2)) +! As |z-z0| < 0.1, it converges with around 15 terms, +! so that no instability can occur for moderate a, b and c. +! Convergence is tested +! with |q[n] (z-z0)^n|oo + |q[n+1] (z-z0)^{n+1}|oo. +! Series is truncated when this test is smaller +! than 1E-15 (|q[0]|oo + |q[1] (z-z0)|oo). +! No false convergence can happen here +! as q[n] behaves smoothly for n -> +oo. +! +! Variables +! --------- +! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) +! abs_z,is_abs_z_small: |z|, true if |z| < 1 and false if not. +! z0,zc_z0_ratio,z0_term1,z0_term2: 0.9 z/|z| if |z| < 1, +! and 1.1 z/|z| if |z| > 1, (z-z0)/(z0 (1-z0)), +! 2 z0 - 1, c - (a+b+c+1) z0 +! hyp_PS_z0,dhyp_PS_z0,prec: F(z0), F'(z0) calculated with 2F1 +! as F'(z0) = (a b/c) 2F1(a+1,b+1,c+1,z0), +! precision demanded for series truncation +! equal to 1E-15 (|q[0]|oo + |q[1] (z-z0)|oo). +! n,an,anp1,anp2,sum: index of the series, q[n] (z-z0)^n, +! q[n+1] (z-z0)^{n+1}, q[n+2] (z-z0)^{n+2}, +! truncated sum of the power series. +!---------------------------------------------------------------------- +FUNCTION HYP_PS_COMPLEX_PLANE_REST(A,B,C,Z) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: A,B,C,Z + INTEGER(IPR) :: N + REAL(PR) :: ABS_Z,PREC + COMPLEX(PR) :: HYP_PS_COMPLEX_PLANE_REST + COMPLEX(PR) :: Z0,ZC,ZC_Z0_RATIO,Z0_TERM1,Z0_TERM2 + COMPLEX(PR) :: HYP_PS_Z0,DHYP_PS_Z0,AN,ANP1,ANP2 + COMPLEX(PR) :: HYP_PS_ZERO,HYP_PS_INFINITY + ! + ABS_Z=ABS(Z) + IF(ABS_Z.LT.ONE) THEN + Z0=0.9D0*Z/ABS_Z; ZC=Z-Z0; ZC_Z0_RATIO=ZC/(Z0*(ONE-Z0)) + Z0_TERM1=TWO*Z0 - ONE; Z0_TERM2=C-(A+B+ONE)*Z0 + HYP_PS_Z0=HYP_PS_ZERO(A,B,C,Z0) + DHYP_PS_Z0=HYP_PS_ZERO(A+ONE,B+ONE,C+ONE,Z0)*A*B/C + ELSE + Z0=1.1D0*Z/ABS_Z; ZC=Z-Z0; ZC_Z0_RATIO=ZC/(Z0*(ONE-Z0)) + Z0_TERM1=TWO*Z0 - ONE; Z0_TERM2=C-(A+B+ONE)*Z0 + HYP_PS_Z0=HYP_PS_INFINITY(A,B,C,Z0) + DHYP_PS_Z0=HYP_PS_INFINITY(A+ONE,B+ONE,C+ONE,Z0)*A*B/C + ENDIF + AN=HYP_PS_Z0;ANP1=ZC*DHYP_PS_Z0;HYP_PS_COMPLEX_PLANE_REST=AN+ANP1 + PREC=EPS15*(INF_NORM(AN)+INF_NORM(ANP1)); N=0 + DO WHILE(INF_NORM(AN).GT.PREC) + ANP2=ZC_Z0_RATIO*(ANP1*(N*Z0_TERM1-Z0_TERM2)+AN*ZC*(A+N)*(B+N) & + /(N+ONE))/(N+TWO) + HYP_PS_COMPLEX_PLANE_REST = HYP_PS_COMPLEX_PLANE_REST + ANP2 + N=N+1 + AN=ANP1 + ANP1=ANP2 + ENDDO + RETURN +END FUNCTION HYP_PS_COMPLEX_PLANE_REST + +! +!---------------------------------------------------------------------- +! Calculation of F(z) for arbitrary z using previous routines +! ----------------------------------------------------------- +! Firstly, it is checked if a,b and c are negative integers. +! If neither a nor b is negative integer but c is, +! F(z) is undefined so that the program stops with an error message. +! If a and c are negative integers with c < a, +! or b and c are negative integers with b < a, +! or c is not negative integer integer but a or b is, +! one is in the polynomial case. +! In this case, if |z| < |z/(z-1)| or z = 1, +! hyp_PS_zero is used directly, as then |z| <= 2 +! and no instability arises with hyp_PS_zero +! as long the degree of the polynomial is small (<= 10 typically). +! If not, one uses the transformation +! F(z) = (1-z)^{-a} 2F1(a,c-b,c,z/(z-1)) if a is negative integer +! or F(z) = (1-z)^{-b} 2F1(b,c-a,c,z/(z-1)) if b is negative integer +! along with hyp_PS_zero. +! Indeed, 2F1(a,c-b,c,X) is a polynomial if a is negative integer, +! and so is 2F1(b,c-a,c,X) if b is negative integer, +! so that one has here |z/(z-1)| <= 2 +! and the stability of the method is the same +! as for the |z| < |z/(z-1)| case. +! If one is in the non-polynomial case, one checks if z >= 1. +! If it is, one is the cut of F(z) +! so that z is replaced by z - 10^{-307}i. +! Then, using F(z) = 2F1(b,a,c,z) +! and F(z) = (1-z)^{c-a-b} 2F1(c-a,c-b,c,z), +! one replaces a,b,c parameters by combinations of them +! so that Re(b-a) >= 0 and Re(c-a-b) >= 0. +! Exchanging a and b does not change convergence properties, +! while having Re(c-a-b) >= 0 accelerates it +! (In hyp_PS_zero, t[n] z^n ~ z^n/(n^{c-a-b}) for n -> +oo). +! If |1-z| < 1E-5, one uses hyp_PS_one +! as the vicinity of the singular point z = 1 is treated properly. +! After that, one compares |z| and |z/(z-1)| +! to R in {0.5,0.6,0.7,0.8,0.9}. +! If one of them is smaller than R, +! one uses hyp_PS_zero without transformation +! or with the transformation F(z) = (1-z)^{-a} 2F1(a,c-b,c,z/(z-1)). +! Then, if both of them are larger than 0.9, +! one compares |1/z|, |(z-1)/z|, |1-z| and |1/(1-z)| +! to R in {0.5,0.6,0.7,0.8,0.9}. +! If one of them is found smaller than R, +! with the condition that |c-b|oo < 5 for (z-1)/z transformation, +! |a,b,c|oo < 5 for |1-z| transformation +! and |a,c-b,c|oo < 5 for |1/(1-z)| transformation, +! the corresponding transformation is used. +! If none of them was smaller than 0.9, +! one is in the missing zones of transformation theory +! so that the Taylor series of hyp_PS_complex_plane_rest is used. +! +! Variables +! --------- +! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) +! Re_a,Re_b,Re_c,na,nb,nc,is_a_neg_int,is_b_neg_int,is_c_neg_int: +! real parts of a,b,c, closest integers to a,b,c, +! true if a,b,c is negative integers and false if not. +! zm1,z_over_zm1,z_shift: z-1, z/(z-1), z - 10^{-307}i in case z >= 1. +! ab_condition, cab_condition: true if Re(b-a) >= 0 and false if not, +! true if Re(c-a-b) >= 0 and false if not. +! abs_zm1,abz_z,abs_z_inv,abs_z_over_zm1,abs_zm1_inv,abs_zm1_over_z: +! |z-1|, |z|, |1/z|, |z/(z-1)|, |1/(z-1)|, |(z-1)/z| +! are_ac_small: true if |a|oo < 5 and |c|oo < 5, false if not. +! is_cmb_small: true if |c-b|oo < 5, false if not. +! are_abc_small: true if |a|oo < 5, |b|oo < 5 and |c|oo < 5, +! false if not. +! are_a_cmb_c_small: true if |a|oo < 5, |c-b|oo < 5 and |c|oo < 5, +! false if not. +! R_tab,R: table of radii {0.5,0.6,0.7,0.8,0.9}, one of these radii. +! res: returned result +!---------------------------------------------------------------------- +RECURSIVE FUNCTION HYP_2F1(A,B,C,Z) RESULT(RES) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + COMPLEX(PR),INTENT(IN) :: A,B,C,Z + INTEGER(IPR) :: NA,NB,NC,I + REAL(PR) :: RE_A,RE_B,RE_C,ABS_Z,ABS_ZM1,ABS_Z_OVER_ZM1 + REAL(PR) :: ABS_ZM1_OVER_Z,ABS_ZM1_INV,R_TABLE(1:5),R,ABS_Z_INV + COMPLEX(PR) :: RES,HYP_PS_INFINITY,HYP_PS_ZERO,Z_SHIFT + COMPLEX(PR) :: HYP_PS_COMPLEX_PLANE_REST,HYP_PS_ONE,Z_OVER_ZM1,ZM1 + LOGICAL :: IS_A_NEG_INT,IS_B_NEG_INT,IS_C_NEG_INT + LOGICAL :: AB_CONDITION,CAB_CONDITION,ARE_A_CMB_C_SMALL + LOGICAL :: IS_CMB_SMALL,ARE_AC_SMALL,ARE_ABC_SMALL + ! + RE_A=REAL(A,PR); RE_B=REAL(B,PR); RE_C=REAL(C,PR); + NA=NINT(RE_A); NB=NINT(RE_B); NC=NINT(RE_C); + IS_A_NEG_INT=A.EQ.NA.AND.NA.LE.0 + IS_B_NEG_INT=B.EQ.NB.AND.NB.LE.0 + IS_C_NEG_INT=C.EQ.NC.AND.NC.LE.0 + ZM1=Z-ONE + IF(IS_C_NEG_INT) THEN + ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1 + ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1) + IF(IS_A_NEG_INT.AND.(NC.LT.NA)) THEN + IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN + RES=HYP_PS_ZERO(A,B,C,Z) + RETURN + ELSE + RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z_OVER_ZM1) + RETURN + ENDIF + ELSE IF(IS_B_NEG_INT.AND.(NC.LT.NB)) THEN + IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN + RES=HYP_PS_ZERO(A,B,C,Z) + RETURN + ELSE + RES=((-ZM1)**(-B))*HYP_PS_ZERO(B,C-A,C,Z_OVER_ZM1) + RETURN + ENDIF + ELSE + STOP '2F1 UNDEFINED' + ENDIF + ENDIF + IF(IS_A_NEG_INT) THEN + ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1 + ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1) + IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN + RES=HYP_PS_ZERO(A,B,C,Z) + RETURN + ELSE + RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z_OVER_ZM1) + RETURN + ENDIF + ELSE IF(IS_B_NEG_INT) THEN + ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1 + ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1) + IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN + RES=HYP_PS_ZERO(A,B,C,Z) + RETURN + ELSE + RES=((-ZM1)**(-B))*HYP_PS_ZERO(B,C-A,C,Z_OVER_ZM1) + RETURN + ENDIF + ENDIF + IF((REAL(Z,PR).GE.ONE).AND.(AIMAG(Z).EQ.ZERO)) THEN + Z_SHIFT=CMPLX(REAL(Z,PR),-1.0D-307,PR) + RES=HYP_2F1(A,B,C,Z_SHIFT) + RETURN + ENDIF + AB_CONDITION = (RE_B.GE.RE_A) + CAB_CONDITION = (RE_C.GE.RE_A + RE_B) + IF ((.NOT.AB_CONDITION).OR.(.NOT.CAB_CONDITION)) THEN + IF ((.NOT.AB_CONDITION).AND.(CAB_CONDITION)) THEN + RES=HYP_2F1(B,A,C,Z) + RETURN + ELSE IF((.NOT.CAB_CONDITION).AND.(AB_CONDITION)) THEN + RES=((-ZM1)**(C-A-B))*HYP_2F1(C-B,C-A,C,Z) + RETURN + ELSE + RES=((-ZM1)**(C-A-B))*HYP_2F1(C-A,C-B,C,Z) + RETURN + ENDIF + ENDIF + ABS_ZM1=ABS(ZM1) + IF(ABS_ZM1.LT.1D-5) THEN + RES=HYP_PS_ONE (A,B,C,-ZM1) + RETURN + ENDIF + ABS_Z=ABS(Z); ABS_Z_OVER_ZM1=ABS_Z/ABS_ZM1; ABS_Z_INV=ONE/ABS_Z + ABS_ZM1_OVER_Z=ONE/ABS_Z_OVER_ZM1; ABS_ZM1_INV=ONE/ABS_ZM1 + IS_CMB_SMALL = INF_NORM(C-B).LT.5.0D0; + ARE_AC_SMALL = (INF_NORM(A).LT.5.0D0).AND.(INF_NORM(C).LT.5.0D0) + ARE_ABC_SMALL = ARE_AC_SMALL.AND.(INF_NORM(B).LT.5.0D0) + ARE_A_CMB_C_SMALL = ARE_AC_SMALL.AND.IS_CMB_SMALL + R_TABLE=(/0.5D0,0.6D0,0.7D0,0.8D0,0.9D0/) + DO I=1,5 + R=R_TABLE(I) + IF(ABS_Z.LE.R) THEN + RES=HYP_PS_ZERO (A,B,C,Z) + RETURN + ENDIF + IF(IS_CMB_SMALL.AND.(ABS_Z_OVER_ZM1.LE.R)) THEN + RES=((-ZM1)**(-A))*HYP_PS_ZERO (A,C-B,C,Z/ZM1) + RETURN + ENDIF + ENDDO + DO I=1,5 + R=R_TABLE(I) + IF(ABS_Z_INV.LE.R) THEN + RES=HYP_PS_INFINITY (A,B,C,Z) + RETURN + ENDIF + IF(IS_CMB_SMALL.AND.(ABS_ZM1_OVER_Z.LE.R)) THEN + RES=((-ZM1)**(-A))*HYP_PS_INFINITY (A,C-B,C,Z/ZM1) + RETURN + ENDIF + IF(ARE_ABC_SMALL.AND.(ABS_ZM1.LE.R)) THEN + RES=HYP_PS_ONE (A,B,C,-ZM1) + RETURN + ENDIF + IF(ARE_A_CMB_C_SMALL.AND.(ABS_ZM1_INV.LE.R)) THEN + RES=((-ZM1)**(-A))*HYP_PS_ONE (A,C-B,C,-ONE/ZM1) + RETURN + ENDIF + ENDDO + RES=HYP_PS_COMPLEX_PLANE_REST (A,B,C,Z) + RETURN +END FUNCTION HYP_2F1 + + + +! +!---------------------------------------------------------------------- +! Test of 2F1 numerical accuracy +! ------------------------------ +! using hypergeometric differential equation +! ------------------------------------------ +! If z = 0, F(z) = 1 so that this value is trivially tested. +! To test otherwise if the value of F(z) is accurate, +! one uses the fact that +! z(z-1) F''(z) + (c - (a+b+1) z) F'(z) - a b F(z) = 0. +! If z is not equal to one, a relative precision test is provided +! by |F''(z) + [(c - (a+b+1) z) F'(z) - a b F(z)]/[z(z-1)]|oo +! /(|F(z)|oo + F'(z)|oo + |F''(z)|oo). +! If z is equal to one, one uses |(c - (a+b+1)) F'(z) - a b F(z)|oo +! /(|F(z)|oo + F'(z)|oo + 1E-307). +! F'(z) and F''(z) are calculated using equalities +! F'(z) = (a b/c) 2F1(a+1,b+1,c+1,z) +! and F'(z) = ((a+1)(b+1)/(c+1)) (a b/c) 2F1(a+2,b+2,c+2,z). +! +! Variables +! --------- +! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) +! F,dF,d2F: F(z), F'(z) and F''(z) calculated with hyp_2F1 +! using F'(z) = (a b/c) 2F1(a+1,b+1,c+1,z) +! and F'(z) = ((a+1)(b+1)/(c+1)) (a b/c) 2F1(a+2,b+2,c+2,z). +!---------------------------------------------------------------------- + +FUNCTION TEST_2F1(A,B,C,Z,F) + !-------------------------------------------------------------------- + USE HYP_2F1_MODULE + IMPLICIT NONE + + COMPLEX(PR),INTENT(IN) :: A,B,C,Z + REAL(PR) :: TEST_2F1 + COMPLEX(PR) :: F,DF,D2F,HYP_2F1 + ! + IF(Z.EQ.ZERO) THEN + TEST_2F1=INF_NORM(F-ONE) + RETURN + ELSE IF(Z.EQ.ONE) THEN + DF = HYP_2F1(A+ONE,B+ONE,C+ONE,Z)*A*B/C + TEST_2F1=INF_NORM((C-(A+B+ONE))*DF-A*B*F) & + /(INF_NORM (F)+INF_NORM(DF)+1D-307) + RETURN + ELSE + DF = HYP_2F1(A+ONE,B+ONE,C+ONE,Z)*A*B/C + D2F = HYP_2F1(A+TWO,B+TWO,C+TWO,Z)*A*(A+ONE)*B*(B+ONE) & + /(C*(C+ONE)) + TEST_2F1=INF_NORM(D2F+((C-(A+B+ONE)*Z)*DF-A*B*F)/(Z*(ONE-Z))) & + /(INF_NORM(F)+INF_NORM(DF)+INF_NORM(D2F)) + RETURN + ENDIF +END FUNCTION TEST_2F1 +! +!============== END HYP_2F1 FILE ====================================== + diff --git a/fieldinf/infbg.f90 b/fieldinf/infbg.f90 new file mode 100644 index 0000000..424d7ca --- /dev/null +++ b/fieldinf/infbg.f90 @@ -0,0 +1,1582 @@ +module infbg + use infprec, only : kp, tolkp + use infbgmodel, only : matterNum, dilatonNum, fieldNum +!background evolution in the Einstein FLRW Frame for multifields: +!scalar gravity + matter fields. + + implicit none + + private + + +!for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_file = .false. + + +!to store snapshot (ini or end, or more) + type infbgphys + sequence + real(kp) :: efold, hubble, epsilon1, epsilon1JF + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum) :: fieldDot + end type infbgphys + + +!to store the bg integration as chained list + type infbgdata + type(infbgphys) :: bg + type(infbgdata), pointer :: ptr => null() + end type infbgdata + + + interface operator (==) + module procedure infbgphys_equal + end interface + + + interface operator (/=) + module procedure infbgphys_unequal + end interface + + + + public infbgdata, infbgphys + public operator(==),operator(/=) + public free_infbg_data, count_infbg_data + + public set_infbg_ini + public rescale_potential + public bg_field_evol, bg_field_dot_coupled + + public slowroll_first_parameter, slowroll_first_parameter_JF + public slowroll_second_parameter, hubble_parameter_square + + public potential, deriv_potential, deriv_second_potential + + public connection_affine, deriv_connection_affine + + public matter_energy_density, matter_energy_density_JF + + +contains + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!recursivity need enough stacksize for big lists, otherwise it +!segfaults. Only needed to store and free the data in memory. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function infbgphys_equal(infbgphysA, infbgphysB) + implicit none + type(infbgphys), intent(in) :: infbgphysA, infbgphysB + logical :: infbgphys_equal + + infbgphys_equal = ((infbgphysA%efold == infbgphysB%efold) & + .and. (infbgphysA%hubble == infbgphysB%hubble) & + .and. (infbgphysA%epsilon1 == infbgphysB%epsilon1) & + .and. (infbgphysA%epsilon1JF == infbgphysB%epsilon1JF) & + .and. all(infbgphysA%field == infbgphysB%field) & + .and. all(infbgphysA%fieldDot == infbgphysB%fieldDot)) + + end function infbgphys_equal + + + + function infbgphys_unequal(infbgphysA, infbgphysB) + implicit none + type(infbgphys), intent(in) :: infbgphysA, infbgphysB + logical :: infbgphys_unequal + + infbgphys_unequal = ((infbgphysA%efold /= infbgphysB%efold) & + .or. (infbgphysA%hubble /= infbgphysB%hubble) & + .or. (infbgphysA%epsilon1 /= infbgphysB%epsilon1) & + .or. (infbgphysA%epsilon1JF /= infbgphysB%epsilon1JF) & + .or. any(infbgphysA%field /= infbgphysB%field) & + .or. any(infbgphysA%fieldDot /= infbgphysB%fieldDot)) + + end function infbgphys_unequal + + + + recursive subroutine free_infbg_data(ptrFirst) + implicit none + type(infbgdata), pointer :: ptrFirst + + if (associated(ptrFirst%ptr)) call free_infbg_data(ptrFirst%ptr) + deallocate(ptrFirst) + + end subroutine free_infbg_data + + + + recursive function count_infbg_data(ptrFirst) result(bgdataCount) + implicit none + integer :: bgdataCount + type(infbgdata), pointer :: ptrFirst + + bgdataCount = 1 + if (associated(ptrFirst%ptr)) then + bgdataCount = count_infbg_data(ptrFirst%ptr) + 1 + endif + + end function count_infbg_data + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!inflation settings: initial conditions, rescaling, normalisation... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function set_infbg_ini(infParam) +!to start on the attractor. This is epsilon2 = 0 for epsilon1<<1 +!initialy. + use infbgmodel, only : infbgparam, metric_inverse + use infsrmodel, only : slowroll_initial_matter_lf + use infsrmodel, only : slowroll_initial_matter_sf + use infsrmodel, only : slowroll_initial_matter_hy + use infsrmodel, only : slowroll_initial_matter_rm + use infsrmodel, only : slowroll_initial_matter_kksf + use infsrmodel, only : slowroll_initial_matter_kklt + use infsrmodel, only : slowroll_initial_matter_mix + + implicit none + type(infbgparam), intent(in) :: infParam + type(infbgphys) :: set_infbg_ini + + real(kp) :: hubbleSquareIni + type(infbgphys) :: infIni + + + infIni%field(1:matterNum) = infParam%matters + infIni%field(matterNum+1:fieldNum) = infParam%conforms + + +!if the matter fields are set to 0, use slow-roll guesses + if (all(infParam%matters == 0._kp)) then + + select case (infParam%name) + + case ('largef') + infIni%field(1:matterNum) = slowroll_initial_matter_lf(infParam) + + case ('smallf') + infIni%field(1:matterNum) = slowroll_initial_matter_sf(infParam) + + case ('hybrid') + infIni%field(1:matterNum) = slowroll_initial_matter_hy(infParam) + + case ('runmas') + infIni%field(1:matterNum) = slowroll_initial_matter_rm(infParam) + + case ('kklmmt') + infIni%field(1:matterNum) = slowroll_initial_matter_kklt(infParam) + + case ('mixinf') + infIni%field(1:matterNum) = slowroll_initial_matter_mix(infParam) + + + end select + + endif + + + infIni%fieldDot & + = - matmul(metric_inverse(infIni%field),deriv_ln_potential(infIni%field)) +! infIni%fieldDot = 0._kp +! print *,'initial condition fieldDot=',infIni%fieldDot + +! infIni%fieldDot(1)=1. +! infIni%fieldDot(2)=-0.5 +! infIni%fieldDot(3)=0.6 + + hubbleSquareIni = hubble_parameter_square(infIni%field,infIni%fieldDot,.false.) + + if (hubbleSquareIni.ge.0._kp) then + infIni%hubble = sqrt(hubbleSquareIni) + else + stop 'H^2 < 0, check initial condition' + endif + + infIni%epsilon1 = slowroll_first_parameter(infIni%field,infIni%fieldDot, .false.) + infIni%epsilon1JF = slowroll_first_parameter_JF(infIni%field, infIni%fieldDot,.false.) + infIni%efold = 0._kp + + set_infbg_ini = infIni + + if (display) then + if (infIni%epsilon1.lt.epsilon(1._kp)) then + write(*,*) + write(*,*)'set_infbg_ini: epsilon1 < accuracy',infIni%epsilon1 + write(*,*) + endif + endif + + end function set_infbg_ini + + + + + + subroutine rescale_potential(scale,infParam,infIni,infEnd,infObs,ptrBgdata) +!update all relevant data such as Unew = scale*Uold + use infbgmodel, only : infbgparam, conformal_factor_square + use infbgmodel, only : set_infbg_param + implicit none + type(infbgparam), intent(inout) :: infParam + type(infbgphys), intent(inout) :: infIni,infEnd,infObs + type(infbgdata), optional, pointer :: ptrBgdata + real(kp), intent(in) :: scale + + type(infbgdata), pointer :: ptrRun + logical :: updateBgParams + + ptrRun => null() + +!see infbgmodel U propto M^4 + infParam%consts(1) = infParam%consts(1)*scale**0.25 + + updateBgParams = set_infbg_param(infParam) + if (.not.updateBgParams) stop 'rescale_potential: updating params failed!' + + infIni%hubble = infIni%hubble * sqrt(scale) + infEnd%hubble = infEnd%hubble * sqrt(scale) + infObs%hubble = infObs%hubble * sqrt(scale) + + if (present(ptrBgData)) then + if (associated(ptrBgdata)) then + ptrRun => ptrBgdata + do while (associated(ptrRun)) + ptrRun%bg%hubble = ptrRun%bg%hubble * sqrt(scale) + ptrRun => ptrRun%ptr + enddo + ptrRun => null() + else + stop 'rescale_potential_by: data not found' + endif + endif + + end subroutine rescale_potential + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!inflationary evolution: find end of inflation + store relevant quantities +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function bg_field_evol(infIni,efoldDataNum,infObs,ptrStart,stopAtThisValue,isStopAtMax) +!integrate the background until epsilon > epsilonStop, and returns some +!physical values (type infbgphys) for which epsilon = epsilon1EndInf (=1) + + use infprec, only : transfert + use inftools, only : easydverk, tunedverk, zbrent + use infbgmodel, only : conformal_factor_square + use infinout + + implicit none + + type(infbgphys), intent(in) :: infIni +!number of wanted stored efold. If accuracy is not enough, the real +!number of stored efold is modified !up to +!efoldBeforeEndObs/efoldStepDefault + integer, optional, intent(in) :: efoldDataNum + type(infbgphys), optional, intent(out) :: infObs + type(infbgdata), optional, pointer :: ptrStart + real(kp), optional, intent(in) :: stopAtThisValue + logical, optional, intent(in) :: isStopAtMax + type(infbgphys) :: bg_field_evol + + + real(kp) :: epsilon1, epsilon1JF + real(kp) :: epsilon2 + +!if ptrBgdata input without data number, this is the default storage step + real(kp), parameter :: efoldStepDefault = 1._kp + +!we cannot discover inflation longer on this computer + real(kp) :: efoldHuge + +!how many efold after end inflation are stored (work only with +!useVelocity=T) + real(kp) :: efoldExploreOsc + +!observable perturbations were produced after that + real(kp), parameter :: efoldBeforeEndObs = 120._kp + real(kp) :: efoldObs + + real(kp) :: hubbleSquare, hubble, hubbleEndInf + real(kp) :: hubbleSquareIni, hubbleIni + + real(kp) :: efold,efoldNext,efoldStepObs, efoldStepNoObs + + real(kp) :: efoldBeforeEndInf,efoldEndInf + real(kp) :: efoldAfterEndInf + + real(kp), dimension(fieldNum) :: field,derivField + real(kp), dimension(fieldNum) :: fieldEndInf,derivFieldEndInf + real(kp), dimension(fieldNum) :: derivFieldAfterEndInf + real(kp), dimension(2*fieldNum) :: bgVar, bgVarIni + +!standard integration accuracy +! real(kp), parameter :: tolEvol = 1e-11 + real(kp), parameter :: tolEvol = tolkp + +!backward integration accuracy (sometime instable, mayneed extra precision) + real(kp) :: tolBackEvol + +!if true derivField=Dfield/Dtphys, otherwise derivField=Dfield/Defold is +!used for the integration. In both cases, only Dfield/Defold is +!stored + logical, parameter :: useVelocity = .true. +!end inflation when epsilon1=1 in Jordan Frame, or in Einstein Frame +!Physics says in JF, but both are the same up to 2% when the dilaton coupling are set to 1 +!Today dilaton couplings are 0.01 maxi, and they are constant or null in our model. +!Integration stops when epsilon1(useJF or not) > epsilon1Stop + real(kp), parameter :: epsilon1Stop = 1 + logical, parameter :: useEpsilon1JF = .false. + +!zbrent accuracy on efoldEnd for which epsilon=epsilon1Stop + real(kp), parameter :: tolEfoldEnd = tolkp + +!another test, checked after epsilon1 values to stop integration. May +!be convenient for hybrid-like one field potential: stop integration +!when the min value of the matter fields is below matterMiniStop, or +!according to the total number of efolds + logical, parameter :: accurateEndInf = .true. + real(kp) :: efoldMaxiStop + logical :: checkHubbleStop + logical :: checkMatterStop + logical :: stopForMax + + real(kp) :: valueStop + integer, parameter :: stopIndexMin = 1, stopIndexMax = 1 + + logical :: inflate, longEnoughObs + +!to make f77 routines discussing together + type(transfert) :: stopData, findData + +!to store the data as chained list + type(infbgdata), pointer :: ptrCurrent + type(infbgdata), pointer :: ptrPrevious + + integer :: neqs + + +!initialisation !!!!!!!!!!!!!!! + tolBackEvol = tolEvol + efoldHuge = 1._kp/epsilon(1._kp) + neqs = 2*fieldNum + + if (present(infObs)) then + infObs = infIni + endif + + efoldExploreOsc = 5. + +!enabled by true + + checkHubbleStop = .false. + + checkMatterStop = .false. + + efoldMaxiStop = 200. + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + efoldHuge = min(efoldMaxiStop,efoldHuge) + + +!checks + if (present(ptrStart)) then + if (associated(ptrStart)) then + stop 'bg_field_evol: ptr to bgdata already associated' + endif + endif + + + + if ((.not.useVelocity).and.efoldExploreOsc.ne.0) then + write(*,*)'bg_field_evol: oscillation exploration disabled!' + efoldExploreOsc = 0. + endif + + if (present(isStopAtMax)) then + stopForMax = isStopAtMax + else + stopForMax = .false. + endif + + if (present(stopAtThisValue)) then + valueStop = stopAtThisValue + if ((.not.checkMatterStop).and.checkHubbleStop) then + if (display) write(*,*)'bg_field_evol: check for Hubble stop enabled' + else + if (display) write(*,*)'bg_field_evol: check for Matter stop enabled' + if (display) write(*,*)'bg_field_evol: stopForMax is',stopForMax + checkHubbleStop = .false. + checkMatterStop = .true. + endif + else + valueStop = tolEvol + endif + +!set initial conditions + + hubbleSquareIni = hubble_parameter_square(infIni%field,infIni%fieldDot,.false.) + if (hubbleSquareIni.ge.0d0) then + hubbleIni = sqrt(hubbleSquareIni) + else + stop 'bg_field_evol: hubbleSquareIni < 0' + endif + bgVarIni(1:fieldNum) = infIni%field(1:fieldNum) + if (useVelocity) then + bgVarIni(fieldNum+1:2*fieldNum) = infIni%fieldDot(1:fieldNum)*hubbleIni + else + bgVarIni(fieldNum+1:2*fieldNum) = infIni%fieldDot(1:fieldNum) + endif + + +!localize rougthly the end of inflation: in fprime, a test stops dverk when epsilon>1 + efold = infIni%efold + bgVar = bgVarIni + +!initialize (all other subtypes may change) + stopData%yesno1 = useEpsilon1JF + stopData%yesno2 = checkMatterStop + stopData%yesno3 = stopForMax + stopData%yesno4 = checkHubbleStop + stopData%check = .false. + stopData%update = .false. + stopData%xend = efoldHuge + stopData%real1 = epsilon1Stop + stopData%real2 = valueStop! - 10._kp*tolEvol + stopData%int1 = stopIndexMin + stopData%int2 = stopIndexMax + + if (useVelocity) then +!derivField=Dfield/Dtphys + call easydverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldHuge,tolEvol & + ,stopData) + else +!derivField=Dfield/Defold + call easydverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldHuge,tolEvol & + ,stopData) + endif + +!up to dverk exploration +! efoldAfterEndInf = stopData%xend and something like bgVar = +! stopData%ptr after allocation + +! print *,'efold bg',efold,bgVar +! print *,'epsilon1',slowroll_first_parameter(bgVar(1:2), bgVar(3:4) & +! , useVelocity) + + + derivFieldAfterEndInf(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum) + + efoldAfterEndInf = efold + efoldBeforeEndInf = efoldAfterEndInf - efoldStepDefault + + + if (efoldBeforeEndInf.le.infIni%efold) then + if (display) write(*,*)'bg_field_evol: inflation too short' + bg_field_evol = infIni + return + endif + + + + +!precise determination of efoldEndInf up to tolEfoldEnd provided +!inflation is longer than efoldStepDefault efold + +!checkMatterMini stands for cases when epsilon1=epsilon1Stop does not +!define the end of inflation, so who cares about accurate +!determination + if ((.not.accurateEndInf).or.(efoldAfterEndInf.eq.efoldMaxiStop)) then + if (display) write(*,*)'bg_field_evol: endinf not determined accurately' + efoldEndInf = efoldAfterEndInf + fieldEndInf = bgVar(1:fieldNum) + derivFieldEndInf = bgVar(fieldNum+1:2*fieldNum) + hubbleEndInf & + = sqrt(hubble_parameter_square(fieldEndInf,derivFieldEndInf,useVelocity)) + + else + + +!careful localisation of the end of inflation move to +!efoldBeforeEndInf: background integration maybe unstable, precision +!is pushed to maximum accuracy + + + tolBackEvol = epsilon(1._kp) + + if (useVelocity) then + call tunedverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldBeforeEndInf & + ,tolBackEvol) + else + call tunedverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldBeforeEndInf & + ,tolBackEvol) + endif + +!use zbrent zero finder in [efoldBeforeEndInf, efoldAfterEndInf] + findData%yesno1 = useVelocity + findData%yesno2 = useEpsilon1JF + findData%yesno3 = stopForMax + findData%real1 = efold + allocate(findData%ptrvector1(2*fieldNum)) + allocate(findData%ptrvector2(2*fieldNum)) + findData%ptrvector1 = bgVar + findData%real2 = tolEvol + findData%real3 = valueStop + + findData%int1 = stopIndexMin + findData%int2 = stopIndexMax + +!find at tolEfoldEnd precision: the interval should be small +!(background integration of inflation is unstable) +! print *,'go in zbrent set',efoldBeforeEndInf,efoldAfterEndInf,findData%real1 + + if (checkHubbleStop.and.(.not.stopData%yesno2)) then + efoldEndInf = zbrent(find_endinf_hubble,efoldBeforeEndInf & + ,efoldAfterEndInf,tolEfoldEnd,findData) + elseif (checkMatterStop.and.(.not.stopData%yesno2)) then + efoldEndInf = zbrent(find_endinf_matter,efoldBeforeEndInf & + ,efoldAfterEndInf,tolEfoldEnd,findData) + else + efoldEndInf = zbrent(find_endinf_epsilon,efoldBeforeEndInf & + ,efoldAfterEndInf,tolEfoldEnd,findData) + endif + +!read the results in the findData buffer + fieldEndInf = findData%ptrvector2(1:fieldNum) + derivFieldEndInf = findData%ptrvector2(fieldNum+1:2*fieldNum) + hubbleEndInf & + = sqrt(hubble_parameter_square(fieldEndInf,derivFieldEndInf,useVelocity)) + endif + + + +!set the output values to bg_field_evol return + + bg_field_evol%hubble = hubbleEndInf + bg_field_evol%efold = efoldEndInf + bg_field_evol%field = fieldEndInf + + if (useVelocity) then + bg_field_evol%fieldDot = derivFieldEndInf/hubbleEndInf + else + bg_field_evol%fieldDot = derivFieldEndInf + endif + bg_field_evol%epsilon1 = slowroll_first_parameter(fieldEndInf, derivFieldEndInf & + , useVelocity) + bg_field_evol%epsilon1JF = slowroll_first_parameter_JF(fieldEndInf, derivFieldEndInf & + , useVelocity) + + if (associated(findData%ptrvector1)) deallocate(findData%ptrvector1) + if (associated(findData%ptrvector2)) deallocate(findData%ptrvector2) + + +!save some data in memory if ptr input is present, recomputes the +!background knowing the end of inflation. Whatever the total number of +!efold, the last relevant efold (after efoldBeforeEndObs) are +!sampled according to efoldStepDefault + + efoldObs = efoldEndInf - efoldBeforeEndObs +! print *,'efoldObs efoldEndInf',efoldObs,efoldEndInf + + if (present(efoldDataNum)) then + if (efoldDataNum.le.1) return + endif + + + + if (present(ptrStart)) then +!for debugging + if (dump_file) then + call delete_file('field.dat') + call delete_file('derivfield.dat') + call delete_file('geom.dat') + call delete_file('epsilon1.dat') + call delete_file('epsilon2.dat') + call delete_file('hubble.dat') + call delete_file('potential.dat') + call delete_file('confsquare.dat') + call delete_file('a2chi2.dat') + endif + + + if (present(efoldDataNum)) then + if (efoldObs - infIni%efold.gt.0.) then + longEnoughObs = .true. + efoldStepNoObs = 2.*(efoldObs - infIni%efold)/real(efoldDataNum-1) + efoldStepObs = 2.*efoldBeforeEndObs/real(efoldDataNum-1) + efoldStepNoObs = max(efoldStepNoObs,efoldStepObs) + else + longEnoughObs = .false. + efoldStepNoObs = 0. + efoldStepObs = (efoldEndInf - infIni%efold)/real(efoldDataNum/2-1) + endif + else + longEnoughObs = .false. + efoldStepNoObs = efoldStepDefault + efoldStepObs = efoldStepDefault + endif + +!initialisation + efold = infIni%efold + bgVar = bgVarIni + + inflate = .true. + + ptrCurrent => null() + ptrPrevious => null() + +! i=0 + + do + +!compute the saved physical quantities + field = bgVar(1:fieldNum) + derivField = bgVar(fieldNum+1:2*fieldNum) + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + epsilon1 = slowroll_first_parameter(field,derivField,useVelocity) + epsilon1JF = slowroll_first_parameter_JF(field,derivField,useVelocity) + + if (hubbleSquare.ge.0d0) then + hubble = sqrt(hubbleSquare) + else + print *,'efold',efold + stop 'bg_field_evol: hubbleSquare < 0' + endif + + +!save the physical quantities as a chained list + + if (.not.associated(ptrStart)) then + allocate(ptrStart); ptrStart%ptr => null(); ptrCurrent => ptrStart + else + allocate(ptrCurrent); ptrCurrent%ptr => null(); ptrPrevious%ptr => ptrCurrent + endif + ptrCurrent%bg%efold = efold + ptrCurrent%bg%hubble = hubble + ptrCurrent%bg%epsilon1 = epsilon1 + ptrCurrent%bg%epsilon1JF = epsilon1JF + ptrCurrent%bg%field = field +! i=i+1 +! print *,'stored efold',ptrCurrent%bg%efold,i + if (useVelocity) then + ptrCurrent%bg%fieldDot = derivField/hubble + else + ptrCurrent%bg%fieldDot = derivField + endif + ptrPrevious => ptrCurrent + +!slow down a lot the computation: for test! + if (dump_file) then + call livewrite('field.dat',efold,bgVar(1),bgVar(2),bgVar(3)) + call livewrite('derivfield.dat',efold, ptrCurrent%bg%fieldDot(1) & + ,ptrCurrent%bg%fieldDot(2)) + call livewrite('hubble.dat',efold,hubble) + call livewrite('epsilon1.dat',efold,epsilon1,epsilon1JF) + epsilon2 = slowroll_second_parameter(field,derivField,useVelocity) + call livewrite('epsilon2.dat',efold,epsilon2) + call livewrite('potential.dat',efold,potential(bgVar(1:fieldNum))) + call livewrite('confsquare.dat',efold & + ,conformal_factor_square(bgVar(matterNum+1:fieldNum))) + call livewrite('a2chi2.dat',efold & + ,conformal_factor_square(bgVar(matterNum+1:fieldNum)) & + *bgVar(1)*bgVar(1)) + endif + + + if (efold.eq.efoldObs) then + if (present(infObs)) then + if (infObs%efold.eq.infIni%efold) then + infObs%efold = efold + infObs%field = field + infObs%hubble = hubble + infObs%fieldDot = ptrCurrent%bg%fieldDot + infObs%epsilon1 = epsilon1 + infObs%epsilon1JF = slowroll_first_parameter_JF(field, derivField & + , useVelocity) +! print *,'infObs set',infObs + endif + endif + endif + + + if (longEnoughObs.and.(efold.lt.efoldObs)) then + efoldNext = min(efold + efoldStepNoObs,efoldObs) + else + efoldNext = min(efold + efoldStepObs,efoldAfterEndInf + efoldExploreOsc) + endif + +! print *,'efoldNExt',efoldNext +! read(*,*) + + +!avoid the next step + if (.not.inflate) exit + +!integration again with the stopping criteria + if (useVelocity) then + if (efoldNext.ge.(efoldAfterEndInf + efoldExploreOsc)) then + inflate = .false. + endif +!derivField=Dfield/Dtphys + call easydverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldNext,tolEvol) + + else + if (efoldNext.ge.efoldAfterEndInf) then + inflate = .false. + endif +!derivField=Dfield/Defold + call easydverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldNext,tolEvol) + endif + + enddo + + ptrCurrent => null() + ptrPrevious => null() + + endif + + + end function bg_field_evol + + + + + function find_endinf_epsilon(efold,findData) + use inftools, only : tunedverk + use infprec, only : transfert + implicit none + real(kp), intent(in) :: efold + type(transfert), optional, intent(inout) :: findData + real(kp) :: find_endinf_epsilon + + logical :: useVelocity, useEpsilon1JF + real(kp) :: efoldStart + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum) :: field, derivField + + useEpsilon1JF = findData%yesno2 + useVelocity = findData%yesno1 + efoldStart = findData%real1 + + + if ((.not.associated(findData%ptrvector1)) & + .or.(.not.associated(findData%ptrvector2))) then + stop 'find_endif: ptrvector not associated' + endif + + bgVar = findData%ptrvector1 + +!backward integration from efoldStart found in bg_evol to the wanted efold + if (useVelocity) then + call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar & + ,efold,findData%real2) + else + call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar & + ,efold,findData%real2) + endif + + findData%ptrvector2 = bgVar + + field = bgVar(1:fieldNum) + derivField = bgVar(fieldNum+1:2*fieldNum) + + +!difference between the epsilon corresponding to the current efold and +!the one wanted to end inflation (=1). The efoldEnd is the zero of +!this function. Striclty speaking inflation ends when epsilon1JF=1. + + if (useEpsilon1JF) then + find_endinf_epsilon & + = slowroll_first_parameter_JF(field,derivField,findData%yesno1) - 1._kp + else + find_endinf_epsilon & + = slowroll_first_parameter(field,derivField,findData%yesno1) - 1._kp + endif + + findData%real3 = find_endinf_epsilon + 1._kp + + + end function find_endinf_epsilon + + + + + function find_endinf_matter(efold,findData) + use inftools, only : tunedverk + use infprec, only : transfert + implicit none + real(kp), intent(in) :: efold + type(transfert), optional, intent(inout) :: findData + real(kp) :: find_endinf_matter + + integer :: ifMin,ifMax + logical :: useVelocity, stopForMatterMax + real(kp) :: efoldStart, matterStop + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum) :: field + + + useVelocity = findData%yesno1 + stopForMatterMax = findData%yesno3 + efoldStart = findData%real1 + matterStop = findData%real3 + + ifMin = findData%int1 + ifMax = findData%int2 + + + if ((.not.associated(findData%ptrvector1)) & + .or.(.not.associated(findData%ptrvector2))) then + stop 'find_endif: ptrvector not associated' + endif + + bgVar = findData%ptrvector1 + +!backward integration from efoldStart found in bg_evol to the wanted efold + if (useVelocity) then + call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar & + ,efold,findData%real2) + else + call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar & + ,efold,findData%real2) + endif + + findData%ptrvector2 = bgVar + + field = bgVar(1:fieldNum) + +!difference between the min matter field value corresponding to the +!current efold and the one wanted to end inflation +!(matterMinStop). The efoldEnd is the zero of this function. + + if (stopForMatterMax) then + find_endinf_matter = maxval(field(ifMin:ifMax)) - matterStop + else + find_endinf_matter = minval(field(ifMin:ifMax)) - matterStop + endif + + + end function find_endinf_matter + + + + function find_endinf_hubble(efold,findData) + use inftools, only : tunedverk + use infprec, only : transfert + implicit none + real(kp), intent(in) :: efold + type(transfert), optional, intent(inout) :: findData + real(kp) :: find_endinf_hubble + + logical :: useVelocity + real(kp) :: efoldStart, hubbleStop,hubbleSquare + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum) :: field,derivField + + + useVelocity = findData%yesno1 + + efoldStart = findData%real1 + hubbleStop = findData%real3 + + + if ((.not.associated(findData%ptrvector1)) & + .or.(.not.associated(findData%ptrvector2))) then + stop 'find_endif: ptrvector not associated' + endif + + bgVar = findData%ptrvector1 + +!backward integration from efoldStart found in bg_evol to the wanted efold + if (useVelocity) then + call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar & + ,efold,findData%real2) + else + call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar & + ,efold,findData%real2) + endif + + findData%ptrvector2 = bgVar + + field = bgVar(1:fieldNum) + derivField = bgVar(fieldNum+1:2*fieldNum) + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + + + find_endinf_hubble = hubbleSquare - hubbleStop**2 + + + end function find_endinf_hubble + + + + + subroutine bg_field_dot_decoupled(neqs,efold,bgVar,bgVarDot,stopData) +!for derivField=Dfield/Defold the field equations decouple from the +!Hubble flow. However, this decomposition becomes singular when the +!potential vanishes and the integration fails a that point. Harmless +!for the inflationary era. + + use infprec, only : transfert + use infbgmodel, only : metric, metric_inverse + implicit none + + integer :: neqs + real(kp) :: efold + real(kp), dimension(neqs) :: bgVar + real(kp), dimension(neqs) :: bgVarDot + type(transfert), optional, intent(inout) :: stopData + + integer :: i + real(kp), dimension(fieldNum) :: dlnPotVec + real(kp), dimension(fieldNum) :: field, christVec + real(kp), dimension(fieldNum) :: fieldDot, fieldDotDot + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel + real(kp) :: fieldDotSquare, epsilon1, hubbleSquare + + logical, save :: stopNow=.false. + + + field = bgVar(1:fieldNum) + fieldDot = bgVar(fieldNum+1:2*fieldNum) + christoffel = connection_affine(field) + + fieldDotSquare = dot_product(fieldDot,matmul(metric(field),fieldDot)) + + if (present(stopData)) then +!use epsilon1JF or not to stop inflation + if (stopData%check) then + + if (stopData%yesno1) then + epsilon1 = slowroll_first_parameter_JF(field,fieldDot,.false.) + else + epsilon1 = fieldDotSquare/2d0 + endif + + if (stopData%yesno2) then + if (stopData%yesno3) then + stopNow = (maxval(field(stopData%int1:stopData%int2)) & + .gt.stopData%real2) + else + stopNow = (minval(field(stopData%int1:stopData%int2)) & + .lt.stopData%real2) + endif + endif + + if (stopData%yesno4) then + hubbleSquare = hubble_parameter_square(field,fieldDot,.false.) + stopNow = (hubbleSquare.lt.(stopData%real2)**2) + endif + + if (stopNow.or.(epsilon1.gt.stopData%real1)) then + stopData%update = .true. + stopData%xend = efold + stopData%yesno2 = .false. + stopData%yesno4 = .false. + endif + + endif + endif + + do i=1,fieldNum + christVec(i) = dot_product(fieldDot,matmul(christoffel(i,:,:),fieldDot)) + enddo + +! dlnPotVec = deriv_ln_potential_vec(field) + + dlnPotVec = matmul(metric_inverse(field),deriv_ln_potential(field)) + + fieldDotDot = -christVec - (3d0 - fieldDotSquare/2d0)*(fieldDot + dlnPotVec) + + bgVarDot(1:fieldNum) = fieldDot + bgVarDot(fieldNum+1:2*fieldNum) = fieldDotDot + + end subroutine bg_field_dot_decoupled + + + + + + subroutine bg_field_dot_coupled(neqs,efold,bgVar,bgVarDot,stopData) +!for derivField=Dfield/Dtphys the field equations are coupled to the +!hubble flow. This avoid the singular behavior of the decoupled +!equations and allows to properly sample the oscillations of the field +!at the end of inflation. + + use infprec, only : transfert + use infbgmodel, only : metric, metric_inverse + implicit none + + integer :: neqs + real(kp) :: efold + real(kp), dimension(neqs) :: bgVar + real(kp), dimension(neqs) :: bgVarDot + type(transfert), optional, intent(inout) :: stopData + + integer :: i + real(kp), dimension(fieldNum) :: dPotVec + real(kp), dimension(fieldNum) :: field, velocity + real(kp), dimension(fieldNum) :: fieldDot, velocityDot, christVec + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel + real(kp) :: velocitySquare, epsilon1, hubbleSquare, hubble + + logical, save :: stopNow = .false. + + + field = bgVar(1:fieldNum) + velocity = bgVar(fieldNum+1:2*fieldNum) + christoffel = connection_affine(field) + + velocitySquare = dot_product(velocity,matmul(metric(field),velocity)) + + do i=1,fieldNum + christVec(i) = dot_product(velocity(:),matmul(christoffel(i,:,:),velocity(:))) + enddo + +! dPotVec = deriv_potential_vec(field) + dPotVec = matmul(metric_inverse(field),deriv_potential(field)) + + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + if (hubbleSquare.ge.0.) then + hubble = sqrt(hubbleSquare) + else + print *,'field= ',field + print *,'velocity= ',velocity + stop 'bg_field_dot_coupled: hubbleSquare < 0' + endif + + if (present(stopData)) then +!use epsilon1JF or not to stop inflation + if (stopData%check) then + if (stopData%yesno1) then + epsilon1 = slowroll_first_parameter_JF(field,velocity,.true.) + else + epsilon1 = velocitySquare/2d0/hubbleSquare + endif + + if (stopData%yesno2) then + if (stopData%yesno3) then + stopNow = (maxval(field(stopData%int1:stopData%int2)) & + .gt.stopData%real2) + else + stopNow = (minval(field(stopData%int1:stopData%int2)) & + .lt.stopData%real2) + endif + endif + + if (stopData%yesno4) stopNow = hubble.le.stopData%real2 + + + if (stopNow.or.(epsilon1.gt.stopData%real1)) then + stopData%update = .true. + stopData%xend = efold + stopData%yesno2 = .false. + stopData%yesno4 = .false. + endif + +! print *,'efold field',efold,field +! print *,'eps1 eps2',epsilon1,slowroll_second_parameter(field,velocity,.true.) +! read(*,*) + endif + endif + + fieldDot = velocity/hubble + velocityDot = -3d0*velocity - (christVec + dPotVec)/hubble + + bgVarDot(1:fieldNum) = fieldDot + bgVarDot(fieldNum+1:2*fieldNum) = velocityDot + + end subroutine bg_field_dot_coupled + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!geometrical functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + + function hubble_parameter_square(field,derivField,useVelocity) +!in unit of kappa^2 + use infbgmodel, only : metric + implicit none + real(kp) :: hubble_parameter_square + real(kp), dimension(fieldNum), intent(in) :: field, derivfield + logical, intent(in) :: useVelocity + + real(kp) :: derivFieldSquare + + derivFieldSquare = dot_product(derivField,matmul(metric(field),derivField)) + + if (useVelocity) then + hubble_parameter_square = (derivFieldSquare + 2._kp*potential(field))/6._kp + else + hubble_parameter_square = 2._kp*potential(field)/(6._kp - derivFieldSquare) + endif + + end function hubble_parameter_square + + + + + function slowroll_first_parameter(field,derivField,useVelocity) +!epsilon1 = epsilon + use infbgmodel, only : metric + implicit none + real(kp) :: slowroll_first_parameter + real(kp), dimension(fieldNum), intent(in) :: field, derivField + logical, intent(in) :: useVelocity + + real(kp) :: derivFieldSquare, hubbleSquare + + derivFieldSquare = dot_product(derivField,matmul(metric(field),derivField)) + + if (useVelocity) then + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + slowroll_first_parameter = derivFieldSquare/2d0/hubbleSquare + else + slowroll_first_parameter = derivFieldSquare/2d0 + endif + + + end function slowroll_first_parameter + + + + + function slowroll_second_parameter(field,derivField,useVelocity) +!epsilon2 = 2(epsilon - delta) + implicit none + real(kp) :: slowroll_second_parameter + real(kp), dimension(fieldNum), intent(in) :: field, derivField + logical, intent(in) :: useVelocity + + real(kp), dimension(fieldNum) :: fieldDot + real(kp) :: epsilon1 + real(kp) :: hubbleSquare, derivPotFieldDot + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + + if (useVelocity) then + fieldDot = derivField/sqrt(hubbleSquare) + else + fieldDot = derivField + endif + + epsilon1 = slowroll_first_parameter(field,derivField,useVelocity) + + if (epsilon1.ne.0.) then + derivPotFieldDot = dot_product(deriv_potential(field),fieldDot) + + slowroll_second_parameter = -6d0 + 2d0*epsilon1 & + - derivPotFieldDot/(epsilon1*hubbleSquare) + else + slowroll_second_parameter = 0. + endif + + end function slowroll_second_parameter + + + + + function slowroll_first_parameter_JF(field,derivField,useVelocity) +!this is epsilon1 EF, up to 2% when dilaton couplings = 1 + use infbgmodel, only : conformal_first_gradient, conformal_second_gradient + use infbgmodel, only : metric_inverse + implicit none + real(kp) :: slowroll_first_parameter_JF + real(kp), dimension(fieldNum), intent(in) :: field, derivField + logical, intent(in) :: useVelocity + + real(kp), dimension(fieldNum) :: christVec, fieldDot, potDerivVec + real(kp), dimension(dilatonNum) :: dilaton, dilatonDot,confFirstGrad + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel + real(kp) :: derivFieldSquare, hubbleSquare, epsilon1, epsilon1Xfactor, shift + real(kp) :: confFirstGradXdilDot + + integer :: i + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + + if (useVelocity) then + fieldDot = derivField/sqrt(hubbleSquare) + else + fieldDot = derivField + endif + + dilaton = field(matterNum+1:fieldNum) + dilatonDot = fieldDot(matterNum+1:fieldNum) + confFirstGrad = conformal_first_gradient(dilaton) + confSecondGrad = conformal_second_gradient(dilaton) +! potDerivVec = deriv_potential_vec(field) + potDerivVec = matmul(metric_inverse(field),deriv_potential(field)) + christoffel = connection_affine(field) + + do i=1,fieldNum + christVec(i) = dot_product(fieldDot(:),matmul(christoffel(i,:,:),fieldDot(:))) + enddo + + confFirstGradXdilDot = dot_product(confFirstGrad,dilatonDot) + + epsilon1 = slowroll_first_parameter(field,derivField,useVelocity) + + + epsilon1Xfactor = (epsilon1 + confFirstGradXdilDot)/(1._kp + confFirstGradXdilDot) + + + shift = ((3._kp - epsilon1)*confFirstGradXdilDot & + + dot_product(confFirstGrad,christVec(matterNum+1:fieldNum)) & + + dot_product(confFirstGrad,potDerivVec(matterNum+1:fieldNum)/hubbleSquare) & + - dot_product(dilatonDot, matmul(confSecondGrad,dilatonDot))) & + / (1._kp + confFirstGradXdilDot)**2 + + + slowroll_first_parameter_JF = epsilon1Xfactor + shift + + + end function slowroll_first_parameter_JF + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!gravity sector functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function connection_affine(field) +!first index contravariant, 2 others covariant and symmetric + use infbgmodel, only : metric_inverse, conformal_first_gradient + use infbgmodel, only : conformal_factor_square + implicit none + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum,fieldNum) :: metricInv + real(kp), dimension(dilatonNum,dilatonNum) :: metricInvConf + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: connection_affine + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton + real(kp), dimension(dilatonNum) :: confFirstGradVec, confFirstGrad + + integer :: i + + connection_affine = 0._kp + + metricInv = metric_inverse(field) + metricInvConf(1:dilatonNum,1:dilatonNum) & + = metricInv(matterNum+1:fieldNum,matterNum+1:fieldNum) + + dilaton=field(matterNum+1:fieldNum) + confFirstGrad = conformal_first_gradient(dilaton) + confFirstGradVec = matmul(metricInvConf,confFirstGrad) + confSquare = conformal_factor_square(dilaton) + + do i=1,dilatonNum + connection_affine(1:matterNum,1:matterNum,matterNum+i) & + = confFirstGrad(i) + connection_affine(1:matterNum,matterNum+i,1:matterNum) & + = confFirstGrad(i) + enddo + + do i=1,matterNum + connection_affine(matterNum+1:fieldNum,i,i) & + = - confSquare * confFirstGradVec(1:dilatonNum) + enddo + + + end function connection_affine + + + + + function deriv_connection_affine(field) +!first partial derivative of the christoffel: first index contrariant, +!3 others covariant + use infbgmodel, only : metric_inverse, conformal_first_gradient + use infbgmodel, only : conformal_second_gradient, conformal_factor_square + implicit none + + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum,fieldNum) :: metricInv + real (kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv + real(kp), dimension(fieldNum,fieldNum,fieldNum,fieldNum) :: deriv_connection_affine + + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad, confFirstGradVec + real(kp), dimension(dilatonNum,dilatonNum) :: metricInvConf + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad, confSecondGradVec + integer :: i,j,k + + deriv_connection_affine = 0._kp + + dilaton(1:dilatonNum) = field(matterNum+1:fieldNum) + confSquare = conformal_factor_square(dilaton) + +! metricDeriv = deriv_metric(field) + metricInv = metric_inverse(field) + metricInvConf = metricInv(matterNum+1:fieldNum,matterNum+1:fieldNum) + + confFirstGrad = conformal_first_gradient(dilaton) + confFirstGradVec = matmul(metricInvConf,confFirstGrad) + confSecondGrad = conformal_second_gradient(dilaton) + confSecondGradVec = matmul(metricInvConf,confSecondGrad) + + + do j=1,dilatonNum + do i=1,dilatonNum + + deriv_connection_affine(1:matterNum,1:matterNum,matterNum+i,matterNum+j) & + = confSecondGrad(i,j) + deriv_connection_affine(1:matterNum,matterNum+i,1:matterNum,matterNum+j) & + = confSecondGrad(i,j) + + do k=1,matterNum + deriv_connection_affine(matterNum+i,k,k,matterNum+j) & + = - confSquare * (confSecondGradVec(i,j) & + + 2._kp * confFirstGradVec(i) * confFirstGrad(j)) + +!zero when the the metric for the dilaton is constant and diagonal +! + confSquare * dot_product(metricInvConf(i,:) & +! ,matmul(metricDeriv(matterNum+1:fieldNum,matterNum+1:fieldNum,j) & +! ,confFirstGradVec)) + enddo + + enddo + enddo + + + end function deriv_connection_affine + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!overall potential (matter + gravity) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function potential(field) +!S=1/(2kappa^2) {{ int{sqrt(-g) d^4 x} [ R - metric Dfield Dfield - 2*potential(Field)] }} + use infbgmodel, only : matter_potential, conformal_factor_square + implicit none + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(matterNum) :: matter + real(kp), dimension(dilatonNum) :: dilaton + real(kp) :: potential + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + potential = matter_potential(matter)*(conformal_factor_square(dilaton))**2 + + end function potential + + + + + function deriv_potential(field) +!with respect to the fields + use infbgmodel, only : deriv_matter_potential, conformal_first_gradient + use infbgmodel, only : conformal_factor_square + implicit none + real(kp), dimension(fieldNum) :: deriv_potential + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(matterNum) :: matter, derivMatterPot + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + + real(kp) :: potentialVal + + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + potentialVal = potential(field) + derivMatterPot = deriv_matter_potential(matter) + confFirstGrad = conformal_first_gradient(dilaton) + + deriv_potential(1:matterNum) & + = derivMatterPot(1:matterNum)*(conformal_factor_square(dilaton))**2 + + deriv_potential(matterNum+1:fieldNum) & + = 4._kp*confFirstGrad(1:dilatonNum)*potentialVal + + end function deriv_potential + + + + + function deriv_second_potential(field) + use infbgmodel, only : deriv_matter_potential, deriv_second_matter_potential + use infbgmodel, only : conformal_first_gradient, conformal_second_gradient + use infbgmodel, only : conformal_factor_square + implicit none + real(kp), dimension(fieldNum,fieldNum) :: deriv_second_potential + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(fieldNum) :: derivPot + real(kp), dimension(matterNum) :: matter, derivMatterPot + real(kp), dimension(matterNum,matterNum) :: derivSecondMatterPot + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad + + real(kp) :: potentialVal + integer :: i,j + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + potentialVal = potential(field) + + derivPot = deriv_potential(field) + derivMatterPot = deriv_matter_potential(matter) + derivSecondMatterPot = deriv_second_matter_potential(matter) + + confFirstGrad = conformal_first_gradient(dilaton) + confSecondGrad = conformal_second_gradient(dilaton) + + deriv_second_potential(1:matterNum,1:matterNum) & + = derivSecondMatterPot(1:matterNum,1:matterNum) & + *(conformal_factor_square(dilaton))**2 + + do i=1,matterNum + deriv_second_potential(i,matterNum+1:fieldNum) & + = derivPot(i) * 4._kp*confFirstGrad(1:dilatonNum) + deriv_second_potential(matterNum+1:fieldNum,i) & + = deriv_second_potential(i,matterNum+1:fieldNum) + enddo + + do i=1,dilatonNum + do j=1,dilatonNum + deriv_second_potential(matterNum+i,matterNum+j) = potentialVal & + * (4._kp*confSecondGrad(i,j) + 4._kp*confFirstGrad(i) & + * 4._kp*confFirstGrad(j)) + enddo + enddo + + end function deriv_second_potential + + + + + function deriv_ln_potential(field) + use infbgmodel, only : conformal_first_gradient + implicit none + real(kp), dimension(fieldNum) :: deriv_ln_potential + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(matterNum) :: matter,derivLnMatterPot + real(kp), dimension(dilatonNum) :: dilaton,confFirstGrad + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + derivLnMatterPot = deriv_ln_matter_potential(matter) + confFirstGrad = conformal_first_gradient(dilaton) + + deriv_ln_potential(1:matterNum) = derivLnMatterPot(1:matterNum) + + deriv_ln_potential(matterNum+1:fieldNum) = 4._kp*confFirstGrad(1:dilatonNum) + + end function deriv_ln_potential + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!matter sector functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function deriv_ln_matter_potential(matter) + use infbgmodel, only : matter_potential, deriv_matter_potential + implicit none + real(kp), dimension(matterNum) :: deriv_ln_matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: matterPotential + + matterPotential = matter_potential(matter) + + if (matterPotential.ne.0._kp) then + deriv_ln_matter_potential = deriv_matter_potential(matter)/matterPotential + else + stop 'infbg:deriv_ln_matter_potential: matter_potential vanishes!' + endif + +! deriv_ln_matter_potential(1) = 2._kp/chi + + end function deriv_ln_matter_potential + + + + + function matter_energy_density(field,velocity) +!energy density of the matter fields in the Einstein Frame +!A^2 (Dchi/Dtphys)^2 + A^4 U + use infbgmodel, only : matter_potential, conformal_factor_square + implicit none + real(kp) :: matter_energy_density + real(kp), dimension(fieldNum), intent(in) :: field,velocity + + real(kp), dimension(matterNum) :: matter, matterVel + real(kp), dimension(dilatonNum) :: dilaton + real(kp) :: confSquare + + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + matterVel = velocity(1:matterNum) + confSquare = conformal_factor_square(dilaton) + + matter_energy_density & + = 0.5d0*confSquare * dot_product(matterVel,matterVel) & + + matter_potential(matter) * confSquare**2 + + end function matter_energy_density + + + + + function matter_energy_density_JF(field,velocity) +!energy density of the matter fields in the Jordan Frame +!EF/A^4 + use infbgmodel, only : conformal_factor_square + implicit none + real(kp) :: matter_energy_density_JF + real(kp), dimension(fieldNum), intent(in) :: field,velocity + + real(kp), dimension(dilatonNum) :: dilaton + real(kp) :: confSquare + real(kp) :: matterEnergyDensEF + + dilaton = field(matterNum+1:fieldNum) + + confSquare = conformal_factor_square(dilaton) + matterEnergyDensEF = matter_energy_density(field,velocity) + + matter_energy_density_JF = matterEnergyDensEF/confSquare**2 + + end function matter_energy_density_JF + + + +end module infbg diff --git a/fieldinf/infbgmodel.F90 b/fieldinf/infbgmodel.F90 new file mode 100644 index 0000000..60f93de --- /dev/null +++ b/fieldinf/infbgmodel.F90 @@ -0,0 +1,691 @@ +module infbgmodel + use infprec, only : kp + implicit none + + private + + logical, parameter :: display = .true. + + + integer, parameter :: matterNum = 1 + integer, parameter :: dilatonNum = 1 + integer, parameter :: fieldNum = matterNum + dilatonNum + +#ifdef PP5 + integer, parameter :: potParamNum = 5 +#elif defined(PP12) + integer, parameter :: potParamNum = 12 +#else + integer, parameter :: potParamNum = 14 +#endif + + + + integer, parameter :: matterParamNum = potParamNum + 2 + integer, parameter :: dilatonParamNum = 0 + integer, parameter :: infParamNum = matterParamNum + dilatonParamNum + + + + type infbgparam +!label identifier + character(len=6) :: name +!coupling constants [mattercouplings,dilatoncouplings] + real(kp), dimension(infParamNum) :: consts +![dilaton degrees of freedom] + real(kp), dimension(dilatonNum) :: conforms +!matterfield values + real(kp), dimension(matterNum) :: matters + end type infbgparam + + + + real(kp), dimension(matterParamNum), save :: matterParam = 0._kp + real(kp), dimension(potParamNum), save :: potParam = 0._kp + + + interface operator (==) + module procedure infparam_equal + end interface + + + interface operator (/=) + module procedure infparam_unequal + end interface + + + public infbgparam + public operator(==),operator(/=) + + public matterParam + public fieldNum, dilatonNum, matterNum + public infParamNum, matterParamNum, dilatonParamNum + + public set_infbg_param + + public matter_potential + public deriv_matter_potential, deriv_second_matter_potential + + public conformal_factor_square + public conformal_first_gradient, conformal_second_gradient + + public metric, metric_inverse, deriv_metric + + +contains + + + function infparam_equal(infparamA, infparamB) + implicit none + type(infbgparam), intent(in) :: infparamA, infparamB + logical :: infparam_equal + + infparam_equal = ((infparamA%name == infparamB%name) & + .and. all(infparamA%conforms == infParamB%conforms) & + .and. all(infparamA%matters == infparamA%matters) & + .and. all(infparamA%consts == infparamB%consts)) + + end function infparam_equal + + + + + function infparam_unequal(infparamA, infparamB) + implicit none + type(infbgparam), intent(in) :: infparamA, infparamB + logical :: infparam_unequal + + infparam_unequal = ((infparamA%name /= infparamB%name) & + .or. any(infparamA%conforms /= infParamB%conforms) & + .or. any(infparamA%matters /= infparamA%matters) & + .or. any(infparamA%consts /= infparamB%consts)) + + end function infparam_unequal + + + + + + + function set_infbg_param(infParam) + implicit none + logical :: set_infbg_param + type(infbgparam), intent(in) :: infParam + + logical :: badParams = .true. + + real(kp) :: kpbuffer + + set_infbg_param=.false. + +!the matter potential is parametrized as +! +! U = [(p1 + p4 ln F) F^p2 + p3]^p5 +! + [p6 + p7 exp(p8 F) + p9 cos(p10 F + p11)] F^p12 +! + p13 F^p14 +! +!where the p are the potential params. In terms of the "matterParams", they read +! +! p1 = sign(m1) m1^4 +! p2 = m2 +! p3 = m3^4 +! p4 = sign(m4) m4^4 +! p5 = m5 +! p6 = sign(m6) m6^4 +! p7 = sign(m7) m7^4 +! p8 = m8 +! p9 = sign(m9) m9^4 +!p10 = m10 +!p11 = m11 +!p12 = m12 +!p13 = sign(m13) m13^4 +!p14 = m14 +! +!The matterParams mi are set from the ci params according to the model +!under scrutiny. Only the ci (infparam%consts) are public. +! +! m15=c15 +! +! is a field value that bounds the initial field values (ex, the throat size for kklt) +! +! m16=c16 +! +!is a field value that stops inflation (ex, hybrid, kklt) instead of +! the condition epsilon1 = 1 +! +! +! +!Other notations: M=c1; mu=c3, p=c2; nu=c4 + + + + select case (infParam%name) + + + case ('largef') + +! U = c1^4 F^c2 + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).ne.0._kp).or.(infParam%consts(5).ne.1._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'large field: improper params' + endif + + + matterParam(1) = infParam%consts(1) + matterParam(2) = infParam%consts(2) + matterParam(3) = 0._kp + matterParam(4) = 0._kp + matterParam(5) = 1._kp + +!fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) +!fieldStop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + case ('smallf') + +! U = c1^4 [1 - (F/c3)^c2] + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).le.0._kp).or.(infParam%consts(5).ne.1._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'small field: improper params' + endif + + matterParam(1) = - infParam%consts(1) & + /(infParam%consts(3)**(infParam%consts(2)/4._kp)) + matterParam(2) = infParam%consts(2) + matterParam(3) = infParam%consts(1) + matterParam(4) = 0._kp + matterParam(5) = 1._kp + +!fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) +!fieldStop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + if (maxval(infParam%matters/infParam%conforms(1)) & + .gt.infParam%consts(3)) then + write(*,*)'set_infbg_param: not small fields initially' + write(*,*)'model name: ',infParam%name + write(*,*)'matterScale = ',infParam%consts(3) + write(*,*)'matterField = ',maxval(infParam%matters) + endif + + + + + case ('hybrid') + +! U = c1^4 [1 + (F/c3)^c2] + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).le.0._kp) & + .or.(infParam%consts(5).ne.1._kp)) + + + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'hybrid models: improper params' + endif + + matterParam(1) = infParam%consts(1) & + /(infParam%consts(3)**(infParam%consts(2)/4._kp)) + matterParam(2) = infParam%consts(2) + matterParam(3) = infParam%consts(1) + matterParam(4) = 0._kp + matterParam(5) = 1._kp + +!fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) +!fieldstop value + matterParam(matterParamNum) =infParam%consts(matterParamNum) + + + + case ('runmas') + +! U = c1^4 { 1 + c4[1/c2 - ln(F/c3)] F^c2 } + + badParams = ((infParam%consts(3).le.0._kp).or.(infParam%consts(3).gt.1._kp) & + .or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(1).le.0._kp) & + .or.(infParam%consts(5).ne.1._kp)) + + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'running mass: improper params' + endif + + kpbuffer = infParam%consts(4)/infParam%consts(2) & + + infParam%consts(4)*log(infParam%consts(3)) + matterParam(1) = infParam%consts(1)*kpbuffer**0.25_kp + + matterParam(2) = infParam%consts(2) + matterParam(3) = infParam%consts(1) + + kpbuffer = infParam%consts(4) + matterParam(4) = -infParam%consts(1)*kpbuffer**0.25_kp + + matterParam(1) = infParam%consts(1) * sign(abs(kpbuffer)**0.25,kpbuffer) + + kpbuffer = infParam%consts(4) + matterParam(4) = - infParam%consts(1) * sign(abs(kpbuffer)**0.25,kpbuffer) + + matterParam(5) = 1._kp + +!fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) +!fieldstop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + + case('kklmmt') + +! U = c1^4 * [1 - (F/c3)^(-c2)] with c2 > 0 for c5=1 or +! U = c1^4 / [1 + (F/c3)^(-c2)] with c2 > 0 for c5=-1 +! +! c6 is Phi_string related to the flux number N +! +! c7 is PhiUv related to the brane tension of the string coupling + + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).le.0._kp) & + .or.(abs(infParam%consts(5)).ne.1._kp) & + .or.(infParam%consts(matterParamNum-1).lt.0._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'kklmmt: improper params' + endif + + + matterParam(1) = - sign(infParam%consts(1)**infParam%consts(5) & + /(infParam%consts(3)**(-infParam%consts(2)/4._kp)) & + ,infParam%consts(5)) + matterParam(2) = -infParam%consts(2) + matterParam(3) = infParam%consts(1)**infParam%consts(5) + matterParam(4) = 0._kp + matterParam(5) = infParam%consts(5) + +!fieldUv: prevents brane out of the throat + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) +!flux number N + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + +#ifndef PP5 + case ('mixinf') +! U = c1^4 [F^c2 + c6 F^c12] + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).ne.0._kp).or.(infParam%consts(5).ne.1._kp) & + .or.(infParam%consts(6).le.0._kp).or.(infParam%consts(12).le.0._kp) & + .or.(infParam%consts(7).ne.0._kp).or.(infParam%consts(8).ne.0._kp) & + .or.(infParam%consts(9).ne.0._kp).or.(infParam%consts(10).ne.0._kp) & + .or.(infParam%consts(11).ne.0._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'infParamNum = ',infParamNum + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'mixed field: improper params' + endif + + + matterParam(1) = infParam%consts(1) + matterParam(2) = infParam%consts(2) + matterParam(3) = 0._kp + matterParam(4) = 0._kp + matterParam(5) = 1._kp + matterParam(6) = infParam%consts(1) & + *sign(abs(infParam%consts(6))**0.25_kp,infParam%consts(6)) + matterParam(7:11) = 0._kp + matterParam(12) = infParam%consts(12) + +!fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) +!fieldStop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + +#endif + + + + case default + stop 'set_infbg_param: no such a model' + + end select + + + if (display) then + write(*,*)'set_infbg_param: model is ',infParam%name +! write(*,*)'matterParam = ',matterParam + endif + + +!update static potential parameters + call set_potential_param() + set_infbg_param = .true. + + end function set_infbg_param + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!full numerical integration functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!matter sector: potentials +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine set_potential_param() + implicit none + + potParam(1) = sign(matterParam(1)**4,matterParam(1)) !/matterParam(3)**4 + potParam(2) = matterParam(2) + potParam(3) = matterParam(3)**4 + potParam(4) = sign(matterParam(4)**4,matterParam(4)) !/matterParam(3)**4 + potParam(5) = matterParam(5) + +#ifndef PP5 + potParam(6) = sign(matterParam(6)**4,matterParam(6)) + potParam(7) = sign(matterParam(7)**4,matterParam(7)) + potParam(8) = matterParam(8) + potParam(9) = sign(matterParam(9)**4,matterParam(9)) + potParam(10) = matterParam(10) + potParam(11) = matterParam(11) + potParam(12) = matterParam(12) + + +#ifndef PP12 + potParam(13) = sign(matterParam(13)**4,matterParam(13)) + potParam(14) = matterParam(14) +#endif +#endif + + if (display) write(*,*)'set_potential_param: potParam = ',potParam + + end subroutine set_potential_param + + + + + function matter_potential(matter) + implicit none + real(kp) :: matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: chi,lnchi + + chi = matter(1) + + if (chi.gt.0._kp) then + lnchi = log(chi) + else + lnchi = -huge(1._kp) + endif + +! From p1 to p5 + matter_potential = (potParam(3) + & + (potParam(1) + potParam(4)*lnchi)*chi**potParam(2) & + )**potParam(5) + +! From p6 to p12 +#ifndef PP5 + matter_potential = matter_potential & + + ( potParam(6) + potParam(7)*exp(potParam(8)*chi) & + + potParam(9)*cos(potParam(10)*chi+potParam(11)) ) * chi**(potParam(12)) + +! From p13 to p14 +#ifndef PP12 + matter_potential = matter_potential + potParam(13)*chi**potParam(14) +#endif +#endif + + if (matter_potential.lt.0._kp) then + write(*,*)'matterField = ',chi + write(*,*)'potParam = ',potParam + write(*,*)'matter_potential = ',matter_potential + stop 'infbgmodel: matter_potential < 0!' + endif + end function matter_potential + + + + function deriv_matter_potential(matter) + implicit none + real(kp), dimension(matterNum) :: deriv_matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: chi, lnchi + + chi = matter(1) + + if (chi.gt.0._kp) then + lnchi = log(chi) + else + lnchi = -huge(1._kp) + endif + + deriv_matter_potential(1) = potParam(5)*chi**(potParam(2)-1._kp) & + * (potParam(1)*potParam(2) + potParam(4) + potParam(4)*potParam(2)*lnchi) & + * ( (potParam(1) + potParam(4)*lnchi)*chi**potParam(2) + potParam(3) ) & + ** (potParam(5)-1._kp) + +#ifndef PP5 + deriv_matter_potential(1) = deriv_matter_potential(1) & + + chi**(-1 + potParam(12))*(potParam(6) + exp(chi*potParam(8))*potParam(7) & + + Cos(chi*potParam(10)+potParam(11))*potParam(9))*potParam(12) & + + chi**potParam(12)*(exp(chi*potParam(8))*potParam(7)*potParam(8) & + - potParam(9)*potParam(10)*Sin(chi*potParam(10)+potParam(11))) + +#ifndef PP12 + deriv_matter_potential(1) = deriv_matter_potential(1) & + + potParam(13)*potParam(14)*chi**(potParam(14)-1._kp) +#endif +#endif + + end function deriv_matter_potential + + + + function deriv_second_matter_potential(matter) + implicit none + real(kp), dimension(matterNum,matterNum) :: deriv_second_matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: chi, lnchi + + chi = matter(1) + + if (chi.gt.0._kp) then + lnchi = log(chi) + else + lnchi = -huge(1._kp) + endif + + deriv_second_matter_potential(1,1) = chi**(-2._kp + potParam(2)) * (potParam(3) & + + chi**potParam(2)*(potParam(1) + lnchi*potParam(4)))**(-2._kp & + + potParam(5))*((potParam(1)*(-1._kp + potParam(2))*potParam(2) & + + lnchi*(-1._kp + potParam(2))*potParam(2)*potParam(4) & + + (-1._kp + 2._kp*potParam(2))*potParam(4))*(potParam(3)+chi**potParam(2) & + * (potParam(1) + lnchi*potParam(4))) + chi**potParam(2) & + * (potParam(1)*potParam(2)+potParam(4)+lnchi*potParam(2)*potParam(4))**2._kp & + * (-1._kp + potParam(5)))*potParam(5) + +#ifndef PP5 + deriv_second_matter_potential(1,1) = deriv_second_matter_potential(1,1) & + + chi**potParam(12)*(exp(chi*potParam(8))*potParam(7)*potParam(8)**2 & + - Cos(chi*potParam(10)+potParam(11))*potParam(9)*potParam(10)**2) & + + chi**(-2 + potParam(12))*(potParam(6)+exp(chi*potParam(8))*potParam(7)& + + Cos(chi*potParam(10)+potParam(11))*potParam(9))*(-1+potParam(12))*potParam(12)& + + 2*chi**(-1 + potParam(12))*potParam(12)*(exp(chi*potParam(8))& + *potParam(7)*potParam(8) - potParam(9)*potParam(10) & + *Sin(chi*potParam(10)+potParam(11))) + +#ifndef PP12 + deriv_second_matter_potential(1,1) = deriv_second_matter_potential(1,1) & + + potParam(13)*potParam(14)*(potParam(14)-1._kp)*chi**(potParam(14)-2._kp) +#endif +#endif + + end function deriv_second_matter_potential + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!gravity sector: metric on the sigma-model field manifold +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + + function metric(field) + implicit none + real(kp), dimension(fieldNum), intent(in) :: field + real(kp), dimension(fieldNum,fieldNum) :: metric + + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton + integer :: i + + metric = 0._kp + + dilaton = field(matterNum+1:fieldNum) + confSquare = conformal_factor_square(dilaton) + + do i=1,matterNum + metric(i,i) = confSquare + enddo + + do i=1,dilatonNum + metric(i+matterNum,i+matterNum) = 1._kp + enddo + + end function metric + + + + function metric_inverse(field) + implicit none + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum,fieldNum) :: metricVal, metric_inverse + real(kp) :: det + + integer :: i + + metric_inverse = 0._kp + + metricVal = metric(field) + + det = 1._kp + do i=1,fieldNum + det = det*metricVal(i,i) + enddo + + if (det.ne.0.) then + do i=1,fieldNum + metric_inverse(i,i) = 1._kp/metricVal(i,i) + enddo + else + stop 'inverse_metric: singularity in the sigma-model!' + endif + + end function metric_inverse + + + + function deriv_metric(field) + implicit none + real(kp), dimension(fieldNum), intent(in) :: field + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: deriv_metric + + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + integer :: i + + deriv_metric = 0._kp + + dilaton = field(matterNum+1:fieldNum) + confSquare = conformal_factor_square(dilaton) + confFirstGrad = conformal_first_gradient(dilaton) + + do i=1,matterNum + deriv_metric(i,i,matterNum+1:fieldNum) & + = 2._kp * confFirstGrad(1:dilatonNum)* confSquare + enddo + + + + end function deriv_metric + + + + function conformal_factor_square(dilaton) +!A^2 + implicit none + real(kp), dimension(dilatonNum), intent(in) :: dilaton + real(kp) :: conformal_factor_square + + conformal_factor_square = 1._kp + + + end function conformal_factor_square + + + + function conformal_first_gradient(dilaton) +!alpha_field = Dln(A)/Dfield + implicit none + real(kp), dimension(dilatonNum) :: conformal_first_gradient + real(kp), dimension(dilatonNum) :: dilaton + + + conformal_first_gradient = 0._kp + + + end function conformal_first_gradient + + + + function conformal_second_gradient(dilaton) +!D alpha_field / D field + implicit none + real(kp), dimension(dilatonNum,dilatonNum) :: conformal_second_gradient + real(kp), dimension(dilatonNum) :: dilaton + + conformal_second_gradient = 0._kp + + + end function conformal_second_gradient + + + + +end module infbgmodel diff --git a/fieldinf/infbgspline.f90 b/fieldinf/infbgspline.f90 new file mode 100644 index 0000000..217c930 --- /dev/null +++ b/fieldinf/infbgspline.f90 @@ -0,0 +1,297 @@ +module infbgspline +!splinning and interpolation routines for the background. Apart for +!test they are only used to determine rapidly the bfold of quantum +!mode creation + + use infprec, only : kp + implicit none + + private + +!for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_file = .false. + + +!bad idea, force the compiler to make copy of pointer arrays at each +!call of bspline (involves explicit shape array) +! type splineinfbg +! integer :: order +! integer :: bcoefNum +! integer :: fieldNum +! real(kp), dimension(:), pointer :: bfoldKnot, epsilon1JFBcoef +! real(kp), dimension(:), pointer :: hubbleBcoef, epsilon1Bcoef +! real(kp), dimension(:,:), pointer :: fieldBcoef, fieldDotBcoef +! end type splineinfbg + + +!to be initialized explicitely from bg computation + +! type(splineinfbg) :: splineBg + + integer, save :: order + integer, save :: bcoefNum + integer, save :: splineNum + real(kp), dimension(:), allocatable, save :: bfoldKnot, epsilon1JFBcoef + real(kp), dimension(:), allocatable, save :: hubbleBcoef, epsilon1Bcoef + real(kp), dimension(:,:), allocatable, save :: fieldBcoef, fieldDotBcoef + + + + public free_infbg_spline,set_infbg_spline, check_infbg_spline + public splineval_hubble_parameter,splineval_epsilon1,splineval_epsilon1JF + public splineval_field,splineval_fielddot + +contains + + + + function check_infbg_spline() + implicit none + logical :: check_infbg_spline + + check_infbg_spline = (allocated(bfoldKnot) & + .or. allocated(epsilon1JFBcoef) & + .or. allocated(hubbleBcoef) & + .or. allocated(epsilon1Bcoef) & + .or. allocated(fieldBcoef) & + .or. allocated(fieldDotBcoef)) + + end function check_infbg_spline + + + + + subroutine free_infbg_spline() + implicit none + if (check_infbg_spline()) then + deallocate(bfoldKnot) + deallocate(hubbleBcoef) + deallocate(epsilon1Bcoef) + deallocate(epsilon1JFBcoef) + deallocate(fieldBcoef) + deallocate(fieldDotBcoef) + if (display) write(*,*)'free_infbg_spline: infbg spline freed' + else + stop 'free_infbg_spline: not infbg spline data allocated' + endif + + end subroutine free_infbg_spline + + + + + + subroutine set_infbg_spline(bgEnd,ptrFirstBgdata) +!initialize the spline and set efoldIni, efoldEnd + use infbgmodel, only : fieldNum + use infbg, only : infbgdata, infbgphys + use infbg, only : count_infbg_data + use bspline + implicit none + type(infbgphys), intent(in) :: bgEnd + type(infbgdata), pointer :: ptrFirstBgdata + + integer :: bgdataNum + + integer :: i + type(infbgdata), pointer :: ptrRun + +!the background computation need to go further than epsilon1 > 1 (spline). + real(kp), allocatable, dimension(:) :: bcoefTemp, dataTemp + real(kp), allocatable, dimension(:) :: bfold, hubble, epsilon1,epsilon1JF + real(kp), allocatable, dimension(:,:) :: field, fieldDot + + i = 0 + ptrRun => null() + + if (check_infbg_spline()) then + stop 'set_infbg_spline: splineBg already associated' + endif + + + bgdataNum = count_infbg_data(ptrFirstBgdata) + if (display) then + write(*,*) + write(*,*)'-------------------set_infbg_spline-------------------' + write(*,*) + write(*,*)'bgdataNum = ',bgdataNum + endif + order = 3 + bcoefNum = bgdataNum + splineNum = fieldNum + + allocate(bfold(bgdataNum)) + allocate(hubble(bgdataNum)) + allocate(epsilon1(bgdataNum)) + allocate(epsilon1JF(bgdataNum)) + allocate(field(bgdataNum,fieldNum)) + allocate(fieldDot(bgdataNum,fieldNum)) + + allocate(bfoldKnot(bgdataNum + order)) + allocate(hubbleBcoef(bcoefNum)) + allocate(epsilon1Bcoef(bcoefNum)) + allocate(epsilon1JFBcoef(bcoefNum)) + allocate(fieldBcoef(bcoefNum,splineNum)) + allocate(fieldDotBcoef(bcoefNum,splineNum)) + + if (associated(ptrFirstBgdata)) then + ptrRun => ptrFirstBgdata + i = 0 + do while (associated(ptrRun)) + i = i + 1 + bfold(i) = ptrRun%bg%efold - bgEnd%efold + if (bfold(i).eq.0.) bfold(i) = epsilon(1.0_kp) + hubble(i) = ptrRun%bg%hubble + epsilon1(i) = ptrRun%bg%epsilon1 + epsilon1JF(i) = ptrRun%bg%epsilon1JF + field(i,:) = ptrRun%bg%field(:) + fieldDot(i,:) = ptrRun%bg%fieldDot(:) + ptrRun => ptrRun%ptr + enddo + + if (display) then + write(*,*) + write(*,*)'assoNum = ',i + write(*,*)'bgdataNum = ',bgdataNum + write(*,*)'splinning range:' + write(*,*)'bfoldIni = bfoldEndData = ',bfold(1),bfold(i) + write(*,*) + write(*,*)'------------------------------------------------------' + write(*,*) + endif + ptrRun => null() + else + stop 'no bgdata found' + endif + + call dbsnak(bgdataNum,bfold,order,bfoldKnot) + call dbsint(bgdataNum,bfold,hubble,order,bfoldKnot & + ,hubbleBcoef) + call dbsint(bgdataNum,bfold,epsilon1,order,bfoldKnot & + ,epsilon1Bcoef) + call dbsint(bgdataNum,bfold,epsilon1JF,order,bfoldKnot & + ,epsilon1JFBcoef) + + allocate(bcoefTemp(bgDataNum)) + allocate(dataTemp(bgDataNum)) + + do i=1,splineNum + dataTemp(:) = field(:,i) + call dbsint(bgdataNum,bfold,dataTemp,order,bfoldKnot,bcoefTemp) + fieldBcoef(:,i) = bcoefTemp + + dataTemp(:) = fieldDot(:,i) + call dbsint(bgdataNum,bfold,dataTemp,order,bfoldKnot,bcoefTemp) + fieldDotBcoef(:,i) = bcoefTemp + enddo + + deallocate(bcoefTemp) + deallocate(dataTemp) + + deallocate(bfold,hubble,epsilon1,epsilon1JF,field,fieldDot) + + end subroutine set_infbg_spline + + + + + + + + function splineval_hubble_parameter(bfold) + use bspline + implicit none + + real(kp) :: splineval_hubble_parameter + real(kp), intent(in) :: bfold + + splineval_hubble_parameter = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,hubbleBcoef) + + end function splineval_hubble_parameter + + + + function splineval_epsilon1(bfold) + use bspline + implicit none + + real(kp) :: splineval_epsilon1 + real(kp), intent(in) :: bfold + + splineval_epsilon1 = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,epsilon1Bcoef) + + end function splineval_epsilon1 + + + + function splineval_epsilon1JF(bfold) + use bspline + implicit none + + real(kp) :: splineval_epsilon1JF + real(kp), intent(in) :: bfold + + splineval_epsilon1JF = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,epsilon1JFBcoef) + + end function splineval_epsilon1JF + + + + + function splineval_field(bfold) + use bspline + implicit none + + real(kp), dimension(splineNum) :: splineval_field + real(kp), intent(in) :: bfold + real(kp), dimension(:), allocatable :: bcoefTemp + integer :: i,bgDataNum + bgDataNum = bcoefNum + + allocate(bcoefTemp(bgDataNum)) + + i = 0 + do i=1,splineNum + bcoefTemp(:) = fieldBcoef(:,i) + splineval_field(i) = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,bcoefTemp) + enddo + + deallocate(bcoefTemp) + + end function splineval_field + + + + + function splineval_fielddot(bfold) +!reminder: this is the efold(bfold) fieldDot = Dfield/De(b)fold + use bspline + implicit none + + real(kp), dimension(splineNum) :: splineval_fielddot + real(kp), intent(in) :: bfold + real(kp), dimension(:), allocatable :: bcoefTemp + integer :: i,bgDataNum + bgDataNum = bcoefNum + + allocate(bcoefTemp(bgDataNum)) + + i = 0 + do i=1,splineNum + bcoefTemp(:) = fieldDotBcoef(:,i) + splineval_fielddot(i) = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,bcoefTemp) + enddo + + deallocate(bcoefTemp) + + end function splineval_fielddot + + + +end module infbgspline diff --git a/fieldinf/infinout.f90 b/fieldinf/infinout.f90 new file mode 100644 index 0000000..5c9c6bb --- /dev/null +++ b/fieldinf/infinout.f90 @@ -0,0 +1,367 @@ +module infinout + +use infprec, only : kp + +private + +interface livewrite + module procedure sp_livewrite, kp_livewrite +end interface + +interface allwrite + module procedure sp_allwrite, kp_allwrite +end interface + +interface binallwrite + module procedure sp_binallwrite, kp_binallwrite +end interface + +integer, parameter :: reclUnit = 4 + +public delete_file +public livewrite, allwrite, binallwrite + +contains + + + subroutine delete_file(name) + implicit none + character(len=*) :: name + logical :: isthere + + inquire(file=name,exist=isthere) + + if (isthere) then + open(unit=10,file=name) + close(unit=10,status='delete') + endif + + end subroutine delete_file + + + subroutine sp_livewrite(name,x,a,b,c,d,e,f,g) + implicit none + character(len=*) :: name + real :: x,a + real, optional :: b,c,d,e,f,g + + open(10,file=name,position='append',status='unknown') + + if (.not.present(b)) then + write(10,100) x,a + elseif (.not.present(c)) then + write(10,100) x,a,b + elseif (.not.present(d)) then + write(10,100) x,a,b,c + elseif (.not.present(e)) then + write(10,100) x,a,b,c,d + elseif (.not.present(f)) then + write(10,100) x,a,b,c,d,e + elseif (.not.present(g)) then + write(10,100) x,a,b,c,d,e,f + else + write(10,100) x,a,b,c,d,e,f,g + endif + + close(10) + +100 format(8(ES25.16E3)) + + end subroutine sp_livewrite + + + subroutine kp_livewrite(name,x,a,b,c,d,e,f,g) + implicit none + character(len=*) :: name + real(kp) :: x,a + real(kp), optional :: b,c,d,e,f,g + + open(10,file=name,position='append',status='unknown') + + if (.not.present(b)) then + write(10,100) x,a + elseif (.not.present(c)) then + write(10,100) x,a,b + elseif (.not.present(d)) then + write(10,100) x,a,b,c + elseif (.not.present(e)) then + write(10,100) x,a,b,c,d + elseif (.not.present(f)) then + write(10,100) x,a,b,c,d,e + elseif (.not.present(g)) then + write(10,100) x,a,b,c,d,e,f + else + write(10,100) x,a,b,c,d,e,f,g + endif + + close(10) + +100 format(8(ES25.16E3)) + + end subroutine kp_livewrite + + + subroutine sp_allwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real :: x(:),a(:) + real, optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + npts=ubound(x,1) + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + open(10,file=name,status='unknown') + + if (.not.present(b)) then + do j=1,npts + write(10,100) x(j),a(j) + enddo + elseif (.not.present(c)) then + do j=1,npts + write(10,100) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + +100 format(8(ES25.16E3)) + + end subroutine sp_allwrite + + + + subroutine kp_allwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real(kp) :: x(:),a(:) + real(kp), optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + npts=ubound(x,1) + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + open(10,file=name,status='unknown') + + if (.not.present(b)) then + do j=1,npts + write(10,100) x(j),a(j) + enddo + elseif (.not.present(c)) then + do j=1,npts + write(10,100) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + +100 format(8(ES25.16E3)) + + end subroutine kp_allwrite + + + + subroutine sp_binallwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real :: x(:),a(:) + real, optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + integer :: datarecl + integer :: recnum + + + recnum = 0 + npts=ubound(x,1) + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + + + if (.not.present(b)) then + datarecl=2*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j) + enddo + elseif (.not.present(c)) then + datarecl=3*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + datarecl=4*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + datarecl=5*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + datarecl=6*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + datarecl=7*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + datarecl=8*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + + end subroutine sp_binallwrite + + + + subroutine kp_binallwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real(kp) :: x(:),a(:) + real(kp), optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + integer :: recnum + integer :: datarecl + + npts=ubound(x,1) + recnum=0 + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + + if (.not.present(b)) then + datarecl = 4*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j) + enddo + elseif (.not.present(c)) then + datarecl = 6*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum =recnum+1 + write(10,rec=recnum) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + datarecl = 8*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum =recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + datarecl = 10*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + datarecl = 12*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + datarecl = 14*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + datarecl = 16*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + + end subroutine kp_binallwrite + + +end module infinout + + diff --git a/fieldinf/infpert.f90 b/fieldinf/infpert.f90 new file mode 100644 index 0000000..4ae70ea --- /dev/null +++ b/fieldinf/infpert.f90 @@ -0,0 +1,1202 @@ +module infpert +!inflationary perturbations for scalar fields and tensor modes, in the +!original field basis (might have precision issues in the +!determination of ridiculously small entropy modes). efold is the +!number of efold running from efoldIni to efoldEnd during the +!inflationary era. bfold is the number of efold before the end of +!inflation: bfold = efold - efoldEnd running from efoldIni-efoldEnd to +!0. + + use infprec, only : kp, tolkp + use infbgmodel, only : matterNum, dilatonNum, fieldNum + use infbg, only : infbgphys + use inftorad, only : inftoradcosmo + implicit none + + private + + +!for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_spectra = .false. + logical, parameter :: dump_modes = .false. + +!+1 due to the bardeen potential. + integer, parameter :: scalNum = fieldNum + 1 + + real(kp), parameter :: kphysOverHubbleCreate = 10._kp + + integer, parameter :: entroRef = 2 + + + public scalNum + public power_spectrum_tens, power_spectrum_scal + + +contains + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!gravitational waves +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function power_spectrum_tens(infCosmo,kmpc) + use inftorad, only : infhubblexit, hubble_splinexit + use infinout, only : livewrite + implicit none + real(kp) :: power_spectrum_tens + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + + type(infhubblexit) :: atHkExit + complex(kp) :: tensEnd + real(kp) :: pi + + pi=acos(-1._kp) + +!evolution of k^3/2 x h by recomputing the background (faster) + tensEnd = pert_tens_bgevol(infCosmo,kmpc) + + power_spectrum_tens = (2._kp/pi/pi)*real(conjg(tensEnd)*tensEnd) + + if (dump_spectra) then + call livewrite('powerhK.dat',kmpc,power_spectrum_tens) + atHkExit = hubble_splinexit(infCosmo,kmpc) + call livewrite('powerhN.dat',atHkExit%bfold,power_spectrum_tens) + endif + + if (display) then + write(*,*)'power_spectrum_tens:' + write(*,*)'kmpc= Ph= '& + ,kmpc,power_spectrum_tens + endif + + + if (dump_modes) then + write(*,*)'tensor evolution dumped!' + read(*,*) + endif + + end function power_spectrum_tens + + + + + function pert_tens_bgevol(infCosmo,kmpc) +!this evolves the bg and tens = k^3/2 * h simultaneously + use inftools, only : easydverk + use infprec, only : transfert + use infbg, only : operator(/=) + use infbg, only : bg_field_dot_coupled + use infbg, only : hubble_parameter_square + use inftorad, only : bfold_hubble_fraction, lnMpcToKappa + use infinout + + implicit none + + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + complex(kp) :: pert_tens_bgevol + + type(transfert) :: cosmoData + +!we do not want to recompute the background from billion efolds. It is +!enough to start just before the relevant modes today are created + +!workaround for old omp threadprivate directive (common for +!static + save) + real(kp) :: efoldTune + real(kp), dimension(fieldNum) :: fieldTune, velocityTune + type(infbgphys) :: bgPrevious + common /bgTensSave/ efoldTune, fieldTune, velocityTune, bgPrevious + save /bgTensSave/ +!$omp threadprivate(/bgTensSave/) + + real(kp) :: bfold, efold, efoldStart, bfoldStart, bfoldNext + +!output files steps + integer, parameter :: bfoldDataNum = 5000 + real(kp) :: bfoldStep + +!accuracy for the forward integration of background only and both +!background and perturbations (any backward (unstable) integration is +!avoided). Since sub-Hubble perturbations oscillate, funny low +!accuracy on pertevol lead to funny long integration time + real(kp), parameter :: tolBgEvol = tolkp + real(kp), parameter :: tolEvol = 1e-11 + + integer, parameter :: neqs = 4 + 2*fieldNum + integer, parameter :: neqsbg = 2*fieldNum + + complex(kp) :: tens,tensDot,tensStart,tensDotStart + real(kp), dimension(2*fieldNum) :: bgVar +!tens and bg together + real(kp), dimension(neqs) :: allVar + real(kp), dimension(fieldNum) :: field,velocity + real(kp) :: hubbleSquare,kphysOverHubbleStart + + + + +!for transferring kmpc + other cosmo to the differential equations + cosmoData%real1 = kmpc + cosmoData%real2 = infCosmo%bgEnd%efold + cosmoData%real3 = infCosmo%efoldEndToToday + +!find the bfold of creation +! solution of N + ln[kappa H(N)] = ln(kmpc) -ln(aend/a0) -Nc -ln[(k/aH)_creation] + kphysOverHubbleStart = kphysOverHubbleCreate + bfoldStart = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleStart) + + if (display) then + write(*,*) + write(*,*)'tensor modes: kmpc = ',kmpc + write(*,*)'bfold quantum = ',bfoldStart + write(*,*) + endif + + + if (dump_modes) then + if (bfoldDataNum.le.1) stop 'pert_tens_bgevol: 1 data point?' + bfoldStep = (infCosmo%bfoldEnd - bfoldStart)/real(bfoldDataNum-1) + call delete_file('tens.dat') + else +!turbo settings, let's go to the end of inflation + bfoldStep = 1._kp/epsilon(1._kp) + endif + + +!evolve the bg from efoldIni to efoldStart of mode creation only +!once. After move from previous bgStart to the new efoldStart of mode +!creation, ONLY if the mode creation is at greater efold than the +!efoldStart of the previous mode: backward integration of the bg is +!unstable by rk methods. We also check that the bginf +!model is the same to do that. When all these conditions are not filled +!we start again from infCosmo + +!test if the bg model change print *,'testcond', +! ((infCosmo%bgIni%efold.ne.bgPrevious%efold) & +! .or.(any(infCosmo%bgIni%field.ne.bgPrevious%field)) & +! .or.(any(infCosmo%bgIni%fieldDot.ne.bgPrevious%fieldDot))), +! (infCosmo%bgIni /= bgPrevious) + + if (infCosmo%bgIni /= bgPrevious) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + endif + + bgPrevious = infCosmo%bgIni + + efoldStart = bfoldStart + infCosmo%bgEnd%efold + +!only forward integration allowed + if (efoldStart.lt.efoldTune) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + if (efoldStart.lt.infCosmo%bgIni%efold) then + write(*,*) 'pert_tens_bgevol: kmpc =',kmpc + write(*,*) 'bfoldCreate= bfoldExtrem= ',bfoldStart,infCosmo%bgIni%efold + stop + endif + endif + + + efold = efoldTune + + bgVar(1:fieldNum) = fieldTune(1:fieldNum) + bgVar(fieldNum+1:2*fieldNum) = velocityTune(1:fieldNum) + + call easydverk(neqsbg,bg_field_dot_coupled,efold,bgVar,efoldStart,tolBgEvol) + + efoldTune = efold + fieldTune(1:fieldNum) = bgVar(1:fieldNum) + velocityTune(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum) + + +!set the quantum initial conditions for the perturbations at bfoldStart + + call pert_creation_standard(tensStart,tensDotStart,bfoldStart,infCosmo,kmpc) + + +!evolve bg + tens pert from mode creation to end of inflation + + allVar(1) = real(tensStart) + allVar(2) = aimag(tensStart) + allVar(3) = real(tensDotStart) + allVar(4) = aimag(tensDotStart) + + allVar(5:4+fieldNum) = bgVar(1:fieldNum) + allVar(5+fieldNum:4+2*fieldNum) = bgVar(fieldNum+1:2*fieldNum) + + bfold = bfoldStart + + do while (bfold.lt.infCosmo%bfoldEnd) + + bfoldNext = min(bfold + bfoldStep, infCosmo%bfoldEnd) + + call easydverk(neqs,pert_tens_bgdot,bfold,allVar,bfoldNext,tolEvol,cosmoData) + + tens = cmplx(AllVar(1),AllVar(2)) + tensDot = cmplx(AllVar(3), AllVar(4)) + +!for test + if (dump_modes) then + field = allVar(5:4+fieldNum) + velocity = allVar(5+fieldNum:4+2*fieldNum) + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + call livewrite('kmpc.dat',bfold, & + kmpc*exp(-bfold)*exp(infCosmo%efoldEndToToday) & + *exp(-lnMpcToKappa)) + call livewrite('tens.dat',bfold,abs(tens),abs(real(tens)),abs(aimag(tens))) + call livewrite('hubble.dat',bfold,sqrt(hubbleSquare)) + endif + + enddo + + pert_tens_bgevol = tens + + end function pert_tens_bgevol + + + + + subroutine pert_tens_bgdot(neqs,bfold,allVar,allVarDot,cosmoData) + use infprec, only : transfert + use infbg, only : bg_field_dot_coupled, slowroll_first_parameter & + , hubble_parameter_square + use inftorad, only : lnMpcToKappa + implicit none + + integer :: neqs + real(kp) :: bfold + type(transfert), optional, intent(inout) :: cosmoData + real(kp), dimension(neqs) :: allVar + real(kp), dimension(neqs) :: allVarDot + + real(kp), dimension(fieldNum) :: field, velocity + real(kp), dimension(2*fieldNum) :: bgVar, bgVarDot + real(kp), dimension(4) :: pertVar, pertVarDot + + real(kp) :: kmpc, efoldEnd, efoldEndToToday + real(kp) :: efold, epsilon1, hubble, kphysOverHubble + + kmpc = cosmoData%real1 + efoldEnd = cosmoData%real2 + efoldEndToToday = cosmoData%real3 + +!equation of motion for the background + bgVar(1:2*fieldNum) = allVar(5:4+2*fieldNum) + + efold = bfold + efoldEnd + call bg_field_dot_coupled(2*fieldNum,efold,bgVar,bgVarDot) + +!need the background for the equations of the perturbations + field = bgVar(1:fieldNum) + velocity = bgVar(fieldNum+1:2*fieldNum) + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + hubble = sqrt(hubble_parameter_square(field,velocity,.true.)) + + kphysOverHubble = (kmpc/hubble)* exp(-bfold + efoldEndToToday & + - lnMpcToKappa) +! print *,'kphysOverHubble',kphysOverHubble +! read(*,*) +!equations of motion for the tensor modes + pertVar(1:4) = allVar(1:4) + + pertVarDot(1:2) = pertVar(3:4) + pertVarDot(3:4) = - (kphysOverHubble**2) * pertVar(1:2) & + - (3d0 - epsilon1)*pertVar(3:4) + +!set the return value + allVarDot(1:4) = pertVarDot(1:4) + allVarDot(5:4+2*fieldNum) = bgVarDot(1:2*fieldNum) + + end subroutine pert_tens_bgdot + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!scalar modes +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function power_spectrum_scal(infCosmo,kmpc) +!computes 1/(2pi^2) * , , , , etc... +!the evolved variables already include the k^3/2 factor. + use inftorad, only : infhubblexit, hubble_splinexit + use infinout, only : livewrite + + implicit none + real(kp), dimension(scalNum,scalNum) :: power_spectrum_scal + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + + type(infhubblexit) :: atHkExit + integer :: vacuumNum + complex(kp) :: powerFrom + + real(kp) :: pi + complex(kp), dimension(scalNum,fieldNum) :: obsPertFrom + + integer :: i,j,k,whichInVac + + + obsPertFrom = 0._kp + +! vacuumNum = fieldNum + +!when the dilaton is not coupled + vacuumNum = matterNum + + pi=acos(-1._kp) + + do whichInVac=1,vacuumNum + obsPertFrom(:,whichInVac) = pert_scal_bgevol(infCosmo,kmpc,whichInVac) + enddo + +!the two-points correlation functions +!mind the modulus --> cross correlations are complex in Fourier Space. + + do j=1,scalNum + do i=1,scalNum + powerFrom = 0._kp + do k=1,vacuumNum + powerFrom = powerFrom + conjg(obsPertFrom(i,k))*obsPertFrom(j,k) + enddo + power_spectrum_scal(i,j) = (0.5_kp/pi/pi)*real(powerFrom) + enddo + enddo + + if (dump_spectra) then + call livewrite('powerzetaK.dat',kmpc & + ,power_spectrum_scal(scalNum,scalNum)) + atHkExit = hubble_splinexit(infCosmo,kmpc) + call livewrite('powerzetaN.dat',atHkExit%bfold & + ,power_spectrum_scal(scalNum,scalNum)) + endif + + if (display) then + write(*,*)'power_spectrum_scal:' + write(*,*)'kmpc= Ps= '& + ,kmpc,power_spectrum_scal(scalNum,scalNum) + endif + + if (dump_modes) then + write(*,*)'scalar evolution dumped!' + read(*,*) + endif + + + end function power_spectrum_scal + + + + + + function pert_scal_bgevol(infCosmo,kmpc,whichInVacuum) +!this evolves the bg and scalar = k^3/2 *(fieldPert,Psi) simultaneously and +!return the final values of . zeta comoving +!curvature perturbation, Psi Bardeen potential, Q Mukhanov variable. + + use inftools, only : easydverk + use infprec, only : transfert + use infbgmodel, only : metric,deriv_metric,conformal_factor_square + use infbgmodel, only : conformal_first_gradient + use infbg, only : operator(/=) + use infbg, only : bg_field_dot_coupled + use infbg, only : slowroll_first_parameter, slowroll_second_parameter + use infbg, only : hubble_parameter_square + use infbg, only : potential, deriv_potential + use inftorad, only : bfold_hubble_fraction + use infinout + + implicit none + + complex(kp), dimension(scalNum) :: pert_scal_bgevol + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + integer, intent(in) :: whichInVacuum + + type(transfert) :: cosmoData + +!not intialized + real(kp) :: efoldTune, hubbleTune, hubble + real(kp), dimension(fieldNum) :: fieldTune, velocityTune + type(infbgphys) :: bgPrevious + common /bgScalSave/ efoldTune, fieldTune, velocityTune, bgPrevious + save /bgScalSave/ +!$omp threadprivate(/bgScalSave/) + + real(kp) :: bfold, efold, efoldStart, bfoldStart, bfoldNext + +!output files number of steps + integer, parameter :: bfoldDataNum = 5000 + real(kp) :: bfoldStep + +!field, fieldDot real; pert, pertDot complex. + +!accuracy for the forward integration of background only and both +!background and perturbations (any backward (unstable) integration is +!avoided). Since sub-Hubble perturbations oscillate, funny low +!accuracy on pertevol lead to funny long integration time + real(kp), parameter :: tolBgEvol = tolkp + real(kp), parameter :: tolEvol = 1e-11 + + integer, parameter :: neqs = 4*scalNum + 2*fieldNum + integer, parameter :: neqsbg = 2*fieldNum + + complex(kp) :: pertStart, pertDotStart + complex(kp), dimension(2) :: bardeensStart + complex(kp), dimension(scalNum) :: scalStart, scalDotStart + complex(kp), dimension(scalNum) :: scal,scalDot + + real(kp) :: epsilon1 + real(kp) :: kphysOverHubbleStart, kinetic, kineticDot + +!observable quantites, total and partial comoving curvature perturbations + complex(kp) :: zeta, zetaJF + complex(kp), dimension(fieldNum) :: mukhaScal,zetaScal !,entro + complex(kp), dimension(matterNum) :: zetaMatterDensJF + + real(kp) :: sigmaDot + real(kp), dimension(fieldNum) :: unitDot + real(kp), dimension(fieldNum) :: field,velocity,fieldDot + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum,fieldNum) :: metricVal + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv +!field and scal together + real(kp), dimension(neqs) :: allVar + + integer :: i + character(len=15) :: strgWhich, strgCount + + +!bugbuster + complex(kp), dimension(2) :: bardeenTest + logical, parameter :: doJordanFrame = .false. + + if ((whichInVacuum.gt.fieldNum).or.(whichInVacuum.le.0)) then + stop 'pert_scalar_bgevol: no such scalar perturbations' + endif + + +!to pass kmpc to differential equations throught dverk + cosmoData%real1 = kmpc + cosmoData%real2 = infCosmo%bgEnd%efold + cosmoData%real3 = infCosmo%efoldEndToToday + +!find the bfold of creation +! solution of N + ln[kappa H(N)] = ln(kmpc) -ln(aend/a0) -Nc -ln[(k/aH)_creation] + kphysOverHubbleStart = kphysOverHubbleCreate + bfoldStart = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleStart) + + if (display) then + write(*,*) + write(*,*)'scalar modes: kmpc = ',kmpc + write(*,*)'bfold quantum = ',bfoldStart + write(*,*)'mode in vacuum: ',whichInVacuum + write(*,*) + endif + + if (dump_modes) then + if (bfoldDataNum.le.1) stop 'pert_scal_bgevol: 1 data point?' + bfoldStep = (infCosmo%bfoldEnd - bfoldStart)/real(bfoldDataNum-1) + write(strgWhich,*) whichInVacuum + call delete_file('zeta2_'//trim(adjustl(strgWhich))//'.dat') + call delete_file('psi_'//trim(adjustl(strgWhich))//'.dat') + call delete_file('zeta2JF_'//trim(adjustl(strgWhich))//'.dat') + do i=1,fieldNum + write(strgCount,*) i + call delete_file('scal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat') +! call delete_file('entro_'//trim(adjustl(strgCount))// & +! '_'//trim(adjustl(strgWhich))//'.dat') + call delete_file('zetascal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat') + enddo + else +!turbo settings, let's go to the end of inflation + bfoldStep = 1._kp/epsilon(1._kp) + endif + + +!test if the bg model change + if (infCosmo%bgIni /= bgPrevious) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + endif + + bgPrevious = infCosmo%bgIni + + efoldStart = bfoldStart + infCosmo%bgEnd%efold + +!only forward integration allowed + if (efoldStart.lt.efoldTune) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + if (efoldStart.lt.infCosmo%bgIni%efold) then + write(*,*) 'pert_scalar_bgevol: kmpc =',kmpc + write(*,*) 'bfoldCreate= bfoldExtrem= ',bfoldStart,infCosmo%bgIni%efold + stop + endif + endif + + +!evolve the bg from 0 to bfold of mode creation + efold = efoldTune + bgVar(1:fieldNum) = fieldTune(1:fieldNum) + bgVar(fieldNum+1:2*fieldNum) = velocityTune(1:fieldNum) + + call easydverk(neqsbg,bg_field_dot_coupled,efold,bgVar,efoldStart,tolBgEvol) + +!update varTune to the bfold of mode creation (the bg will be computed +!from here next time) + efoldTune = efold + fieldTune(1:fieldNum) = bgVar(1:fieldNum) + velocityTune(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum) + hubbleTune = sqrt(hubble_parameter_square(fieldTune,velocityTune,.true.)) + +!the field initial quantum states have to be normalised with respect +!to their kinetic term (done by calling pert_creation_kinetic) + metricVal = metric(fieldTune) + metricDeriv = deriv_metric(fieldTune) + + kinetic = metricVal(whichInVacuum,whichInVacuum) + kineticDot = dot_product(metricDeriv(whichInVacuum,whichInVacuum,:) & + ,velocityTune/hubbleTune) + +! print *,'kinteic',kinetic,kineticDot + + call pert_creation_kinetic(pertStart,pertDotStart & + ,bfoldStart,kinetic,kineticDot,infCosmo,kmpc) +! print *,'kinetic' +! print *,'pertStart',pertStart +! print *,'pertDotStart',pertDotStart + +! call pert_creation_standard(pertStart,pertDotStart,bfoldStart,infCosmo,kmpc) +! print *,'standard' +! print *,'pertStart',pertStart +! print *,'pertDotStart',pertDotStart + +!reset everyone + scalStart = 0._kp + scalDotStart = 0._kp + +!there is a sqrt(2) factor between scalar and tensor modes. + scalStart(whichInVacuum) = pertStart /sqrt(2._kp) + scalDotStart(whichInVacuum) = pertDotStart /sqrt(2._kp) + + +!The initial value of the Bardeen potential is fixed by the constraint +!equuations, i.e. momemtum and energy conservation. It is a bad idea +!to use these equations during the evolution since they are singular +!at Hubble exit and epsilon=1, but are fine initially, for quantum +!wavelength well below the Hubble radius + bardeensStart = bardeen_bardeen_dot(bfoldStart,fieldTune,velocityTune & + ,scalStart(1:fieldNum),scalDotStart(1:fieldNum),cosmoData) + + scalStart(scalNum) = bardeensStart(1) + scalDotStart(scalNum) = bardeensStart(2) + + +!evolve bg + tens pert from mode creation to end of inflation +!pert variables and their derivatives + do i=1,scalNum + allVar(2*i-1) = real(scalStart(i)) + allVar(2*i) = aimag(scalStart(i)) + allVar(2*scalNum + 2*i-1) = real(scalDotStart(i)) + allVar(2*scalNum + 2*i) = aimag(scalDotStart(i)) + enddo + +!bg field and velocity + allVar(4*scalNum+1:4*scalNum+2*fieldNum) = bgVar(1:2*fieldNum) + + bfold = bfoldStart + + do while (bfold.lt.infCosmo%bfoldEnd) + + bfoldNext = min(bfold + bfoldStep, infCosmo%bfoldEnd) + +! print * +! print *,'allVar',allVar +! print * + + call easydverk(neqs,pert_scalar_bgdot,bfold,allVar,bfoldNext,tolEvol,cosmoData) + + field = allVar(4*scalNum+1:4*scalNum+fieldNum) + metricVal = metric(field) + velocity = allVar(4*scalNum+fieldNum+1:4*scalNum+2*fieldNum) + hubble = sqrt(hubble_parameter_square(field,velocity,.true.)) + fieldDot = velocity/hubble + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + sigmaDot = sqrt(2._kp*epsilon1) + + do i=1,scalNum + scal(i) = cmplx(allVar(2*i-1),allVar(2*i)) + scalDot(i) = cmplx(allVar(2*scalNum+2*i-1),allVar(2*scalNum+2*i)) + enddo + + unitDot = fieldDot/sigmaDot + +!curvature perturbation for each field: Psi + +!deltaField/(Dfield/Dbfold) + do i=1,fieldNum + mukhaScal(i) = scal(i) + fieldDot(i)*scal(scalNum) + if (fieldDot(i).ne.0._kp) then + zetaScal(i) = scal(scalNum) + scal(i)/fieldDot(i) + else + zetaScal(i) = 0._kp + endif +! entro(i) = scal(i) - unitDot(i) & +! * dot_product(matmul(metricVal,unitDot),scal(1:fieldNum)) + enddo + + + +!zeta constant density hypersurface in Jordan Frame for matter fields + if (doJordanFrame) then + zetaMatterDensJF(1:matterNum) & + = curvature_matter_density_JF(field,velocity,scal,scalDot) + zetaJF = curvature_comoving_JF(field,velocity,scal,scalDot) + else +!comoving curvature perturbation: Psi + deltaSigma/(DSigma/Dbfold) + zeta = scal(scalNum) & + + (dot_product(matmul(metricVal,fieldDot),scal(1:fieldNum))) & + /(2._kp*epsilon1) + endif + +!for test (fully inefficient way of writing files) + if (dump_modes) then + + + bardeenTest = bardeen_bardeen_dot(bfold,field,velocity & + ,scal(1:fieldNum),scalDot(1:fieldNum),cosmoData) + +! print *,'Psi',bardeenTest(1)-scal(scalNum) +! print *,'Psidot',bardeenTest(2)-scalDot(scalNum) +! print *,'zeta',zeta-(bardeenTest(1)+ (bardeenTest(2) + bardeenTest(1))/epsilon1) +! print *,'ZetaScal' +! print *,'zeta -each',zeta & +! - (dot_product(matmul(metricVal,velocity/hubble) & +! ,velocity/hubble*zetaScal)/(2.*epsilon1)) +! read(*,*) + + call livewrite('zeta2_'//trim(adjustl(strgWhich))//'.dat' & + , bfold, abs(conjg(zeta)*zeta),abs(real(zeta)),abs(aimag(zeta))) + + call livewrite('zeta2JF_'//trim(adjustl(strgWhich))//'.dat' & + ,bfold,real(conjg(zetaJF)*zetaJF),abs(real(zetaJF)) & + ,abs(aimag(zetaJF))) + + do i=1,fieldNum + write(strgCount,*) i + call livewrite('scal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat' & + , bfold, abs(scal(i)),abs(real(scal(i))), abs(aimag(scal(i)))) + call livewrite('zetascal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat' & + ,bfold,abs(zetaScal(i)),abs(real(zetaScal(i)))& + ,abs(aimag(zetaScal(i)))) + enddo + + call livewrite('psi_'//trim(adjustl(strgWhich))//'.dat' & + , bfold, abs(scal(scalNum)),abs(real(scal(scalNum))) & + ,abs(aimag(scal(scalNum)))) + + endif + enddo + + +!zeta is returned instead from the mukhanov variable Q +!zeta = Q/sigmaDot = Q/(sqrt(2epsilon1)) +!rescaled entropic perturbations are returned: S1(2) = entro1(2)/sigmaDot + +! pert_scal_bgevol(1:fieldNum) = entro(1:fieldNum)/sigmaDot +! pert_scal_bgevol(scalNum) = zeta + + + if (doJordanFrame) then + pert_scal_bgevol(1:matterNum) = zetaMatterDensJF + pert_scal_bgevol(matterNum+1:fieldNum) = scal(matterNum+1:fieldNum) + pert_scal_bgevol(scalNum) = zetaJF + else + do i=1,fieldNum + pert_scal_bgevol(i) = zetaScal(i)-zetaScal(entroRef) + enddo + pert_scal_bgevol(scalNum) = zeta + endif + + end function pert_scal_bgevol + + + + + + + + subroutine pert_scalar_bgdot(neqs,bfold,allVar,allVarDot,cosmoData) + use infprec, only : transfert + use infbgmodel, only : metric, metric_inverse, deriv_metric + use infbg, only : potential, deriv_potential, deriv_second_potential + use infbg, only : bg_field_dot_coupled, slowroll_first_parameter + use infbg, only : hubble_parameter_square + use infbg, only : connection_affine, deriv_connection_affine + use inftorad, only : lnMpcToKappa + + implicit none + + integer :: neqs + real(kp) :: bfold + type(transfert), optional, intent(inout) :: cosmoData + real(kp), dimension(neqs) :: allVar + real(kp), dimension(neqs) :: allVarDot + + real(kp), dimension(fieldNum) :: field, velocity, fieldDot + + real(kp), dimension(2*fieldNum) :: bgVar, bgVarDot + + real(kp) :: kmpc, efoldEnd, efoldEndToToday + real(kp) :: efold, kphysOverHubble, pot + real(kp) :: hubbleSquare, hubble, epsilon1 + + +!temp variable for writing the equations of motion... + complex(kp) :: bardeenPsi, bardeenPsiDot, bardeenPsiDotDot + complex(kp), dimension(fieldNum) :: fieldPert,fieldPertDot,fieldPertDotDot + +!the coefficients entering in the equations of motion + + +!the physical quantities entering in the above coefficients + real(kp), dimension(fieldNum) :: potDeriv, potDerivVec + real(kp), dimension(fieldNum,fieldNum) :: metricVal, metricInv, potSecond + real(kp), dimension(fieldNum,fieldNum) :: connectXfieldDot, potSecondVec + real(kp), dimension(fieldNum,fieldNum) :: connectDerivXfieldDotSquare + real(kp), dimension(fieldNum,fieldNum) :: metricPotDerivs, Vff + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv,connect + real(kp), dimension(fieldNum,fieldNum,fieldNum,fieldNum) :: connectDeriv + + integer :: i,j + + + +!get the wave number from dverk + kmpc = cosmoData%real1 + efoldEnd = cosmoData%real2 + efoldEndToToday = cosmoData%real3 + +!equation of motion for the background (we use the physical velocity) + bgVar(1:2*fieldNum) = allVar(4*scalNum+1:4*scalNum+2*fieldNum) + + efold = bfold + efoldEnd + call bg_field_dot_coupled(2*fieldNum,efold,bgVar,bgVarDot) + + +!need some background quantities for the perturbations + field = bgVar(1:fieldNum) + velocity = bgVar(fieldNum+1:2*fieldNum) + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + hubble = sqrt(hubbleSquare) + fieldDot = velocity/hubble + +!remind this is also: -(DHubble/Dbfold)/Hubble and sigmaDot^2/2 + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + + kphysOverHubble = (kmpc/hubble) * exp(-bfold + efoldEndToToday & + - lnMpcToKappa) + + +!the scalar perturbations (real and imaginary parts) +! fieldPert(1:fieldNum) = allVar(1:2*fieldNum) +! bardeenPsi = allVar(2*fieldNum+1:2*scalNum) + +!their derivatives +! fieldPertDot(1:fieldNum) = allVar(2*scalNum+1:2*scalNum+2*fieldNum) +! bardeenPsiDot = allVar(2*scalNum+2*fieldNum+1:4*scalNum) + + do i=1,fieldNum + fieldPert(i) = cmplx(allVar(2*i-1),allVar(2*i)) + fieldPertDot(i) = cmplx(allVar(2*scalNum+2*i-1),allVar(2*scalNum+2*i)) + enddo + bardeenPsi = cmplx(allVar(2*fieldNum+1),allVar(2*scalNum)) + bardeenPsiDot = cmplx(allVar(2*scalNum+2*fieldNum+1),allVar(4*scalNum)) + + + +!their equations of motion + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! warm up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + metricVal = metric(field) + metricInv = metric_inverse(field) + metricDeriv = deriv_metric(field) + + connect = connection_affine(field) + connectDeriv = deriv_connection_affine(field) + +!all potential related functions are in unit of H^2 + pot = potential(field)/hubbleSquare + potDeriv = deriv_potential(field)/hubbleSquare + potSecond = deriv_second_potential(field)/hubbleSquare + + potDerivVec = matmul(metricInv,potDeriv) + potSecondVec = matmul(metricInv,potSecond) + + do i=1,fieldNum + connectXfieldDot(i,:) = matmul(connect(i,:,:),fieldDot) + do j=1,fieldNum + connectDerivXfieldDotSquare(i,j) & + = dot_product(matmul(connectDeriv(i,:,:,j),fieldDot),fieldDot) + metricPotDerivs(i,j) & + = dot_product(matmul(metricDeriv(:,:,j),potDerivVec),metricInv(i,:)) + Vff(i,j) = connectDerivXfieldDotSquare(i,j) + potSecondVec(i,j) & + - metricPotDerivs(i,j) + enddo + enddo + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! equations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + fieldPertDotDot = - (3._kp - epsilon1) * fieldPertDot & + - 2._kp * matmul(connectXfieldDot,fieldPertDot) - matmul(Vff,fieldPert) & + - kphysOverHubble**2 * fieldPert & + + 4._kp * fieldDot * bardeenPsiDot - 2._kp * potDerivVec * bardeenPsi + + bardeenPsiDotDot = - (7._kp - epsilon1) * bardeenPsiDot & + - (2._kp * pot + kphysOverHubble**2) * bardeenPsi & + - dot_product(potDeriv,fieldPert) + +! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end equations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!specify the return value: glue all things together for integration. + +! allVarDot(1:2*fieldNum) = fieldPertDot(1:fieldNum) +! allVarDot(2*fieldNum+1:2*scalNum) = bardeenPsiDot +! allVarDot(2*scalNum+1:2*scalNum+2*fieldNum) = fieldpertDotDot(1:fieldNum) +! allVarDot(2*scalNum+2*fieldNum+1:4*scalNum) = bardeenPsiDotDot + + do i=1,fieldNum + allVarDot(2*i-1)=real(fieldPertDot(i)) + allVarDot(2*i) = aimag(fieldPertDot(i)) + allVarDot(2*scalNum+2*i-1) = real(fieldPertDotDot(i)) + allVarDot(2*scalNum+2*i) = aimag(fieldPertDotDot(i)) + enddo + + allVarDot(2*fieldNum+1) = real(bardeenPsiDot) + allVarDot(2*scalNum) = aimag(bardeenPsiDot) + allVarDot(2*scalNum+2*fieldNum+1) = real(bardeenPsiDotDot) + allVarDot(4*scalNum) = aimag(bardeenPsiDotDot) + + allVarDot(4*scalNum+1:4*scalNum+2*fieldNum) = bgVarDot(1:2*fieldNum) + + end subroutine pert_scalar_bgdot + + + + + + function bardeen_bardeen_dot(bfold,field,velocity,fieldPert,fieldPertDot,cosmoData) +!return the Bardeen potential and its derivative wrt efold from the +!constraint equations + use infprec, only : transfert + use infbgmodel, only : metric, deriv_metric + use infbg, only : deriv_potential, hubble_parameter_square + use infbg, only : slowroll_first_parameter + use inftorad, only : lnMpcToKappa + + implicit none + complex(kp), dimension(2) :: bardeen_bardeen_dot + real(kp), intent(in) :: bfold + real(kp), dimension(fieldNum), intent(in) :: field, velocity + complex(kp), dimension(fieldNum), intent(in) :: fieldPert,fieldPertDot + type(transfert), intent(in) :: cosmoData + + + real(kp) :: epsilon1, hubbleSquare, hubble + real(kp) :: kmpc, efoldEndToToday, kphysOverHubble + + + real(kp), dimension(fieldNum) :: potDeriv,metricDerivXFieldDotSquare, fieldDot + real(kp), dimension(fieldNum) :: metricXFieldDot + real(kp), dimension(fieldNum,fieldNum) :: metricVal + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv + + integer :: i + + + kmpc = cosmoData%real1 + efoldEndToToday = cosmoData%real3 + + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + hubble = sqrt(hubbleSquare) + + fieldDot = velocity/hubble + + metricVal = metric(field) + metricDeriv = deriv_metric(field) + potDeriv = deriv_potential(field)/hubbleSquare + + kphysOverHubble = (kmpc/hubble) * exp(-bfold + efoldEndToToday & + - lnMpcToKappa) + + metricXFieldDot = matmul(metricVal,fieldDot) + + do i=1,fieldNum + metricDerivXFieldDotSquare(i) = dot_product(matmul(metricDeriv(:,:,i),fieldDot) & + ,fieldDot) + enddo + +!bardeen potential + bardeen_bardeen_dot(1) & + = (1.5_kp * dot_product(metricXFieldDot,fieldPert) & + + 0.25_kp * dot_product(metricDerivXFieldDotSquare,fieldPert) & + + 0.5_kp * dot_product(potDeriv,fieldPert) & + + 0.5_kp * dot_product(metricXFieldDot,fieldPertDot)) & + / (epsilon1 - kphysOverHubble**2) + +!bardeen potential derivative wrt bfold time + bardeen_bardeen_dot(2) = 0.5_kp * dot_product(metricXFieldDot,fieldPert) & + - bardeen_bardeen_dot(1) + + + end function bardeen_bardeen_dot + + + + + function curvature_matter_density_JF(field,velocity,scal,scalDot) +!this is the curvature on constant density hypersurface for the matter +!fields zetamat = Psi + (delta Rho) / (DRho/Defold), if one matter +!field only. zetamat_i = Psi + (delta Rho_i) / (DField_i/Defold)^2 +!otherwise. In case of multiple matter fields, rho_i is not well +!defined due to possible couplings through the matter potential. + + use infbgmodel, only : conformal_factor_square, conformal_first_gradient + use infbgmodel, only : deriv_matter_potential + use infbg, only : hubble_parameter_square + implicit none + + complex(kp), dimension(matterNum) :: curvature_matter_density_JF + real(kp), dimension(fieldNum), intent(in) :: field, velocity + complex(kp), dimension(scalNum), intent(in) :: scal, scalDot + + + complex(kp), dimension(matterNum) :: matterPert, matterPertDot + complex(kp), dimension(dilatonNum) :: dilatonPert, dilatonPertDot + complex(kp) :: bardeenPsi, bardeenPhi + + real(kp) :: hubbleSquare, confSquare + real(kp), dimension(matterNum) :: matter, matterDot,derivMatterPot + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + real(kp), dimension(fieldNum) :: fieldDot + + bardeenPsi = scal(scalNum) + bardeenPhi = bardeenPsi + + matterPert = scal(1:matterNum) + matterPertDot = scalDot(1:matterNum) + dilatonPert = scal(matterNum+1:fieldNum) + dilatonPertDot = scalDot(matterNum+1:fieldNum) + + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + fieldDot = velocity/sqrt(hubbleSquare) + matterDot(1:matterNum) = fieldDot(1:matterNum) + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + derivMatterPot = deriv_matter_potential(matter) + confSquare = conformal_factor_square(dilaton) + confFirstGrad = conformal_first_gradient(dilaton) + + + curvature_matter_density_JF = bardeenPsi + bardeenPhi/3._kp & + - (2._kp/3._kp) * dot_product(confFirstGrad,dilatonPert) & + - (1._kp/3._kp) * (matterPertDot/matterDot & + + confSquare * derivMatterPot / hubbleSquare / matterDot**2._kp & + * matterPert) + + end function curvature_matter_density_JF + + + + + function curvature_comoving_JF(field,velocity,scal,scalDot) +!this is the comoiving curvature perturbation in the Jordan Frame, +!i.e. zeta = PsiJF + (PsiJF' + HubbleConfJF x PhiJF)/(HubbleConfJF x +!epsilon1JF) + + use infbgmodel, only : conformal_first_gradient, conformal_second_gradient + use infbg, only : slowroll_first_parameter_JF, hubble_parameter_square + implicit none + + complex(kp) :: curvature_comoving_JF + real(kp), dimension(fieldNum), intent(in) :: field, velocity + complex(kp), dimension(scalNum), intent(in) :: scal, scalDot + + + complex(kp), dimension(dilatonNum) :: dilatonPert, dilatonPertDot + complex(kp) :: bardeenPsi, bardeenPsiDot, bardeenPhi + complex(kp) :: bardeenPsiJF, bardeenPsiJFDot, bardeenPhiJF + + real(kp) :: hubbleSquare, epsilon1JF + real(kp), dimension(fieldNum) :: fieldDot + real(kp), dimension(dilatonNum) :: dilaton, dilatonDot,confFirstGrad + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad + + + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + epsilon1JF = slowroll_first_parameter_JF(field,velocity,.true.) + + fieldDot = velocity/sqrt(hubbleSquare) + + dilaton = field(matterNum+1:fieldNum) + dilatonDot = fieldDot(matterNum+1:fieldNum) + + bardeenPsi = scal(scalNum) + bardeenPhi = bardeenPsi + bardeenPsiDot = scalDot(scalNum) + + dilatonPert = scal(matterNum+1:fieldNum) + dilatonPertDot = scalDot(matterNum+1:fieldNum) + + + confFirstGrad = conformal_first_gradient(dilaton) + confSecondGrad = conformal_second_gradient(dilaton) + + bardeenPsiJF = bardeenPsi - dot_product(confFirstGrad,dilatonPert) + bardeenPhiJF = bardeenPhi + dot_product(confFirstGrad,dilatonPert) + + bardeenPsiJFDot = bardeenPsiDot - dot_product(confFirstGrad,dilatonPertDot) & + - dot_product(matmul(confSecondGrad,dilatonDot),dilatonPert) + + curvature_comoving_JF = bardeenPsiJF + (bardeenPsiJFDot & + + (1._kp + dot_product(confFirstGrad,dilatonDot))*bardeenPhiJF) & + / ((1._kp + dot_product(confFirstGrad,dilatonDot))*epsilon1JF) + + end function curvature_comoving_JF + + + + + subroutine pert_creation_standard(pertIni,pertDotIni,bfoldCreate,infCosmo,kmpc) +!For standard constant kinetic terms. +!mode creation at different times corresponding to a fix physical +!scale with respect to the Hubble radius: k/aH = Cte +!kmpc is the wavenumber today in unit of Mpc^-1. H is the Hubble +!parameter during inflation in unit of kappa. Evolution of the perturbations +!involve the dimensionless quantity: k/(aH) +! k/aH = (k/a0)/(kappa H) x aend/a x a0/aend x kappa +! = kmpc/kappaH x exp[-N] x a0/aend x (kappa/1Mpc) +! = kmpc/kappaH x exp[-N] x exp[ln(a0/aend)] x exp[-Nc] +! where Nc = ln[1Mpc/sqrt(8pi)/lPl] <---- Nc=lnMpcToKappa() +! N number of efold before the end of inflation (efold-efoldEnd) + + use inftorad, only : scaleFactorToday, lnMpcToKappa + implicit none + + real(kp), intent(in) :: kmpc + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: bfoldCreate + complex(kp), intent(out) :: pertIni, pertDotIni + + complex(kp) :: qMode, qModePrimeOverk + + +!set the quantum initial conditions at found bfold, in bfold time +!ex: for grav wav +! h = qmode/a +! h = a0/aend x aend/acreate x qmode/a0 +! Dh/Dbfold = a H h' = a H (qmode/a)' = (k/aH) x a0/aend x aend/acreate +! x (qmode'/k)/a0 - h + + call quantum_creation(kmpc,qmode,qmodePrimeOverk) + + pertIni = qmode/scaleFactorToday + pertDotIni = (kphysOverHubbleCreate*qmodePrimeOverk - qmode)/scaleFactorToday + +!normalisation of k in Mpc^-1 today + pertIni = pertIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa) + pertDotIni = pertDotIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa) + + end subroutine pert_creation_standard + + + + + subroutine pert_creation_kinetic(pertIni,pertDotIni,bfoldCreate,kinetic,kineticDot & + ,infCosmo,kmpc) +!for non-standard kinetic terms K(eta) Dfield Dfield instead of Dfield Dfield + use inftorad, only : scaleFactorToday, lnMpcToKappa + implicit none + + real(kp), intent(in) :: kmpc + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: bfoldCreate, kinetic, kineticDot + complex(kp), intent(out) :: pertIni, pertDotIni + + real(kp) :: sqrtKinetic, lnDotSqrtKinetic + complex(kp) :: qMode, qModePrimeOverk + +!set the quantum initial conditions at found bfold, in bfold time +!ex: for grav wav, qmod designs the standard normalised quantum mode +! h = qmode/a/K^1/2 +! h = a0/aend x aend/acreate x qmode/a0/K^1/2 +! Dh/Dbfold = a H h' = a H (qmode/a/K^1/2)' +! =(k/aH) x a0/aend x aend/acreate x (qmode'/k)/a0/K^1/2 - h x (1+1/2 DLn(K)/Dbfold) + + call quantum_creation(kmpc,qmode,qmodePrimeOverk) + + sqrtKinetic = sqrt(kinetic) + lnDotSqrtKinetic = 0.5_kp * kineticDot/kinetic + + pertIni = qmode /scaleFactorToday /sqrtKinetic + pertDotIni = (kphysOverHubbleCreate*qmodePrimeOverk - (1._kp + lnDotSqrtKinetic)*qmode) & + /scaleFactorToday /sqrtKinetic + +!normalisation of k in Mpc^-1 today + pertIni = pertIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa) + pertDotIni = pertDotIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa) + + end subroutine pert_creation_kinetic + + + + + subroutine quantum_creation(k,modeIni,modePrimeIniOverFreq) +!creates the initial quantum mode for a given k. The Bogoliubov +!coefficients are alpha and beta such as |alpha|^2 - |beta|^2 = 1. The +!creation time is not specified here and Prime denotes derivative with +!respect to the conformal time. Calling this function for all k at a +!same given conformal time with alpha=1,beta=0 is a Bunch-Davies vacuum. +!This is for rescaled modes in Fourier space: k^{3/2}*mode and +!in unit hbar=c=1, k is in unit of what you wish (cause rescaled modes). + + implicit none + real(kp), intent(in) :: k + complex(kp), intent(out) :: modeIni, modePrimeIniOverFreq + real(kp), parameter :: pi = 3.141592653589793238 + complex(kp), parameter :: alpha = (1._kp,0._kp) + complex(kp), parameter :: beta = (0._kp,0._kp) + + + modeIni = k*(alpha + beta) + modePrimeIniOverFreq = - k*cmplx(0._kp,1._kp)*(alpha - beta) +! print *,'qmode qmodeDot',modeIni,modePrimeIniOverFreq + end subroutine quantum_creation + + + +end module infpert diff --git a/fieldinf/infpowspline.f90 b/fieldinf/infpowspline.f90 new file mode 100644 index 0000000..19cec2d --- /dev/null +++ b/fieldinf/infpowspline.f90 @@ -0,0 +1,292 @@ +module infpowspline +!compute the primordial power spectra for few values of k and set a +!spline at intermediate k + + use infprec, only : kp + + implicit none + + private + + logical, parameter :: display = .false. + + + integer, save :: scalOrder + integer, save :: scalBcoefNum + integer, save :: scalModeNum + real(kp), dimension(:), allocatable, save :: scalLnkmpcKnot + real(kp), dimension(:,:,:), allocatable, save :: scalPowerBcoef + + integer, save :: tensOrder + integer, save :: tensBcoefNum + integer, save :: tensModeNum + real(kp), dimension(:), allocatable, save :: tensLnkmpcKnot + real(kp), dimension(:), allocatable, save :: tensPowerBcoef + + + + public check_power_scal_spline, check_power_tens_spline + public free_power_scal_spline, free_power_tens_spline + public set_power_scal_spline, set_power_tens_spline + public splineval_power_scal, splineval_power_tens + +contains + + + function check_power_scal_spline() + implicit none + logical :: check_power_scal_spline + + check_power_scal_spline = (allocated(scalLnkmpcKnot) & + .or. allocated(scalPowerBcoef)) + + end function check_power_scal_spline + + + + + subroutine free_power_scal_spline() + implicit none + + if (check_power_scal_spline()) then + deallocate(scalLnkmpcKnot) + deallocate(scalPowerBcoef) + if (display) write(*,*) 'free_power_scal_spline: powerscalar spline freed' + else + write(*,*) 'free_power_scal_spline: not powerscalar spline data allocated' + endif + + end subroutine free_power_scal_spline + + + + + function check_power_tens_spline() + implicit none + logical :: check_power_tens_spline + + check_power_tens_spline = (allocated(tensLnkmpcKnot) & + .or. allocated(tensPowerBcoef)) + + end function check_power_tens_spline + + + + + subroutine free_power_tens_spline() + implicit none + + if (check_power_tens_spline()) then + deallocate(tensLnkmpcKnot) + deallocate(tensPowerBcoef) + if (display) write(*,*) 'free_power_tens_spline: powertensor spline freed' + else + write(*,*) 'free_power_tens_spline: not powertensor spline data allocated' + endif + + end subroutine free_power_tens_spline + + + + + subroutine set_power_scal_spline(infCosmo,lnkmpcVec) + use bspline, only : dbsnak, dbsint + use inftorad, only : inftoradcosmo + use infpert, only : scalNum, power_spectrum_scal + implicit none + + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), dimension(:), intent(in) :: lnkmpcVec + + real(kp), dimension(:), allocatable :: lnPowerScalTemp + real(kp), dimension(:), allocatable :: scalPowerBcoefTemp + real(kp), dimension(:,:,:), allocatable :: lnPowerScal + real(kp), dimension(scalNum,scalNum) :: powerScal + real(kp) :: kmpc + + integer :: i,j,k,lnkmpcNum + + lnkmpcNum = size(lnkmpcVec,1) + + scalOrder = 3 + scalBcoefNum = lnkmpcNum + scalModeNum = scalNum + +!spline allocation + if (check_power_scal_spline()) then + write(*,*) 'set_power_scal_spline: spline already allocated' + stop + endif + + allocate(scalLnkmpcKnot(lnkmpcNum + scalOrder)) + allocate(scalPowerBcoef(scalBcoefNum,scalNum,scalNum)) + +!local + allocate(lnPowerScal(lnkmpcNum,scalNum,scalNum)) + + if (display) then + write(*,*)'set_power_scal_spline: computing knots' + endif + +!$omp parallel do & +!$omp default(shared) & +!$omp private(i,kmpc,powerScal,j,k) & +!$omp schedule(dynamic) + do i=1,lnkmpcNum + kmpc = exp(lnkmpcVec(i)) + powerScal = power_spectrum_scal(infCosmo,kmpc) + do k=1,scalNum + do j=1,scalNum + if (powerScal(j,k).eq.0._kp) then + powerScal(j,k) = tiny(1.0_kp) + endif + lnPowerScal(i,j,k) = log(powerScal(j,k)) + enddo + enddo + enddo +!$omp end parallel do + + if (display) then + write(*,*)'set_power_scal_spline: end computing knots' + endif + + call dbsnak(lnkmpcNum,lnkmpcVec,scalOrder,scalLnkmpcKnot) + +!to avoid race conditions + allocate(scalPowerBcoefTemp(scalBcoefNum)) + allocate(lnPowerScalTemp(lnkmpcNum)) + + do j=1,scalNum + do i=1,scalNum + lnPowerScalTemp(:) = lnPowerScal(:,i,j) + call dbsint(lnkmpcNum,lnkmpcVec,lnPowerScalTemp,scalOrder,scalLnkmpcKnot & + ,scalPowerBcoefTemp) + scalPowerBcoef(:,i,j) = scalPowerBcoefTemp(:) + enddo + enddo + + deallocate(scalPowerBcoefTemp) + deallocate(lnPowerScalTemp) + deallocate(lnPowerScal) + + + end subroutine set_power_scal_spline + + + + + + subroutine set_power_tens_spline(infCosmo,lnkmpcVec) + use bspline, only : dbsnak, dbsint + use infbgmodel, only : fieldNum + use inftorad, only : inftoradcosmo + use infpert, only : scalNum, power_spectrum_tens + implicit none + + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), dimension(:), intent(in) :: lnkmpcVec + + real(kp), dimension(:), allocatable :: lnPowerTens + real(kp) :: kmpc, powerTens + integer :: i,lnkmpcNum + + + lnkmpcNum = size(lnkmpcVec,1) + tensOrder = 3 + tensBcoefNum = lnkmpcNum + tensModeNum = 1 + +!spline allocation + if (check_power_tens_spline()) then + write(*,*) 'set_power_tens_spline: spline already allocated' + stop + endif + + allocate(tensLnkmpcKnot(lnkmpcNum + tensOrder)) + allocate(tensPowerBcoef(tensBcoefNum)) + +!local + allocate(lnPowerTens(lnkmpcNum)) + + if (display) then + write(*,*)'set_power_tens_spline: computing knots' + endif + + +!$omp parallel do & +!$omp default(shared) & +!$omp private(i,kmpc,powerTens) & +!$omp schedule(dynamic) + do i=1,lnkmpcNum + kmpc = exp(lnkmpcVec(i)) + powerTens = power_spectrum_tens(infCosmo,kmpc) + if (powerTens.eq.0._kp) then + powerTens = tiny(1.0_kp) + endif + lnPowerTens(i) = log(powerTens) + enddo +!$omp end parallel do + + if (display) then + write(*,*)'set_power_scal_spline: end computing knots' + endif + + call dbsnak(lnkmpcNum,lnkmpcVec,tensOrder,tensLnkmpcKnot) + + call dbsint(lnkmpcNum,lnkmpcVec,lnPowerTens,tensOrder,tensLnkmpcKnot & + ,tensPowerBcoef) + + deallocate(lnPowerTens) + + end subroutine set_power_tens_spline + + + + + + function splineval_power_scal(kmpc) + use bspline, only : dbsval + implicit none + real(kp), intent(in) :: kmpc + real(kp), dimension(scalModeNum,scalModeNum) :: splineval_power_scal + real(kp) :: lnkmpc + real(kp), dimension(:), allocatable :: scalPowerBcoefTemp + integer :: i,j + + lnkmpc = log(kmpc) + +!avoid race condition + allocate(scalPowerBcoefTemp(scalBcoefNum)) + + do j=1,scalModeNum + do i=1,scalModeNum + scalPowerBcoefTemp = scalPowerBcoef(:,i,j) + splineval_power_scal(i,j) = exp(dbsval(lnkmpc,scalOrder,scalLnkmpcKnot & + ,scalBcoefNum,scalPowerBcoefTemp)) + enddo + enddo + + deallocate(scalPowerBcoefTemp) + + end function splineval_power_scal + + + + + function splineval_power_tens(kmpc) + use bspline, only : dbsval + implicit none + real(kp), intent(in) :: kmpc + real(kp) :: splineval_power_tens + real(kp) :: lnkmpc + + lnkmpc = log(kmpc) + + splineval_power_tens = exp(dbsval(lnkmpc,tensOrder,tensLnkmpcKnot & + ,tensBcoefNum,tensPowerBcoef)) + + end function splineval_power_tens + + + +end module infpowspline diff --git a/fieldinf/infprec.f90 b/fieldinf/infprec.f90 new file mode 100644 index 0000000..00d9d5a --- /dev/null +++ b/fieldinf/infprec.f90 @@ -0,0 +1,34 @@ +module infprec + implicit none + + public + +!quad precision +! integer, parameter :: kp = kind(1.0_16) + +!double precision + integer, parameter :: kp = kind(1.0_8) + +!home made precision: p number of digit +! integer, parameter :: kp = selected_real_kind(p=32) + +!default integration accuracy + real(kp), parameter :: tolkp = 1.d-12 + +!workaround for passing argument to old f77 functions. Only pointer +!can be deferred shape in derived data type. +!Allows to stop integration from conditions coming from called +!functions (find the end of inflation) + type transfert + logical :: yesno1,yesno2, yesno3, yesno4 + integer :: int1, int2, int3 + real(kp) :: real1, real2, real3, real4, real5 + real(kp), dimension(:), pointer :: ptrvector1 => null() + real(kp), dimension(:), pointer :: ptrvector2 => null() +!reserved + logical :: check,update + real(kp) :: xend + end type transfert + + +end module infprec diff --git a/fieldinf/infsrmodel.F90 b/fieldinf/infsrmodel.F90 new file mode 100644 index 0000000..18ebd17 --- /dev/null +++ b/fieldinf/infsrmodel.F90 @@ -0,0 +1,1212 @@ +!provides the slow-roll initial field values such that N e-folds of +!inflation occurs. + +module infsrmodel + use infprec, only : kp + use infbgmodel, only : matterNum + implicit none + + private + + logical, parameter :: display = .true. + + integer, parameter :: efoldBound = 110._kp + + + public field_stopinf, field_thbound + public slowroll_initial_matter_lf, slowroll_initial_matter_sf + public slowroll_initial_matter_hy, slowroll_initial_matter_rm + public slowroll_initial_matter_kksf, slowroll_initial_matter_kklt + public slowroll_initial_matter_mix + + public sr_efold_sf, sr_endinf_sf, sr_iniinf_sf + public sr_efold_kklt, sr_endinf_kklt, sr_iniinf_kklt + public sr_efold_rm, sr_iniinf_rm + public sr_efold_mix, sr_endinf_mix, sr_iniinf_mix + + + + + + + + +contains + + + + function field_stopinf(infParam) +!return the field stop value in (1) and if it is a maximum (+1) or +!minimum (-1) in (2) + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), dimension(2) :: field_stopinf + + + select case (infParam%name) + + case ('largef') + field_stopinf(1) = infParam%consts(matterParamNum) + field_stopinf(2) = -1._kp + + case ('smallf') + field_stopinf(1) = infParam%consts(matterParamNum)*infParam%consts(3) + field_stopinf(2) = 1._kp + + case ('hybrid') + field_stopinf(1) = infParam%consts(matterParamNum) & + * slowroll_stopmax_matter_hy(infParam) + field_stopinf(2) = -1._kp + + case ('runmas') + + field_stopinf(1) = infParam%consts(matterParamNum) +!for nu>0 + if (infParam%consts(matterParamNum).lt.infParam%consts(3)) then + field_stopinf(2) = -1._kp + else + field_stopinf(2) = +1._kp + endif +!reverse if nu<0 + if (infParam%consts(4).lt.0._kp) then + field_stopinf(2) = -field_stopinf(2) + endif + + case ('kklmmt') + field_stopinf(1) = infParam%consts(matterParamNum)*infParam%consts(3) + field_stopinf(2) = -1._kp + print *, 'fieldStop = infParam(matterParamNum)' + + case ('mixinf') + field_stopinf(1) = infParam%consts(matterParamNum) + field_stopinf(2) = -1._kp + + + end select + + + + end function field_stopinf + + + + function field_thbound(infParam) +!returns a theoretical bound on the allowed field values if any. May be +!from the stochastic regime or uv limit in brane setup + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), dimension(2) :: field_thbound + + + select case (infParam%name) + + case ('kklmmt') + field_thbound(1) = infParam%consts(matterParamNum-1) + field_thbound(2) = +1._kp + print *, 'fieldUv = infParam%consts(matterParamNum-1)' + + case default + stop 'no theoretical field bound implemented for this model!' + + end select + + end function field_thbound + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!large field models +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function slowroll_initial_matter_lf(infParam,efoldWanted) + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_lf + + real(kp), parameter :: efoldDefault = efoldBound + real(kp) :: matterEnd, matterIni + real(kp) :: p,mu,efold + + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + mu = infParam%consts(3) + if (mu.ne.0._kp) stop 'slowroll_initial_matter_lf: improper parameters' + + + p = infParam%consts(2) + + matterEnd = p/sqrt(2._kp) + + matterIni = sqrt(p**2/2._kp + 2._kp*p*efold) + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_lf: (*kappa)' + write(*,*)'matterEnd = ',matterEnd + write(*,*)'matterIni = ',matterIni + write(*,*) + endif + + slowroll_initial_matter_lf = matterIni + + end function slowroll_initial_matter_lf + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!small field models +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function slowroll_initial_matter_sf(infParam,efoldWanted) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_sf + + type(transfert) :: sfData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + + real(kp) :: matterOverMuEnd, matterOverMuIni + real(kp) :: mini,maxi + real(kp) :: p, mu, efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_sf: improper parameters' + endif + + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_sf: p = ',p + stop + endif + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + +!find the end of inflation + + mini = epsilon(1._kp) + maxi = 1._kp + epsilon(1._kp) + + sfData%real1 = p + sfData%real2 = mu + + matterOverMuEnd = zbrent(sr_endinf_sf,mini,maxi,tolFind,sfData) + + + +!find the initial field values efolds before + + mini = epsilon(1._kp) + maxi = matterOverMuEnd + + sfData%real1 = p + sfData%real2 = 2._kp*p*efold/mu**2 + sr_efold_sf(matterOverMuEnd,p) + + + matterOverMuIni = zbrent(sr_iniinf_sf,mini,maxi,tolFind,sfData) + + slowroll_initial_matter_sf = matterOverMuIni*mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_sf: (*kappa) (/mu)' + write(*,*)'matterEnd = ',matterOverMuEnd*mu,matterOverMuEnd + write(*,*)'matterIni = ',matterOverMuIni*mu,matterOverMuIni + write(*,*) + endif + + + end function slowroll_initial_matter_sf + + + + + function sr_endinf_sf(x,sfData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: sfData + real(kp) :: sr_endinf_sf + real(kp) :: p,mu + + p=sfData%real1 + mu=sfData%real2 + + sr_endinf_sf = x**(p-1._kp) + sqrt(2._kp)*mu/abs(p) * (x**p - 1._kp) + + end function sr_endinf_sf + + + + + function sr_iniinf_sf(x,sfData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: sfData + real(kp) :: sr_iniinf_sf + real(kp) :: p + + p=sfData%real1 + + sr_iniinf_sf = sr_efold_sf(x,p) - sfData%real2 + + end function sr_iniinf_sf + + + + + function sr_efold_sf(x,p) + implicit none + real(kp), intent(in) :: x,p + real(kp) :: sr_efold_sf + + if (p == 2._kp) then + sr_efold_sf = x**2 - 2._kp * log(x) + else + sr_efold_sf = x**2 + 2._kp/(p-2._kp) * x**(2._kp-p) + endif + + end function sr_efold_sf + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!kklmmt +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!some function call the small field ones since kklmmt potential looks +!like the small field ones with p->-p + + + function slowroll_initial_matter_kksf(infParam,efoldWanted) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_kksf + + type(transfert) :: sfData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + + real(kp) :: matterOverMuEnd, matterOverMuIni + real(kp) :: mini,maxi + real(kp) :: p, mu, efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_kksf: improper parameters' + endif + + + if (p.lt.0._kp) then + write(*,*) 'slowroll_initial_matter_kksf: p = ',p + stop + endif + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + +!find the end of inflation + + mini = 1._kp + epsilon(1._kp) + maxi = 1._kp/epsilon(1._kp) + + sfData%real1 = -p + sfData%real2 = mu + + matterOverMuEnd = zbrent(sr_endinf_sf,mini,maxi,tolFind,sfData) + + + +!find the initial field values efolds before + + mini = matterOverMuEnd + maxi = 1._kp/epsilon(1._kp) + + sfData%real1 = -p + sfData%real2 = 2._kp*(-p)*efold/mu**2 + sr_efold_sf(matterOverMuEnd,-p) + + + matterOverMuIni = zbrent(sr_iniinf_sf,mini,maxi,tolFind,sfData) + + slowroll_initial_matter_kksf = matterOverMuIni*mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_kksf: (*kappa) (/mu)' + write(*,*)'matterEnd = ',matterOverMuEnd*mu,matterOverMuEnd + write(*,*)'matterIni = ',matterOverMuIni*mu,matterOverMuIni + write(*,*) + endif + + + end function slowroll_initial_matter_kksf + + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!hybrid models +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + + function slowroll_initial_matter_hy(infParam,efoldWanted) + use infprec, only : transfert, tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_hy + + type(transfert) :: hyData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + real(kp), dimension(2) :: fieldStop + real(kp) :: matterOverMuMax, matterOverMuIni, matterOverMuStop + real(kp) :: mini,maxi + real(kp) :: p, mu + real(kp) :: muConnex, efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + +!sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_hy: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_hy: p = ',p + stop + endif + + if (infParam%consts(matterParamNum).gt.1._kp) then + stop 'slowroll_initial_matter_hy: improper consts(5)' + endif + + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + +!determines the maximum allowed field value to stop hybrid inflation +!(see the called function) +! matterOverMuStopMax = slowroll_stopmax_matter_hy(infParam) / mu + +!for hybrid inflation, it assumes that consts(matparamnum) is in unit of +!mattertopMax + fieldStop = field_stopinf(infParam) + matterOverMuStop = fieldStop(1) / mu + + +!upper field value bound + matterOverMuMax = slowroll_startmax_matter_hy(infParam) + + +!find matterIni otherwise to get the right number of efolds + + mini = matterOverMuStop + maxi = matterOverMuMax + + hyData%real1 = p + hyData%real2 = 2._kp*p*(efold)/mu**2 + sr_efold_hy(matterOverMuStop,p) + + matterOverMuIni = zbrent(sr_iniinf_hy,mini,maxi,tolFind,hyData) + + slowroll_initial_matter_hy = matterOverMuIni * mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_hy: (*kappa) (/mu)' + write(*,*)'matterStop = ',matterOverMuStop*mu, matterOverMuStop + write(*,*)'matterIni = ',matterOverMuIni*mu, matterOverMuIni + write(*,*) + endif + + + end function slowroll_initial_matter_hy + + + + + + function slowroll_stopmax_matter_hy(infParam) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp) :: slowroll_stopmax_matter_hy + + real(kp), parameter :: efoldHybrid = efoldBound + + real(kp), parameter :: tolFind = tolkp + type(transfert) :: hyData + real(kp) :: p,mu, mini,maxi + real(kp) :: matterOverMuMax, matterOverMuStopMax + + p = infParam%consts(2) + mu = infParam%consts(3) + +!sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_stopmax_matter_hy: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_stopmax_matter_hy: p = ',p + stop + endif + + matterOverMuMax = slowroll_startmax_matter_hy(infParam)/mu + +!MatterStopMax is the zero of the sr evolution equation with N --> -N +!and set to efoldHybrid. + + mini = epsilon(1._kp) + maxi = matterOverMuMax + + hyData%real1 = p + hyData%real2 = -2._kp*p*(efoldHybrid)/mu**2 + sr_efold_hy(matterOverMuMax,p) + + matterOverMuStopMax = zbrent(sr_iniinf_hy,mini,maxi,tolFind,hyData) + +!return the field value, in unit of kappa + slowroll_stopmax_matter_hy = matterOverMuStopMax * mu + + if (display) then + write(*,*) + write(*,*)'slowroll_matter_stopmax_hy: (*kappa) (/mu)' + write(*,*)'efold definition = ',efoldHybrid + write(*,*)'matterStopMax = ',matterOverMuStopMax*mu, matterOverMuStopMax + write(*,*) + endif + + end function slowroll_stopmax_matter_hy + + + + + + + function slowroll_startmax_matter_hy(infParam) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp) :: slowroll_startmax_matter_hy + + real(kp), parameter :: tolFind = tolkp + type(transfert) :: hyData + real(kp) :: p,mu,mini,maxi, muConnex + real(kp) :: matterOverMuTrans, matterOverMuMax + + p = infParam%consts(2) + mu = infParam%consts(3) + +!sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_startmax_matter_hy: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_startmax_matter_hy: p = ',p + stop + endif + + +!this is the mu above which eps1 = 1 has no solution and for which +!inflationary domains in field space are simply connected + muConnex = p/sqrt(8._kp) + +!this is the matter/mu for which eps1 is maximum. eps1(matter) is a +!increasing function wrt the field under this value, and decreasing +!above. So hybrid like behaviour only appears for matter < +!matterTrans. Otherwise, this is a mixture between large field like +!and hybrid inflation during which the sign of eps2 changes + matterOverMuTrans = (p - 1._kp)**(1._kp/p) + + +!We are looking to the maximum allowed value of the field to stop +!inflation and to get at least "efoldHybrid" efolds of inflation. Here +!we discard the case where inflation may start for matterIni > +!matterTrans since it would be large field like inflation. So the +!ultimate upper limit for matterIni, defined as matterMax, is the +!min(matterTrans,matterOne) where eps1(matterOne) = 1. MatterOne is +!seeked in [0,matterTrans]: this selects only the lower root, the +!other corresponding to the end of a large field like inflation) + mini = epsilon(1._kp) + maxi = matterOverMuTrans + + hyData%real1 = p + hyData%real2 = mu + + if (mu.le.muConnex) then + matterOverMuMax = zbrent(sr_endinf_hy,mini,maxi,tolFind,hyData) + else + matterOverMuMax = matterOverMuTrans + endif + + slowroll_startmax_matter_hy = matterOverMuMax * mu + + if (display) then + write(*,*)'slowroll_startmax_matter_hy: (*kappa) (/mu)' + write(*,*)'matterMax = ',matterOverMuMax*mu,matterOverMuMax + if (mu.lt.muConnex) then + write(*,*) '<--- due to epsilon1 > 1 above' + else + write(*,*) '<--- due to epsilon2 > 0 above' + endif + endif + + end function slowroll_startmax_matter_hy + + + + function sr_endinf_hy(x,hyData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: hyData + real(kp) :: sr_endinf_hy + real(kp) :: p,mu + + p=hyData%real1 + mu=hyData%real2 + + sr_endinf_hy = x**(p-1._kp) - sqrt(2._kp)*mu/p * (x**p + 1._kp) + + end function sr_endinf_hy + + + + + function sr_iniinf_hy(x,hyData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: hyData + real(kp) :: sr_iniinf_hy + real(kp) :: p + + p=hyData%real1 + + sr_iniinf_hy = sr_efold_hy(x,p) - hyData%real2 + + end function sr_iniinf_hy + + + + + function sr_efold_hy(x,p) + implicit none + real(kp), intent(in) :: x,p + real(kp) :: sr_efold_hy + + if (p == 2._kp) then + sr_efold_hy = x**2 + 2._kp * log(x) + else + sr_efold_hy = x**2 - 2._kp/(p-2._kp) * x**(2._kp-p) + endif + + + end function sr_efold_hy + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!running mass models +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function slowroll_initial_matter_rm(infParam,efoldWanted) + use infprec, only : transfert, tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_rm + + type(transfert) :: rmData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + real(kp) :: efold + real(kp) :: mini,maxi,randnum + real(kp) :: p,mu,nu,lambda + real(kp) :: matterOverMuStop,matterStop,matterEnd,matterIni + real(kp) :: matterZero + real(kp), dimension(2) :: fieldStop + +!should match with the definition of consts! + p = infParam%consts(2) + mu = infParam%consts(3) + nu = infParam%consts(4) + +!sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_rm: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_rm: p = ',p + stop + endif + + if ((abs(infParam%consts(4)).gt.0.5_kp).or.(infParam%consts(4).eq.0._kp)) then + write(*,*)'slowroll_initial_matter_rm: improper consts(4) = ',infParam%consts(4) + read(*,*) + endif + + lambda = nu * mu**p + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + + +!the potential is +! U = M^4 { 1 + nu*[1/p - ln(matter/mu)]*matter^p} + + +!matterstop required + fieldStop = field_stopinf(infParam) + matterStop = fieldStop(1) + + + +!for nu>0 there is matterEnd such as eps1(matterEnd) = 1. So the end +!of inflation in that case is either given by matterEnd or by +!matterStop. Note however that eps2 is usually big in that case which +!makes this calculation useless DAMNED!!. The eps1=1 eq has +!one solution only in [mu,matterZero] where U(matterZero) = 0 + if ((nu.gt.0._kp).and.(matterStop.gt.mu)) then + mini = mu + epsilon(1._kp) + maxi = 1._kp/epsilon(1._kp) + + rmData%real1 = p + rmData%real2 = mu + rmData%real3 = nu + + matterZero = zbrent(rm_potential,mini,maxi,tolFind,rmData) + + mini = mu + maxi = matterZero + + rmData%real1 = p + rmData%real2 = mu + rmData%real3 = nu + + matterEnd = zbrent(sr_endinf_rm,mini,maxi,tolFind,rmData) + + if (display) then + if (matterEnd.lt.matterStop) then + write(*,*)'slowroll_initial_matter_rm: epsilon1 stops inflation in SR approx' + endif + endif + +!useless matterStop = min(matterStop,matterEnd) + endif + + +!find matterIni according to matterStop to get the right number of +!efolds. The choice between the 4 models is done according to the +!value of matterStop. matterIni>1 has been allowed for RM4, with still +!matterStop < 1 + + if (matterStop.eq.mu) then + write(*,*)'slowroll_initial_matter_rm: matterStop/mu = ',matterStop/mu + stop + endif + + if (matterStop.lt.mu) then + mini = epsilon(1._kp) + maxi = mu - epsilon(1._kp) + elseif (matterStop.gt.mu) then + mini = mu + epsilon(1._kp) + if (nu.gt.0._kp) then + maxi = 1._kp + else + maxi = 1._kp/epsilon(1._kp) + endif + else + stop 'slowroll_initial_matter_rm: error' + endif + + matterOverMuStop = matterStop/mu + +! print *,'mini maxi',mini,maxi + + rmData%real1 = p + rmData%real2 = mu + rmData%real3 = nu + rmData%xend = sr_efold_rm(matterOverMuStop,p,lambda) + 2._kp*p*efold/mu**2 + + matterIni = zbrent(sr_iniinf_rm,mini,maxi,tolFind,rmData) + + slowroll_initial_matter_rm = matterIni + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_rm: (*kappa)' + write(*,*)'matterZero = ',matterZero + write(*,*)'matterEnd = ',matterEnd + write(*,*)'matterStop = ',matterStop + write(*,*)'matterIni = ',matterIni + write(*,*) + endif + + + end function slowroll_initial_matter_rm + + + + + function sr_efold_rm(x,p,l) + use specialinf, only : dp, dei + implicit none + real(kp), intent(in) :: x,p,l + real(kp) :: sr_efold_rm + real(dp) :: argei1,argei2 + +!l=nu*mu^p + + if (p == 2._kp) then + argei1 = 2._dp*log(x) + sr_efold_rm = x**2 - (2._kp/l)*log(abs(log(x))) - dei(argei1) + else + argei1 = (2._dp-p)*log(x) + argei2 = 2._dp*log(x) + sr_efold_rm = x**2 - (2._kp/l)*dei(argei1) - (2._kp/p)*dei(argei2) + endif + +! print *,'arg ei',argei1,dei(argei1) + + end function sr_efold_rm + + + + + function sr_endinf_rm(matter,rmData) +!vanishes for eps1=1 in the sr approx + use infprec, only : transfert + implicit none + real(kp), intent(in) :: matter + type(transfert), optional, intent(inout) :: rmData + real(kp) :: sr_endinf_rm + real(kp) :: p,mu,nu,x + + p=rmData%real1 + mu=rmData%real2 + nu=rmData%real3 + + x = matter/mu + + sr_endinf_rm = 1._kp + nu*(1._kp/p - log(x))*matter**p & + - (nu*p/sqrt(2._kp))*log(x)*matter**(p-1._kp) + + end function sr_endinf_rm + + + + + + function sr_iniinf_rm(matter,rmData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: matter + type(transfert), optional, intent(inout) :: rmData + real(kp) :: sr_iniinf_rm + real(kp) :: p,mu,nu,x,l + + p=rmData%real1 + mu=rmData%real2 + nu=rmData%real3 + + x = matter/mu + l = nu * mu**p + + sr_iniinf_rm = sr_efold_rm(x,p,l) - rmData%xend + + end function sr_iniinf_rm + + + + function rm_potential(matter,rmData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: matter + type(transfert), optional, intent(inout) :: rmData + real(kp) :: rm_potential + real(kp) :: p,mu,nu,x + + p=rmData%real1 + mu=rmData%real2 + nu=rmData%real3 + + x = matter/mu + + rm_potential = 1._kp + nu*(1._kp/p - log(x))*matter**p + + end function rm_potential + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!kklmmt models with m2=0: V = M^4 / [1 + (mu/phi)^p] +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function slowroll_initial_matter_kklt(infParam,efoldWanted) + use infprec, only : transfert, tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_kklt + + type(transfert) :: kkltData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + real(kp), dimension(2) :: fieldStop, fieldUv + real(kp) :: matterOverMuUv, matterOverMuString + real(kp) :: matterOverMuEps, matterOverMuIni, matterOverMuEnd + real(kp) :: mini,maxi + real(kp) :: p, mu + real(kp) :: efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + +!sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_kklt: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_kklt: p = ',p + stop + endif + + if (infParam%consts(5).ne.-1._kp) then + stop 'slowroll_initial_matter_kklt: improper consts(5)' + endif + + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + +!upper field value bound + fieldUv = field_thbound(infParam) + matterOverMuUv = fieldUv(1)/mu + + +!inflation stops at matterOverMuEps1 (its determination is no accurate +!since eps2>1 in that region, but the number of efold in between is +!small. This condition could be replaced by matterOverMuEps2 as well + + mini = 0._kp + maxi = 1._kp/epsilon(1._kp) + + kkltData%real1 = p + kkltData%real2 = mu + + matterOverMuEps = zbrent(sr_endinf_kklt,mini,maxi,tolFind,kkltData) + + +!the branes collide at matterString + fieldStop = field_stopinf(infParam) + matterOverMuString = fieldStop(1)/mu + + if (matterOverMuString.lt.1.) then + write(*,*)'slowroll_initial_matter_kklt: matterOverMuString < mu' + endif + + + matterOverMuEnd = max(matterOverMuString,MatterOverMuEps) + + + if (matterOverMuEnd.gt.matterOverMuUv) then + write(*,*)'slowroll_initial_matter_kklt: matterOverMuEnd > matterOverMuUv' + endif + +!find matterIni that gives the wanted number of efolds + + mini = 0._kp + maxi = 1._kp/epsilon(1._kp) + + kkltData%real1 = p + kkltData%real2 = p*(efold)/mu**2 + sr_efold_kklt(matterOverMuEnd,p) + + matterOverMuIni = zbrent(sr_iniinf_kklt,mini,maxi,tolFind,kkltData) + + slowroll_initial_matter_kklt = matterOverMuIni * mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_kklt: (*kappa) (/mu)' + write(*,*)'matterEnd = ',matterOverMuEnd*mu, matterOverMuEnd + write(*,*)'matterString = ',matterOverMuString*mu, matterOverMuString + write(*,*)'matterEps = ',matterOverMuEps*mu, matterOverMuEps + write(*,*)'matterIni = ',matterOverMuIni*mu, matterOverMuIni + write(*,*)'matterUv = ',matterOverMuUv*mu, matterOverMuUv + write(*,*) + endif + + + end function slowroll_initial_matter_kklt + + + + + function sr_endinf_kklt(x,kkltData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: kkltData + logical, parameter :: endinfIsEpsOne=.true. + real(kp) :: sr_endinf_kklt + real(kp) :: p,mu + + p=kkltData%real1 + mu=kkltData%real2 + + if (endinfIsEpsOne) then +!epsilon1=1 + sr_endinf_kklt = x**(p+1._kp) + x - p/(mu*sqrt(2._kp)) + else +!epsilon2=1 + sr_endinf_kklt = (x**(p+1._kp) + x)**2 - (2._kp*p/mu/mu) & + *( (p+1._kp)*x**p + 1._kp) + endif + + end function sr_endinf_kklt + + + + + function sr_iniinf_kklt(x,kkltData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: kkltData + real(kp) :: sr_iniinf_kklt + real(kp) :: p + + p=kkltData%real1 + + sr_iniinf_kklt = sr_efold_kklt(x,p) - kkltData%real2 + + end function sr_iniinf_kklt + + + + + function sr_efold_kklt(x,p) + implicit none + real(kp), intent(in) :: x,p + real(kp) :: sr_efold_kklt + + sr_efold_kklt = 0.5_kp*x**2 + x**(p+2._kp)/(p+2._kp) + + + end function sr_efold_kklt + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!mixed inflation M^4( phi^p + alpha phi^q) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function slowroll_initial_matter_mix(infParam,efoldWanted) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_mix + + type(transfert) :: mixData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + + real(kp) :: matterEnd, matterIni + real(kp) :: mini,maxi + real(kp) :: alpha, efold, p, q + +#ifndef PP5 + p = infParam%consts(2) + q = infParam%consts(12) + alpha = infParam%consts(6) +#else + stop 'slowroll_initial_matter_mix: check potParamNum value!' +#endif + + + if (alpha.lt.0._kp) then + stop 'mixed inflation: infParam%consts(6) < 0!' + endif + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + +!find the end of inflation + + mini = epsilon(1._kp) + maxi = 1._kp/epsilon(1._kp) + + mixData%real1 = p + mixData%real2 = q + mixData%real3 = alpha + + matterEnd = zbrent(sr_endinf_mix,mini,maxi,tolFind,mixData) + + + +!find the initial field values efolds before + + mini = matterEnd - epsilon(1._kp) + maxi = 1._kp/epsilon(1._kp) + + mixData%real1 = p + mixData%real2 = q + mixData%real3 = alpha + mixData%real4 = efold + sr_efold_mix(matterEnd,p,q,alpha) + + matterIni = zbrent(sr_iniinf_mix,mini,maxi,tolFind,mixData) + + slowroll_initial_matter_mix = matterIni + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_mix: (*kappa)' + write(*,*)'matterEnd = ',matterEnd + write(*,*)'matterIni = ',matterIni + write(*,*) + endif + + + end function slowroll_initial_matter_mix + + + + + function sr_endinf_mix(x,mixData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: mixData + real(kp) :: sr_endinf_mix + real(kp) :: p,q,alpha + + p=mixData%real1 + q=mixData%real2 + alpha=mixData%real3 + + sr_endinf_mix = alpha*sqrt(2._kp)*x**(q-p+1._kp) - alpha*q*x**(q-p) & + + sqrt(2._kp)*x - p + + end function sr_endinf_mix + + + + + function sr_iniinf_mix(x,mixData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: mixData + real(kp) :: sr_iniinf_mix + real(kp) :: p,q,alpha + + p=mixData%real1 + q=mixData%real2 + alpha=mixData%real3 + + sr_iniinf_mix = sr_efold_mix(x,p,q,alpha) - mixData%real4 + + end function sr_iniinf_mix + + + function sr_efold_mix(x,p,q,alpha) + use specialinf, only : hypergeom_2F1 + implicit none + real(kp), intent(in) :: x,p,q,alpha + real(kp) :: sr_efold_mix + + sr_efold_mix = 0.5_kp*x**2/(p*q)*(p + (q-p) & + *hypergeom_2F1(1._kp,2._kp/(q-p),1._kp + 2._kp/(q-p),-alpha*q*x**(q-p)/p)) + + end function sr_efold_mix + + +end module infsrmodel diff --git a/fieldinf/inftools.f90 b/fieldinf/inftools.f90 new file mode 100644 index 0000000..3646df6 --- /dev/null +++ b/fieldinf/inftools.f90 @@ -0,0 +1,1078 @@ +module inftools + use infprec, only : kp,transfert + implicit none + + private + + public easydverk, tunedverk + public zbrent + + + +contains + + + + subroutine easydverk(n,fcn,x,y,xend,tol,extradata) + implicit none + + integer :: n,ind + real(kp) :: x,y(n),xend,tol,c(24),w(n,9) + type(transfert), optional,intent(inout) :: extradata + +! external :: fcn + + include 'inftools.h' + + +! ind=1 + ind=2 + c = 0._kp + c(3) = epsilon(1._kp) + + call dverk(n,fcn,x,y,xend,tol,ind,c,n,w,extradata) + + if (ind.ne.3) then + write(*,*) 'easydverk: stop ind = ',ind + write(*,*) 'try to reduce tolerance' + stop + endif + end subroutine easydverk + + + + subroutine tunedverk(n,fcn,x,y,xend,tol,extradata) + implicit none + + integer :: n,ind + real(kp) :: x,y(n),xend,tol,c(24),w(n,9) + type(transfert), optional,intent(inout) :: extradata + +! external :: fcn + + include 'inftools.h' + + + + ind=2 + c = 0._kp + c(3) = epsilon(1._kp) + c(4) = epsilon(1._kp) + + call dverk(n,fcn,x,y,xend,tol,ind,c,n,w,extradata) + + if (ind.ne.3) then + write(*,*) 'unsanedverk: stop ind = ',ind + write(*,*) 'desesperate accuracy unreachable...' + write(*,*) 'try tuning c(4) and c(6) in inftools:unsanedverk!' + stop + endif + end subroutine tunedverk + + + + + + + subroutine diydverk(n,fcn,x,y,xend,tol,ind,c,extradata) + implicit none + + integer :: n,ind + real(kp) :: x,y(n),xend,tol,c(24),w(n,9) + type(transfert), optional, intent(inout) :: extradata + +! external :: fcn + + include 'inftools.h' + + ind=2 + c = 0._kp + + c(3) = epsilon(1._kp) + c(4) = 0.001_kp + + call dverk(n,fcn,x,y,xend,tol,ind,c,n,w,extradata) + + if ((ind.ne.3).and.(ind.ne.7)) then + write(*,*) 'diydverk: stop ind = ',ind + stop + endif + end subroutine diydverk + + + + +! function easyfixpnf(xstart,f,fjac,extradata) +! use hompack, only : rhodum, rhojacdum,fixpnf +! implicit none + +! real(kp) :: xstart, easyfixpnf +! type(transfert), optional :: extradata + + +! real(kp), parameter :: tolZero = 1e-5 + +! integer, parameter :: n = 1 +! integer :: iflag, trace, nfe +! real(kp) :: arcre,arcae +! real(kp) :: ansre,ansae +! real(kp) :: arclen + +! real(kp), dimension(n) :: a +! real(kp), dimension(n+1) :: y,yp,yold,ypold + +! real(kp), dimension(1:N,1:N+2) :: qr +! real(kp), dimension(n) :: alpha +! real(kp), dimension(n+1) :: tz,w,wp,z0,z1 + +! real(kp), dimension(8) :: sspar + +! integer, dimension(n+1) :: pivot + +! include 'hominfpack.h' + +! iflag = -1 +! trace = -1 +! sspar = -1 + +! arcre = -1. +! arcae = -1. +! ansre = tolZero +! ansae = tolZero + + +! y(n+1) = xstart + +! call fixpnf(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE, & +! ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR, & +! f,fjac,rhodum,rhojacdum,extradata) + +! if (iflag.ne.1) then +! write(*,*)'easyzero: iflag = ',iflag +! stop +! endif + +! easyfixpnf = y(n+1) + +! end function easyfixpnf + + + + + + + + subroutine dverk(n,fcn,x,y,xend,tol,ind,c,nw,w,extradata) + implicit none + integer :: n, ind, nw, k + real(kp) :: x, y(n), xend, tol, c(*), w(nw,9), temp + type(transfert), optional, intent(inout) :: extradata + + +! +!*********************************************************************** +! * +! note added 11/14/85. * +! * +! if you discover any errors in this subroutine, please contact * +! * +! kenneth r. jackson * +! department of computer science * +! university of toronto * +! toronto, ontario, * +! canada m5s 1a4 * +! * +! phone: 416-978-7075 * +! * +! electroni! mail: * +! uucp: {cornell,decvax,ihnp4,linus,uw-beaver}!utcsri!krj * +! csnet: krj@toronto * +! arpa: krj.toronto@csnet-relay * +! bitnet: krj%toronto@csnet-relay.arpa * +! * +! dverk is written in fortran 66. * +! * +! the constants dwarf and rreb -- c(10) and c(11), respectively -- are * +! set for a vax in double precision. they should be reset, as * +! described below, if this program is run on another machine. * +! * +! the c array is declared in this subroutine to have one element only, * +! although more elements are referenced in this subroutine. this * +! causes some compilers to issue warning messages. there is, though, * +! no error provided c is declared sufficiently large in the calling * +! program, as described below. * +! * +! the following external statement for fcn was added to avoid a * +! warning message from the unix f77 compiler. the original dverk * +! comments and code follow it. * +! * +!*********************************************************************** +! + +!EXTRADATA + +!might be dangerous (xlf90) with optional argument, rather use explicit +!interface +! external fcn + include 'inftools.h' + + if (present(extradata)) extradata%update = .false. +! +!*********************************************************************** +! * +! purpose - this is a runge-kutta subroutine based on verner's * +! fifth and sixth order pair of formulas for finding approximations to * +! the solution of a system of first order ordinary differential * +! equations with initial conditions. it attempts to keep the global * +! error proportional to a tolerance specified by the user. (the * +! proportionality depends on the kind of error control that is used, * +! as well as the differential equation and the range of integration.) * +! * +! various options are available to the user, including different * +! kinds of error control, restrictions on step sizes, and interrupts * +! which permit the user to examine the state of the calculation (and * +! perhaps make modifications) during intermediate stages. * +! * +! the program is efficient for non-stiff systems. however, a good * +! variable-order-adams method will probably be more efficient if the * +! function evaluations are very costly. such a method would also be * +! more suitable if one wanted to obtain a large number of intermediate * +! solution values by interpolation, as might be the case for example * +! with graphical output. * +! * +! hull-enright-jackson 1/10/76 * +! * +!*********************************************************************** +! * +! use - the user must specify each of the following * +! * +! n number of equations * +! * +! fcn name of subroutine for evaluating functions - the subroutine * +! itself must also be provided by the user - it should be of * +! the following form * +! subroutine fcn(n, x, y, yprime) * +! integer n * +! double precision x, y(n), yprime(n) * +! *** etc *** * +! and it should evaluate yprime, given n, x and y * +! * +! x independent variable - initial value supplied by user * +! * +! y dependent variable - initial values of components y(1), y(2), * +! ..., y(n) supplied by user * +! * +! xend value of x to which integration is to be carried out - it may * +! be less than the initial value of x * +! * +! tol tolerance - the subroutine attempts to control a norm of the * +! local error in such a way that the global error is * +! proportional to tol. in some problems there will be enough * +! damping of errors, as well as some cancellation, so that * +! the global error will be less than tol. alternatively, the * +! control can be viewed as attempting to provide a * +! calculated value of y at xend which is the exact solution * +! to the problem y' = f(x,y) + e(x) where the norm of e(x) * +! is proportional to tol. (the norm is a max norm with * +! weights that depend on the error control strategy chosen * +! by the user. the default weight for the k-th component is * +! 1/max(1,abs(y(k))), which therefore provides a mixture of * +! absolute and relative error control.) * +! * +! ind indicator - on initial entry ind must be set equal to either * +! 1 or 2. if the user does not wish to use any options, he * +! should set ind to 1 - all that remains for the user to do * +! then is to declare c and w, and to specify nw. the user * +! may also select various options on initial entry by * +! setting ind = 2 and initializing the first 9 components of * +! c as described in the next section. he may also re-enter * +! the subroutine with ind = 3 as mentioned again below. in * +! any event, the subroutine returns with ind equal to * +! 3 after a normal return * +! 4, 5, or 6 after an interrupt (see options c(8), c(9)) * +! -1, -2, or -3 after an error condition (see below) * +! * +! c communications vector - the dimension must be greater than or * +! equal to 24, unless option c(1) = 4 or 5 is used, in which * +! case the dimension must be greater than or equal to n+30 * +! * +! nw first dimension of workspace w - must be greater than or * +! equal to n * +! * +! w workspace matrix - first dimension must be nw and second must * +! be greater than or equal to 9 * +! * +! the subroutine will normally return with ind = 3, having * +! replaced the initial values of x and y with, respectively, the value * +! of xend and an approximation to y at xend. the subroutine can be * +! called repeatedly with new values of xend without having to change * +! any other argument. however, changes in tol, or any of the options * +! described below, may also be made on such a re-entry if desired. * +! * +! three error returns are also possible, in which case x and y * +! will be the most recently accepted values - * +! with ind = -3 the subroutine was unable to satisfy the error * +! requirement with a particular step-size that is less than or * +! equal to hmin, which may mean that tol is too small * +! with ind = -2 the value of hmin is greater than hmax, which * +! probably means that the requested tol (which is used in the * +! calculation of hmin) is too small * +! with ind = -1 the allowed maximum number of fcn evaluations has * +! been exceeded, but this can only occur if option c(7), as * +! described in the next section, has been used * +! * +! there are several circumstances that will cause the calculations * +! to be terminated, along with output of information that will help * +! the user determine the cause of the trouble. these circumstances * +! involve entry with illegal or inconsistent values of the arguments, * +! such as attempting a normal re-entry without first changing the * +! value of xend, or attempting to re-enter with ind less than zero. * +! * +!*********************************************************************** +! * +! options - if the subroutine is entered with ind = 1, the first 9 * +! components of the communications vector are initialized to zero, and * +! the subroutine uses only default values for each option. if the * +! subroutine is entered with ind = 2, the user must specify each of * +! these 9 components - normally he would first set them all to zero, * +! and then make non-zero those that correspond to the particular * +! options he wishes to select. in any event, options may be changed on * +! re-entry to the subroutine - but if the user changes any of the * +! options, or tol, in the course of a calculation he should be careful * +! about how such changes affect the subroutine - it may be better to * +! restart with ind = 1 or 2. (components 10 to 24 of c are used by the * +! program - the information is available to the user, but should not * +! normally be changed by him.) * +! * +! c(1) error control indicator - the norm of the local error is the * +! max norm of the weighted error estimate vector, the * +! weights being determined according to the value of c(1) - * +! if c(1)=1 the weights are 1 (absolute error control) * +! if c(1)=2 the weights are 1/abs(y(k)) (relative error * +! control) * +! if c(1)=3 the weights are 1/max(abs(c(2)),abs(y(k))) * +! (relative error control, unless abs(y(k)) is less * +! than the floor value, abs(c(2)) ) * +! if c(1)=4 the weights are 1/max(abs(c(k+30)),abs(y(k))) * +! (here individual floor values are used) * +! if c(1)=5 the weights are 1/abs(c(k+30)) * +! for all other values of c(1), including c(1) = 0, the * +! default values of the weights are taken to be * +! 1/max(1,abs(y(k))), as mentioned earlier * +! (in the two cases c(1) = 4 or 5 the user must declare the * +! dimension of c to be at least n+30 and must initialize the * +! components c(31), c(32), ..., c(n+30).) * +! * +! c(2) floor value - used when the indicator c(1) has the value 3 * +! * +! c(3) hmin specification - if not zero, the subroutine chooses hmin * +! to be abs(c(3)) - otherwise it uses the default value * +! 10*max(dwarf,rreb*max(weighted norm y/tol,abs(x))), * +! where dwarf is a very small positive machine number and * +! rreb is the relative roundoff error bound * +! * +! c(4) hstart specification - if not zero, the subroutine will use * +! an initial hmag equal to abs(c(4)), except of course for * +! the restrictions imposed by hmin and hmax - otherwise it * +! uses the default value of hmax*(tol)**(1/6) * +! * +! c(5) scale specification - this is intended to be a measure of the * +! scale of the problem - larger values of scale tend to make * +! the method more reliable, first by possibly restricting * +! hmax (as described below) and second, by tightening the * +! acceptance requirement - if c(5) is zero, a default value * +! of 1 is used. for linear homogeneous problems with * +! constant coefficients, an appropriate value for scale is a * +! norm of the associated matrix. for other problems, an * +! approximation to an average value of a norm of the * +! jacobian along the trajectory may be appropriate * +! * +! c(6) hmax specification - four cases are possible * +! if c(6).ne.0 and c(5).ne.0, hmax is taken to be * +! min(abs(c(6)),2/abs(c(5))) * +! if c(6).ne.0 and c(5).eq.0, hmax is taken to be abs(c(6)) * +! if c(6).eq.0 and c(5).ne.0, hmax is taken to be * +! 2/abs(c(5)) * +! if c(6).eq.0 and c(5).eq.0, hmax is given a default value * +! of 2 * +! * +! c(7) maximum number of function evaluations - if not zero, an * +! error return with ind = -1 will be caused when the number * +! of function evaluations exceeds abs(c(7)) * +! * +! c(8) interrupt number 1 - if not zero, the subroutine will * +! interrupt the calculations after it has chosen its * +! preliminary value of hmag, and just before choosing htrial * +! and xtrial in preparation for taking a step (htrial may * +! differ from hmag in sign, and may require adjustment if * +! xend is near) - the subroutine returns with ind = 4, and * +! will resume calculation at the point of interruption if * +! re-entered with ind = 4 * +! * +! c(9) interrupt number 2 - if not zero, the subroutine will * +! interrupt the calculations immediately after it has * +! decided whether or not to accept the result of the most * +! recent trial step, with ind = 5 if it plans to accept, or * +! ind = 6 if it plans to reject - y(*) is the previously * +! accepted result, while w(*,9) is the newly computed trial * +! value, and w(*,2) is the unweighted error estimate vector. * +! the subroutine will resume calculations at the point of * +! interruption on re-entry with ind = 5 or 6. (the user may * +! change ind in this case if he wishes, for example to force * +! acceptance of a step that would otherwise be rejected, or * +! vice versa. he can also restart with ind = 1 or 2.) * +! * +!*********************************************************************** +! * +! summary of the components of the communications vector * +! * +! prescribed at the option determined by the program * +! of the user * +! * +! c(10) rreb(rel roundoff err bnd) * +! c(1) error control indicator c(11) dwarf (very small mach no) * +! c(2) floor value c(12) weighted norm y * +! c(3) hmin specification c(13) hmin * +! c(4) hstart specification c(14) hmag * +! c(5) scale specification c(15) scale * +! c(6) hmax specification c(16) hmax * +! c(7) max no of fcn evals c(17) xtrial * +! c(8) interrupt no 1 c(18) htrial * +! c(9) interrupt no 2 c(19) est * +! c(20) previous xend * +! c(21) flag for xend * +! c(22) no of successful steps * +! c(23) no of successive failures * +! c(24) no of fcn evals * +! * +! if c(1) = 4 or 5, c(31), c(32), ... c(n+30) are floor values * +! * +!*********************************************************************** +! * +! an overview of the program * +! * +! begin initialization, parameter checking, interrupt re-entries * +! ......abort if ind out of range 1 to 6 * +! . cases - initial entry, normal re-entry, interrupt re-entries * +! . case 1 - initial entry (ind .eq. 1 or 2) * +! v........abort if n.gt.nw or tol.le.0 * +! . if initial entry without options (ind .eq. 1) * +! . set c(1) to c(9) equal to zero * +! . else initial entry with options (ind .eq. 2) * +! . make c(1) to c(9) non-negative * +! . make floor values non-negative if they are to be used * +! . end if * +! . initialize rreb, dwarf, prev xend, flag, counts * +! . case 2 - normal re-entry (ind .eq. 3) * +! .........abort if xend reached, and either x changed or xend not * +! . re-initialize flag * +! . case 3 - re-entry following an interrupt (ind .eq. 4 to 6) * +! v transfer control to the appropriate re-entry point....... * +! . end cases . * +! . end initialization, etc. . * +! . v * +! . loop through the following 4 stages, once for each trial step . * +! . stage 1 - prepare . * +!***********error return (with ind=-1) if no of fcn evals too great . * +! . calc slope (adding 1 to no of fcn evals) if ind .ne. 6 . * +! . calc hmin, scale, hmax . * +!***********error return (with ind=-2) if hmin .gt. hmax . * +! . calc preliminary hmag . * +!***********interrupt no 1 (with ind=4) if requested.......re-entry.v * +! . calc hmag, xtrial and htrial . * +! . end stage 1 . * +! v stage 2 - calc ytrial (adding 7 to no of fcn evals) . * +! . stage 3 - calc the error estimate . * +! . stage 4 - make decisions . * +! . set ind=5 if step acceptable, else set ind=6 . * +!***********interrupt no 2 if requested....................re-entry.v * +! . if step accepted (ind .eq. 5) * +! . update x, y from xtrial, ytrial * +! . add 1 to no of successful steps * +! . set no of successive failures to zero * +!**************return(with ind=3, xend saved, flag set) if x .eq. xend * +! . else step not accepted (ind .eq. 6) * +! . add 1 to no of successive failures * +!**************error return (with ind=-3) if hmag .le. hmin * +! . end if * +! . end stage 4 * +! . end loop * +! . * +! begin abort action * +! output appropriate message about stopping the calculations, * +! along with values of ind, n, nw, tol, hmin, hmax, x, xend, * +! previous xend, no of successful steps, no of successive * +! failures, no of fcn evals, and the components of y * +! stop * +! end abort action * +! * +!*********************************************************************** +! +! ****************************************************************** +! * begin initialization, parameter checking, interrupt re-entries * +! ****************************************************************** +! +! ......abort if ind out of range 1 to 6 + if (ind.lt.1 .or. ind.gt.6) go to 500 +! +! cases - initial entry, normal re-entry, interrupt re-entries + go to (5, 5, 45, 1111, 2222, 2222), ind +! case 1 - initial entry (ind .eq. 1 or 2) +! .........abort if n.gt.nw or tol.le.0 + 5 if (n.gt.nw .or. tol.le.0._kp) go to 500 + if (ind.eq. 2) go to 15 +! initial entry without options (ind .eq. 1) +! set c(1) to c(9) equal to 0 + do 10 k = 1, 9 + c(k) = 0._kp + 10 continue + go to 35 + 15 continue +! initial entry with options (ind .eq. 2) +! make c(1) to c(9) non-negative + do 20 k = 1, 9 + c(k) = abs(c(k)) + 20 continue +! make floor values non-negative if they are to be used + if (c(1).ne.4._kp .and. c(1).ne.5._kp) go to 30 + do 25 k = 1, n + c(k+30) = abs(c(k+30)) + 25 continue + 30 continue + 35 continue +! initialize rreb, dwarf, prev xend, flag, counts + c(10) = 2._kp**(-56) + c(11) = 1.d-35 +! set previous xend initially to initial value of x + c(20) = x + do 40 k = 21, 24 + c(k) = 0._kp + 40 continue + go to 50 +! case 2 - normal re-entry (ind .eq. 3) +! .........abort if xend reached, and either x changed or xend not + 45 if (c(21).ne.0._kp .and. & + (x.ne.c(20) .or. xend.eq.c(20))) go to 500 +! re-initialize flag + c(21) = 0._kp + go to 50 +! case 3 - re-entry following an interrupt (ind .eq. 4 to 6) +! transfer control to the appropriate re-entry point.......... +! this has already been handled by the computed go to . +! end cases v + 50 continue +! +! end initialization, etc. +! +! ****************************************************************** +! * loop through the following 4 stages, once for each trial step * +! * until the occurrence of one of the following * +! * (a) the normal return (with ind .eq. 3) on reaching xend in * +! * stage 4 * +! * (b) an error return (with ind .lt. 0) in stage 1 or stage 4 * +! * (c) an interrupt return (with ind .eq. 4, 5 or 6), if * +! * requested, in stage 1 or stage 4 * +! ****************************************************************** +! +99999 continue +! +! *************************************************************** +! * stage 1 - prepare - do calculations of hmin, hmax, etc., * +! * and some parameter checking, and end up with suitable * +! * values of hmag, xtrial and htrial in preparation for taking * +! * an integration step. * +! *************************************************************** +! +!***********error return (with ind=-1) if no of fcn evals too great + if (c(7).eq.0._kp .or. c(24).lt.c(7)) go to 100 + ind = -1 + return + 100 continue +! +! calculate slope (adding 1 to no of fcn evals) if ind .ne. 6 + if (ind .eq. 6) go to 105 +!EXTRADATA call fcn(n, x, y, w(1,1)) + if (present(extradata)) extradata%check=.true. + call fcn(n, x, y, w(1,1),extradata) + if (present(extradata)) then + if (extradata%update) xend = extradata%xend + extradata%check=.false. + endif +!END EXTRADATA + c(24) = c(24) + 1._kp + 105 continue +! +! calculate hmin - use default unless value prescribed + c(13) = c(3) + if (c(3) .ne. 0._kp) go to 165 +! calculate default value of hmin +! first calculate weighted norm y - c(12) - as specified +! by the error control indicator c(1) + temp = 0._kp + if (c(1) .ne. 1._kp) go to 115 +! absolute error control - weights are 1 + do 110 k = 1, n + temp = max(temp, abs(y(k))) + 110 continue + c(12) = temp + go to 160 + 115 if (c(1) .ne. 2._kp) go to 120 +! relative error control - weights are 1/abs(y(k)) so +! weighted norm y is 1 + c(12) = 1._kp + go to 160 + 120 if (c(1) .ne. 3._kp) go to 130 +! weights are 1/max(c(2),abs(y(k))) + do 125 k = 1, n + temp = max(temp, abs(y(k))/c(2)) + 125 continue + c(12) = min(temp, 1._kp) + go to 160 + 130 if (c(1) .ne. 4._kp) go to 140 +! weights are 1/max(c(k+30),abs(y(k))) + do 135 k = 1, n + temp = max(temp, abs(y(k))/c(k+30)) + 135 continue + c(12) = min(temp, 1._kp) + go to 160 + 140 if (c(1) .ne. 5._kp) go to 150 +! weights are 1/c(k+30) + do 145 k = 1, n + temp = max(temp, abs(y(k))/c(k+30)) + 145 continue + c(12) = temp + go to 160 + 150 continue +! default case - weights are 1/max(1,abs(y(k))) + do 155 k = 1, n + temp = max(temp, abs(y(k))) + 155 continue + c(12) = min(temp, 1._kp) + 160 continue + c(13) = 10._kp*max(c(11),c(10)*max(c(12)/tol,abs(x))) + 165 continue +! +! calculate scale - use default unless value prescribed + c(15) = c(5) + if (c(5) .eq. 0._kp) c(15) = 1._kp +! +! calculate hmax - consider 4 cases +! case 1 both hmax and scale prescribed + if (c(6).ne.0._kp .and. c(5).ne.0._kp) & + c(16) = min(c(6), 2._kp/c(5)) +! case 2 - hmax prescribed, but scale not + if (c(6).ne.0._kp .and. c(5).eq.0._kp) c(16) = c(6) +! case 3 - hmax not prescribed, but scale is + if (c(6).eq.0._kp .and. c(5).ne.0._kp) c(16) = 2._kp/c(5) +! case 4 - neither hmax nor scale is provided + if (c(6).eq.0._kp .and. c(5).eq.0._kp) c(16) = 2._kp +! +!***********error return (with ind=-2) if hmin .gt. hmax + if (c(13) .le. c(16)) go to 170 + ind = -2 + return + 170 continue +! +! calculate preliminary hmag - consider 3 cases + if (ind .gt. 2) go to 175 +! case 1 - initial entry - use prescribed value of hstart, if +! any, else default + c(14) = c(4) + if (c(4) .eq. 0._kp) c(14) = c(16)*tol**(1./6.) + go to 185 + 175 if (c(23) .gt. 1._kp) go to 180 +! case 2 - after a successful step, or at most one failure, +! use min(2, .9*(tol/est)**(1/6))*hmag, but avoid possible +! overflow. then avoid reduction by more than half. + temp = 2._kp*c(14) + if (tol .lt. (2._kp/.9_kp)**6*c(19)) & + temp = .9_kp*(tol/c(19))**(1./6.)*c(14) + c(14) = max(temp, .5_kp*c(14)) + go to 185 + 180 continue +! case 3 - after two or more successive failures + c(14) = .5_kp*c(14) + 185 continue +! +! check against hmax + c(14) = min(c(14), c(16)) +! +! check against hmin + c(14) = max(c(14), c(13)) +! +!***********interrupt no 1 (with ind=4) if requested + if (c(8) .eq. 0._kp) go to 1111 + ind = 4 + return +! resume here on re-entry with ind .eq. 4 ........re-entry.. + 1111 continue +! +! calculate hmag, xtrial - depending on preliminary hmag, xend + if (c(14) .ge. abs(xend - x)) go to 190 +! do not step more than half way to xend + c(14) = min(c(14), .5_kp*abs(xend - x)) + c(17) = x + sign(c(14), xend - x) + go to 195 + 190 continue +! hit xend exactly + c(14) = abs(xend - x) + c(17) = xend + 195 continue +! +! calculate htrial + c(18) = c(17) - x +! +! end stage 1 +! +! *************************************************************** +! * stage 2 - calculate ytrial (adding 7 to no of fcn evals). * +! * w(*,2), ... w(*,8) hold intermediate results needed in * +! * stage 3. w(*,9) is temporary storage until finally it holds * +! * ytrial. * +! *************************************************************** +! + temp = c(18)/1398169080000._kp +! + do 200 k = 1, n + w(k,9) = y(k) + temp*w(k,1)*233028180000._kp + 200 continue + call fcn(n, x + c(18)/6._kp, w(1,9), w(1,2),extradata) +! + do 205 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*74569017600._kp & + + w(k,2)*298276070400._kp ) + 205 continue + call fcn(n, x + c(18)*(4._kp/15._kp), w(1,9), w(1,3),extradata) +! + do 210 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*1165140900000._kp & + - w(k,2)*3728450880000._kp & + + w(k,3)*3495422700000._kp ) + 210 continue + call fcn(n, x + c(18)*(2._kp/3._kp), w(1,9), w(1,4),extradata) +! + do 215 k = 1, n + w(k,9) = y(k) + temp*( - w(k,1)*3604654659375._kp & + + w(k,2)*12816549900000._kp & + - w(k,3)*9284716546875._kp & + + w(k,4)*1237962206250._kp ) + 215 continue + call fcn(n, x + c(18)*(5._kp/6._kp), w(1,9), w(1,5),extradata) +! + do 220 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*3355605792000._kp & + - w(k,2)*11185352640000._kp & + + w(k,3)*9172628850000._kp & + - w(k,4)*427218330000._kp & + + w(k,5)*482505408000._kp ) + 220 continue + call fcn(n, x + c(18), w(1,9), w(1,6),extradata) +! + do 225 k = 1, n + w(k,9) = y(k) + temp*( - w(k,1)*770204740536._kp & + + w(k,2)*2311639545600._kp & + - w(k,3)*1322092233000._kp & + - w(k,4)*453006781920._kp & + + w(k,5)*326875481856._kp ) + 225 continue + call fcn(n, x + c(18)/15._kp, w(1,9), w(1,7),extradata) +! + do 230 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*2845924389000._kp & + - w(k,2)*9754668000000._kp & + + w(k,3)*7897110375000._kp & + - w(k,4)*192082660000._kp & + + w(k,5)*400298976000._kp & + + w(k,7)*201586000000._kp ) + 230 continue + call fcn(n, x + c(18), w(1,9), w(1,8),extradata) +! +! calculate ytrial, the extrapolated approximation and store +! in w(*,9) + do 235 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*104862681000._kp & + + w(k,3)*545186250000._kp & + + w(k,4)*446637345000._kp & + + w(k,5)*188806464000._kp & + + w(k,7)*15076875000._kp & + + w(k,8)*97599465000._kp ) + 235 continue +! +! add 7 to the no of fcn evals + c(24) = c(24) + 7._kp +! +! end stage 2 +! +! *************************************************************** +! * stage 3 - calculate the error estimate est. first calculate * +! * the unweighted absolute error estimate vector (per unit * +! * step) for the unextrapolated approximation and store it in * +! * w(*,2). then calculate the weighted max norm of w(*,2) as * +! * specified by the error control indicator c(1). finally, * +! * modify this result to produce est, the error estimate (per * +! * unit step) for the extrapolated approximation ytrial. * +! *************************************************************** +! +! calculate the unweighted absolute error estimate vector + do 300 k = 1, n + w(k,2) = ( w(k,1)*8738556750._kp & + + w(k,3)*9735468750._kp & + - w(k,4)*9709507500._kp & + + w(k,5)*8582112000._kp & + + w(k,6)*95329710000._kp & + - w(k,7)*15076875000._kp & + - w(k,8)*97599465000._kp)/1398169080000._kp + 300 continue +! +! calculate the weighted max norm of w(*,2) as specified by +! the error control indicator c(1) + temp = 0._kp + if (c(1) .ne. 1._kp) go to 310 +! absolute error control + do 305 k = 1, n + temp = max(temp,abs(w(k,2))) + 305 continue + go to 360 + 310 if (c(1) .ne. 2._kp) go to 320 +! relative error control + do 315 k = 1, n + temp = max(temp, abs(w(k,2)/y(k))) + 315 continue + go to 360 + 320 if (c(1) .ne. 3._kp) go to 330 +! weights are 1/max(c(2),abs(y(k))) + do 325 k = 1, n + temp = max(temp, abs(w(k,2)) & + / max(c(2), abs(y(k))) ) + 325 continue + go to 360 + 330 if (c(1) .ne. 4._kp) go to 340 +! weights are 1/max(c(k+30),abs(y(k))) + do 335 k = 1, n + temp = max(temp, abs(w(k,2)) & + / max(c(k+30), abs(y(k))) ) + 335 continue + go to 360 + 340 if (c(1) .ne. 5._kp) go to 350 +! weights are 1/c(k+30) + do 345 k = 1, n + temp = max(temp, abs(w(k,2)/c(k+30))) + 345 continue + go to 360 + 350 continue +! default case - weights are 1/max(1,abs(y(k))) + do 355 k = 1, n + temp = max(temp, abs(w(k,2)) & + / max(1._kp, abs(y(k))) ) + 355 continue + 360 continue +! +! calculate est - (the weighted max norm of w(*,2))*hmag*scale +! - est is intended to be a measure of the error per unit +! step in ytrial + c(19) = temp*c(14)*c(15) +! +! end stage 3 +! +! *************************************************************** +! * stage 4 - make decisions. * +! *************************************************************** +! +! set ind=5 if step acceptable, else set ind=6 + ind = 5 + if (c(19) .gt. tol) ind = 6 +! +!***********interrupt no 2 if requested + if (c(9) .eq. 0._kp) go to 2222 + return +! resume here on re-entry with ind .eq. 5 or 6 ...re-entry.. + 2222 continue +! + if (ind .eq. 6) go to 410 +! step accepted (ind .eq. 5), so update x, y from xtrial, +! ytrial, add 1 to the no of successful steps, and set +! the no of successive failures to zero + x = c(17) + do 400 k = 1, n + y(k) = w(k,9) + 400 continue + c(22) = c(22) + 1._kp + c(23) = 0._kp +!**************return(with ind=3, xend saved, flag set) if x .eq. xend + if (x .ne. xend) go to 405 + ind = 3 + c(20) = xend + c(21) = 1._kp + return + 405 continue + go to 420 + 410 continue +! step not accepted (ind .eq. 6), so add 1 to the no of +! successive failures + c(23) = c(23) + 1._kp +!**************error return (with ind=-3) if hmag .le. hmin + if (c(14) .gt. c(13)) go to 415 + ind = -3 + return + 415 continue + 420 continue +! +! end stage 4 +! + go to 99999 +! end loop +! +! begin abort action + 500 continue + write(6,*)'Computation stopped in dverk with' + write(6,*)'ind= tol= ',ind,tol + write(6,*)'x= n= ',x,n + write(6,*)'c(13)= xend= ',c(13),xend + write(6,*)'nw= c(16)= c(20)= ',nw, c(16),c(20) + write(6,*)'c(22)= c(23)= c(24)= ',c(22),c(23),c(24) + write(6,*)'y(:)= ',y +! write(6,*) ind, tol, x, n, c(13), xend, nw, c(16), c(20), & +! c(22), c(23), c(24), (y(k), k = 1, n) +! 505 format( /// 1h0, 58hcomputation stopped in dverk with the following values - / 1h0, 5hind =, i4, 5x, 6htol =, 1pd13.6, 5x, 11hx =,& +! 1pd22.15& +! / 1h , 5hn =, i4, 5x, 6hhmin =, 1pd13.6, 5x, 11hxend =,& +! 1pd22.15& +! / 1h , 5hnw =, i4, 5x, 6hhmax =, 1pd13.6, 5x, 11hprev xend =,& +! 1pd22.15& +! / 1h0, 14x, 27hno of successful steps =, 0pf8.0& +! / 1h , 14x, 27hno of successive failures =, 0pf8.0& +! / 1h , 14x, 27hno of function evals =, 0pf8.0& +! / 1h0, 23hthe components of y are& +! // (1h , 1p5d24.15) ) +! + stop +! +! end abort action +! + end subroutine dverk + + + + + + + function zbrent(func,x1,x2,tol,extradata) + INTEGER ITMAX + real(kp) zbrent,tol,x1,x2,EPS + type(transfert) :: extradata + + !real(kp) :: func +! EXTERNAL func + PARAMETER (ITMAX=1000,EPS=1d-15) + INTEGER iter + real(kp) a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm + + integer, parameter :: iexmax = 1000 + real(kp), parameter :: tolExpand = 1e-2 + integer :: iex + logical :: notbracketed + + interface + function func(x,otherdata) + use infprec, only : kp,transfert + implicit none + real(kp) :: func + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: otherdata + end function func + end interface + + notbracketed = .true. + iex = 0 + + a=x1 + b=x2 + + do while (notbracketed.and.(iex.lt.iexmax)) + fa=func(a,extradata) + fb=func(b,extradata) + if((fa.gt.0..and.fb.gt.0.).or.(fa.lt.0..and.fb.lt.0.)) then + write(*,*)'x1= fa= ',a,fa + write(*,*)'x2= fb= ',b,fb + write(*,*)'zbrent: expanding interval!' + a = a - abs(a)*tolExpand + b = b + abs(b)*tolExpand + iex = iex + 1 + notbracketed = .true. + else + notbracketed = .false. + endif + enddo + + if (notbracketed) stop 'root must be bracketed for zbrent' + + c=b + fc=fb + do iter=1,ITMAX + if((fb.gt.0..and.fc.gt.0.).or.(fb.lt.0..and.fc.lt.0.))then + c=a + fc=fa + d=b-a + e=d + endif + if(abs(fc).lt.abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2.*EPS*abs(b)+0.5*tol + xm=.5*(c-b) + if(abs(xm).le.tol1 .or. fb.eq.0.)then + zbrent=b + return + endif + if(abs(e).ge.tol1 .and. abs(fa).gt.abs(fb)) then + s=fb/fa + if(a.eq.c) then + p=2.*xm*s + q=1.-s + else + q=fa/fc + r=fb/fc + p=s*(2.*xm*q*(q-r)-(b-a)*(r-1.)) + q=(q-1.)*(r-1.)*(s-1.) + endif + if(p.gt.0.) q=-q + p=abs(p) + if(2.*p .lt. min(3.*xm*q-abs(tol1*q),abs(e*q))) then + e=d + d=p/q + else + d=xm + e=d + endif + else + d=xm + e=d + endif + a=b + fa=fb + if(abs(d) .gt. tol1) then + b=b+d + else + b=b+sign(tol1,xm) + endif + fb=func(b,extradata) + enddo + stop 'zbrent exceeding maximum iterations' + zbrent=b + return + end function zbrent + + + + + + + + end module inftools + + diff --git a/fieldinf/inftools.h b/fieldinf/inftools.h new file mode 100644 index 0000000..2735555 --- /dev/null +++ b/fieldinf/inftools.h @@ -0,0 +1,11 @@ + interface + subroutine fcn(n, x, y, yprime, otherdata) + use infprec, only : kp,transfert + implicit none + integer :: n + real(kp) :: x + real(kp), dimension(n) :: y, yprime + type(transfert), optional, intent(inout) :: otherdata + end subroutine fcn + end interface + diff --git a/fieldinf/inftorad.f90 b/fieldinf/inftorad.f90 new file mode 100644 index 0000000..a6490bd --- /dev/null +++ b/fieldinf/inftorad.f90 @@ -0,0 +1,515 @@ +module inftorad + use cosmopar + use infprec, only : kp + use infbgmodel, only : fieldNum + use infbg, only : infbgphys + implicit none + + private + + +!we use this everywhere + type inftoradcosmo + real(kp) :: bfoldIni + real(kp) :: bfoldEnd + real(kp) :: efoldEndToToday + real(kp) :: lnEnergyEnd + type(infbgphys) :: bgIni + type(infbgphys) :: bgEnd + end type inftoradcosmo + + +!for debugging, physical quantities at hubble exit + type infhubblexit + real(kp) :: kmpc + real(kp) :: bfold + real(kp) :: hubble + real(kp) :: epsilon1 + real(kp) :: epsilon1JF + end type infhubblexit + + +!for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_file = .false. + + +!some physical constants + real(kp), parameter :: scaleFactorToday = 1._kp + +! ln[1Mpc/sqrt(8pi)/lPl] = 130.282 +! real(kp), parameter :: lnMpcToKappa = 130.282_kp + +!enforce constant equation of state during reheating for large field models + logical, parameter :: LargeFieldWreh = .false. + + public inftoradcosmo + public scaleFactorToday, lnMpcToKappa + + public set_inftorad_cosmo, bfold_hubble_fraction + + +!for test + public infhubblexit, hubble_splinexit + +contains + + + + + + function set_inftorad_cosmo(bgParam,bgIni,bgEnd,lnReheat,inferror) + use infbgmodel, only : infbgparam + use infbg, only : infbgdata, infbgphys + use infbg, only : matter_energy_density, matter_energy_density_JF + use infbgspline, only : set_infbg_spline + implicit none + + type(inftoradcosmo) :: set_inftorad_cosmo + + type(infbgparam), intent(in) :: bgParam + type(infbgphys), intent(in) :: bgIni + type(infbgphys), intent(in) :: bgEnd + +!ln(aend/areh) + (1/4)ln(rhoend/rhoreh) + (1/4)ln(rhoend). This is the +!deviations expected from either instantaneous reheating or radiation +!dominated like reheating + real(kp), intent(in) :: lnReheat + +!useful for setting hard prior + integer, optional :: inferror + +!rho at the end of inflation + real(kp) :: lnEnergyEndInf + +!bound on lnReheat + real(kp) :: lnReheatMin, lnReheatMax + +!deviation from rad-like reheating: lnRrad = lnR - 1/4 ln(rhoend) + real(kp) :: lnRrad + + real(kp) :: wreh, p, thirdminusw + real(kp) :: ThirdMinusWlnEnergyEndReh, lnEnergyEndReh + +!kappaeff^4 x rhonuc with rhonuc~10MeV +!energyNuc = 2.9d-82 +! real(kp), parameter :: lnEnergyNuc = -187.747 + real(kp), parameter :: lnEnergyNuc = lnRhoNuc + + real(kp), dimension(fieldNum) :: velocityEnd, fieldEnd + + fieldEnd = bgEnd%field + velocityEnd = bgEnd%fieldDot*bgEnd%hubble + +!if epsilon1=1 at the end of inflation, it should be Hend^2/3 (for one +!field models) + + lnEnergyEndInf = log(matter_energy_density(fieldEnd,velocityEnd)) + +!comes from -1/3 rhonuc + + lnReheatMax = (1._kp/12._kp)* (-lnEnergyNuc) & + - (1._kp/3._kp) * (-lnEnergyEndInf) + + lnReheatMin = - (1._kp/4._kp)* (-lnEnergyNuc) + + + set_inftorad_cosmo%lnEnergyEnd = lnEnergyEndInf + set_inftorad_cosmo%bfoldIni = bgIni%efold - bgEnd%efold + set_inftorad_cosmo%bfoldEnd = 0._kp + + set_inftorad_cosmo%efoldEndToToday = - ln_scale_factor_scale_inv(lnEnergyEndInf) & + - lnReheat + +!TODELETE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! set_inftorad_cosmo%efoldEndToToday = 60._kp +! write(*,*)'efoldEndToToday fixed to: ',set_inftorad_cosmo%efoldEndToToday +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + set_inftorad_cosmo%bgIni = bgIni + set_inftorad_cosmo%bgEnd = bgEnd + + +!hard priors: inflation should occur at energy scale higher than bbn, +!as well as reheating + if (lnEnergyEndInf.le.lnEnergyNuc) then + write(*,*)'set_inftorad_cosmo: inflation till bbn (111)' + if (display) then + write(*,*)'lnEnergyEndInf = ',lnEnergyEndInf + write(*,*)'lnEnergyNucSynth = ',lnEnergyNuc + endif + if (present(inferror)) then + inferror = 111 + return + else + stop + endif + endif + + if (lnReheat.gt.lnReheatMax) then + write(*,*)'set_inftorad_cosmo: higher reheating limit reached (w=1 rho=bbn) (112)' + write(*,*)'lnReheat = ',lnReheat + write(*,*)'lnReheatMax= ',lnReheatMax + if (present(inferror)) then + inferror = 112 + return + else + stop + endif + endif + + if (lnReheat.lt.lnReheatMin) then + write(*,*)'set_inftorad_cosmo: lower reheating limit reached (w=-1/3 rho=bbn) (113)' + write(*,*)'lnReheat = ',lnReheat + write(*,*)'lnReheatMin = ',lnReheatMin + if (present(inferror)) then + inferror = 113 + return + else + stop + endif + endif + + if (LargeFieldWreh) then + + if (bgParam%name.ne.'largef') then + stop 'set_inftorad_cosmo: incompatible models in inftorad!' + endif + + p = bgParam%consts(2) + if (p.gt.1) then + wreh = (p-2._kp)/(p+2._kp) + thirdminusw = 1._kp/3._kp - wreh + else + stop 'set_inftorad_cosmo: reheating cannot be parametric when p<1' + endif + + write(*,*)'set_inftorad_cosmo: enforcing wreh = (p-2)/(p+2) =',wreh + +!reheating is radiation + if (thirdminusw.eq.0._kp) then + write(*,*)'set_inftorad_cosmo: reheating is radiation: no constraint' + return + endif + + lnRrad = lnReheat - 0.25_kp*lnEnergyEndInf + + thirdMinusWlnEnergyEndReh = thirdminusw_ln_energy_endreh(lnRrad,lnEnergyEndInf,wreh) + lnEnergyEndReh = thirdMinusWlnEnergyEndReh/thirdminusw + + if (lnEnergyEndReh.gt.lnEnergyEndInf) then + write(*,*)'set_inftorad_cosmo: higher cte reheating limit reached (rho=rhoinf) (114)' + write(*,*)'lnRhoEndReh = ',lnEnergyEndReh + write(*,*)'lnRhoEndInf = ',lnEnergyEndInf + if (present(inferror)) then + inferror = 114 + return + else + stop + endif + endif + + if (lnEnergyEndReh.lt.lnEnergyNuc) then + write(*,*)'set_inftorad_cosmo: lower cte reheating limit reached (rho=bbn) (115)' + write(*,*)'lnRhoEndReh = ',lnEnergyEndReh + write(*,*)'lnRhoNuc = ',lnEnergyNuc + if (present(inferror)) then + inferror = 115 + return + else + stop + endif + endif + + endif + + + + + if (display) then + write(*,*)'--------------- set_inftorad_cosmo ---------------' + write(*,*) + write(*,*)'a0 = ',scaleFactorToday + write(*,*)'bfoldIni = ',set_inftorad_cosmo%bfoldIni + write(*,*)'bfoldEnd = ',set_inftorad_cosmo%bfoldEnd + write(*,*)'efoldIni = ',set_inftorad_cosmo%bgIni%efold + write(*,*)'efoldEnd = ',set_inftorad_cosmo%bgEnd%efold + write(*,*)'lnReheatMin = ',lnReheatMin + write(*,*)'lnReheat = ',lnReheat + write(*,*)'lnReheatMax = ',lnReheatMax + write(*,*) + if (largeFieldWreh) then + write(*,*)'wreh = ',wreh + write(*,*) 'ln(EnergyEndReh)',lnEnergyEndReh/4 + endif + write(*,*)'ln(EnergyEndInf) = ',lnEnergyEndInf/4 + write(*,*)'ln(EnergyNuc) = ',lnEnergyNuc/4 + write(*,*) + write(*,*)'efoldEndToToday = ',set_inftorad_cosmo%efoldEndToToday + write(*,*)'ln[1Mpc/kappaeff] = ',lnMpcToKappa + write(*,*) + write(*,*)'fieldEnd = ',set_inftorad_cosmo%bgEnd%field + write(*,*) + write(*,*)'energyEnd^1/2 = ',exp(0.5*set_inftorad_cosmo%lnEnergyEnd) + write(*,*)'hubbleEnd.3^1/2 = ',sqrt(3.)*set_inftorad_cosmo%bgEnd%hubble + write(*,*) + write(*,*)'-------------------------------------------------' + endif + + + end function set_inftorad_cosmo + + + + + function ln_scale_factor_eq() +!all in unit of kappa = sqrt(8pi)/Mpl. H0 et OmegaRad are fixed since +!the incertainties on their measured values is irrelevant compared to +!inflationary params. They can be added in the chains but this would +!render all prim parameters as "slow" in cosmocmc. + + implicit none + + real(kp) :: ln_scale_factor_eq + +! real(kp), parameter :: HubbleSquareRootOf2OmegaRad = 8.00d-63 !x kappaendinf(#kappatoday) + + +!this is: 1/4 ln(rhoeq) + ln(aeq/a0) +! = (1/4) ln(rhoeq) - ln(1+zeq) +! = -(1/4) ln(2/3) + (1/2) ln[Heq/(1+zeq)^2] +! where used has been made of: rhoeq = (3/2) Heq^2 (in kappa unit) +! +! Heq/(1+zeq)^2 = sqrt(2 Omega0) H0 / sqrt(1+zeq) +! 1+zeq = Omega0/OmegaRadiation0 <---- photons + neutrinos +! H0 = 100h km/s/Mpc = 1.74717d-61 Mpl +! There is no dependency in h and Omega0 in Heq/(1+zeq)^2 = sqrt(2 OmegaRad0) H0 (x kappatoday) + + ln_scale_factor_eq = log(scaleFactorToday) & + + 0.5_kp*log(HubbleSquareRootOf2OmegaRad) & + - 0.25_kp*log(2._kp/3._kp) + + end function ln_scale_factor_eq + + + + + + function ln_scale_factor_scale_inv(lnEnergyEndInf) +!this is ln(aend/a0) when R=1 +!in that case we have: +! ln(aend/a0) = +! ln(aend/areh) - 1/4 ln(rhoreh) + 1/2 ln(rhoend) <--lnReheat +! + ln(aeq/a0) + 1/4 ln(rhoeq) - 1/2 ln(rhoend) <-- ln_scale_inv + + implicit none + real(kp), intent(in) :: lnEnergyEndInf + real(kp) :: ln_scale_factor_scale_inv + + + ln_scale_factor_scale_inv = ln_scale_factor_eq() - 0.5_kp*lnEnergyEndInf + + end function ln_scale_factor_scale_inv + + + + + + + function ln_scale_factor_radreheat(lnEnergyEndInf) +!This is ln(aend/a0) for Rrad=1. Rough approximation of the physical +!scale factor at the end of inflation. Assumes instantenous reheating +!and instantenous transitions, all in unit of kappa = +!sqrt(8pi)/Mpl. The input is supposed to be the energy transfered +!after inflation to the "matter sector", in our case this is the +!energy density of the matter field at the end of inflation. This +!assumes pure GR after the end of inflation. + + implicit none + + real(kp), intent(in) :: lnEnergyEndInf + real(kp) :: ln_scale_factor_radreheat + +! ln(aend/a0) = ln(aend/areh) + ln(areh/aeq) + ln(aeq/a0) +! ~ (1/4) ln(rhoeq/rhoend) - ln(1+zeq) +! = -(1/4) ln(2rhoend/3) + (1/2) ln[Heq/(1+zeq)^2] +! where used has been made of: rhoeq = (3/2) Heq^2 (in kappa unit) +! +! Heq/(1+zeq)^2 = sqrt(2 Omega0) H0 / sqrt(1+zeq) +! 1+zeq = Omega0/OmegaRadiation0 <---- photons + neutrinos +! H0 = 100h km/s/Mpc = 1.74717d-61 Mpl +! There is no dependency in h and Omega0 in Heq/(1+zeq)^2 = sqrt(2 OmegaRad0) H0 (x kappatoday) + + ln_scale_factor_radreheat = ln_scale_factor_eq() - 0.25_kp*lnEnergyEndInf + + end function ln_scale_factor_radreheat + + + + function ln_scale_factor_corr_radreheat(lnEnergyEndInf,lnEnergyEndReh,wreh) +!This is ln(Rrad): the correction from a rad-like reheating period +!when during reheating one has P=wre x rho, with wre a constant + +! ln(aend/areh) + (1/4) ln(rhoend/rhoreheat) = (1/4) x +! (w-1/3)/(w+1) x ln(rhoend/rhoreheat) + + implicit none + + real(kp), intent(in) :: lnEnergyEndInf, lnEnergyEndReh, wreh + real(kp) :: ln_scale_factor_corr_radreheat + + ln_scale_factor_corr_radreheat = 0.25_kp * (wreh - 1._kp/3._kp)/(wreh + 1._kp) & + * (lnEnergyEndInf - lnEnergyEndReh) + + end function ln_scale_factor_corr_radreheat + + + + + + function thirdminusw_ln_energy_endreh(lnRrad,lnEnergyEndInf,wreh) +!This is the inverse function. It gives (1/3 -w) ln(rhoreh) as a function of ln(Rrad) and ln(rhoend) + implicit none + + real(kp), intent(in) :: lnRrad,lnEnergyEndinf,wreh + real(kp) :: thirdminusw_ln_energy_endreh + + thirdminusw_ln_energy_endreh = 4._kp*(1._kp+wreh)*lnRrad + (1._kp/3._kp-wreh)*lnEnergyEndInf + + end function thirdminusw_ln_energy_endreh + + + + + + + function bfold_plus_ln_hubble(bfold,cosmoData) +!returns N + ln[H(N)] - cosmoData%real1, required by zeros finder subroutine: +!zbrent + use infprec, only : transfert + use infbgspline, only : splineval_hubble_parameter + implicit none + + type(transfert), optional, intent(inout) :: cosmoData + real(kp), intent(in) :: bfold + real(kp) :: bfold_plus_ln_hubble + + real(kp) :: hubble + + hubble = splineval_hubble_parameter(bfold) + + bfold_plus_ln_hubble = bfold + log(hubble) - cosmoData%real1 + +! print *,'bfold',bfold,bfold_plus_ln_hubble,cosmoData%real1 +! print *,'hubble^2',hubble**2 + + end function bfold_plus_ln_hubble + + + + + + + function bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubble,inferror) +!return the bfold at which k/aH = kphysOverHubble + use inftools, only : zbrent + use infprec, only : transfert + implicit none + real(kp), intent(in) :: kmpc + real(kp), intent(inout) :: kphysOverHubble + type(inftoradcosmo), intent(in) :: infCosmo + real(kp) :: bfold_hubble_fraction + +!hard prior if quantum ic cannot be set + integer, optional :: inferror + + type(transfert) :: cosmoData + real(kp), parameter :: tolBfold = 1e-6 + real(kp) :: bfoldSign + + + cosmoData%real1 = log(kmpc) + infCosmo%efoldEndToToday - lnMpcToKappa & + - log(kphysOverHubble) + + bfoldSign = bfold_plus_ln_hubble(infCosmo%bfoldIni,cosmoData) + + if (bfoldSign.ge.0d0) then + write(*,*)'no crossing found (444) for mode k = ',kmpc, 'at k/aH = ' & + ,kphysOverHubble + write(*,*)'bfoldIni = ',infCosmo%bfoldIni + if (present(inferror)) then + inferror = 222 + return + else + if (bfoldSign.lt.log(kphysOverHubble)) then + write(*,*)'setting initial condition at bfoldIni' + write(*,*)'ln(k/aH) = ', -bfoldSign + log(kphysOverHubble) + kphysOverHubble = exp(-bfoldSign) * kphysOverHubble + bfold_hubble_fraction = infCosmo%bfoldIni + return + else + stop + endif + endif + endif + + bfold_hubble_fraction = zbrent(bfold_plus_ln_hubble,infCosmo%bfoldIni & + , infCosmo%bfoldEnd ,tolBfold, cosmoData) + + + end function bfold_hubble_fraction + + + + + function hubble_splinexit(infCosmo,kmpc) +!spline evaluation of physical quantities at hubble exit (k/aH=1) for the mode kmpc + use infinout + use infbgspline, only : splineval_hubble_parameter + use infbgspline, only : splineval_epsilon1 + use infbgspline, only : splineval_epsilon1JF + implicit none + + real(kp), intent(in) :: kmpc + type(infhubblexit) :: hubble_splinexit + type(inftoradcosmo) :: infCosmo + real(kp) :: bfoldExit, hubbleExit + real(kp) :: epsilon1Exit, epsilon1JFExit + real(kp) :: kphysOverHubbleExit + real(kp) :: pi + + pi = acos(-1._kp) + kphysOverHubbleExit = 1._kp + + bfoldExit = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleExit) + hubbleExit = splineval_hubble_parameter(bfoldExit) + epsilon1Exit = splineval_epsilon1(bfoldExit) + epsilon1JFExit = splineval_epsilon1JF(bfoldExit) + + if (display) then +!this is the tensor spectrum, up to a negligeable relaxation after Hubble exit + write(*,*) + write(*,*)'kmpc = ',kmpc + write(*,*)'hubble crossing at bfold = ',bfoldExit + write(*,*)'2(Hk/pi)^2 = ',(2._kp/pi/pi)*hubbleExit**2 + write(*,*)'epsilon1 = ',epsilon1Exit + write(*,*)'epsilon1JF = ',epsilon1JFExit + write(*,*) + endif + + if (dump_file) then + call livewrite('hubblexit.dat',kmpc,(2._kp/pi/pi)*hubbleExit**2) + call livewrite('epsilonexit.dat',kmpc,epsilon1Exit,epsilon1JFExit) + call livewrite('bfoldexit.dat',kmpc,bfoldExit) + endif + + hubble_splinexit%kmpc = kmpc + hubble_splinexit%bfold = bfoldExit + hubble_splinexit%hubble = hubbleExit + hubble_splinexit%epsilon1 = epsilon1Exit + hubble_splinexit%epsilon1 = epsilon1JFExit + + end function hubble_splinexit + + +end module inftorad diff --git a/fieldinf/power_inf.f90 b/fieldinf/power_inf.f90 new file mode 100644 index 0000000..5322b8f --- /dev/null +++ b/fieldinf/power_inf.f90 @@ -0,0 +1,948 @@ +!This module provides the initial power spectra, computed from the inflationary module + +module InitialPower + use precision, only : dl + use infprec, only : kp + use infbgmodel, only : infbgparam + use infbg, only : infbgphys, infbgdata + use inftorad, only : inftoradcosmo + + implicit none + + private + + logical, parameter :: display=.false. + + character(LEN=*), parameter :: Power_Name = 'power_inf' + integer, parameter :: nnmax= 1 + +!mind that for mcmc + logical, parameter :: checkStopDefault = .false. + logical, parameter :: checkBoundDefault = .false. + logical, parameter :: useSplineDefault = .true. + + + type InitialPowerParams + integer :: nn + integer :: bgParamNum + logical :: checkStop + logical :: checkBound + logical :: useSpline + integer :: lnkmpcNum + real(kp) :: lnkmpcMax, lnkmpcMin + real(kp) :: lnReheat + real(kp) :: kstar + type(infbgparam) :: infParam + end type InitialPowerParams + + + type InitialPowerData + type(initialpowerparams) :: initP + type(infbgphys) :: infIni + type(infbgphys) :: infObs + type(infbgphys) :: infEnd + type(inftoradcosmo) :: infCosmo + type(infbgdata), pointer :: ptrBgdata => null() + end type InitialPowerData + + + type ExportInfProp + real(kp) :: lnEnergyEnd + real(kp) :: efoldEndToToday + end type ExportInfProp + + + real(dl) :: curv !Curvature contant, set in InitializePowers + + + + type(InitialPowerData), save :: powerD + + + + + interface operator (==) + module procedure inipowerparams_equal + end interface + + interface operator (/=) + module procedure inipowerparams_unequal + end interface + + private operator(==),operator(/=) + + public nnmax + public SetInfBg, SetInfBgSpline, SetInfCosmo, SetInfScalPow + public InitializePowers, FreePowers, ScalarPower, TensorPower + public InitialPowerParams,Power_Descript, Power_Name, SetDefPowerParams + + public exportinfprop, UpdateInfProp + + public InitialPower_ReadParams + +contains + + + + + + function inipowerparams_equal(PinA, PinB) + use infbgmodel, only : operator(==) + implicit none + type(initialpowerparams), intent(in) :: PinA, PinB + logical :: inipowerparams_equal + + inipowerparams_equal = ((PinA%infParam == PinB%infParam) & + .and. (PinA%lnReheat == PinB%lnReheat) & + .and. (PinA%nn == PinB%nn) & + .and. (PinA%bgParamNum == PinB%bgParamNum) & + .and. (PinA%checkStop .eqv. PinB%checkStop) & + .and. (PinA%checkBound .eqv. PinB%checkBound) & + .and. (PinA%useSpline .eqv. PinB%useSpline) & + .and. (PinA%lnkmpcNum == PinB%lnkmpcNum) & + .and. (PinA%lnkmpcMax == PinB%lnkmpcMax) & + .and. (PinA%lnkmpcMin == PinB%lnkmpcMin)) + + end function inipowerparams_equal + + + + + function inipowerparams_unequal(PinA, PinB) + implicit none + type(initialpowerparams), intent(in) :: PinA, PinB + logical :: inipowerparams_unequal + + inipowerparams_unequal = .not.(inipowerparams_equal(PinA,PinB)) + + end function inipowerparams_unequal + + + + + subroutine UpdateInfProp(export) + implicit none + type(exportinfprop), intent(out) :: export + + export%lnEnergyEnd = powerD%infCosmo%lnEnergyEnd + export%efoldEndToToday = powerD%infCosmo%efoldEndToToday + + end subroutine UpdateInfProp + + + + + + subroutine SetDefPowerParams(Pin) + use infbgmodel, only : fieldNum, dilatonNum + use infbgmodel, only : matterParamNum, dilatonParamNum + use infbgmodel, only : infParamNum + implicit none + type (InitialPowerParams), intent(out) :: Pin + + Pin%nn = 1 + + Pin%bgParamNum = matterParamNum + dilatonParamNum + +!stop inflation according to field values + Pin%checkStop = checkStopDefault + +!impose hard prior from theoretical bounds on field values + Pin%checkBound = checkBoundDefault + +!range and sampling of the power spectra spline + Pin%useSpline = useSplineDefault + Pin%lnkmpcMin = -14. + Pin%lnkmpcMax = 0. + Pin%lnkmpcNum = 12 + + Pin%lnReheat = 0. + Pin%kstar = 0.05 + +!value for the parameters (see infbg.f90) + Pin%infParam%name = 'largef' + Pin%infParam%consts(1:infParamNum) = 0. + Pin%infParam%conforms(1:dilatonNum) = 1. + + Pin%infParam%consts(1) = 1e-5 + Pin%infParam%consts(2) = 2. + Pin%infParam%consts(3:4) = 0. + Pin%infParam%consts(5) = 1. + + if (infParamNum.gt.5) then + Pin%infParam%consts(6:infParamNum) = 0. + endif + + end subroutine SetDefPowerParams + + + + + subroutine InitializePowers(Pin,acurv,wantScalars,wantTensors) + implicit none + + type (initialpowerparams) :: Pin + !Called before computing final Cls in cmbmain.f90 + !Could read spectra from disk here, do other processing, etc. + real(dl) :: acurv + logical, optional, intent(in) :: wantScalars, wantTensors + integer :: inferror + logical, parameter :: usePstar=.false. + real(kp), parameter :: Pstar = 1._kp + + inferror = 0 + + if (Pin%nn > nnmax) then + stop 'can only used one initial power spectrum' + end if + curv=acurv + + if (curv.ne.0d0) stop 'flat universe only' + +!one background for all k (that's why nnmax=1) +! print *,'we are in initialize power',(Pin%infParam == powerD%initP%infParam) & +! ,(Pin%infParam /= powerD%initP%infParam) + + call SetInfBg(Pin,inferror) + if (inferror.ne.0) stop 'InitializePowers: unproper infbg' + + if (usePstar) then +!this is only for playing with normalised power spectra to Pstar. + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'InitializePower: renormalising P(k*) to Pstar=',Pstar + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + read(*,*) + call SetInfScalPow(Pin,Pstar) + endif + + call SetInfBgSpline(Pin) + + call SetInfCosmo(Pin,inferror) + if (inferror.ne.0) stop 'InitializePowers: unproper inftorad' + + end subroutine InitializePowers + + + + + subroutine SetInfBg(Pin,inferror) + use infbgmodel, only : operator(==) + use infbgmodel, only : set_infbg_param, matterNum + use infsrmodel, only : field_stopinf + use infbg, only : operator(==) + use infbg, only : set_infbg_ini, bg_field_evol + implicit none + + type (initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + logical :: areTryParamsOk, areInfIniOk, isThBoundOk + logical :: areParamsSet + integer, parameter :: infbgPoints = 1000 + type(initialpowerparams) :: Pstack + real(kp), dimension(2) :: fieldStop + logical :: stopAtMax + +! print *,'Pin',Pin + if (associated(powerD%ptrBgdata)) then + if (Pin%infParam == powerD%initP%infParam) then + if (display) then + write(*,*)'SetInfBg: same infbg params' + write(*,*)'Pin%infParam= ',Pin%infParam + endif + return + else + if (display) then + write(*,*)'SetInfBg: new infbgparams' + write(*,*)'Pin%infParam= ',Pin%infParam + endif + Pstack = powerD%initP + call FreePowers(Pstack) + endif + endif + +!hard prior tests on the parameters + areTryParamsOk = HardPriorAcceptParam(Pin%infParam,inferror) + if (.not.areTryParamsOk) then + if (present(inferror).and.display) write(*,*)'SetInfBg: inferror ',inferror + return + endif + + +!update powerD%initP according to Pin (may be modified in) + areParamsSet = set_infbg_param(Pin%infParam) + powerD%initP = Pin + if (.not.(areParamsSet)) then + stop 'SetInfBg: params initialisation failed!' + endif + + powerD%infIni = set_infbg_ini(Pin%infParam) + + + +!hard prior tests on the initial field values + areInfIniOk = HardPriorAcceptInfIni(powerD%infIni,inferror) + if (.not.areInfIniOk) then + if (present(inferror).and.display) write(*,*)'SetInfBg: inferror ',inferror + powerD%infEnd = powerD%infIni + return + endif + + + +!hard prior tests for theoretical bound on initial field values + if (powerD%initP%checkBound) then + + isThBoundOk = HardPriorInThBound(powerD%initP%infParam & + ,powerD%infIni,inferror) + + if (.not.isThBoundOk) then + powerD%infEnd = powerD%infIni + if (present(inferror).and.display) write(*,*)'SetInfBg: inferror ',inferror + return + endif + + endif + + + if (powerD%initP%checkStop) then + fieldStop = field_stopinf(powerD%initP%infParam) + if (fieldStop(2).gt.0._kp) then + stopAtMax = .true. + else + stopAtMax = .false. + endif + + powerD%infEnd = bg_field_evol(powerD%infIni,infbgPoints & + ,powerD%infObs,powerD%ptrBgdata,fieldStop(1),stopAtMax) + else + + powerD%infEnd = bg_field_evol(powerD%infIni,infbgPoints & + ,powerD%infObs,powerD%ptrBgdata) + + endif + +!last hard prior: the number of efolds is not enough + if (powerD%infEnd == powerD%infIni) then + if (display) write(*,*)'SetInfBg: infEnd = infIni (4444)' + if (present(inferror)) inferror = 4444 + return + endif + + + end subroutine SetInfBg + + + + function HardPriorAcceptParam(infParam,inferror) + use infbgmodel, only : matterParamNum + implicit none + logical :: HardPriorAcceptParam + type(infbgparam), intent(in) :: infParam + integer, optional :: inferror + + HardPriorAcceptParam = .true. + +!if during mcmc, consts(4)=0 is unprobably tested (singular for this value) + if (infParam%name=='runmas') then + if (infParam%consts(4).eq.0._kp) then + if (display) then + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'HardPriorAcceptParam: infParam%consts(4)=0 (1111)' + write(*,*)'for running mass model!' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + endif + if (present(inferror)) inferror = 1111 + HardPriorAcceptParam=.false. + endif + endif + + if (infParam%name=='kklmmt') then + if (infParam%consts(matterParamNum).lt.infParam%consts(3)) then + if (display) write(*,*)'HardPriorAcceptParam: MatterString < mu (1112)' + if (present(inferror)) inferror = 1112 + HardPriorAcceptParam=.false. + endif + endif + + + end function HardPriorAcceptParam + + + + function HardPriorAcceptInfIni(infIni,inferror) + implicit none + logical :: HardPriorAcceptInfIni + type(infbgphys), intent(in) :: infIni + integer, optional :: inferror + + HardPriorAcceptInfIni=.true. + + if (infIni%epsilon1.gt.1._kp) then + if (display) write(*,*) 'HardPriorAcceptInfIni: epsilon1 > 1 (2222) ' + if (present(inferror)) inferror = 2222 + HardPriorAcceptInfIni = .false. + endif + + end function HardPriorAcceptInfIni + + + + + function HardPriorInThBound(infParam,infIni,inferror) + use infbgmodel, only : matterNum + use infsrmodel, only : field_thbound + implicit none + logical :: HardPriorInThBound + type(infbgparam), intent(in) :: infParam + type(infbgphys), intent(in) :: infIni + integer, optional :: inferror + + real(kp), dimension(2) :: fieldBound + + HardPriorInThBound = .true. + + fieldBound = field_thbound(infParam) + if (fieldBound(2).gt.0._kp) then + HardPriorInThBound = (maxval(infIni%field(1:matterNum)) & + .lt.fieldBound(1)) + else + HardPriorInThBound = (minval(infIni%field(1:matterNum)) & + .lt.fieldBound(1)) + endif + + if (.not.HardPriorInthBound) then + if (display) write(*,*) 'HardPriorInThBound: bound violated (3333)' + if (present(inferror)) inferror = 3333 + endif + + end function HardPriorInThBound + + + + + subroutine SetInfBgSpline(Pin) + use infbgmodel, only : operator(==) + use infbgspline, only : set_infbg_spline,check_infbg_spline + implicit none + + type (initialpowerparams), intent(in) :: Pin + + if (check_infbg_spline()) return + +!sanity checks + if (Pin%infParam == powerD%initP%infParam) then + call set_infbg_spline(powerD%infEnd,powerD%ptrBgdata) + else + stop 'SetInfBgSpline: Pin%params >< Data params' + endif + + end subroutine SetInfBgSpline + + + + + + subroutine FreeInfBgSpline(Pin) + use infbgmodel, only : operator(==) + use infbgspline, only : free_infbg_spline, check_infbg_spline + implicit none + + type (initialpowerparams), intent(in) :: Pin + + if (.not. check_infbg_spline()) return + +!sanity checks + if (Pin%infParam == powerD%initP%infParam) then + call free_infbg_spline() + else + stop 'FreeInfBgSpline: Pin%params >< Data params' + endif + + end subroutine FreeInfBgSpline + + + + + + subroutine FreeInfBgData(Pin) + use infbgmodel, only : operator(==) + use infbg, only : free_infbg_data + implicit none + + type (initialpowerparams), intent(in) :: Pin + + if (.not.associated(powerD%ptrBgdata)) stop 'FreeInfBgData: no bgdata found!' + +!sanity checks + if (Pin%infParam == powerD%initP%infParam) then + call free_infbg_data(powerD%ptrBgdata) + else + stop 'FreeInfBgData: Pin%params >< Data params' + endif + + end subroutine FreeInfBgData + + + + + + subroutine SetInfCosmo(Pin,inferror) + use infbgmodel, only : operator(/=) + use inftorad, only : set_inftorad_cosmo + use infpowspline, only : check_power_scal_spline, check_power_tens_spline + + implicit none + + type (initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + +!sanity checks + if (Pin%infParam /= powerD%initP%infParam) then + stop 'SetInfCosmo: Pin%params >< Data params' + endif + + + if (Pin /= powerD%initP) then + if (Pin%useSpline) call FreePowSpline(Pin) + if (display) then + write(*,*)'SetInfCosmo: new inftorad params' + write(*,*)'lnReheat = ',Pin%lnReheat + endif + powerD%initP = Pin + else + if (display) then + write(*,*)'SetInfCosmo: same inftorad params' + write(*,*)'lnReheat = ',Pin%lnReheat + endif + endif + + powerD%infCosmo = set_inftorad_cosmo(powerD%initP%infParam & + ,powerD%infObs,powerD%infEnd,powerD%InitP%lnReheat,inferror) + + if (present(inferror)) then + if (inferror.ne.0) return + endif + + if (Pin%useSpline) then + call SetScalPowSpline(Pin,inferror) + call SetTensPowSpline(Pin,inferror) + endif + + end subroutine SetInfCosmo + + + + + + subroutine SetTensPowSpline(Pin,inferror) + use inftorad, only : bfold_hubble_fraction + use infpowspline, only : set_power_tens_spline + use infpowspline, only : check_power_tens_spline + implicit none + type(initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcKnots + + if (check_power_tens_spline()) return + + call IniPowSpline(Pin,lnkmpcKnots,inferror) + + if (present(inferror)) then + if (inferror.ne.0) return + endif + + call set_power_tens_spline(powerD%infCosmo,lnkmpcKnots) + +! if (present(inferror)) inferror = 0 + + end subroutine SetTensPowSpline + + + + + + subroutine SetScalPowSpline(Pin,inferror) + use infpowspline, only : set_power_scal_spline + use infpowspline, only : check_power_scal_spline + implicit none + type(initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcKnots + + if (check_power_scal_spline()) return + + call IniPowSpline(Pin,lnkmpcKnots,inferror) + + if (present(inferror)) then + if (inferror.ne.0) return + endif + + call set_power_scal_spline(powerD%infCosmo,lnkmpcKnots) + + end subroutine SetScalPowSpline + + + + + + + subroutine IniPowSpline(Pin,lnkmpcVec,inferror) + use inftorad, only : bfold_hubble_fraction + implicit none + type(initialpowerparams), intent(in) :: Pin + real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcVec + integer, optional :: inferror + + integer :: i + real(kp) :: kmpcMin, bfoldSmallest + real(kp) :: kphysOverHubbleInit + + kphysOverHubbleInit = 100._kp + + !sanity checks + if (.not.associated(powerD%ptrBgdata)) then + stop 'SetInfPowSpline: no InfBg found, call SetInfBg before!' + else + if (Pin /= powerD%initP) then + write(*,*)'SetInfPowSpline: Pin >< Data' + stop + endif + endif + if (.not.Pin%useSpline) stop 'SetInfPowSpline: useSpline is F' + + do i=1,powerD%initP%lnkmpcNum + lnkmpcVec(i) = powerD%initP%lnkmpcMin + real(i-1)*(powerD%initP%lnkmpcMax & + - powerD%initP%lnkmpcMin)/real(powerD%initP%lnkmpcNum-1) + enddo + +!this test that initial conditions at kphysOverHubbleInit can be set, +!or in other words that there are enough efold to do it + if (present(inferror)) then + kmpcMin = exp(powerD%InitP%lnkmpcMin) + bfoldSmallest = bfold_hubble_fraction(kmpcMin,powerD%infCosmo & + ,kphysOverHubbleInit,inferror) + endif + + end subroutine IniPowSpline + + + + + + subroutine FreePowSpline(Pin) + use infpowspline, only : check_power_scal_spline + use infpowspline, only : check_power_tens_spline + use infpowspline, only : free_power_scal_spline + use infpowspline, only : free_power_tens_spline + implicit none + type(initialpowerparams), intent(in) :: Pin + + if (Pin%useSPline) then + if (check_power_scal_spline()) call free_power_scal_spline() + if (check_power_tens_spline()) call free_power_tens_spline() + else + stop 'FreePowSpline: useSpline is false!' + endif + + end subroutine FreePowSpline + + + + + + subroutine SetInfScalPow(Pin,Pwanted) +!to normalise the scalar spectrum to Pwanted at kpivot + use infbgmodel, only : operator(/=) + use infbg, only : rescale_potential + use inftorad, only : set_inftorad_cosmo + use infpert, only : scalNum + use infpert, only : power_spectrum_scal + implicit none + + type (initialpowerparams), intent(inout) :: Pin + real(kp), intent(in) :: Pwanted + + real(kp) :: scale + real(kp) :: Pscal(scalNum,scalNum) + + integer :: ierror + +!sanity checks + if (Pin%infParam /= powerD%initP%infParam) then + stop 'SetInfScalPow: Pin%params >< Data params' + endif + + powerD%infCosmo = set_inftorad_cosmo(powerD%initP%infParam, & + powerD%infObs,powerD%infEnd,powerD%InitP%lnReheat,ierror) + +!the bg spline should be set to compute the power spectrum (if not +!already) TODO: not optimal at all + call SetInfBgSpline(Pin) + + Pscal = power_spectrum_scal(powerD%infCosmo,Pin%kstar) + + if (Pscal(scalNum,scalNum).ne.0.) then + scale = Pwanted/Pscal(scalNum,scalNum) + else + stop 'SetInfScalPow: Pscal = 0' + endif + +!rescale all the relevant quantities. After this call, everything +!should be as if the potential has been normalised according to Pwanted + call rescale_potential(scale,powerD%initP%infParam,powerD%infIni & + ,powerD%infEnd,powerD%infObs,powerD%ptrBgdata) + +!update the external infParam + Pin%infParam = powerD%initP%infParam + +!but the background spline is not longer up to date + call FreeInfBgSpline(Pin) + + +!for debugging only + if (display) then + write(*,*) + write(*,*)'SetInfScalPow:' + write(*,*)'Pwanted = ',Pwanted + write(*,*)'Pnow = ',Pscal(scalNum,scalNum) + call SetInfBgSpline(Pin) + powerD%infCosmo = set_inftorad_cosmo(powerD%InitP%infParam & + ,powerD%infObs,powerD%infEnd,powerD%InitP%lnReheat,ierror) + Pscal = power_spectrum_scal(powerD%infCosmo,Pin%kstar) + call FreeInfBgSpline(Pin) + write(*,*)'Pafter = ',Pscal(scalNum,scalNum) + write(*,*) + endif + + + end subroutine SetInfScalPow + + + + + + subroutine FreePowers(Pin) + use infbgmodel, only : operator(==) + implicit none + type(initialpowerparams), intent(in) :: Pin + + if (.not.associated(powerD%ptrBgdata)) then + write(*,*) 'FreePowers: powerD%ptrBgdata not associated!' + return + endif + + if (Pin%infParam == powerD%initP%infParam) then + if (display) write(*,*) 'FreePowers: freeing infbg spline' + call FreeInfBgSpline(Pin) + + if (display) write(*,*) 'FreePowers: freeing infbg data' + call FreeInfBgData(Pin) + + if (powerD%initP%useSpline) then + if (display) write(*,*) 'FreePowers: freeing powspline data' + call FreePowSpline(Pin) + endif + else + write(*,*) + write(*,*) 'FreePowers: Pin <> Data' + write(*,*) 'FreePowers: Pin%Param = ',Pin%infParam + write(*,*) 'FreePowers: Data%Param = ',powerD%initP%infParam + write(*,*) + stop + endif + + end subroutine FreePowers + + + + + + + function ScalarPower(k,in) +!"in" gives the index of the power to return for this k +!ScalarPower = const for scale invariant spectrum +!The normalization is defined so that for adiabatic perturbations the gradient of the 3-Ricci +!scalar on co-moving hypersurfaces receives power +! < |D_a R^{(3)}|^2 > = int dk/k 16 k^6/S^6 (1-3K/k^2)^2 ScalarPower(k) +!In other words ScalarPower is the power spectrum of the conserved curvature perturbation given by +!-chi = \Phi + 2/3*\Omega^{-1} \frac{H^{-1}\Phi' - \Psi}{1+w} +!(w=p/\rho), so < |\chi(x)|^2 > = \int dk/k ScalarPower(k). +!Near the end of inflation chi is equal to 3/2 Psi. +!Here nu^2 = (k^2 + curv)/|curv| + +!This power spectrum is also used for isocurvature modes where +!< |\Delta(x)|^2 > = \int dk/k ScalarPower(k) +!For the isocurvture velocity mode ScalarPower is the power in the neutrino heat flux. + use infpert, only : power_spectrum_scal + use infpert, only : scalNum + use infpowspline, only : splineval_power_scal + implicit none + + real(kp), dimension(scalNum,scalNum) :: powerSpectrumScal + real(dl) :: ScalarPower,k + integer :: in + + if (in.ne.1) stop 'ScalarPower: only 1 Ps allowed' + + if (powerD%initP%useSpline) then + powerSpectrumScal = splineval_power_scal(k*1._kp) + else + powerSpectrumScal = power_spectrum_scal(powerD%infCosmo,k*1._kp) + endif + + ScalarPower = powerSpectrumScal(scalNum,scalNum) + + end function ScalarPower + + + + + + function TensorPower(k,in) +!TensorPower= const for scale invariant spectrum +!The normalization is defined so that +! < h_{ij}(x) h^{ij}(x) > = \sum_nu nu /(nu^2-1) (nu^2-4)/nu^2 TensorPower(k) +!for a closed model +! < h_{ij}(x) h^{ij}(x) > = int d nu /(nu^2+1) (nu^2+4)/nu^2 TensorPower(k) +!for an open model +!"in" gives the index of the power spectrum to return +!Here nu^2 = (k^2 + 3*curv)/|curv| + use infpert, only : power_spectrum_tens + use infpowspline, only : splineval_power_tens + implicit none + + real(dl) :: TensorPower,k + real(kp), parameter :: PiByTwo=3.14159265d0/2._kp + + integer :: in + + if (in.ne.1) stop 'TensorPower: only 1 Pt allowed' + + if (powerD%initP%useSpline) then + TensorPower = splineval_power_tens(k*1._kp) + else + TensorPower = power_spectrum_tens(powerD%infCosmo,k*1._kp) + endif + + if (curv < 0) TensorPower=TensorPower*tanh(PiByTwo*sqrt(-k**2/curv-3)) + + end function TensorPower + + + + + + + function Power_Descript(in, Scal, Tens, Keys, Vals) +!Get parameters describing parameterisation (for FITS file) + character(LEN=8), intent(out) :: Keys(*) + real(kp), intent(out) :: Vals(*) + integer, intent(IN) :: in + logical, intent(IN) :: Scal, Tens + integer num, Power_Descript + num=0 + if ((Scal).or.(Tens)) then + num=num+1 + Keys(num) = 'C1' + Vals(num) = powerD%initP%infParam%consts(1) + num=num+1 + Keys(num) = 'C2' + Vals(num) = powerD%initP%infParam%consts(2) + num=num+1 + Keys(num) = 'C3' + Vals(num) = powerD%initP%infParam%consts(3) + num=num+1 + Keys(num) = 'C4' + Vals(num) = powerD%initP%infParam%consts(4) + num=num+1 + Keys(num) = 'Conf' + Vals(num) = powerD%initP%infParam%conforms(1) + num=num+1 + Keys(num) = 'Field' + Vals(num) = powerD%initP%infParam%matters(1) + num=num+1 + Keys(num) = 'lnReheat' + Vals(num) = powerD%initP%lnReheat + num=num+1 + Keys(num) = 'HubbleEnd' + Vals(num) = powerD%infCosmo%bgEnd%hubble + num=num+1 + Keys(num) = 'EnergyEndInf' + Vals(num) = powerD%infCosmo%lnEnergyEnd + num=num+1 + Keys(num) = 'EfoldEndToToday' + Vals(num) = powerD%infCosmo%efoldEndToToday + end if + Power_Descript = num + + end function Power_Descript + + + subroutine InitialPower_ReadParams(InitPower, Ini, WantTensors) + use IniFile +!fields + use infbgmodel, only : dilatonNum, matterNum + real :: mu,nu +!end fields + + Type(InitialPowerParams) :: InitPower + Type(TIniFile) :: Ini + logical, intent(in) :: WantTensors + integer i + +!fields + + InitPower%nn = Ini_Read_Int('initial_power_num',1) + if (InitPower%nn>nnmax) stop 'Too many initial power spectra - increase nnmax in InitialPower' + InitPower%infParam%name = Ini_Read_String('inf_model_name') + InitPower%bgParamNum = Ini_Read_Int('inf_param_number',3) + + do i=1, InitPower%bgParamNum + InitPower%infParam%consts(i) & + = Ini_Read_Double_Array_File(Ini,'inf_param',i,0._dl) + end do + + do i=1,dilatonNum + InitPower%infParam%conforms(i) & + = Ini_Read_Double_Array_File(Ini,'inf_conform',i,1d0) + enddo + + do i=1,matterNum + InitPower%infParam%matters(i) & + = Ini_Read_Double_Array_File(Ini,'inf_matter',i,1d1) + enddo + + InitPower%checkBound = Ini_Read_Logical('inf_check_bound',.false.) + InitPower%checkStop = Ini_Read_Logical('inf_check_stop',.false.) + + InitPower%lnReheat = Ini_Read_Double('inf_ln_reheat',0d0) + + InitPower%useSpline = Ini_Read_Logical('power_spectra_spline',.false.) + if (InitPower%useSpline) then + InitPower%lnkmpcMin = Ini_Read_Double('spline_lnkmpc_min',-14d0) + InitPower%lnkmpcMax = Ini_Read_Double('spline_lnkmpc_max',0d0) + InitPower%lnkmpcNum = Ini_Read_Int('spline_lnkmpc_num',10) + endif + + +!convenient rescalings +! InitPower%infParam%consts(1) = 10.**InitPower%infParam%consts(1) +! InitPower%infParam%consts(4) = 10.**InitPower%infParam%consts(4) + mu = InitPower%infParam%consts(3) + nu = InitPower%infParam%consts(4) + if ((mu.ne.0.).and.(nu.eq.0.)) then + InitPower%infParam%matters = InitPower%infParam%matters & + *abs(mu) + endif + +!end fields + + + end subroutine InitialPower_ReadParams + + + +end module InitialPower diff --git a/fieldinf/specialinf.f90 b/fieldinf/specialinf.f90 new file mode 100644 index 0000000..188014a --- /dev/null +++ b/fieldinf/specialinf.f90 @@ -0,0 +1,541 @@ +module specialprec + use infprec, only : kp + implicit none + integer, parameter :: dp = selected_real_kind(12,60) +! integer, parameter :: dp = kp +end module specialprec + + +module specialinf + use specialprec, only : dp,kp + implicit none +contains + + function hypergeom_2F1(a,b,c,z) + implicit none + real(dp), intent(in) :: a,b,c,z + real(dp) :: hypergeom_2F1 + complex(dp) :: ac,bc,cc,zc + complex(dp) :: HYP_2F1,res + + ac = cmplx(a,0,dp) + bc = cmplx(b,0,dp) + cc = cmplx(c,0,dp) + zc = cmplx(z,0,dp) + + res = HYP_2F1(ac,bc,cc,zc) + + hypergeom_2F1 = real(res,dp) + + + end function hypergeom_2F1 + + + function lambertw(x) + implicit none + real(kp) :: lambertw + real(kp), intent(in) :: x + real(kp) :: w,wTimesExpW,wPlusOneTimesExpW + real(kp), parameter :: tol=1d-15 + +!rough estimation + + if ((x.le.500._kp).and.(x.ge.0._kp)) then + w = 0.665_kp * (1._kp + 0.0195*log(x+1._kp)) & + *log(x+1._kp) + 0.04_kp + elseif (x.gt.500._kp) then + w = log(x-4._kp) - (1._kp - 1._kp/log(x)) & + *log(log(x)) + elseif (x.ge.-1._kp/exp(1._kp)) then + w=-0.5 + else + stop 'x<-1/e' + endif + +!recurrence + + do + wTimesExpW = w*exp(w) + wPlusOneTimesExpW = (w+1._kp)*exp(w) + if (tol.gt.(abs((x-wTimesExpW)/wPlusOneTimesExpW))) then + exit + else + w = w-(wTimesExpW-x) & + /(wPlusOneTimesExpW-(w+2._kp)*(wTimesExpW-x) & + /(2._kp*w+2._kp)) + endif + enddo + + lambertw = w + + end function lambertw + + + + + + + +!DECK DLI +! Code converted using TO_F90 by Alan Miller +! Date: 2002-02-26 Time: 16:43:57 + FUNCTION dli(x) RESULT(fn_val) +!***BEGIN PROLOGUE DLI +!***PURPOSE Compute the logarithmic integral. +!***LIBRARY SLATEC (FNLIB) +!***CATEGORY C5 +!***TYPE REAL (dp) (ALI-S, DLI-D) +!***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS +!***AUTHOR Fullerton, W., (LANL) +!***DESCRIPTION +! DLI(X) calculates the REAL (dp) logarithmic integral +! for REAL (dp) argument X. +!***REFERENCES (NONE) +!***ROUTINES CALLED DEI, XERMSG +!***REVISION HISTORY (YYMMDD) +! 770701 DATE WRITTEN +! 890531 Changed all specific intrinsics to generic. (WRB) +! 890531 REVISION DATE from Version 3.2 +! 891214 Prologue converted to Version 4.0 format. (BAB) +! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +!***END PROLOGUE DLI + REAL (dp), INTENT(IN) :: x + REAL (dp) :: fn_val +!***FIRST EXECUTABLE STATEMENT DLI + IF (x <= 0.d0) CALL xermsg('SLATEC', 'DLI', 'LOG INTEGRAL UNDEFINED FOR X <= 0') + IF (x == 1.d0) CALL xermsg('SLATEC', 'DLI', 'LOG INTEGRAL UNDEFINED FOR X = 0') + fn_val = dei(LOG(x)) + RETURN + END FUNCTION dli +!DECK DCSEVL + FUNCTION dcsevl(x, cs, n) RESULT(fn_val) +!***BEGIN PROLOGUE DCSEVL +!***PURPOSE Evaluate a Chebyshev series. +!***LIBRARY SLATEC (FNLIB) +!***CATEGORY C3A2 +!***TYPE REAL (dp) (CSEVL-S, DCSEVL-D) +!***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS +!***AUTHOR Fullerton, W., (LANL) +!***DESCRIPTION +! Evaluate the N-term Chebyshev series CS at X. Adapted from +! a method presented in the paper by Broucke referenced below. +! Input Arguments -- +! X value at which the series is to be evaluated. +! CS array of N terms of a Chebyshev series. In evaluating +! CS, only half the first coefficient is summed. +! N number of terms in array CS. +!***REFERENCES R. Broucke, Ten subroutines for the manipulation of Chebyshev +! series, Algorithm 446, Communications of the A.C.M. 16, +! (1973) pp. 254-256. +! L. Fox and I. B. Parker, Chebyshev Polynomials in Numerical +! Analysis, Oxford University Press, 1968, page 56. +!***ROUTINES CALLED D1MACH, XERMSG +!***REVISION HISTORY (YYMMDD) +! 770401 DATE WRITTEN +! 890831 Modified array declarations. (WRB) +! 890831 REVISION DATE from Version 3.2 +! 891214 Prologue converted to Version 4.0 format. (BAB) +! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +! 900329 Prologued revised extensively and code rewritten to allow +! X to be slightly outside interval (-1,+1). (WRB) +! 920501 Reformatted the REFERENCES section. (WRB) +!***END PROLOGUE DCSEVL +REAL (dp), INTENT(IN) :: x +REAL (dp), INTENT(IN) :: cs(:) +INTEGER, INTENT(IN) :: n +REAL (dp) :: fn_val +REAL (dp) :: b0, b1, b2, twox +REAL (dp), SAVE :: onepl +LOGICAL, SAVE :: first = .TRUE. +INTEGER :: i, ni +!***FIRST EXECUTABLE STATEMENT DCSEVL +IF (first) onepl = 1.0_dp + 2*EPSILON(0.0_dp) +first = .false. +IF (n < 1) CALL xermsg('SLATEC','DCSEVL', 'NUMBER OF TERMS <= 0') +IF (n > 1000) CALL xermsg('SLATEC', 'DCSEVL', 'NUMBER OF TERMS > 1000') +IF (ABS(x) > onepl) CALL xermsg('SLATEC','DCSEVL', 'X OUTSIDE THE INTERVAL (-1,+1)') +b1 = 0.0_dp +b0 = 0.0_dp +twox = 2.0_dp * x +DO i = 1, n + b2 = b1 + b1 = b0 + ni = n + 1 - i + b0 = twox * b1 - b2 + cs(ni) +END DO +fn_val = 0.5_dp * (b0-b2) +RETURN +END FUNCTION dcsevl +!DECK DE1 +FUNCTION de1(x) RESULT(fn_val) +!***BEGIN PROLOGUE DE1 +!***PURPOSE Compute the exponential integral E1(X). +!***LIBRARY SLATEC (FNLIB) +!***CATEGORY C5 +!***TYPE REAL (dp) (E1-S, DE1-D) +!***KEYWORDS E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, +! SPECIAL FUNCTIONS +!***AUTHOR Fullerton, W., (LANL) +!***DESCRIPTION +! DE1 calculates the REAL (dp) exponential integral, E1(X), for positive +! REAL (dp) argument X and the Cauchy principal value for negative X. +! If principal values are used everywhere, then, for all X, +! E1(X) = -Ei(-X) +! or +! Ei(X) = -E1(-X). +! Series for AE10 on the interval -3.12500E-02 to 0. +! with weighted error 4.62E-32 +! log weighted error 31.34 +! significant figures required 29.70 +! decimal places required 32.18 +! Series for AE11 on the interval -1.25000E-01 to -3.12500E-02 +! with weighted error 2.22E-32 +! log weighted error 31.65 +! significant figures required 30.75 +! decimal places required 32.54 +! Series for AE12 on the interval -2.50000E-01 to -1.25000E-01 +! with weighted error 5.19E-32 +! log weighted error 31.28 +! significant figures required 30.82 +! decimal places required 32.09 +! Series for E11 on the interval -4.00000E+00 to -1.00000E+00 +! with weighted error 8.49E-34 +! log weighted error 33.07 +! significant figures required 34.13 +! decimal places required 33.80 +! Series for E12 on the interval -1.00000E+00 to 1.00000E+00 +! with weighted error 8.08E-33 +! log weighted error 32.09 +! approx significant figures required 30.4 +! decimal places required 32.79 +! Series for AE13 on the interval 2.50000E-01 to 1.00000E+00 +! with weighted error 6.65E-32 +! log weighted error 31.18 +! significant figures required 30.69 +! decimal places required 32.03 +! Series for AE14 on the interval 0. to 2.50000E-01 +! with weighted error 5.07E-32 +! log weighted error 31.30 +! significant figures required 30.40 +! decimal places required 32.20 +!***REFERENCES (NONE) +!***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG +!***REVISION HISTORY (YYMMDD) +! 770701 DATE WRITTEN +! 890531 Changed all specific intrinsics to generic. (WRB) +! 891115 Modified prologue description. (WRB) +! 891115 REVISION DATE from Version 3.2 +! 891214 Prologue converted to Version 4.0 format. (BAB) +! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +! 920618 Removed space from variable names. (RWC, WRB) +!***END PROLOGUE DE1 +REAL (dp), INTENT(IN) :: x +REAL (dp) :: fn_val +REAL (dp) :: eta, xmaxt +REAL (dp), SAVE :: xmax +INTEGER, SAVE :: ntae10, ntae11, ntae12, nte11, nte12, ntae13, ntae14 +LOGICAL, SAVE :: first = .TRUE. +REAL (dp), PARAMETER :: ae10cs(50) = (/ +.3284394579616699087873844201881E-1_dp, & + -.1669920452031362851476184343387E-1_dp, +.2845284724361346807424899853252E-3_dp, & + -.7563944358516206489487866938533E-5_dp, +.2798971289450859157504843180879E-6_dp, & + -.1357901828534531069525563926255E-7_dp, +.8343596202040469255856102904906E-9_dp, & + -.6370971727640248438275242988532E-10_dp, +.6007247608811861235760831561584E-11_dp, & + -.7022876174679773590750626150088E-12_dp, +.1018302673703687693096652346883E-12_dp, & + -.1761812903430880040406309966422E-13_dp, +.3250828614235360694244030353877E-14_dp, & + -.5071770025505818678824872259044E-15_dp, +.1665177387043294298172486084156E-16_dp, & + +.3166753890797514400677003536555E-16_dp, -.1588403763664141515133118343538E-16_dp, & + +.4175513256138018833003034618484E-17_dp, -.2892347749707141906710714478852E-18_dp, & + -.2800625903396608103506340589669E-18_dp, +.1322938639539270903707580023781E-18_dp, & + -.1804447444177301627283887833557E-19_dp, -.7905384086522616076291644817604E-20_dp, & + +.4435711366369570103946235838027E-20_dp, -.4264103994978120868865309206555E-21_dp, & + -.3920101766937117541553713162048E-21_dp, +.1527378051343994266343752326971E-21_dp, & + +.1024849527049372339310308783117E-22_dp, -.2134907874771433576262711405882E-22_dp, & + +.3239139475160028267061694700366E-23_dp, +.2142183762299889954762643168296E-23_dp, & + -.8234609419601018414700348082312E-24_dp, -.1524652829645809479613694401140E-24_dp, & + +.1378208282460639134668480364325E-24_dp, +.2131311202833947879523224999253E-26_dp, & + -.2012649651526484121817466763127E-25_dp, +.1995535662263358016106311782673E-26_dp, & + +.2798995808984003464948686520319E-26_dp, -.5534511845389626637640819277823E-27_dp, & + -.3884995396159968861682544026146E-27_dp, +.1121304434507359382850680354679E-27_dp, & + +.5566568152423740948256563833514E-28_dp, -.2045482929810499700448533938176E-28_dp, & + -.8453813992712336233411457493674E-29_dp, +.3565758433431291562816111116287E-29_dp, & + +.1383653872125634705539949098871E-29_dp, -.6062167864451372436584533764778E-30_dp, & + -.2447198043989313267437655119189E-30_dp, +.1006850640933998348011548180480E-30_dp, & + +.4623685555014869015664341461674E-31_dp /) +REAL (dp), PARAMETER :: ae11cs(60) = (/ +.20263150647078889499401236517381_dp, & + -.73655140991203130439536898728034E-1_dp, +.63909349118361915862753283840020E-2_dp, & + -.60797252705247911780653153363999E-3_dp, -.73706498620176629330681411493484E-4_dp, & + +.48732857449450183453464992488076E-4_dp, -.23837064840448290766588489460235E-5_dp, & + -.30518612628561521027027332246121E-5_dp, +.17050331572564559009688032992907E-6_dp, & + +.23834204527487747258601598136403E-6_dp, +.10781772556163166562596872364020E-7_dp, & + -.17955692847399102653642691446599E-7_dp, -.41284072341950457727912394640436E-8_dp, & + +.68622148588631968618346844526664E-9_dp, +.53130183120506356147602009675961E-9_dp, & + +.78796880261490694831305022893515E-10_dp, -.26261762329356522290341675271232E-10_dp, & + -.15483687636308261963125756294100E-10_dp, -.25818962377261390492802405122591E-11_dp, & + +.59542879191591072658903529959352E-12_dp, +.46451400387681525833784919321405E-12_dp, & + +.11557855023255861496288006203731E-12_dp, -.10475236870835799012317547189670E-14_dp, & + -.11896653502709004368104489260929E-13_dp, -.47749077490261778752643019349950E-14_dp, & + -.81077649615772777976249734754135E-15_dp, +.13435569250031554199376987998178E-15_dp, & + +.14134530022913106260248873881287E-15_dp, +.49451592573953173115520663232883E-16_dp, & + +.79884048480080665648858587399367E-17_dp, -.14008632188089809829248711935393E-17_dp, & + -.14814246958417372107722804001680E-17_dp, -.55826173646025601904010693937113E-18_dp, & + -.11442074542191647264783072544598E-18_dp, +.25371823879566853500524018479923E-20_dp, & + +.13205328154805359813278863389097E-19_dp, +.62930261081586809166287426789485E-20_dp, & + +.17688270424882713734999261332548E-20_dp, +.23266187985146045209674296887432E-21_dp, & + -.67803060811125233043773831844113E-22_dp, -.59440876959676373802874150531891E-22_dp, & + -.23618214531184415968532592503466E-22_dp, -.60214499724601478214168478744576E-23_dp, & + -.65517906474348299071370444144639E-24_dp, +.29388755297497724587042038699349E-24_dp, & + +.22601606200642115173215728758510E-24_dp, +.89534369245958628745091206873087E-25_dp, & + +.24015923471098457555772067457706E-25_dp, +.34118376888907172955666423043413E-26_dp, & + -.71617071694630342052355013345279E-27_dp, -.75620390659281725157928651980799E-27_dp, & + -.33774612157467324637952920780800E-27_dp, -.10479325703300941711526430332245E-27_dp, & + -.21654550252170342240854880201386E-28_dp, -.75297125745288269994689298432000E-30_dp, & + +.19103179392798935768638084000426E-29_dp, +.11492104966530338547790728833706E-29_dp, & + +.43896970582661751514410359193600E-30_dp, +.12320883239205686471647157725866E-30_dp, & + +.22220174457553175317538581162666E-31_dp /) +REAL (dp), PARAMETER :: ae12cs(41) = (/ +.63629589796747038767129887806803_dp, & + -.13081168675067634385812671121135E+0_dp, -.84367410213053930014487662129752E-2_dp, & + +.26568491531006685413029428068906E-2_dp, +.32822721781658133778792170142517E-3_dp, & + -.23783447771430248269579807851050E-4_dp, -.11439804308100055514447076797047E-4_dp, & + -.14405943433238338455239717699323E-5_dp, +.52415956651148829963772818061664E-8_dp, & + +.38407306407844323480979203059716E-7_dp, +.85880244860267195879660515759344E-8_dp, & + +.10219226625855003286339969553911E-8_dp, +.21749132323289724542821339805992E-10_dp, & + -.22090238142623144809523503811741E-10_dp, -.63457533544928753294383622208801E-11_dp, & + -.10837746566857661115340539732919E-11_dp, -.11909822872222586730262200440277E-12_dp, & + -.28438682389265590299508766008661E-14_dp, +.25080327026686769668587195487546E-14_dp, & + +.78729641528559842431597726421265E-15_dp, +.15475066347785217148484334637329E-15_dp, & + +.22575322831665075055272608197290E-16_dp, +.22233352867266608760281380836693E-17_dp, & + +.16967819563544153513464194662399E-19_dp, -.57608316255947682105310087304533E-19_dp, & + -.17591235774646878055625369408853E-19_dp, -.36286056375103174394755328682666E-20_dp, & + -.59235569797328991652558143488000E-21_dp, -.76030380926310191114429136895999E-22_dp, & + -.62547843521711763842641428479999E-23_dp, +.25483360759307648606037606400000E-24_dp, & + +.25598615731739857020168874666666E-24_dp, +.71376239357899318800207052800000E-25_dp, & + +.14703759939567568181578956800000E-25_dp, +.25105524765386733555198634666666E-26_dp, & + +.35886666387790890886583637333333E-27_dp, +.39886035156771301763317759999999E-28_dp, & + +.21763676947356220478805333333333E-29_dp, -.46146998487618942367607466666666E-30_dp, & + -.20713517877481987707153066666666E-30_dp, -.51890378563534371596970666666666E-31_dp /) +REAL (dp), PARAMETER :: e11cs(29) = (/ -.16113461655571494025720663927566180E+2_dp, & + +.77940727787426802769272245891741497E+1_dp, -.19554058188631419507127283812814491E+1_dp, & + +.37337293866277945611517190865690209E+0_dp, -.56925031910929019385263892220051166E-1_dp, & + +.72110777696600918537847724812635813E-2_dp, -.78104901449841593997715184089064148E-3_dp, & + +.73880933562621681878974881366177858E-4_dp, -.62028618758082045134358133607909712E-5_dp, & + +.46816002303176735524405823868362657E-6_dp, -.32092888533298649524072553027228719E-7_dp, & + +.20151997487404533394826262213019548E-8_dp, -.11673686816697793105356271695015419E-9_dp, & + +.62762706672039943397788748379615573E-11_dp, -.31481541672275441045246781802393600E-12_dp, & + +.14799041744493474210894472251733333E-13_dp, -.65457091583979673774263401588053333E-15_dp, & + +.27336872223137291142508012748799999E-16_dp, -.10813524349754406876721727624533333E-17_dp, & + +.40628328040434303295300348586666666E-19_dp, -.14535539358960455858914372266666666E-20_dp, & + +.49632746181648636830198442666666666E-22_dp, -.16208612696636044604866560000000000E-23_dp, & + +.50721448038607422226431999999999999E-25_dp, -.15235811133372207813973333333333333E-26_dp, & + +.44001511256103618696533333333333333E-28_dp, -.12236141945416231594666666666666666E-29_dp, & + +.32809216661066001066666666666666666E-31_dp, -.84933452268306432000000000000000000E-33_dp /) +REAL (dp), PARAMETER :: e12cs(25) = (/ -.3739021479220279511668698204827E-1_dp, & + +.4272398606220957726049179176528E-1_dp, -.130318207984970054415392055219726_dp, & + +.144191240246988907341095893982137E-1_dp, -.134617078051068022116121527983553E-2_dp, & + +.107310292530637799976115850970073E-3_dp, -.742999951611943649610283062223163E-5_dp, & + +.453773256907537139386383211511827E-6_dp, -.247641721139060131846547423802912E-7_dp, & + +.122076581374590953700228167846102E-8_dp, -.548514148064092393821357398028261E-10_dp, & + +.226362142130078799293688162377002E-11_dp, -.863589727169800979404172916282240E-13_dp, & + +.306291553669332997581032894881279E-14_dp, -.101485718855944147557128906734933E-15_dp, & + +.315482174034069877546855328426666E-17_dp, -.923604240769240954484015923200000E-19_dp, & + +.255504267970814002440435029333333E-20_dp, -.669912805684566847217882453333333E-22_dp, & + +.166925405435387319431987199999999E-23_dp, -.396254925184379641856000000000000E-25_dp, & + +.898135896598511332010666666666666E-27_dp, -.194763366993016433322666666666666E-28_dp, & + +.404836019024630033066666666666666E-30_dp, -.807981567699845120000000000000000E-32_dp /) +REAL (dp), PARAMETER :: ae13cs(50) = (/ -.60577324664060345999319382737747_dp, & + -.11253524348366090030649768852718E+0_dp, +.13432266247902779492487859329414E-1_dp, & + -.19268451873811457249246838991303E-2_dp, +.30911833772060318335586737475368E-3_dp, & + -.53564132129618418776393559795147E-4_dp, +.98278128802474923952491882717237E-5_dp, & + -.18853689849165182826902891938910E-5_dp, +.37494319356894735406964042190531E-6_dp, & + -.76823455870552639273733465680556E-7_dp, +.16143270567198777552956300060868E-7_dp, & + -.34668022114907354566309060226027E-8_dp, +.75875420919036277572889747054114E-9_dp, & + -.16886433329881412573514526636703E-9_dp, +.38145706749552265682804250927272E-10_dp, & + -.87330266324446292706851718272334E-11_dp, +.20236728645867960961794311064330E-11_dp, & + -.47413283039555834655210340820160E-12_dp, +.11221172048389864324731799928920E-12_dp, & + -.26804225434840309912826809093395E-13_dp, +.64578514417716530343580369067212E-14_dp, & + -.15682760501666478830305702849194E-14_dp, +.38367865399315404861821516441408E-15_dp, & + -.94517173027579130478871048932556E-16_dp, +.23434812288949573293896666439133E-16_dp, & + -.58458661580214714576123194419882E-17_dp, +.14666229867947778605873617419195E-17_dp, & + -.36993923476444472706592538274474E-18_dp, +.93790159936721242136014291817813E-19_dp, & + -.23893673221937873136308224087381E-19_dp, +.61150624629497608051934223837866E-20_dp, & + -.15718585327554025507719853288106E-20_dp, +.40572387285585397769519294491306E-21_dp, & + -.10514026554738034990566367122773E-21_dp, +.27349664930638667785806003131733E-22_dp, & + -.71401604080205796099355574271999E-23_dp, +.18705552432235079986756924211199E-23_dp, & + -.49167468166870480520478020949333E-24_dp, +.12964988119684031730916087125333E-24_dp, & + -.34292515688362864461623940437333E-25_dp, +.90972241643887034329104820906666E-26_dp, & + -.24202112314316856489934847999999E-26_dp, +.64563612934639510757670475093333E-27_dp, & + -.17269132735340541122315987626666E-27_dp, +.46308611659151500715194231466666E-28_dp, & + -.12448703637214131241755170133333E-28_dp, +.33544574090520678532907007999999E-29_dp, & + -.90598868521070774437543935999999E-30_dp, +.24524147051474238587273216000000E-30_dp, & + -.66528178733552062817107967999999E-31_dp /) +REAL (dp), PARAMETER :: ae14cs(64) = (/ -.1892918000753016825495679942820_dp, & + -.8648117855259871489968817056824E-1_dp, +.7224101543746594747021514839184E-2_dp, & + -.8097559457557386197159655610181E-3_dp, +.1099913443266138867179251157002E-3_dp, & + -.1717332998937767371495358814487E-4_dp, +.2985627514479283322825342495003E-5_dp, & + -.5659649145771930056560167267155E-6_dp, +.1152680839714140019226583501663E-6_dp, & + -.2495030440269338228842128765065E-7_dp, +.5692324201833754367039370368140E-8_dp, & + -.1359957664805600338490030939176E-8_dp, +.3384662888760884590184512925859E-9_dp, & + -.8737853904474681952350849316580E-10_dp, +.2331588663222659718612613400470E-10_dp, & + -.6411481049213785969753165196326E-11_dp, +.1812246980204816433384359484682E-11_dp, & + -.5253831761558460688819403840466E-12_dp, +.1559218272591925698855028609825E-12_dp, & + -.4729168297080398718476429369466E-13_dp, +.1463761864393243502076199493808E-13_dp, & + -.4617388988712924102232173623604E-14_dp, +.1482710348289369323789239660371E-14_dp, & + -.4841672496239229146973165734417E-15_dp, +.1606215575700290408116571966188E-15_dp, & + -.5408917538957170947895023784252E-16_dp, +.1847470159346897881370231402310E-16_dp, & + -.6395830792759094470500610425050E-17_dp, +.2242780721699759457250233276170E-17_dp, & + -.7961369173983947552744555308646E-18_dp, +.2859308111540197459808619929272E-18_dp, & + -.1038450244701137145900697137446E-18_dp, +.3812040607097975780866841008319E-19_dp, & + -.1413795417717200768717562723696E-19_dp, +.5295367865182740958305442594815E-20_dp, & + -.2002264245026825902137211131439E-20_dp, +.7640262751275196014736848610918E-21_dp, & + -.2941119006868787883311263523362E-21_dp, +.1141823539078927193037691483586E-21_dp, & + -.4469308475955298425247020718489E-22_dp, +.1763262410571750770630491408520E-22_dp, & + -.7009968187925902356351518262340E-23_dp, +.2807573556558378922287757507515E-23_dp, & + -.1132560944981086432141888891562E-23_dp, +.4600574684375017946156764233727E-24_dp, & + -.1881448598976133459864609148108E-24_dp, +.7744916111507730845444328478037E-25_dp, & + -.3208512760585368926702703826261E-25_dp, +.1337445542910839760619930421384E-25_dp, & + -.5608671881802217048894771735210E-26_dp, +.2365839716528537483710069473279E-26_dp, & + -.1003656195025305334065834526856E-26_dp, +.4281490878094161131286642556927E-27_dp, & + -.1836345261815318199691326958250E-27_dp, +.7917798231349540000097468678144E-28_dp, & + -.3431542358742220361025015775231E-28_dp, +.1494705493897103237475066008917E-28_dp, & + -.6542620279865705439739042420053E-29_dp, +.2877581395199171114340487353685E-29_dp, & + -.1271557211796024711027981200042E-29_dp, +.5644615555648722522388044622506E-30_dp, & + -.2516994994284095106080616830293E-30_dp, +.1127259818927510206370368804181E-30_dp, & + -.5069814875800460855562584719360E-31_dp /) +!***FIRST EXECUTABLE STATEMENT DE1 +IF (first) THEN + eta = 0.1 * EPSILON(0.0_dp) + ntae10 = initds(ae10cs, 50, eta) + ntae11 = initds(ae11cs, 60, eta) + ntae12 = initds(ae12cs, 41, eta) + nte11 = initds(e11cs, 29, eta) + nte12 = initds(e12cs, 25, eta) + ntae13 = initds(ae13cs, 50, eta) + ntae14 = initds(ae14cs, 64, eta) + xmaxt = -LOG( TINY(0.0_dp) ) + xmax = xmaxt - LOG(xmaxt) +END IF +first = .false. +IF (x <= -1._dp) THEN + IF (x <= -32._dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl(64._dp/x+1._dp, ae10cs, ntae10)) + RETURN + END IF + IF (x <= -8._dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl((64._dp/x+5._dp)/3._dp, ae11cs, ntae11)) + RETURN + END IF + IF (x <= -4._dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl(16._dp/x+3._dp, ae12cs, ntae12)) + RETURN + END IF + fn_val = -LOG(-x) + dcsevl((2._dp*x+5._dp)/3._dp, e11cs, nte11) + RETURN +END IF +IF (x <= 1.0_dp) THEN + IF (x == 0._dp) CALL xermsg('SLATEC', 'DE1', 'X IS 0') + fn_val = (-LOG(ABS(x)) - 0.6875_dp+x) + dcsevl(x, e12cs, nte12) + RETURN +END IF +IF (x <= 4.0_dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl((8._dp/x-5._dp)/3._dp, ae13cs, ntae13)) + RETURN +END IF +IF (x <= xmax) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl(8._dp/x-1._dp, ae14cs, ntae14)) + RETURN +END IF +CALL xermsg('SLATEC', 'DE1', 'X SO BIG E1 UNDERFLOWS') +fn_val = 0._dp +RETURN +END FUNCTION de1 +!DECK DEI +FUNCTION dei(x) RESULT(fn_val) +!***BEGIN PROLOGUE DEI +!***PURPOSE Compute the exponential integral Ei(X). +!***LIBRARY SLATEC (FNLIB) +!***CATEGORY C5 +!***TYPE REAL (dp) (EI-S, DEI-D) +!***KEYWORDS EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, +! SPECIAL FUNCTIONS +!***AUTHOR Fullerton, W., (LANL) +!***DESCRIPTION +! DEI calculates the REAL (dp) exponential integral, Ei(X), for +! positive REAL (dp) argument X and the Cauchy principal value +! for negative X. If principal values are used everywhere, then, for +! all X, +! Ei(X) = -E1(-X) +! or +! E1(X) = -Ei(-X). +!***REFERENCES (NONE) +!***ROUTINES CALLED DE1 +!***REVISION HISTORY (YYMMDD) +! 770701 DATE WRITTEN +! 891115 Modified prologue description. (WRB) +! 891115 REVISION DATE from Version 3.2 +! 891214 Prologue converted to Version 4.0 format. (BAB) +!***END PROLOGUE DEI +REAL (dp), INTENT(IN) :: x +REAL (dp) :: fn_val +!***FIRST EXECUTABLE STATEMENT DEI +fn_val = -de1(-x) +RETURN +END FUNCTION dei +!DECK INITDS +FUNCTION initds(os, nos, eta) RESULT(ival) +!***BEGIN PROLOGUE INITDS +!***PURPOSE Determine the number of terms needed in an orthogonal +! polynomial series so that it meets a specified accuracy. +!***LIBRARY SLATEC (FNLIB) +!***CATEGORY C3A2 +!***TYPE REAL (dp) (INITS-S, INITDS-D) +!***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, +! ORTHOGONAL SERIES, SPECIAL FUNCTIONS +!***AUTHOR Fullerton, W., (LANL) +!***DESCRIPTION +! Initialize the orthogonal series, represented by the array OS, so that +! INITDS is the number of terms needed to insure the error is no larger than +! ETA. Ordinarily, ETA will be chosen to be one-tenth machine precision. +! Input Arguments -- +! OS REAL (dp) array of NOS coefficients in an orthogonal series. +! NOS number of coefficients in OS. +! ETA single precision scalar containing requested accuracy of series. +!***REFERENCES (NONE) +!***ROUTINES CALLED XERMSG +!***REVISION HISTORY (YYMMDD) +! 770601 DATE WRITTEN +! 890531 Changed all specific intrinsics to generic. (WRB) +! 890831 Modified array declarations. (WRB) +! 891115 Modified error message. (WRB) +! 891115 REVISION DATE from Version 3.2 +! 891214 Prologue converted to Version 4.0 format. (BAB) +! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +!***END PROLOGUE INITDS +REAL (dp), INTENT(IN) :: os(:) +INTEGER, INTENT(IN) :: nos +REAL (dp), INTENT(IN) :: eta +INTEGER :: ival +INTEGER :: i, ii +REAL (dp) :: ERR +!***FIRST EXECUTABLE STATEMENT INITDS +IF (nos < 1) CALL xermsg('SLATEC', 'INITDS', 'Number of coefficients < 1') +ERR = 0.0_dp +DO ii = 1, nos + i = nos + 1 - ii + ERR = ERR + ABS(os(i)) + IF (ERR > eta) GO TO 20 +END DO +20 IF (i == nos) CALL xermsg('SLATEC', 'INITDS', & + 'Chebyshev series too short for specified accuracy') +ival = i +RETURN +END FUNCTION initds + +SUBROUTINE xermsg(text1, text2, text3) +CHARACTER (LEN= *), INTENT(IN) :: text1 +CHARACTER (LEN= *), INTENT(IN) :: text2 +CHARACTER (LEN= *), INTENT(IN) :: text3 +WRITE(*, '(6a)') ' Error in call to ', text1, ' routine: ', text2, ' Mesg: ', text3 +return +END SUBROUTINE xermsg + + +end module specialinf diff --git a/params.ini b/params.ini index 6e524dd..dcfa811 100644 --- a/params.ini +++ b/params.ini @@ -1,7 +1,7 @@ #Sample parameters for cosmomc in default parameterization #Root name for files produced -file_root = chains/test +file_root = chains/fields #action = 0: MCMC, action=1: postprocess .data file, action=2: find best fit point only action = 0 @@ -10,7 +10,7 @@ action = 0 samples = 200000 #Feedback level ( 2=lots,1=chatty,0=none) -feedback = 1 +feedback = 3 #Temperature at which to Monte-Carlo temperature = 1 @@ -72,18 +72,18 @@ directional_grid_steps = 20 #use fast-slow parameter distinctions to speed up #(note for basic models WMAP3 code is only ~3x as fast as CAMB) -use_fast_slow = F +use_fast_slow = T #Can use covariance matrix for proposal density, otherwise use settings below #Covariance matrix can be produced using "getdist" program. -propose_matrix = params_CMB.covmat +#propose_matrix = params_CMB.covmat #If propose_matrix is blank (first run), can try to use numerical Hessian to #estimate a good propose matrix. As a byproduct you also get an approx best fit point estimate_propose_matrix = F #Tolerance on log likelihood to use when estimating best fit point -delta_loglike = 2 +delta_loglike = 0.1 #Scale of proposal relative to covariance; 2.4 is recommended by astro-ph/0405462 for Gaussians #If propose_matrix is much broader than the new distribution, make proportionately smaller @@ -150,7 +150,7 @@ highL_unlensed_cl_template = ./camb/HighLExtrapTemplate_lenspotentialCls.dat #CAMB parameters #If we are including tensors -compute_tensors = F +compute_tensors = T #Initial power spectrum amplitude point (Mpc^{-1}) #Note if you change this, may need new .covmat as degeneracy directions change pivot_k = 0.05 @@ -168,6 +168,9 @@ high_accuracy_default = F #accuracy_level can be increased to check stability/higher accuracy, but inefficient accuracy_level = 1 +#select the inflationary model +inflation_model = largef + #If action = 1 redo_likelihoods = T redo_theory = F @@ -192,12 +195,33 @@ param[omegak] = 0 0 0 0 0 param[fnu] = 0 0 0 0 0 param[w] = -1 -1 -1 0 0 -param[ns] = 0.95 0.5 1.5 0.02 0.01 -param[nt] = 0 0 0 0 0 -param[nrun] = 0 0 0 0 0 +#initial field values +#dilaton +param[Aini] = 1 1 1 0 0 +#matter field X (0 to use guessed values) +param[Xini] = 0 0 0 0 0 +#potential parameters: mu = nu = 0 for large fields +#p +param[p] = 2 2 2 0 0 +#mu +param[mu] = 0 0 0 0 0 +#nu +param[nu] = 0 0 0 0 0 +#q +param[q] = 1 1 1 0 0 + +#reheating correction +#ln(aend/areh) + 1/4 ln(1/rhoreh) - 1/2 ln(1/rhoend) +param[lnR] = 0 -46 15 10 10 + +#bound on field values (need checkBound=T) +param[Xend] = 0 0 0 0 0 + +#end field values (needs checkStop=T) +param[Xstop] = 0 0 0 0 0 #log[10^10 A_s] -param[logA] = 3 2.7 4 0.01 0.01 -param[r] = 0 0 0 0 0 +param[lnA] = 3 2.7 4 0.01 0.01 +param[r] = 1 1 1 0 0 #SZ amplitude, as in WMAP analysis param[asz]= 1 0 2 0.4 0.4 diff --git a/params_CMB.paramnames b/params_CMB.paramnames index 0c08e67..87e65b6 100644 --- a/params_CMB.paramnames +++ b/params_CMB.paramnames @@ -1,20 +1,30 @@ -omegabh2 \Omega_b h^2 #physical baryon density -omegadmh2 \Omega_{DM} h^2 #physical dark matter density, including CDM and massive neutrinos -theta \theta #100 times the ratio of the angular diameter distance to the LSS sound horizon (approx) +omegabh2 \Omega_b h^2 #physical baryon density +omegadmh2 \Omega_{DM} h^2 #physical dark matter density, including CDM and massive neutrinos +theta \theta #100 times the ratio of the angular diameter distance to the LSS sound horizon (approx) tau \tau omegak \Omega_K -fnu f_\nu #neutrino energy density as fraction of omegadmh2 -w w #constant equation of state parameter for scalar field dark energy -ns n_s #beware that pivot scale can change in .ini file -nt n_t -nrun n_{run} -logA log[10^{10} A_s] -r r #ratio of tensor to scalar primordial amplitudes at pivot scale -asz A_{SZ} #SZ template amplitude, as in WMAP +fnu f_\nu #neutrino energy density as fraction of omegadmh2 +w w #constant equation of state parameter for scalar field dark energy +Aini A_{ini} #initial conformal factor in the Einstein frame +Xini \kappa\chi_{ini} #initiai field value +p p #potential parameter p +mu \mu #potential parameter mu +nu \nu #potential parameter nu +q q #potential parameter q +lnR ln(R) #reheating parameter +Xend \kappa\chi_{uv} #bound on fields values +Xstop \kappa\chi_{stop} #force inflation to stop at this fied value +lnA ln[10^{10} P_*] #scalar power spectrum amplitude +r r #ratio of tensor to scalar primordial amplitudes at pivot scale +asz A_{SZ} #SZ template amplitude, as in WMAP omegal* \Omega_\Lambda age* Age/Gyr omegam* \Omega_m sigma8* \sigma_8 zrei* z_{re} -r10* r_{10} #tensor-scalar C_l amplitude at l=10 -H0* H_0 #hubble parameter is H0 km/s/Mpc \ No newline at end of file +r10* r_{10} #tensor-scalar C_l amplitude at l=10 +H0* H_0 #hubble parameter is H0 km/s/Mpc +logM* log(\kappa M) #potential normalisation +lnRrad* ln(R_{rad}) #derived reheating parameter ln(a_{end}/a_{reh}) - 1/4 ln(\rho_{reh}/\rho_{end}) +lnzinf* ln(a_0/a_{end}) #redshit of the end of inflation +lnrhoinf* ln(\kappa^4 \rho_{end}) #energy at the end of inflation diff --git a/readme.html b/readme.html index 9c8fd78..69a24f9 100644 --- a/readme.html +++ b/readme.html @@ -171,8 +171,12 @@ If you don't have a propose_matrix, set estimate_propose_matrix = T to au

  • Sampling method
    Set sampling_method=1 to use the default Metropolis algorithm (in the optimal fast/slow subspaces if use_fast_slow is true). Other options are slice sampling (2), slice sampling fast parameters (3), and directional gridding (4). These methods should work fine for most simple distributions; the temperature input parameter can be increased to probe further into the tails if required (e.g. to get better high-confidence limits). Further sampling_method options that you can try for nastier (e.g. multi-modal distributions) are multicanonical sampling (5) and Wang-Landau-like sampling (6). These latter methods could be modified to calculate the evidence, but at the moment are only implemented to sample nastier distributions via importance sampling. Multicanonical sampling probes into the tails a distance proportional to the running time, and all samples can be kept if the distribution turns out to be unimodal. The Wang-Landau-like sampling probes the full likelihood range from the word go, and produces no samples for the first 10,000 or so steps (thereafter all samples are strictly Markovian may be kept without burn in). Methods 5 and 6 can be used with MPI, but MPI stopping should probably be turned off; MPI proposal learning may work with method 6, though this is not extensively tested. Both are likely to require samples = 100000 or larger, hence significantly slow than a basic MCMC run for simple distributions. Settings for methods 5 and 6 can be edited at the top of MCMC.f90. See the notes for a more detailed explanation of sampling methods. +

    +
  • CAMB's numerical accuracy
    +The default accuracy is aimed at WMAP. Set high_accuracy_default = T to target ~0.1% accuracy on the CMB power spectra from CAMB. This is sufficient for numerical biases to be small compared to the error bar for Planck; for an accuracy study see arXiv:1201.3654. You can also use the accuracy_level parameter to increase accuracy further, however this is numerically inefficient and is best used mainly for numerical stability checks using importance sampling (action=1).

    +
  • Best-fit point
    Set action =2 to just calculate the best-fit point and stop. Set delta_loglike to the tolerance on the log likelihood for finding the best fit. The values are output to a file called file_root.minimum. Note that this function does not always work very reliably. @@ -185,7 +189,6 @@ to zero and remove entries when you come to process the output samples.

    -
  • Threads and run-time adjustment
    The num_threads parameter will determine the number of openMP threads (in MPI runs, usually set to the number of CPUs on each node). Scaling is linear up to about 8 processors on most systems, then falls off slowly. It is probably best to run several chains on 8 or fewer @@ -523,8 +526,8 @@ weighting function or parameter mapping.
  • January 2012
    diff --git a/source/CMB_Cls_simple.f90 b/source/CMB_Cls_simple.f90 index db9d905..c631413 100644 --- a/source/CMB_Cls_simple.f90 +++ b/source/CMB_Cls_simple.f90 @@ -139,8 +139,14 @@ contains !Always get everything again. Slight waste of time in general, but allows complete mixing of fast !parameters, and works with lensing - call SetCAMBInitPower(Info%Transfers%Params,CMB,1) - +!fields call SetCAMBInitPower(Info%Transfers%Params,CMB,1) + call SetCAMBInitPower(Info%Transfers%Params,CMB,1,error) + if (error.ne.0) then + if (Feedback > 1) write(*,*)'CMB_Cls_simple: out of prior error =',error + return + endif +!end fields + call CAMB_TransfersToPowers(Info%Transfers) !this sets slow CAMB params correctly from value stored in Transfers if (global_error_flag/=0) then @@ -261,8 +267,13 @@ contains Threadnum =num_threads call CMBToCAMB(CMB, P) P%OnlyTransfers = .false. - call SetCAMBInitPower(P,CMB,1) - +!fields call SetCAMBInitPower(P,CMB,1) + call SetCAMBInitPower(P,CMB,1,error) + if (error.ne.0) then + if (Feedback > 1) write(*,*)'GetClsInfo: out of prior error =',error + stop + endif +!end fields MatterOnly = .false. if (DoPk) then P%WantTransfer = .true. @@ -478,6 +489,10 @@ contains if (use_BAO) P%want_zdrag = .true. !JH P%want_zstar = .false. !set to true if you want CAMB to calculate exact z_star +!fields + P%InitPower%infParam%name = InfModelName +!end fields + if (CMB_Lensing) then P%DoLensing = .true. P%Max_l = lmax +100 + 50 !+50 in case accuracyBoost>1 and so odd l spacing diff --git a/source/GetDist.f90 b/source/GetDist.f90 index 65cbc71..e72ad74 100644 --- a/source/GetDist.f90 +++ b/source/GetDist.f90 @@ -105,6 +105,32 @@ module MCSamples integer Num_ComparePlots logical :: prob_label = .false. +!addon +!exact field model + logical, parameter :: findMaxValues = .false. + logical, parameter :: mapRhoReh = .false. + logical, parameter :: mapLFPowerToWreh = .true. + +!slow-roll analysis + logical, parameter :: adjEps1ToLog = .false. + logical, parameter :: extractHinf = .false. + logical, parameter :: mapnslogr = .true. + logical, parameter :: use2ndSR=.true. + real, parameter :: ln10p5HinfCut=-10 + real, parameter :: logrCut=-3.7 + +#ifdef SRREHEAT + logical, parameter :: doReheatFromSr = .false. + character(len=*), parameter :: reheatModel='smallf' +#endif + + real, parameter :: wfix = -0.3 + real, parameter :: pmax = 15, pmin = 0 + real, parameter :: logmumax=10 +!end addon + + + contains subroutine AdjustPriors @@ -112,8 +138,20 @@ contains !Be careful as this code is parameterisation dependent integer i real ombh2, chisq +!addon + integer, parameter :: dp = kind(1._8) + real(dp) :: eps1,logeps1,eps2,eps3, lnR,lnRrad + real(dp) :: wreh,p,logmu,lnRhoReh,lnRhoEnd + + real :: ln10p5HinfMin=1e30 + real :: ln10p5HinfMax=-1e30 + + real :: lnRhoRehmax = -1e30, lnRhoEndMax=-1e30, lnRmax = -1e30, lnRradmax = -1e30 + + real, parameter :: lnRhoNuc = -187.747 - stop 'You need to write the AdjustPriors subroutine in GetDist.f90 first!' +! stop 'You need to write the AdjustPriors subroutine in GetDist.f90 first!' +!end addon ! write (*,*) 'Adjusting priors' ! do i=0, nrows-1 @@ -125,6 +163,214 @@ contains ! ! end do +!addon + wreh = wfix + + + if (findMaxValues) then + print *,'-->computing maximum values in chains' + + do i=0,nrows-1 + lnR = coldata(14+2,i) + lnRhoEnd = coldata(2+30,i) + lnRrad = coldata(2+28,i) + lnRhoEndMax = max(lnRHoEndMax,lnRhoEnd) + lnRmax = max(lnRmax, lnR) + lnRradmax = max(lnRradmax, lnRrad) + enddo + + print *,'lnRhoEndMax= ',lnRhoEndMax + print *,'lnRradMax= lnRmax= ',lnRradMax, lnRmax + endif + + if (mapRhoReh) then + print *,'--> rejecting all p <',pmin + print *,'--> rejecting all logmu >',logmumax + print *,'--> rejecting all lnRhoNuc > lnRhoReh > lnRhoEnd' + + do i=0,nrows-1 + p = coldata(2+10,i) + logmu = coldata(11+2,i) + + if (mapLFPowerToWreh) wreh = (p-2._dp)/(p+2._dp) + + lnR = coldata(14+2,i) + lnRrad = coldata(2+28,i) + lnRhoReh = coldata(27+2,i) + lnRhoEnd = coldata(2+30,i) + + if ((wreh.lt.-1._dp/3._dp) & + .or.(p.lt.pmin).or.(logmu.gt.logmumax) & + .or.(lnRhoReh.gt.lnRhoEnd) & + .or.(lnRhoReh.lt.lnRhoNuc)) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + else + lnRhoRehMax = max(lnRHoRehMax,lnRhoReh) + lnRhoEndMax = max(lnRHoEndMax,lnRhoEnd) + lnRmax = max(lnRmax, lnR) + lnRradmax = max(lnRradmax, lnRrad) + endif + + enddo + print *,'Max values after applying prior!' + print *,'lnRhoEndMax= ',lnRhoEndMax + print *,'lnRhoRehMax= ',lnRhoRehMax + print *,'lnRradMax= lnRmax= ',lnRradMax, lnRmax + endif + + if (adjEps1ToLog) then + print *,'----> assumed mapped log(eps1) in col 8' + print *,'----> from flat eps1 to flat log(eps1)' + read(*,*) + do i=0, nrows-1 + + logeps1 = coldata(8+2,i) + eps1 = 10.**logeps1 + + coldata(1,i) = coldata(1,i)/(eps1*log(10.)) + coldata(2,i) = coldata(2,i) + + end do + endif + + + + if (extractHinf) then + + write (*,*)'Computing and adjusting bounds for ln(10^5 Hinf/mpl) in 17!' + + do i=0,nrows-1 + ln10p5HinfMax = max(ln10p5HinfMax,coldata(2+17,i)) + ln10p5HinfMin = min(ln10p5HinfMin,coldata(2+17,i)) + + if (coldata(2+17,i).lt.ln10p5HinfCut) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + + enddo + + write(*,*)'----> ln(10^5 Hinf) Min= Max= ',ln10p5HinfMin,ln10p5HinfMax + + endif + + if (mapnslogr) then + + write (*,*)'Adjusting bounds for log(r) in 14!' + + do i=0,nrows-1 + + if (coldata(2+14,i).lt.logrCut) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + + enddo + endif + +#ifdef SRREHEAT + if (doReheatFromSR) then + write(*,*)'Adjusting prior for reheat SR analysis' + + select case (reheatModel) + + case ('largef') + + + do i=0,nrows-1 + + eps1 = 10**(coldata(2+8,i)) + eps2 = coldata(2+9,i) + p = coldata(2+14,i) + wreh = (p-2.)/(p+2.) + +!large field models cannot produce eps2<=0 (out of prior) + if ((eps2.le.0.).or.(p.gt.pmax).or.(p.lt.pmin)) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + +!reheating is after end of inflation + lnRhoReh = coldata(11+2,i) + lnRhoEnd = coldata(12+2,i) + +! print *,'lnrhoreh end=',lnRhoReh,lnRhoEnd,eps1,eps2 + + if (wreh.lt.-1./3.) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + if (lnRhoReh.gt.lnRhoEnd) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + if (lnRhoReh.lt.lnRhoNuc) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + enddo + + case ('smallf') + + wreh = wfix + + do i=0,nrows-1 + + eps1 = 10**(coldata(2+8,i)) + eps2 = coldata(2+9,i) + eps3 = coldata(2+10,i) + + p = coldata(2+14,i) + + +!small field models (out of prior) + if (.not.(sr_checkobs_sf(eps1,eps2,eps3)) & + .or.(p.gt.pmax).or.(p.lt.pmin)) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + + +!reheating is after end of inflation + lnRhoReh = coldata(11+2,i) + lnRhoEnd = coldata(12+2,i) + + if (wreh.lt.-1./3.) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + if (lnRhoReh.gt.lnRhoEnd) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + if (lnRhoReh.lt.lnRhoNuc) then + chisq = 1e30 + coldata(1,i) = 0. + coldata(2,i) = coldata(2,i) + chisq/2 + endif + enddo + + end select + + + endif +#endif +!end addon + + + + end subroutine AdjustPriors subroutine MapParameters(invars) @@ -132,7 +378,194 @@ contains ! map parameters in invars: eg. invars(3)=invars(3)*invars(4) ! invars(2+13)=invars(17+2)*exp(-invars(2+4)) - stop 'Need to write MapParameters routine first' + + +!addon + integer, save :: counter = 0 + real :: lnR, lnRhoReh,lnRhoEnd, ns,logr + real :: cseps1,eps1mdel1,eps2pdel1,del1 + real :: as0,ln10p5Hinf + real, parameter :: C_const = -0.7296 + + integer, parameter :: dp=kind(1._8) + real(dp) :: p, mu, wreh, Pstar,bfold,eps1,eps2,eps3 + real(dp), dimension(2) :: buffer2D + real(dp), dimension(3) :: buffer3D + + + counter = counter + 1 + + if (mapRhoReh) then + + if (mapLFPowerToWreh) then + + p = invars(2+10) + wreh = (p-2._dp)/(p+2._dp) + + if (counter.eq.1) print *,'reheat marginalisation on p in col10' + else + + wreh = wfix + if (counter.eq.1) print *,'marginalising at fixed wreh= ',wreh + + endif + + if (wreh.eq.1./3.) stop 'Treh inversion is singular!' + + if (counter.eq.1) print *,'mapping lnR -> lnRhoReh in col27' + + lnR = invars(2+14) + + lnRhoEnd = invars(2+30) + + lnRhoReh = 4._dp*((1._dp+wreh)/(1._dp/3._dp-wreh))*lnR & + - 4._dp*(1._dp/3._dp + wreh)/(1._dp/3._dp - wreh)*lnRhoEnd/2._dp + + invars(27+2)=lnRhoReh + + end if + + + if (extractHinf) then + del1 = 0. + + if (counter.eq.1) print *,'assumiing 10**(col10) is eps1' + + eps1mdel1 = 10**invars(2+8) + eps2pdel1 = invars(2+9) + eps1 = eps1mdel1 + eps2 = eps2pdel1 + eps3 = invars(2+10) + + + cseps1=eps1mdel1 +! cseps1 = eps1/invars(2+15) +! cseps1= 10.**invars(2+15) + +! eps1 = 10.**invars(2+8) +! eps2 = invars(2+9) +! eps3 = invars(2+10) + + + + as0 = 1. + eps1mdel1*(-2.*(C_const+1.)) - eps2pdel1*C_const + + if (use2ndSR) then + if (counter.eq.1) print *,'using 2nd order slow-roll!' + as0 = as0 + eps1*eps1 * (2.*C_const**2 + 2.*C_const + pi**2/2. - 5.) & + + eps1*eps2 * (C_const**2 - C_const + 7.*pi**2/12. - 7.) & + + eps2*eps2 * (0.5*C_const**2 + pi**2/8. - 1.) & + + eps2*eps3 * (-0.5*C_const**2 + pi**2/24.) + endif + + ln10p5Hinf = + 0.5*invars(2+16) & + + 0.5*log(3.141592653589793238*cseps1) - 0.5*log(as0) + + + invars(2+17) = ln10p5Hinf + endif + + if (mapnslogr) then + + if (counter.eq.1) then + print *,'assumiing 10**(col10) is eps1' + print *,'Mapping ns --> col15 & logr --> col14' + endif + + eps1 = 10**invars(2+8) + eps2 = invars(2+9) + eps3 = invars(2+10) + + ns = 1 - 2.*eps1 - eps2 + logr = log10(16*eps1) + + if (use2ndSR) then + if (counter.eq.1) print *,'using 2nd order slow-roll!' + ns = ns - 2*eps1**2 - (2*C_const + 3)*eps1*eps2 - C_const*eps2*eps3 + logr = logr + log10(1 + C_const*eps2) + endif + + invars(2+14) = logr + invars(2+15) = ns + + endif + + +#ifdef SRREHEAT + if (doReheatFromSR) then + + if (counter.eq.1) then + write(*,*)'************************************************' + write(*,*)'Model is: ',reheatModel + write(*,*)'Doing Reheating analysis from SR:' + write(*,*)'Mapping lnRhoReh -> col11 & lnRhoEnd -> col12' + write(*,*)'& -N* -> col13 & p -> col14 & mu -> col15' + write(*,*)'************************************************' + endif + + Pstar = exp(invars(2+16))*1.e-10 + + eps1 = 10**(invars(2+8)) + eps2 = invars(2+9) + eps3 = invars(2+10) + + lnRhoReh = 0. + lnRhoEnd = 0. + bfold=0. + + select case(reheatModel) + + case ('largef') + +!large field models cannot produce eps2<=0 (out of prior) + if (eps2.le.0.) return + + buffer2d = sr_matter_obs_lf(eps1,eps2) + + p = buffer2d(1) + invars(15+2)=p + + if ((p.gt.pmax).or.(p.lt.pmin)) return + + lnRhoReh = sr_lnrhoreh_lf(wreh,eps1,eps2,Pstar,bfold) + lnRhoEnd = sr_lnrhoend_lf(p,Pstar) + + invars(11+2)=lnRhoReh + invars(12+2)=lnRhoEnd + invars(13+2)=bfold + + case ('smallf') + +!small field models cannot produce any eps1,eps2,eps3<=0 (out of prior) + if (.not.sr_checkobs_sf(eps1,eps2,eps3)) return + + buffer3d = sr_matterovermu_obs_sf(eps1,eps2,eps3) + + p = buffer3d(1) + mu = buffer3d(2) + wreh = wfix + + invars(14+2)=p + invars(15+2)=mu + + if ((p.gt.pmax).or.(p.lt.pmin)) return + + lnRhoReh = sr_lnrhoreh_sf(wreh,eps1,eps2,eps3,Pstar,bfold) + lnRhoEnd = sr_lnrhoend_sf(p,mu,Pstar) + + invars(11+2) = lnRhoReh + invars(12+2) = lnRhoEnd + invars(13+2) = bfold + + case default + + stop 'model not implemented!' + + end select + + endif +#endif +!end addon end subroutine MapParameters diff --git a/source/MCMC.f90 b/source/MCMC.f90 index 9c3285d..c731cb4 100644 --- a/source/MCMC.f90 +++ b/source/MCMC.f90 @@ -215,7 +215,7 @@ contains Like = GetLogLike(grid(r)) - if (Feedback > 1) write (*,*) r, 'Likelihood: ', Like, 'Current Like:', CurLike + if (Feedback > 1) write (*,*) r, 'Likelihood: ', Like, 'Current Like:', CurLike, 'Rank', MPIRank if ((Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike)) then !Accept @@ -501,7 +501,7 @@ function WL_Weight(L) result (W) output_lines = output_lines +1 call WriteParams(CurParams, real(mult), CurLike) end if - if (Feedback > 1) write (*,*) instance, 'Slicing, Current Like:', CurLike + if (Feedback > 1) write (*,*) instance, 'Slicing, Current Like:', CurLike, 'Rank', MPIRank mult = 1 if (num_slow /=0) call SliceSampleSlowParam(CurParams, CurLike) if (num_fast /=0) call SliceSampleFastParams(CurParams, CurLike) @@ -536,7 +536,7 @@ function WL_Weight(L) result (W) Like = GetLogLike(Trial) - if (Feedback > 1) write (*,*) 'Likelihood: ', Like, 'Current Like:', CurLike + if (Feedback > 1) write (*,*) 'Likelihood: ', Like, 'Current Like:', CurLike, 'Rank', MPIRank !!! accpt = (Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike) !Include the min() so that compilers not doing optimal compilation don't complain diff --git a/source/Makefile b/source/Makefile index 9f2ad5a..f0895c8 100644 --- a/source/Makefile +++ b/source/Makefile @@ -1,123 +1,83 @@ -#You may need to edit the library paths for MKL for Intel -#Beware of using optimizations that lose accuracy - may give errors when running - -##Uncomment the next line to include dr7 LRG -EXTDATA = -#EXTDATA = LRG - -#set WMAP empty not to compile with WMAP -WMAP = /home/aml1005/WMAP7/likelihood_v4 - -#Only needed for WMAP -cfitsio = /usr/local/cfitsio/intel10/64/3.040 - -#GSL only needed for DR7 LRG -GSLPATH = /home/aml1005/libs/gsl - -IFLAG = -I -INCLUDE= - -#Intel MPI (assuming mpif77 set to point to ifort) -#these settings for ifort 11.1 and higher; may need to add explicit link directory otherwise -#Can add -xHost if your cluster is uniform, or specify specific processor optimizations -x... -#If getdist gives segfaults remove openmp when compiling getdist -F90C = mpif90 -FFLAGS = -O3 -W0 -WB -openmp -fpp -DMPI -vec_report0 -mkl=parallel -LAPACKL = -lmpi - -#GFortran: defaults for v4.5; if pre v4.3 add -D__GFORTRAN__ -#F90C = gfortran -#in earlier versions use FFLAGS = -O2 -ffree-form -x f95-cpp-input -D__GFORTRAN__ -#FFLAGS = -O3 -fopenmp -ffree-form -x f95-cpp-input -ffast-math -march=native -funroll-loops -#LAPACKL = -Wl,-framework -Wl,accelerate -#commented above is (I think) for Mac; this is standard linux (sudo apt-get install liblapack-dev) -#LAPACKL = -lblas -llapack - -#HPCF settings. Use Intel 9 or 10.1+, not 10.0 -#F90C = mpif90 -#FFLAGS = -O2 -Vaxlib -W0 -WB -openmp -fpp -DMPI -vec_report0 -#LAPACKL = -L/usr/local/Cluster-Apps/intel/mkl/10.2.2.025/lib/em64t -lmkl_lapack -lmkl -lguide -lpthread -#GSLPATH = /usr/local/Cluster-Apps/gsl/1.9 -#cfitsio = /usr/local/Cluster-Users/cpac/cmb/2.1.0/cfitsio -#INCLUDE= - -#COSMOS: use "module load cosmolib latest" -#use "runCosmomc" (globally installed) to run, defining required memory usage -ifeq ($(COSMOHOST),cosmos) -F90C = ifort -FFLAGS = -openmp -fast -w -fpp2 -DMPI -LAPACKL = -mkl=sequential -lmkl_lapack -lmpi -cfitsio = $(CFITSIO) -WMAP = $(COSMOLIB)/WMAP7 -GSLPATH = $(GSL_ROOT) +# >>> DESIGNED FOR GMAKE <<< + +# Unified Systems makefile for COSMOMC +# Add FLAGS -DMPI for using MPI + +ext=$(shell uname | cut -c1-3) + +CC=cc + +ifeq ($(ext),IRI) +F90C= f90 +FFLAGS= -Ofast -mp -n32 -LANG:recursive=ON -lmpi -DMPI +WMAPFLAGS= $(FFLAGS) +LAPACKL = -lcomplib.sgimath_mp +INCLUDE = -I../camb +CFITSIODIR = +GSLDIR = endif -#Intel fortran 8, check you have the latest update from the Intel web pages -#See Makefile_intel for ifc 7.1 or lower (some versions have problems) -#F90C = ifort -#FFLAGS = -O2 -Vaxlib -ip -W0 -WB -openmp -fpp -#LAPACKL = -L/opt/intel/mkl61/lib/32 -lmkl_lapack -lmkl_ia32 -lguide -lpthread - -#G95; make sure LAPACK and MPI libs also compiled with g95 -#F90C = mpif90 -#FFLAGS = -O2 -cpp -DMPI -#LAPACKL = /LAPACK/lapack_LINUX.a /LAPACK/blas_LINUX.a - -#SGI, -mp toggles multi-processor. Use -O2 if -Ofast gives problems. -#Not various versions of the compiler are buggy giving erroneous seg faults with -mp. -#Version 7.3 is OK, currently version 7.4 is bugged, as are some earlier versions. -#F90C = f90 -#LAPACKL = -lcomplib.sgimath -#FFLAGS = -Ofast -mp - -#Digital/Compaq fortran, -omp toggles multi-processor -#F90C = f90 -#FFLAGS = -omp -O4 -arch host -math_library fast -tune host -fpe1 -#LAPACKL = -lcxml - -#Absoft ProFortran, single processor, set -cpu:[type] for your local system -#F90C = f95 -#FFLAGS = -O2 -s -cpu:athlon -lU77 -w -YEXT_NAMES="LCS" -YEXT_SFX="_" -#LAPACKL = -llapack -lblas -lg2c -#IFLAG = -p - -#NAGF95, single processor: -#F90C = f95 -#FFLAGS = -DNAGF95 -O3 -#LAPACKL = -llapack -lblas -lg2c - -#PGF90 -#F90C = pgf90 -#FFLAGS = -O2 -DESCAPEBACKSLASH -Mpreprocess -#LAPACKL = -llapack -lblas - - -#Sun, single processor: -#F90C = f90 -#FFLAGS = -fast -ftrap=%none -#LAPACKL = -lsunperf -lfsu -#LAPACKL = -lsunperf -lfsu -lsocket -lm -#IFLAG = -M - -#Sun MPI -#F90C = mpf90 -#FFLAGS = -O4 -openmp -ftrap=%none -dalign -DMPI -#LAPACKL = -lsunperf -lfsu -lmpi_mt -#IFLAG = -M - -#Sun parallel enterprise: -#F90C = f95 -#FFLAGS = -O4 -xarch=native64 -openmp -ftrap=%none -#LAPACKL = -lsunperf -lfsu -#IFLAG = -M - - -#IBM XL Fortran, multi-processor (run "module load lapack" then run "gmake") -# See also http://cosmocoffee.info/viewtopic.php?t=326 -#F90C = xlf90_r $(LAPACK) -#FFLAGS = -WF,-DIBMXL -qsmp=omp -qsuffix=f=f90:cpp=F90 -O3 -qstrict -qarch=pwr3 -qtune=pwr3 -#INCLUDE = -lessl -#LAPACKL = +ifeq ($(ext),Lin) +F90C=gfortran +FFLAGS= -O -cpp -fopenmp +WMAPFLAGS= -O +LAPACKL = -llapack -lblas +INCLUDE = -I../camb +CFITSIODIR = +GSLDIR = /usr +endif + +ifeq ($(ext),OSF) +F90C=f90 +FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1 +WMAPFLAGS= $(FFLAGS) +LAPACKL = -lcxml +INCLUDE = -I../camb +CFITSIODIR = +GSLDIR = +endif + +ifeq ($(ext),Sun) +F90C=f90 +FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none +WMAPFLAGS= $(FFLAGS) +LAPACKL = -lsunperf -lfsu +INCLUDE = -I../camb -M../camb +CFITSIODIR = +GSLDIR = +endif + +ifeq ($(ext),AIX) +F90C = mpxlf90_r +FFLAGS = -O4 -WF,-DIBMXL,-DMPI -qstrict -qsmp=omp -qmaxmem=-1 -qsuffix=f=f90:cpp=F90 +WMAPFLAGS= $(FFLAGS) +LAPACKL = -lessl +INCLUDE = -I../camb +CFITSIODIR = +GSLDIR = +endif + +EXTDATA = LRG +EXTINCLUDE = -I$(GSLDIR)/include +EXTOBJS = bsplinepk.o + + +WMAPDIR = ../WMAP +WMAPINCLUDE = -I$(CFITSIODIR)/include +WMAPOBJS = read_archive_map.o \ + read_fits.o \ + healpix_types.o \ + br_mod_dist.o \ + WMAP_7yr_options.o \ + WMAP_7yr_util.o \ + WMAP_7yr_gibbs.o \ + WMAP_7yr_tt_pixlike.o \ + WMAP_7yr_tt_beam_ptsrc_chisq.o \ + WMAP_7yr_teeebb_pixlike.o \ + WMAP_7yr_tetbeebbeb_pixlike.o \ + WMAP_7yr_likelihood.o + + PROPOSE = propose.o CLSFILE = CMB_Cls_simple.o @@ -125,51 +85,43 @@ CLSFILE = CMB_Cls_simple.o #Can use params_H if you prefer more generic parameters PARAMETERIZATION = params_CMB.o -F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(IFLAG)../camb $(INCLUDE) -LINKFLAGS = -L../camb -lcamb $(LAPACKL) +LINKFLAGS = -L../camb -lcamb -linf $(LAPACKL) + +F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(INCLUDE) -DISTFILES = ParamNames.o Matrix_utils.o settings.o IO.o GetDist.o +DISTFILES = utils.o ParamNames.o Matrix_utils.o settings.o IO.o GetDist.o -OBJFILES= ParamNames.o Matrix_utils.o settings.o IO.o cmbtypes.o Planck_like.o \ - cmbdata.o WeakLen.o bbn.o lrggettheory.o mpk.o bao.o supernovae.o HST.o SDSSLy-a-v3.o \ +OBJFILES = utils.o ParamNames.o Matrix_utils.o settings.o IO.o cmbtypes.o Planck_like.o \ + cmbdata.o WeakLen.o bbn.o lrggettheory.o mpk.o bao.o supernovae.o HST.o SDSSLy-a-v3.o\ $(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \ conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o - -ifeq ($(EXTDATA),LRG) +ifeq ($(EXTDATA),LRG) F90FLAGS += -DDR71RG -OBJFILES += bsplinepk.o -GSLINC = -I$(GSLPATH)/include -LINKFLAGS += -L$(GSLPATH)/lib -lgsl -lgslcblas -endif - -ifneq ($(WMAP),) -F90FLAGS += $(IFLAG)$(cfitsio)/include $(IFLAG)$(WMAP) -LINKFLAGS += -L$(cfitsio)/lib -L$(WMAP) -lcfitsio - -OBJFILES += $(WMAP)/read_archive_map.o \ - $(WMAP)/read_fits.o \ - $(WMAP)/healpix_types.o \ - $(WMAP)/WMAP_7yr_options.o \ - $(WMAP)/WMAP_7yr_util.o \ - $(WMAP)/WMAP_7yr_tt_pixlike.o \ - $(WMAP)/WMAP_7yr_teeebb_pixlike.o \ - $(WMAP)/WMAP_7yr_likelihood.o \ - $(WMAP)/WMAP_7yr_gibbs.o \ - $(WMAP)/WMAP_7yr_tt_beam_ptsrc_chisq.o \ - $(WMAP)/br_mod_dist.o +EXTINCLUDE = -I$(GSLDIR)/include +LINKFLAGS += -lgsl -lgslcblas +OBJFILES += $(EXTOBJS) +endif + +ifneq ($(WMAPDIR),) +F90FLAGS += $(WMAPINCLUDE) +LINKFLAGS += -lcfitsio +OBJFILES += $(WMAPOBJS) else F90FLAGS += -DNOWMAP endif -default: cosmomc -all : cosmomc getdist -settings.o: ../camb/libcamb.a +default: cosmomc.$(ext) + +all : cosmomc.$(ext) getdist.$(ext) + + +settings.o: utils.o cmbtypes.o: settings.o Planck_like.o: cmbtypes.o -cmbdata.o: Planck_like.o $(WMAPOBJS) +cmbdata.o: Planck_like.o $(WMAPOBJS) WeakLen.o: cmbtypes.o bbn.o: settings.o mpk.o: cmbtypes.o lrggettheory.o @@ -188,14 +140,20 @@ postprocess.o: calclike.o MCMC.o: calclike.o driver.o: MCMC.o -export FFLAGS -export F90C - .f.o: f77 $(F90FLAGS) -c $< %.o: %.c - $(CC) $(GSLINC) -c $*.c + $(CC) $(EXTINCLUDE) -c $*.c + +%.o: $(WMAPDIR)/%.f90 + $(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $< + +%.o: $(WMAPDIR)/%.F90 + $(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $< + +utils.o: ../camb/utils.F90 + $(F90C) $(F90FLAGS) -c $< %.o: %.f90 $(F90C) $(F90FLAGS) -c $*.f90 @@ -204,19 +162,14 @@ export F90C $(F90C) $(F90FLAGS) -c $*.F90 -cosmomc: camb $(OBJFILES) - $(F90C) -o ../cosmomc $(OBJFILES) $(LINKFLAGS) $(F90FLAGS) - +cosmomc.$(ext): $(OBJFILES) ../camb/libcamb.a ../camb/libinf.a + $(F90C) -o ../$@ $(OBJFILES) $(LINKFLAGS) $(F90FLAGS) -clean: cleancosmomc - rm -f ../camb/*.o ../camb/*.obj ../camb/*.mod -cleancosmomc: +clean: rm -f *.o *.mod *.d *.pc *.obj ../core +getdist.$(ext): $(DISTFILES) + $(F90C) -o ../$@ $(DISTFILES) $(LINKFLAGS) $(F90FLAGS) -getdist: camb $(DISTFILES) - $(F90C) -o ../getdist $(DISTFILES) $(LINKFLAGS) $(F90FLAGS) -camb: - cd ../camb && $(MAKE) --file=Makefile_main libcamb.a diff --git a/source/distparams.ini b/source/distparams.ini new file mode 100644 index 0000000..9101ee3 --- /dev/null +++ b/source/distparams.ini @@ -0,0 +1,126 @@ +#Params for "getdist" - for processing .txt chain information + +#if zero, columnnum calculated automatically as total number of columns +columnnum = 0 + +file_root = chains/test +out_root = +out_dir = +plot_data_dir = plot_data/ + +#if parameter_names empty set from file_root.paramnames if it exists +#otherwise set up labels manually in this file using lab1=... etc. +parameter_names = +#params_CMB.paramnames + + +#If generated chain at higher temperature can cool for computing results +cool = 1 + +#If 0 assume 1 and no chain filename prefixes +chain_num = 6 +first_chain = +exclude_chain = + +#width of Gaussian smoothing - Should check plots are robust to changes in +#this parameter. Narrow diagonal distributions need larger number +#Can also check plots by comparing with setting smoothing=F below +num_bins = 20 + +#For disgarding burn-in if using raw chains +#if < 1 interpreted as a fraction of the total number of rows (0.3 ignores first 30% of lines) +ignore_rows = 0.5 + +#if T produced B&W printer friendly output +B&W = F +#version of MatLab you are using +matlab_version = 7 + +#Switches; auto_label labels all parameters by their number +no_plots = F +no_tests = F +auto_label = F +#samples_are_chains = F can be useful for other samples when first two columns not present +samples_are_chains = T + +#Include these in 1D plots for comparison - must have same parameters +compare_num = 0 +compare1 = basic6_cmb + +plot_meanlikes = T +shade_meanlikes = T + +# if non-zero, output _thin file, thinned by thin_factor +thin_factor = 0 +#Do probabilistic importance sampling to single samples +make_single_samples = F +single_thin = 4 + +#Do simple importance sampling +adjust_priors = F +#Map parameters to other derived quantities +map_params = F + +#Use a Gaussian smoothing with width of the bin size +#Otherwise use top hat bins +smoothing = T + +num_contours = 2 +contour1 = 0.68 +contour2 = 0.95 + +do_minimal_1d_intervals = F + +#if we only want 2D plots agains a particular variable +plot_2D_param = 0 + +#if above zero, instead plot just these combinations: +#if both zero it will plot most correlated variables +plot_2D_num = 0 +plot1 = ns omegabh2 +plot2 = + +#number of sample plots, colored by third parameter +#if last parameter is 0 or -1 colored by the parameter most correlated +#with one of the eigenvector directions (e.g. parallel or orthogonal to degeneracy) +num_3D_plots = 1 +3D_plot1 = H0 omegam tau + +#Output 2D plots for param combos with 1D marginalized plots along the diagonal +triangle_plot = T + +#e.g. colormap('jet') +matlab_colscheme = + +#Parameters to use. If zero use all parameters which have lables. +plotparams_num = 0 +plotparams = omegabh2 omegadmh2 tau ns p mu nu q lnR Xend Xstop lnA asz + +#Get set label to empty to not include a parameter in the parameter_names file +#lab[asz]= + +#marker[x] adds vertical line to MatLab 1D plot +marker[nrun] = 0 + +#Need to give limits if prior cuts off distribution where not very small +limits[tau] = 0.01 N +limits[fnu] = 0 N +limits[w] = -1 N +limits[r]= 0 N +limits[asz] = 0 2 + +#all_limits sets all limitsxx for all variables to the same; can be useful for bins +all_limits = + +#compute two-tail marginalized limits irrespective of limits settings above +#(otherwise limits are two-tail only for those parameters without limits) +force_twotail = F + +#PCA - analysis output in file file_root.PCA +#number of parameter to do PCA for +PCA_num = 0 +PCA_normparam = omegam +#The parameters to use +PCA_params = omegam H0 tau +#L for log(x), M for log(-x), N for no log +PCA_func = LLL diff --git a/source/driver.F90 b/source/driver.F90 index 8188b94..60afbd3 100644 --- a/source/driver.F90 +++ b/source/driver.F90 @@ -58,12 +58,19 @@ program SolveCosmology end if #ifdef MPI - - if (instance /= 0) call DoAbort('With MPI should not have second parameter') +!fields +! if (instance /= 0) call DoAbort('With MPI should not have second parameter') + instance_shift=instance + write(*,*)'MPI file names shifted by: ',instance_shift +!end fields call mpi_comm_rank(mpi_comm_world,MPIrank,ierror) instance = MPIrank +1 !start at 1 for chains - write (numstr,*) instance +!fields + !write (numstr,*) instance + instance_shift = MPIrank + instance_shift + write (numstr,*) instance_shift +!end fields rand_inst = instance if (ierror/=MPI_SUCCESS) call DoAbort('MPI fail') @@ -104,7 +111,9 @@ program SolveCosmology HighAccuracyDefault = Ini_Read_Logical('high_accuracy_default',.false.) AccuracyLevel = Ini_Read_Real('accuracy_level',1.) - +!fields + InfModelName = Ini_Read_String('inflation_model') +!end fields if (Ini_HasKey('highL_unlensed_cl_template')) & highL_unlensed_cl_template= ReadIniFilename(DefIni,'highL_unlensed_cl_template') diff --git a/source/params_CMB.f90 b/source/params_CMB.f90 index a453def..5c5538c 100644 --- a/source/params_CMB.f90 +++ b/source/params_CMB.f90 @@ -46,7 +46,9 @@ !Mapping between array of power spectrum parameters and CAMB - subroutine SetCAMBInitPower(P,CMB,in) +!fields subroutine SetCAMBInitPower(P,CMB,in) + subroutine SetCAMBInitPower(P,CMB,in,inferror) + use infprec, only : kp use camb use settings use cmbtypes @@ -56,27 +58,70 @@ integer, intent(in) :: in + integer :: inferror - if (Power_Name == 'power_tilt') then + real(kp) :: Pstar - P%InitPower%k_0_scalar = pivot_k - P%InitPower%k_0_tensor = pivot_k - P%InitPower%ScalarPowerAmp(in) = cl_norm*CMB%norm(norm_As) - P%InitPower%rat(in) = CMB%norm(norm_amp_ratio) - - P%InitPower%an(in) = CMB%InitPower(1) - P%InitPower%ant(in) = CMB%InitPower(2) - P%InitPower%n_run(in) = CMB%InitPower(3) - if (inflation_consistency) then - P%InitPower%ant(in) = - CMB%norm(norm_amp_ratio)/8. - !note input n_T is ignored, so should be fixed (to anything) - end if - else + if (Power_Name /= 'power_inf') then stop 'params_CMB:Wrong initial power spectrum' - end if + endif + + P%InitPower%kstar = pivot_k + Pstar = cl_norm*CMB%norm(norm_As) + + +!fields + P%InitPower%infParam%conforms(1) = CMB%InitPower(1) + P%InitPower%infParam%matters(1) = CMB%InitPower(2) + +!power + P%InitPower%infParam%consts(2) = CMB%InitPower(3) + +!mu + P%InitPower%infParam%consts(3) = CMB%InitPower(4) + +!nu + P%InitPower%infParam%consts(4) = CMB%InitPower(5) + +!q + P%InitPower%infParam%consts(5) = CMB%InitPower(6) + +!changed below + P%InitPower%infParam%consts(1) = 1. + + P%InitPower%lnReheat = CMB%InitPower(7) + + +!field bound related + P%InitPower%infParam%consts(6) = CMB%InitPower(8) + +!field stop related + P%InitPower%infParam%consts(7) = CMB%InitPower(9) + + + call SetInfBg(P%InitPower,inferror) + if (inferror.ne.0) then + write(*,*)'SetCAMBInitPower: infbg out of prior',inferror + return + endif + + + call SetInfScalPow(P%InitPower,Pstar) + + call SetInfBgSpline(P%InitPower) + + + call SetInfCosmo(P%InitPower,inferror) + if (inferror.ne.0) then + write(*,*)'SetCAMBInitPower: inftorad out of prior',inferror + return + endif + end subroutine SetCAMBInitPower +!end fields + subroutine SetForH(Params,CMB,H0, firsttime) @@ -268,12 +313,18 @@ use settings use cmbtypes use ParamDef +!fields + use initialpower, only : exportinfprop,updateinfprop +!end fields use IO use Lists implicit none Type(ParamSet) P real, intent(in) :: mult, like Type(CMBParams) CMB +!fields + type(exportinfprop) :: infExport +!end fields real, allocatable :: output_array(:) Type(real_pointer) :: derived integer numderived @@ -289,8 +340,11 @@ else numderived = CalcDerivedParams(P, derived) - - allocate(output_array(num_real_params + numderived + nuisance_params_used )) +!fields + call UpdateInfProp(infExport) +! allocate(output_array(num_real_params + numderived + nuisance_params_used )) + allocate(output_array(num_real_params + numderived + nuisance_params_used +4)) +!end fields output_array(1:num_real_params) = P%P(1:num_real_params) output_array(num_real_params+1:num_real_params+numderived) = derived%P deallocate(derived%P) @@ -299,7 +353,14 @@ output_array(num_real_params+numderived+1:num_real_params+numderived+nuisance_params_used) = & P%P(num_real_params+1:num_real_params+nuisance_params_used) end if - +!fields + output_array(num_real_params+nuisance_params_used+numderived+1) & + = log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) + output_array(num_real_params+nuisance_params_used+numderived+2) & + = P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd + output_array(num_real_params+nuisance_params_used+numderived+3) = infExport%efoldEndToToday + output_array(num_real_params+nuisance_params_used+numderived+4) = infExport%lnEnergyEnd +!end fields call IO_OutputChainRow(outfile_handle, mult, like, output_array) deallocate(output_array) end if @@ -313,6 +374,9 @@ use settings use cmbtypes use ParamDef +!fields + use initialpower, only : exportinfprop,updateinfprop +!end fields use IO use Lists implicit none @@ -320,6 +384,9 @@ real, intent(in) :: mult, like character(LEN =30) fmt Type(CMBParams) CMB +!fields + type(exportinfprop) :: infExport +!end fields real,allocatable :: output_array(:) Type(real_pointer) :: derived integer numderived @@ -329,15 +396,25 @@ if (outfile_handle ==0) return numderived = CalcDerivedParams(P, derived) - - allocate(output_array(num_real_params + numderived + num_matter_power )) +!fields + call UpdateInfProp(infExport) +! allocate(output_array(num_real_params + numderived + num_matter_power )) + allocate(output_array(num_real_params + numderived + num_matter_power +4)) +!end fields output_array(1:num_real_params) = P%P(1:num_real_params) output_array(num_real_params+1:num_real_params+numderived) = derived%P deallocate(derived%P) output_array(num_real_params+numderived+1:num_real_params+numderived+num_matter_power) = & P%Info%Theory%matter_power(:,1) - +!fields + output_array(num_real_params+num_matter_power+numderived+1) & + = log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) + output_array(num_real_params+num_matter_power+numderived+2) & + = P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd + output_array(num_real_params+num_matter_power+numderived+3) = infExport%efoldEndToToday + output_array(num_real_params+num_matter_power+numderived+4) = infExport%lnEnergyEnd +!end fields call IO_OutputChainRow(outfile_handle, mult, like, output_array) deallocate(output_array) diff --git a/source/settings.f90 b/source/settings.f90 index 90d84d0..a7deff5 100644 --- a/source/settings.f90 +++ b/source/settings.f90 @@ -6,6 +6,7 @@ module settings implicit none real :: AccuracyLevel = 1. + character (len=6) :: InfModelName !Set to >1 to use CAMB etc on higher accuracy settings. !Does not affect MCMC (except making it all slower) @@ -19,7 +20,10 @@ module settings ! (e.g. beam uncertainty modes, etc, specific to dataset) integer, parameter :: num_hard =7 - integer, parameter :: num_initpower = 3 +!fields +! integer, parameter :: num_initpower = 3 + integer, parameter :: num_initpower = 9 +!end fields integer, parameter :: num_freq_params = 1 integer, parameter :: num_norm = 2 + num_freq_params integer, parameter :: num_nuisance_params= 0 @@ -66,6 +70,9 @@ module settings integer :: num_threads = 0 integer :: instance = 0 +!addon + integer :: instance_shift = 0 +!end addon integer :: MPIchains = 1, MPIrank = 0 logical :: Use_LSS = .true.