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 5295384..bc47965 100644 --- a/camb/Makefile +++ b/camb/Makefile @@ -1,77 +1,135 @@ -#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 ifc versions, some of which behave oddly - -#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 -O2 -ip -W0 -WB -fpp2 -vec_report0 -ifneq ($(FISHER),) -FFLAGS += -mkl +ifeq ($(ext),IRI) +F90C=f90 +FFLAGS = -Ofast=ip35 -n32 +LFLAGS= endif -#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 +ifeq ($(ext),Lin) +F90C=gfortran +FFLAGS= -O -fopenmp +LFLAGS= +endif -#Gfortran compiler: if pre v4.3 add -D__GFORTRAN__ -#F90C = gfortran -#FFLAGS = -O2 - -#SGI, -mp toggles multi-processor. Use -O2 if -Ofast gives problems. -#F90C = f90 -#FFLAGS = -Ofast -mp +ifeq ($(ext),OSF) +F90C=f90 +FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1 +LFLAGS= +endif -#Digital/Compaq fortran, -omp toggles multi-processor -#F90C = f90 -#FFLAGS = -omp -O4 -arch host -math_library fast -tune host -fpe1 +ifeq ($(ext),Sun) +F90C=f90 +FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none +LFLAGS= +endif -#Absoft ProFortran, single processor: -#F90C = f95 -#FFLAGS = -O2 -cpu:athlon -s -lU77 -w -YEXT_NAMES="LCS" -YEXT_SFX="_" +ifeq ($(ext),AIX) +F90C=xlf90_r +FFLAGS= -O4 -q64 -qsmp=omp -qmaxmem=-1 -qstrict -qfree=f90 -qsuffix=f=f90:cpp=F90 +LFLAGS= +endif -#NAGF95, single processor: -#F90C = f95 -#FFLAGS = -DNAGF95 -O3 -#PGF90 -#F90C = pgf90 -#FFLAGS = -O2 -DESCAPEBACKSLASH +#Files containing evolution equations initial power spectrum module +EQUATIONS = equations +POWERSPECTRUM = power_inf +REIONIZATION = reionization +RECOMBINATION = recfast +BISPECTRUM = SeparableBispectrum +DENABLE_FISHER = -#Sun V880 -#F90C = mpf90 -#FFLAGS = -O4 -openmp -ftrap=%none -dalign -DMPI +#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 -#Sun parallel enterprise: -#F90C = f95 -#FFLAGS = -O2 -xarch=native64 -openmp -ftrap=%none -#try removing -openmp if get bus errors. -03, -04 etc are dodgy. +#Module doing non-linear scaling +NONLINEAR = halofit -#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 +#Driver program +DRIVER = inidriver.F90 +#DRIVER = sigma8.f90 +#DRIVER = tester.f90 -#Settings for building camb_fits -#Location of FITSIO and name of library -FITSDIR = /home/cpac/cpac-tools/lib -FITSLIB = cfitsio #Location of HEALPIX for building camb_fits -HEALPIXDIR = /home/cpac/cpac-tools/healpix +HEALPIXDIR = /usr + +CAMBLIB = libcamb.a +INFLIB = libinf.a -ifneq ($(FISHER),) +ifneq ($(DENABLE_FISHER),) FFLAGS += -DFISHER +LFLAGS += -llapack -lblas EXTCAMBFILES = Matrix_utils.o else EXTCAMBFILES = endif -include ./Makefile_main \ No newline at end of file + +#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 f290c72..49ba51e 100644 --- a/camb/cmbmain.f90 +++ b/camb/cmbmain.f90 @@ -1938,12 +1938,17 @@ end if 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) end do - +!$omp end parallel do +!end fields end subroutine GetInitPowerArrayVec @@ -1951,11 +1956,16 @@ end if 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) end do - +!$omp end parallel do +!end fields end subroutine GetInitPowerArrayTens @@ -1971,7 +1981,11 @@ end if 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 @@ -1986,7 +2000,8 @@ end if end do - +!$omp end parallel do +!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 b67ce83..0d639c2 100644 --- a/camb/inidriver.F90 +++ b/camb/inidriver.F90 @@ -316,6 +316,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 95893cc..b6f9cf4 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/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 c30e575..12f2dc8 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 @@ -67,18 +67,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 @@ -142,7 +142,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}) pivot_k = 0.05 #If using tensors, enforce n_T = -A_T/(8A_s) @@ -159,6 +159,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 @@ -183,12 +186,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/source/CMB_Cls_simple.f90 b/source/CMB_Cls_simple.f90 index bb64245..bfdbf2e 100644 --- a/source/CMB_Cls_simple.f90 +++ b/source/CMB_Cls_simple.f90 @@ -133,8 +133,13 @@ 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 @@ -251,8 +256,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. @@ -465,6 +475,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 b4094ce..11fb2bf 100644 --- a/source/GetDist.f90 +++ b/source/GetDist.f90 @@ -104,6 +104,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 @@ -111,8 +137,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 @@ -124,6 +162,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) @@ -131,7 +377,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 d3219e8..9e8df0e 100644 --- a/source/Makefile +++ b/source/Makefile @@ -1,119 +1,83 @@ -#You may need to edit the library paths for MKL for Intel -#Beware of using optmizations 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 -F90C = mpif90 -FFLAGS = -O2 -ip -W0 -WB -openmp -fpp -DMPI -vec_report0 -mkl=parallel -LAPACKL = -lmkl_lapack - -#HPCF settings. Use Inteal 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 -O3 -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 + +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 -#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 - -#GFortran: if pre v4.3 add -D__GFORTRAN__ -#F90C = gfortran -#FFLAGS = -O2 -ffree-form -x f95-cpp-input -#LAPACKL = -Wl,-framework -Wl,accelerate -#may need to delete -Wl,accelerate, and/or add -shared - -#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 -#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 = +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 @@ -121,51 +85,45 @@ 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) -DISTFILES = ParamNames.o Matrix_utils.o settings.o IO.o GetDist.o +F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(INCLUDE) -OBJFILES= ParamNames.o Matrix_utils.o settings.o IO.o cmbtypes.o Planck_like.o \ - cmbdata.o WeakLen.o bbn.o bao.o lrggettheory.o mpk.o supernovae.o HST.o SDSSLy-a-v3.o \ +DISTFILES = utils.o ParamNames.o Matrix_utils.o settings.o IO.o GetDist.o + + + +OBJFILES = utils.o ParamNames.o Matrix_utils.o settings.o IO.o cmbtypes.o Planck_like.o \ + cmbdata.o WeakLen.o bbn.o bao.o lrggettheory.o mpk.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 bao.o: cmbtypes.o @@ -184,14 +142,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 @@ -200,19 +164,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 d5376fb..35e6ae8 100644 --- a/source/driver.F90 +++ b/source/driver.F90 @@ -56,12 +56,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') @@ -102,7 +109,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 dd29269..cfe72d7 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 @@ -64,6 +68,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.