- REFERENCES
-
- Some notes and relevant Maple derivations are given here (see also the Appendix of astro-ph/0406096). There is a BibTex file of references (including CosmoMC).
-
-
- Efficient computation of CMB anisotropies in closed FRW Models
- Antony Lewis, Anthony Challinor and Anthony Lasenby astro-ph/9911177 Ap. J. 538:473-476, 2000.
-
- Geometric Algebra and
- Covariant Methods in Physics and Cosmology, Chapters 6&7
- PhD thesis, Antony Lewis 2000. PostScript.
-
- Covariant theory
-
- Cosmic Microwave Background Anisotropies in the CDM model: A
- Covariant and Gauge-Invariant Approach
- Anthony Challinor and Anthony Lasenby, astro-ph/9804301
- Ap. J. 513:1 1-22, 1999
-
Evolution of cosmological dark matter perturbations
- Antony Lewis and Anthony Challinor astro-ph/0203507
- Phys. Rev. D66, 023531 (2002)
-
-
- Microwave background anisotropies from gravitational waves: the 1+3
- covariant approach
- Anthony Challinor, astro-ph/9906474
-
- Microwave background polarization in cosmological models
- Anthony Challinor, astro-ph/9911481
-
- CMB anisotropies from primordial inhomogeneous magnetic fields
- Antony Lewis, astro-ph/0406096
- (The appendix contains general derivations of the multipole equations and Cl as used in CAMB)
-
-
- Initial conditions
-
- The General Primordial Cosmic Perturbation
- Martin Bucher, Kavilan Moodley and Neil Turok, astro-ph/9904231
- (These results extended to the non-flat case; see the theory page)
-
-
- Observable primordial vector modes
- Antony Lewis, astro-ph/0403583
-
- HALOFIT
-
- Stable clustering, the halo model and nonlinear cosmological power spectra
- Smith, R. E. and others, astro-ph/0207664
-
- RECOMBINATION
-
- A new calculation of the recombination epoch.
- Seager, S., Sasselov, D. & Scott, D., 1999, ApJ, 523, L1, astro-ph/9909275.
-
- How well do we understand cosmological recombination?
- Wong, Wan Yan and Moss, Adam and Scott, Douglas, arXiv:0711.1357.
-
- Weak lensing of the CMB
-
-
- lensing_method=1
- Lensed CMB power spectra from all-sky correlation functions
- A. Challinor and A. Lewis. astro-ph/0502425. (For Maple derivations see the theory page.)
- Also: Weak Lensing of the CMB, astro-ph/0601594.
-
-
-
- lensing_method=2
- Gravitational lensing effect on cosmic microwave background
- anisotropies: A Power spectrum approach
- Uros Seljak. astro-ph/9505109
-
- Gravitational Lensing Effect on Cosmic Microwave Background
- Polarization
- Uros Seljak and Matias Zaldarriaga. astro-ph/9803150
-
- lensing_method=3
- Weak Lensing of the CMB: A Harmonic Approach
- Wayne Hu. astro-ph/0001303
- See also astro-ph/0301064, astro-ph/0301031
-
-
-
- Synchronous gauge theory and non-flat models
-
- Complete treatment of CMB anisotropies in a FRW universe
- Wayne Hu, Uros Seljak and Matias Zaldarriaga.
- Phys. Rev. D57:6, 3290-3301, 1998. astro-ph/9709066.
-
-
-
- WKB approx to hyperspherical Bessel functions
-
- Efficient Computation of Hyperspherical Bessel Functions
- Arthur Kosowsky, astro-ph/9805173
-
-
-
- CMBFAST and the line of sight approach
-
- A line of sight integration approach to Cosmic Microwave Background
- Anisotropies
- Uros Seljak and Matias Zaldarriaga, astro-ph/9603033
- Ap.J. 469:2 437-444, 1996
-
- CMBFAST for spatially closed universes
- Uros Seljak and Matias Zaldariaga, astro-ph/9911219
-
- See also the references on the CMBFAST home page.
-
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/recfast.f90 cosmomc_sampler/camb/recfast.f90
*** cosmomc/camb/recfast.f90 2010-01-27 12:03:27.000000000 +0100
--- cosmomc_sampler/camb/recfast.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,1293 ****
- !Recombination module for CAMB, using RECFAST
-
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- !C Integrator for Cosmic Recombination of Hydrogen and Helium,
- !C developed by Douglas Scott (dscott@astro.ubc.ca)
- !C based on calculations in the paper Seager, Sasselov & Scott
- !C (ApJ, 523, L1, 1999).
- !and "fudge" updates in Wong, Moss & Scott (2008).
- !C
- !C Permission to use, copy, modify and distribute without fee or royalty at
- !C any tier, this software and its documentation, for any purpose and without
- !C fee or royalty is hereby granted, provided that you agree to comply with
- !C the following copyright notice and statements, including the disclaimer,
- !C and that the same appear on ALL copies of the software and documentation,
- !C including modifications that you make for internal use or for distribution:
- !C
- !C Copyright 1999-2010 by University of British Columbia. All rights reserved.
- !C
- !C THIS SOFTWARE IS PROVIDED "AS IS", AND U.B.C. MAKES NO
- !C REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.
- !C BY WAY OF EXAMPLE, BUT NOT LIMITATION,
- !c U.B.C. MAKES NO REPRESENTATIONS OR WARRANTIES OF
- !C MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT
- !C THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT INFRINGE
- !C ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS.
- !C
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- !
- !CN Name: RECFAST
- !CV Version: 1.5
- !C
- !CP Purpose: Calculate ionised fraction as a function of redshift.
- !CP Solves for H and He simultaneously, and includes
- !CP H "fudge factor" for low z effect, as well as
- !CP HeI fudge factor.
- !C
- !CD Description: Solves for ionisation history since recombination
- !CD using the equations in Seager, Sasselov & Scott (ApJ, 1999).
- !CD The Cosmological model can be flat or open.
- !CD The matter temperature is also followed, with an update from
- !CD Scott & Scott (2009).
- !CD The values for \alpha_B for H are from Hummer (1994).
- !CD The singlet HeI coefficient is a fit from the full code.
- !CD Additional He "fudge factors" are as described in Wong, Moss
- !CD and Scott (2008).
- !CD Extra fitting function included (in optical depth) to account
- !CD for extra H physics described in Rubino-Martin et al. (2010).
- !CD Care is taken to use the most accurate constants.
- !C
- !CA Arguments:
- !CA Name, Description
- !CA real(dl) throughout
- !CA
- !CA z is redshift - W is sqrt(1+z), like conformal time
- !CA x is total ionised fraction, relative to H
- !CA x_H is ionized fraction of H - y(1) in R-K routine
- !CA x_He is ionized fraction of He - y(2) in R-K routine
- !CA (note that x_He=n_He+/n_He here and not n_He+/n_H)
- !CA Tmat is matter temperature - y(3) in R-K routine
- !CA f's are the derivatives of the Y's
- !CA alphaB is case B recombination rate
- !CA alpHe is the singlet only HeII recombination rate
- !CA a_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
- !CA b_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
- !CA c_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
- !CA d_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
- !CA a_VF is Verner and Ferland type fitting parameter for Helium
- !CA b_VF is Verner and Ferland type fitting parameter for Helium
- !CA T_0 is Verner and Ferland type fitting parameter for Helium
- !CA T_1 is Verner and Ferland type fitting parameter for Helium
- !CA Tnow is the observed CMB temperature today
- !CA Yp is the primordial helium abundace
- !CA fHe is He/H number ratio = Yp/4(1-Yp)
- !CA Trad and Tmat are radiation and matter temperatures
- !CA epsilon is the approximate difference (=Trad-Tmat) at high z
- !CA OmegaB is Omega in baryons today
- !CA H is Hubble constant in units of 100 km/s/Mpc
- !CA HO is Hubble constant in SI units
- !CA bigH is 100 km/s/Mpc in SI units
- !CA Hz is the value of H at the specific z (in ION)
- !CA G is grvitational constant
- !CA n is number density of hydrogen
- !CA Nnow is number density today
- !CA x0 is initial ionized fraction
- !CA x_H0 is initial ionized fraction of Hydrogen
- !CA x_He0 is initial ionized fraction of Helium
- !CA rhs is dummy for calculating x0
- !CA zinitial and zfinal are starting and ending redshifts
- !CA zeq is the redshift of matter-radiation equality
- !CA zstart and zend are for each pass to the integrator
- !CA C,k_B,h_P: speed of light, Boltzmann's and Planck's constants
- !CA m_e,m_H: electron mass and mass of H atom in SI
- !CA not4: ratio of 4He atomic mass to 1H atomic mass
- !CA sigma: Thomson cross-section
- !CA a_rad: radiation constant for u=aT^4
- !CA Lambda: 2s-1s two photon rate for Hydrogen
- !CA Lambda_He: 2s-1s two photon rate for Helium
- !CA DeltaB: energy of first excited state from continuum = 3.4eV
- !CA DeltaB_He: energy of first excited state from cont. for He = 3.4eV
- !CA L_H_ion: level for H ionization in m^-1
- !CA L_H_alpha: level for H Ly alpha in m^-1
- !CA L_He1_ion: level for HeI ionization
- !CA L_He2_ion: level for HeII ionization
- !CA L_He_2s: level for HeI 2s
- !CA L_He_2p: level for HeI 2p (21P1-11S0) in m^-1
- !CA Lalpha: Ly alpha wavelength in SI
- !CA Lalpha_He: Helium I 2p-1s wavelength in SI
- !CA mu_H,mu_T: mass per H atom and mass per particle
- !CA H_frac: follow Tmat when t_Compton / t_Hubble > H_frac
- !CA CDB=DeltaB/k_B Constants derived from B1,B2,R
- !CA CDB_He=DeltaB_He/k_B n=2-infinity for He in Kelvin
- !CA CB1=CDB*4. Lalpha and sigma_Th, calculated
- !CA CB1_He1: CB1 for HeI ionization potential
- !CA CB1_He2: CB1 for HeII ionization potential
- !CA CR=2*Pi*(m_e/h_P)*(k_B/h_P) once and passed in a common block
- !CA CK=Lalpha**3/(8.*Pi)
- !CA CK_He=Lalpha_He**3/(8.*Pi)
- !CA CL=C*h_P/(k_B*Lalpha)
- !CA CL_He=C*h_P/(k_B*Lalpha_He)
- !CA CT=(8./3.)*(sigma/(m_e*C))*a
- !CA Bfact=exp((E_2p-E_2s)/kT) Extra Boltzmann factor
- !CA b_He= "fudge factor" for HeI, to approximate higher z behaviour
- !CA Heswitch=integer for modifying HeI recombination
- !CA Parameters and quantities to describe the extra triplet states
- !CA and also the continuum opacity of H, with a fitting function
- !CA suggested by KIV, astro-ph/0703438
- !CA a_trip: used to fit HeI triplet recombination rate
- !CA b_trip: used to fit HeI triplet recombination rate
- !CA L_He_2Pt: level for 23P012-11S0 in m^-1
- !CA L_He_2St: level for 23S1-11S0 in m^-1
- !CA L_He2St_ion: level for 23S1-continuum in m^-1
- !CA A2P_s: Einstein A coefficient for He 21P1-11S0
- !CA A2P_t: Einstein A coefficient for He 23P1-11S0
- !CA sigma_He_2Ps: H ionization x-section at HeI 21P1-11S0 freq. in m^2
- !CA sigma_He_2Pt: H ionization x-section at HeI 23P1-11S0 freq. in m^2
- !CA CL_PSt = h_P*C*(L_He_2Pt - L_He_2st)/k_B
- !CA CfHe_t: triplet statistical correction
- !CA Hswitch is an boolean for modifying the H recombination
- !CA AGauss1 is the amplitude of the 1st Gaussian for the H fudging
- !CA AGauss2 is the amplitude of the 2nd Gaussian for the H fudging
- !CA zGauss1 is the ln(1+z) central value of the 1st Gaussian
- !CA zGauss2 is the ln(1+z) central value of the 2nd Gaussian
- !CA wGauss1 is the width of the 1st Gaussian
- !CA wGauss2 is the width of the 2nd Gaussian
-
-
- !CA tol: tolerance for the integrator
- !CA cw(24),w(3,9): work space for DVERK
- !CA Ndim: number of d.e.'s to solve (integer)
- !CA Nz: number of output redshitf (integer)
- !CA I: loop index (integer)
- !CA ind,nw: work-space for DVERK (integer)
- !C
- !CF File & device access:
- !CF Unit /I,IO,O /Name (if known)
- !C
- !CM Modules called:
- !CM DVERK (numerical integrator)
- !CM GET_INIT (initial values for ionization fractions)
- !CM ION (ionization and Temp derivatives)
- !C
- !CC Comments:
- !CC none
- !C
- !CH History:
- !CH CREATED (simplest version) 19th March 1989
- !CH RECREATED 11th January 1995
- !CH includes variable Cosmology
- !CH uses DVERK integrator
- !CH initial conditions are Saha
- !CH TESTED a bunch, well, OK, not really
- !CH MODIFIED January 1995 (include Hummer's 1994 alpha table)
- !CH January 1995 (include new value for 2s-1s rate)
- !CH January 1995 (expand comments)
- !CH March 1995 (add Saha for Helium)
- !CH August 1997 (add HeII alpha table)
- !CH July 1998 (include OmegaT correction and H fudge factor)
- !CH Nov 1998 (change Trad to Tmat in Rup)
- !CH Jan 1999 (tidied up for public consumption)
- !CH Sept 1999 (switch to formula for alpha's, fix glitch)
- !CH Sept 1999 modified to CMBFAST by US & MZ
- !CH Nov 1999 modified for F90 and CAMB (AML)
- !CH Aug 2000 modified to prevent overflow erorr in He_Boltz (AML)
- !CH Feb 2001 corrected fix of Aug 2000 (AML)
- !CH Oct 2001 fixed error in hubble parameter, now uses global function (AML)
- ! March 2003 fixed bugs reported by savita gahlaut
- ! March 2005 added option for corrections from astro-ph/0501672.
- ! thanks to V.K.Dubrovich, S.I.Grachev
- ! June 2006 defined RECFAST_fudge as free parameter (AML)
- ! October 2006 (included new value for G)
- ! October 2006 (improved m_He/m_H to be "not4")
- ! October 2006 (fixed error, x for x_H in part of f(1))
- !CH January 2008 (improved HeI recombination effects,
- !CH including HeI rec. fudge factor)
- ! Feb 2008 Recfast 1.4 changes above added (AML)
- ! removed Dubrovich option (wrong anyway)
- !CH Sept 2008 (added extra term to make transition, smoother for Tmat evolution)
- ! Sept 2008 Recfast 1.4.2 changes above added (AML)
- ! General recombination module structure, fix to make He x_e smooth also in recfast (AML)
- !CH Jan 2010 (added fitting function to modify K
- !CH to match x_e(z) for new H physics)
-
- !! ===============================================================
-
- module RECDATA
- use constants
- implicit none
-
-
- real(dl) Lambda,DeltaB,DeltaB_He,Lalpha,mu_H,mu_T,H_frac
- real(dl) Lambda_He,Lalpha_He,Bfact,CK_He,CL_He
- real(dl) L_H_ion,L_H_alpha,L_He1_ion,L_He2_ion,L_He_2s,L_He_2p
- real(dl) CB1,CDB,CR,CK,CL,CT,CB1_He1,CB1_He2,CDB_He,fu
- real(dl) A2P_s,A2P_t,sigma_He_2Ps,sigma_He_2Pt
- real(dl) L_He_2Pt,L_He_2St,L_He2St_ion
-
-
- real(dl), parameter :: bigH=100.0D3/Mpc !Ho in s-1
- real(dl), parameter :: sigma = sigma_thomson
- real(dl), parameter :: not4 = mass_ratio_He_H !mass He/H atom
-
- real(dl) Tnow,HO
- integer :: n_eq = 3
-
- !The following only used for approximations where small effect
- real(dl) OmegaK, OmegaT, z_eq
-
-
- !Fundamental constants in SI units
- ! ("not4" pointed out by Gary Steigman)
-
- data Lambda /8.2245809d0/
- data Lambda_He /51.3d0/ !new value from Dalgarno
- data L_H_ion /1.096787737D7/ !level for H ion. (in m^-1)
- data L_H_alpha /8.225916453D6/ !averaged over 2 levels
- data L_He1_ion /1.98310772D7/ !from Drake (1993)
- data L_He2_ion /4.389088863D7/ !from JPhysChemRefData (1987)
- data L_He_2s /1.66277434D7/ !from Drake (1993)
- data L_He_2p /1.71134891D7/ !from Drake (1993)
- ! 2 photon rates and atomic levels in SI units
-
- data A2P_s /1.798287D9/ !Morton, Wu & Drake (2006)
- data A2P_t /177.58D0/ !Lach & Pachuski (2001)
- data L_He_2Pt /1.690871466D7/ !Drake & Morton (2007)
- data L_He_2St /1.5985597526D7/ !Drake & Morton (2007)
- data L_He2St_ion /3.8454693845D6/ !Drake & Morton (2007)
- data sigma_He_2Ps /1.436289D-22/ !Hummer & Storey (1998)
- data sigma_He_2Pt /1.484872D-22/ !Hummer & Storey (1998)
- ! Atomic data for HeI
-
-
- end module RECDATA
-
-
- module Recombination
- use constants
- use AMLUtils
- implicit none
- private
-
- real(dl), parameter :: zinitial = 1e4_dl !highest redshift
- real(dl), parameter :: zfinal=0._dl
- integer, parameter :: Nz=10000
- real(dl), parameter :: delta_z = (zinitial-zfinal)/Nz
-
- integer, parameter :: RECFAST_Heswitch_default = 6
- real(dl), parameter :: RECFAST_fudge_He_default = 0.86_dl !Helium fudge parameter
- logical, parameter :: RECFAST_Hswitch_default = .true. !include H corrections (v1.5, 2010)
- real(dl), parameter :: RECFAST_fudge_default = 1.14_dl
- real(dl), parameter :: RECFAST_fudge_default2 = 1.105d0
- !fudge parameter if RECFAST_Hswitch
-
- real(dl), parameter :: AGauss1 = -0.14D0 !Amplitude of 1st Gaussian
- real(dl), parameter :: AGauss2 = 0.05D0 !Amplitude of 2nd Gaussian
- real(dl), parameter :: zGauss1 = 7.28D0 !ln(1+z) of 1st Gaussian
- real(dl), parameter :: zGauss2= 6.75D0 !ln(1+z) of 2nd Gaussian
- real(dl), parameter :: wGauss1= 0.18D0 !Width of 1st Gaussian
- real(dl), parameter :: wGauss2= 0.33D0 !Width of 2nd Gaussian
- ! Gaussian fits for extra H physics (fit by Adam Moss)
-
- type RecombinationParams
-
- real(dl) :: RECFAST_fudge
- real(dl) :: RECFAST_fudge_He
- integer :: RECFAST_Heswitch
- logical :: RECFAST_Hswitch
- !0) no change from old Recfast'
- !1) full expression for escape probability for singlet'
- !' 1P-1S transition'
- !2) also including effect of contiuum opacity of H on HeI'
- !' singlet (based in fitting formula suggested by'
- !' Kholupenko, Ivanchik & Varshalovich, 2007)'
- !3) only including recombination through the triplets'
- !4) including 3 and the effect of the contiuum '
- !' (although this is probably negligible)'
- !5) including only 1, 2 and 3'
- !6) including all of 1 to 4'
-
- end type RecombinationParams
-
- character(LEN=*), parameter :: Recombination_Name = 'Recfast_1.5'
-
- real(dl) zrec(Nz),xrec(Nz),dxrec(Nz), Tsrec(Nz) ,dTsrec(Nz), tmrec(Nz),dtmrec(Nz)
-
- real(dl), parameter :: Do21cm_mina = 1/(1+900.) !at which to start evolving Delta_TM
- logical, parameter :: evolve_Ts = .false. !local equilibrium is very accurate
- real(dl), parameter :: Do21cm_minev = 1/(1+400.) !at which to evolve T_s
-
-
- real(dl), parameter :: B01 = 3*B10
- real(dl) :: NNow, fHe
-
-
- logical :: Do21cm = .false.
- logical :: doTmatTspin = .false.
-
- real(dl) :: recombination_saha_z !Redshift at which saha OK
- real(dl) :: recombination_saha_tau !set externally
-
-
- public RecombinationParams, Recombination_xe, Recombination_tm,Recombination_ts ,Recombination_init, &
- Recombination_ReadParams, Recombination_SetDefParams, Recombination_Validate, Recombination_Name, &
- kappa_HH_21cm,kappa_eH_21cm,kappa_pH_21cm, &
- Do21cm, doTmatTspin, Do21cm_mina, dDeltaxe_dtau, &
- recombination_saha_tau, recombination_saha_z
-
- contains
-
-
-
- subroutine Recombination_ReadParams(R, Ini)
- use IniFile
- Type(RecombinationParams) :: R
- Type(TIniFile) :: Ini
-
-
- R%RECFAST_fudge_He = Ini_Read_Double_File(Ini,'RECFAST_fudge_He',RECFAST_fudge_He_default)
- R%RECFAST_Heswitch = Ini_Read_Int_File(Ini, 'RECFAST_Heswitch',RECFAST_Heswitch_default)
- R%RECFAST_Hswitch = Ini_Read_Logical_File(Ini, 'RECFAST_Hswitch',RECFAST_Hswitch_default)
- R%RECFAST_fudge = Ini_Read_Double_File(Ini,'RECFAST_fudge',RECFAST_fudge_default)
- if (R%RECFAST_Hswitch) then
- R%RECFAST_fudge = R%RECFAST_fudge - (RECFAST_fudge_default - RECFAST_fudge_default2)
- end if
- end subroutine Recombination_ReadParams
-
- subroutine Recombination_SetDefParams(R)
- type (RecombinationParams) ::R
-
-
- R%RECFAST_fudge = RECFAST_fudge_default
- R%RECFAST_fudge_He = RECFAST_fudge_He_default !Helium fudge parameter
- R%RECFAST_Heswitch = RECFAST_Heswitch_default
- R%RECFAST_Hswitch = RECFAST_Hswitch_default
- if (R%RECFAST_Hswitch) then
- R%RECFAST_fudge = R%RECFAST_fudge - (RECFAST_fudge_default - RECFAST_fudge_default2)
- end if
-
- end subroutine Recombination_SetDefParams
-
-
- subroutine Recombination_Validate(R, OK)
- Type(RecombinationParams),intent(in) :: R
- logical, intent(inout) :: OK
-
- if (R%RECFAST_Heswitch<0 .or. R%RECFAST_Heswitch > 6) then
- OK = .false.
- write(*,*) 'RECFAST_Heswitch unknown'
- end if
-
- end subroutine Recombination_Validate
-
-
- function Recombination_tm(a)
- use RECDATA, only : Tnow
- real(dl) zst,a,z,az,bz,Recombination_tm
- integer ilo,ihi
-
- if (.not. doTmatTspin) stop 'RECFAST: Recombination_tm not stored'
- z=1/a-1
- if (z >= zrec(1)) then
- Recombination_tm=Tnow/a
- else
- if (z <=zrec(nz)) then
- Recombination_tm=Tmrec(nz)
- else
- zst=(zinitial-z)/delta_z
- ihi= int(zst)
- ilo = ihi+1
- az=zst - int(zst)
- bz=1-az
- Recombination_tm=az*Tmrec(ilo)+bz*Tmrec(ihi)+ &
- ((az**3-az)*dTmrec(ilo)+(bz**3-bz)*dTmrec(ihi))/6._dl
- endif
- endif
-
- end function Recombination_tm
-
-
- function Recombination_ts(a)
- !zrec(1) is zinitial-delta_z
- real(dl), intent(in) :: a
- real(dl) zst,z,az,bz,Recombination_ts
- integer ilo,ihi
-
- z=1/a-1
- if (z.ge.zrec(1)) then
- Recombination_ts=tsrec(1)
- else
- if (z.le.zrec(nz)) then
- Recombination_ts=tsrec(nz)
- else
- zst=(zinitial-z)/delta_z
- ihi= int(zst)
- ilo = ihi+1
- az=zst - int(zst)
- bz=1-az
-
- Recombination_ts=az*tsrec(ilo)+bz*tsrec(ihi)+ &
- ((az**3-az)*dtsrec(ilo)+(bz**3-bz)*dtsrec(ihi))/6._dl
- endif
- endif
-
- end function Recombination_ts
-
-
- function Recombination_xe(a)
- real(dl), intent(in) :: a
- real(dl) zst,z,az,bz,Recombination_xe
- integer ilo,ihi
-
- z=1/a-1
- if (z.ge.zrec(1)) then
- Recombination_xe=xrec(1)
- else
- if (z.le.zrec(nz)) then
- Recombination_xe=xrec(nz)
- else
- zst=(zinitial-z)/delta_z
- ihi= int(zst)
- ilo = ihi+1
- az=zst - int(zst)
- bz=1-az
- Recombination_xe=az*xrec(ilo)+bz*xrec(ihi)+ &
- ((az**3-az)*dxrec(ilo)+(bz**3-bz)*dxrec(ihi))/6._dl
- endif
- endif
-
- end function Recombination_xe
-
-
-
- subroutine Recombination_init(Recomb, OmegaC, OmegaB, Omegan, Omegav, h0inp,tcmb,yp)
- !Would love to pass structure as arguments, but F90 would give circular reference...
- !hence mess passing parameters explcitly and non-generally
- !Note recfast only uses OmegaB, h0inp, tcmb and yp - others used only for Tmat approximation where effect small
- use RECDATA
- use AMLUtils
- implicit none
- Type (RecombinationParams) :: Recomb
-
- real(dl), save :: last_OmB =0, Last_YHe=0, Last_H0=0, Last_dtauda=0, last_fudge, last_fudgeHe
-
- real(dl) Trad,Tmat,Tspin,d0hi,d0lo
- integer I
-
- real(dl) OmegaB,OmegaC, Omegan, Omegav, H
- real(dl) z,n,x,x0,rhs,x_H,x_He,x_H0,x_He0,h0inp
- real(dl) zstart,zend,tcmb
- real(dl) cw(24)
- real(dl), dimension(:,:), allocatable :: w
- real(dl) y(4)
- real(dl) yp
- real(dl) C10, tau_21Ts
- real(dl) fnu
- integer ind,nw
-
- ! --- Parameter statements
- real(dl), parameter :: tol=1.D-5 !Tolerance for R-K
-
- real(dl) dtauda
- external dtauda, dverk
-
- ! ===============================================================
-
- if (Last_OmB==OmegaB .and. Last_H0 == h0inp .and. yp == Last_YHe .and. &
- dtauda(0.2352375823_dl) == Last_dtauda .and. last_fudge == Recomb%RECFAST_fudge &
- .and. last_fudgeHe==Recomb%RECFAST_fudge_He) return
- !This takes up most of the single thread time, so cache if at all possible
- !For example if called with different reionization, or tensor rather than scalar
-
- Last_dtauda = dtauda(0.2352375823_dl) !Just get it at a random scale factor
- Last_OmB = OmegaB
- Last_H0 = h0inp
- Last_YHe=yp
- last_fudge = Recomb%RECFAST_FUDGE
- last_fudgeHe = Recomb%RECFAST_FUDGE_He
-
- if (Do21cm) doTmatTspin = .true.
-
-
- ! write(*,*)'recfast version 1.0'
- ! write(*,*)'Using Hummer''s case B recombination rates for H'
- ! write(*,*)' with fudge factor = 1.14'
- ! write(*,*)'and tabulated HeII singlet recombination rates'
- ! write(*,*)
-
- n_eq = 3
- if (Evolve_Ts) n_eq=4
- allocate(w(n_eq,9))
-
- recombination_saha_z=0.d0
-
- Tnow=tcmb
- ! These are easy to inquire as input, but let's use simple values
- z = zinitial
- ! will output every 1 in z, but this is easily changed also
-
- !Not general, but only for approx
- OmegaT=OmegaC+OmegaB !total dark matter + baryons
- OmegaK=1.d0-OmegaT-OmegaV !curvature
-
-
- ! convert the Hubble constant units
- H = H0inp/100._dl
- HO = H*bigH
-
-
- ! sort out the helium abundance parameters
- mu_H = 1.d0/(1.d0-Yp) !Mass per H atom
- mu_T = not4/(not4-(not4-1.d0)*Yp) !Mass per atom
- fHe = Yp/(not4*(1.d0-Yp)) !n_He_tot / n_H_tot
-
-
- Nnow = 3._dl*HO*HO*OmegaB/(8._dl*Pi*G*mu_H*m_H)
-
- n = Nnow * (1._dl+z)**3
- fnu = (21.d0/8.d0)*(4.d0/11.d0)**(4.d0/3.d0)
- ! (this is explictly for 3 massless neutrinos - change if N_nu.ne.3; but only used for approximation so not critical)
- z_eq = (3.d0*(HO*C)**2/(8.d0*Pi*G*a_rad*(1.d0+fnu)*Tnow**4))*(OmegaB+OmegaC)
- z_eq = z_eq - 1.d0
-
-
- ! Set up some constants so they don't have to be calculated later
- Lalpha = 1.d0/L_H_alpha
- Lalpha_He = 1.d0/L_He_2p
- DeltaB = h_P*C*(L_H_ion-L_H_alpha)
- CDB = DeltaB/k_B
- DeltaB_He = h_P*C*(L_He1_ion-L_He_2s) !2s, not 2p
- CDB_He = DeltaB_He/k_B
- CB1 = h_P*C*L_H_ion/k_B
- CB1_He1 = h_P*C*L_He1_ion/k_B !ionization for HeI
- CB1_He2 = h_P*C*L_He2_ion/k_B !ionization for HeII
- CR = 2.d0*Pi*(m_e/h_P)*(k_B/h_P)
- CK = Lalpha**3/(8.d0*Pi)
- CK_He = Lalpha_He**3/(8.d0*Pi)
- CL = C*h_P/(k_B*Lalpha)
- CL_He = C*h_P/(k_B/L_He_2s) !comes from det.bal. of 2s-1s
- CT = Compton_CT / MPC_in_sec
-
- Bfact = h_P*C*(L_He_2p-L_He_2s)/k_B
-
-
- ! Matter departs from radiation when t(Th) > H_frac * t(H)
- ! choose some safely small number
- H_frac = 1D-3
-
- ! Fudge factor to approximate for low z out of equilibrium effect
- fu=Recomb%RECFAST_fudge
-
- ! Set initial matter temperature
- y(3) = Tnow*(1._dl+z) !Initial rad. & mat. temperature
- Tmat = y(3)
- y(4) = Tmat
- Tspin = Tmat
-
- call get_init(z,x_H0,x_He0,x0)
-
- y(1) = x_H0
- y(2) = x_He0
-
- ! OK that's the initial conditions, now start writing output file
-
-
- ! Set up work-space stuff for DVERK
- ind = 1
- nw = n_eq
- do i = 1,24
- cw(i) = 0._dl
- end do
-
- do i = 1,Nz
- ! calculate the start and end redshift for the interval at each z
- ! or just at each z
- zstart = zinitial - real(i-1,dl)*delta_z
- zend = zinitial - real(i,dl)*delta_z
-
- ! Use Saha to get x_e, using the equation for x_e for ionized helium
- ! and for neutral helium.
- ! Everything ionized above z=8000. First ionization over by z=5000.
- ! Assume He all singly ionized down to z=3500, then use He Saha until
- ! He is 99% singly ionized, and *then* switch to joint H/He recombination.
-
- z = zend
-
- if (zend > 8000._dl) then
-
- x_H0 = 1._dl
- x_He0 = 1._dl
- x0 = 1._dl+2._dl*fHe
- y(1) = x_H0
- y(2) = x_He0
- y(3) = Tnow*(1._dl+z)
- y(4) = y(3)
-
- else if(z > 5000._dl)then
-
- x_H0 = 1._dl
- x_He0 = 1._dl
- rhs = exp( 1.5d0 * log(CR*Tnow/(1._dl+z)) &
- - CB1_He2/(Tnow*(1._dl+z)) ) / Nnow
- rhs = rhs*1._dl !ratio of g's is 1 for He++ <-> He+
- x0 = 0.5d0 * ( sqrt( (rhs-1._dl-fHe)**2 &
- + 4._dl*(1._dl+2._dl*fHe)*rhs) - (rhs-1._dl-fHe) )
- y(1) = x_H0
- y(2) = x_He0
- y(3) = Tnow*(1._dl+z)
- y(4) = y(3)
-
- else if(z > 3500._dl)then
-
- x_H0 = 1._dl
- x_He0 = 1._dl
- x0 = x_H0 + fHe*x_He0
- y(1) = x_H0
- y(2) = x_He0
- y(3) = Tnow*(1._dl+z)
- y(4) = y(3)
-
- else if(y(2) > 0.99)then
-
- x_H0 = 1._dl
- rhs = exp( 1.5d0 * log(CR*Tnow/(1._dl+z)) &
- - CB1_He1/(Tnow*(1._dl+z)) ) / Nnow
- rhs = rhs*4._dl !ratio of g's is 4 for He+ <-> He0
- x_He0 = 0.5d0 * ( sqrt( (rhs-1._dl)**2 &
- + 4._dl*(1._dl+fHe)*rhs )- (rhs-1._dl))
- x0 = x_He0
- x_He0 = (x0 - 1._dl)/fHe
- y(1) = x_H0
- y(2) = x_He0
- y(3) = Tnow*(1._dl+z)
- y(4) = y(3)
-
- else if (y(1) > 0.99d0) then
-
- rhs = exp( 1.5d0 * log(CR*Tnow/(1._dl+z)) &
- - CB1/(Tnow*(1._dl+z)) ) / Nnow
- x_H0 = 0.5d0 * (sqrt( rhs**2+4._dl*rhs ) - rhs )
-
- call DVERK(Recomb,3,ION,zstart,y,zend,tol,ind,cw,nw,w)
- y(1) = x_H0
- x0 = y(1) + fHe*y(2)
- y(4)=y(3)
- else
-
- call DVERK(Recomb,nw,ION,zstart,y,zend,tol,ind,cw,nw,w)
-
- x0 = y(1) + fHe*y(2)
-
- end if
-
- Trad = Tnow * (1._dl+zend)
- Tmat = y(3)
- x_H = y(1)
- x_He = y(2)
- x = x0
-
- zrec(i)=zend
- xrec(i)=x
-
-
- if (doTmatTspin) then
- if (Evolve_Ts .and. zend< 1/Do21cm_minev-1 ) then
- Tspin = y(4)
- else
- C10 = Nnow * (1._dl+zend)**3*(kappa_HH_21cm(Tmat,.false.)*(1-x_H) + kappa_eH_21cm(Tmat,.false.)*x)
- tau_21Ts = line21_const*NNow*(1+zend)*dtauda(1/(1+zend))/1000
-
- Tspin = Trad*( C10/Trad + A10/T_21cm)/(C10/Tmat + A10/T_21cm) + &
- tau_21Ts/2*A10*( 1/(C10*T_21cm/Tmat+A10) - 1/(C10*T_21cm/Trad+A10) )
-
- y(4) = Tspin
- end if
-
- tsrec(i) = Tspin
- tmrec(i) = Tmat
-
- end if
-
- ! write (*,'(5E15.5)') zend, Trad, Tmat, Tspin, x
-
- end do
-
- d0hi=1.0d40
- d0lo=1.0d40
- call spline(zrec,xrec,nz,d0lo,d0hi,dxrec)
- if (doTmatTspin) then
- call spline(zrec,tsrec,nz,d0lo,d0hi,dtsrec)
- call spline(zrec,tmrec,nz,d0lo,d0hi,dtmrec)
- end if
- deallocate(w)
-
- end subroutine Recombination_init
-
- ! ===============================================================
- subroutine GET_INIT(z,x_H0,x_He0,x0)
-
- ! Set up the initial conditions so it will work for general,
- ! but not pathological choices of zstart
- ! Initial ionization fraction using Saha for relevant species
- use RECDATA
- implicit none
-
-
- real(dl) z,x0,rhs,x_H0,x_He0
-
-
- if(z > 8000._dl)then
-
- x_H0 = 1._dl
- x_He0 = 1._dl
- x0 = 1._dl+2._dl*fHe
-
- else if(z > 3500._dl)then
-
- x_H0 = 1._dl
- x_He0 = 1._dl
- rhs = exp( 1.5d0 * log(CR*Tnow/(1._dl+z)) &
- - CB1_He2/(Tnow*(1._dl+z)) ) / Nnow
- rhs = rhs*1._dl !ratio of g's is 1 for He++ <-> He+
- x0 = 0.5d0 * ( sqrt( (rhs-1._dl-fHe)**2 &
- + 4._dl*(1._dl+2._dl*fHe)*rhs) - (rhs-1._dl-fHe) )
-
- else if(z > 2000._dl)then
-
- x_H0 = 1._dl
- rhs = exp( 1.5d0 * log(CR*Tnow/(1._dl+z)) &
- - CB1_He1/(Tnow*(1._dl+z)) ) / Nnow
- rhs = rhs*4._dl !ratio of g's is 4 for He+ <-> He0
- x_He0 = 0.5d0 * ( sqrt( (rhs-1._dl)**2 + 4._dl*(1._dl+fHe)*rhs )- (rhs-1._dl))
- x0 = x_He0
- x_He0 = (x0 - 1._dl)/fHe
-
- else
-
- rhs = exp( 1.5d0 * log(CR*Tnow/(1._dl+z)) &
- - CB1/(Tnow*(1._dl+z)) ) / Nnow
- x_H0 = 0.5d0 * (sqrt( rhs**2+4._dl*rhs ) - rhs )
- x_He0 = 0._dl
- x0 = x_H0
-
- end if
-
-
- end subroutine GET_INIT
-
-
-
- subroutine ION(Recomb,Ndim,z,Y,f)
- use RECDATA
- implicit none
-
- integer Ndim
- Type (RecombinationParams) :: Recomb
-
- real(dl) z,x,n,n_He,Trad,Tmat,Tspin,x_H,x_He, Hz
- real(dl) y(Ndim),f(Ndim)
- real(dl) Rup,Rdown,K,K_He,Rup_He,Rdown_He,He_Boltz
- real(dl) timeTh,timeH
- real(dl) a_VF,b_VF,T_0,T_1,sq_0,sq_1,a_PPB,b_PPB,c_PPB,d_PPB
- real(dl) tauHe_s,pHe_s
- real(dl) a_trip,b_trip,Rdown_trip,Rup_trip
- real(dl) Doppler,gamma_2Ps,pb,qb,AHcon
- real(dl) tauHe_t,pHe_t,CL_PSt,CfHe_t,gamma_2Pt
- real(dl) epsilon
- integer Heflag
- real(dl) dtauda
- real(dl) C10, dHdz
- external dtauda
-
- ! the Pequignot, Petitjean & Boisson fitting parameters for Hydrogen
- a_PPB = 4.309d0
- b_PPB = -0.6166d0
- c_PPB = 0.6703d0
- d_PPB = 0.5300d0
- ! the Verner and Ferland type fitting parameters for Helium
- ! fixed to match those in the SSS papers, and now correct
- a_VF = 10.d0**(-16.744d0)
- b_VF = 0.711d0
- T_0 = 10.d0**(0.477121d0) !3K
- T_1 = 10.d0**(5.114d0)
- ! fitting parameters for HeI triplets
- ! (matches Hummer's table with <1% error for 10^2.8 < T/K < 10^4)
-
- a_trip = 10.d0**(-16.306d0)
- b_trip = 0.761D0
-
-
- x_H = y(1)
- x_He = y(2)
- x = x_H + fHe * x_He
- Tmat = y(3)
- ! Tspin = y(4)
-
- n = Nnow * (1._dl+z)**3
- n_He = fHe * Nnow * (1._dl+z)**3
- Trad = Tnow * (1._dl+z)
-
- Hz = 1/dtauda(1/(1._dl+z))*(1._dl+z)**2/MPC_in_sec
-
-
- ! Get the radiative rates using PPQ fit, identical to Hummer's table
-
- Rdown=1.d-19*a_PPB*(Tmat/1.d4)**b_PPB &
- /(1._dl+c_PPB*(Tmat/1.d4)**d_PPB)
- Rup = Rdown * (CR*Tmat)**(1.5d0)*exp(-CDB/Tmat)
-
- ! calculate He using a fit to a Verner & Ferland type formula
- sq_0 = sqrt(Tmat/T_0)
- sq_1 = sqrt(Tmat/T_1)
- ! typo here corrected by Wayne Hu and Savita Gahlaut
- Rdown_He = a_VF/(sq_0*(1.d0+sq_0)**(1.d0-b_VF))
- Rdown_He = Rdown_He/(1.d0+sq_1)**(1.d0+b_VF)
- Rup_He = Rdown_He*(CR*Tmat)**(1.5d0)*exp(-CDB_He/Tmat)
- Rup_He = 4.d0*Rup_He !statistical weights factor for HeI
- ! Avoid overflow (pointed out by Jacques Roland)
- if((Bfact/Tmat) > 680.d0)then
- He_Boltz = exp(680.d0)
- else
- He_Boltz = exp(Bfact/Tmat)
- end if
- ! now deal with H and its fudges
- if (.not. Recomb%RECFAST_Hswitch) then
- K = CK/Hz !Peebles coefficient K=lambda_a^3/8piH
- else
- !c fit a double Gaussian correction function
- K = CK/Hz*(1.0d0 &
- +AGauss1*exp(-((log(1.0d0+z)-zGauss1)/wGauss1)**2.d0) &
- +AGauss2*exp(-((log(1.0d0+z)-zGauss2)/wGauss2)**2.d0))
- end if
-
-
- ! add the HeI part, using same T_0 and T_1 values
- Rdown_trip = a_trip/(sq_0*(1.d0+sq_0)**(1.0-b_trip))
- Rdown_trip = Rdown_trip/((1.d0+sq_1)**(1.d0+b_trip))
- Rup_trip = Rdown_trip*dexp(-h_P*C*L_He2St_ion/(k_B*Tmat))
- Rup_trip = Rup_trip*((CR*Tmat)**(1.5d0))*(4.d0/3.d0)
- ! last factor here is the statistical weight
-
- ! try to avoid "NaN" when x_He gets too small
- if ((x_He.lt.5.d-9) .or. (x_He.gt.0.98d0)) then
- Heflag = 0
- else
- Heflag = Recomb%RECFAST_Heswitch
- end if
- if (Heflag.eq.0)then !use Peebles coeff. for He
- K_He = CK_He/Hz
- else !for Heflag>0 !use Sobolev escape probability
- tauHe_s = A2P_s*CK_He*3.d0*n_He*(1.d0-x_He)/Hz
- pHe_s = (1.d0 - dexp(-tauHe_s))/tauHe_s
- K_He = 1.d0/(A2P_s*pHe_s*3.d0*n_He*(1.d0-x_He))
- ! if (((Heflag.eq.2) .or. (Heflag.ge.5)) .and. x_H < 0.99999d0) then
- if (((Heflag.eq.2) .or. (Heflag.ge.5)) .and. x_H < 0.9999999d0) then
- !AL changed July 08 to get smoother Helium
-
- ! use fitting formula for continuum opacity of H
- ! first get the Doppler width parameter
- Doppler = 2.D0*k_B*Tmat/(m_H*not4*C*C)
- Doppler = C*L_He_2p*dsqrt(Doppler)
- gamma_2Ps = 3.d0*A2P_s*fHe*(1.d0-x_He)*C*C &
- /(dsqrt(Pi)*sigma_He_2Ps*8.d0*Pi*Doppler*(1.d0-x_H)) &
- /((C*L_He_2p)**2.d0)
- pb = 0.36d0 !value from KIV (2007)
- qb = Recomb%RECFAST_fudge_He
- ! calculate AHcon, the value of A*p_(con,H) for H continuum opacity
- AHcon = A2P_s/(1.d0+pb*(gamma_2Ps**qb))
- K_He=1.d0/((A2P_s*pHe_s+AHcon)*3.d0*n_He*(1.d0-x_He))
- end if
- if (Heflag.ge.3) then !include triplet effects
- tauHe_t = A2P_t*n_He*(1.d0-x_He)*3.d0
- tauHe_t = tauHe_t /(8.d0*Pi*Hz*L_He_2Pt**(3.d0))
- pHe_t = (1.d0 - dexp(-tauHe_t))/tauHe_t
- CL_PSt = h_P*C*(L_He_2Pt - L_He_2st)/k_B
- if ((Heflag.eq.3) .or. (Heflag.eq.5).or.(x_H.gt.0.99999d0)) then !Recfast 1.4.2 (?)
- ! if ((Heflag.eq.3) .or. (Heflag.eq.5) .or. x_H >= 0.9999999d0) then !no H cont. effect
- CfHe_t = A2P_t*pHe_t*dexp(-CL_PSt/Tmat)
- CfHe_t = CfHe_t/(Rup_trip+CfHe_t) !"C" factor for triplets
- else !include H cont. effect
- Doppler = 2.d0*k_B*Tmat/(m_H*not4*C*C)
- Doppler = C*L_He_2Pt*dsqrt(Doppler)
- gamma_2Pt = 3.d0*A2P_t*fHe*(1.d0-x_He)*C*C &
- /(dsqrt(Pi)*sigma_He_2Pt*8.d0*Pi*Doppler*(1.d0-x_H)) &
- /((C*L_He_2Pt)**2.d0)
- ! use the fitting parameters from KIV (2007) in this case
- pb = 0.66d0
- qb = 0.9d0
- AHcon = A2P_t/(1.d0+pb*gamma_2Pt**qb)/3.d0
- CfHe_t = (A2P_t*pHe_t+AHcon)*dexp(-CL_PSt/Tmat)
- CfHe_t = CfHe_t/(Rup_trip+CfHe_t) !"C" factor for triplets
- end if
- end if
- end if
-
-
- ! Estimates of Thomson scattering time and Hubble time
- timeTh=(1._dl/(CT*Trad**4))*(1._dl+x+fHe)/x !Thomson time
- timeH=2./(3.*HO*(1._dl+z)**1.5) !Hubble time
-
- ! calculate the derivatives
- ! turn on H only for x_H<0.99, and use Saha derivative for 0.98 0.99) then !don't change at all
- f(1) = 0._dl
- !! else if (x_H > 0.98_dl) then
- else if (x_H.gt.0.985d0) then !use Saha rate for Hydrogen
- f(1) = (x*x_H*n*Rdown - Rup*(1.d0-x_H)*dexp(-CL/Tmat)) /(Hz*(1.d0+z))
- recombination_saha_z = z
- !AL: following commented as not used
- ! for interest, calculate the correction factor compared to Saha
- ! (without the fudge)
- ! factor=(1.d0 + K*Lambda*n*(1.d0-x_H))
- ! /(Hz*(1.d0+z)*(1.d0+K*Lambda*n*(1.d0-x)
- ! +K*Rup*n*(1.d0-x)))
- else !use full rate for H
-
- f(1) = ((x*x_H*n*Rdown - Rup*(1.d0-x_H)*exp(-CL/Tmat)) &
- *(1.d0 + K*Lambda*n*(1.d0-x_H))) &
- /(Hz*(1.d0+z)*(1.d0/fu+K*Lambda*n*(1.d0-x_H)/fu &
- +K*Rup*n*(1.d0-x_H)))
-
- end if
-
- ! turn off the He once it is small
- if (x_He < 1.e-15) then
- f(2)=0.d0
- else
-
- f(2) = ((x*x_He*n*Rdown_He &
- - Rup_He*(1-x_He)*exp(-CL_He/Tmat)) &
- *(1 + K_He*Lambda_He*n_He*(1.d0-x_He)*He_Boltz)) &
- /(Hz*(1+z) &
- * (1 + K_He*(Lambda_He+Rup_He)*n_He*(1.d0-x_He)*He_Boltz))
-
- ! Modification to HeI recombination including channel via triplets
- if (Heflag.ge.3) then
- f(2) = f(2)+ (x*x_He*n*Rdown_trip &
- - (1.d0-x_He)*3.d0*Rup_trip*dexp(-h_P*C*L_He_2st/(k_B*Tmat))) &
- *CfHe_t/(Hz*(1.d0+z))
- end if
-
- end if
-
- if (timeTh < H_frac*timeH) then
- ! f(3)=Tmat/(1._dl+z) !Tmat follows Trad
- ! additional term to smooth transition to Tmat evolution,
- ! (suggested by Adam Moss)
- dHdz = (HO**2/2.d0/Hz)*(4.d0*(1.d0+z)**3/(1.d0+z_eq)*OmegaT &
- + 3.d0*OmegaT*(1.d0+z)**2 + 2.d0*OmegaK*(1.d0+z) )
-
- epsilon = Hz*(1.d0+x+fHe)/(CT*Trad**3*x)
- f(3) = Tnow &
- + epsilon*((1.d0+fHe)/(1.d0+fHe+x))*((f(1)+fHe*f(2))/x) &
- - epsilon* dHdz/Hz + 3.0d0*epsilon/(1.d0+z)
-
- else
- f(3)= CT * (Trad**4) * x / (1._dl+x+fHe) &
- * (Tmat-Trad) / (Hz*(1._dl+z)) + 2._dl*Tmat/(1._dl+z)
- end if
-
- ! print *, z, f(3)*(1+z)/Tmat
-
- if (Do21cm .and. evolve_Ts) then
-
- ! follow the matter temperature once it has a chance of diverging
- if (timeTh < H_frac*timeH) then
- f(4) = Tnow !spin follows Trad and Tmat
- else
- if (z< 1/Do21cm_minev-1) then
-
- Tspin = y(4)
- C10 = n*(kappa_HH_21cm(Tmat,.false.)*(1-x_H) + kappa_eH_21cm(Tmat,.false.)*x)
-
- f(4) = 4*Tspin/Hz/(1+z)*( (Tspin/Tmat-1._dl)*C10 + Trad/T_21cm*(Tspin/Trad-1._dl)*A10) - f(1)*Tspin/(1-x_H)
- else
- f(4)=f(3)
- end if
- end if
-
- end if
-
- end subroutine ION
-
-
-
- function dDeltaxe_dtau(a, Delta_xe,Delta_nH, Delta_Tm, hdot, kvb)
- !d x_e/d tau assuming Helium all neutral and temperature perturbations negligible
- !it is not accurate for x_e of order 1
- use RECDATA
- implicit none
- real(dl) dDeltaxe_dtau
- real(dl), intent(in):: a, Delta_xe,Delta_nH, Delta_Tm, hdot, kvb
- real(dl) Delta_Tg
- real(dl) xedot,z,x,n,n_He,Trad,Tmat,x_H,Hz, C_r, dlnC_r
- real(dl) Rup,Rdown,K
- real(dl) a_PPB,b_PPB,c_PPB,d_PPB
- real(dl) delta_alpha, delta_beta, delta_K, clh
- real(dl) dtauda
- external dtauda
-
-
- Delta_tg =Delta_Tm
- x_H = min(1._dl,Recombination_xe(a))
-
- ! the Pequignot, Petitjean & Boisson fitting parameters for Hydrogen
- a_PPB = 4.309d0
- b_PPB = -0.6166d0
- c_PPB = 0.6703d0
- d_PPB = 0.5300d0
-
- z=1/a-1
-
- x = x_H
-
- n = Nnow /a**3
- n_He = fHe * n
- Trad = Tnow /a
- clh = 1/dtauda(a)/a !conformal time
- Hz = clh/a/MPC_in_sec !normal time in seconds
-
- Tmat = Recombination_tm(a)
-
- ! Get the radiative rates using PPQ fit, identical to Hummer's table
-
- Rdown=1.d-19*a_PPB*(Tmat/1.d4)**b_PPB &
- /(1._dl+c_PPB*(Tmat/1.d4)**d_PPB) !alpha
- Rup = Rdown * (CR*Tmat)**(1.5d0)*exp(-CDB/Tmat)
-
- K = CK/Hz !Peebles coefficient K=lambda_a^3/8piH
-
-
- Rdown = Rdown*fu
- Rup = Rup*fu
- C_r = a*(1.d0 + K*Lambda*n*(1.d0-x_H)) /( 1.d0+K*(Lambda+Rup)*n*(1.d0-x_H) )*MPC_in_sec
-
- xedot = -(x*x_H*n*Rdown - Rup*(1.d0-x_H)*exp(-CL/Tmat))*C_r
-
- delta_alpha = (b_PPB + c_PPB*(Tmat/1d4)**d_PPB*(b_PPB-d_PPB))/(1+c_PPB*(Tmat/1d4)**d_PPB)*Delta_Tg
- delta_beta = delta_alpha + (3./2 + CDB/Tmat)*delta_Tg !(Rup = beta)
- delta_K = - hdot/clh - kvb/clh/3
-
-
- dlnC_r = -Rup*K*n*( (Delta_nH+Delta_K + Delta_beta*(1+K*Lambda*n*(1-x_H)))*(1-x_H) - x_H*Delta_xe) &
- / ( 1.d0+K*(Lambda+Rup)*n*(1.d0-x_H) ) /(1.d0 + K*Lambda*n*(1.d0-x_H))
-
- dDeltaxe_dtau= xedot/x_H*(dlnC_r +Delta_alpha - Delta_xe) &
- - C_r*( (2*Delta_xe + Delta_nH)*x_H*n*Rdown + (Delta_xe - (3./2+ CB1/Tmat)*(1/x_H-1)*Delta_Tg)*Rup*exp(-CL/Tmat))
-
-
- !Approximate form valid at late times
- ! dDeltaxe_dtau= xedot/x_H*(Delta_alpha + Delta_xe + Delta_nH)
-
-
- end function dDeltaxe_dtau
-
- ! ===============================================================
-
-
- function polevl(x,coef,N)
- implicit none
- integer N
- real(dl) polevl
- real(dl) x,ans
- real(dl) coef(N+1)
-
- integer i
-
- ans=coef(1)
- do i=2,N+1
- ans=ans*x+coef(i)
- end do
- polevl=ans
-
- end function polevl
-
-
- function derivpolevl(x,coef,N)
- implicit none
- integer N
- real(dl) derivpolevl
- real(dl) x,ans
- real(dl) coef(N+1)
- integer i
-
- ans=coef(1)*N
- do i=2,N
- ans=ans*x+coef(i)*(N-i+1)
- end do
- derivpolevl=ans
-
- end function derivpolevl
-
-
- function kappa_HH_21cm(T, deriv)
- !Polynomail fit to Hydrogen-Hydrogen collision rate as function of Tmatter, from astro-ph/0608032
- !if deriv return d log kappa / d log T
- real(dl), intent(in) :: T
- logical, intent(in) :: deriv
- ! real(dl), dimension(8), parameter :: fit = &
- ! (/ 0.00120402_dl, -0.0322247_dl,0.339581_dl, -1.75094_dl,4.3528_dl,-4.03562_dl, 1.26899_dl, -29.6113_dl /)
- integer, parameter :: n_table = 27
- integer, dimension(n_table), parameter :: Temps = &
- (/ 1, 2, 4, 6,8,10,15,20,25,30,40,50,60,70,80,90,100,200,300,500,700,1000,2000,3000,5000,7000,10000/)
- real, dimension(n_table), parameter :: rates = &
- (/ 1.38e-13, 1.43e-13,2.71e-13, 6.60e-13,1.47e-12,2.88e-12,9.10e-12,1.78e-11,2.73e-11,&
- 3.67e-11,5.38e-11,6.86e-11,8.14e-11,9.25e-11, &
- 1.02e-10,1.11e-10,1.19e-10,1.75e-10,2.09e-10,2.56e-10,2.91e-10,3.31e-10,4.27e-10,&
- 4.97e-10,6.03e-10,6.87e-10,7.87e-10/)
-
- real(dl) kappa_HH_21cm, logT, logRate
- real(dl), save, dimension(:), allocatable :: logRates, logTemps, ddlogRates
- integer xlo, xhi
- real(dl) :: a0, b0, ho
-
- if (.not. allocated(logRates)) then
-
- allocate(logRates(n_table),logTemps(n_table),ddlogRates(n_table))
- logRates = log(real(rates,dl)*0.01**3)
- logTemps = log(real(Temps,dl))
- call spline(logTemps,logRates,n_table,1d30,1d30,ddlogRates)
- end if
-
- if (T<=Temps(1)) then
- if (deriv) then
- kappa_HH_21cm = 0
- else
- kappa_HH_21cm = rates(1)*0.01**3
- end if
- return
- elseif (T >=Temps(n_table)) then
- if (deriv) then
- kappa_HH_21cm = 0
- else
- kappa_HH_21cm = rates(n_table)*0.01**3
- end if
- return
- end if
-
- logT = log(T)
- xlo=0
- do xhi=2, n_table
- if (logT < logTemps(xhi)) then
- xlo = xhi-1
- exit
- end if
- end do
- xhi = xlo+1
-
- ho=logTemps(xhi)-logTemps(xlo)
- a0=(logTemps(xhi)-logT)/ho
- b0=1-a0
-
- if (deriv) then
- kappa_HH_21cm = (logRates(xhi) - logRates(xlo))/ho + &
- ( ddlogRates(xhi)*(3*b0**2-1) - ddlogRates(xlo)*(3*a0**2-1))*ho/6
- ! kappa_HH_21cm = derivpolevl(logT,fit,7)
- else
- logRate = a0*logRates(xlo)+ b0*logRates(xhi)+ ((a0**3-a0)* ddlogRates(xlo) +(b0**3-b0)*ddlogRates(xhi))*ho**2/6
- kappa_HH_21cm = exp(logRate)
- ! kappa_HH_21cm = exp(polevl(logT,fit,7))*0.01**3
-
- end if
-
- end function kappa_HH_21cm
-
-
- function kappa_eH_21cm(T, deriv)
- !Polynomail fit to electron-Hydrogen collision rate as function of Tmatter; from astro-ph/0608032
- !if deriv return d log kappa / d log T
- ! from astro-ph/0608032
- ! 1 2.39e-10
- ! 2 3.37e-10
- ! 5 5.3e-10
- ! 10 7.46e-10
- ! 20 1.05e-9
- ! 50 1.63e-9
- ! 100 2.26e-9
- ! 200 3.11e-9
- ! 500 4.59e-9
- ! 1000 5.92e-9
- ! 2000 7.15e-9
- ! 5000 8.17e-9
- ! 10000 8.37e-9
- ! 15000 8.29e-9
- ! 20000 8.11e-9
- real(dl), intent(in) :: T
- logical, intent(in) :: deriv
- real(dl), dimension(6), parameter :: fit = &
- (/5.86236d-005, -0.00171375_dl, 0.0137303_dl, -0.0435277_dl, 0.540905_dl,-22.1596_dl /)
-
- real(dl) kappa_eH_21cm, logT
-
- logT = log(T)
- if (deriv) then
- kappa_eH_21cm = derivpolevl(logT,fit,5)
- else
- kappa_eH_21cm = exp(polevl(logT,fit,5))*0.01**3
- end if
-
- end function kappa_eH_21cm
-
-
-
-
- function kappa_pH_21cm(T, deriv) ! from astro-ph/0702487
- !Not actually used
- !Polynomail fit to proton-Hydrogen collision rate as function of Tmatter
- !if deriv return d log kappa / d log T
- real(dl), intent(in) :: T
- logical, intent(in) :: deriv
- integer, parameter :: n_table = 17
- integer, dimension(n_table), parameter :: Temps = &
- (/ 1, 2, 5, 10,20,50,100,200,500,1000,2000,3000,5000,7000,10000,15000,20000/)
- real, dimension(n_table), parameter :: rates = &
- (/ 0.4028, 0.4517,0.4301,0.3699,0.3172,0.3047, 0.3379, 0.4043, 0.5471, 0.7051, 0.9167, 1.070, &
- 1.301, 1.48,1.695,1.975,2.201/)
-
- real(dl) kappa_pH_21cm, logT, logRate
- real(dl), save, dimension(:), allocatable :: logRates, logTemps, ddlogRates
- integer xlo, xhi
- real(dl) :: a0, b0, ho
- real(dl):: factor = 0.01**3*1e-9
-
- if (.not. allocated(logRates)) then
-
- allocate(logRates(n_table),logTemps(n_table),ddlogRates(n_table))
- logRates = log(real(rates,dl)*factor)
- logTemps = log(real(Temps,dl))
- call spline(logTemps,logRates,n_table,1d30,1d30,ddlogRates)
- end if
-
- if (T<=Temps(1)) then
- if (deriv) then
- kappa_pH_21cm = 0
- else
- kappa_pH_21cm = rates(1)*factor
- end if
- return
- elseif (T >=Temps(n_table)) then
- if (deriv) then
- kappa_pH_21cm = 0
- else
- kappa_pH_21cm = rates(n_table)*factor
- end if
- return
- end if
-
- logT = log(T)
- xlo=0
- do xhi=2, n_table
- if (logT < logTemps(xhi)) then
- xlo = xhi-1
- exit
- end if
- end do
- xhi = xlo+1
-
- ho=logTemps(xhi)-logTemps(xlo)
- a0=(logTemps(xhi)-logT)/ho
- b0=1-a0
-
- if (deriv) then
- kappa_pH_21cm = (logRates(xhi) - logRates(xlo))/ho + &
- ( ddlogRates(xhi)*(3*b0**2-1) - ddlogRates(xlo)*(3*a0**2-1))*ho/6
- else
- logRate = a0*logRates(xlo)+ b0*logRates(xhi)+ ((a0**3-a0)* ddlogRates(xlo) +(b0**3-b0)*ddlogRates(xhi))*ho**2/6
- kappa_pH_21cm = exp(logRate)
- end if
-
- end function kappa_pH_21cm
-
-
- end module Recombination
-
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/reionization.f90 cosmomc_sampler/camb/reionization.f90
*** cosmomc/camb/reionization.f90 2010-01-27 12:03:27.000000000 +0100
--- cosmomc_sampler/camb/reionization.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,363 ****
-
- module Reionization
- use Precision
- use AMLutils
- implicit none
-
- !This module puts smooth tanh reionization of specified mid-point (z_{re}) and width
- !The tanh function is in the variable (1+z)**Rionization_zexp
-
- !Rionization_zexp=1.5 has the property that for the same z_{re}
- !the optical depth agrees with infinitely sharp model for matter domination
- !So tau and zre can be mapped into each other easily (for any symmetric window)
- !However for generality the module maps tau into z_{re} using a binary search
- !so could be easily modified for other monatonic parameterizations.
-
- !AL March 2008
- !AL July 2008 - added trap for setting optical depth without use_optical_depth
-
- !See CAMB notes for further discussion: http://cosmologist.info/notes/CAMB.pdf
-
- character(LEN=*), parameter :: Reionization_Name = 'CAMB_reionization'
-
- real(dl), parameter :: Reionization_DefFraction = -1._dl
- !if -1 set from YHe assuming Hydrogen and first ionization of Helium follow each other
-
- real(dl) :: Reionization_AccuracyBoost = 1._dl
- real(dl) :: Rionization_zexp = 1.5_dl
-
- logical :: include_helium_fullreion = .true.
- real(dl) :: helium_fullreion_redshift = 3.5_dl
- real(dl) :: helium_fullreion_deltaredshift = 0.5
- real(dl) :: helium_fullreion_redshiftstart = 5._dl
-
-
- type ReionizationParams
- logical :: Reionization
- logical :: use_optical_depth
- real(dl) :: redshift, delta_redshift, fraction
- real(dl) :: optical_depth
- end type ReionizationParams
-
- type ReionizationHistory
- !These two are used by main code to bound region where xe changing
- real(dl) :: tau_start, tau_complete
- !This is set from main code
- real(dl) :: akthom, fHe
-
- !The rest are internal to this module.
- real(dl) :: WindowVarMid, WindowVarDelta
-
- end type ReionizationHistory
-
- real(dl), parameter :: Reionization_maxz = 40._dl
- real(dl), private, parameter :: Reionization_tol = 1d-5
-
- real(dl), private, external :: dtauda, rombint,rombint2
-
- Type(ReionizationParams), private, pointer :: ThisReion
- Type(ReionizationHistory), private, pointer :: ThisReionHist
-
- contains
-
-
- function Reionization_xe(a, tau, xe_recomb)
- !a and time tau and redundant, both provided for convenience
- !xe_recomb is xe(tau_start) from recombination (typically very small, ~2e-4)
- !xe should map smoothly onto xe_recomb
- real(dl), intent(in) :: a
- real(dl), intent(in), optional :: tau, xe_recomb
- real(dl) Reionization_xe
- real(dl) tgh, xod
- real(dl) xstart
-
- if (present(xe_recomb)) then
- xstart = xe_recomb
- else
- xstart = 0._dl
- end if
-
- xod = (ThisReionHist%WindowVarMid - 1._dl/a**Rionization_zexp)/ThisReionHist%WindowVarDelta
- if (xod > 100) then
- tgh=1.d0
- else
- tgh=tanh(xod)
- end if
- Reionization_xe =(ThisReion%fraction-xstart)*(tgh+1._dl)/2._dl+xstart
-
- if (include_helium_fullreion .and. a > (1/(1+ helium_fullreion_redshiftstart))) then
-
- !Effect of Helium becoming fully ionized at z <~ 3.5 is very small so details not important
- xod = (1+helium_fullreion_redshift - 1._dl/a)/helium_fullreion_deltaredshift
- if (xod > 100) then
- tgh=1.d0
- else
- tgh=tanh(xod)
- end if
-
- Reionization_xe = Reionization_xe + ThisReionHist%fHe*(tgh+1._dl)/2._dl
-
- end if
-
- end function Reionization_xe
-
- function Reionization_timesteps(ReionHist)
- !minimum number of time steps to use between tau_start and tau_complete
- !Scaled by AccuracyBoost later
- !steps may be set smaller than this anyway
- Type(ReionizationHistory) :: ReionHist
- integer Reionization_timesteps
-
- Reionization_timesteps = 50
-
- end function Reionization_timesteps
-
- subroutine Reionization_ReadParams(Reion, Ini)
- use IniFile
- Type(ReionizationParams) :: Reion
- Type(TIniFile) :: Ini
-
- Reion%Reionization = Ini_Read_Logical_File(Ini,'reionization')
- if (Reion%Reionization) then
-
- Reion%use_optical_depth = Ini_Read_Logical_File(Ini,'re_use_optical_depth')
-
- if (Reion%use_optical_depth) then
- Reion%optical_depth = Ini_Read_Double_File(Ini,'re_optical_depth')
- else
- Reion%redshift = Ini_Read_Double_File(Ini,'re_redshift')
- end if
-
- Reion%delta_redshift = Ini_Read_Double_File(Ini,'re_delta_redshift', 0.5_dl) !default similar to CMBFAST original
- Reion%fraction = Ini_Read_Double_File(Ini,'re_ionization_frac',Reionization_DefFraction)
-
- end if
-
- end subroutine Reionization_ReadParams
-
- subroutine Reionization_SetParamsForZre(Reion,ReionHist)
- Type(ReionizationParams), target :: Reion
- Type(ReionizationHistory), target :: ReionHist
-
- ReionHist%WindowVarMid = (1._dl+Reion%redshift)**Rionization_zexp
- ReionHist%WindowVarDelta = &
- Rionization_zexp*(1._dl+Reion%redshift)**(Rionization_zexp-1._dl)*Reion%delta_redshift
-
- end subroutine Reionization_SetParamsForZre
-
- subroutine Reionization_Init(Reion, ReionHist, Yhe, akthom, tau0, FeedbackLevel)
- use constants
- Type(ReionizationParams), target :: Reion
- Type(ReionizationHistory), target :: ReionHist
- real(dl), intent(in) :: akthom, tau0, Yhe
- integer, intent(in) :: FeedbackLevel
- real(dl) astart
-
- ReionHist%akthom = akthom
- ReionHist%fHe = YHe/(mass_ratio_He_H*(1.d0-YHe))
-
- ReionHist%tau_start=tau0
- ReionHist%tau_complete=tau0
-
- ThisReion => Reion
- ThisReionHist => ReionHist
-
- if (Reion%Reionization) then
-
- if (Reion%optical_depth /= 0._dl .and. .not. Reion%use_optical_depth) &
- write (*,*) 'WARNING: You seem to have set the optical depth, but use_optical_depth = F'
-
-
- if (Reion%use_optical_depth.and.Reion%optical_depth<0.001 &
- .or. .not.Reion%use_optical_depth .and. Reion%Redshift<0.001) then
- Reion%Reionization = .false.
- end if
-
- end if
-
- if (Reion%Reionization) then
-
- if (Reion%fraction==Reionization_DefFraction) &
- Reion%fraction = 1._dl + ReionHist%fHe !H + singly ionized He
-
- if (Reion%use_optical_depth) then
- call Reionization_SetFromOptDepth(Reion,ReionHist)
- if (FeedbackLevel > 0) write(*,'("Reion redshift = ",f6.3)') Reion%redshift
- end if
-
- call Reionization_SetParamsForZre(ThisReion,ThisReionHist)
-
- !this is a check, agrees very well in default parameterization
- if (FeedbackLevel > 1) write(*,'("Integrated opt depth = ",f7.4)') &
- Reionization_GetOptDepth(Reion, ReionHist)
-
- !Get relevant times
- astart=1.d0/(1.d0+Reion%redshift + Reion%delta_redshift*8)
- ReionHist%tau_start = max(0.05_dl, rombint(dtauda,0._dl,astart,1d-3))
- !Time when a very small reionization fraction (assuming tanh fitting)
-
- ReionHist%tau_complete = min(tau0, &
- ReionHist%tau_start+ rombint(dtauda,astart,1.d0/(1.d0+max(0.d0,Reion%redshift-Reion%delta_redshift*8)),1d-3))
-
- end if
-
- end subroutine Reionization_Init
-
-
- subroutine Reionization_SetDefParams(Reion)
- Type(ReionizationParams) :: Reion
-
- Reion%Reionization = .true.
- Reion%use_optical_depth = .false.
- Reion%optical_depth = 0._dl
- Reion%redshift = 10
- Reion%fraction = Reionization_DefFraction
- Reion%delta_redshift = 0.5_dl
-
- end subroutine Reionization_SetDefParams
-
- subroutine Reionization_Validate(Reion, OK)
- Type(ReionizationParams),intent(in) :: Reion
- logical, intent(inout) :: OK
-
- if (Reion%Reionization) then
- if (Reion%use_optical_depth) then
- if (Reion%optical_depth<0 .or. Reion%optical_depth > 0.9 .or. &
- include_helium_fullreion .and. Reion%optical_depth<0.01) then
- OK = .false.
- write(*,*) 'Optical depth is strange. You have:', Reion%optical_depth
- end if
- else
- if (Reion%redshift < 0 .or. Reion%Redshift +Reion%delta_redshift*3 > Reionization_maxz .or. &
- include_helium_fullreion .and. Reion%redshift < helium_fullreion_redshift) then
- OK = .false.
- write(*,*) 'Reionization redshift strange. You have: ',Reion%Redshift
- end if
- end if
- if (Reion%fraction/= Reionization_DefFraction .and. (Reion%fraction < 0 .or. Reion%fraction > 1.5)) then
- OK = .false.
- write(*,*) 'Reionization fraction strange. You have: ',Reion%fraction
- end if
- if (Reion%delta_redshift > 3 .or. Reion%delta_redshift<0.1 ) then
- !Very narrow windows likely to cause problems in interpolation etc.
- !Very broad likely to conflic with quasar data at z=6
- OK = .false.
- write(*,*) 'Reionization delta_redshift is strange. You have: ',Reion%delta_redshift
- end if
-
-
- end if
-
- end subroutine Reionization_Validate
-
-
- function Reionization_doptdepth_dz(z)
- real(dl) :: Reionization_doptdepth_dz
- real(dl), intent(in) :: z
- real(dl) a
-
- a = 1._dl/(1._dl+z)
-
- Reionization_doptdepth_dz = Reionization_xe(a)*ThisReionHist%akthom*dtauda(a)
-
- end function Reionization_doptdepth_dz
-
- function Reionization_GetOptDepth(Reion, ReionHist)
- Type(ReionizationParams), target :: Reion
- Type(ReionizationHistory), target :: ReionHist
- real(dl) Reionization_GetOptDepth
-
- ThisReion => Reion
- ThisReionHist => ReionHist
- Reionization_GetOptDepth = rombint2(Reionization_doptdepth_dz,0.d0,Reionization_maxz,&
- Reionization_tol, 20, nint(Reionization_maxz/Reion%delta_redshift*5))
-
- end function Reionization_GetOptDepth
-
- subroutine Reionization_zreFromOptDepth(Reion, ReionHist)
- !General routine to find zre parameter given optical depth
- !Not used for Rionization_zexp = 1.5
- Type(ReionizationParams) :: Reion
- Type(ReionizationHistory) :: ReionHist
- real(dl) try_b, try_t
- real(dl) tau
- integer i
-
- try_b = 0
- try_t = Reionization_maxz
- i=0
- do
- i=i+1
- Reion%redshift = (try_t + try_b)/2
- call Reionization_SetParamsForZre(Reion,ReionHist)
- tau = Reionization_GetOptDepth(Reion, ReionHist)
-
- if (tau > Reion%optical_depth) then
- try_t = Reion%redshift
- else
- try_b = Reion%redshift
- end if
- if (abs(try_b - try_t) < 2e-3/Reionization_AccuracyBoost) exit
- if (i>100) call mpiStop('Reionization_zreFromOptDepth: failed to converge')
- end do
-
-
- if (abs(tau - Reion%optical_depth) > 0.002) then
- write (*,*) 'Reionization_zreFromOptDepth: Did not converge to optical depth'
- write (*,*) 'tau =',tau, 'optical_depth = ', Reion%optical_depth
- write (*,*) try_t, try_b
- call mpiStop()
- end if
-
- end subroutine Reionization_zreFromOptDepth
-
-
-
- subroutine Reionization_SetFromOptDepth(Reion, ReionHist)
- Type(ReionizationParams) :: Reion
- Type(ReionizationHistory) :: ReionHist
-
- ! This subroutine calculates the redshift of reionization
-
- ! This implementation is approximate but quite accurate and fast
-
- real(dl) dz, optd
- real(dl) z, tmp, tmpHe
- integer na
-
- Reion%redshift = 0
-
- if (Reion%Reionization .and. Reion%optical_depth /= 0) then
-
- !Do binary search to find zre from z
- !This is general method
- call Reionization_zreFromOptDepth(Reion, ReionHist)
-
- if (.false.) then
- !Use equivalence with sharp for special case
- optd=0
- na=1
- dz=1._dl/2000/Reionization_AccuracyBoost
- tmp = dz*Reion%fraction*ThisReionHist%akthom
- tmpHe = dz*(Reion%fraction+ReionHist%fHe)*ThisReionHist%akthom
- z=0
- do while (optd < Reion%optical_depth)
- z=na*dz
- if (include_helium_fullreion .and. z < helium_fullreion_redshift) then
- optd=optd+ tmpHe*dtauda(1._dl/(1._dl+z))
- else
- optd=optd+tmp*dtauda(1._dl/(1._dl+z))
- end if
- na=na+1
- end do
- end if
- else
- Reion%Reionization = .false.
- end if
-
- end subroutine Reionization_SetFromOptDepth
-
-
-
- end module Reionization
-
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/sigma8.f90 cosmomc_sampler/camb/sigma8.f90
*** cosmomc/camb/sigma8.f90 2006-05-29 21:12:48.000000000 +0200
--- cosmomc_sampler/camb/sigma8.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,47 ****
- !Simple test program to print out sigma_8 as a function of the CDM density
- program GetSigma8
- use CAMB
- implicit none
- integer i
-
- type(CAMBparams) P !defined in ModelParams in modules.f90
-
- call CAMB_SetDefParams(P)
-
- P%WantTransfer= .true.
-
- P%WantCls = .false.
-
- P%omegab = .045
- P%omegac = 0.155
- P%omegav = 0.8
- P%omegan = 0.0
- P%H0 = 65
-
- P%InitPower%ScalarPowerAmp = 2e-9
- P%InitPower%nn = 1 !number of initial power spectra
- P%InitPower%an(1) = 1 !scalar spectral index
- P%InitPower%ant(1) = 0 !Not used here
- P%InitPower%rat(1) = 1 !ditto
-
- !these settings seem good enough for sigma8 to a percent or so
- P%Transfer%high_precision=.false.
- P%Transfer%kmax=0.5
- P%Transfer%k_per_logint=3
- P%Transfer%num_redshifts=1
- P%Transfer%redshifts(1)=0
-
- do i=1,10
- P%Omegav=P%Omegav-0.05
- P%Omegac=P%Omegac+0.05
- call CAMB_GetResults(P)
-
- !Results are in the Transfer module in modules.f90
-
- write (*,*) 'Omc = ',real(P%Omegac),'OmLam=',real(P%Omegav) &
- , 'sigma_8 = ', real(MT%sigma_8(1,1))
- end do
-
- end program GetSigma8
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/subroutines.f90 cosmomc_sampler/camb/subroutines.f90
*** cosmomc/camb/subroutines.f90 2008-09-16 18:04:28.000000000 +0200
--- cosmomc_sampler/camb/subroutines.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,1133 ****
- !General numerical routines and global accuracy. Includes modified dverk for CAMB.
-
-
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
- subroutine splder(y,dy,n, g)
- use Precision
- ! Splder fits a cubic spline to y and returns the first derivatives at
- ! the grid points in dy. Dy is equivalent to a 4th-order Pade
- ! difference formula for dy/di.
- implicit none
- integer, intent(in) :: n
- real(dl), intent(in) :: y(n),g(n)
- real(dl), intent(out) :: dy(n)
- integer :: n1, i
- real(dl), allocatable, dimension(:) :: f
-
- allocate(f(n))
- n1=n-1
- ! Quartic fit to dy/di at boundaries, assuming d3y/di3=0.
- f(1)=(-10._dl*y(1)+15._dl*y(2)-6._dl*y(3)+y(4))/6._dl
- f(n)=(10._dl*y(n)-15._dl*y(n1)+6._dl*y(n-2)-y(n-3))/6._dl
- ! Solve the tridiagonal system
- ! dy(i-1)+4*dy(i)+dy(i+1)=3*(y(i+1)-y(i-1)), i=2,3,...,n1,
- ! with dy(1)=f(1), dy(n)=f(n).
- do i=2,n1
- f(i)=g(i)*(3._dl*(y(i+1)-y(i-1))-f(i-1))
- end do
- dy(n)=f(n)
- do i=n1,1,-1
- dy(i)=f(i)-g(i)*dy(i+1)
- end do
- deallocate(f)
- end subroutine splder
- !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- subroutine splini(g,n)
- use Precision
- ! Splini must be called before splder to initialize array g in common.
- implicit none
- integer, intent(in) :: n
- real(dl), intent(out):: g(n)
- integer :: i
-
- g(1)=0._dl
- do i=2,n
- g(i)=1/(4._dl-g(i-1))
- end do
- end subroutine splini
-
-
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- function rombint2(f,a,b,tol, maxit, minsteps)
- use precision
- ! Rombint returns the integral from a to b of using Romberg integration.
- ! The method converges provided that f(x) is continuous in (a,b).
- ! f must be real(dl) and must be declared external in the calling
- ! routine. tol indicates the desired relative accuracy in the integral.
-
- ! Modified by AL to specify max iterations and minimum number of steps
- ! (min steps useful to stop wrong results on periodic or sharp functions)
- implicit none
- integer, parameter :: MAXITER=20,MAXJ=5
- dimension g(MAXJ+1)
- real(dl) f
- external f
- real(dl) :: rombint2
- real(dl), intent(in) :: a,b,tol
- integer, intent(in):: maxit,minsteps
-
- integer :: nint, i, k, jmax, j
- real(dl) :: h, gmax, error, g, g0, g1, fourj
-
- h=0.5d0*(b-a)
- gmax=h*(f(a)+f(b))
- g(1)=gmax
- nint=1
- error=1.0d20
- i=0
- do
- i=i+1
- if (i > maxit.or.(i > 5.and.abs(error) < tol) .and. nint > minsteps) exit
- ! Calculate next trapezoidal rule approximation to integral.
- g0=0._dl
- do k=1,nint
- g0=g0+f(a+(k+k-1)*h)
- end do
- g0=0.5d0*g(1)+h*g0
- h=0.5d0*h
- nint=nint+nint
- jmax=min(i,MAXJ)
- fourj=1._dl
- do j=1,jmax
- ! Use Richardson extrapolation.
- fourj=4._dl*fourj
- g1=g0+(g0-g(j))/(fourj-1._dl)
- g(j)=g0
- g0=g1
- end do
- if (abs(g0).gt.tol) then
- error=1._dl-gmax/g0
- else
- error=gmax
- end if
- gmax=g0
- g(jmax+1)=g0
- end do
-
- rombint2=g0
- if (i > maxit .and. abs(error) > tol) then
- write(*,*) 'Warning: Rombint failed to converge; '
- write (*,*)'integral, error, tol:', rombint2,error, tol
- end if
-
- end function rombint2
-
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- function rombint(f,a,b,tol)
- use Precision
- ! Rombint returns the integral from a to b of using Romberg integration.
- ! The method converges provided that f(x) is continuous in (a,b).
- ! f must be real(dl) and must be declared external in the calling
- ! routine. tol indicates the desired relative accuracy in the integral.
- !
- implicit none
- integer, parameter :: MAXITER=20
- integer, parameter :: MAXJ=5
- dimension g(MAXJ+1)
- real(dl) f
- external f
- real(dl) :: rombint
- real(dl), intent(in) :: a,b,tol
- integer :: nint, i, k, jmax, j
- real(dl) :: h, gmax, error, g, g0, g1, fourj
- !
-
- h=0.5d0*(b-a)
- gmax=h*(f(a)+f(b))
- g(1)=gmax
- nint=1
- error=1.0d20
- i=0
- 10 i=i+1
- if (i.gt.MAXITER.or.(i.gt.5.and.abs(error).lt.tol)) &
- go to 40
- ! Calculate next trapezoidal rule approximation to integral.
- g0=0._dl
- do 20 k=1,nint
- g0=g0+f(a+(k+k-1)*h)
- 20 continue
- g0=0.5d0*g(1)+h*g0
- h=0.5d0*h
- nint=nint+nint
- jmax=min(i,MAXJ)
- fourj=1._dl
- do 30 j=1,jmax
- ! Use Richardson extrapolation.
- fourj=4._dl*fourj
- g1=g0+(g0-g(j))/(fourj-1._dl)
- g(j)=g0
- g0=g1
- 30 continue
- if (abs(g0).gt.tol) then
- error=1._dl-gmax/g0
- else
- error=gmax
- end if
- gmax=g0
- g(jmax+1)=g0
- go to 10
- 40 rombint=g0
- if (i.gt.MAXITER.and.abs(error).gt.tol) then
- write(*,*) 'Warning: Rombint failed to converge; '
- write (*,*)'integral, error, tol:', rombint,error, tol
- end if
-
- end function rombint
-
-
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- function rombint_obj(obj,f,a,b,tol, maxit)
- use Precision
- ! Rombint returns the integral from a to b of using Romberg integration.
- ! The method converges provided that f(x) is continuous in (a,b).
- ! f must be real(dl) and must be declared external in the calling
- ! routine. tol indicates the desired relative accuracy in the integral.
- !
- implicit none
- integer, intent(in), optional :: maxit
- integer :: MAXITER=20
- integer, parameter :: MAXJ=5
- dimension g(MAXJ+1)
- real obj !dummy
- real(dl) f
- external f
- real(dl) :: rombint_obj
- real(dl), intent(in) :: a,b,tol
- integer :: nint, i, k, jmax, j
- real(dl) :: h, gmax, error, g, g0, g1, fourj
- !
-
- if (present(maxit)) then
- MaxIter = maxit
- end if
- h=0.5d0*(b-a)
- gmax=h*(f(obj,a)+f(obj,b))
- g(1)=gmax
- nint=1
- error=1.0d20
- i=0
- 10 i=i+1
- if (i.gt.MAXITER.or.(i.gt.5.and.abs(error).lt.tol)) &
- go to 40
- ! Calculate next trapezoidal rule approximation to integral.
- g0=0._dl
- do 20 k=1,nint
- g0=g0+f(obj,a+(k+k-1)*h)
- 20 continue
- g0=0.5d0*g(1)+h*g0
- h=0.5d0*h
- nint=nint+nint
- jmax=min(i,MAXJ)
- fourj=1._dl
- do 30 j=1,jmax
- ! Use Richardson extrapolation.
- fourj=4._dl*fourj
- g1=g0+(g0-g(j))/(fourj-1._dl)
- g(j)=g0
- g0=g1
- 30 continue
- if (abs(g0).gt.tol) then
- error=1._dl-gmax/g0
- else
- error=gmax
- end if
- gmax=g0
- g(jmax+1)=g0
- go to 10
- 40 rombint_obj=g0
- if (i.gt.MAXITER.and.abs(error).gt.tol) then
- write(*,*) 'Warning: Rombint failed to converge; '
- write (*,*)'integral, error, tol:', rombint_obj,error, tol
- end if
-
- end function rombint_obj
-
-
- !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- ! calculates array of second derivatives used by cubic spline
- ! interpolation. y2 is array of second derivatives, yp1 and ypn are first
- ! derivatives at end points.
-
-
- SUBROUTINE spline(x,y,n,yp1,ypn,y2)
- use Precision
- implicit none
- INTEGER, intent(in) :: n
- real(dl), intent(in) :: x(n), y(n), yp1, ypn
- real(dl), intent(out) :: y2(n)
- INTEGER i,k
- real(dl) p,qn,sig,un
- real(dl), dimension(:), allocatable :: u
-
-
- Allocate(u(1:n))
- if (yp1.gt..99d30) then
- y2(1)=0._dl
- u(1)=0._dl
- else
- y2(1)=-0.5d0
- u(1)=(3._dl/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
- endif
-
- do i=2,n-1
- sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
- p=sig*y2(i-1)+2._dl
-
- y2(i)=(sig-1._dl)/p
-
- u(i)=(6._dl*((y(i+1)-y(i))/(x(i+ &
- 1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
- u(i-1))/p
- end do
- if (ypn.gt..99d30) then
- qn=0._dl
- un=0._dl
- else
- qn=0.5d0
- un=(3._dl/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
- endif
- y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1._dl)
- do k=n-1,1,-1
- y2(k)=y2(k)*y2(k+1)+u(k)
- end do
-
- Deallocate(u)
-
- ! (C) Copr. 1986-92 Numerical Recipes Software =$j*m,).
- END SUBROUTINE spline
-
-
- SUBROUTINE spline_deriv(x,y,y2,y1,n)
- !Get derivative y1 given array of x, y and y''
- use Precision
- implicit none
- INTEGER, intent(in) :: n
- real(dl), intent(in) :: x(n), y(n), y2(n)
- real(dl), intent(out) :: y1(n)
- INTEGER i
- real(dl) dx
-
-
- do i=1, n-1
-
- dx = (x(i+1) - x(i))
- y1(i) = (y(i+1) - y(i))/dx - dx*(2*y2(i) + y2(i+1))/6
- end do
- dx = x(n) - x(n-1)
- y1(n) = (y(n) - y(n-1))/dx + dx* ( y2(i-1) + 2*y2(i) )/6
-
- END SUBROUTINE spline_deriv
-
- subroutine spline_integrate(x,y,y2,yint,n)
- !Cumulative integral of cubic spline
- use Precision
- integer, intent(in) :: n
- real(dl), intent(in) :: x(n), y(n), y2(n)
- real(dl), intent(out) :: yint(n)
- real(dl) dx
- integer i
-
- yint(1) = 0
- do i=2, n
-
- dx = (x(i) - x(i-1))
- yint(i) = yint(i-1) + dx*( (y(i)+y(i-1))/2 - dx**2/24*(y2(i)+y2(i-1)))
-
- end do
-
- end subroutine spline_integrate
-
-
-
- !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
- ! this is not the splint given in numerical recipes
-
-
- subroutine splint(y,z,n)
- use Precision
- ! Splint integrates a cubic spline, providing the output value
- ! z = integral from 1 to n of s(i)di, where s(i) is the spline fit
- ! to y(i).
- !
- implicit none
- integer, intent(in) :: n
- real(dl), intent(in) :: y(n)
- real(dl), intent(out) :: z
-
- integer :: n1
- real(dl) :: dy1, dyn
- !
- n1=n-1
- ! Cubic fit to dy/di at boundaries.
- ! dy1=(-11._dl*y(1)+18._dl*y(2)-9._dl*y(3)+2._dl*y(4))/6._dl
- dy1=0._dl
- dyn=(11._dl*y(n)-18._dl*y(n1)+9._dl*y(n-2)-2._dl*y(n-3))/6._dl
- !
- z=0.5d0*(y(1)+y(n))+(dy1-dyn)/12._dl
- z= z + sum(y(2:n1))
- end subroutine splint
-
-
- !This version is modified to pass an object parameter to the function on each call
- !Fortunately Fortran doesn't do type checking on functions, so we can pretend the
- !passed object parameter (EV) is any type we like. In reality it is just a pointer.
-
- subroutine dverk (EV,n, fcn, x, y, xend, tol, ind, c, nw, w)
- use Precision
- use AMLUtils
- integer n, ind, nw, k
- real(dl) x, y(n), xend, tol, c(*), w(nw,9), temp
- real EV !It isn't, but as long as it maintains it as a pointer we are OK
- !
- !***********************************************************************
- ! *
- ! 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 *
- ! *
- ! electronic 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. *
- ! *
- !***********************************************************************
- !
- external fcn
- !
- !***********************************************************************
- ! *
- ! 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 *
- ! real(dl) 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
- if (ind==3) goto 45
- if (ind==4) goto 1111
- if (ind==5 .or. ind==6) goto 2222
-
- ! case 1 - initial entry (ind .eq. 1 or 2)
- ! .........abort if n.gt.nw or tol.le.0
- if (n.gt.nw .or. tol.le.0._dl) 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 k = 1, 9
- c(k) = 0._dl
- end do
- go to 35
- 15 continue
- ! initial entry with options (ind .eq. 2)
- ! make c(1) to c(9) non-negative
- do k = 1, 9
- c(k) = dabs(c(k))
- end do
- ! make floor values non-negative if they are to be used
- if (c(1).ne.4._dl .and. c(1).ne.5._dl) go to 30
- do k = 1, n
- c(k+30) = dabs(c(k+30))
- end do
- 30 continue
- 35 continue
- ! initialize rreb, dwarf, prev xend, flag, counts
- c(10) = 2._dl**(-56)
- c(11) = 1.d-35
- ! set previous xend initially to initial value of x
- c(20) = x
- do k = 21, 24
- c(k) = 0._dl
- end do
- 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._dl .and. &
- (x.ne.c(20) .or. xend.eq.c(20))) go to 500
- ! re-initialize flag
- c(21) = 0._dl
- 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._dl .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
- call fcn(EV,n, x, y, w(1,1))
- c(24) = c(24) + 1._dl
- 105 continue
- !
- ! calculate hmin - use default unless value prescribed
- c(13) = c(3)
- if (c(3) .ne. 0._dl) 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._dl
- if (c(1) .ne. 1._dl) go to 115
- ! absolute error control - weights are 1
- do 110 k = 1, n
- temp = dmax1(temp, dabs(y(k)))
- 110 continue
- c(12) = temp
- go to 160
- 115 if (c(1) .ne. 2._dl) go to 120
- ! relative error control - weights are 1/dabs(y(k)) so
- ! weighted norm y is 1
- c(12) = 1._dl
- go to 160
- 120 if (c(1) .ne. 3._dl) go to 130
- ! weights are 1/max(c(2),abs(y(k)))
- do 125 k = 1, n
- temp = dmax1(temp, dabs(y(k))/c(2))
- 125 continue
- c(12) = dmin1(temp, 1._dl)
- go to 160
- 130 if (c(1) .ne. 4._dl) go to 140
- ! weights are 1/max(c(k+30),abs(y(k)))
- do 135 k = 1, n
- temp = dmax1(temp, dabs(y(k))/c(k+30))
- 135 continue
- c(12) = dmin1(temp, 1._dl)
- go to 160
- 140 if (c(1) .ne. 5._dl) go to 150
- ! weights are 1/c(k+30)
- do 145 k = 1, n
- temp = dmax1(temp, dabs(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 = dmax1(temp, dabs(y(k)))
- 155 continue
- c(12) = dmin1(temp, 1._dl)
- 160 continue
- c(13) = 10._dl*dmax1(c(11),c(10)*dmax1(c(12)/tol,dabs(x)))
- 165 continue
- !
- ! calculate scale - use default unless value prescribed
- c(15) = c(5)
- if (c(5) .eq. 0._dl) c(15) = 1._dl
- !
- ! calculate hmax - consider 4 cases
- ! case 1 both hmax and scale prescribed
- if (c(6).ne.0._dl .and. c(5).ne.0._dl) &
- c(16) = dmin1(c(6), 2._dl/c(5))
- ! case 2 - hmax prescribed, but scale not
- if (c(6).ne.0._dl .and. c(5).eq.0._dl) c(16) = c(6)
- ! case 3 - hmax not prescribed, but scale is
- if (c(6).eq.0._dl .and. c(5).ne.0._dl) c(16) = 2._dl/c(5)
- ! case 4 - neither hmax nor scale is provided
- if (c(6).eq.0._dl .and. c(5).eq.0._dl) c(16) = 2._dl
- !
- !***********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._dl) c(14) = c(16)*tol**(1._dl/6._dl)
- go to 185
- 175 if (c(23) .gt. 1._dl) 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._dl*c(14)
- if (tol .lt. (2._dl/.9d0)**6*c(19)) &
- temp = .9d0*(tol/c(19))**(1._dl/6._dl)*c(14)
- c(14) = dmax1(temp, .5d0*c(14))
- go to 185
- 180 continue
- ! case 3 - after two or more successive failures
- c(14) = .5d0*c(14)
- 185 continue
- !
- ! check against hmax
- c(14) = dmin1(c(14), c(16))
- !
- ! check against hmin
- c(14) = dmax1(c(14), c(13))
- !
- !***********interrupt no 1 (with ind=4) if requested
- if (c(8) .eq. 0._dl) 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. dabs(xend - x)) go to 190
- ! do not step more than half way to xend
- c(14) = dmin1(c(14), .5d0*dabs(xend - x))
- c(17) = x + dsign(c(14), xend - x)
- go to 195
- 190 continue
- ! hit xend exactly
- c(14) = dabs(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._dl
- !
- do 200 k = 1, n
- w(k,9) = y(k) + temp*w(k,1)*233028180000._dl
- 200 continue
- call fcn(EV,n, x + c(18)/6._dl, w(1,9), w(1,2))
- !
- do 205 k = 1, n
- w(k,9) = y(k) + temp*( w(k,1)*74569017600._dl &
- + w(k,2)*298276070400._dl )
- 205 continue
- call fcn(EV,n, x + c(18)*(4._dl/15._dl), w(1,9), w(1,3))
- !
- do 210 k = 1, n
- w(k,9) = y(k) + temp*( w(k,1)*1165140900000._dl &
- - w(k,2)*3728450880000._dl &
- + w(k,3)*3495422700000._dl )
- 210 continue
- call fcn(EV,n, x + c(18)*(2._dl/3._dl), w(1,9), w(1,4))
- !
- do 215 k = 1, n
- w(k,9) = y(k) + temp*( - w(k,1)*3604654659375._dl &
- + w(k,2)*12816549900000._dl &
- - w(k,3)*9284716546875._dl &
- + w(k,4)*1237962206250._dl )
- 215 continue
- call fcn(EV,n, x + c(18)*(5._dl/6._dl), w(1,9), w(1,5))
- !
- do 220 k = 1, n
- w(k,9) = y(k) + temp*( w(k,1)*3355605792000._dl &
- - w(k,2)*11185352640000._dl &
- + w(k,3)*9172628850000._dl &
- - w(k,4)*427218330000._dl &
- + w(k,5)*482505408000._dl )
- 220 continue
- call fcn(EV,n, x + c(18), w(1,9), w(1,6))
- !
- do 225 k = 1, n
- w(k,9) = y(k) + temp*( - w(k,1)*770204740536._dl &
- + w(k,2)*2311639545600._dl &
- - w(k,3)*1322092233000._dl &
- - w(k,4)*453006781920._dl &
- + w(k,5)*326875481856._dl )
- 225 continue
- call fcn(EV,n, x + c(18)/15._dl, w(1,9), w(1,7))
- !
- do 230 k = 1, n
- w(k,9) = y(k) + temp*( w(k,1)*2845924389000._dl &
- - w(k,2)*9754668000000._dl &
- + w(k,3)*7897110375000._dl &
- - w(k,4)*192082660000._dl &
- + w(k,5)*400298976000._dl &
- + w(k,7)*201586000000._dl )
- 230 continue
- call fcn(EV,n, x + c(18), w(1,9), w(1,8))
- !
- ! 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._dl &
- + w(k,3)*545186250000._dl &
- + w(k,4)*446637345000._dl &
- + w(k,5)*188806464000._dl &
- + w(k,7)*15076875000._dl &
- + w(k,8)*97599465000._dl )
- 235 continue
- !
- ! add 7 to the no of fcn evals
- c(24) = c(24) + 7._dl
- !
- ! 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._dl &
- + w(k,3)*9735468750._dl &
- - w(k,4)*9709507500._dl &
- + w(k,5)*8582112000._dl &
- + w(k,6)*95329710000._dl &
- - w(k,7)*15076875000._dl &
- - w(k,8)*97599465000._dl)/1398169080000._dl
- 300 continue
- !
- ! calculate the weighted max norm of w(*,2) as specified by
- ! the error control indicator c(1)
- temp = 0._dl
- if (c(1) .ne. 1._dl) go to 310
- ! absolute error control
- do 305 k = 1, n
- temp = dmax1(temp,dabs(w(k,2)))
- 305 continue
- go to 360
- 310 if (c(1) .ne. 2._dl) go to 320
- ! relative error control
- do 315 k = 1, n
- temp = dmax1(temp, dabs(w(k,2)/y(k)))
- 315 continue
- go to 360
- 320 if (c(1) .ne. 3._dl) go to 330
- ! weights are 1/max(c(2),abs(y(k)))
- do 325 k = 1, n
- temp = dmax1(temp, dabs(w(k,2)) &
- / dmax1(c(2), dabs(y(k))) )
- 325 continue
- go to 360
- 330 if (c(1) .ne. 4._dl) go to 340
- ! weights are 1/max(c(k+30),abs(y(k)))
- do 335 k = 1, n
- temp = dmax1(temp, dabs(w(k,2)) &
- / dmax1(c(k+30), dabs(y(k))) )
- 335 continue
- go to 360
- 340 if (c(1) .ne. 5._dl) go to 350
- ! weights are 1/c(k+30)
- do 345 k = 1, n
- temp = dmax1(temp, dabs(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 = dmax1(temp, dabs(w(k,2)) &
- / dmax1(1._dl, dabs(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._dl) 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._dl
- c(23) = 0._dl
- !**************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._dl
- 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._dl
- !**************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 (*,*) 'Error in dverk, x =',x, 'xend=', xend
- call MpiStop()
- !
- ! end abort action
- !
- end subroutine dverk
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/tester.f90 cosmomc_sampler/camb/tester.f90
*** cosmomc/camb/tester.f90 2005-03-31 01:37:14.000000000 +0200
--- cosmomc_sampler/camb/tester.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,59 ****
- !Simple program to get the scalar and tensor Cls, and print them out (and the sum)
-
- program tester
- use CAMB
- implicit none
- integer l
- real(dl) ratio
-
- type(CAMBparams) P !defined in ModelParams in modules.f90
-
-
- call CAMB_SetDefParams(P)
-
- P%omegab = .045
- P%omegac = 0.355
- P%omegav = 0.6
- P%omegan = 0.0
- P%H0 = 65
-
- P%InitPower%nn = 1 !number of initial power spectra
- P%InitPower%an(1) = 1 !scalar spectral index
- P%InitPower%ant(1) = 0 !tensor spectra index
- P%InitPower%rat(1) = 1 !ratio of initial amplitudes
- !actually we don't use this here since we generate the Cls separately
- !so set to 1, and then put in the ratio after calculating the Cls
-
-
- P%OutputNormalization = outNone
-
- !Generate scalars first so that start with maximum Max_l that is used
- P%WantScalars = .true.
- P%WantTensors = .true.
-
- P%Max_l=1500
- P%Max_eta_k=3000
- P%Max_l_tensor=200
- P%Max_eta_k_tensor=500
-
- P%AccuratePolarization = .false. !We are only interested in the temperature here
-
- call CAMB_GetResults(P)
-
- ratio =0.1
-
- do l=2,P%Max_l
- !print out scalar and tensor temperature, then sum
- if (l <= P%Max_l_tensor) then
- !The indices of the Cl_xxx arrays are l, initial power spectrum index, Cl type
- write(*,'(1I5,3E15.5)') l, Cl_scalar(l,1, C_Temp), ratio*Cl_tensor(l,1,CT_Temp), &
- ratio*Cl_tensor(l,1,C_Temp)+Cl_scalar(l,1,C_Temp)
- else
- write(*,'(1I5,3E15.5)') l, Cl_scalar(l,1, C_Temp),0._dl,Cl_scalar(l,1,C_Temp)
- end if
- end do
-
-
- end program Tester
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/utils.F90 cosmomc_sampler/camb/utils.F90
*** cosmomc/camb/utils.F90 2010-01-28 13:42:10.000000000 +0100
--- cosmomc_sampler/camb/utils.F90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,2771 ****
- !Module of generally useful routines and definitions
- !Antony Lewis, http://cosmologist.info/
-
- !April 2006: fix to TList_RealArr_Thin
- !March 2008: fix to Ranges
- !This version Mar 2008
-
- module Ranges
- !A collection of ranges, consisting of sections of minimum step size
- implicit none
-
- integer, parameter :: Max_Ranges = 100
- double precision, parameter :: RangeTol = 0.1d0
- !fraction of bin width we are prepared for merged bin widths to increase by
-
- Type Region
- integer start_index
- integer steps
- logical :: IsLog
- double precision Low, High
- double precision delta
- double precision delta_max, delta_min !for log spacing, the non-log max and min step size
- end Type Region
-
- Type Regions
-
- integer count
- integer npoints
- double precision Lowest, Highest
- Type(Region) :: R(Max_ranges)
- logical :: has_dpoints
- double precision, dimension(:), pointer :: points, dpoints
- !dpoints is (points(i+1)-points(i-1))/2
-
- end Type Regions
-
- contains
-
- subroutine Ranges_Init(R)
- Type(Regions) R
-
- call Ranges_Free(R)
-
- end subroutine Ranges_Init
-
- subroutine Ranges_Free(R)
- Type(Regions) R
- integer status
-
- deallocate(R%points,stat = status)
- deallocate(R%dpoints,stat = status)
- call Ranges_Nullify(R)
-
- end subroutine Ranges_Free
-
-
- subroutine Ranges_Nullify(R)
- Type(Regions) R
-
- nullify(R%points)
- nullify(R%dpoints)
- R%count = 0
- R%npoints = 0
- R%has_dpoints = .false.
-
-
- end subroutine Ranges_Nullify
-
- function Ranges_IndexOf(Reg, tau) result(pointstep)
- Type(Regions), intent(in), target :: Reg
- Type(Region), pointer :: AReg
- double precision :: tau
- integer pointstep
- integer i
-
-
- pointstep=0
- do i=1,Reg%count
- AReg => Reg%R(i)
-
- if (tau < AReg%High .and. tau >= AReg%Low) then
- if (AReg%IsLog) then
- pointstep = AReg%start_index + int( log(tau/AReg%Low)/AReg%delta)
- else
- pointstep = AReg%start_index + int(( tau - AReg%Low)/AReg%delta)
- end if
- return
- end if
-
- end do
-
- if (tau >= Reg%Highest) then
- pointstep = Reg%npoints
- else
- write (*,*) 'Ranges_IndexOf: value out of range'
- stop
- end if
-
- end function Ranges_IndexOf
-
-
- subroutine Ranges_GetArray(Reg, want_dpoints)
- Type(Regions), target :: Reg
- Type(Region), pointer :: AReg
- logical, intent(in), optional :: want_dpoints
- integer status,i,j,ix
-
-
- if (present(want_dpoints)) then
- Reg%has_dpoints = want_dpoints
- else
- Reg%has_dpoints = .true.
- end if
-
- deallocate(Reg%points,stat = status)
- allocate(Reg%points(Reg%npoints))
-
- ix=0
- do i=1, Reg%count
- AReg => Reg%R(i)
- do j = 0, AReg%steps-1
- ix=ix+1
- if (AReg%IsLog) then
- Reg%points(ix) = AReg%Low*exp(j*AReg%delta)
- else
- Reg%points(ix) = AReg%Low + AReg%delta*j
- end if
- end do
- end do
- ix =ix+1
- Reg%points(ix) = Reg%Highest
- if (ix /= Reg%npoints) stop 'Ranges_GetArray: ERROR'
-
- if (Reg%has_dpoints) call Ranges_Getdpoints(Reg)
-
- end subroutine Ranges_GetArray
-
-
- subroutine Ranges_Getdpoints(Reg, half_ends)
- Type(Regions), target :: Reg
- logical, intent(in), optional :: half_ends
- integer i, status
- logical halfs
-
- if (present(half_ends)) then
- halfs = half_ends
- else
- halfs = .true.
- end if
-
- deallocate(Reg%dpoints,stat = status)
- allocate(Reg%dpoints(Reg%npoints))
-
- do i=2, Reg%npoints-1
- Reg%dpoints(i) = (Reg%points(i+1) - Reg%points(i-1))/2
- end do
- if (halfs) then
- Reg%dpoints(1) = (Reg%points(2) - Reg%points(1))/2
- Reg%dpoints(Reg%npoints) = (Reg%points(Reg%npoints) - Reg%points(Reg%npoints-1))/2
- else
- Reg%dpoints(1) = (Reg%points(2) - Reg%points(1))
- Reg%dpoints(Reg%npoints) = (Reg%points(Reg%npoints) - Reg%points(Reg%npoints-1))
- end if
- end subroutine Ranges_Getdpoints
-
-
- subroutine Ranges_Add_delta(Reg, t_start, t_end, t_approx_delta, IsLog)
- Type(Regions), target :: Reg
- logical, intent(in), optional :: IsLog
- double precision, intent(in) :: t_start, t_end, t_approx_delta
- integer n
- logical :: WantLog
-
- if (present(IsLog)) then
- WantLog = IsLog
- else
- WantLog = .false.
- end if
-
- if (t_end <= t_start) &
- stop 'Ranges_Add_delta: end must be larger than start'
- if (t_approx_delta <=0) stop 'Ranges_Add_delta: delta must be > 0'
-
- if (WantLog) then
- n = max(1,int(log(t_end/t_start)/t_approx_delta + 1.d0 - RangeTol))
- else
- n = max(1,int((t_end-t_start)/t_approx_delta + 1.d0 - RangeTol))
- end if
- call Ranges_Add(Reg,t_start, t_end, n, WantLog)
-
- end subroutine Ranges_Add_delta
-
-
- subroutine Ranges_Add(Reg, t_start, t_end, nstep, IsLog)
- Type(Regions), target :: Reg
- logical, intent(in), optional :: IsLog
- double precision, intent(in) :: t_start, t_end
- integer, intent(in) :: nstep
- Type(Region), pointer :: AReg, LastReg
- Type(Region), target :: NewRegions(Max_Ranges)
- double precision EndPoints(0:Max_Ranges*2)
- integer ixin, nreg, ix, i,j, nsteps
- double precision delta
- logical WantLog
- double precision min_request, max_request, min_log_step, max_log_step, diff, max_delta
- double precision RequestDelta(Max_Ranges)
-
- if (present(IsLog)) then
- WantLog = IsLog
- else
- WantLog = .false.
- end if
-
- if (WantLog) then
- delta = log(t_end/t_start) / nstep
- else
- delta = (t_end - t_start) / nstep
- end if
-
- if (t_end <= t_start) stop 'Ranges_Add: end must be larger than start'
- if (nstep <=0) stop 'Ranges_Add: nstep must be > 0'
- if (Reg%Count>= Max_Ranges) stop 'Ranges_Add: Increase Max_Ranges'
-
- !avoid IBM compiler bug, from Angel de Vicente
- ! if (Reg%count > 0) NewRegions(1:Reg%count) = Reg%R(1:Reg%count)
- if (Reg%count > 0) THEN
- DO i=1,Reg%count
- NewRegions(i) = Reg%R(i)
- END DO
- END IF
- nreg = Reg%count + 1
- AReg=> NewRegions(nreg)
- AReg%Low = t_start
- AReg%High = t_end
- AReg%delta = delta
- AReg%steps = nstep
- AReg%IsLog = WantLog
-
- !Get end point in order
- ix = 0
- do i=1, nreg
-
- AReg => NewRegions(i)
- if (ix==0) then
- ix = 1
- EndPoints(ix) = AReg%Low
- ix = 2
- EndPoints(ix) = AReg%High
- else
- ixin = ix
- do j=1,ixin
- if (AReg%Low < EndPoints(j)) then
- EndPoints(j+1:ix+1) = EndPoints(j:ix)
- EndPoints(j) = AReg%Low
- ix=ix+1
- exit
- end if
- end do
- if (ixin == ix) then
- ix = ix+1
- EndPoints(ix) = AReg%Low
- ix = ix+1
- EndPoints(ix) = AReg%High
- else
- ixin = ix
- do j=1,ixin
- if (AReg%High < EndPoints(j)) then
- EndPoints(j+1:ix+1) = EndPoints(j:ix)
- EndPoints(j) = AReg%High
- ix=ix+1
- exit
- end if
- end do
- if (ixin == ix) then
- ix = ix+1
- EndPoints(ix) = AReg%High
- end if
-
- end if
- end if
-
- end do
-
- !remove duplicate points
- ixin = ix
- ix = 1
- do i=2, ixin
- if (EndPoints(i) /= EndPoints(ix)) then
- ix=ix+1
- EndPoints(ix) = EndPoints(i)
- end if
- end do
-
-
- !ix is the number of end points
- Reg%Lowest = EndPoints(1)
- Reg%Highest = EndPoints(ix)
- Reg%count = 0
-
- max_delta = Reg%Highest - Reg%Lowest
-
- do i=1, ix - 1
- AReg => Reg%R(i)
- AReg%Low = EndPoints(i)
- AReg%High = EndPoints(i+1)
-
- ! max_delta = EndPoints(i+1) - EndPoints(i)
- delta = max_delta
- AReg%IsLog = .false.
-
- do j=1, nreg
- if (AReg%Low >= NewRegions(j)%Low .and. Areg%Low < NewRegions(j)%High) then
- if (NewRegions(j)%IsLog) then
- if (AReg%IsLog) then
- delta = min(delta,NewRegions(j)%delta)
- else
- min_log_step = AReg%Low*(exp(NewRegions(j)%delta)-1)
- if (min_log_step < delta) then
- max_log_step = AReg%High*(1-exp(-NewRegions(j)%delta))
- if (delta < max_log_step) then
- delta = min_log_step
- else
- AReg%IsLog = .true.
- delta = NewRegions(j)%delta
- end if
- end if
- end if
- else !NewRegion is not log
- if (AReg%IsLog) then
- max_log_step = AReg%High*(1-exp(-delta))
- if (NewRegions(j)%delta < max_log_step) then
- min_log_step = AReg%Low*(exp(delta)-1)
- if (min_log_step < NewRegions(j)%delta) then
- AReg%IsLog = .false.
- delta = min_log_step
- else
- delta = - log(1- NewRegions(j)%delta/AReg%High)
- end if
- end if
- else
- delta = min(delta, NewRegions(j)%delta)
- end if
- end if
- end if
- end do
-
- if (AReg%IsLog) then
- Diff = log(AReg%High/AReg%Low)
- else
- Diff = AReg%High - AReg%Low
- endif
- if (delta >= Diff) then
- AReg%delta = Diff
- AReg%steps = 1
- else
- AReg%steps = max(1,int(Diff/delta + 1.d0 - RangeTol))
- AReg%delta = Diff / AReg%steps
- end if
-
- Reg%count = Reg%count + 1
- RequestDelta(Reg%Count) = delta
-
- if (AReg%IsLog) then
- if (AReg%steps ==1) then
- AReg%Delta_min = AReg%High - AReg%Low
- AReg%Delta_max = AReg%Delta_min
- else
- AReg%Delta_min = AReg%Low*(exp(AReg%delta)-1)
- AReg%Delta_max = AReg%High*(1-exp(-AReg%delta))
- end if
- else
- AReg%Delta_max = AReg%delta
- AReg%Delta_min = AReg%delta
- end if
- end do
-
-
- !Get rid of tiny regions
- ix = Reg%Count
- do i=ix, 1, -1
- AReg => Reg%R(i)
- if (AReg%steps ==1) then
- Diff = AReg%High - AReg%Low
- if (AReg%IsLog) then
- min_request = AReg%Low*(exp(RequestDelta(i))-1)
- max_request = AReg%High*(1-exp(-RequestDelta(i)))
- else
- min_request = RequestDelta(i)
- max_request = min_request
- end if
- if (i/= Reg%Count) then !from i/= ix Mar08
- LastReg => Reg%R(i+1)
- if (RequestDelta(i) >= AReg%delta .and. Diff <= LastReg%Delta_min &
- .and. LastReg%Delta_min <= max_request) then
-
- LastReg%Low = AReg%Low
- if (Diff > LastReg%Delta_min*RangeTol) then
- LastReg%steps = LastReg%steps + 1
- end if
- if (LastReg%IsLog) then
- LastReg%delta = log(LastReg%High/LastReg%Low) / LastReg%steps
- else
- LastReg%delta = (LastReg%High -LastReg%Low) / LastReg%steps
- end if
- Reg%R(i:Reg%Count-1) = Reg%R(i+1:Reg%Count)
- Reg%Count = Reg%Count -1
- cycle
- end if
- end if
- if (i/=1) then
- LastReg => Reg%R(i-1)
- if (RequestDelta(i) >= AReg%delta .and. Diff <= LastReg%Delta_max &
- .and. LastReg%Delta_max <= min_request) then
- LastReg%High = AReg%High
- !AlMat08 LastReg%Low = AReg%Low
- if (Diff > LastReg%Delta_max*RangeTol) then
- LastReg%steps = LastReg%steps + 1
- end if
- if (LastReg%IsLog) then
- LastReg%delta = log(LastReg%High/LastReg%Low) / LastReg%steps
- else
- LastReg%delta = (LastReg%High -LastReg%Low) / LastReg%steps
- end if
- Reg%R(i:Reg%Count-1) = Reg%R(i+1:Reg%Count)
- Reg%Count = Reg%Count -1
- end if
- end if
- end if
- end do
-
-
- !Set up start indices and get total number of steps
- nsteps = 1
- do i = 1, Reg%Count
- AReg => Reg%R(i)
- AReg%Start_index = nsteps
- nsteps = nsteps + AReg%steps
- if (AReg%IsLog) then
- if (AReg%steps ==1) then
- AReg%Delta_min = AReg%High - AReg%Low
- AReg%Delta_max = AReg%Delta_min
- else
- AReg%Delta_min = AReg%Low*(exp(AReg%delta)-1)
- AReg%Delta_max = AReg%High*(1-exp(-AReg%delta))
- end if
- else
- AReg%Delta_max = AReg%delta
- AReg%Delta_min = AReg%delta
- end if
- end do
-
- Reg%npoints = nsteps
-
- end subroutine Ranges_Add
-
-
- subroutine Ranges_Write(Reg)
- Type(Regions), intent(in), target :: Reg
- Type(Region), pointer :: AReg
- integer i
-
- do i=1,Reg%count
- AReg => Reg%R(i)
- if (AReg%IsLog) then
- Write (*,'("Range ",I3,":", 3E14.4," log")') i, AReg%Low, AReg%High, AReg%delta
- else
- Write (*,'("Range ",I3,":", 3E14.4," linear")') i, AReg%Low, AReg%High, AReg%delta
- end if
- end do
- end subroutine Ranges_Write
-
-
- end module Ranges
-
-
- module Lists
- !Currently implements lists of strings and lists of arrays of reals
- implicit none
-
- type real_pointer
- real, dimension(:), pointer :: p
- end type real_pointer
-
- type double_pointer
- double precision, dimension(:), pointer :: p
- end type double_pointer
-
- type String_pointer
- character, dimension(:), pointer :: p
- end type String_pointer
-
-
- Type TList_RealArr
- integer Count
- integer Delta
- integer Capacity
- type(Real_Pointer), dimension(:), pointer :: Items
- end Type TList_RealArr
-
- Type TStringList
- integer Count
- integer Delta
- integer Capacity
- type(String_Pointer), dimension(:), pointer :: Items
- end Type TStringList
-
- contains
-
- subroutine TList_RealArr_Init(L)
- Type (TList_RealArr) :: L
-
- L%Count = 0
- L%Capacity = 0
- L%Delta = 1024
- nullify(L%items)
-
- end subroutine TList_RealArr_Init
-
- subroutine TList_RealArr_Clear(L)
- Type (TList_RealArr) :: L
- integer i, status
-
- do i=L%Count,1,-1
- deallocate (L%Items(i)%P, stat = status)
- end do
- deallocate (L%Items, stat = status)
- nullify(L%Items)
- L%Count = 0
- L%Capacity = 0
-
- end subroutine TList_RealArr_Clear
-
-
- subroutine TList_RealArr_Add(L, P)
- Type (TList_RealArr) :: L
- real, intent(in) :: P(:)
- integer s
-
- if (L%Count == L%Capacity) call TList_RealArr_SetCapacity(L, L%Capacity + L%Delta)
- s = size(P)
- L%Count = L%Count + 1
- allocate(L%Items(L%Count)%P(s))
- L%Items(L%Count)%P = P
-
- end subroutine TList_RealArr_Add
-
- subroutine TList_RealArr_SetCapacity(L, C)
- Type (TList_RealArr) :: L
- integer C
- type(Real_Pointer), dimension(:), pointer :: TmpItems
-
- if (L%Count > 0) then
- if (C < L%Count) stop 'TList_RealArr_SetCapacity: smaller than Count'
- allocate(TmpItems(L%Count))
- TmpItems = L%Items(1:L%Count)
- deallocate(L%Items)
- allocate(L%Items(C))
- L%Items(1:L%Count) = TmpItems
- deallocate(TmpItems)
- else
- allocate(L%Items(C))
- end if
- L%Capacity = C
- end subroutine TList_RealArr_SetCapacity
-
- subroutine TList_RealArr_Delete(L, i)
- Type (TList_RealArr) :: L
- integer, intent(in) :: i
- integer status
-
- deallocate(L%items(i)%P, stat = status)
- if (L%Count > 1) L%Items(i:L%Count-1) = L%Items(i+1:L%Count)
- L%Count = L%Count -1
-
- end subroutine TList_RealArr_Delete
-
- subroutine TList_RealArr_SaveBinary(L,fid)
- Type (TList_RealArr) :: L
- integer, intent(in) :: fid
- integer i
-
- write (fid) L%Count
- do i=1,L%Count
- write(fid) size(L%Items(i)%P)
- write(fid) L%Items(i)%P
- end do
-
- end subroutine TList_RealArr_SaveBinary
-
- subroutine TList_RealArr_ReadBinary(L,fid)
- Type (TList_RealArr) :: L
- integer, intent(in) :: fid
- integer num,i,sz
-
- call TList_RealArr_Clear(L)
- read (fid) num
- call TList_RealArr_SetCapacity(L, num)
- do i=1,num
- read(fid) sz
- allocate(L%Items(i)%P(sz))
- read(fid) L%Items(i)%P
- end do
- L%Count = num
-
- end subroutine TList_RealArr_ReadBinary
-
-
- subroutine TList_RealArr_Thin(L, i)
- Type (TList_RealArr) :: L
- integer, intent(in) :: i
- integer newCount
- type(Real_Pointer), dimension(:), pointer :: TmpItems
-
- if (L%Count > 1) then
- newCount = (L%Count-1)/i+1
- allocate(TmpItems(newCount))
- TmpItems = L%Items(1:L%Count:i)
- deallocate(L%Items)
- L%Capacity = newCount
- allocate(L%Items(L%Capacity))
- L%Items = TmpItems
- L%Count = newCount
- deallocate(TmpItems)
- end if
- end subroutine TList_RealArr_Thin
-
- subroutine TList_RealArr_ConfidVal(L, ix, limfrac, ix1, ix2, Lower, Upper)
- !Taking the ix'th entry in each array to be a sample, value for which
- !limfrac of the items between ix1 and ix2 (inc) are above or below
- !e.g. if limfrac = 0.05 get two tail 90% confidence limits
- Type (TList_RealArr) :: L
- integer, intent(IN) :: ix
- real, intent(IN) :: limfrac
- real, intent(OUT), optional :: Lower, Upper
- integer, intent(IN), optional :: ix1,ix2
- integer b,t,samps
- real pos, d
- type(Real_Pointer), dimension(:), pointer :: SortItems
-
- b=1
- t=L%Count
- if (present(ix1)) b = ix1
- if (present(ix2)) t = ix2
- samps = t - b + 1
-
- allocate(SortItems(samps))
- SortItems = L%Items(b:t)
- call QuickSortArr_Real(SortItems, 1, samps, ix)
- if (present(Lower)) then
- pos = (samps-1)*limfrac + 1
- b = max(int(pos),1)
- Lower = SortItems(b)%P(ix)
- if (b < samps .and. pos>b) then
- d = pos - b
- Lower = Lower*(1 - d) + d * SortItems(b+1)%P(ix)
- end if
- end if
- if (present(Upper)) then
- pos = (samps-1)*(1.-limfrac) + 1
- b = max(int(pos),1)
- Upper = SortItems(b)%P(ix)
- if (b < samps .and. pos>b) then
- d = pos - b
- Upper = Upper*(1 - d) + d * SortItems(b+1)%P(ix)
- end if
- end if
-
- deallocate(SortItems)
-
- end subroutine TList_RealArr_ConfidVal
-
- subroutine TStringList_Init(L)
- Type (TStringList) :: L
-
- L%Count = 0
- L%Capacity = 0
- L%Delta = 128
- nullify(L%items)
-
- end subroutine TStringList_Init
-
- subroutine TStringList_Clear(L)
- Type (TStringList) :: L
- integer i, status
-
- do i=L%Count,1,-1
- deallocate (L%Items(i)%P, stat = status)
- end do
- deallocate (L%Items, stat = status)
- call TStringList_Init(L)
-
- end subroutine TStringList_Clear
-
- subroutine TStringList_SetFromString(L, S, valid_chars)
- Type (TStringList) :: L
- character(Len=*), intent(in) :: S, valid_chars
- character(LEN=1024) item
- integer i,j
-
- call TStringList_Clear(L)
- item =''
- j=0
- do i=1, len_trim(S)
- if (verify(S(i:i),trim(valid_chars)) == 0) then
- j=j+1
- item(j:j) = S(i:i)
- else
- if (trim(S(i:i))/='') then
- write (*,*) 'Invalid character in: '//trim(S)
- end if
- if (j>0) call TStringList_Add(L, item(1:j))
- j=0
- end if
- end do
- if (j>0) call TStringList_Add(L, item(1:j))
-
- end subroutine TStringList_SetFromString
-
-
-
- subroutine TStringList_Add(L, P)
- Type (TStringList) :: L
- character(LEN=*), intent(in) :: P
- integer s,i
-
- if (L%Count == L%Capacity) call TStringList_SetCapacity(L, L%Capacity + L%Delta)
- s = len_trim(P)
- L%Count = L%Count + 1
- allocate(L%Items(L%Count)%P(s))
- do i=1,s
- L%Items(L%Count)%P(i) = P(i:i)
- end do
- end subroutine TStringList_Add
-
- subroutine TStringList_SetCapacity(L, C)
- Type (TStringList) :: L
- integer C
- type(String_Pointer), dimension(:), pointer :: TmpItems
-
- if (L%Count > 0) then
- if (C < L%Count) stop 'TStringList_SetCapacity: smaller than Count'
- allocate(TmpItems(L%Count))
- TmpItems = L%Items(1:L%Count)
- deallocate(L%Items)
- allocate(L%Items(C))
- L%Items(1:L%Count) = TmpItems
- deallocate(TmpItems)
- else
- allocate(L%Items(C))
- end if
- L%Capacity = C
-
- end subroutine TStringList_SetCapacity
-
- subroutine TStringList_Delete(L, i)
- Type (TStringList) :: L
- integer, intent(in) :: i
- integer status
-
- deallocate(L%items(i)%P, stat = status)
- if (L%Count > 1) L%Items(i:L%Count-1) = L%Items(i+1:L%Count)
- L%Count = L%Count -1
-
- end subroutine TStringList_Delete
-
- function TStringList_IndexOf(L, S)
- Type (TStringList) :: L
- character(LEN=*), intent(in) :: S
- integer TStringList_IndexOf, i, j,slen
-
- slen = len_trim(S)
- do i=1,L%Count
- if ( size(L%Items(i)%P)==slen) then
- !Yes, comparing strings and pointer strings really is this horrible...
- j=1
- do while (L%Items(i)%P(j)==S(j:j))
- j=j+1
- if (j>slen) then
- TStringList_IndexOf = i
- return
- end if
- end do
- end if
- end do
- TStringList_IndexOf=-1
-
- end function TStringList_IndexOf
-
-
- recursive subroutine QuickSortArr_Real(Arr, Lin, R, index)
- !Sorts an array of pointers to arrays of reals by the value of the index'th entry
- integer, intent(in) :: Lin, R, index
- #ifdef __GFORTRAN__
- type(real_pointer), dimension(:) :: Arr
- #else
- type(real_pointer), dimension(*) :: Arr
- #endif
- integer I, J, L
- real P
- type(real_pointer) :: temp
-
- L = Lin
- do
-
- I = L
- J = R
- P = Arr((L + R)/2)%p(index)
-
- do
- do while (Arr(I)%p(index) < P)
- I = I + 1
- end do
-
- do while (Arr(J)%p(index) > P)
- J = J - 1
- end do
-
- if (I <= J) then
-
- Temp%p => Arr(I)%p
- Arr(I)%p => Arr(J)%p
- Arr(J)%p => Temp%p
- I = I + 1
- J = J - 1
- end if
- if (I > J) exit
-
- end do
- if (L < J) call QuickSortArr_Real(Arr, L, J, index);
- L = I
- if (I >= R) exit
- end do
-
- end subroutine QuickSortArr_Real
-
-
-
- recursive subroutine QuickSortArr(Arr, Lin, R, index)
- !Sorts an array of pointers to arrays of reals by the value of the index'th entry
- integer, intent(in) :: Lin, R, index
- #ifdef __GFORTRAN__
- type(double_pointer), dimension(:) :: Arr
- #else
- type(double_pointer), dimension(*) :: Arr
- #endif
- integer I, J, L
- double precision P
- type(double_pointer) :: temp
-
- L = Lin
- do
-
- I = L
- J = R
- P = Arr((L + R)/2)%p(index)
-
- do
- do while (Arr(I)%p(index) < P)
- I = I + 1
- end do
-
- do while (Arr(J)%p(index) > P)
- J = J - 1
- end do
-
- if (I <= J) then
-
- Temp%p => Arr(I)%p
- Arr(I)%p => Arr(J)%p
- Arr(J)%p => Temp%p
- I = I + 1
- J = J - 1
- end if
- if (I > J) exit
-
- end do
- if (L < J) call QuickSortArr(Arr, L, J, index);
- L = I
- if (I >= R) exit
- end do
-
- end subroutine QuickSortArr
-
-
- end module Lists
-
- module AMLutils
- use Lists
-
- #ifdef DECONLY
- !Comment out if linking to LAPACK/MKL separetly
- !CXML only has LAPACK 2.0
- include 'CXML_INCLUDE.F90'
- #endif
-
-
- #ifdef NAGF95
- use F90_UNIX
- #endif
-
- implicit none
-
- #ifndef NAGF95
- #ifndef GFC
- #ifndef __INTEL_COMPILER_BUILD_DATE
- #ifndef __GFORTRAN__
- integer iargc
- external iargc
- #endif
- #endif
- #endif
- #endif
-
-
- #ifdef MPI
- include "mpif.h"
- #endif
-
- integer :: Feedback = 1
- integer, parameter :: tmp_file_unit = 50
-
-
- double precision, parameter :: pi=3.14159265358979323846264338328d0, &
- twopi=2*pi, fourpi=4*pi
- double precision, parameter :: root2 = 1.41421356237309504880168872421d0, sqrt2 = root2
- double precision, parameter :: log2 = 0.693147180559945309417232121458d0
-
- real, parameter :: pi_r = 3.141592653, twopi_r = 2*pi_r, fourpi_r = twopi_r*2
-
- logical :: flush_write = .true.
- !True means no data lost on crashes, but may make it slower
-
- integer, parameter :: file_units_start = 20
- integer, parameter :: file_units_end = 100
-
- logical file_units(file_units_start:file_units_end)
-
- INTERFACE CONCAT
- module procedure concat_s, concat_s_n
-
- END INTERFACE
-
-
-
- contains
-
- function new_file_unit()
- integer i, new_file_unit
- logical, save :: file_units_inited = .false.
- logical notfree
-
- if (.not. file_units_inited) then
- file_units = .false.
- file_units_inited = .true.
- end if
-
- do i=file_units_start, file_units_end
- if (.not. file_units(i) .and. i/=tmp_file_unit) then
- inquire(i,opened=notfree)
- if (notfree) cycle
- file_units(i)=.true.
- new_file_unit = i
- return
- end if
- end do
-
- call mpiStop('No unused file unit numbers')
-
- end function new_file_unit
-
-
- subroutine CloseFile(i)
- integer, intent(in) :: i
-
- close(i)
- file_units(i) = .false.
-
- end subroutine CloseFile
-
- subroutine ClearFileUnit(i)
- integer, intent(in) :: i
-
- file_units(i) = .false.
-
- end subroutine ClearFileUnit
-
- function GetParamCount()
- integer GetParamCount
-
- GetParamCount = iargc()
-
- end function GetParamCount
-
- function GetMpiRank()
- integer GetMpiRank
- #ifdef MPI
- integer ierror
- call mpi_comm_rank(mpi_comm_world,GetMPIrank,ierror)
- #else
- GetMpiRank=0
- #endif
-
- end function GetMpiRank
-
- function IsMainMPI()
- logical IsMainMPI
-
- IsMainMPI = GetMpiRank() == 0
-
- end function IsMainMPI
-
- subroutine MpiStop(Msg)
- character(LEN=*), intent(in), optional :: Msg
- integer i
- #ifdef MPI
- integer ierror, MpiRank
- #endif
-
- if (present(Msg)) write(*,*) trim(Msg)
-
- #ifdef MPI
- call mpi_comm_rank(mpi_comm_world,MPIrank,ierror)
- write (*,*) 'MpiStop: ', MpiRank
- call MPI_ABORT(MPI_COMM_WORLD,i)
- #endif
- i=1 !put breakpoint on this line to debug
- stop
-
- end subroutine MpiStop
-
- subroutine MpiStat(MpiID, MpiSize)
- implicit none
- integer MpiID,MpiSize
- #ifdef MPI
- integer ierror
- call mpi_comm_rank(mpi_comm_world,MpiID,ierror)
- if (ierror/=MPI_SUCCESS) stop 'MpiStat: MPI rank'
- call mpi_comm_size(mpi_comm_world,MpiSize,ierror)
- #else
- MpiID=0
- MpiSize=1
- #endif
- end subroutine MpiStat
-
- #ifdef __GFORTRAN__
-
- ! ===========================================================
- function iargc ()
- ! ===========================================================
- integer iargc
- ! ===========================================================
-
- iargc=command_argument_count()
- end function iargc
-
- ! ===========================================================
- subroutine getarg(num, res)
- ! ===========================================================
- integer, intent(in) :: num
- character(len=*), intent(out) :: res
- integer l, err
- ! ===========================================================
- call get_command_argument(num,res,l,err)
- end subroutine getarg
-
- #endif
-
-
- function GetParam(i)
-
- character(LEN=512) GetParam
- integer, intent(in) :: i
-
- if (iargc() < i) then
- GetParam = ''
- else
- call getarg(i,GetParam)
- end if
- end function GetParam
-
- function concat_s(S1,S2,S3,S4,S5,S6,S7,S8) result(concat)
- character(LEN=*), intent(in) :: S1, S2
- character(LEN=*), intent(in) , optional :: S3, S4, S5, S6,S7,S8
- character(LEN = 1000) concat
-
- concat = trim(S1) // S2
- if (present(S3)) then
- concat = trim(concat) // S3
- if (present(S4)) then
- concat = trim(concat) // S4
- if (present(S5)) then
- concat = trim(concat) // S5
- if (present(S6)) then
- concat = trim(concat) // S6
- if (present(S7)) then
- concat = trim(concat) // S7
- if (present(S8)) then
- concat = trim(concat) // S8
- end if
- end if
- end if
- end if
- end if
- end if
-
- end function concat_s
-
- function concat_s_n(SS1,N2,SS3,N4,SS5,N6,SS7,N8,SS9,N10,SS11) result(concat)
- character(LEN=*), intent(in) :: SS1
- integer, intent(in) :: N2
- character(LEN=*), intent(in) , optional :: SS3, SS5, SS7, SS9,SS11
- integer, intent(in), optional ::N4,N6,N8, N10
- character(LEN = 1000) concat
-
- concat = trim(SS1) //trim(IntToStr(N2))
- if (present(SS3)) then
- concat = trim(concat) // SS3
- if (present(N4)) then
- concat = trim(concat) // trim(IntToStr(N4))
- if (present(SS5)) then
- concat = trim(concat) // SS5
- if (present(N6)) then
- concat = trim(concat) // trim(intToStr(N6))
- if (present(SS7)) then
- concat = trim(concat) // SS7
- if (present(N8)) then
- concat = trim(concat) // trim(intToStr(N8))
- if (present(SS9)) then
- concat = trim(concat) // SS9
- if (present(N10)) then
- concat = trim(concat) // trim(intToStr(N10))
- if (present(SS11)) then
- concat = trim(concat) // SS11
- end if
- end if
- end if
- end if
- end if
- end if
- end if
- end if
- end if
-
- end function concat_s_n
-
- subroutine Exchange(i1,i2)
- integer i1,i2,tmp
-
- tmp=i1
- i1=i2
- i2=tmp
-
- end subroutine Exchange
-
- subroutine WriteS(S)
- character(LEN=*), intent(in) :: S
-
- write (*,*) trim(S)
-
- end subroutine WriteS
-
- subroutine StringReplace(FindS, RepS, S)
- character(LEN=*), intent(in) :: FindS, RepS
- character(LEN=*), intent(inout) :: S
- integer i
-
- i = index(S,FindS)
- if (i>0) then
- S = S(1:i-1)//trim(RepS)//S(i+len_trim(FindS):len_trim(S))
- end if
-
-
- end subroutine StringReplace
-
- function numcat(S, num)
- character(LEN=*) S
- character(LEN=120) numcat, numstr
- integer num
-
- write (numstr, *) num
- numcat = trim(S) // trim(adjustl(numstr))
- !OK, so can probably do with with a format statement too...
- end function numcat
-
- function LogicalToint(B)
- integer LogicalToint
- logical, intent(in) :: B
-
- if (B) then
- LogicalToInt=1
- else
- LogicalToint=0
- end if
-
- end function LogicalToInt
-
- function IntToLogical(I)
- integer, intent(in) :: I
- logical IntToLogical
-
- IntToLogical = I /= 0
-
- end function IntToLogical
-
- function IntToStr(I, minlen)
- integer , intent(in) :: I
- character(LEN=30) IntToStr
- integer, intent(in), optional :: minlen
- integer n
- character (LEN=20) :: form
-
- if (present(minlen)) then
- n = minlen
- if (I<0) n=n+1
- form = concat('(I',n,'.',minlen,')')
- write (IntToStr,form) i
- else
- write (IntToStr,*) i
- IntToStr = adjustl(IntToStr)
- end if
-
-
- end function IntToStr
-
- function StrToInt(S)
- integer :: StrToInt
- character(LEN=30), intent(in) :: S
-
- read (S,*) StrToInt
- end function StrToInt
-
-
- function RealToStr(R, figs)
- real, intent(in) :: R
- integer, intent(in), optional :: figs
- character(LEN=30) RealToStr
-
- if (abs(R)>=0.001) then
- write (RealToStr,'(f12.6)') R
-
- RealToStr = adjustl(RealToStr)
- if (present(figs)) then
- RealToStr = RealToStr(1:figs)
- else
- RealToStr = RealToStr(1:6)
- end if
-
- else
- if (present(figs)) then
- write (RealToStr,'(E'//trim(numcat('(',figs))//'.2)') R
- else
- write (RealToStr,'(G9.2)') R
- end if
- RealToStr = adjustl(RealToStr)
- end if
-
-
- end function RealToStr
-
- function IndexOf(aval,arr, n)
- integer, intent(in) :: n, arr(n), aval
- integer IndexOf, i
-
- do i=1,n
- if (arr(i)==aval) then
- IndexOf= i
- return
- end if
- end do
- IndexOf = 0
-
- end function IndexOf
-
- function MaxIndex(arr, n)
- integer, intent(in) :: n
- real, intent(in) :: arr(n)
- integer locs(1:1), MaxIndex
-
- locs = maxloc(arr(1:n))
- MaxIndex = locs(1)
-
- end function MaxIndex
-
-
- function MinIndex(arr, n)
- integer, intent(in) :: n
- real, intent(in) :: arr(n)
- integer locs(1:1), MinIndex
-
- locs = minloc(arr(1:n))
- MinIndex = locs(1)
-
- end function MinIndex
-
-
- subroutine TList_RealArr_SaveToFile(L,fname)
- character(LEN=*), intent(IN) :: fname
- Type (TList_RealArr) :: L
- character(LEN=20) aform
- integer i
- integer :: Plen = -1
- integer :: file_id
-
- file_id = new_file_unit()
- call CreateTxtFile(fname,file_id)
- do i=1, L%Count
- if (PLen /= size(L%Items(i)%P)) then
- PLen = size(L%Items(i)%P)
- aform = '('//trim(IntToStr(PLen))//'E16.8)'
- end if
- write (file_id,aform) L%Items(i)%P
- end do
- call CloseFile(file_id)
-
- end subroutine TList_RealArr_SaveToFile
-
-
- function ExtractFilePath(aname)
- character(LEN=*), intent(IN) :: aname
- character(LEN=120) ExtractFilePath
- integer len, i
-
- len = len_trim(aname)
- do i = len, 1, -1
- if (aname(i:i)=='/') then
- ExtractFilePath = aname(1:i)
- return
- end if
- end do
- ExtractFilePath = ''
-
- end function ExtractFilePath
-
- function ExtractFileExt(aname)
- character(LEN=*), intent(IN) :: aname
- character(LEN=120) ExtractFileExt
- integer len, i
-
- len = len_trim(aname)
- do i = len, 1, -1
- if (aname(i:i)=='/') then
- ExtractFileExt = ''
- return
- else if (aname(i:i)=='.') then
- ExtractFileExt= aname(i:len)
- return
- end if
- end do
- ExtractFileExt = ''
-
- end function ExtractFileExt
-
-
- function ExtractFileName(aname)
- character(LEN=*), intent(IN) :: aname
- character(LEN=120) ExtractFileName
- integer len, i
-
- len = len_trim(aname)
- do i = len, 1, -1
- if (aname(i:i)=='/') then
- ExtractFileName = aname(i+1:len)
- return
- end if
- end do
- ExtractFileName = aname
-
- end function ExtractFileName
-
- function ChangeFileExt(aname,ext)
- character(LEN=*), intent(IN) :: aname,ext
- character(LEN=120) ChangeFileExt
- integer len, i
-
- len = len_trim(aname)
- do i = len, 1, -1
- if (aname(i:i)=='.') then
- ChangeFileExt = aname(1:i) // trim(ext)
- return
- end if
- end do
- ChangeFileExt = trim(aname) // '.' // trim(ext)
-
- end function ChangeFileExt
-
-
- function CheckTrailingSlash(aname)
- character(LEN=*), intent(in) :: aname
- character(LEN=120) CheckTrailingSlash
- integer len
-
- len = len_trim(aname)
- #ifdef IBMXL
- if (aname(len:len) /= '\\' .and. aname(len:len) /= '/') then
- #else
- #ifdef ESCAPEBACKSLASH
- if (aname(len:len) /= '\\' .and. aname(len:len) /= '/') then
- #else
- if (aname(len:len) /= '\' .and. aname(len:len) /= '/') then
- #endif
- #endif
- CheckTrailingSlash = trim(aname)//'/'
- else
- CheckTrailingSlash = aname
- end if
-
-
- end function CheckTrailingSlash
-
-
- subroutine DeleteFile(aname)
- character(LEN=*), intent(IN) :: aname
- integer file_id
-
- file_id = new_file_unit()
-
- open(unit = file_id, file = aname, err = 2)
- close(unit = file_id, status = 'DELETE')
- 2 return
-
- file_units(file_id) = .false.
-
- end subroutine DeleteFile
-
-
- subroutine FlushFile(aunit)
- #ifdef __INTEL_COMPILER_BUILD_DATE
- USE IFPORT
- #endif
- integer, intent(IN) :: aunit
-
-
- #ifdef IBMXL
- call flush_(aunit)
- #else
- call flush(aunit)
- #endif
-
- end subroutine FlushFile
-
-
- function FileExists(aname)
- character(LEN=*), intent(IN) :: aname
- logical FileExists
-
- inquire(file=aname, exist = FileExists)
-
- end function FileExists
-
- subroutine OpenFile(aname, aunit,mode)
- character(LEN=*), intent(IN) :: aname,mode
- integer, intent(in) :: aunit
-
-
- open(unit=aunit,file=aname,form=mode,status='old', err=500)
- return
-
- 500 call MpiStop('File not found: '//trim(aname))
-
-
- end subroutine OpenFile
-
-
- subroutine OpenTxtFile(aname, aunit)
- character(LEN=*), intent(IN) :: aname
- integer, intent(in) :: aunit
-
- call OpenFile(aname,aunit,'formatted')
-
- end subroutine OpenTxtFile
-
- subroutine CreateOpenTxtFile(aname, aunit, append)
- character(LEN=*), intent(IN) :: aname
- integer, intent(in) :: aunit
- logical, optional, intent(in) :: append
- logical A
-
- if (present(append)) then
- A=append
- else
- A = .false.
- endif
-
- call CreateOpenFile(aname,aunit,'formatted',A)
-
- end subroutine CreateOpenTxtFile
-
-
- subroutine CreateTxtFile(aname, aunit)
- character(LEN=*), intent(IN) :: aname
- integer, intent(in) :: aunit
-
- call CreateFile(aname,aunit,'formatted')
-
- end subroutine CreateTxtFile
-
-
- subroutine CreateFile(aname, aunit,mode)
- character(LEN=*), intent(IN) :: aname,mode
- integer, intent(in) :: aunit
-
- open(unit=aunit,file=aname,form=mode,status='replace', err=500)
-
- return
-
- 500 call MpiStop('Error creating file '//trim(aname))
-
-
- end subroutine CreateFile
-
- subroutine CreateOpenFile(aname, aunit,mode, append)
- character(LEN=*), intent(IN) :: aname,mode
- integer, intent(in) :: aunit
- logical, optional, intent(in) :: append
- logical A
-
- if (present(append)) then
- A=append
- else
- A = .false.
- endif
-
- if (A) then
- open(unit=aunit,file=aname,form=mode,status='unknown', err=500, position='append')
- else
- open(unit=aunit,file=aname,form=mode,status='replace', err=500)
- end if
-
- return
-
- 500 call MpiStop('Error creatinging or opening '//trim(aname))
-
-
- end subroutine CreateOpenFile
-
-
-
- function FileColumns(aunit) result(n)
- integer, intent(in) :: aunit
- integer n,i
- logical isNum
- character(LEN=4096) :: InLine
-
- n=0
- isNum=.false.
- read(aunit,'(a)', end = 10) InLine
- do i=1, len_trim(InLIne)
- if (verify(InLine(i:i),'-+eE.0123456789') == 0) then
- if (.not. IsNum) n=n+1
- IsNum=.true.
- else
- IsNum=.false.
- end if
- end do
-
- 10 rewind aunit
-
- end function FileColumns
-
- function FileLines(aunit) result(n)
- integer, intent(in) :: aunit
- integer n
- character(LEN=4096) :: InLine
-
- n=0
- do
-
- read(aunit,'(a)', end = 200) InLine
- n = n+1
- end do
-
- 200 rewind aunit
-
-
- end function FileLines
-
-
-
- function TxtFileColumns(aname) result(n)
- character(LEN=*), intent(IN) :: aname
- integer n, file_id
-
-
- file_id = new_file_unit()
-
- call OpenTxtFile(aname, file_id)
- n = FileColumns(file_id)
- call CloseFile(file_id)
-
- end function TxtFileColumns
-
-
- function LastFileLine(aname)
- character(LEN=*), intent(IN) :: aname
- character(LEN = 5000) LastFileLine, InLine
- integer file_id
-
- file_id = new_file_unit()
-
- InLine = ''
- call OpenTxtFile(aname,file_id)
- do
- read(file_id,'(a)', end = 200) InLine
- end do
-
- 200 call CloseFile(file_id)
-
- LastFileLine = InLine
-
- end function LastFileLine
-
-
-
- subroutine spline_real(x,y,n,y2)
-
- integer, intent(in) :: n
- real, intent(in) :: x(n),y(n)
- real, intent(out) :: y2(n)
- integer i,k
- real p,qn,sig,un
- real, dimension(:), allocatable :: u
-
-
- allocate(u(1:n))
-
- y2(1)=0
- u(1)=0
-
- do i=2,n-1
- sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
- p=sig*y2(i-1)+2.0
-
- y2(i)=(sig-1.0)/p
-
- u(i)=(6.0*((y(i+1)-y(i))/(x(i+ &
- 1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
- u(i-1))/p
- end do
- qn=0.0
- un=0.0
-
- y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.0)
- do k=n-1,1,-1
- y2(k)=y2(k)*y2(k+1)+u(k)
- end do
-
- deallocate(u)
-
- ! (C) Copr. 1986-92 Numerical Recipes Software, adapted.
- end subroutine spline_real
-
-
- subroutine spline_double(x,y,n,y2)
-
- integer, intent(in) :: n
- double precision, intent(in) :: x(n),y(n)
- double precision, intent(out) :: y2(n)
- integer i,k
- double precision p,qn,sig,un
- double precision, dimension(:), allocatable :: u
-
-
- allocate(u(1:n))
-
- y2(1)=0
- u(1)=0
-
- do i=2,n-1
- sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
- p=sig*y2(i-1)+2
-
- y2(i)=(sig-1)/p
-
- u(i)=(6*((y(i+1)-y(i))/(x(i+ &
- 1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
- u(i-1))/p
- end do
- qn=0
- un=0
-
- y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1)
- do k=n-1,1,-1
- y2(k)=y2(k)*y2(k+1)+u(k)
- end do
-
- deallocate(u)
-
- ! (C) Copr. 1986-92 Numerical Recipes Software, adapted.
- end subroutine spline_double
-
-
- function DLGAMMA(x)
- !Use Stirling generalization for large x
- !See e.g. http://en.wikipedia.org/wiki/Stirling's_approximation
- !Is accurate to at least 10 decimals, worse just about 30
- double precision :: x
- double precision:: DLGAMMA !approx log gamma
- double precision, parameter :: const = .91893853320467274180d0 !log(2pi)/2
-
- if (x<32.d0) then
- DLGAMMA = log(GAMMA(x))
- else
- DLGAMMA = (x-0.5d0)*log(x) - x + const + &
- 1/12.d0/(1+x)*(1+1/(x+2)*(1+59.d0/30/(x+3)*(1+2.9491525423728813559d0/(x+4))))
- end if
- end function DLGAMMA
-
-
- function LogGamma(x)
- real LogGamma
- real, intent(in) :: x
- integer i, j
- real r
-
- i = nint(x*2)
- if (abs(i-x*2) > 1e-4) call MpiStop('LogGamma function for half integral only')
- if (mod(i,2) == 0) then
- r=0
- do j = 2, i/2-1
- r = r + log(real(j))
- end do
- LogGamma = r
- else
- r = log(pi)/2
- do j = 1, i-2 , 2
- r = r+ log(j/2.0)
- end do
- LogGamma = r
- end if
-
- end function LogGamma
-
- DOUBLE PRECISION FUNCTION GAMMA(X)
- !----------------------------------------------------------------------
- !
- ! This routine calculates the GAMMA function for a real argument X.
- ! Computation is based on an algorithm outlined in reference 1.
- ! The program uses rational functions that approximate the GAMMA
- ! function to at least 20 significant decimal digits. Coefficients
- ! for the approximation over the interval (1,2) are unpublished.
- ! Those for the approximation for X .GE. 12 are from reference 2.
- ! The accuracy achieved depends on the arithmetic system, the
- ! compiler, the intrinsic functions, and proper selection of the
- ! machine-dependent constants.
- !*******************************************************************
- !
- ! Explanation of machine-dependent constants
- !
- ! beta - radix for the floating-point representation
- ! maxexp - the smallest positive power of beta that overflows
- ! XBIG - the largest argument for which GAMMA(X) is representable
- ! in the machine, i.e., the solution to the equation
- ! GAMMA(XBIG) = beta**maxexp
- ! XINF - the largest machine representable floating-point number;
- ! approximately beta**maxexp
- ! EPS - the smallest positive floating-point number such that
- ! 1.0+EPS .GT. 1.0
- ! XMININ - the smallest positive floating-point number such that
- ! 1/XMININ is machine representable
- !
- ! Approximate values for some important machines are:
- !
- ! beta maxexp XBIG
- !
- ! CRAY-1 (S.P.) 2 8191 966.961
- ! Cyber 180/855
- ! under NOS (S.P.) 2 1070 177.803
- ! IEEE (IBM/XT,
- ! SUN, etc.) (S.P.) 2 128 35.040
- ! IEEE (IBM/XT,
- ! SUN, etc.) (D.P.) 2 1024 171.624
- ! IBM 3033 (D.P.) 16 63 57.574
- ! VAX D-Format (D.P.) 2 127 34.844
- ! VAX G-Format (D.P.) 2 1023 171.489
- !
- ! XINF EPS XMININ
- !
- ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466
- ! Cyber 180/855
- ! under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294
- ! IEEE (IBM/XT,
- ! SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-38
- ! IEEE (IBM/XT,
- ! SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-308
- ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76
- ! VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-39
- ! VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-308
- !
- !*******************************************************************
- !*******************************************************************
- !
- ! Error returns
- !
- ! The program returns the value XINF for singularities or
- ! when overflow would occur. The computation is believed
- ! to be free of underflow and overflow.
- !
- !
- ! Intrinsic functions required are:
- !
- ! INT, DBLE, EXP, LOG, REAL, SIN
- !
- !
- ! References: "An Overview of Software Development for Special
- ! Functions", W. J. Cody, Lecture Notes in Mathemati,
- ! 506, Numerical Analysis Dundee, 1975, G. A. Watson
- ! (ed.), Springer Verlag, Berlin, 1976.
- !
- ! Computer Approximations, Hart, Et. Al., Wiley and
- ! sons, New York, 1968.
- !
- ! Latest modification: October 12, 1989
- !
- ! Authors: W. J. Cody and L. Stoltz
- ! Applied Mathemati Division
- ! Argonne National Laboratory
- ! Argonne, IL 60439
- !
- !----------------------------------------------------------------------
- INTEGER I,N
- LOGICAL PARITY
- DOUBLE PRECISION C,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE, &
- TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
- DIMENSION C(7),P(8),Q(8)
- !----------------------------------------------------------------------
- ! Mathematical constants
- !----------------------------------------------------------------------
- DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/, &
- SQRTPI/0.9189385332046727417803297D0/, &
- PI/3.1415926535897932384626434D0/
- !----------------------------------------------------------------------
- ! Machine dependent parameters
- !----------------------------------------------------------------------
- DATA XBIG,XMININ,EPS/35.040D0,1.18D-38,1.19D-7/, &
- XINF/3.4E38/
- !----------------------------------------------------------------------
- ! Numerator and denominator coefficients for rational minimax
- ! approximation over (1,2).
- !----------------------------------------------------------------------
- DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1, &
- -3.79804256470945635097577E+2,6.29331155312818442661052E+2, &
- 8.66966202790413211295064E+2,-3.14512729688483675254357E+4, &
- -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
- DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2, &
- -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, &
- 2.25381184209801510330112E+4,4.75584627752788110767815E+3, &
- -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
- !----------------------------------------------------------------------
- ! Coefficients for minimax approximation over (12, INF).
- !----------------------------------------------------------------------
- DATA C/-1.910444077728D-03,8.4171387781295D-04, &
- -5.952379913043012D-04,7.93650793500350248D-04, &
- -2.777777777777681622553D-03,8.333333333333333331554247D-02, &
- 5.7083835261D-03/
- !----------------------------------------------------------------------
- ! Statement functions for conversion between integer and float
- !----------------------------------------------------------------------
- PARITY = .FALSE.
- FACT = ONE
- N = 0
- Y = X
- IF (Y .LE. ZERO) THEN
- !----------------------------------------------------------------------
- ! Argument is negative
- !----------------------------------------------------------------------
- Y = -X
- Y1 = AINT(Y)
- RES = Y - Y1
- IF (RES .NE. ZERO) THEN
- IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE.
- FACT = -PI / SIN(PI*RES)
- Y = Y + ONE
- ELSE
- RES = XINF
- GO TO 900
- END IF
- END IF
- !----------------------------------------------------------------------
- ! Argument is positive
- !----------------------------------------------------------------------
- IF (Y .LT. EPS) THEN
- !----------------------------------------------------------------------
- ! Argument .LT. EPS
- !----------------------------------------------------------------------
- IF (Y .GE. XMININ) THEN
- RES = ONE / Y
- ELSE
- RES = XINF
- GO TO 900
- END IF
- ELSE IF (Y .LT. TWELVE) THEN
- Y1 = Y
- IF (Y .LT. ONE) THEN
- !----------------------------------------------------------------------
- ! 0.0 .LT. argument .LT. 1.0
- !----------------------------------------------------------------------
- Z = Y
- Y = Y + ONE
- ELSE
- !----------------------------------------------------------------------
- ! 1.0 .LT. argument .LT. 12.0, reduce argument if necessary
- !----------------------------------------------------------------------
- N = INT(Y) - 1
- Y = Y - REAL(N)
- Z = Y - ONE
- END IF
- !----------------------------------------------------------------------
- ! Evaluate approximation for 1.0 .LT. argument .LT. 2.0
- !----------------------------------------------------------------------
- XNUM = ZERO
- XDEN = ONE
- DO 260 I = 1, 8
- XNUM = (XNUM + P(I)) * Z
- XDEN = XDEN * Z + Q(I)
- 260 CONTINUE
- RES = XNUM / XDEN + ONE
- IF (Y1 .LT. Y) THEN
- !----------------------------------------------------------------------
- ! Adjust result for case 0.0 .LT. argument .LT. 1.0
- !----------------------------------------------------------------------
- RES = RES / Y1
- ELSE IF (Y1 .GT. Y) THEN
- !----------------------------------------------------------------------
- ! Adjust result for case 2.0 .LT. argument .LT. 12.0
- !----------------------------------------------------------------------
- DO 290 I = 1, N
- RES = RES * Y
- Y = Y + ONE
- 290 CONTINUE
- END IF
- ELSE
- !----------------------------------------------------------------------
- ! Evaluate for argument .GE. 12.0,
- !----------------------------------------------------------------------
- IF (Y .LE. XBIG) THEN
- YSQ = Y * Y
- SUM = C(7)
- DO 350 I = 1, 6
- SUM = SUM / YSQ + C(I)
- 350 CONTINUE
- SUM = SUM/Y - Y + SQRTPI
- SUM = SUM + (Y-HALF)*LOG(Y)
- RES = EXP(SUM)
- ELSE
- RES = XINF
- GO TO 900
- END IF
- END IF
- !----------------------------------------------------------------------
- ! Final adjustments and return
- !----------------------------------------------------------------------
- IF (PARITY) RES = -RES
- IF (FACT .NE. ONE) RES = FACT / RES
- 900 GAMMA = RES
-
- END FUNCTION GAMMA
-
- subroutine SetIdlePriority
- #ifdef RUNIDLE
- USE DFWIN
- Integer dwPriority
- Integer CheckPriority
-
- dwPriority = 64 ! idle priority
- CheckPriority = SetPriorityClass(GetCurrentProcess(), dwPriority)
- #endif
- end subroutine SetIdlePriority
-
-
- subroutine GetThreeJs(thrcof,l2in,l3in,m2in,m3in)
- !Recursive evaluation of 3j symbols. Does minimal error checking on input parameters.
- implicit none
- integer, parameter :: dl = KIND(1.d0)
- integer, intent(in) :: l2in,l3in, m2in,m3in
- real(dl), dimension(*) :: thrcof
- #ifdef THREEJ
- INTEGER, PARAMETER :: i8 = 8
- integer(i8) :: l2,l3,m2,m3
- integer(i8) :: l1, m1, l1min,l1max, lmatch, nfin, a1, a2
-
- real(dl) :: newfac, oldfac, sumfor, c1,c2,c1old, dv, denom, x, sum1, sumuni
- real(dl) :: x1,x2,x3, y,y1,y2,y3,sum2,sumbac, ratio,cnorm, sign1, thresh
- integer i,ier, index, nlim, sign2
- integer nfinp1,nfinp2,nfinp3, lstep, nstep2,n
- real(dl), parameter :: zero = 0._dl, one = 1._dl
- real(dl), parameter :: tiny = 1.0d-30, srtiny=1.0d-15, huge = 1.d30, srhuge = 1.d15
-
- ! routine to generate set of 3j-coeffs (l1,l2,l3\\ m1,m2,m3)
-
- ! by recursion from l1min = max(abs(l2-l3),abs(m1))
- ! to l1max = l2+l3
- ! the resulting 3j-coeffs are stored as thrcof(l1-l1min+1)
-
- ! to achieve the numerical stability, the recursion will proceed
- ! simultaneously forwards and backwards, starting from l1min and l1max
- ! respectively.
- !
- ! lmatch is the l1-value at which forward and backward recursion are matched.
- !
- ! ndim is the length of the array thrcof
- !
- ! ier = -1 for all 3j vanish(l2-abs(m2)<0, l3-abs(m3)<0 or not integer)
- ! ier = -2 if possible 3j's exceed ndim
- ! ier >= 0 otherwise
-
- l2=l2in
- l3=l3in
- m2=m2in
- m3=m3in
- newfac = 0
- lmatch = 0
- m1 = -(m2+m3)
-
- ! check relative magnitude of l and m values
- ier = 0
-
- if (l2 < abs(m2) .or. l3 < m3) then
- ier = -1
- call MpiStop('error ier = -1')
- return
- end if
-
- ! limits for l1
- l1min = max(abs(l2-l3),abs(m1))
- l1max = l2+l3
-
- if (l1min >= l1max) then
- if (l1min/=l1max) then
- ier = -1
- call MpiStop('error ier = -1')
- return
- end if
-
- ! reached if l1 can take only one value, i.e.l1min=l1max
- thrcof(1) = (-1)**abs(l2+m2-l3+m3)/sqrt(real(l1min+l2+l3+1,dl))
- return
-
- end if
-
- nfin = l1max-l1min+1
-
- ! starting forward recursion from l1min taking nstep1 steps
- l1 = l1min
- thrcof(1) = srtiny
- sum1 = (2*l1 + 1)*tiny
-
- lstep = 1
-
- 30 lstep = lstep+1
- l1 = l1+1
-
- oldfac = newfac
- a1 = (l1+l2+l3+1)*(l1-l2+l3)*(l1+l2-l3)
- a2 = (l1+m1)*(l1-m1)*(-l1+l2+l3+1)
- newfac = sqrt(a2*real(a1,dl))
- if (l1 == 1) then
- !IF L1 = 1 (L1-1) HAS TO BE FACTORED OUT OF DV, HENCE
- c1 = -(2*l1-1)*l1*(m3-m2)/newfac
- else
-
- dv = -l2*(l2+1)*m1 + l3*(l3+1)*m1 + l1*(l1-1)*(m3-m2)
- denom = (l1-1)*newfac
-
- if (lstep > 2) c1old = abs(c1)
- c1 = -(2*l1-1)*dv/denom
-
- end if
-
- if (lstep<= 2) then
-
- ! if l1=l1min+1 the third term in the recursion eqn vanishes, hence
- x = srtiny*c1
- thrcof(2) = x
- sum1 = sum1+tiny*(2*l1+1)*c1*c1
- if(lstep==nfin) then
- sumuni=sum1
- go to 230
- end if
- goto 30
-
- end if
-
- c2 = -l1*oldfac/denom
-
- ! recursion to the next 3j-coeff x
- x = c1*thrcof(lstep-1) + c2*thrcof(lstep-2)
- thrcof(lstep) = x
- sumfor = sum1
- sum1 = sum1 + (2*l1+1)*x*x
- if (lstep/=nfin) then
-
- ! see if last unnormalised 3j-coeff exceeds srhuge
- if (abs(x) >= srhuge) then
-
- ! REACHED IF LAST 3J-COEFFICIENT LARGER THAN SRHUGE
- ! SO THAT THE RECURSION SERIES THRCOF(1), ... , THRCOF(LSTEP)
- ! HAS TO BE RESCALED TO PREVENT OVERFLOW
-
- ier = ier+1
- do i = 1, lstep
- if (abs(thrcof(i)) < srtiny) thrcof(i)= zero
- thrcof(i) = thrcof(i)/srhuge
- end do
-
- sum1 = sum1/huge
- sumfor = sumfor/huge
- x = x/srhuge
-
- end if
-
- ! as long as abs(c1) is decreasing, the recursion proceeds towards increasing
- ! 3j-valuse and so is numerically stable. Once an increase of abs(c1) is
- ! detected, the recursion direction is reversed.
-
- if (c1old > abs(c1)) goto 30
-
- end if !lstep/=nfin
-
- ! keep three 3j-coeffs around lmatch for comparison with backward recursion
-
- lmatch = l1-1
- x1 = x
- x2 = thrcof(lstep-1)
- x3 = thrcof(lstep-2)
- nstep2 = nfin-lstep+3
-
- ! --------------------------------------------------------------------------
- !
- ! starting backward recursion from l1max taking nstep2 stpes, so that
- ! forward and backward recursion overlap at 3 points
- ! l1 = lmatch-1, lmatch, lmatch+1
-
- nfinp1 = nfin+1
- nfinp2 = nfin+2
- nfinp3 = nfin+3
- l1 = l1max
- thrcof(nfin) = srtiny
- sum2 = tiny*(2*l1+1)
-
- l1 = l1+2
- lstep=1
-
- do
- lstep = lstep + 1
- l1= l1-1
-
- oldfac = newfac
- a1 = (l1+l2+l3)*(l1-l2+l3-1)*(l1+l2-l3-1)
- a2 = (l1+m1-1)*(l1-m1-1)*(-l1+l2+l3+2)
- newfac = sqrt(a1*real(a2,dl))
-
- dv = -l2*(l2+1)*m1 + l3*(l3+1)*m1 +l1*(l1-1)*(m3-m2)
-
- denom = l1*newfac
- c1 = -(2*l1-1)*dv/denom
- if (lstep <= 2) then
-
- ! if l2=l2max+1, the third term in the recursion vanishes
-
- y = srtiny*c1
- thrcof(nfin-1) = y
- sumbac = sum2
- sum2 = sum2 + tiny*(2*l1-3)*c1*c1
-
- cycle
-
- end if
-
- c2 = -(l1-1)*oldfac/denom
-
- ! recursion to the next 3j-coeff y
- y = c1*thrcof(nfinp2-lstep)+c2*thrcof(nfinp3-lstep)
-
- if (lstep==nstep2) exit
-
- thrcof(nfinp1-lstep) = y
- sumbac = sum2
- sum2 = sum2+(2*l1-3)*y*y
-
- ! see if last unnormalised 3j-coeff exceeds srhuge
- if (abs(y) >= srhuge) then
-
- ! reached if 3j-coeff larger than srhuge so that the recursion series
- ! thrcof(nfin),..., thrcof(nfin-lstep+1) has to be rescaled to prevent overflow
-
- ier=ier+1
- do i = 1, lstep
- index=nfin-i+1
- if (abs(thrcof(index)) < srtiny) thrcof(index)=zero
- thrcof(index) = thrcof(index)/srhuge
- end do
-
- sum2=sum2/huge
- sumbac=sumbac/huge
-
- end if
-
- end do
-
- ! the forward recursion 3j-coeffs x1, x2, x3 are to be matched with the
- ! corresponding backward recursion vals y1, y2, y3
-
- y3 = y
- y2 = thrcof(nfinp2-lstep)
- y1 = thrcof(nfinp3-lstep)
-
- ! determine now ratio such that yi=ratio*xi (i=1,2,3) holds with minimal error
-
- ratio = (x1*y1+x2*y2+x3*y3)/(x1*x1+x2*x2+x3*x3)
- nlim = nfin-nstep2+1
-
- if (abs(ratio) >= 1) then
-
- thrcof(1:nlim) = ratio*thrcof(1:nlim)
- sumuni = ratio*ratio*sumfor + sumbac
-
- else
-
- nlim = nlim+1
- ratio = 1/ratio
- do n = nlim, nfin
- thrcof(n) = ratio*thrcof(n)
- end do
- sumuni = sumfor + ratio*ratio*sumbac
-
- end if
- ! normalise 3j-coeffs
-
- 230 cnorm = 1/sqrt(sumuni)
-
- ! sign convention for last 3j-coeff determines overall phase
-
- sign1 = sign(one,thrcof(nfin))
- sign2 = (-1)**(abs(l2+m2-l3+m3))
- if (sign1*sign2 <= 0) then
- cnorm = -cnorm
- end if
- if (abs(cnorm) >= one) then
- thrcof(1:nfin) = cnorm*thrcof(1:nfin)
- return
- end if
-
- thresh = tiny/abs(cnorm)
-
- do n = 1, nfin
- if (abs(thrcof(n)) < thresh) thrcof(n) = zero
- thrcof(n) = cnorm*thrcof(n)
- end do
- return
- #else
- call MpiStop('must compile with -DTHREEJ to use 3j routine')
-
- !Just prevent unused variable warnings:
- thrcof(1)=l2in+l3in+m2in+m3in
- #endif
-
-
- end subroutine GetThreeJs
-
-
-
- end module AMLutils
-
-
- #ifdef ZIGGURAT
- MODULE Ziggurat
- ! Marsaglia & Tsang generator for random normals & random exponentials.
- ! Translated from C by Alan Miller (amiller@bigpond.net.au)
-
- ! Marsaglia, G. & Tsang, W.W. (2000) `The ziggurat method for generating
- ! random variables', J. Statist. Software, v5(8).
-
- ! This is an electronic journal which can be downloaded from:
- ! http://www.jstatsoft.org/v05/i08
-
- ! N.B. It is assumed that all integers are 32-bit.
- ! N.B. The value of M2 has been halved to compensate for the lack of
- ! unsigned integers in Fortran.
-
- ! Latest version - 1 January 2001
- !
- ! AL: useful material at http://en.wikipedia.org/wiki/Ziggurat_algorithm
- IMPLICIT NONE
-
- PRIVATE
-
- INTEGER, PARAMETER :: DP=SELECTED_REAL_KIND( 12, 60 )
- REAL(DP), PARAMETER :: m1=2147483648.0_DP, m2=2147483648.0_DP, &
- half=0.5_DP
- REAL(DP) :: dn=3.442619855899_DP, tn=3.442619855899_DP, &
- vn=0.00991256303526217_DP, &
- q, de=7.697117470131487_DP, &
- te=7.697117470131487_DP, &
- ve=0.003949659822581572_DP
- INTEGER, SAVE :: iz, jz, jsr=123456789, kn(0:127), &
- ke(0:255), hz
- REAL(DP), SAVE :: wn(0:127), fn(0:127), we(0:255), fe(0:255)
- LOGICAL, SAVE :: initialized=.FALSE.
-
- PUBLIC :: zigset, shr3, uni, rnor, rexp
-
-
- CONTAINS
-
-
- SUBROUTINE zigset( jsrseed )
-
- INTEGER, INTENT(IN) :: jsrseed
-
- INTEGER :: i
-
- ! Set the seed
- jsr = jsrseed
-
- ! Tables for RNOR
- q = vn*EXP(half*dn*dn)
- kn(0) = (dn/q)*m1
- kn(1) = 0
- wn(0) = q/m1
- wn(127) = dn/m1
- fn(0) = 1.0_DP
- fn(127) = EXP( -half*dn*dn )
- DO i = 126, 1, -1
- dn = SQRT( -2.0_DP * LOG( vn/dn + EXP( -half*dn*dn ) ) )
- kn(i+1) = (dn/tn)*m1
- tn = dn
- fn(i) = EXP(-half*dn*dn)
- wn(i) = dn/m1
- END DO
-
- ! Tables for REXP
- q = ve*EXP( de )
- ke(0) = (de/q)*m2
- ke(1) = 0
- we(0) = q/m2
- we(255) = de/m2
- fe(0) = 1.0_DP
- fe(255) = EXP( -de )
- DO i = 254, 1, -1
- de = -LOG( ve/de + EXP( -de ) )
- ke(i+1) = m2 * (de/te)
- te = de
- fe(i) = EXP( -de )
- we(i) = de/m2
- END DO
- initialized = .TRUE.
- RETURN
- END SUBROUTINE zigset
-
-
-
- ! Generate random 32-bit integers
- FUNCTION shr3( ) RESULT( ival )
- INTEGER :: ival
-
- jz = jsr
- jsr = IEOR( jsr, ISHFT( jsr, 13 ) )
- jsr = IEOR( jsr, ISHFT( jsr, -17 ) )
- jsr = IEOR( jsr, ISHFT( jsr, 5 ) )
- ival = jz + jsr
- RETURN
- END FUNCTION shr3
-
-
-
- ! Generate uniformly distributed random numbers
- FUNCTION uni( ) RESULT( fn_val )
- REAL(DP) :: fn_val
-
- fn_val = half + 0.2328306e-9_DP * shr3( )
- RETURN
- END FUNCTION uni
-
-
-
- ! Generate random normals
- FUNCTION rnor( ) RESULT( fn_val )
- REAL(DP) :: fn_val
-
- REAL(DP), PARAMETER :: r = 3.442620_DP
- REAL(DP) :: x, y
-
- IF( .NOT. initialized ) CALL zigset( jsr )
- hz = shr3( )
- iz = IAND( hz, 127 )
- IF( ABS( hz ) < kn(iz) ) THEN
- fn_val = hz * wn(iz)
- ELSE
- DO
- IF( iz == 0 ) THEN
- DO
- x = -0.2904764_DP* LOG( uni( ) )
- y = -LOG( uni( ) )
- IF( y+y >= x*x ) EXIT
- END DO
- fn_val = r+x
- IF( hz <= 0 ) fn_val = -fn_val
- RETURN
- END IF
- x = hz * wn(iz)
- IF( fn(iz) + uni( )*(fn(iz-1)-fn(iz)) < EXP(-half*x*x) ) THEN
- fn_val = x
- RETURN
- END IF
- hz = shr3( )
- iz = IAND( hz, 127 )
- IF( ABS( hz ) < kn(iz) ) THEN
- fn_val = hz * wn(iz)
- RETURN
- END IF
- END DO
- END IF
- RETURN
- END FUNCTION rnor
-
-
-
- ! Generate random exponentials
- FUNCTION rexp( ) RESULT( fn_val )
- REAL(DP) :: fn_val
-
- REAL(DP) :: x
-
- IF( .NOT. initialized ) CALL Zigset( jsr )
- jz = shr3( )
- iz = IAND( jz, 255 )
- IF( ABS( jz ) < ke(iz) ) THEN
- fn_val = ABS(jz) * we(iz)
- RETURN
- END IF
- DO
- IF( iz == 0 ) THEN
- fn_val = 7.69711 - LOG( uni( ) )
- RETURN
- END IF
- x = ABS( jz ) * we(iz)
- IF( fe(iz) + uni( )*(fe(iz-1) - fe(iz)) < EXP( -x ) ) THEN
- fn_val = x
- RETURN
- END IF
- jz = shr3( )
- iz = IAND( jz, 255 )
- IF( ABS( jz ) < ke(iz) ) THEN
- fn_val = ABS( jz ) * we(iz)
- RETURN
- END IF
- END DO
- RETURN
- END FUNCTION rexp
-
- END MODULE ziggurat
- #endif
-
-
-
- module Random
- integer :: rand_inst = 0
- logical, parameter :: use_ziggurat = .false.
- !Ziggurat is significantly (3-4x) faster, see Wikipedia for details
- !Have seem some suspicious things, though couldn't replicate; may be OK..
-
- contains
-
- subroutine initRandom(i)
- use AMLUtils
- #ifdef ZIGGURAT
- use Ziggurat
- #endif
- implicit none
- integer, optional, intent(IN) :: i
- integer seed_in,kl,ij
- character(len=10) :: fred
- real :: klr
-
- if (present(i)) then
- seed_in = i
- else
- seed_in = -1
- end if
- if (seed_in /=-1) then
- kl = 9373
- ij = i
- else
- call system_clock(count=ij)
- ij = mod(ij + rand_inst*100, 31328)
- call date_and_time(time=fred)
- read (fred,'(e10.3)') klr
- kl = mod(int(klr*1000), 30081)
- end if
-
- if (Feedback > 0 ) write(*,'(" Random seeds:",1I6,",",1I6," rand_inst:",1I4)') ij,kl,rand_inst
- call rmarin(ij,kl)
- #ifdef ZIGGURAT
- if (use_ziggurat) call zigset(ij)
- #endif
- end subroutine initRandom
-
- subroutine RandIndices(indices, nmax, n)
- use AMLUtils
- integer, intent(in) :: nmax, n
- integer indices(n),i, ix
- integer tmp(nmax)
-
- if (n> nmax) call MpiStop('Error in RandIndices, n > nmax')
- do i=1, nmax
- tmp(i)=i
- end do
- do i=1, n
- ix = int(ranmar()*(nmax +1 -i)) + 1
- indices(i) = tmp(ix)
- tmp(ix) = tmp(nmax+1-i)
- end do
-
- end subroutine RandIndices
-
-
- subroutine RandRotation(R, N)
- !this is most certainly not the world's most efficient or robust random rotation generator
- integer, intent(in) :: N
- real R(N,N), vec(N), norm
- integer i,j
-
- do j = 1, N
- do
- do i = 1, N
- vec(i) = Gaussian1()
- end do
- do i = 1, j-1
- vec = vec - sum(vec*R(i,:))*R(i,:)
- end do
- norm = sum(vec**2)
- if (norm > 1e-3) exit
- end do
- R(j,:) = vec / sqrt(norm)
- end do
-
- end subroutine RandRotation
-
-
- double precision function GAUSSIAN1()
- #ifdef ZIGGURAT
- use Ziggurat
- #endif
- implicit none
- double precision R, V1, V2, FAC
- integer, save :: iset = 0
- double precision, save :: gset
-
- if (use_ziggurat) then
- #ifdef ZIGGURAT
- Gaussian1 = rnor( )
- #endif
- else
- !Box muller
- if (ISET==0) then
- R=2
- do while (R >= 1.d0)
- V1=2.d0*ranmar()-1.d0
- V2=2.d0*ranmar()-1.d0
- R=V1**2+V2**2
- end do
- FAC=sqrt(-2.d0*log(R)/R)
- GSET=V1*FAC
- GAUSSIAN1=V2*FAC
- ISET=1
- else
- GAUSSIAN1=GSET
- ISET=0
- endif
- end if
- end function GAUSSIAN1
-
-
- double precision function CAUCHY1()
- implicit none
-
- Cauchy1 = Gaussian1()/max(1d-15,abs(Gaussian1()))
-
- end function CAUCHY1
-
-
- real FUNCTION RANDEXP1()
- !
- ! Random-number generator for the exponential distribution
- ! Algorithm EA from J. H. Ahrens and U. Dieter,
- ! Communications of the ACM, 31 (1988) 1330--1337.
- ! Coded by K. G. Hamilton, December 1996, with corrections.
- !
- real u, up, g, y
-
- real, parameter :: alog2= 0.6931471805599453
- real, parameter :: a = 5.7133631526454228
- real, parameter :: b = 3.4142135623730950
- real, parameter :: c = -1.6734053240284925
- real, parameter :: p = 0.9802581434685472
- real, parameter :: aa = 5.6005707569738080
- real, parameter :: bb = 3.3468106480569850
- real, parameter :: hh = 0.0026106723602095
- real, parameter :: dd = 0.0857864376269050
-
- u = ranmar()
- do while (u.le.0) ! Comment out this block
- u = ranmar() ! if your RNG can never
- enddo ! return exact zero
- g = c
- u = u+u
- do while (u.lt.1.0)
- g = g + alog2
- u = u+u
- enddo
- u = u-1.0
- if (u.le.p) then
- randexp1 = g + aa/(bb-u)
- return
- endif
- do
- u = ranmar()
- y = a/(b-u)
- up = ranmar()
- if ((up*hh+dd)*(b-u)**2 .le. exp(-(y+c))) then
- randexp1 = g+y
- return
- endif
- enddo
-
- end function randexp1
-
-
- ! This random number generator originally appeared in ''Toward a Universal
- ! Random Number Generator'' by George Marsaglia and Arif Zaman.
- ! Florida State University Report: FSU-SCRI-87-50 (1987)
- !
- ! It was later modified by F. James and published in ''A Review of Pseudo-
- ! random Number Generators''
- !
- ! THIS IS THE BEST KNOWN RANDOM NUMBER GENERATOR AVAILABLE.
- ! (However, a newly discovered technique can yield
- ! a period of 10^600. But that is still in the development stage.)
- !
- ! It passes ALL of the tests for random number generators and has a period
- ! of 2^144, is completely portable (gives bit identical results on all
- ! machines with at least 24-bit mantissas in the floating point
- ! representation).
- !
- ! The algorithm is a combination of a Fibonacci sequence (with lags of 97
- ! and 33, and operation "subtraction plus one, modulo one") and an
- ! "arithmetic sequence" (using subtraction).
- !
- ! On a Vax 11/780, this random number generator can produce a number in
- ! 13 microseconds.
- !========================================================================
- !
- ! PROGRAM TstRAN
- ! INTEGER IJ, KL, I
- ! Thee are the seeds needed to produce the test case results
- ! IJ = 1802
- ! KL = 9373
- !
- !
- ! Do the initialization
- ! call rmarin(ij,kl)
- !
- ! Generate 20000 random numbers
- ! do 10 I = 1, 20000
- ! x = RANMAR()
- !10 continue
- !
- ! If the random number generator is working properly, the next six random
- ! numbers should be:
- ! 6533892.0 14220222.0 7275067.0
- ! 6172232.0 8354498.0 10633180.0
- !
- !
- !
- ! write(6,20) (4096.0*4096.0*RANMAR(), I=1,6)
- !20 format (3f12.1)
- ! end
- !
- subroutine RMARIN(IJ,KL)
- ! This is the initialization routine for the random number generator RANMAR()
- ! NOTE: The seed variables can have values between: 0 <= IJ <= 31328
- ! 0 <= KL <= 30081
- !The random number sequences created by these two seeds are of sufficient
- ! length to complete an entire calculation with. For example, if sveral
- ! different groups are working on different parts of the same calculation,
- ! each group could be assigned its own IJ seed. This would leave each group
- ! with 30000 choices for the second seed. That is to say, this random
- ! number generator can create 900 million different subsequences -- with
- ! each subsequence having a length of approximately 10^30.
- !
- ! Use IJ = 1802 & KL = 9373 to test the random number generator. The
- ! subroutine RANMAR should be used to generate 20000 random numbers.
- ! Then display the next six random numbers generated multiplied by 4096*4096
- ! If the random number generator is working properly, the random numbers
- ! should be:
- ! 6533892.0 14220222.0 7275067.0
- ! 6172232.0 8354498.0 10633180.0
- double precision U(97), C, CD, CM, S, T
- integer I97, J97,i,j,k,l,m
- integer ij,kl
- integer ii,jj
-
-
- ! INTEGER IRM(103)
-
- common /RASET1/ U, C, CD, CM, I97, J97
- if( IJ .lt. 0 .or. IJ .gt. 31328 .or. &
- KL .lt. 0 .or. KL .gt. 30081 ) then
- print '(A)', ' The first random number seed must have a value between 0 and 31328'
- print '(A)',' The second seed must have a value between 0 and 30081'
- stop
- endif
- I = mod(IJ/177, 177) + 2
- J = mod(IJ , 177) + 2
- K = mod(KL/169, 178) + 1
- L = mod(KL, 169)
- do 2 II = 1, 97
- S = 0.0
- T = 0.5
- do 3 JJ = 1, 24
- M = mod(mod(I*J, 179)*K, 179)
- I = J
- J = K
- K = M
- L = mod(53*L+1, 169)
- if (mod(L*M, 64) .ge. 32) then
- S = S + T
- endif
- T = 0.5 * T
- 3 continue
- U(II) = S
- 2 continue
- C = 362436.0 / 16777216.0
- CD = 7654321.0 / 16777216.0
- CM = 16777213.0 /16777216.0
- I97 = 97
- J97 = 33
-
- end subroutine RMARIN
-
- double precision function RANMAR()
- ! This is the random number generator proposed by George Marsaglia in
- ! Florida State University Report: FSU-SCRI-87-50
- ! It was slightly modified by F. James to produce an array of pseudorandom
- ! numbers.
- double precision U(97), C, CD, CM
- integer I97, J97
- double precision uni
-
- common /RASET1/ U, C, CD, CM, I97, J97
- ! INTEGER IVEC
- UNI = U(I97) - U(J97)
- if( UNI .lt. 0.0 ) UNI = UNI + 1.0
- U(I97) = UNI
- I97 = I97 - 1
- if(I97 .eq. 0) I97 = 97
- J97 = J97 - 1
- if(J97 .eq. 0) J97 = 97
- C = C - CD
- if( C .lt. 0.d0 ) C = C + CM
- UNI = UNI - C
- if( UNI .lt. 0.d0 ) UNI = UNI + 1.0 ! bug?
- RANMAR = UNI
-
- end function RANMAR
-
-
- end module Random
-
-
-
\ No newline at end of file
--- 0 ----
diff -r -c -b -B -N cosmomc/camb/writefits.f90 cosmomc_sampler/camb/writefits.f90
*** cosmomc/camb/writefits.f90 2005-03-31 01:37:14.000000000 +0200
--- cosmomc_sampler/camb/writefits.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,121 ****
- !subroutine to export Cls in FITS format for HEALPix 1.2
- !Antony Lewis July 2003
-
-
- subroutine WriteFitsCls(Clsfile, lmx)
- use CAMB
- use head_fits, ONLY : add_card
- use fitstools, only : write_asctab
- implicit none
- character(LEN=*), INTENT(IN) :: Clsfile
- integer, INTENT(IN) :: lmx
- CHARACTER(LEN=80), DIMENSION(1:120) :: header
- INTEGER nlheader,i, j
- real, allocatable, dimension (:,:) :: clout,allcl
- real(dl) :: fac, PowerVals(20)
- character(Len=40) :: unitstr
- character(Len=8) :: PowerKeys(20)
- logical COBEnorm
-
-
- if (CP%InitPower%nn>1) write(*,*) &
- 'Warning: FITS file contains result for first power spectrum only'
-
- allocate(clout(2:lmx,1:4))
-
- call CAMB_GetCls(clout, lmx, 1, .false.)
- !HealPix 1.2 uses E-B conventions
-
- if (CP%OutputNormalization == outCOBE) then
- fac=2*pi*CP%tcmb**2
- else
- if (CP%OutputNormalization >=2) then
- fac=1
- else
- fac=OutputDenominator*CP%tcmb**2
- end if
- end if
-
- !FITS file has Cls without l(l+1)/twopi factors
- do i=2,lmx
- clout(i,:)=clout(i,:)/i/dble(i+1)*fac
- end do
-
- allocate(allcl(0:lmx,1:4))
- allcl(2:lmx,1:4) = clout
- allcl(0:1,1:4) = 0
- deallocate(clout)
-
- header = ''
-
- if (CP%OutputNormalization == outCOBE) then
- unitstr='Kelvin-squared'
- else
- unitstr='unknown'
- end if
-
- call add_card(header,'COMMENT','-----------------------------------------------')
- call add_card(header,'COMMENT',' CMB power spectrum C(l) keywords ')
- call add_card(header,'COMMENT','-----------------------------------------------')
- call add_card(header,'EXTNAME','''COMPUTED POWER SPECTRUM''')
- call add_card(header,'COMMENT',' POWER SPECTRUM : C(l) ')
- call add_card(header)
- call add_card(header,'CREATOR','CAMB', 'Software creating the FITS file')
- call add_card(header,'VERSION',version, 'Version of the simulation software')
- call add_card(header,'POLAR',.true.,'Polarisation included (True/False)')
- call add_card(header,'POLNORM','CMBFAST','Uses E-B conventions')
- call add_card(header)
- call add_card(header)
- call add_card(header,'TTYPE1', 'TEMPERATURE','Temperature C(l)')
- call add_card(header,'TUNIT1', unitstr,'unit')
- call add_card(header)
-
- call add_card(header,'TTYPE2', 'E-mode C_l','ELECTRIC polarisation C(l)')
- call add_card(header,'TUNIT2', unitstr,'unit')
- call add_card(header)
-
- call add_card(header,'TTYPE3', 'B-mode C_l','MAGNETIC polarisation C(l)')
- call add_card(header,'TUNIT3', unitstr,'unit')
- call add_card(header)
-
- call add_card(header,'TTYPE4', 'E-T cross corr.','Gradient-Temperature cross terms')
- call add_card(header,'TUNIT4', unitstr,'unit')
- call add_card(header)
-
- call add_card(header,'COMMENT','-----------------------------------------------')
- call add_card(header,'COMMENT',' Cosmological parameters')
- call add_card(header,'COMMENT','-----------------------------------------------')
- call add_card(header,'OMEGAB',CP%omegab, 'Omega in baryons')
- call add_card(header,'OMEGAC',CP%omegac, 'Omega in CDM')
- call add_card(header,'OMEGAV',CP%omegav, 'Omega in cosmological constant')
- call add_card(header,'OMEGAN',CP%omegan, 'Omega in neutrinos')
- call add_card(header,'HUBBLE', CP%h0, 'Hublle constant in km/s/Mpc')
- call add_card(header,'NNUNR',CP%Num_Nu_massive, 'number of massive neutrinos')
- call add_card(header,'NNUR',CP%Num_Nu_massless, 'number of massless neutrinos')
- call add_card(header,'TCMB',CP%tcmb, 'CMB temperature in Kelvin')
- call add_card(header,'HELFRACT',CP%yhe, 'Helium fraction')
- call add_card(header,'OPTDLSS',CP%Reion%optical_depth, 'reionisation optical depth')
- call add_card(header,'IONFRACT',CP%Reion%fraction, 'ionisation fraction')
- call add_card(header,'ZREION',CP%reion%redshift, 'reionisation redshift')
- call add_card(header,'COMMENT','-----------------------------------------------')
- call add_card(header,'COMMENT',' Other parameters')
- call add_card(header,'COMMENT','-----------------------------------------------')
- call add_card(header,'SCALARS',CP%WantScalars, 'includes scalar modes')
- call add_card(header,'TENSORS',CP%WantTensors, 'includes tensor modes')
- call add_card(header,'INITFLAG',CP%Scalar_initial_condition, 'initial condition flag')
- COBEnorm = CP%outputNormalization==outCOBE
- call add_card(header,'COBENORM',COBEnorm, 'COBE normalized')
- call add_card(header,'KETA_MAX',CP%Max_eta_k, 'Max wavenumber')
- call add_card(header,'PRECIS',AccuracyBoost, 'Relative computation accuracy')
- call add_card(header,'EQS_FILE',Eqns_name, 'Gauge-dependent and background equations')
- call add_card(header,'POW_FILE',Power_Name, 'Initial power spectrum file')
- i = Power_Descript(1,CP%WantScalars,CP%WantTensors,PowerKeys,PowerVals)
- do j=1,i
- call add_card(header,PowerKeys(j),PowerVals(j), 'Initial power spectrum details')
- end do
-
- nlheader = SIZE(header)
- call write_asctab (allcl, lmx, 4, header, nlheader, Clsfile)
- deallocate(allcl)
-
- end subroutine WriteFitsCls
--- 0 ----
diff -r -c -b -B -N cosmomc/params.ini cosmomc_sampler/params.ini
*** cosmomc/params.ini 2010-05-14 17:26:20.000000000 +0200
--- cosmomc_sampler/params.ini 2009-04-30 15:31:00.333646418 +0200
***************
*** 1,97 ****
#Sample parameters for cosmomc in default parameterization
#Root name for files produced
! file_root = chains/test
! #action = 0: MCMC, action=1: postprocess .data file, action=2: find best fit point only
! action = 0
!
! #Maximum number of chain steps
! samples = 200000
! #Feedback level ( 2=lots,1=chatty,0=none)
! feedback = 1
! #Temperature at which to Monte-Carlo
! temperature = 1
! #filenames for CMB datasets and SZ templates (added to C_l times parameter(13))
! #Note you may need to change lmax in cmbtypes.f90 to use small scales (e.g. lmax=2100)
! cmb_numdatasets = 1
! cmb_dataset1 = WMAP
! cmb_dataset_SZ1 = data/WMAP_SZ_VBand.dat
! cmb_dataset_SZ_scale1 = 1
!
! cmb_dataset2 = data/acbar2007_v3_corr.newdat
! cmb_dataset_SZ2 = data/WMAP_SZ_VBand.dat
! cmb_dataset_SZ_scale2 = 0.28
!
! cmb_dataset3 = data/CBIpol_2.0_final.newdat
! cmb_dataset4 = data/B03_NA_21July05.newdat
!
! #filenames for matter power spectrum datasets, incl twodf
! mpk_numdatasets = 1
! mpk_dataset1 = data/lrgDR7kmax02kmin02newmaxLv2ALL_MAGCOVv3.dataset
! #mpk_dataset1 = data/sdss_lrgDR4.dataset
! #mpk_dataset1 = data/2df_2005.dataset
!
! #filename for supernovae (default SDSS compilation)
! SN_filename = data/supernovae.dataset
!
! #if true, use HALOFIT for non-linear corrections (astro-ph/0207664).
! #note lyman-alpha (lya) code assumes linear spectrum
! nonlinear_pk = F
!
! use_CMB = T
! use_HST = F
! use_mpk = F
! use_BAO = F
! use_clusters = F
! use_BBN = F
! use_Age_Tophat_Prior = T
! use_SN = F
! use_lya = F
! use_min_zre = 0
! #directory, e.g. window functions in directory windows under data_dir
! data_dir = data/
- #Force computation of sigma_8 even if use_mpk = F
- get_sigma8 = F
! #1: Simple Metropolis, 2: slice sampling, 3: slice sampling fast parameters, 4: directional gridding
! sampling_method = 1
! #if sampling_method =4, iterations per gridded direction
! 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
! #Can use covariance matrix for proposal density, otherwise use settings below
! #Covariance matrix can be produced using "getdist" program.
! 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
! #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
! #Generally make smaller if your acceptance rate is too low
! propose_scale = 2.4
! #Increase to oversample fast parameters more, e.g. if space is odd shape
! oversample_fast = 1
! #if non-zero number of steps between sample info dumped to file file_root.data
indep_sample = 0
! #number of samples to disgard at start; usually set to zero and remove later
burn_in = 0
#If zero set automatically
--- 1,60 ----
#Sample parameters for cosmomc in default parameterization
#Root name for files produced
! file_root = test
! samples = 100000
! delta_loglike = 2
! sampling_method = 1
! estimate_propose_matrix = F
! propose_scale = 2.4
! #Temperature at which to Monte-Carlo
! temperature = 1
! #action = 0, to MCMC, action=1, postprocess .data file
! action = 0
! #Feedback level ( 2=lots,1=chatty,0=less,-1=minimal)
! feedback = 1
! #Can re-start from the last line of previous run (.txt file)
! continue_from =
! #Increase to oversample fast parameters,e.g. if space is odd shape
! oversample_fast = 1
! #Can use covariance matrix for proposal density, otherwise use settings below
! #Covariance matrix can be produced using "getdist" prorgram.
! propose_matrix =
! #If action = 1
! redo_likelihoods = T
! redo_theory = F
! redo_cls = F
! redo_pk = F
! redo_skip = 0
! redo_outroot =
! redo_thin = 1
! #If large difference in log likelihoods may need to offset to give sensible weights
! #for exp(difference in likelihoods)
! redo_likeoffset = 0
! #Number of distinct points to sample
! #Every accepted point is included
! #number of steps between independent samples
! #if non-zero all info is dumped to file file_root.data
indep_sample = 0
!
! #number of samples to disgard at start
! #May prefer to set to zero and remove later
burn_in = 0
#If zero set automatically
***************
*** 101,189 ****
#MPI_Converge_Stop is a (variance of chain means)/(mean of variances) parameter that can be used to stop the chains
#Set to a negative number not to use this feature. Does not guarantee good accuracy of confidence limits.
MPI_Converge_Stop = 0.03
!
! #Do initial period of slice sampling; may be good idea if
! #cov matrix or widths are likely to be very poor estimates
! MPI_StartSliceSampling = F
#Can optionally also check for convergence of confidence limits (after MPI_Converge_Stop reached)
- #Can be good idea as small value of MPI_Converge_Stop does not (necessarily) imply good exploration of tails
MPI_Check_Limit_Converge = F
#if MPI_Check_Limit_Converge = T, give tail fraction to check (checks both tails):
MPI_Limit_Converge = 0.025
! #permitted quantile chain variance in units of the standard deviation (small values v slow):
! MPI_Limit_Converge_Err = 0.2
#which parameter's tails to check. If zero, check all parameters:
MPI_Limit_Param = 0
- #if MPI_LearnPropose = T, the proposal density is continally updated from the covariance of samples so far (since burn in)
- MPI_LearnPropose = T
- #can set a value of converge at which to stop updating covariance (so that it becomes rigorously Markovian)
- #e.g. MPI_R_StopProposeUpdate = 0.4 will stop updating when (variance of chain means)/(mean of variances) < 0.4
- MPI_R_StopProposeUpdate = 0
-
- #If have covmat, R to reach before updating proposal density (increase if covmat likely to be poor)
- #Only used if not varying new parameters that are fixed in covmat
- MPI_Max_R_ProposeUpdate = 2
- #As above, but used if varying new parameters that were fixed in covmat
- MPI_Max_R_ProposeUpdateNew = 30
#if blank this is set from system clock
rand_seed =
! #If true, generate checkpoint files and terminated runs can be restarted using exactly the same command
! #and chains continued from where they stopped
! #With checkpoint=T note you must delete all chains/file_root.* files if you want new chains with an old file_root
! checkpoint = F
!
! #CAMB parameters
! #If we are including tensors
! compute_tensors = F
! #Initial power spectrum amplitude point (Mpc^{-1})
! pivot_k = 0.05
! #If using tensors, enforce n_T = -A_T/(8A_s)
! inflation_consistency = F
!
! #Set Y_He from BBN constraint; if false set to fixed value of 0.24 by default.
! bbn_consistency=T
!
! #Whether the CMB should be lensed (slows a lot unless also computing matter power)
! CMB_lensing = T
! #increase accuracy_level to run CAMB on higher accuracy
! #(default is about 0.3%, accuracy_level=2 around 0.1% at high l)
! accuracy_level = 1
!
! #If action = 1
! redo_likelihoods = T
! redo_theory = F
! redo_cls = F
! redo_pk = F
! redo_skip = 0
! redo_outroot =
! redo_thin = 1
! redo_add = F
! redo_from_text = F
! #If large difference in log likelihoods may need to offset to give sensible weights
! #for exp(difference in likelihoods)
! redo_likeoffset = 0
- #parameter start center, min, max, start width, st. dev. estimate
- param[omegabh2] = 0.0223 0.005 0.1 0.001 0.001
- param[omegadmh2] = 0.105 0.01 0.99 0.01 0.01
- param[theta] = 1.04 0.5 10 0.002 0.002
- param[tau] = 0.09 0.01 0.8 0.03 0.03
-
- 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
-
- #log[10^10 A_s]
- param[logA] = 3 2.7 4 0.01 0.01
- param[r] = 0 0 0 0 0
- #SZ amplitude, as in WMAP analysis
- param[asz]= 1 0 2 0.4 0.4
--- 64,101 ----
#MPI_Converge_Stop is a (variance of chain means)/(mean of variances) parameter that can be used to stop the chains
#Set to a negative number not to use this feature. Does not guarantee good accuracy of confidence limits.
MPI_Converge_Stop = 0.03
! #if MPI_LearnPropose = T, the proposal density is continally updated from the covariance of samples so far (since burn in)
! MPI_LearnPropose = T
#Can optionally also check for convergence of confidence limits (after MPI_Converge_Stop reached)
MPI_Check_Limit_Converge = F
#if MPI_Check_Limit_Converge = T, give tail fraction to check (checks both tails):
MPI_Limit_Converge = 0.025
! #And the permitted percentil chain variance in units of the standard deviation (small values v slow):
! MPI_Limit_Converge_Err = 0.3
#which parameter's tails to check. If zero, check all parameters:
MPI_Limit_Param = 0
#if blank this is set from system clock
rand_seed =
! #parameter start center, min, max, start width, propose width
! #e.g. for 2D Gaussian
! param1 = 0 -20 20 1 1
! param2 = 0 -20 20 1 1
! param3 = 0 0 0 0 0
! param4 = 0 0 0 0 0
! param5 = 0 0 0 0 0
! param6 = 0 0 0 0 0
! param7 = 0 0 0 0 0
!
! #fast params
! param8 = 0 -20 20 1 1
! param9 = 0 0 0 0 0
! param10 = 0 0 0 0 0
! param11 = 0 0 0 0 0
! param12 = 0 0 0 0 0
! param13 = 0 0 0 0 0
diff -r -c -b -B -N cosmomc/source/bao.f90 cosmomc_sampler/source/bao.f90
*** cosmomc/source/bao.f90 2010-05-20 12:13:02.000000000 +0200
--- cosmomc_sampler/source/bao.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,90 ****
- ! Percival et al 2009 BAO results hard-coded here by Beth Reid March 2009
- ! Copied structure from supernovae.f90
- !
- !default values from http://arxiv.org/abs/0907.1660
- !! for explanation of the changes to the rs expression, see Hamann et al,
- !! http://xxx.lanl.gov/abs/1003.3999
-
- module bao
- use cmbtypes
- use CAMB, only : AngularDiameterDistance !!angular diam distance also in Mpc no h units
- use constants
- implicit none
-
- real(dl), parameter :: rstodvz1 = 0.190533, z1 = 0.2
- real(dl), parameter :: rstodvz2 = 0.109715, z2 = 0.35
- real(dl), dimension(2,2) :: invcov
-
- contains
-
- subroutine BAO_init
-
- invcov(1,1) = 30124.1d0
- invcov(1,2) = -17226.9d0
- invcov(2,1) = invcov(1,2)
- invcov(2,2) = 86976.6d0
-
- end subroutine BAO_init
-
- !JH: new routines; integrate to get sound horizon rather than using EH98 formula.
- function CMBToBAOrs(CMB)
- use settings
- use cmbtypes
- use ModelParams
- use Precision
- use ThermoData, only : z_drag
- implicit none
- Type(CMBParams) CMB
- real(dl) :: adrag, atol, rsdrag
- real(dl), external :: dsoundda, rombint
- real(dl) :: CMBToBAOrs
- integer error
-
- adrag = 1.0d0/(1.0d0+z_drag)
- atol = 1e-6
- rsdrag = rombint(dsoundda,1d-8,adrag,atol)
- CMBToBAOrs = rsdrag
-
- end function CMBToBAOrs
-
-
- real(dl) function BAO_LnLike(CMB)
- use Precision
- type(CMBParams) CMB
- real :: rs, dv1theory, dv2theory, hz1, hz2, omegam
- real :: rstodvz1theorydelta, rstodvz2theorydelta
- !JH: ratio of fitting formula vs. exact result for fiducial model of Percival et al., arXiv:0907.1660
- real, parameter :: rs_rescale = 154.6588d0/150.8192d0
- logical, save :: do_BAO_init = .true.
-
- if(do_BAO_init) then
- call BAO_init
- do_BAO_init = .false.
- end if
-
- !JH: Need to rescale rs because Percival et al. data assume inaccurate fitting formula result for z_drag
- ! rescaled rs has correct dependence on all cosmological parameters though (e.g., N_nu, Y_He, ...)
- rs = CMBToBAOrs(CMB)*rs_rescale
-
- !!AngularDiameterDistance and rs returned in Mpc no h units.
- !! at z <~ 0.5, the neutrinos are nonrelativistic, so they contribute to the matter density, unlike at zdrag.
- !! note for really tiny neutrino masses, this breaks down; see Section 3.3 of Komatsu et al 2010, WMAP7 cosmological interpretation paper. However, completely negigible given current error bars!
- omegam = 1.d0 - CMB%omv - CMB%omk
- hz1 = sqrt(omegam*(1.0d0+z1)**3.0d0+CMB%omk*(1.0d0+z1)**2.0+CMB%omv*(1.0d0+z1)**(3.0d0*(1.0d0+CMB%w)))
- hz2 = sqrt(omegam*(1.0d0+z2)**3.0d0+CMB%omk*(1.0d0+z2)**2.0+CMB%omv*(1.0d0+z2)**(3.0d0*(1.0d0+CMB%w)))
- dv1theory = ((1.0d0+z1)*AngularDiameterDistance(z1))**2.0d0*c*z1/CMB%H0/hz1/1000.0d0
- dv2theory = ((1.0d0+z2)*AngularDiameterDistance(z2))**2.0d0*c*z2/CMB%H0/hz2/1000.0d0
- dv1theory = dv1theory**(1.0d0/3.0d0)
- dv2theory = dv2theory**(1.0d0/3.0d0)
-
- rstodvz1theorydelta = rs/dv1theory - rstodvz1
- rstodvz2theorydelta = rs/dv2theory - rstodvz2
-
- BAO_LnLike = 0.5*((rstodvz1theorydelta) * invcov(1,1) * (rstodvz1theorydelta) &
- & + 2.0d0 * (rstodvz1theorydelta) * invcov(1,2) * (rstodvz2theorydelta) &
- & + (rstodvz2theorydelta) * invcov(2,2) * (rstodvz2theorydelta))
-
- if (Feedback > 1) print *,'BAO_LnLike: ',BAO_LnLike
- end function BAO_LnLike
-
- end module bao
--- 0 ----
diff -r -c -b -B -N cosmomc/source/bbn.f90 cosmomc_sampler/source/bbn.f90
*** cosmomc/source/bbn.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/bbn.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,195 ****
- !Module from Jan Hamann, 4/2010
- !Modified by AL, 4/2010
- module bbn
-
- use settings
-
- implicit none
- private
-
- integer, parameter :: dp = KIND(1.d0)
-
- type bbnstuff
- real(dp), dimension(:), pointer :: ombh2,deltan
- real(dp), dimension(:,:), pointer :: yp,ddyp
- integer :: n_ombh2,n_deltan
- end type
-
- type(bbnstuff) bbn_data
-
- public bbnini,yp_bbn
-
- contains
-
- subroutine bbnini
- real(dp), dimension(:,:), allocatable :: bbn_tmp
- ! Number of grid points in \omega_b h^2 and \Delta N_\nu
- integer, parameter :: num_ombh2 = 26, num_deltan = 11
- integer :: i,j, file_id
- character :: dummy
-
-
- if (feedback .ge. 1) print*,'Initialising BBN Helium data...'
-
- allocate(bbn_tmp(num_ombh2*num_deltan,3))
- allocate(bbn_data%ombh2(num_ombh2))
- allocate(bbn_data%deltan(num_deltan))
- allocate(bbn_data%yp(num_ombh2,num_deltan))
- allocate(bbn_data%ddyp(num_ombh2,num_deltan))
-
- bbn_data%n_ombh2 = num_ombh2
- bbn_data%n_deltan = num_deltan
-
- file_id = new_file_unit()
- call OpenTxtFile(trim(DataDir)//'helium.dat', file_id)
-
- !skip data file header
- do i=1,7
- read(file_id,*) dummy
- end do
-
- !read in data
- do i = 1,num_ombh2*num_deltan
- read(file_id,*) bbn_tmp(i,1),bbn_tmp(i,2),bbn_tmp(i,3)
- end do
-
- call CloseFile(file_id)
-
- do i = 1,num_ombh2
- bbn_data%ombh2(i) = bbn_tmp(i,1)
-
- do j = 1,num_deltan
- bbn_data%yp(i,j) = bbn_tmp(num_ombh2*(j-1)+i,3)
- end do
- end do
-
- do i = 1,num_deltan
- bbn_data%deltan(i) = bbn_tmp((i-1)*num_ombh2+1,2)
- end do
-
- deallocate(bbn_tmp)
-
- !prepare array of second derivatives needed for spline interpolation
- call bbn_splie2(bbn_data%ombh2,bbn_data%deltan,bbn_data%yp,num_ombh2,num_deltan,bbn_data%ddyp)
-
- end subroutine bbnini
-
-
- !interpolate Yp from grid
- real function yp_bbn(ombh2_in,deltan_in)
- real :: ombh2_in,deltan_in
- logical, save:: initialized = .false.
- real(dp) res
-
- if (.not. initialized) then
- call bbnini
- initialized = .true.
- end if
- call bbn_splin2(bbn_data%ombh2,bbn_data%deltan,bbn_data%yp,bbn_data%ddyp,bbn_data%n_ombh2, &
- bbn_data%n_deltan,real(ombh2_in,dp),real(deltan_in,dp),res)
- yp_bbn = res
-
- end function yp_bbn
-
-
-
- !spline and splint routines, adapted from Numerical Recipes
- subroutine bbn_spline(x,y,n,yp1,ypn,y2)
- integer :: n,i,k
- real(dp) :: yp1,ypn,x(n),y(n),y2(n)
- integer, parameter :: NMAX=500
- real(dp) :: p,qn,sig,un,u(NMAX)
-
- if (yp1.gt..99e30) then
- y2(1)=0.
- u(1)=0.
- else
- y2(1)=-0.5
- u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
- endif
- do i=2,n-1
- sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
- p=sig*y2(i-1)+2.
- y2(i)=(sig-1.)/p
- u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
- end do
- if (ypn.gt..99e30) then
- qn=0.
- un=0.
- else
- qn=0.5
- un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
- endif
- y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
- do k=n-1,1,-1
- y2(k)=y2(k)*y2(k+1)+u(k)
- end do
- end subroutine bbn_spline
-
-
- subroutine bbn_splie2(x1a,x2a,ya,m,n,y2a)
- integer :: m,n,j,k
- real(dp) :: x1a(m),x2a(n),y2a(m,n),ya(m,n)
- integer, parameter :: NN=100
- real(dp) :: y2tmp(NN),ytmp(NN)
-
- do j=1,m
- do k=1,n
- ytmp(k)=ya(j,k)
- end do
- call bbn_spline(x2a,ytmp,n,1.d30,1.d30,y2tmp)
- do k=1,n
- y2a(j,k)=y2tmp(k)
- end do
- end do
- end subroutine bbn_splie2
-
-
- subroutine bbn_splint(xa,ya,y2a,n,x,y)
- integer :: n,k,khi,klo
- real(dp) :: x,y,xa(n),y2a(n),ya(n),a,b,h
-
- !safeguard against extrapolation added
- if (.not. (((x.ge.xa(n)) .and. (x.le.xa(1))) .or. ((x.ge.xa(1)) .and. (x.lt.xa(n))))) then
- Print*,'Input of bbn_splint out of interpolation range.'
- Print*,xa(n),x,xa(1)
- stop
- end if
- klo=1
- khi=n
- do while (khi-klo.gt.1)
- k=(khi+klo)/2
- if(xa(k).gt.x)then
- khi=k
- else
- klo=k
- endif
- end do
- h=xa(khi)-xa(klo)
- if (h.eq.0.) call MpiStop('bad xa input in bbn_splint')
- a=(xa(khi)-x)/h
- b=(x-xa(klo))/h
- y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.
- end subroutine bbn_splint
-
-
- subroutine bbn_splin2(x1a,x2a,ya,y2a,m,n,x1,x2,y)
- integer :: m,n,j,k
- real(dp) :: x1,x2,y,x1a(m),x2a(n),y2a(m,n),ya(m,n)
- integer, parameter :: NN=100
- real(dp) :: y2tmp(NN),ytmp(NN),yytmp(NN)
-
- do j=1,m
- do k=1,n
- ytmp(k)=ya(j,k)
- y2tmp(k)=y2a(j,k)
- end do
- call bbn_splint(x2a,ytmp,y2tmp,n,x2,yytmp(j))
- end do
- call bbn_spline(x1a,yytmp,m,1.d30,1.d30,y2tmp)
- call bbn_splint(x1a,yytmp,y2tmp,m,x1,y)
- end subroutine bbn_splin2
-
-
- end module bbn
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/calclike.f90 cosmomc_sampler/source/calclike.f90
*** cosmomc/source/calclike.f90 2009-11-10 19:00:40.000000000 +0100
--- cosmomc_sampler/source/calclike.f90 2010-05-27 16:14:16.365517973 +0200
***************
*** 1,25 ****
module CalcLike
- use CMB_Cls
- use cmbtypes
- use cmbdata
- use mpk
use Random
use settings
use ParamDef
- use snovae
- use WeakLen
- use Lya
implicit none
- logical :: Use_Age_Tophat_Prior = .true.
- logical :: Use_CMB = .true.
- logical :: Use_BBN = .false.
- logical :: Use_Clusters = .false.
-
- integer :: H0_min = 40, H0_max = 100
- real :: Omk_min = -0.3, Omk_max = 0.3
- real :: Use_min_zre = 0
- integer :: Age_min = 10, Age_max = 20
real :: Temperature = 1
contains
--- 1,9 ----
***************
*** 41,72 ****
end function GenericLikelihoodFunction
- function GetLogPrior(CMB, Info) !Get -Ln(Prior)
- real GetLogPrior
- real Age
- Type (CMBParams) CMB
- Type(ParamSetInfo) Info
-
- GetLogPrior = logZero
-
- if (.not. generic_mcmc) then
- if (CMB%H0 < H0_min .or. CMB%H0 > H0_max) return
- if (CMB%omk < Omk_min .or. CMB%omk > Omk_max .or. CMB%Omv < 0) return
- if (CMB%zre < Use_min_zre) return
-
- Age = GetAge(CMB, Info)
- !This sets up parameters in CAMB, so do not delete unless you are careful!
-
- if (Use_Age_Tophat_Prior .and. (Age < Age_min .or. Age > Age_max) .or. Age < 0) return
-
- end if
- GetLogPrior = 0
-
- end function GetLogPrior
-
function GetLogLike(Params) !Get -Ln(Likelihood)
type(ParamSet) Params
- Type (CMBParams) CMB
real GetLogLike
real dum(1,1)
--- 25,32 ----
***************
*** 81,176 ****
else
! call ParamsToCMBParams(Params%P,CMB)
!
! GetLogLike = GetLogLikePost(CMB, Params%Info,dum,.false.)
end if
end function GetLogLike
- function GetLogLikePost(CMB, Info, inCls, HasCls)
- real GetLogLikePost
- Type (CMBParams) CMB
- Type(ParamSetInfo) Info
- real, intent(in):: inCls(:,:)
- logical, intent(in) :: HasCls
- real acl(lmax,num_cls_tot)
- integer error
-
- if (generic_mcmc) stop 'GetLogLikePost: not supported for generic'
-
- GetLogLikePost = GetLogPrior(CMB, Info)
- if ( GetLogLikePost >= logZero) then
- GetLogLikePost = logZero
-
- else
- GetLogLikePost = GetLogLikePost + sum(CMB%nuisance(1:nuisance_params_used)**2)/2
- !Unit Gaussian prior on all nuisance parameters
- if (Use_BBN) GetLogLikePost = GetLogLikePost + (CMB%ombh2 - 0.022)**2/(2*0.002**2)
- !I'm using increased error bars here
-
- if (Use_CMB .or. Use_LSS) then
- if (HasCls) then
- acl = inCls
- error =0
- else
- call GetCls(CMB, Info, acl, error)
- end if
- if (error /= 0) then
- GetLogLikePost = logZero
- else
- if (Use_CMB) GetLogLikePost = &
- CMBLnLike(acl, CMB%norm(norm_freq_ix:norm_freq_ix+num_freq_params-1),CMB%nuisance) + GetLogLikePost
- if (Use_mpk) GetLogLikePost = GetLogLikePost + LSSLnLike(CMB, Info%theory)
- if (Use_WeakLen) GetLogLikePost = GetLogLikePost + WeakLenLnLike(CMB, Info%theory)
- if (Use_Lya) GetLogLikePost = GetLogLikePost + LSS_Lyalike(CMB, Info%Theory)
- if ( GetLogLikePost >= logZero) then
- GetLogLikePost = logZero
- end if
- end if
- if (Use_SN .and. GetLogLikePost /= logZero ) then
- if (Info%Theory%SN_loglike /= 0) then
- GetLogLikePost = GetLogLikePost + Info%Theory%SN_loglike
- else
- GetLogLikePost = GetLogLikePost + SN_LnLike(CMB)
- end if
- !Assume computed only every time hard parameters change
- end if
- if (Use_BAO .and. GetLogLikePost /= logZero ) then
- if (Info%Theory%BAO_loglike /= 0) then
- GetLogLikePost = GetLogLikePost + Info%Theory%BAO_loglike
- else
- GetLogLikePost = GetLogLikePost + BAO_LnLike(CMB)
- end if
- !Assume computed only every time hard parameters change
- end if
- if (Use_HST .and. GetLogLikePost /= logZero) then
- if (Info%Theory%HST_loglike /= 0) then
- GetLogLikePost = GetLogLikePost + Info%Theory%HST_loglike
- else
- GetLogLikePost = GetLogLikePost + HST_LnLike(CMB)
- end if
- !!Old: GetLogLikePost = GetLogLikePost + (CMB%H0 - 72)**2/(2*8**2) !HST
- end if
-
- else
- if (Use_SN) GetLogLikePost = GetLogLikePost + SN_LnLike(CMB)
- if (Use_BAO) GetLogLikePost = GetLogLikePost + BAO_LnLike(CMB)
- if (Use_HST) GetLogLikePost = GetLogLikePost + HST_LnLike(CMB)
- end if
-
-
- if (Use_Clusters .and. GetLogLikePost /= LogZero) then
- GetLogLikePost = GetLogLikePost + &
- (Info%Theory%Sigma_8-0.9)**2/(2*0.05**2)
- stop 'Write your cluster prior in calclike.f90 first!'
- end if
-
- if (GetLogLikePost /= LogZero) GetLogLikePost = GetLogLikePost/Temperature
-
-
- end if
- end function GetLogLikePost
end module CalcLike
--- 41,51 ----
else
! stop
end if
end function GetLogLike
end module CalcLike
diff -r -c -b -B -N cosmomc/source/CMB_Cls_simple.f90 cosmomc_sampler/source/CMB_Cls_simple.f90
*** cosmomc/source/CMB_Cls_simple.f90 2010-05-20 12:13:02.000000000 +0200
--- cosmomc_sampler/source/CMB_Cls_simple.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,527 ****
- !Use CAMB
- module CMB_Cls
- use cmbtypes
- use CAMB, only : CAMB_GetResults, CAMB_GetAge, CAMBParams, CAMB_SetDefParams,Transfer_GetMatterPower, &
- AccuracyBoost, Cl_scalar, Cl_tensor, Cl_lensed, outNone, w_lam, &
- CAMBParams_Set, MT, CAMBdata, NonLinear_Pk, Reionization_GetOptDepth, CAMB_GetZreFromTau, &
- CAMB_GetTransfers,CAMB_FreeCAMBdata,CAMB_InitCAMBdata, CAMB_TransfersToPowers, &
- initial_adiabatic,initial_vector,initial_iso_baryon,initial_iso_neutrino, initial_iso_neutrino_vel
-
- use settings
- use snovae
- use bao
- use HST
- use IO
- implicit none
- logical :: Use_SN =.false. !Compute Supernovae likelihoods only when background changes
- logical :: Use_HST =.false. !Compute HST likelihoods only when background changes
- logical :: Use_BAO = .false.
-
- logical :: compute_tensors = .false.
- logical :: CMB_lensing = .false.
- logical :: use_nonlinear = .false.
-
- Type ParamSetInfo
-
- Type (CosmoTheory) :: Theory
- Type (CAMBdata) :: Transfers
- Type (CMBParams) :: LastParams
- end Type ParamSetInfo
-
- integer, parameter :: ScalClOrder(5) = (/1,3,2,4,5/), TensClOrder(4) = (/1,4,2,3/)
- !Mapping of CAMB CL array ordering to TT , TE, EE, BB, phi, phiT
- integer :: ncalls = 0
- type(CAMBParams) CAMBP
- logical :: w_is_w = .true.
-
- contains
- subroutine CMBToCAMB(CMB,P)
- use LambdaGeneral
- type(CMBParams) CMB
- type(CAMBParams) P
- P = CAMBP
- P%omegab = CMB%omb
- P%omegan = CMB%omnu
- P%omegac = CMB%omc
- P%omegav = CMB%omv
- P%H0 = CMB%H0
- P%Reion%redshift= CMB%zre
- if (w_is_w) then
- w_lam = CMB%w
- else
- P%InitialConditionVector(initial_iso_baryon) = CMB%w
- w_lam = -1
- end if
- if (CMB%nnu < 3.04) call MpiStop('CMBToCAMB: nnu < 3.04, would give negative masless neutrinos')
- P%Num_Nu_Massless = CMB%nnu - 3.046 !assume three massive
- P%YHe = CMB%YHe
-
- end subroutine CMBToCAMB
-
- function RecomputeTransfers (A, B)
- logical RecomputeTransfers
- type(CMBParams) A, B
-
- RecomputeTransfers = .not. (A%omb == B%omb .and. A%omc == B%omc .and. A%omv == B%omv .and. &
- A%omnu == B%omnu .and. A%zre == B%zre .and. A%omk == B%omk .and. A%w == B%w .and. &
- A%nnu == B%nnu .and. A%YHe == B%YHe)
-
- end function RecomputeTransfers
-
-
- subroutine GetCls(CMB,Info, Cls, error)
- use ModelParams, only : ThreadNum
- #ifdef DR71RG
- use lrggettheory
- real(dl) :: getabstransferscale
- !! BR09: this variable is for renormalizing the power spectra to the z=0 value;
- !this is the assumption of the LRG model.
- #endif
- type(CMBParams) CMB
- integer error
- Type(ParamSetInfo) Info
- real Cls(lmax,1:num_cls_tot)
- type(CAMBParams) P
- logical NewTransfers
- integer zix
- character(LEN=128) :: LogLine
-
-
- error = 0
- Newtransfers = .false.
-
- if (RecomputeTransfers(CMB, Info%LastParams)) then
- !Slow parameters have changed
- call CAMB_InitCAMBdata(Info%Transfers)
- call CMBToCAMB(CMB, P)
-
- if (Feedback > 1) write (*,*) 'Calling CAMB'
- Threadnum =num_threads
-
- call CAMB_GetTransfers(P, Info%Transfers, error)
- NewTransfers = .true.
- Info%LastParams = CMB
- if (Use_SN) then
- Info%Theory%SN_Loglike = SN_LnLike(CMB)
- else
- Info%Theory%SN_Loglike = 0
- end if
- if (Use_BAO) then
- Info%Theory%BAO_loglike = BAO_LnLike(CMB)
- else
- Info%Theory%BAO_loglike = 0
- end if
- if (Use_HST) then
- Info%Theory%HST_Loglike = HST_LnLike(CMB)
- else
- Info%Theory%HST_Loglike = 0
- end if
-
- ncalls=ncalls+1
- if (mod(ncalls,100)==0 .and. logfile_unit/=0) then
- write (logLine,*) 'CAMB called ',ncalls, ' times'
- call IO_WriteLog(logfile_unit,logLine)
- end if
- if (Feedback > 1) write (*,*) 'CAMB done'
-
- end if
-
- ! if ((error==0) .and. (Newtransfers .or. any(CMB%InitPower /= Info%LastParams%InitPower))) then
- !Use the initial power spectra to get the Cls and matter power spectrum
- if (error == 0) then
- !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)
-
- call CAMB_TransfersToPowers(Info%Transfers)
- !this sets slow CAMB params correctly from value stored in Transfers
-
- call SetTheoryFromCAMB(Info%Theory)
-
- if (any(Info%Theory%cl(:,1) < 0 )) then
- error = 1
- !Kill initial power spectra that go negative
- return
- end if
-
- if (Use_LSS) then
- Info%Theory%sigma_8 = Info%Transfers%MTrans%sigma_8(matter_power_lnzsteps,1)
- #ifdef DR71RG
- !! BR09 get lrgtheory info
- if (num_matter_power /= 0 .and. use_dr7lrg) then
- do zix = 1,matter_power_lnzsteps
- if(zix .eq. iz0lrg .or. zix .eq. izNEARlrg .or. zix .eq. izMIDlrg .or. zix .eq. izFARlrg) then
- call Transfer_GetMatterPowerAndNW(Info%Transfers%MTrans,&
- Info%Theory%matter_power(:,zix),matter_power_lnzsteps-zix+1,&
- 1,matter_power_minkh, matter_power_dlnkh,num_matter_power,&
- kmindata,getabstransferscale, &
- Info%Theory%mpk_nw(:,zix),Info%Theory%mpkrat_nw_nl(:,zix))
- if(zix == iz0lrg) powerscaletoz0(1) = getabstransferscale**2.0d0
- if(zix == izNEARlrg) powerscaletoz0(2) = powerscaletoz0(1)/getabstransferscale**2.0d0
- if(zix == izMIDlrg) powerscaletoz0(3) = powerscaletoz0(1)/getabstransferscale**2.0d0
- if(zix == izFARlrg) powerscaletoz0(4) = powerscaletoz0(1)/getabstransferscale**2.0d0
- else !! not an LRG redshift, so call regular function.
- call Transfer_GetMatterPower(Info%Transfers%MTrans,&
- Info%Theory%matter_power(:,zix),matter_power_lnzsteps-zix+1,&
- 1,matter_power_minkh, matter_power_dlnkh,num_matter_power)
- end if
- end do
- if(zix == iz0lrg) powerscaletoz0(1) = 1.0d0
- else if (num_matter_power /= 0) then
- !! end BR09 get lrgtheory info
- #else
- if (num_matter_power /= 0) then
- #endif
- do zix = 1,matter_power_lnzsteps
- call Transfer_GetMatterPower(Info%Transfers%MTrans,&
- Info%Theory%matter_power(:,zix),matter_power_lnzsteps-zix+1,&
- 1,matter_power_minkh, matter_power_dlnkh,num_matter_power)
- end do
- end if
- else
- Info%Theory%sigma_8 = 0
- end if
-
- end if
- if (error /= 0) return
-
- call ClsFromTheoryData(Info%Theory, CMB, Cls)
-
- end subroutine GetCls
-
- subroutine SetTheoryFromCAMB(Theory)
- Type(CosmoTheory) Theory
- real, parameter :: cons = (COBE_CMBTemp*1e6)**2*2*pi
- real nm
- integer l
-
- !The reason we store tensors separately is that can then importance sample re-computing scalars only,
- !using the stored tensor C_l
-
- do l = 2, lmax
-
- nm = cons/(l*(l+1))
- if (CMB_Lensing) then
- Theory%cl(l,1:num_clsS) = nm*Cl_lensed(l,1, TensClOrder(1:num_clsS))
- else
- Theory%cl(l,1:num_clsS) = nm*Cl_scalar(l,1, scalClOrder(1:num_clsS))
- end if
-
- if (num_cls>num_clsS) Theory%cl(l,num_clsS+1:num_cls) = 0
-
- if (compute_tensors .and. l<=lmax_tensor) then
- Theory%cl_tensor(l,1:num_cls) = nm*Cl_tensor(l,1, TensClOrder(1:num_cls))
- end if
-
- if (num_cls_ext > 0) then
- !CMB lensing potential
- !in camb Cphi is l^4 C_l, we want [l(l+1)]^2Cphi/2pi
- if (.not. CMB_lensing) call MpiStop('Must have lensing on to use lensing potential')
- Theory%cl(l,num_clsS+1) = Cl_scalar(l,1, scalClOrder(4))*(real(l+1)**2/l**2)/twopi
- if (num_cls_ext>1) then
- !lensing-temp
- if (num_cls_ext>1) call MpiStop('SetTheoryFromCAMB: check defs for num_cls_ext>1')
- Theory%cl(l,num_clsS+2) = Cl_scalar(l,1, scalClOrder(5))/real(l)**3
- end if
- end if
-
- end do
-
-
- end subroutine SetTheoryFromCAMB
-
- subroutine GetClsInfo(CMB, Theory, error, DoCls, DoPk)
- use ModelParams, only : ThreadNum
- #ifdef DR71RG
- use lrggettheory
- real(dl) :: getabstransferscale
- !! BR09: this variable is for renormalizing the power spectra to the z=0 value;
- !this is the assumption of the LRG model.
- #endif
- type(CMBParams) CMB
- Type(CosmoTheory) Theory
- integer error
- logical, intent(in) :: DoCls, DoPk
- type(CAMBParams) P
- logical MatterOnly
- integer zix
- error = 0
- Threadnum =num_threads
- call CMBToCAMB(CMB, P)
- P%OnlyTransfers = .false.
- call SetCAMBInitPower(P,CMB,1)
-
- MatterOnly = .false.
- if (DoPk) then
- P%WantTransfer = .true.
- if (.not. DoCls) then
- MatterOnly = .true.
- P%WantScalars = .false.
- P%WantTensors = .false.
- end if
- end if
- if (DoCls) then
- !Assume we just want Cls to higher l
- P%WantScalars = .true.
- !P%WantTensors = .false.
- !compute_tensors = .false.
- P%WantTensors = compute_tensors
-
- if (.not. DoPk) then
- P%WantTransfer = .false.
- end if
- end if
-
- call CAMB_GetResults(P)
- error = 0 !using error optional parameter gives seg faults on SGI
- if (error==0) then
-
- if (DoCls) then
-
- Theory%cl_tensor(2:lmax_tensor,1:num_cls) = 0
- call SetTheoryFromCAMB(Theory)
- end if
-
- !!BR09 new addition, putting LRGs back here as well, same structure as above.
- if (DoPk) then
- Theory%sigma_8 = MT%sigma_8(matter_power_lnzsteps,1)
-
- #ifdef DR71RG
- !! BR09 get lrgtheory info
- if (num_matter_power /= 0 .and. use_dr7lrg) then
- do zix = 1,matter_power_lnzsteps
- if(zix .eq. iz0lrg .or. zix .eq. izNEARlrg .or. zix .eq. izMIDlrg .or. zix .eq. izFARlrg) then
- call Transfer_GetMatterPowerAndNW(MT,&
- Theory%matter_power(:,zix),matter_power_lnzsteps-zix+1,&
- 1,matter_power_minkh, matter_power_dlnkh,num_matter_power,&
- kmindata,getabstransferscale, &
- Theory%mpk_nw(:,zix),Theory%mpkrat_nw_nl(:,zix))
- if(zix == iz0lrg) powerscaletoz0(1) = getabstransferscale**2.0d0
- if(zix == izNEARlrg) powerscaletoz0(2) = powerscaletoz0(1)/getabstransferscale**2.0d0
- if(zix == izMIDlrg) powerscaletoz0(3) = powerscaletoz0(1)/getabstransferscale**2.0d0
- if(zix == izFARlrg) powerscaletoz0(4) = powerscaletoz0(1)/getabstransferscale**2.0d0
- else !! not an LRG redshift, so call regular function.
- call Transfer_GetMatterPower(MT,&
- Theory%matter_power(:,zix),matter_power_lnzsteps-zix+1,&
- 1,matter_power_minkh, matter_power_dlnkh,num_matter_power)
- end if
- end do
- if(zix == iz0lrg) powerscaletoz0(1) = 1.0d0
- else if (num_matter_power /= 0) then
- !! end BR09 get lrgtheory info
- #else
- if (num_matter_power /= 0) then
- #endif
- do zix = 1,matter_power_lnzsteps
- call Transfer_GetMatterPower(MT,&
- Theory%matter_power(:,zix),matter_power_lnzsteps-zix+1,&
- 1,matter_power_minkh, matter_power_dlnkh,num_matter_power)
- end do
- end if
- end if
- Theory%Age = CAMB_GetAge(P)
-
- end if
- end subroutine GetClsInfo
-
-
- subroutine InitCAMB(CMB,error, DoReion)
- type(CMBParams), intent(in) :: CMB
- logical, optional, intent(in) :: DoReion
- logical WantReion
- type(CAMBParams) P
- integer error
-
- if (present(DoReion)) then
- WantReion = DoReion
- else
- WantReion = .true.
- end if
-
- call CMBToCAMB(CMB, P)
- call CAMBParams_Set(P,error,WantReion)
-
- end subroutine InitCAMB
-
- function GetOpticalDepth(CMB)
- type(CMBParams) CMB
- real GetOpticalDepth
- type(CAMBParams) P
- integer error
-
- call CMBToCAMB(CMB, P)
- call CAMBParams_Set(P,error)
-
- if (error/= 0) then
- GetOpticalDepth = -1
- else
- GetOpticalDepth = Reionization_GetOptDepth(P%Reion, P%ReionHist)
- end if
- end function GetOpticalDepth
-
- function GetZreFromTau(CMB, tau)
- type(CMBParams) CMB
- real, intent(in) :: tau
- real GetZreFromTau
- type(CAMBParams) P
-
- call CMBToCAMB(CMB, P)
- GetZreFromTau = CAMB_GetZreFromTau(P,dble(tau))
-
- end function GetZreFromTau
-
- function GetAge(CMB, Info)
- !Return <0 if error
- real GetAge
- type(CMBParams) CMB
- Type(ParamSetInfo) Info
- type(CAMBParams) P
- call CMBToCAMB(CMB, P)
-
- Info%Theory%Age = CAMB_GetAge(P)
-
- GetAge = Info%Theory%Age
- end function GetAge
-
- subroutine InitCAMBParams(P)
- use lensing
- use ModelParams
- use Lya
- use mpk
- type(CAMBParams) P
- integer zix
- real redshifts(matter_power_lnzsteps)
-
- Threadnum =num_threads
- w_lam = -1
- call CAMB_SetDefParams(P)
-
- P%OutputNormalization = outNone
-
- P%WantScalars = .true.
- P%WantTensors = compute_tensors
- P%WantTransfer = Use_LSS
-
- P%Max_l=lmax
- P%Max_eta_k=lmax*2
- P%Max_l_tensor=lmax_tensor
- P%Max_eta_k_tensor=lmax_tensor*5./2
-
- P%Transfer%k_per_logint=0
-
- if (use_nonlinear) then
- P%NonLinear = NonLinear_Pk
- P%Transfer%kmax = 1.2
- else
- P%Transfer%kmax = 0.8
- end if
- if (Use_Lya) P%Transfer%kmax = lya_kmax
- P%Transfer%num_redshifts = matter_power_lnzsteps
-
- if (AccuracyLevel > 1) then
- if (USE_LSS) then
- P%Transfer%high_precision=.true.
- P%Transfer%kmax=P%Transfer%kmax + 0.2
- end if
- AccuracyBoost = AccuracyLevel
- lAccuracyBoost = AccuracyLevel
- lSampleBoost = AccuracyLevel
- P%AccurateReionization = .true.
- end if
-
- if (max_transfer_redshifts < matter_power_lnzsteps) then
- stop 'Need to manually set max_transfer_redshifts larger in CAMB''s modules.f90'
- end if
- if (use_LSS) then
- redshifts(1) = 0
-
- do zix=2, matter_power_lnzsteps
- !Default Linear spacing in log(z+1) if matter_power_lnzsteps > 1
- redshifts(zix) = exp( log(matter_power_maxz+1) * &
- real(zix-1)/(max(2,matter_power_lnzsteps)-1) )-1
- !put in max(2,) to stop compilers complaining of div by zero
- end do
-
- if (use_mpk) call mpk_SetTransferRedshifts(redshifts) !can modify to use specific redshifts
- if (redshifts(1) > 0.0001) call MpiStop('mpk redshifts: lowest redshift must be zero')
- do zix=1, matter_power_lnzsteps
- !CAMB's ordering is from highest to lowest
- P%Transfer%redshifts(zix) = redshifts(matter_power_lnzsteps-zix+1)
- end do
- else
- P%Transfer%redshifts(1) = 0
- end if
-
- P%Num_Nu_Massive = 3.046
- P%Num_Nu_Massless = 0
- P%InitPower%nn = 1
- P%AccuratePolarization = num_cls/=1
- P%Reion%use_optical_depth = .false.
- P%OnlyTransfers = .true.
-
- if (use_BAO) P%want_zdrag = .true. !JH
- P%want_zstar = .false. !set to true if you want CAMB to calculate exact z_star
-
- if (CMB_Lensing) then
- P%DoLensing = .true.
- P%Max_l = lmax +250 + 50 !+50 in case accuracyBoost>1 and so odd l spacing
- P%Max_eta_k = P%Max_l*2
- end if
-
- lensing_includes_tensors = .false.
-
- P%Scalar_initial_condition = initial_vector
- P%InitialConditionVector = 0
- P%InitialConditionVector(initial_adiabatic) = -1
-
-
- end subroutine InitCAMBParams
-
- subroutine CMB_Initialize(Info)
- Type(ParamSetInfo) Info
- type(CAMBParams) P
- compute_tensors = Ini_Read_Logical('compute_tensors',.false.)
- if (num_cls==3 .and. compute_tensors) write (*,*) 'WARNING: computing tensors with num_cls=3 (BB=0)'
- CMB_lensing = Ini_Read_Logical('CMB_lensing',.false.)
-
- if (Feedback > 0 ) then
- write (*,*) 'Computing tensors:', compute_tensors
- write (*,*) 'Doing CMB lensing:',CMB_lensing
- write(*,'(" lmax = ",1I4)') lmax
- if (compute_tensors) write(*,'(" lmax_tensor = ",1I4)') lmax_tensor
- write(*,'(" Number of C_ls = ",1I4)') num_cls
- end if
-
- if (CMB_lensing) num_clsS = num_cls !Also scalar B in this case
-
- call InitCAMBParams(P)
-
- call CAMB_InitCAMBdata(Info%Transfers)
-
- P%WantTensors = compute_tensors
- Info%LastParams%omb = -1 !Make sure we calculate the CMB first time called
- CAMBP = P
-
- end subroutine CMB_Initialize
-
-
- subroutine AcceptReject(accpt, CurParams, Trial)
- logical, intent(in) :: accpt
- Type(ParamSetInfo) CurParams, Trial
-
- if (.not. associated(CurParams%Transfers%ClTransScal%Delta_p_l_k,&
- Trial%Transfers%ClTransScal%Delta_p_l_k)) then
- !If they point to same memory don't need to free anything
- if (accpt) then
- call CAMB_FreeCAMBdata(CurParams%Transfers)
- else
- call CAMB_FreeCAMBdata(Trial%Transfers)
- end if
-
- end if
-
- end subroutine AcceptReject
-
- end module CMB_Cls
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/cmbdata.F90 cosmomc_sampler/source/cmbdata.F90
*** cosmomc/source/cmbdata.F90 2010-01-27 11:11:34.000000000 +0100
--- cosmomc_sampler/source/cmbdata.F90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,1062 ****
- !Module storing observed datasets, their points and window functions
- !and routines for computing the likelihood
- !Cls passed to these routines are in in MicroK^2, no 2pi or l(l+1)
- !WMAP data is handled separately as a special case
-
- !If windows_are_bandpowers=T Windows functions read in from files are assumed to be W_l/l.
- !(unless windows_are_bare=T, in which case we assume they are W_l)
- !The band powers are obtained from
- !W_l by \sum_l (l+1/2) W_l C_l/2pi where W_l is normalized so \sum_l (l+1/2)/l(l+1) W_l = 1.
- !If windows_are_normalized=T the windows are assumed to be already normalized;
- !this must be the case for polarization in which the window files contain
- ! l TT TE EE BB
- !contributions to each band power. Usually all but two columns will be zeros.
-
- !If windows_are_bandpowers=F then window functions are assumed raw, and directly related
- !to the bandpowers by B_i=sum_l W_{il} C_l
-
- !This code is very indebted to Sarah's cosmarg
- !Analytic marginalization over calibration and beam from astro-ph/0112114
-
- !x factors are described in astro-ph/9808264. Essentially they are a first correction
- !for the bandpower errors being non-Gaussian. If no x-factors we assume they are gaussian.
- !Using x-factors we transform to a variable Z = log (bandpower + x), and assume Z has Gaussian errors.
- !When x-factors are used the inverse covariance matrix is assumed to be that for Z.
- !See the RADPACK page for data http://bubba.ucdavis.edu/~knox/radpack.html
-
- !This version August 2006
- !Mar 04: added first_band parameter to .dataset files, added format for doing exact likelihoods
- !Jul 05: Readdataset_bcp changes for BOOM/CBI data, allowing for band cuts
- !Mar 06: changed to WMAP 3-year likelihood
- !Aug 06: added cal**2 scaling of x-factors
- !Oct 06: edited ReadAllExact to auto-account for number of cls (e.g. missing BB)
- !Oct 07: added Planck-like CMBLikes format
- !Sept 09: modified ReadDataset_bcp for QUaD, allowing beam errors to be explicitly provided for each band
- ! CMBLnLike passes array of parameters for frequency-dependent part of signal
- !Oct 27 Oct 09: fixed bugs using .newdat files
- !Jan 10: switched to support WMAP7
-
- module cmbdata
- use settings
- use cmbtypes
- use MatrixUtils
- use CMBLikes
- use constants
- implicit none
-
-
- !if CMBdataset%has_xfactors then obs, var and N_inv are for the offset-lognormal variables Z
-
- Type CMBdatapoint
- integer win_min, win_max
- !Ranges in which window is non-zero
- real, pointer, dimension(:,:) :: window
- !Normalized window function in l
- real obs, err_minus, err_plus, sigma, var
- !Observed value of l(l+1) C_l/2pi bandpowers in MicroK^2, with errors
- real beam_err !fractional beam error (file is value in MicroK^2)
- logical inc_pol
-
- end Type CMBdatapoint
-
- Type CMBdataset
- logical :: use_set
- logical :: has_pol, windows_are_bandpowers,windows_are_normalized
- logical :: has_sz_template
- real :: calib_uncertainty
- logical :: beam_uncertain, has_corr_errors, has_xfactors
- integer :: num_points, file_points
- character(LEN=80) :: name
- Type(CMBdatapoint), pointer, dimension(:) :: points
- real, pointer, dimension(:,:) :: N_inv
- real, pointer, dimension(:) :: xfactors
- logical, pointer, dimension(:) :: has_xfactor !whether each bin has one
- logical :: all_l_exact
- logical :: CMBLike !New format
- integer :: all_l_lmax
- integer :: nuisance_parameters
- real, pointer, dimension(:,:) :: all_l_obs, all_l_noise
- real, pointer, dimension(:) :: all_l_fsky
- real, pointer, dimension(:) :: sz_template
- Type (TCMBLikes), pointer :: CMBLikes
- end Type CMBdataset
-
- integer :: num_datasets = 0
- Type(CMBdataset) datasets(10)
-
- logical :: init_MAP = .true.
-
- integer :: cl_bin_width =1
-
-
- integer, parameter :: halfsteps = 5 !do 2*halfsteps+1 steps in numerical marginalization
- real margeweights(-halfsteps:halfsteps)
- real :: margenorm = 0
- private halfsteps, margeweights, margenorm
- contains
-
-
- subroutine ReadWindow(AP, aname, are_bare, aset)
- Type(CMBdatapoint) AP
- character(LEN=*), intent(IN) :: aname
- logical, intent(IN) :: are_bare
- Type (CMBdataset) :: aset
- integer l, ncls
- real wpol(1:num_cls-1),ll, IW,w
- character(LEN=200) tmp
-
- if (Feedback > 1) write (*,*) 'reading window: '//trim(aname)
-
- if (aset%has_pol) then
- ncls = num_cls
- else
- ncls = 1
- endif
- allocate(AP%window(ncls,lmax))
-
- AP%window = 0
-
- call OpenTxtFile(aname, tmp_file_unit)
-
- do
- if (aset%has_pol) then
- read(tmp_file_unit,'(a)',end=1) tmp
- read(tmp,*, end=1) ll, w, wpol
- else
- read(tmp_file_unit,*, end=1) ll, w
- end if
-
- l=nint(ll)
- if (abs(l-ll) > 1e-4) stop 'non-integer l in window file'
- if (l>=2 .and. l<=lmax) then
- AP%window(1,l) = w
- if(aset%has_pol) then
- AP%window(2:num_cls,l) = wpol
- end if
- if (.not. are_bare) AP%window(:,l) = AP%window(:,l)*l
- else
- if (l>lmax .and. w /= 0) then
- write (*,*) 'Warning: Window function non-zero outside l_max: ',trim(aname)
- write (*,*) 'assuming contribution is negligible'
- exit
- end if
- end if
-
- end do
- 1 close(tmp_file_unit)
-
- do l=2, lmax
- if (any(AP%window(:,l)/=0)) then
- AP%win_min = l
- exit
- end if
- end do
-
- do l=lmax,2,-1
- if (any(AP%window(:,l)/=0)) then
- AP%win_max = l
- exit
- end if
- end do
-
- AP%inc_pol = .false.
-
- if (aset%windows_are_bandpowers) then
- IW = 0
- do l = AP%win_min, AP%win_max
- IW = IW + ((l+0.5)*AP%window(1,l))/(l*(l+1))
- AP%window(:,l) = AP%window(:,l)*(l+0.5)/(2*pi)
- end do
- if (.not. aset%windows_are_normalized) then
- if (aset%has_pol) stop 'Polarization windows must be normalized'
- AP%window(1,AP%win_min:AP%win_max) = &
- AP%window(1,AP%win_min:AP%win_max)/IW
- end if
- end if
- !If has_pol we are assuming windows are normalized
-
- if (aset%has_pol) AP%inc_pol = any(AP%window(2:num_cls,:)/=0)
-
- end subroutine ReadWindow
-
- subroutine ReadAllExact(Ini,aset)
- Type(TIniFile) :: Ini
- Type (CMBdataset) :: aset
- character(LEN=Ini_max_string_len) :: fname
- integer l, idum, ncls, ncol
- real inobs(4)
- integer file_unit
-
- !In this case we have data for every l, and use exact full-sky likelihood expression
- !with some fudge factor fsky_eff^2 to reduce the degrees of freedom: fsky^eff*(2l+1)
-
- if (Feedback > 0) &
- write(*,*) 'all_l_exact note: you might want to change fsky_eff^2 factor to fsky_eff'
-
- aset%num_points = 0
- aset%all_l_lmax = Ini_Read_Int_File(Ini,'all_l_lmax')
-
- if (aset%all_l_lmax > lmax) stop 'cmbdata.f90::ReadAllExact: all_l_lmax > lmax'
- if (aset%has_pol) then
- allocate(aset%all_l_obs(2:aset%all_l_lmax,num_cls))
- allocate(aset%all_l_noise(2:aset%all_l_lmax,2))
- else
- allocate(aset%all_l_obs(2:aset%all_l_lmax,1))
- allocate(aset%all_l_noise(2:aset%all_l_lmax,1))
- end if
- allocate(aset%all_l_fsky(2:aset%all_l_lmax))
- fname = trim(Ini_Read_String_File(Ini,'all_l_file'))
- ncol = TxtFileColumns(fname)
- if (ncol==7) then
- ncls = 3
- elseif (ncol==8) then
- ncls = 4
- elseif (ncol==4) then
- ncls=1
- if (aset%has_pol) stop 'cmbdata.f90::ReadAllExact: has_pol wrong'
- else
- stop 'cmbdata.f90::ReadAllExact: wrong number of columns'
- end if
-
- file_unit = new_file_unit()
-
- call OpenTxtFile(fname,file_unit)
- !File format:
- !l C_TT (C_TE C_EE [C_BB]) N_T (N_P) fsky_eff
- !Must have num_cls set to correct value for file
- do l = 2, aset%all_l_lmax
- read (file_unit, *, end=100, err=100) idum,inobs(1:ncls), aset%all_l_noise(l,:), aset%all_l_fsky(l)
- if (idum /= l) stop 'Error reading all_l_file'
- !set BB to pure noise if not in file
- if (aset%has_pol .and. ncls < num_cls) inobs(num_cls) = aset%all_l_noise(l,2)
- aset%all_l_obs(l,:) = inobs(1:num_cls)
- end do
- call CloseFile(file_unit)
-
- return
- 100 stop 'Error reading all_l_file file'
-
-
- end subroutine ReadAllExact
-
-
- function ChiSqExact(cl, aset)
- !Compute -ln(Likelihood)
- real cl(lmax,num_cls)
- Type(CMBdataset) :: aset
- integer l
- real ChiSqExact, chisq, term, CT, CE, CB, CC
- real CThat, CChat, CEhat, CBhat
- real dof
- integer i
-
- chisq=0
-
- do l=2, 30
- dof = aset%all_l_fsky(l)*(2*l+1)
- !Ignoring l correlations but using f_sky^2_eff fudge factor may be a good approx
- !for nearly full sky observations
- !switched to just fsky**1 default Nov 09 since usually more useful
- CT = cl(l,1) + aset%all_l_noise(l,1)
- if (aset%has_pol) then
- CE = cl(l,3) + aset%all_l_noise(l,2)
- term = CT*CE- cl(l,2)**2
- chisq = chisq + dof*( &
- (CT*aset%all_l_obs(l,3) + CE*aset%all_l_obs(l,1) - 2 *cl(l,2)*aset%all_l_obs(l,2))/term &
- + log( term/ (aset%all_l_obs(l,1)*aset%all_l_obs(l,3) - aset%all_l_obs(l,2)**2)) -2)
- if (num_cls>3) then
- !add in BB
- CB = cl(l,num_cls) + aset%all_l_noise(l,2)
- chisq = chisq + dof * (aset%all_l_obs(l,num_cls)/CB &
- +log(CB/aset%all_l_obs(l,num_cls)) - 1)
- end if
- else
- chisq = chisq + dof * (aset%all_l_obs(l,1)/CT &
- +log(CT/aset%all_l_obs(l,1)) - 1)
- end if
- end do
-
-
- do l=31 , aset%all_l_lmax, cl_bin_width
- dof = 0
- CT=0
- CE=0
- CC=0
- CB=0
- CThat=0
- CEhat=0
- CChat=0
- CBhat=0
- do i=l,l+cl_bin_width-1
- dof = dof + aset%all_l_fsky(i)**2*(2*i+1)
- CT = CT + (cl(i,1) + aset%all_l_noise(i,1))*(2*i+1)
- CThat = CThat + aset%all_l_obs(i,1)*(2*i+1)
- if (aset%has_pol) then
- CE = CE + (cl(i,3) + aset%all_l_noise(i,2) ) *(2*i+1)
- CC = CC + cl(i,2)*(2*i+1)
- CEhat = CEhat + aset%all_l_obs(i,3)*(2*i+1)
- CChat = CChat + aset%all_l_obs(i,2)*(2*i+1)
- if (num_cls>3) then
- !add in BB
- CB = CB + (cl(i,num_cls) + aset%all_l_noise(i,2))*(2*i+1)
- CBhat = CBhat + aset%all_l_obs(i,num_cls)*(2*i+1)
- end if
- end if
- end do
-
-
- if (aset%has_pol) then
- term = CT*CE - CC**2
- chisq = chisq + dof*( &
- (CT*CEHat + CE*CThat - 2 *CC*CCHat)/term &
- + log( term/ (CTHat*CEHat - CCHat**2)) -2)
- if (num_cls>3) then
- !add in BB
- chisq = chisq + dof * (CBhat/CB +log(CB/CBhat) - 1)
- end if
- else
- chisq = chisq + dof * (CTHat/CT +log(CT/CTHat) - 1)
- end if
- end do
-
- ChiSqExact = ChiSq
-
- end function ChiSqExact
-
- subroutine ReadDataset(aname)
- use CMBLikes
- character(LEN=*), intent(IN) :: aname
- character(LEN=Ini_max_string_len) :: InLine, window_dir, Ninv_file, xfact_file, band_file
- logical bad, windows_are_bare
- Type (CMBdataset) :: aset
- integer i, first_band, use_i
- real, pointer, dimension(:,:) :: tmp_mat
- real, pointer, dimension(:) :: tmp_arr
- character(LEN=Ini_max_string_len) :: data_format
- integer file_unit
- Type(TIniFile) :: Ini
-
- num_datasets = num_datasets + 1
-
- if (num_datasets > 10) stop 'too many datasets'
-
- aset%has_sz_template = .false.
- aset%nuisance_parameters = 0
-
- !Special cases
- if (aname == 'MAP' .or. aname == 'WMAP') then
- aset%name = 'WMAP'
- datasets(num_datasets) = aset
- return
- elseif( aname(LEN_TRIM(aname)-5:LEN_TRIM(aname)) == 'newdat') then
- !Carlo format for polarized Boomerang et al.
- if (Feedback > 0) write(*,*) 'Reading BCP data set: ' // TRIM(aname)
- call ReadDataset_bcp(aset,aname)
- datasets(num_datasets) = aset
- return
- end if
-
- file_unit = new_file_unit()
-
- call Ini_Open_File(Ini,aname, file_unit, bad, .false.)
- if (bad) then
- write (*,*) 'Error opening dataset file '//trim(aname)
- stop
- end if
- Ini_fail_on_not_found = .true.
-
- aset%name = Ini_Read_String_File(Ini,'name')
- aset%use_set =.true.
- aset%num_points = 0
-
- if (Feedback > 0) write (*,*) 'reading: '//trim(aset%name)
-
- Ini_fail_on_not_found = .false.
-
- data_format = Ini_Read_String_File(Ini,'dataset_format')
-
- aset%CMBlike = data_format == 'CMBLike'
-
- aset%all_l_exact = (data_format =='all_l_exact') &
- .or. Ini_Read_Logical_File(Ini,'all_l_exact',.false.)
- if (aset%CMBLike) then
- allocate(aset%CMBLikes)
- call CMBLikes_ReadData(aset%CMBLikes, Ini, ExtractFilePath(aname))
- aset%nuisance_parameters = aset%CMBLikes%num_nuisance_parameters
-
- else if (aset%all_l_exact) then
- aset%has_pol = Ini_Read_Logical_File(Ini,'has_pol',.false.)
- call ReadAllExact(Ini,aset)
- else if (data_format/='') then
- write(*,*) 'Error in '//trim(aname)
- write(*,*) 'Unknown data_format: '//trim(data_format)
- stop
- else
- !Otherwise do usual guassian/offset lognormal stuff
-
- aset%has_pol = Ini_Read_Logical_File(Ini,'has_pol',.false.)
-
- aset%num_points = Ini_Read_Int_File(Ini,'num_points')
-
- aset%calib_uncertainty = Ini_Read_Double_File(Ini,'calib_uncertainty')
- aset%beam_uncertain = Ini_Read_logical_File(Ini,'beam_uncertainty')
-
- window_dir = ReadIniFilename(Ini,'window_dir')
-
- windows_are_bare = Ini_Read_Logical_File(Ini,'windows_are_bare',.false.)
- aset%windows_are_bandpowers = Ini_Read_Logical_File(Ini,'windows_are_bandpowers',.true.)
- aset%windows_are_normalized = Ini_Read_Logical_File(Ini,'windows_are_normalized',.false.)
-
- aset%file_points = Ini_read_Int_File(Ini,'file_points',aset%num_points)
- first_band = Ini_read_Int_File(Ini,'first_band',1)
- if (first_band + aset%num_points > aset%file_points+1) then
- write (*,*) 'Error with dataset file '//trim(aname)
- write (*,*) 'first_band + num_points > file_points'
- stop
- end if
- !Read in the observed values, errors and beam uncertainties
- allocate(aset%points(aset%num_points))
- band_file = Ini_Read_String_File(Ini,'bandpowers')
- if (band_file /= '') call OpenTxtFile(band_file, 51)
- Ini_fail_on_not_found = .true.
- do i=1, aset%num_points + first_band -1
- if (band_file /= '') then
- read(51,'(a)') InLine
- else
- InLine = Ini_Read_String_File(Ini,numcat('data',i))
- end if
- if (i < first_band) cycle
- use_i = i - first_band + 1
- if (aset%beam_uncertain) then
- read(InLine,*) aset%points(use_i)%obs, aset%points(use_i)%err_minus, aset%points(use_i)%err_plus, &
- aset%points(use_i)%beam_err
- aset%points(use_i)%beam_err = aset%points(use_i)%beam_err/aset%points(use_i)%obs
- else
- read(InLine,*) aset%points(use_i)%obs, aset%points(use_i)%err_minus, aset%points(use_i)%err_plus
- aset%points(use_i)%beam_err = 0
- end if
- aset%points(use_i)%sigma = (aset%points(use_i)%err_minus + aset%points(use_i)%err_plus)/2
- aset%points(use_i)%var = aset%points(use_i)%sigma**2
- call ReadWindow(aset%points(use_i),trim(window_dir)//'/'//trim(numcat(aset%name,i)),windows_are_bare,aset)
- end do
- if (band_file /= '') Close(51)
-
-
- !See if the inverse covariance matrix is given (otherwise assume diagonal)
- Ini_fail_on_not_found = .false.
-
- Ninv_file = Ini_Read_String_File(Ini,'N_inv')
- aset%has_corr_errors = Ninv_file /= ''
- if (aset%has_corr_errors) then
- allocate(tmp_mat(aset%file_points,aset%file_points))
- allocate(aset%N_inv(aset%num_points,aset%num_points))
- call ReadMatrix(Ninv_file, tmp_mat,aset%file_points,aset%file_points)
- if (aset%num_points /= aset%file_points) then
- !!Changed to truncation of covariance matrix, AL: May 2003
- call Matrix_Inverse(tmp_mat)
- aset%N_inv = tmp_mat(first_band:first_band+aset%num_points-1,&
- first_band:first_band + aset%num_points -1)
- call Matrix_Inverse(aset%N_inv)
- else
- aset%N_inv = tmp_mat(1:aset%num_points,1:aset%num_points)
- end if
- deallocate(tmp_mat)
- end if
-
- if (Ini_Read_Logical_File(Ini,'use_hyperparameter',.false.)) stop 'Hyperparameters deprecated'
-
- !See if xfactors are given
-
- xfact_file = Ini_Read_String_File(Ini,'xfactors')
- aset%has_xfactors = xfact_file /= ''
-
- if (aset%has_xfactors) then
- allocate(tmp_arr(aset%num_points + first_band -1))
- call ReadVector(xfact_file, tmp_arr,aset%num_points+ first_band -1)
- allocate(aset%xfactors(aset%num_points))
- allocate(aset%has_xfactor(aset%num_points))
- aset%has_xfactor = .true.
- aset%xfactors = tmp_arr(first_band:first_band+aset%num_points-1)
- deallocate(tmp_arr)
- aset%points(:)%var = aset%points(:)%var/(aset%points(:)%obs +aset%xfactors)**2
- aset%points(:)%obs = log(aset%points(:)%obs +aset%xfactors)
-
- end if
-
- end if !not all_l_exact or cut sky unbinned
-
- call Ini_Close_File(Ini)
- call ClearFileUnit(file_unit)
-
- datasets(num_datasets) = aset
-
- end subroutine ReadDataset
-
- subroutine ReadSZTemplate(aset, aname, ascale)
- Type (CMBdataset) :: aset
- real, intent(in) :: ascale
- character(LEN=*), intent(IN) :: aname
- integer l, unit
- real sz
- allocate(aset%sz_template(2:lmax))
- aset%sz_template = 0
- aset%has_sz_template = .true.
- call OpenTxtFile(aname, tmp_file_unit)
- do
- read(tmp_file_unit,*,end=2) l, sz
- if (l>=2 .and. l<=lmax) aset%sz_template(l) = ascale * sz/(l*(l+1)/twopi)
- end do
-
- 2 Close(tmp_file_unit)
- end subroutine ReadSZTemplate
-
- function GetWinBandPower(AP, cl)
- real GetWinBandPower
- real cl(lmax,num_cls)
- Type(CMBdatapoint) AP
- integer l
- real bandpower
-
- bandpower = sum(cl(AP%win_min:AP%win_max,1)*AP%window(1,AP%win_min:AP%win_max))
-
- if (AP%inc_pol) then
- do l= AP%win_min, AP%win_max
- bandpower = bandpower + sum(cl(l,2:num_cls)*AP%window(2:num_cls,l))
- end do
- endif
- GetWinBandPower = bandpower
-
- end function GetWinBandPower
-
- subroutine InitNumericalMarge
- integer i
-
- do i= -halfsteps, halfsteps
- margeweights(i) = exp(-(i*3/real(halfsteps))**2/2)
- end do
- margenorm = sum(margeweights)
-
- end subroutine InitNumericalMarge
-
- function GetCalibMargexChisq(bandpowers, aset)
- !Numerically integrate over the calibration uncertainty
- !Assume Gaussian prior, as for analytic calculation without x-factors
- !Could also Monte-Carlo
- real GetCalibMargexChisq
- Type(CMBdataset) aset
- real bandpowers(aset%num_points),beambandpowers(aset%num_points),diffs(aset%num_points)
- real calib, chisq(-halfsteps:halfsteps),chisqcalib(-halfsteps:halfsteps)
- real minchisq
- integer i,j, ibeam
-
- if (margenorm == 0) call InitNumericalMarge
-
- do ibeam= -halfsteps, halfsteps
-
- if (aset%beam_uncertain) then
- beambandpowers = bandpowers*(1 + aset%points(:)%beam_err*ibeam*3/real(halfsteps))!Go out to 3 sigma
- else
- beambandpowers = bandpowers
- end if
-
- do i=-halfsteps,halfsteps
-
- calib = 1 + aset%calib_uncertainty*i*3./halfsteps !Go out to 3 sigma
-
- if (aset%has_xfactors) then
- do j=1, aset%num_points
- if (aset%has_xfactor(j)) then
- diffs(j) = aset%points(j)%obs- log(calib*beambandpowers(j) + aset%xfactors(j))
- else
- diffs(j) = aset%points(j)%obs - calib*beambandpowers(j)
- endif
- end do
- else
- diffs = aset%points(:)%obs - calib*beambandpowers
- end if
-
- if (aset%has_corr_errors) then
- chisq(i) = SUM(diffs*MATMUL(aset%N_inv,diffs))
- else
- chisq(i) = SUM(diffs**2/aset%points(:)%var)
- end if
- end do
-
- minchisq = minval(chisq)
-
- chisqcalib(ibeam) = -2*log(sum(margeweights*exp(max(-30.,-(chisq-minchisq)/2)))/margenorm) + minchisq
-
- if (.not. aset%beam_uncertain) then
- GetCalibMargexChisq = chisqcalib(ibeam)
- return
- end if
-
- end do
-
- minchisq = minval(chisqcalib)
- GetCalibMargexChisq = -2*log(sum(margeweights*exp(max(-30.,-(chisqcalib-minchisq)/2)))/margenorm) + minchisq
-
- end function GetCalibMargexChisq
-
-
- !Routine by Carlo Contaldi to read .newdat file format (Boomerang et al)
- !Modified to account for offset lognormal toggle per band
- !AL July 2005: modified to allow band selection
- !MLB May 09: modified to allow provision of per-band beam errors (Quad)
- SUBROUTINE ReadDataset_bcp(aset,aname)
- !File Format:
- !name
- !n_bands_TT n_EE, n_BB, n_EB, n_TE, n_TB
- !has_calib_uncertain calib(amplitude) calib_err(power)
- !has_beam_uncertain beam beam_err
- !ilike (0: Gaussian, 1: all x-factor, 2: specified have x-factor)
- !loop over {
- ! band-types
- ! band info: num obs + - x_factor l_min l_max use_x
- ! correlation-matrix (ignored)
- ! }
- ! covariance matrix
- use constants
-
- CHARACTER(LEN=*), INTENT(IN) :: aname
- TYPE (CMBdataset) :: aset
-
- CHARACTER(LEN=100) :: instr
- CHARACTER(LEN=3), DIMENSION(1:6) :: ch_types
-
- LOGICAL windows_are_bare
- INTEGER i, j, k,use_i, n_types, xin
- REAL, POINTER, DIMENSION(:) :: tmp_x
- REAL, POINTER, DIMENSION(:,:) :: lb
- real, allocatable, dimension(:,:) :: tmp_mat
- integer, allocatable, dimension(:) :: used_bands
-
- INTEGER :: npol(6), minmax(2,6)
- INTEGER :: file_i,ijunk, ilike, ibeam
- REAL :: cal, beam_width, beam_sigma, l_mid
- integer, parameter :: like_xfactorall=1, like_xfactorsome = 2
- !to be compatible with some older CITA output files
- LOGICAL :: FISHER_T_CMB
- integer file_unit
-
-
- file_unit = new_file_unit()
- CALL OpenTxtFile(aname, file_unit)
-
- READ(file_unit,'(a)') instr
- FISHER_T_CMB = .FALSE.
- IF(instr == 'FISHER_T_CMB') THEN
- FISHER_T_CMB = .TRUE.
- READ(file_unit,'(a)') instr
- WRITE(*,'(a)') 'FISHER_T_CMB is set for :'//TRIM(ADJUSTL(instr))
- ENDIF
- aset%name = TRIM(ADJUSTL(instr))
- WRITE(*,*) 'Reading: '//TRIM(ADJUSTL(aset%name))
- aset%use_set =.TRUE.
-
- READ(file_unit,*) npol(1:6)
-
- aset%has_pol = any(npol(2:6) /=0)
-
- aset%all_l_exact = .FALSE.
- aset%file_points = SUM(npol)
- aset%num_points = SUM(npol)
- n_types = count(npol /= 0)
- READ(file_unit,'(a)') instr
- IF(instr == 'BAND_SELECTION') THEN
- !list of 'first_band last_band' for each pol type
- !if first_band=0 then ignore that pol type
- aset%num_points = 0
- aset%has_pol = .false.
- if(feedback>0) WRITE(*,*) 'Using selected band ranges'
- do i=1,6
- READ(file_unit,*) minmax(1:2,i)
- if (minmax(1,i)/=0) then
- aset%num_points = aset%num_points + minmax(2,i) - minmax(1,i) + 1
- if (i>1) aset%has_pol = .true.
- else
- minmax(2,i) = 0
- end if
- end do
- READ(file_unit,'(a)') instr
- ELSE
- !use all bands in file
- do i=1,6
- minmax(1,i)=1
- minmax(2,i)=npol(i)
- end do
- ENDIF
-
-
- READ(instr,*) ijunk, cal, aset%calib_uncertainty
- IF(ijunk == 0) aset%calib_uncertainty = 0.e0
-
- READ(file_unit,*) ibeam, beam_width, beam_sigma
- aset%beam_uncertain = ibeam /= 0
-
- !this agrees with latest windows coming out of MPIlikely
- windows_are_bare = .FALSE.
- aset%windows_are_bandpowers = .TRUE.
- aset%windows_are_normalized = .TRUE.
-
- ALLOCATE(aset%points(aset%num_points))
- allocate(used_bands(aset%num_points))
-
- READ(file_unit,*) ilike
- aset%has_xfactors = ilike ==like_xfactorsome .or. ilike==like_xfactorall
- !1 : all bands are offset lognormal
- !2 : only bands specified have offset lognormal
- IF(aset%has_xfactors) then
- ALLOCATE(aset%has_xfactor(1:aset%num_points))
- aset%has_xfactor = .true.
- end if
-
- ALLOCATE(tmp_x(1:aset%num_points))
- ALLOCATE(lb(1:aset%num_points,1:2))
- k = 0
- use_i = 0
- file_i = 0
- DO j=1,n_types
- READ(file_unit,'(a2)') ch_types(j)
- k = k + 1
- DO i=1,20
- IF(npol(k) == 0 ) THEN
- k = k + 1
- ELSE
- EXIT
- ENDIF
- ENDDO
-
- if(feedback>1) write(*,*) j, ch_types(j), minmax(1,k), minmax(2,k)
-
- DO i=1,npol(k)
- file_i = file_i+1
- if (i>=minmax(1,k) .and. i<=minmax(2,k)) then
- use_i = use_i + 1
- used_bands(use_i) = file_i
- IF(ibeam .le. 1) THEN
- IF(ilike /= like_xfactorsome) THEN
- READ(file_unit,'(a)') instr
- READ(instr,*) ijunk, aset%points(use_i)%obs,aset%points(use_i)%err_minus, &
- aset%points(use_i)%err_plus,tmp_x(use_i),lb(use_i,1),lb(use_i,2)
- ELSE
- !like_xfactorsome
- !read also offset switch per band
- READ(file_unit,*) ijunk, aset%points(use_i)%obs,aset%points(use_i)%err_minus, &
- aset%points(use_i)%err_plus,tmp_x(use_i),lb(use_i,1),lb(use_i,2),xin
- aset%has_xfactor(use_i) = xin/=0
- ENDIF
- !beam error in bandpower
- l_mid = (lb(use_i,2)-lb(use_i,1))/2.d0 + lb(use_i,1)
- aset%points(use_i)%beam_err = exp(-l_mid*(l_mid+1.d0)*1.526e-8*2.d0*beam_sigma*beam_width)-1.d0
- aset%points(use_i)%beam_err = abs(aset%points(use_i)%beam_err)
- ELSE !Bandpowers from file, a la Quad
- IF(ilike /= like_xfactorsome) THEN
- READ(file_unit,'(a)') instr
- READ(instr,*) ijunk, aset%points(use_i)%obs,aset%points(use_i)%err_minus, &
- aset%points(use_i)%err_plus,tmp_x(use_i),lb(use_i,1),lb(use_i,2),aset%points(use_i)%beam_err
- ELSE
- !like_xfactorsome
- !read also offset switch per band
- READ(file_unit,*) ijunk, aset%points(use_i)%obs,aset%points(use_i)%err_minus, &
- aset%points(use_i)%err_plus,tmp_x(use_i),lb(use_i,1),lb(use_i,2),xin,aset%points(use_i)%beam_err
- aset%has_xfactor(use_i) = xin/=0
- ENDIF
- l_mid = (lb(use_i,2)-lb(use_i,1))/2.d0 + lb(use_i,1)
- ENDIF
- aset%points(use_i)%sigma = (aset%points(use_i)%err_minus + aset%points(use_i)%err_plus)/2
-
- if (Feedback>1 ) print*, aset%beam_uncertain, l_mid, aset%points(use_i)%beam_err
-
- !recalibrate
- aset%points(use_i)%obs = cal**2 * aset%points(use_i)%obs
- aset%points(use_i)%sigma = cal**2 * aset%points(use_i)%sigma
-
- aset%points(use_i)%var = aset%points(use_i)%sigma**2
- !AL: Oct 08, changed to set path from the dataset path
- CALL ReadWindow(aset%points(use_i), trim(concat(ExtractFilePath(aname),'windows/')) // &
- TRIM(numcat(aset%name,file_i)),windows_are_bare,aset)
-
- else
- !discard band
- READ(file_unit,'(a)') instr
- end if
- ENDDO
- !discard correlation submatrix
- READ(file_unit,'(a)') (instr,i=1,npol(k))
- ENDDO
-
- !assume always have the matrix
- aset%has_corr_errors = .TRUE.
- allocate(tmp_mat(aset%file_points,aset%file_points))
- ALLOCATE(aset%N_inv(aset%num_points,aset%num_points))
- READ(file_unit,*) (tmp_mat(1:aset%file_points,i),i=1,aset%file_points)
- aset%N_inv = tmp_mat(used_bands,used_bands)
- deallocate(tmp_mat)
- deallocate(used_bands)
-
- !READ(file_unit,*,err=101,end=101) instr
- !stop 'ReadDataset_bcp:Should be at end of file after reading matrix'
- 101 call CloseFile(file_unit)
-
- !recalibrate and change units as required
- !some older output had final fisher matrix in
- !in units of T_CMB whitle bandpowers are in units
- !of \microK^2
- IF(FISHER_T_CMB) THEN
- aset%N_inv = cal**4 * aset%N_inv *COBE_CMBTemp**4 * 1.e24
- ELSE
- aset%N_inv = cal**4 * aset%N_inv
- ENDIF
-
- IF(aset%has_pol) WRITE(*,*) 'has pols: ', ADJUSTR(ch_types(1:n_types))
-
- !transform into Z_B = ln(C_B+x_B) for bandpowers with xfactors
- IF(aset%has_xfactors) THEN
- ALLOCATE(aset%xfactors(1:aset%num_points))
- aset%xfactors(1:aset%num_points) = cal**2*tmp_x(1:aset%num_points)
- DO i=1,aset%num_points
- DO j=1,aset%num_points
- if(aset%has_xfactor(i)) aset%N_inv(i,j) = aset%N_inv(i,j)/(aset%points(i)%obs + aset%xfactors(i))
- if(aset%has_xfactor(j)) aset%N_inv(i,j) = aset%N_inv(i,j)/(aset%points(j)%obs + aset%xfactors(j))
- ENDDO
- ENDDO
- DO i=1,aset%num_points
- IF(aset%has_xfactor(i)) THEN
- aset%points(i)%var = aset%points(i)%var/(aset%points(i)%obs +aset%xfactors(i))**2
- aset%points(i)%obs = LOG(aset%points(i)%obs + aset%xfactors(i))
- ENDIF
- ENDDO
- CALL Matrix_Inverse(aset%N_inv)
- ELSE
- CALL Matrix_Inverse(aset%N_inv)
- ENDIF
-
- DEALLOCATE(tmp_x)
- deallocate(lb)
- END SUBROUTINE ReadDataset_bcp
-
-
- function CalcLnLike(clall, aset,nuisance_params)
- !Compute -ln(Likelihood)
- real clall(lmax,num_cls_tot), CalcLnLike
- real, intent(in) :: nuisance_params(:)
- Type(CMBdataset) aset
- integer i
- real cl(lmax, num_cls)
- real chisq
- real chi2op, chi2pp, wpp, wdd
- real chi2dd,chi2pd,chi2od
- real bandpowers(aset%num_points), diffs(aset%num_points), tmp(aset%num_points), beam(aset%num_points)
- real denom
-
- if (.not. aset%use_set) then
- CalcLnLike = 0
- return
- end if
- cl = clall(:,1:num_cls) !without lensing power spectrum or other extra CL
-
- if (aset%CMBLike) then
-
- chisq = CMBLikes_CMBLike(aset%CMBLikes, clall, nuisance_params)
-
- else if (aset%all_l_exact) then
-
- chisq = ChiSqExact(cl,aset)
-
- else
-
- denom = 1 !Assume Prob \propto exp(-chisq/2)/sqrt(denom)
-
- do i=1, aset%num_points
- bandpowers(i) = GetWinBandPower(aset%points(i), cl)
- end do
-
- if (aset%has_xfactors .and. (aset%calib_uncertainty > 1e-4 .or. aset%beam_uncertain)) then
-
- chisq = GetCalibMargexChisq(bandpowers,aset)
-
- else
-
- if (aset%has_xfactors) then
- do i=1, aset%num_points
- if (aset%has_xfactor(i)) then
- !obs in this case is Z = log(observed + x)
- diffs(i) = aset%points(i)%obs- log(bandpowers(i) + aset%xfactors(i))
- else
- diffs(i) = aset%points(i)%obs - bandpowers(i)
- end if
- end do
- else
- diffs = aset%points(:)%obs - bandpowers
- end if
-
- if (aset%has_corr_errors) then
- chisq = SUM(diffs*MATMUL(aset%N_inv,diffs))
- else
- chisq = SUM(diffs**2/aset%points(:)%var)
- end if
-
- if (aset%calib_uncertainty > 1e-4 .or. aset%beam_uncertain) then
-
- if (aset%has_corr_errors) then
- tmp = MATMUL(aset%N_inv,bandpowers)
- else
- tmp = bandpowers/aset%points(:)%var
- end if
- chi2op = SUM(diffs*tmp)
- chi2pp = SUM(bandpowers*tmp)
- if (aset%beam_uncertain) then
- beam = aset%points(:)%beam_err*bandpowers
- if (aset%has_corr_errors) then
- tmp = MATMUL(aset%N_inv,beam)
- else
- tmp = beam/aset%points(:)%var
- end if
- chi2dd = SUM(beam*tmp)
- chi2pd = SUM(bandpowers*tmp)
- chi2od = SUM(diffs*tmp)
- end if
-
- if (aset%calib_uncertainty > 1e-4) then
- !analytic marginalization over calibration uncertainty
- wpp = 1/(chi2pp+1/aset%calib_uncertainty**2)
- chisq = chisq - wpp*chi2op**2
- denom = denom/wpp*aset%calib_uncertainty**2
- else
- wpp = 0
- end if
-
- if (aset%beam_uncertain) then
- !analytic marginalization over beam uncertainty
- wdd=1/(chi2dd-wpp*chi2pd**2+1)
- chisq = chisq - wdd*(chi2od-wpp*chi2op*chi2pd)**2
- denom = denom/wdd
- end if
-
- end if
-
- end if
-
- if (denom /= 1) chisq = chisq + log(denom)
-
- end if
- CalcLnLike = chisq/2
-
-
-
- end function CalcLnLike
-
- function CMBLnLike(cl, freq_params, nuisance_params)
- real, intent(in) :: cl(lmax,num_cls_tot)
- real CMBLnLike
- real,intent(in) :: freq_params(num_freq_params),nuisance_params(:)
- real sznorm, szcl(lmax,num_cls_tot)
- integer i
- integer nuisance
- real tot(num_datasets)
-
- sznorm = freq_params(1)
- nuisance =1
- do i=1, num_datasets
- szcl= cl
- if (datasets(i)%has_sz_template) then
- szcl(2:lmax,1) = szcl(2:lmax,1) + sznorm*datasets(i)%sz_template(2:lmax)
- end if
- if (datasets(i)%name == 'WMAP') then
- tot(i) = MAPLnLike(szcl)
- else
- tot(i) = CalcLnLike(szcl,datasets(i), nuisance_params(nuisance:))
- if (datasets(i)%CMBLike) nuisance = nuisance + datasets(i)%CMBLikes%num_nuisance_parameters
- end if
- end do
- CMBLnLike = SUM(tot)
- end function
-
-
- function MAPLnLike(cl)
- #ifndef NOWMAP
- use wmap_likelihood_7yr
- use WMAP_OPTIONS
- use WMAP_UTIL
- #endif
- real cl(lmax,num_cls_tot), MAPLnLike
- #ifndef NOWMAP
-
- real(8), dimension(2:ttmax) :: cl_tt,cl_te,cl_ee,cl_bb
- real(8) :: like(num_WMAP),like_tot
- integer l
-
- if (Init_MAP) then
- #ifdef WMAPNOHIGHLTT
- use_TT = .false.
- use_TT_beam_ptsrc = .false.
- #endif
- if (lmax0) write(*,*) 'reading WMAP7 data'
- Init_MAP = .false.
- end if
-
-
- do l = 2, ttmax
- cl_tt(l) = cl(l,1)*l*(l+1)/twopi
- cl_te(l) = cl(l,2)*l*(l+1)/twopi
- cl_ee(l) = cl(l,3)*l*(l+1)/twopi
- if(num_cls == 4) then
- cl_bb(l) = cl(l,num_cls)*l*(l+1)/twopi
- else
- cl_bb(l) = 0.0d0
- end if
- end do
-
- like=0.0d0
- call wmap_likelihood_compute(cl_tt,cl_te,cl_ee,cl_bb,like)
- !call wmap_likelihood_error_report
-
- if (wmap_likelihood_ok) then
- MAPLnLike = sum(like)
- else
- MAPLnLike = LogZero
- endif
- #else
- MAPLnLike=cl(2,1) !just stop unused symbol warnings
- stop 'Compiled without WMAP'
- #endif
- end function
-
-
- !WMAP1
- ! function MAPLnLike(cl)
- ! use WMAP
- ! real cl(lmax,num_cls), MAPLnLike
- ! integer l
- ! real(WMAP_precision) clTT(WMAP_lmax_TT), clTE(WMAP_lmax_TT), ClEE(WMAP_lmax_TT)
- ! integer stat
- ! character(LEN=20) :: ttFile = 'WMAP/tt_diag.dat'
- ! character(LEN=20) :: ttOffDiag ='WMAP/tt_offdiag.dat'
- ! character(LEN=20) :: teFile = 'WMAP/te_diag.dat'
- ! character(LEN=20) :: teOffDiag ='WMAP/te_offdiag.dat'
- !
- ! if (Init_MAP) then
- ! if (lmax0) write(*,*) 'reading WMAP data'
- ! Call WMAP_init(ttFile, ttOffDiag, teFile, teOffDiag, stat)!
- !
- ! if (stat /=0) stop 'Error reading WMAP files'
- ! if (Feedback>0) write(*,*) 'WMAP read'
- ! Init_MAP = .false.
- ! end if
-
- ! do l = 2, WMAP_lmax_TT
- ! clTT(l) = cl(l,1)*l*(l+1)/twopi
- ! clTE(l) = cl(l,2)*l*(l+1)/twopi
- ! clEE(l) = cl(l,3)*l*(l+1)/twopi
- ! end do
- ! MAPLnLike = -(WMAP_LnLike_TT(clTT) + WMAP_LnLike_TE(clTT, clTE, clEE))
-
- ! end function
-
-
- end module cmbdata
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/cmbtypes.f90 cosmomc_sampler/source/cmbtypes.f90
*** cosmomc/source/cmbtypes.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/cmbtypes.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,439 ****
- !Define the data types and read/writes them to disk. Also change l_max here.
-
- module cmbtypes
- use settings
- implicit none
-
-
- !Number of CMB Cls, 1 for just temperature, 3 (4) for polarization (with B)
- integer, parameter :: num_cls = 3
-
- integer, parameter :: num_cls_ext=0
- !number of other C_l
- !e.g. 2 for CMB lensing potential and cross-correlation
-
- !l_max. Tensors are not computed unless compute_tensors = T in input file
- !Make these multiples of 50, should be 50 more than you need accurately
- integer, parameter :: lmax = 2100, lmax_tensor = 400
-
- !Parameters for calculating/storing the matter power spectrum
- !Note that by default everything is linear
-
- !Note these are the interpolated/extrapolated values. The k at which matter power is computed up to
- !by CAMB is set in CMB_Cls_xxx with, e.g. P%Transfer%kmax = 0.6 (which is enough for 2dF)
-
- !Old mpk settings
- #ifdef DR71RG
- !!! BR09: Reid et al 2009 settings for the LRG power spectrum.
- integer, parameter :: num_matter_power = 300 !number of points computed in matter power spectrum
- real, parameter :: matter_power_minkh = 0.999e-4 !minimum value of k/h to store
- real, parameter :: matter_power_dlnkh = 0.03 !log spacing in k/h
- real, parameter :: matter_power_maxz = 0.
- integer, parameter :: matter_power_lnzsteps = 4 ! z=0 to get sigma8 (this first entry appears to be coded in some spots in the code!!), plus 3 LRG redshifts.
- #else
- integer, parameter :: num_matter_power = 74 !number of points computed in matter power spectrum
- real, parameter :: matter_power_minkh = 0.999e-4 !1e-4 !minimum value of k/h to store
- real, parameter :: matter_power_dlnkh = 0.143911568 !log spacing in k/h
- real, parameter :: matter_power_maxz = 0. !6.0
- integer, parameter :: matter_power_lnzsteps = 1 !20
- #endif
- !Only used in params_CMB
- real :: pivot_k = 0.05 !Point for defining primordial power spectra
- logical :: inflation_consistency = .false. !fix n_T or not
-
- logical :: bbn_consistency = .true. !JH
-
-
- integer, parameter :: num_cls_tot = num_cls + num_cls_ext
- !Number of scalar-only cls
- !if num_cls=4 and CMB_lensing then increased to 4
- integer :: num_clsS=min(num_cls,3)
-
- integer, parameter :: norm_As=1, norm_amp_ratio=2, norm_freq_ix = 3
-
- Type CMBParams
- real nuisance(1:num_nuisance_params)
- !unit Gaussians for experimental parameters
- real norm(1:num_norm)
- !These are fast parameters controling amplitudes, calibrations, etc.
- real InitPower(1:num_initpower)
- !These are fast paramters for the initial power spectrum
- !Now remaining (non-independent) parameters
- real omb, omc, omv, omnu, omk, omdm
- real ombh2, omch2, omnuh2, omdmh2
- real zre, nufrac
- real h, H0
- real w
- real YHe, nnu
- real reserved(5)
-
- end Type CMBParams
-
- Type CosmoTheory
- real Age, r10
- real SN_loglike, HST_loglike, BAO_loglike, reserved(1)
- real cl(lmax,num_cls_tot), cl_tensor(lmax_tensor,num_cls)
- !TT, TE, EE (BB) + other C_l (e.g. lensing) in that order
- real sigma_8
- real matter_power(num_matter_power,matter_power_lnzsteps)
- !second index is redshifts from 0 to matter_power_maxz
- !if custom_redshift_steps = false with equal spacing in
- !log(1+z) and matter_power_lnzsteps points
- !if custom_redshift_steps = true set in mpk.f90
- ! BR09 additions
- real mpk_nw(num_matter_power,matter_power_lnzsteps) !no wiggles fit to matter power spectrum
- real mpkrat_nw_nl(num_matter_power,matter_power_lnzsteps) !halofit run on mpk_nw
- real finalLRGtheoryPk(num_matter_power) !! this is the quantity that enters the LRG likelihood calculation
- ! end BR09 additions
- end Type CosmoTheory
-
- logical, parameter :: Old_format = .false.
- logical, parameter :: write_all_Cls = .false.
- !if false use CAMB's flat interpolation scheme (lossless if models are flat except near lmax when lensed)
-
- contains
-
-
- subroutine WriteModel(i,CMB, T, like, mult)
- integer i
- real, intent(in), optional :: mult
- Type(CosmoTheory) T
- real like, amult
- Type(CMBParams) CMB
- integer j
-
- if (present(mult)) then
- amult = mult
- else
- amult = 1
- end if
-
- if (Old_format) then
-
- stop 'old not supported'
- else
-
- j = 0 !format ID
- if (write_all_cls) j=1
- write(i) j
-
- write(i) amult, num_matter_power, lmax, lmax_tensor, num_cls
-
- write(i) T%SN_loglike, T%HST_loglike, T%BAO_loglike, T%reserved
-
- write(i) like
- write(i) CMB
-
- write(i) T%Age, T%r10, T%sigma_8, T%matter_power
-
- if (write_all_cls) then
- write(i) T%cl(2:lmax,1:num_cls_tot)
- write(i) T%cl_tensor(2:lmax_tensor,1:num_cls)
- else
-
- !Use interpolation scheme CAMB uses for flat models
- !If using significantly non-flat, or increasing interpolation accuracy, save all th cls instead
- write(i) T%cl(2:20,1:num_cls_tot)
- do j=30,90,10
- write(i) T%cl(j,1:num_cls_tot)
- end do
- do j=110,130, 20
- write(i) T%cl(j,1:num_cls_tot)
- end do
- do j=150,lmax, 50
- write(i) T%cl(j,1:num_cls_tot)
- end do
-
- if (lmax_tensor /= 0) then
- if (lmax_tensor<150) stop 'lmax_tensor too small'
- write(i) T%cl_tensor(2:20,1:num_cls)
- do j=30,90,10
- write(i) T%cl_tensor(j,1:num_cls)
- end do
- do j=110,130,20
- write(i) T%cl_tensor(j,1:num_cls)
- end do
- do j=150,lmax_tensor, 50
- write(i) T%cl_tensor(j,1:num_cls)
- end do
- end if
- end if
-
- end if
-
- if (flush_write) call FlushFile(i)
-
- end subroutine WriteModel
-
-
- subroutine ReadModel(i,CMB, T, mult, like, error)
- integer, intent(in) :: i
- integer, intent(out) :: error
- real, intent(out) :: mult
- Type(CosmoTheory) T
- real like
- Type(CMBParams) CMB
- real icl(lmax,1:num_cls_tot),iclt(lmax,1:num_cls)
- integer allcl,j,ind, ix(lmax)
- integer almax,almaxtensor, anumpowers, anumcls
-
- error = 0
-
- if (old_format) then
-
- stop 'old not supported'
-
- else
-
- read(i,end=100,err=100) allcl
-
- if (allcl/=0 .and. allcl/=1) stop 'wrong file format'
-
- read(i,end=100,err=100) mult,anumpowers,almax, almaxtensor, anumcls
- if (almax > lmax) stop 'reading file with larger lmax'
- if (anumcls /= num_cls) stop 'reading file with different Cls'
-
- read(i) T%SN_loglike, T%HST_loglike,T%BAO_loglike,T%reserved
-
- read(i,end = 100, err=100) like
- read(i) CMB
-
-
- read(i) T%Age, T%r10, T%sigma_8, T%matter_power(1:anumpowers,1:matter_power_lnzsteps)
- T%cl = 0
- T%cl_tensor = 0
-
- if(allcl==1) then
- read(i) T%cl(2:almax,1:num_cls_tot)
- read(i) T%cl_tensor(2:almaxtensor,1:num_cls)
- else
-
- read(i) icl(1:19,1:num_cls_tot)
- ind =1
- do j =2,20
- ix(ind)=j
- ind=ind+1
- end do
- do j=30,90,10
- read(i) icl(ind,1:num_cls_tot)
- ix(ind) = j
- ind = ind + 1
- end do
- do j=110,130,20
- read(i) icl(ind,1:num_cls_tot)
- ix(ind) = j
- ind = ind + 1
- end do
- do j=150,almax, 50
- read(i) icl(ind,1:num_cls_tot)
- ix(ind) = j
- ind = ind+1
- end do
- ind = ind-1
-
- call InterpCls(ix,icl, T%cl, ind, almax, num_Cls_tot)
-
- if (almaxtensor /= 0) then
- read(i) iclt(1:19,1:num_cls)
- ind =1
- do j =2,20
- ix(ind)=j
- ind=ind+1
- end do
- do j=30,90,10
- read(i) iclt(ind,1:num_cls)
- ix(ind) = j
- ind = ind + 1
- end do
- do j=110,130,20
- read(i) iclt(ind,1:num_cls)
- ix(ind) = j
- ind = ind + 1
- end do
- do j=150,almaxtensor, 50
- read(i) iclt(ind,1:num_cls)
- ix(ind) = j
- ind = ind+1
- end do
- ind = ind-1
- call InterpCls(ix,iclt, T%cl_tensor, ind, almaxtensor,num_cls)
- end if
-
- end if
-
- return
- 100 error = 1
-
- end if
-
- end subroutine ReadModel
-
- subroutine InterpCls(l,iCl, all_Cl, n, almax, ncls)
- integer, intent(in) :: n, almax,ncls
-
- real, intent(in) :: iCl(lmax,1:ncls)
- integer l(n),p
- real all_Cl(:,:)
-
- integer il,llo,lhi,xi
- real xl(n), ddCl(n)
-
- real a0,b0,ho
- real inCl(n)
-
-
- do p =1, ncls
-
- do il=1,n
- inCl(il) = iCl(il,p)*l(il)**2
- end do
-
- xl = l
- call spline_real(xl,inCl,n,ddCl)
-
- llo=1
- do il=2,l(n)
- xi=il
- if ((xi > l(llo+1)).and.(llo < n)) then
- llo=llo+1
- end if
- lhi=llo+1
- ho=l(lhi)-l(llo)
- a0=(xl(lhi)-xi)/ho
- b0=(xi-xl(llo))/ho
-
- all_Cl(il,p) = (a0*inCl(llo)+ b0*inCl(lhi)+((a0**3-a0)* ddCl(llo) &
- +(b0**3-b0)*ddCl(lhi))*ho**2/6)/il**2
-
- end do
-
- end do
-
- all_Cl(l(n)+1:almax,:) = 0
-
-
- end subroutine InterpCls
-
-
- subroutine ClsFromTheoryData(T, CMB, Cls)
- Type(CosmoTheory) T
- Type(CMBParams) CMB
- real Cls(lmax,num_cls_tot)
- integer i
-
- Cls(2:lmax,1:num_clsS) =T%cl(2:lmax,1:num_clsS) !CMB%norm(norm_As)*T%cl(2:lmax,1:num_clsS)
- if (num_cls>3 .and. num_ClsS==3) Cls(2:lmax,num_cls)=0
- if (num_cls_ext>0) then
- Cls(2:lmax,num_cls+1:num_cls_tot) =T%cl(2:lmax,num_clsS+1:num_clsS+num_cls_ext)
- end if
-
- i = norm_amp_ratio !this convolution is to avoid compile-time bounds-check errors on CMB%norm
- if (CMB%norm(i) /= 0) then
- Cls(2:lmax_tensor,1:num_cls) = Cls(2:lmax_tensor,1:num_cls)+ T%cl_tensor(2:lmax_tensor,1:num_cls)
- !CMB%norm(norm_As)*CMB%norm(norm_amp_ratio)*T%cl_tensor(2:lmax_tensor,:)
- end if
-
- end subroutine ClsFromTheoryData
-
- subroutine WriteTextCls(aname,T, CMB)
- Type(CosmoTheory) T
- Type(CMBParams) CMB
- character (LEN=*), intent(in) :: aname
- integer l
- real Cls(lmax,num_cls_tot)
-
- call ClsFromTheoryData(T,CMB,Cls)
- open(unit = tmp_file_unit, file = aname, form='formatted', status = 'replace')
- do l=2, lmax
- write (tmp_file_unit,*) l, Cls(l,1:num_cls)*l*(l+1)/(2*pi), Cls(l,num_cls+1:num_cls_tot)
- end do
- close(tmp_file_unit)
-
- end subroutine WriteTextCls
-
- function MatterPowerAt(T,kh)
- !get matter power spectrum today at kh = k/h by interpolation from stored values
- real, intent(in) :: kh
- Type(CosmoTheory) T
- real MatterPowerAt
- real x, d
- integer i
-
- x = log(kh/matter_power_minkh) / matter_power_dlnkh
- if (x < 0 .or. x >= num_matter_power-1) then
- write (*,*) ' k/h out of bounds in MatterPowerAt (',kh,')'
- stop
- end if
- i = int(x)
- d = x - i
- MatterPowerAt = exp(log(T%matter_power(i+1,1))*(1-d) &
- + log(T%matter_power(i+2,1))*d)
- !Just do linear interpolation in logs for now..
- !(since we already cublic-spline interpolated to get the stored values)
- !Assume matter_power_lnzsteps is at redshift zero
- end function
-
-
-
- !BR09 this function is just a copy of the one above but with LRG theory put in instead of linear theory
- function LRGPowerAt(T,kh)
- !get LRG matter power spectrum today at kh = k/h by interpolation from stored values
- real, intent(in) :: kh
- Type(CosmoTheory) T
- real LRGPowerAt
- real x, d
- integer i
-
- x = log(kh/matter_power_minkh) / matter_power_dlnkh
- if (x < 0 .or. x >= num_matter_power-1) then
- write (*,*) ' k/h out of bounds in MatterPowerAt (',kh,')'
- stop
- end if
- i = int(x)
- d = x - i
- LRGPowerAt = exp(log(T%finalLRGtheoryPk(i+1))*(1-d) + log(T%finalLRGtheoryPk(i+2))*d)
- !Just do linear interpolation in logs for now..
- !(since we already cublic-spline interpolated to get the stored values)
- end function
- !!BRO09 addition end
-
- function MatterPowerAt_Z(T,kh,z)
- !get matter power spectrum at z at kh = k/h by interpolation from stored values
-
- real, intent(in) :: kh
- Type(CosmoTheory) T
- real MatterPowerAt_Z
- real x, d, z, y, dz, mup, mdn
- real matter_power_dlnz
- integer i, iz
-
- matter_power_dlnz = log(matter_power_maxz+1) / (matter_power_lnzsteps -1 + 1e-13)
- y = log(1.+ z) / matter_power_dlnz
-
- if (z > matter_power_maxz ) then
- write (*,*) ' z out of bounds in MatterPowerAt_Z (',z,')'
- stop
- end if
- x = log(kh/matter_power_minkh) / matter_power_dlnkh
- if (x < 0 .or. x >= num_matter_power-1) then
- write (*,*) ' k/h out of bounds in MatterPowerAt_Z (',kh,')'
- stop
- end if
-
- iz = int(y*0.99999999)
- dz = y - iz
-
- i = int(x)
- d = x - i
-
- mup = log(T%matter_power(i+1,iz+2))*(1-d) + log(T%matter_power(i+2,iz+2))*d
- mdn = log(T%matter_power(i+1,iz+1))*(1-d) + log(T%matter_power(i+2,iz+1))*d
-
- MatterPowerAt_Z = exp(mdn*(1-dz) + mup*dz)
-
- end function MatterPowerAt_Z
-
-
-
-
- end module cmbtypes
--- 0 ----
diff -r -c -b -B -N cosmomc/source/conjgrad_wrapper.f90 cosmomc_sampler/source/conjgrad_wrapper.f90
*** cosmomc/source/conjgrad_wrapper.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/conjgrad_wrapper.f90 2010-05-27 16:16:03.804892605 +0200
***************
*** 4,9 ****
--- 4,10 ----
use ParamDef
use CalcLike
use Random
+ use wrapper
implicit none
private
real ftol, Bestfit_loglike
diff -r -c -b -B -N cosmomc/source/cosmomc.dsp cosmomc_sampler/source/cosmomc.dsp
*** cosmomc/source/cosmomc.dsp 2008-02-26 21:47:26.000000000 +0100
--- cosmomc_sampler/source/cosmomc.dsp 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,440 ****
- # Microsoft Developer Studio Project File - Name="cosmomc" - Package Owner=<4>
- # Microsoft Developer Studio Generated Build File, Format Version 6.00
- # ** DO NOT EDIT **
-
- # TARGTYPE "Win32 (x86) Console Application" 0x0103
-
- CFG=cosmomc - Win32 Debug
- !MESSAGE This is not a valid makefile. To build this project using NMAKE,
- !MESSAGE use the Export Makefile command and run
- !MESSAGE
- !MESSAGE NMAKE /f "cosmomc.mak".
- !MESSAGE
- !MESSAGE You can specify a configuration when running NMAKE
- !MESSAGE by defining the macro CFG on the command line. For example:
- !MESSAGE
- !MESSAGE NMAKE /f "cosmomc.mak" CFG="cosmomc - Win32 Debug"
- !MESSAGE
- !MESSAGE Possible choices for configuration are:
- !MESSAGE
- !MESSAGE "cosmomc - Win32 Release" (based on "Win32 (x86) Console Application")
- !MESSAGE "cosmomc - Win32 Debug" (based on "Win32 (x86) Console Application")
- !MESSAGE
-
- # Begin Project
- # PROP AllowPerConfigDependencies 0
- # PROP Scc_ProjName ""
- # PROP Scc_LocalPath ""
- CPP=cl.exe
- F90=df.exe
- RSC=rc.exe
-
- !IF "$(CFG)" == "cosmomc - Win32 Release"
-
- # PROP BASE Use_MFC 0
- # PROP BASE Use_Debug_Libraries 0
- # PROP BASE Output_Dir "Release"
- # PROP BASE Intermediate_Dir "Release"
- # PROP BASE Target_Dir ""
- # PROP Use_MFC 0
- # PROP Use_Debug_Libraries 0
- # PROP Output_Dir "Release"
- # PROP Intermediate_Dir "Release"
- # PROP Target_Dir ""
- # ADD BASE F90 /compile_only /nologo /warn:nofileopt
- # ADD F90 /compile_only /nologo /warn:nofileopt
- # ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
- # ADD CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
- # ADD BASE RSC /l 0x809 /d "NDEBUG"
- # ADD RSC /l 0x809 /d "NDEBUG"
- BSC32=bscmake.exe
- # ADD BASE BSC32 /nologo
- # ADD BSC32 /nologo
- LINK32=link.exe
- # ADD BASE LINK32 kernel32.lib /nologo /subsystem:console /machine:I386
- # ADD LINK32 kernel32.lib /nologo /subsystem:console /machine:I386
-
- !ELSEIF "$(CFG)" == "cosmomc - Win32 Debug"
-
- # PROP BASE Use_MFC 0
- # PROP BASE Use_Debug_Libraries 1
- # PROP BASE Output_Dir "Debug"
- # PROP BASE Intermediate_Dir "Debug"
- # PROP BASE Target_Dir ""
- # PROP Use_MFC 0
- # PROP Use_Debug_Libraries 1
- # PROP Output_Dir "Debug"
- # PROP Intermediate_Dir "Debug"
- # PROP Ignore_Export_Lib 0
- # PROP Target_Dir ""
- # ADD BASE F90 /check:bounds /compile_only /dbglibs /debug:full /nologo /traceback /warn:argument_checking /warn:nofileopt
- # ADD F90 /check:bounds /compile_only /dbglibs /debug:full /define:"NOWMAP" /define:"MATRIX_SINGLE" /define:"DECONLY" /fpp /nologo /traceback /warn:argument_checking /warn:nofileopt
- # ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
- # ADD CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
- # ADD BASE RSC /l 0x809 /d "_DEBUG"
- # ADD RSC /l 0x809 /d "_DEBUG"
- BSC32=bscmake.exe
- # ADD BASE BSC32 /nologo
- # ADD BSC32 /nologo
- LINK32=link.exe
- # ADD BASE LINK32 kernel32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
- # ADD LINK32 kernel32.lib /nologo /subsystem:console /incremental:no /debug /machine:I386 /out:"../cosmomc.exe" /pdbtype:sept
-
- !ENDIF
-
- # Begin Target
-
- # Name "cosmomc - Win32 Release"
- # Name "cosmomc - Win32 Debug"
- # Begin Group "Source Files"
-
- # PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;f90;for;f;fpp"
- # Begin Group "CAMB"
-
- # PROP Default_Filter ""
- # Begin Source File
-
- SOURCE=..\camb\bessels.f90
- DEP_F90_BESSE=\
- ".\Debug\lvalues.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\Precision.mod"\
- ".\Debug\Ranges.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\camb.f90
- DEP_F90_CAMB_=\
- ".\Debug\CAMBmain.mod"\
- ".\Debug\GaugeInterface.mod"\
- ".\Debug\InitialPower.mod"\
- ".\Debug\lensing.mod"\
- ".\Debug\ModelData.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\Precision.mod"\
- ".\Debug\SpherBessels.mod"\
- ".\Debug\ThermoData.mod"\
- ".\Debug\Transfer.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\cmbmain.f90
- DEP_F90_CMBMA=\
- ".\Debug\GaugeInterface.mod"\
- ".\Debug\InitialPower.mod"\
- ".\Debug\lvalues.mod"\
- ".\Debug\MassiveNu.mod"\
- ".\Debug\ModelData.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\NonLinear.mod"\
- ".\Debug\Precision.mod"\
- ".\Debug\SpherBessels.mod"\
- ".\Debug\ThermoData.mod"\
- ".\Debug\Transfer.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\equations.f90
- DEP_F90_EQUAT=\
- ".\Debug\lvalues.mod"\
- ".\Debug\MassiveNu.mod"\
- ".\Debug\ModelData.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\Precision.mod"\
- ".\Debug\ThermoData.mod"\
- ".\Debug\Transfer.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\halofit.f90
- DEP_F90_HALOF=\
- ".\Debug\ModelParams.mod"\
- ".\Debug\Transfer.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\inifile.f90
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\lensing.f90
- DEP_F90_LENSI=\
- ".\Debug\InitialPower.mod"\
- ".\Debug\lvalues.mod"\
- ".\Debug\ModelData.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\Precision.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\modules.f90
- DEP_F90_MODUL=\
- ".\Debug\AMLutils.mod"\
- ".\Debug\IniFile.mod"\
- ".\Debug\InitialPower.mod"\
- ".\Debug\Precision.mod"\
- ".\Debug\Ranges.mod"\
- ".\Debug\RECFAST.MOD"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\power_tilt.f90
- DEP_F90_POWER=\
- ".\Debug\Precision.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\recfast.f90
- DEP_F90_RECFA=\
- ".\Debug\Precision.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\subroutines.f90
- DEP_F90_SUBRO=\
- ".\Debug\AMLutils.mod"\
-
- # End Source File
- # End Group
- # Begin Source File
-
- SOURCE=.\calclike.f90
- DEP_F90_CALCL=\
- ".\Debug\CMB_Cls.mod"\
- ".\Debug\cmbdata.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\lya.mod"\
- ".\Debug\mpk.mod"\
- ".\Debug\ParamDef.mod"\
- ".\Debug\Random.mod"\
- ".\Debug\settings.mod"\
- ".\Debug\snovae.mod"\
- ".\Debug\WeakLen.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\CMB_Cls_simple.f90
- DEP_F90_CMB_C=\
- ".\Debug\CAMB.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\LambdaGeneral.mod"\
- ".\Debug\lensing.mod"\
- ".\Debug\lya.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\settings.mod"\
- ".\Debug\snovae.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\cmbdata.f90
- DEP_F90_CMBDA=\
- ".\Debug\CMBLikes.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\MatrixUtils.mod"\
- ".\Debug\settings.mod"\
-
- NODEP_F90_CMBDA=\
- ".\Debug\WMAP_OPTIONS.mod"\
- ".\Debug\WMAP_PASS2.mod"\
- ".\Debug\WMAP_UTIL.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\cmbtypes.f90
- DEP_F90_CMBTY=\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\conjgrad_wrapper.f90
- DEP_F90_CONJG=\
- ".\Debug\CalcLike.mod"\
- ".\Debug\ParamDef.mod"\
- ".\Debug\Random.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\driver.F90
- DEP_F90_DRIVE=\
- ".\Debug\CalcLike.mod"\
- ".\Debug\cmbdata.mod"\
- ".\Debug\ConjGradModule.mod"\
- ".\Debug\EstCovmatModule.mod"\
- ".\Debug\IniFile.mod"\
- ".\Debug\MatrixUtils.mod"\
- ".\Debug\MonteCarlo.mod"\
- ".\Debug\mpk.mod"\
- ".\Debug\ParamDef.mod"\
- ".\Debug\posthoc.mod"\
- ".\Debug\settings.mod"\
- ".\Debug\WeakLen.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\EstCovmat.f90
- DEP_F90_ESTCO=\
- ".\Debug\CalcLike.mod"\
- ".\Debug\MatrixUtils.mod"\
- ".\Debug\ParamDef.mod"\
- ".\Debug\Random.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\lya.f90
- DEP_F90_LYA_F=\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\Matrix_utils.F90
- DEP_F90_MATRI=\
- ".\Debug\AMLutils.mod"\
-
- NODEP_F90_MATRI=\
- ".\Debug\IFPORT.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\MCMC.f90
- DEP_F90_MCMC_=\
- ".\Debug\CalcLike.mod"\
- ".\Debug\ParamDef.mod"\
- ".\Debug\propose.mod"\
- ".\Debug\Random.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\mpk.f90
- DEP_F90_MPK_F=\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\MatrixUtils.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\paramdef.F90
- DEP_F90_PARAM=\
- ".\Debug\CMB_Cls.mod"\
- ".\Debug\cmbdata.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\IniFile.mod"\
- ".\Debug\MatrixUtils.mod"\
- ".\Debug\Random.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\params_CMB.f90
- DEP_F90_PARAMS=\
- ".\Debug\CAMB.mod"\
- ".\Debug\CMB_Cls.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\ModelParams.mod"\
- ".\Debug\ParamDef.mod"\
- ".\Debug\Precision.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\Planck_like.f90
- DEP_F90_PLANC=\
- ".\Debug\AMLutils.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\IniFile.mod"\
- ".\Debug\MatrixUtils.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\postprocess.f90
- DEP_F90_POSTP=\
- ".\Debug\CalcLike.mod"\
- ".\Debug\CMB_Cls.mod"\
- ".\Debug\cmbdata.mod"\
- ".\Debug\cmbtypes.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\propose.f90
- DEP_F90_PROPO=\
- ".\Debug\ParamDef.mod"\
- ".\Debug\Random.mod"\
- ".\Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\settings.f90
- DEP_F90_SETTI=\
- ".\Debug\AMLutils.mod"\
- ".\Debug\IniFile.mod"\
- ".\Debug\Random.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\supernovae.f90
- DEP_F90_SUPER=\
- ".\Debug\CAMB.mod"\
- ".\Debug\cmbtypes.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\utils.F90
- DEP_F90_UTILS=\
- {$(INCLUDE)}"cxml_dll_use.mod"\
- {$(INCLUDE)}"CXML_INCLUDE.F90"\
- {$(INCLUDE)}"cxml_static_use.mod"\
-
- NODEP_F90_UTILS=\
- ".\Debug\F90_UNIX.mod"\
- ".\Debug\IFPORT.mod"\
- ".\Debug\mpif.h"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\WeakLen.f90
- DEP_F90_WEAKL=\
- ".\Debug\cmbtypes.mod"\
-
- # End Source File
- # End Group
- # Begin Group "Header Files"
-
- # PROP Default_Filter "h;hpp;hxx;hm;inl;fi;fd"
- # End Group
- # Begin Group "Resource Files"
-
- # PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"
- # End Group
- # End Target
- # End Project
--- 0 ----
diff -r -c -b -B -N cosmomc/source/cosmomc.dsw cosmomc_sampler/source/cosmomc.dsw
*** cosmomc/source/cosmomc.dsw 2004-08-07 06:35:16.000000000 +0200
--- cosmomc_sampler/source/cosmomc.dsw 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,41 ****
- Microsoft Developer Studio Workspace File, Format Version 6.00
- # WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
-
- ###############################################################################
-
- Project: "GetDist"=.\GetDist.dsp - Package Owner=<4>
-
- Package=<5>
- {{{
- }}}
-
- Package=<4>
- {{{
- }}}
-
- ###############################################################################
-
- Project: "cosmomc"=.\cosmomc.dsp - Package Owner=<4>
-
- Package=<5>
- {{{
- }}}
-
- Package=<4>
- {{{
- }}}
-
- ###############################################################################
-
- Global:
-
- Package=<5>
- {{{
- }}}
-
- Package=<3>
- {{{
- }}}
-
- ###############################################################################
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/cosmomc.sln cosmomc_sampler/source/cosmomc.sln
*** cosmomc/source/cosmomc.sln 2009-09-17 18:33:21.000000000 +0200
--- cosmomc_sampler/source/cosmomc.sln 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,25 ****
- Microsoft Visual Studio Solution File, Format Version 10.00
- # Visual Studio 2008
- Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "cosmomc", "cosmomc.vfproj", "{5818CEFF-E933-41ED-A2A1-7A6D8F22AFB6}"
- EndProject
- Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "GetDist", "GetDist.vfproj", "{573A6A6A-BD92-4FF0-BD64-E101E2496178}"
- EndProject
- Global
- GlobalSection(SolutionConfigurationPlatforms) = preSolution
- Debug|Win32 = Debug|Win32
- Release|Win32 = Release|Win32
- EndGlobalSection
- GlobalSection(ProjectConfigurationPlatforms) = postSolution
- {5818CEFF-E933-41ED-A2A1-7A6D8F22AFB6}.Debug|Win32.ActiveCfg = Debug|Win32
- {5818CEFF-E933-41ED-A2A1-7A6D8F22AFB6}.Debug|Win32.Build.0 = Debug|Win32
- {5818CEFF-E933-41ED-A2A1-7A6D8F22AFB6}.Release|Win32.ActiveCfg = Release|Win32
- {5818CEFF-E933-41ED-A2A1-7A6D8F22AFB6}.Release|Win32.Build.0 = Release|Win32
- {573A6A6A-BD92-4FF0-BD64-E101E2496178}.Debug|Win32.ActiveCfg = Debug|Win32
- {573A6A6A-BD92-4FF0-BD64-E101E2496178}.Debug|Win32.Build.0 = Debug|Win32
- {573A6A6A-BD92-4FF0-BD64-E101E2496178}.Release|Win32.ActiveCfg = Release|Win32
- {573A6A6A-BD92-4FF0-BD64-E101E2496178}.Release|Win32.Build.0 = Release|Win32
- EndGlobalSection
- GlobalSection(SolutionProperties) = preSolution
- HideSolutionNode = FALSE
- EndGlobalSection
- EndGlobal
--- 0 ----
diff -r -c -b -B -N cosmomc/source/cosmomc.vfproj cosmomc_sampler/source/cosmomc.vfproj
*** cosmomc/source/cosmomc.vfproj 2010-05-04 10:28:17.000000000 +0200
--- cosmomc_sampler/source/cosmomc.vfproj 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,70 ****
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/driver.F90 cosmomc_sampler/source/driver.F90
*** cosmomc/source/driver.F90 2010-05-20 12:13:02.000000000 +0200
--- cosmomc_sampler/source/driver.F90 2010-05-27 16:15:03.833643289 +0200
***************
*** 7,25 ****
use MonteCarlo
use ParamDef
use settings
- use cmbdata
use posthoc
- use WeakLen
use CalcLike
use EstCovmatModule
use ConjGradModule
- use mpk
use MatrixUtils
use IO
use ParamNames
! #ifdef WMAP_PARAMS
! use WMAP_OPTIONS
! #endif
implicit none
character(LEN=Ini_max_string_len) InputFile, LogFile
--- 7,20 ----
use MonteCarlo
use ParamDef
use settings
use posthoc
use CalcLike
use EstCovmatModule
use ConjGradModule
use MatrixUtils
use IO
use ParamNames
!
implicit none
character(LEN=Ini_max_string_len) InputFile, LogFile
***************
*** 27,34 ****
logical bad, est_bfp_before_covmat
integer numsets, nummpksets, i, numtoget, action
character(LEN=Ini_max_string_len) baseroot, filename(100), &
! mpk_filename(100), SZTemplate(100), numstr, fname
! real SZscale(100)
Type(ParamSet) Params, EstParams
integer num_points
integer status
--- 22,29 ----
logical bad, est_bfp_before_covmat
integer numsets, nummpksets, i, numtoget, action
character(LEN=Ini_max_string_len) baseroot, filename(100), &
! numstr, fname
!
Type(ParamSet) Params, EstParams
integer num_points
integer status
***************
*** 88,99 ****
checkpoint = Ini_Read_Logical('checkpoint',.false.)
if (checkpoint) flush_write = .true.
! #ifdef WMAP_PARAMS
! use_TT_beam_ptsrc = Ini_read_Logical('use_TT_beam_ptsrc')
! use_TE = Ini_read_Logical('use_TE')
! use_TT = Ini_Read_Logical('use_TT')
! print *, 'WMAP beam TE TT', use_TT_beam_ptsrc, use_TE, use_TT
! #endif
#ifdef MPI
--- 83,89 ----
checkpoint = Ini_Read_Logical('checkpoint',.false.)
if (checkpoint) flush_write = .true.
!
#ifdef MPI
***************
*** 185,226 ****
call InitRandom()
end if
- use_nonlinear = Ini_Read_Logical('nonlinear_pk',.false.)
- pivot_k = Ini_Read_Real('pivot_k',0.05)
- inflation_consistency = Ini_read_Logical('inflation_consistency',.false.)
- bbn_consistency = Ini_Read_Logical('bbn_consistency',.true.)
- w_is_w = Ini_Read_Logical ('w_is_w',.true.)
oversample_fast = Ini_Read_Int('oversample_fast',1)
use_fast_slow = Ini_read_Logical('use_fast_slow',.true.)
if (Ini_Read_Logical('cmb_hyperparameters', .false.)) &
call DoStop( 'Hyperparameters not supported any more')
- if (Ini_Read_String('use_2dF') /= '') stop 'use_2dF now replaced with use_mpk'
- Use_Clusters = Ini_Read_Logical('use_clusters',.false.)
- Use_mpk = Ini_Read_Logical('use_mpk',.false.) ! matter power spectrum, incl 2dF
- Use_HST = Ini_Read_Logical('use_HST',.true.)
- Use_BBN = Ini_Read_Logical('use_BBN',.false.)
- Use_Age_Tophat_Prior= Ini_Read_Logical('use_Age_Tophat_Prior',.true.)
- Use_SN = Ini_Read_Logical('use_SN',.false.)
- if (Use_SN) SN_filename = Ini_Read_String('SN_filename')
- Use_BAO = Ini_Read_Logical('use_BAO',.false.)
- Use_CMB = Ini_Read_Logical('use_CMB',.true.)
- Use_WeakLen = Ini_Read_Logical('use_WeakLen',.false.)
- Use_min_zre = Ini_Read_Double('use_min_zre',0.d0)
- Use_Lya = Ini_Read_logical('use_lya',.false.)
-
- if (Ini_HasKey('data_dir')) DataDir=Ini_Read_String('data_dir')
- if (Ini_HasKey('local_dir')) LocalDir=Ini_Read_String('local_dir')
-
- if (Use_Lya .and. use_nonlinear) &
- call DoStop('Lya.f90 assumes LINEAR power spectrum input')
-
- !flag to force getting sigma8 even if not using LSS data
- use_LSS = Ini_Read_Logical('get_sigma8',.false.)
- ! use_LSS = Use_2dF .or. Use_Clusters .or. Use_WeakLen
- use_LSS = Use_LSS .or. Use_mpk .or. Use_Clusters .or. Use_WeakLen .or. Use_Lya
Temperature = Ini_Read_Real('temperature',1.)
--- 175,187 ----
***************
*** 239,276 ****
Ini_fail_on_not_found = .true.
! numsets = Ini_Read_Int('cmb_numdatasets')
num_points = 0
nuisance_params_used = 0
- if (Use_CMB) then
- do i= 1, numsets
- filename(i) = Ini_Read_String(numcat('cmb_dataset',i))
- call ReadDataset(filename(i))
- num_points = num_points + datasets(i)%num_points
- SZTemplate(i) = Ini_Read_String(numcat('cmb_dataset_SZ',i), .false.)
- if (SZTemplate(i)/='') then
- SZScale(i) = Ini_read_Real(numcat('cmb_dataset_SZ_scale',i),1.0)
- call ReadSZTemplate(datasets(i), SZTemplate(i),SZScale(i))
- end if
- nuisance_params_used = nuisance_params_used + datasets(i)%nuisance_parameters
- end do
- if (Feedback > 1) write (*,*) 'read datasets'
- end if
Ini_fail_on_not_found = .true.
- nummpksets = Ini_Read_Int('mpk_numdatasets',0)
- if (Use_mpk) then
- do i= 1, nummpksets
- mpk_filename(i) = ReadIniFileName(DefIni,numcat('mpk_dataset',i))
- call ReadMpkDataset(mpk_filename(i))
- end do
- if (Feedback>1) write(*,*) 'read mpk datasets'
- end if
-
- if(Use_BAO .and. use_dr7lrg) &
- call MpiStop('DR7 LRG and BAO are based on the same dataset. You cannot use both.')
-
numtoget = Ini_Read_Int('samples')
call Initialize(DefIni,Params)
--- 200,211 ----
Ini_fail_on_not_found = .true.
!
num_points = 0
nuisance_params_used = 0
Ini_fail_on_not_found = .true.
numtoget = Ini_Read_Int('samples')
call Initialize(DefIni,Params)
diff -r -c -b -B -N cosmomc/source/EstCovmat.f90 cosmomc_sampler/source/EstCovmat.f90
*** cosmomc/source/EstCovmat.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/EstCovmat.f90 2010-05-27 16:15:42.364892866 +0200
***************
*** 12,17 ****
--- 12,18 ----
use CalcLike
use settings
use Matrixutils
+ use wrapper
implicit none
real, dimension(:,:,:,:), allocatable :: Lgrid
diff -r -c -b -B -N cosmomc/source/getdist.dsp cosmomc_sampler/source/getdist.dsp
*** cosmomc/source/getdist.dsp 2008-02-26 21:47:26.000000000 +0100
--- cosmomc_sampler/source/getdist.dsp 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,140 ****
- # Microsoft Developer Studio Project File - Name="GetDist" - Package Owner=<4>
- # Microsoft Developer Studio Generated Build File, Format Version 6.00
- # ** DO NOT EDIT **
-
- # TARGTYPE "Win32 (x86) Console Application" 0x0103
-
- CFG=GetDist - Win32 Debug
- !MESSAGE This is not a valid makefile. To build this project using NMAKE,
- !MESSAGE use the Export Makefile command and run
- !MESSAGE
- !MESSAGE NMAKE /f "GetDist.mak".
- !MESSAGE
- !MESSAGE You can specify a configuration when running NMAKE
- !MESSAGE by defining the macro CFG on the command line. For example:
- !MESSAGE
- !MESSAGE NMAKE /f "GetDist.mak" CFG="GetDist - Win32 Debug"
- !MESSAGE
- !MESSAGE Possible choices for configuration are:
- !MESSAGE
- !MESSAGE "GetDist - Win32 Release" (based on "Win32 (x86) Console Application")
- !MESSAGE "GetDist - Win32 Debug" (based on "Win32 (x86) Console Application")
- !MESSAGE
-
- # Begin Project
- # PROP AllowPerConfigDependencies 0
- # PROP Scc_ProjName ""
- # PROP Scc_LocalPath ""
- CPP=cl.exe
- F90=df.exe
- RSC=rc.exe
-
- !IF "$(CFG)" == "GetDist - Win32 Release"
-
- # PROP BASE Use_MFC 0
- # PROP BASE Use_Debug_Libraries 0
- # PROP BASE Output_Dir "Release"
- # PROP BASE Intermediate_Dir "Release"
- # PROP BASE Target_Dir ""
- # PROP Use_MFC 0
- # PROP Use_Debug_Libraries 0
- # PROP Output_Dir "Release"
- # PROP Intermediate_Dir "Release"
- # PROP Target_Dir ""
- # ADD BASE F90 /compile_only /nologo /warn:nofileopt
- # ADD F90 /compile_only /nologo /warn:nofileopt
- # ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
- # ADD CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
- # ADD BASE RSC /l 0x809 /d "NDEBUG"
- # ADD RSC /l 0x809 /d "NDEBUG"
- BSC32=bscmake.exe
- # ADD BASE BSC32 /nologo
- # ADD BSC32 /nologo
- LINK32=link.exe
- # ADD BASE LINK32 kernel32.lib /nologo /subsystem:console /machine:I386
- # ADD LINK32 kernel32.lib /nologo /subsystem:console /machine:I386
-
- !ELSEIF "$(CFG)" == "GetDist - Win32 Debug"
-
- # PROP BASE Use_MFC 0
- # PROP BASE Use_Debug_Libraries 1
- # PROP BASE Output_Dir "GetDist_Debug"
- # PROP BASE Intermediate_Dir "GetDist_Debug"
- # PROP BASE Target_Dir ""
- # PROP Use_MFC 0
- # PROP Use_Debug_Libraries 1
- # PROP Output_Dir "GetDist_Debug"
- # PROP Intermediate_Dir "GetDist_Debug"
- # PROP Ignore_Export_Lib 0
- # PROP Target_Dir ""
- # ADD BASE F90 /check:bounds /compile_only /dbglibs /debug:full /nologo /traceback /warn:argument_checking /warn:nofileopt
- # ADD F90 /check:bounds /compile_only /dbglibs /debug:full /define:"MATRIX_SINGLE" /define:"NOWMAP" /define:"DECONLY" /fpp /nologo /traceback /warn:argument_checking /warn:nofileopt
- # ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
- # ADD CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
- # ADD BASE RSC /l 0x809 /d "_DEBUG"
- # ADD RSC /l 0x809 /d "_DEBUG"
- BSC32=bscmake.exe
- # ADD BASE BSC32 /nologo
- # ADD BSC32 /nologo
- LINK32=link.exe
- # ADD BASE LINK32 kernel32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
- # ADD LINK32 kernel32.lib /nologo /subsystem:console /incremental:no /debug /machine:I386 /out:"../GetDist.exe" /pdbtype:sept
- # SUBTRACT LINK32 /pdb:none
-
- !ENDIF
-
- # Begin Target
-
- # Name "GetDist - Win32 Release"
- # Name "GetDist - Win32 Debug"
- # Begin Group "Source Files"
-
- # PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;f90;for;f;fpp"
- # Begin Source File
-
- SOURCE=.\GetDist.f90
- NODEP_F90_GETDI=\
- ".\GetDist_Debug\IniFile.mod"\
- ".\GetDist_Debug\Random.mod"\
- ".\GetDist_Debug\settings.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=..\camb\inifile.f90
- # End Source File
- # Begin Source File
-
- SOURCE=.\Matrix_utils.F90
- # End Source File
- # Begin Source File
-
- SOURCE=.\settings.f90
- DEP_F90_SETTI=\
- ".\GetDist_Debug\AMLutils.mod"\
- ".\GetDist_Debug\IniFile.mod"\
- ".\GetDist_Debug\Random.mod"\
-
- # End Source File
- # Begin Source File
-
- SOURCE=.\utils.F90
- NODEP_F90_UTILS=\
- ".\GetDist_Debug\F90_UNIX.mod"\
- ".\GetDist_Debug\mpif.h"\
- ".\xml_dll_use.mod"\
- ".\XML_INCLUDE.F90"\
- ".\xml_static_use.mod"\
-
- # End Source File
- # End Group
- # Begin Group "Header Files"
-
- # PROP Default_Filter "h;hpp;hxx;hm;inl;fi;fd"
- # End Group
- # Begin Group "Resource Files"
-
- # PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"
- # End Group
- # End Target
- # End Project
--- 0 ----
diff -r -c -b -B -N cosmomc/source/GetDist.vfproj cosmomc_sampler/source/GetDist.vfproj
*** cosmomc/source/GetDist.vfproj 2009-11-10 19:54:41.000000000 +0100
--- cosmomc_sampler/source/GetDist.vfproj 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,36 ****
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/HST.f90 cosmomc_sampler/source/HST.f90
*** cosmomc/source/HST.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/HST.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,27 ****
- !HST from http://arxiv.org/abs/0905.0695
- !Thanks to Beth Reid, minor mods by AL, Oct 09
- module HST
- use cmbtypes
- use CAMB, only : AngularDiameterDistance !!physical angular diam distance also in Mpc no h units
- use constants
- implicit none
-
- ! angdistinveffh0 is the inverse of the angular diameter distance at z = 0.04 for H_0 = 74.2
- ! and a fiducial cosmology (omega_k = 0, omega_lambda = 0.7, w = -1); this is proportional to
- !H_0 but includes the tiny cosmological dependence of the measurement (primarily on w) correctly.
- ! angdistinveffh0err = 3.6 / DL(0.04)
- real(dl), parameter :: angdistinvzeffh0 = 6.49405e-3, zeffh0 = 0.04, &
- angdistinvzeffh0errsqr = 9.93e-8
-
- contains
-
- real(dl) function HST_LnLike(CMB)
- type(CMBParams) CMB
- real(dl) :: theoryval
-
- theoryval = 1.0/AngularDiameterDistance(zeffh0)
- HST_LnLike = (theoryval - angdistinvzeffh0)**2/(2*angdistinvzeffh0errsqr)
- if (Feedback > 1) print *,'HST_LnLike like: ',HST_LnLike
- end function HST_LnLike
-
- end module HST
--- 0 ----
diff -r -c -b -B -N cosmomc/source/inifile.f90 cosmomc_sampler/source/inifile.f90
*** cosmomc/source/inifile.f90 1970-01-01 01:00:00.000000000 +0100
--- cosmomc_sampler/source/inifile.f90 2010-05-27 16:16:07.653015718 +0200
***************
*** 0 ****
--- 1,671 ----
+ !Module to read in name/value pairs from a file, with each line of the form line 'name = value'
+ !Should correctly interpret FITS headers
+ !Antony Lewis (http://cosmologist.info/). Released to the public domain.
+ !This version Oct 2009.
+
+ module IniFile
+ implicit none
+ public
+
+ integer, parameter :: Ini_max_name_len = 128
+
+ integer, parameter :: Ini_max_string_len = 1024
+ logical :: Ini_fail_on_not_found = .false.
+
+ logical :: Ini_Echo_Read = .false.
+
+ type TNameValue
+ !no known way to make character string pointers..
+ character(Ini_max_name_len) :: Name
+ character(Ini_max_string_len):: Value
+ end type TNameValue
+
+ type TNameValue_pointer
+ Type(TNameValue), pointer :: P
+ end type TNameValue_pointer
+
+ Type TNameValueList
+ integer Count
+ integer Delta
+ integer Capacity
+ type(TNameValue_pointer), dimension(:), pointer :: Items
+ end Type TNameValueList
+
+ Type TIniFile
+ logical SlashComments
+ Type (TNameValueList) :: L, ReadValues
+ end Type TIniFile
+
+ Type(TIniFile) :: DefIni
+
+ contains
+
+ subroutine TNameValueList_Init(L)
+ Type (TNameValueList) :: L
+
+ L%Count = 0
+ L%Capacity = 0
+ L%Delta = 128
+ nullify(L%Items)
+
+ end subroutine TNameValueList_Init
+
+ subroutine TNameValueList_Clear(L)
+ Type (TNameValueList) :: L
+ integer i, status
+
+ do i=L%count,1,-1
+ deallocate (L%Items(i)%P, stat = status)
+ end do
+ deallocate (L%Items, stat = status)
+ call TNameValueList_Init(L)
+
+ end subroutine TNameValueList_Clear
+
+ subroutine TNameValueList_ValueOf(L, AName, AValue)
+ Type (TNameValueList), intent(in) :: L
+ character(LEN=*), intent(in) :: AName
+ CHARACTER(LEN=*), intent(out) :: AValue
+ integer i
+
+ do i=1, L%Count
+ if (L%Items(i)%P%Name == AName) then
+ AValue = L%Items(i)%P%Value
+ return
+ end if
+ end do
+ AValue = ''
+
+ end subroutine TNameValueList_ValueOf
+
+ function TNameValueList_HasKey(L, AName) result (AValue)
+ Type (TNameValueList), intent(in) :: L
+ character(LEN=*), intent(in) :: AName
+ logical :: AValue
+ integer i
+
+ do i=1, L%Count
+ if (L%Items(i)%P%Name == AName) then
+ AValue = .true.
+ return
+ end if
+ end do
+ AValue = .false.
+
+ end function TNameValueList_HasKey
+
+ subroutine TNameValueList_Add(L, AName, AValue)
+ Type (TNameValueList) :: L
+ character(LEN=*), intent(in) :: AName, AValue
+
+ if (L%Count == L%Capacity) call TNameValueList_SetCapacity(L, L%Capacity + L%Delta)
+ L%Count = L%Count + 1
+ allocate(L%Items(L%Count)%P)
+ L%Items(L%Count)%P%Name = AName
+ L%Items(L%Count)%P%Value = AValue
+
+ end subroutine TNameValueList_Add
+
+ subroutine TNameValueList_SetCapacity(L, C)
+ Type (TNameValueList) :: L
+ integer C
+ type(TNameValue_pointer), dimension(:), pointer :: TmpItems
+
+ if (L%Count > 0) then
+ if (C < L%Count) stop 'TNameValueList_SetCapacity: smaller than Count'
+ allocate(TmpItems(L%Count))
+ TmpItems = L%Items(1:L%Count)
+ deallocate(L%Items)
+ allocate(L%Items(C))
+ L%Items(1:L%Count) = TmpItems
+ deallocate(TmpItems)
+ else
+ allocate(L%Items(C))
+ end if
+ L%Capacity = C
+
+ end subroutine TNameValueList_SetCapacity
+
+ subroutine TNameValueList_Delete(L, i)
+ Type (TNameValueList) :: L
+ integer, intent(in) :: i
+
+ deallocate(L%Items(i)%P)
+ if (L%Count > 1) L%Items(i:L%Count-1) = L%Items(i+1:L%Count)
+ L%Count = L%Count -1
+
+ end subroutine TNameValueList_Delete
+
+ subroutine Ini_NameValue_Add(Ini,AInLine)
+ Type(TIniFile) :: Ini
+ character (LEN=*), intent(IN) :: AInLine
+ integer EqPos, slashpos, lastpos
+ character (LEN=len(AInLine)) :: AName, S, InLine
+
+ InLine=trim(adjustl(AInLine))
+ EqPos = scan(InLine,'=')
+ if (EqPos/=0 .and. InLine(1:1)/='#' .and. InLine(1:7) /= 'COMMENT' ) then
+
+ AName = trim(InLine(1:EqPos-1))
+
+ S = adjustl(InLine(EqPos+1:))
+ if (Ini%SlashComments) then
+ slashpos=scan(S,'/')
+ if (slashpos /= 0) then
+ S = S(1:slashpos-1)
+ end if
+ end if
+ lastpos=len_trim(S)
+ if (lastpos>1) then
+ if (S(1:1)=='''' .and. S(lastpos:lastpos)=='''') then
+ S = S(2:lastpos-1)
+ end if
+ end if
+ call TNameValueList_Add(Ini%L, AName, S)
+
+ end if
+
+ end subroutine Ini_NameValue_Add
+
+ subroutine Ini_Open(filename, unit_id, error, slash_comments)
+ character (LEN=*), intent(IN) :: filename
+ integer, intent(IN) :: unit_id
+ logical, optional, intent(OUT) :: error
+ logical, optional, intent(IN) :: slash_comments
+ logical aerror
+
+ call TNameValueList_Init(DefIni%L)
+ call TNameValueList_Init(DefIni%ReadValues)
+
+ if (present(slash_comments)) then
+ call Ini_Open_File(DefIni,filename,unit_id,aerror,slash_comments)
+ else
+ call Ini_Open_File(DefIni,filename,unit_id,aerror)
+ end if
+
+ if (present(error)) then
+ error = aerror
+ else
+ if (aerror) then
+ write (*,*) 'Ini_Open: Error opening file ' // trim(filename)
+ stop
+ end if
+ end if
+
+ end subroutine Ini_Open
+
+
+
+ subroutine Ini_Open_File(Ini, filename, unit_id, error, slash_comments)
+ Type(TIniFile) :: Ini
+
+ character (LEN=*), intent(IN) :: filename
+ integer, intent(IN) :: unit_id
+ logical, intent(OUT) :: error
+ logical, optional, intent(IN) :: slash_comments
+ character (LEN=120) :: InLine
+
+
+ call TNameValueList_Init(Ini%L)
+ call TNameValueList_Init(Ini%ReadValues)
+
+ if (present(slash_comments)) then
+ Ini%SlashComments = slash_comments
+ else
+ Ini%SlashComments = .false.
+ end if
+
+ open(unit=unit_id,file=filename,form='formatted',status='old', err=500)
+
+ do
+ read (unit_id,'(a)',end=400) InLine
+ if (InLine == 'END') exit;
+ if (InLine /= '') call Ini_NameValue_Add(Ini,InLine)
+ end do
+
+ 400 close(unit_id)
+ error=.false.
+ return
+
+ 500 error=.true.
+
+ end subroutine Ini_Open_File
+
+ subroutine Ini_Open_Fromlines(Ini, Lines, NumLines, slash_comments)
+ Type(TIniFile) :: Ini
+
+ integer, intent(IN) :: NumLines
+ character (LEN=*), dimension(NumLines), intent(IN) :: Lines
+ logical, intent(IN) :: slash_comments
+ integer i
+
+ call TNameValueList_Init(Ini%L)
+ call TNameValueList_Init(Ini%ReadValues)
+
+ Ini%SlashComments = slash_comments
+
+ do i=1,NumLines
+ call Ini_NameValue_Add(Ini,Lines(i))
+ end do
+
+ end subroutine Ini_Open_Fromlines
+
+ subroutine Ini_Close
+
+ call Ini_close_File(DefIni)
+
+ end subroutine Ini_Close
+
+
+ subroutine Ini_Close_File(Ini)
+ Type(TIniFile) :: Ini
+
+ call TNameValueList_Clear(Ini%L)
+ call TNameValueList_Clear(Ini%ReadValues)
+
+ end subroutine Ini_Close_File
+
+
+
+ function Ini_Read_String(Key, NotFoundFail) result(AValue)
+ character (LEN=*), intent(IN) :: Key
+ logical, optional, intent(IN) :: NotFoundFail
+ character(LEN=Ini_max_string_len) :: AValue
+
+ if (present(NotFoundFail)) then
+ AValue = Ini_Read_String_File(DefIni, Key, NotFoundFail)
+ else
+ AValue = Ini_Read_String_File(DefIni, Key)
+ end if
+
+ end function Ini_Read_String
+
+
+ function Ini_Read_String_File(Ini, Key, NotFoundFail) result(AValue)
+ Type(TIniFile) :: Ini
+ character (LEN=*), intent(IN) :: Key
+ logical, optional, intent(IN) :: NotFoundFail
+ character(LEN=Ini_max_string_len) :: AValue
+
+ call TNameValueList_ValueOf(Ini%L, Key, AValue)
+
+ if (AValue/='') then
+
+ call TNameValueList_Add(Ini%ReadValues, Key, AValue)
+ if (Ini_Echo_Read) write (*,*) trim(Key)//' = ',trim(AValue)
+ return
+
+ end if
+ if (present(NotFoundFail)) then
+ if (NotFoundFail) then
+ write(*,*) 'key not found : '//trim(Key)
+ stop
+ end if
+ else if (Ini_fail_on_not_found) then
+ write(*,*) 'key not found : '//trim(Key)
+ stop
+ end if
+
+ end function Ini_Read_String_File
+ function Ini_HasKey(Key) result(AValue)
+ character (LEN=*), intent(IN) :: Key
+ logical AValue
+
+ AValue = Ini_HasKey_File(DefIni, Key)
+
+ end function Ini_HasKey
+
+ function Ini_HasKey_File(Ini, Key) result(AValue)
+ type(TIniFile), intent(in) :: Ini
+ character (LEN=*), intent(IN) :: Key
+ logical AValue
+
+ Avalue = TNameValueList_HasKey(Ini%L, Key)
+
+ end function Ini_HasKey_File
+
+ function Ini_Key_To_Arraykey(Key, index) result(AValue)
+ character (LEN=*), intent(IN) :: Key
+ integer, intent(in) :: index
+ character(LEN=Ini_max_string_len) :: AValue
+
+ character(LEN=32) :: numstr
+ write (numstr,*) index
+ numstr=adjustl(numstr)
+ AValue = trim(Key) // '(' // trim(numStr) // ')'
+
+ end function Ini_Key_To_Arraykey
+
+ function Ini_Read_String_Array(Key, index, NotFoundFail) result(AValue)
+ character (LEN=*), intent(IN) :: Key
+ integer, intent(in) :: index
+ logical, optional, intent(IN) :: NotFoundFail
+ character(LEN=Ini_max_string_len) :: AValue
+
+ if (present(NotFoundFail)) then
+ AValue = Ini_Read_String_Array_File(DefIni, Key, index, NotFoundFail)
+ else
+ AValue = Ini_Read_String_Array_File(DefIni, Key, index)
+ end if
+
+ end function Ini_Read_String_Array
+
+ function Ini_Read_String_Array_File(Ini, Key, index, NotFoundFail) result(AValue)
+ Type(TIniFile) :: Ini
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ logical, optional, intent(IN) :: NotFoundFail
+ character(LEN=Ini_max_string_len) :: AValue
+ character(LEN=Ini_max_string_len) :: ArrayKey
+
+ ArrayKey = Ini_Key_To_Arraykey(Key,index)
+ if (present(NotFoundFail)) then
+ AValue = Ini_Read_String_File(Ini, ArrayKey, NotFoundFail)
+ else
+ AValue = Ini_Read_String_File(Ini, ArrayKey)
+ end if
+
+ end function Ini_Read_String_Array_File
+
+ function Ini_Read_Int_Array(Key, index, Default)
+ integer, optional, intent(IN) :: Default
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ integer Ini_Read_Int_Array
+
+ if (present(Default)) then
+ Ini_Read_Int_Array = Ini_Read_Int_Array_File(DefIni, Key, index, Default)
+ else
+ Ini_Read_Int_Array = Ini_Read_Int_Array_File(DefIni, Key, index)
+ end if
+
+ end function Ini_Read_Int_Array
+
+ function Ini_Read_Int_Array_File(Ini,Key, index, Default)
+ !Reads Key(1), Key(2), etc.
+ Type(TIniFile) :: Ini
+ integer Ini_Read_Int_Array_File
+ integer, optional, intent(IN) :: Default
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ character(LEN=Ini_max_string_len) :: ArrrayKey
+ ArrrayKey = Ini_Key_To_Arraykey(Key,index)
+ if (present(Default)) then
+ Ini_Read_Int_Array_File = Ini_Read_Int_File(Ini, ArrrayKey, Default)
+ else
+ Ini_Read_Int_Array_File = Ini_Read_Int_File(Ini, ArrrayKey)
+ end if
+ end function Ini_Read_Int_Array_File
+
+
+ function Ini_Read_Int(Key, Default)
+ integer, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ integer Ini_Read_Int
+
+ if (present(Default)) then
+ Ini_Read_Int = Ini_Read_Int_File(DefIni, Key, Default)
+ else
+ Ini_Read_Int = Ini_Read_Int_File(DefIni, Key)
+ end if
+ end function Ini_Read_Int
+
+ function Ini_Read_Int_File(Ini, Key, Default)
+ Type(TIniFile) :: Ini
+ integer Ini_Read_Int_File
+ integer, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ character(LEN=Ini_max_string_len) :: S
+
+ S = Ini_Read_String_File(Ini, Key,.not. present(Default))
+ if (S == '') then
+ if (.not. present(Default)) then
+ write(*,*) 'no value for key: '//Key
+ stop
+ end if
+ Ini_Read_Int_File = Default
+ write (S,*) Default
+ call TNameValueList_Add(Ini%ReadValues, Key, S)
+ else
+ if (verify(trim(S),'-+0123456789') /= 0) goto 10
+ read (S,*, err = 10) Ini_Read_Int_File
+ end if
+ return
+ 10 write (*,*) 'error reading integer for key: '//Key
+ stop
+
+ end function Ini_Read_Int_File
+
+ function Ini_Read_Double(Key, Default)
+ double precision, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ double precision Ini_Read_Double
+
+ if (present(Default)) then
+ Ini_Read_Double = Ini_Read_Double_File(DefIni, Key, Default)
+ else
+ Ini_Read_Double = Ini_Read_Double_File(DefIni, Key)
+ end if
+
+ end function Ini_Read_Double
+
+ function Ini_Read_Double_File(Ini,Key, Default)
+ Type(TIniFile) :: Ini
+ double precision Ini_Read_Double_File
+ double precision, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ character(LEN=Ini_max_string_len) :: S
+
+ S = Ini_Read_String_File(Ini,Key,.not. present(Default))
+ if (S == '') then
+ if (.not. present(Default)) then
+ write(*,*) 'no value for key: '//Key
+ stop
+ end if
+ Ini_Read_Double_File = Default
+ write (S,*) Default
+
+ call TNameValueList_Add(Ini%ReadValues, Key, S)
+
+ else
+ read (S,*, err=10) Ini_Read_Double_File
+ end if
+
+ return
+
+ 10 write (*,*) 'error reading double for key: '//Key
+ stop
+
+ end function Ini_Read_Double_File
+
+
+
+ function Ini_Read_Double_Array(Key, index, Default)
+ double precision, optional, intent(IN) :: Default
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ double precision Ini_Read_Double_Array
+
+ if (present(Default)) then
+ Ini_Read_Double_Array = Ini_Read_Double_Array_File(DefIni, Key, index, Default)
+ else
+ Ini_Read_Double_Array = Ini_Read_Double_Array_File(DefIni, Key, index)
+ end if
+
+ end function Ini_Read_Double_Array
+
+
+ function Ini_Read_Double_Array_File(Ini,Key, index, Default)
+
+ !Reads Key(1), Key(2), etc.
+
+ Type(TIniFile) :: Ini
+
+ double precision Ini_Read_Double_Array_File
+ double precision, optional, intent(IN) :: Default
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ character(LEN=Ini_max_string_len) :: ArrrayKey
+
+ ArrrayKey = Ini_Key_To_Arraykey(Key,index)
+ if (present(Default)) then
+
+ Ini_Read_Double_Array_File = Ini_Read_Double_File(Ini, ArrrayKey, Default)
+ else
+ Ini_Read_Double_Array_File = Ini_Read_Double_File(Ini, ArrrayKey)
+ end if
+ end function Ini_Read_Double_Array_File
+
+ function Ini_Read_Real(Key, Default)
+ real, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ real Ini_Read_Real
+
+ if (present(Default)) then
+ Ini_Read_Real = Ini_Read_Real_File(DefIni, Key, Default)
+ else
+ Ini_Read_Real = Ini_Read_Real_File(DefIni, Key)
+ end if
+
+ end function Ini_Read_Real
+
+ function Ini_Read_Real_File(Ini,Key, Default)
+ Type(TIniFile) :: Ini
+ real Ini_Read_Real_File
+ real, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ character(LEN=Ini_max_string_len) :: S
+
+ S = Ini_Read_String_File(Ini,Key,.not. present(Default))
+ if (S == '') then
+ if (.not. present(Default)) then
+ write(*,*) 'no value for key: '//Key
+ stop
+ end if
+ Ini_Read_Real_File = Default
+ write (S,*) Default
+ call TNameValueList_Add(Ini%ReadValues, Key, S)
+
+ else
+ read (S,*, err=10) Ini_Read_Real_File
+ end if
+
+ return
+
+ 10 write (*,*) 'error reading double for key: '//Key
+ stop
+
+ end function Ini_Read_Real_File
+
+
+
+ function Ini_Read_Real_Array(Key, index, Default)
+ real, optional, intent(IN) :: Default
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ real Ini_Read_Real_Array
+
+ if (present(Default)) then
+ Ini_Read_Real_Array = Ini_Read_Real_Array_File(DefIni, Key, index, Default)
+ else
+ Ini_Read_Real_Array = Ini_Read_Real_Array_File(DefIni, Key, index)
+ end if
+ end function Ini_Read_Real_Array
+
+ function Ini_Read_Real_Array_File(Ini,Key, index, Default)
+ !Reads Key(1), Key(2), etc.
+ Type(TIniFile) :: Ini
+ real Ini_Read_Real_Array_File
+ real, optional, intent(IN) :: Default
+ integer, intent(in) :: index
+ character (LEN=*), intent(IN) :: Key
+ character(LEN=Ini_max_string_len) :: ArrrayKey
+
+ ArrrayKey = Ini_Key_To_Arraykey(Key,index)
+ if (present(Default)) then
+ Ini_Read_Real_Array_File = Ini_Read_Real_File(Ini, ArrrayKey, Default)
+ else
+ Ini_Read_Real_Array_File = Ini_Read_Real_File(Ini, ArrrayKey)
+ end if
+ end function Ini_Read_Real_Array_File
+
+ function Ini_Read_Logical(Key, Default)
+ Logical, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+ logical Ini_Read_Logical
+
+ if (present(Default)) then
+ Ini_Read_Logical = Ini_Read_Logical_File(DefIni, Key, Default)
+ else
+ Ini_Read_Logical = Ini_Read_Logical_File(DefIni, Key)
+ end if
+ end function Ini_Read_Logical
+
+ function Ini_Read_Logical_File(Ini, Key, Default)
+ Type(TIniFile) :: Ini
+
+ logical Ini_Read_Logical_File
+ logical, optional, intent(IN) :: Default
+ character (LEN=*), intent(IN) :: Key
+
+ character(LEN=Ini_max_string_len) :: S
+
+ S = Ini_Read_String_File(Ini,Key,.not. present(Default))
+ if (S == '') then
+ if (.not. present(Default)) then
+ write(*,*) 'no value for key: '//Key
+ stop
+ end if
+ Ini_Read_Logical_File = Default
+ write (S,*) Default
+
+ call TNameValueList_Add(Ini%ReadValues, Key, S)
+
+ else
+
+ if (verify(trim(S),'10TF') /= 0) goto 10
+ read (S,*, err = 10) Ini_Read_Logical_File
+ end if
+
+ return
+
+ 10 write (*,*) 'error reading logical for key: '//Key
+ stop
+ end function Ini_Read_Logical_File
+
+
+
+ subroutine Ini_SaveReadValues(afile,unit_id)
+ character(LEN=*) :: afile
+ integer, intent(in) :: unit_id
+
+ call Ini_SaveReadValues_File(DefIni, afile, unit_id)
+
+ end subroutine Ini_SaveReadValues
+
+
+
+ subroutine Ini_SaveReadValues_File(Ini, afile, unit_id)
+ Type(TIniFile) :: Ini
+ character(LEN=*), intent(in) :: afile
+ integer, intent(in) :: unit_id
+ integer i
+
+ open(unit=unit_id,file=afile,form='formatted',status='replace', err=500)
+
+ do i=1, Ini%ReadValues%Count
+
+ write (unit_id,'(a)') trim(Ini%ReadValues%Items(i)%P%Name) // ' = ' &
+ //trim(Ini%ReadValues%Items(i)%P%Value)
+
+ end do
+
+ close(unit_id)
+ return
+
+ 500 write(*,*) 'Ini_SaveReadValues_File: Error creating '//trim(afile)
+
+ end subroutine Ini_SaveReadValues_File
+
+ end module IniFile
+
diff -r -c -b -B -N cosmomc/source/lrggettheory.f90 cosmomc_sampler/source/lrggettheory.f90
*** cosmomc/source/lrggettheory.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/lrggettheory.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,189 ****
- !!! moved this routine from modules.f90 in CAMB here by preference of Antony.
- !!! needs to be separate from Pktheory.f90 because that file depends on CMB_Cls somehow
-
- module lrggettheory
- use precision
- use Transfer
- implicit none
-
- real(dl), parameter :: aNEAR = 0.809717d0, aMID = 0.745156d0, aFAR = 0.70373d0
- real(dl), parameter :: z0 = 0.0d0, zNEAR = 0.235d0, zMID = 0.342d0, zFAR = 0.421d0
- real(dl), parameter :: sigma2BAONEAR = 86.9988, sigma2BAOMID = 85.1374, sigma2BAOFAR = 84.5958
- real(dl), parameter :: zeffDR7 = 0.312782 !! effective redshift of the LRG sample
- real(dl), dimension(4) :: transferscalefid !! this is set in LRGinfo_init
- real(dl), dimension(4) :: powerscaletoz0
- !! this is to scale the amplitude of the redshift slices power spectra to the z=0 amplitude;
- !this is the assumption of the model.
- real(dl), parameter :: kmindata = 0.02
- !! in h/Mpc. they are needed for normalizing nowiggs power spectrum.
- ! Hard coded for the SDSS DR7 values.
- integer :: iz0lrg, izNEARlrg, izMIDlrg, izFARlrg
- logical :: use_dr7lrg = .false.
-
- contains
-
- subroutine Transfer_GetMatterPowerAndNW(MTrans,outpower, itf, in, minkh, dlnkh, &
- npoints, kmindata, getabstransferscale, outpowernw, outpowerrationwhalofit)
-
- !Allows for non-smooth priordial spectra
- !if CP%Nonlinear/ = NonLinear_none includes non-linear evolution
- !Get total matter power spectrum at logarithmically equal intervals dlnkh of k/h starting at minkh
- !in units of (h Mpc^{-1})^3.
- !Here there definition is < Delta^2(x) > = 1/(2 pi)^3 int d^3k P_k(k)
- !We are assuming that Cls are generated so any baryonic wiggles are well sampled and that matter power
- !sepctrum is generated to beyond the CMB k_max
- Type(MatterTransferData), intent(in) :: MTrans
- Type(MatterPowerData) :: PKnw
-
- integer, intent(in) :: itf, in, npoints
- real, intent(out) :: outpower(npoints)
- real, intent(out) :: outpowernw(npoints), outpowerrationwhalofit(npoints)
- real, intent(in) :: minkh, dlnkh
- real(dl), intent(in) :: kmindata
- real(dl), intent(out) :: getabstransferscale
- real(dl), parameter :: cllo=1.e30_dl,clhi=1.e30_dl
- integer ik, llo,il,lhi,lastix
- real(dl) matpower(MTrans%num_q_trans), kh, kvals(MTrans%num_q_trans), ddmat(MTrans%num_q_trans)
- real(dl) atransfer,xi, a0, b0, ho, logmink,k, h, fbaryon,omegam
- real(dl) matpowernw(MTrans%num_q_trans), matpowernwhalofit(MTrans%num_q_trans), &
- & atransfernw, atransfernwhalofit, &
- &ddmatnw(MTrans%num_q_trans), ddmatnwhalofit(MTrans%num_q_trans)
-
- !!added for splining.
- real(dl) :: mykvals(MTrans%num_q_trans),mylnpklinear(MTrans%num_q_trans),mylnpksmooth(MTrans%num_q_trans)
-
- integer :: nwi,tempi, setabs
- Type(MatterTransferData) :: MTransnw
-
- MTransnw%num_q_trans = MTrans%num_q_trans
- allocate(MTransnw%q_trans(MTransnw%num_q_trans))
- allocate(MTransnw%TransferData(Transfer_max,MTransnw%num_q_trans,CP%Transfer%num_redshifts))
- allocate(MTransnw%sigma_8(CP%Transfer%num_redshifts, CP%InitPower%nn))
-
-
- h = CP%H0/100
- do nwi = 1, MTransnw%num_q_trans
- MTransnw%q_trans(nwi) = MTrans%q_trans(nwi) !! not ever referenced.
- MTransnw%TransferData(Transfer_kh,nwi,1) = MTrans%TransferData(Transfer_kh,nwi,1)
- kh = MTrans%TransferData(Transfer_kh,nwi,1)
- k = kh*h
- do tempi=2,Transfer_tot
- MTransnw%TransferData(tempi,nwi,1) = 0.0d0
- end do
- mykvals(nwi) = k
- atransfer=MTrans%TransferData(transfer_power_var,nwi,itf)
- mylnpklinear(nwi) = log(atransfer**2*k*pi*twopi*h**3*ScalarPower(k,in))
- end do
-
- #ifdef DR71RG
- call dopksmoothbspline(mykvals,mylnpklinear,mylnpksmooth, MTrans%num_q_trans)
- #else
- call MpiStop('mpk: edit makefile to have "EXTDATA = LRG" to inlude LRGs')
- #endif
- setabs = 0
- do nwi = 1, MTransnw%num_q_trans
- kh = MTrans%TransferData(Transfer_kh,nwi,1)
- if(kh > kmindata .and. setabs == 0) then
- getabstransferscale = sqrt(exp(mylnpklinear(nwi)))
- setabs = 1
- end if
- k = kh*h
- MTransnw%TransferData(transfer_power_var,nwi,1) = sqrt(exp(mylnpksmooth(nwi))/(k*pi*twopi*h**3*ScalarPower(k,in)))
- end do
- if (npoints < 2) stop 'Need at least 2 points in Transfer_GetMatterPower'
- if (minkh*exp((npoints-1)*dlnkh) > MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf) &
- .and. FeedbackLevel > 0 ) &
- write(*,*) 'Warning: extrapolating matter power in Transfer_GetMatterPower'
-
- !! get nonlinear on Pnw
- call Transfer_GetMatterPowerData(MTransnw,PKnw, in, 1)
- Pknw%redshifts(1) = CP%Transfer%Redshifts(itf)
- call NonLinear_GetRatios(Pknw)
-
- h = CP%H0/100
- logmink = log(minkh)
- do ik=1,MTrans%num_q_trans
- kh = MTrans%TransferData(Transfer_kh,ik,itf)
- k = kh*h
- kvals(ik) = log(kh)
- atransfer=MTrans%TransferData(transfer_power_var,ik,itf)
- atransfernw=MTransnw%TransferData(transfer_power_var,ik,1)
- atransfernwhalofit=MTransnw%TransferData(transfer_power_var,ik,1)
- atransfernwhalofit = atransfernwhalofit * PKnw%nonlin_ratio(ik,1)
- matpower(ik) = log(atransfer**2*k*pi*twopi*h**3)
- !Put in power spectrum later: transfer functions should be smooth, initial power may not be
-
- matpowernw(ik) = log(atransfernw**2*k*pi*twopi*h**3)
- matpowernwhalofit(ik) = log(atransfernwhalofit**2*k*pi*twopi*h**3)
- end do
- call spline(kvals,matpower,MTrans%num_q_trans,cllo,clhi,ddmat)
- call spline(kvals,matpowernw,MTrans%num_q_trans,cllo,clhi,ddmatnw)
- call spline(kvals,matpowernwhalofit,MTrans%num_q_trans,cllo,clhi,ddmatnwhalofit)
-
-
- llo=1
- lastix = npoints + 1
- do il=1, npoints
- xi=logmink + dlnkh*(il-1)
- if (xi < kvals(1)) then
- outpower(il)=-30.
- outpowernw(il)=-30.
- outpowerrationwhalofit(il)=-30.
- cycle
- end if
- do while ((xi > kvals(llo+1)).and.(llo < MTrans%num_q_trans))
- llo=llo+1
- if (llo >= MTrans%num_q_trans) exit
- end do
- if (llo == MTrans%num_q_trans) then
- lastix = il
- exit
- end if
- lhi=llo+1
- ho=kvals(lhi)-kvals(llo)
- a0=(kvals(lhi)-xi)/ho
- b0=(xi-kvals(llo))/ho
-
- outpower(il) = a0*matpower(llo)+ b0*matpower(lhi)+((a0**3-a0)* ddmat(llo) &
- +(b0**3-b0)*ddmat(lhi))*ho**2/6
- outpowernw(il) = a0*matpowernw(llo)+ b0*matpowernw(lhi)+((a0**3-a0)* ddmatnw(llo) &
- +(b0**3-b0)*ddmatnw(lhi))*ho**2/6
- outpowerrationwhalofit(il) = a0*matpowernwhalofit(llo)+ b0*matpowernwhalofit(lhi)+((a0**3-a0)* ddmatnwhalofit(llo) &
- +(b0**3-b0)*ddmatnwhalofit(lhi))*ho**2/6
-
- end do
-
- do while (lastix <= npoints)
- !Do linear extrapolation in the log
- !Obviouly inaccurate, non-linear etc, but OK if only using in tails of window functions
- outpower(lastix) = 2*outpower(lastix-1) - outpower(lastix-2)
- outpowernw(lastix) = 2*outpowernw(lastix-1) - outpowernw(lastix-2)
- outpowerrationwhalofit(lastix) = 2*outpowerrationwhalofit(lastix-1)&
- - outpowerrationwhalofit(lastix-2)
- lastix = lastix+1
- end do
-
- outpower = exp(max(-30.,outpower))
- outpowernw = exp(max(-30.,outpowernw))
- outpowerrationwhalofit = exp(max(-30.,outpowerrationwhalofit))
-
-
- do il = 1, npoints
- k = exp(logmink + dlnkh*(il-1))*h
- outpower(il) = outpower(il) * ScalarPower(k,in)
- outpowerrationwhalofit(il) = outpowerrationwhalofit(il)/outpowernw(il)
- !! do this first because the ScalarPower calls cancel.
- outpowernw(il) = outpowernw(il) * ScalarPower(k,in)
- !print *,k/h,outpower(il),outpowernw(il)
- !print *,k/h,outpowerrationwhalofit(il)
- end do
-
- call MatterPowerdata_Free(PKnw)
- deallocate(MTransnw%q_trans)
- deallocate(MTransnw%TransferData)
- deallocate(MTransnw%sigma_8)
-
- end subroutine Transfer_GetMatterPowerAndNW
-
-
- end module
--- 0 ----
diff -r -c -b -B -N cosmomc/source/lya.f90 cosmomc_sampler/source/lya.f90
*** cosmomc/source/lya.f90 2006-04-20 22:14:30.000000000 +0200
--- cosmomc_sampler/source/lya.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,182 ****
- !Module for using Viel et al. Lyman-alpha data
- !J.Lesgourgues,29/10/04
- !AL modification to integrate over calibration numerically,
- ! reject models with weird high om_m that probe v small scales
- !April 2006: Fixed major bug (introduced by AL)
- ! removed unsafe OPENMP; CROFT on by default
-
- module lya
- use settings
- use cmbtypes
- implicit none
-
- integer, parameter :: lya_points = 9
- real :: lya_k(lya_points)
-
- ! for LUQAS:
- real :: lya_P1(lya_points), lya_dP1(lya_points)
- logical :: use_LUQAS = .true.
-
- ! for CROFT:
- real :: lya_P2(lya_points), lya_dP2(lya_points)
- logical :: use_CROFT = .true.
-
- real :: lya_kmax = 6.
- logical :: do_lya_init = .true.
- logical :: Use_lya = .false.
-
- contains
-
- subroutine lya_init
- integer i
-
- if (Feedback > 0) write(*,*) 'reading: Lyman-alpha data'
- call OpenTxtFile('data/lyman_alpha.dat', tmp_file_unit)
-
- do i =1, lya_points
- read (tmp_file_unit,*, end = 200, err=200) &
- lya_k(i), lya_P1(i), lya_dP1(i), lya_P2(i), lya_dP2(i)
- end do
- close(tmp_file_unit)
-
- do_lya_init = .false.
-
- goto 300
-
- 200 stop 'Error reading Lyman-alpha file'
-
- 300 return
-
- end subroutine lya_init
-
- function LSS_lyalike(CMB, Theory)
- Type (CMBParams) CMB
- Type (CosmoTheory) Theory
- real LSS_lyalike
- real omegam, g2, omegam_z, omegav_z, th, chisq, minchisq
- real z, z1, z2, coef, D_ratio, acal
- integer, parameter :: ncal=12
- real dif2(-ncal:ncal)
- real, parameter :: dcal= 0.25
- real calweights(-ncal:ncal)
- real, parameter :: cal_sigma = 0.29
- integer i, ical
-
- if (do_lya_init) call lya_init
-
- if (CMB%W /= -1. .or. CMB%omnu/=0.) then
- write (*,*) 'Lya.f90 not tested for extended models'
- stop
- end if
-
-
- z1=2.125
- z2=2.72
- omegam=1.-CMB%omv-CMB%omk
-
- dif2 = 0
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! compute chi2 for LUQAS
-
- if (use_LUQAS) then
-
- z=z1
-
- ! coefficient from h/Mpc to s/km
- g2=omegam*(1.+z)**3+CMB%omk*(1.+z)**2+CMB%omv
- coef = 100. * sqrt(g2) / (1.+z)
- ! growth factor
- omegam_z= omegam*(1.+z)**3/g2
- omegav_z= CMB%omv/g2
- D_ratio = omegam_z/(1.+z)/(exp(4./7.*log(omegam_z))-omegav_z &
- +(1.+omegam_z/2.)*(1.+omegav_z/70.)) &
- /omegam*(exp(4./7.*log(omegam))-CMB%omv &
- +(1.+omegam/2.)*(1.+CMB%omv/70.))
-
-
- if (lya_k(lya_points)*coef > &
- exp(log(matter_power_minkh) + (num_matter_power-1)*matter_power_dlnkh)) then
- !Just thow out if way-off model
- LSS_lyalike = LogZero
- return
- end if
-
- do i=1, lya_points
-
- th = MatterPowerAt(Theory,lya_k(i)*coef) *coef**3 &
- *(D_ratio)**2 &
- *(1.+1.4*exp(0.6*log(omegam_z)))/2.4
-
- do ical=-ncal,ncal
- acal = 1+ical*cal_sigma*dcal
-
- dif2(ical) = dif2(ical) + ((th-lya_P1(i)*0.93*acal)**2/ &
- (lya_dP1(i)*0.93*acal)**2)
- end do
-
- end do
-
- end if
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! compute chi2 for z=z1
-
- if (use_CROFT) then
-
- z=z2
-
- ! coefficient from h/Mpc to s/km
- g2=omegam*(1.+z)**3+CMB%omk*(1.+z)**2+CMB%omv
- coef = 100. * sqrt(g2) / (1.+z)
- ! growth factor
- omegam_z= omegam*(1.+z)**3/g2
- omegav_z= CMB%omv/g2
- D_ratio = omegam_z/(1.+z)/(exp(4./7.*log(omegam_z))-omegav_z &
- +(1.+omegam_z/2.)*(1.+omegav_z/70.)) &
- /omegam*(exp(4./7.*log(omegam))-CMB%omv &
- +(1.+omegam/2.)*(1.+CMB%omv/70.))
-
-
- do i=1, lya_points
-
- th = MatterPowerAt(Theory,lya_k(i)*coef) *coef**3 &
- *(D_ratio)**2 &
- *(1.+1.4*exp(0.6*log(omegam_z)))/2.4
-
- do ical=-ncal,ncal
- acal = 1+ical*cal_sigma*dcal
-
- dif2(ical) = dif2(ical) + ((th-lya_P2(i)*0.93*acal)**2/ &
- (lya_dP2(i)*0.93*acal)**2)
- end do
-
- end do
-
- end if
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- do i=-ncal,ncal
- acal = 1+i*cal_sigma*dcal
- calweights(i) = exp(-(1-acal)**2/cal_sigma**2/2)
- end do
-
- minchisq = minval(dif2)
- chisq = sum(exp(-(dif2-minchisq)/2)*calweights)/sum(calweights)
-
- if (chisq == 0) then
- chisq = 2*LogZero
- else
- chisq = -2*log(chisq) + minchisq
- end if
-
- if (Feedback>1) write(*,*) 'Lyman-alpha chi-sq: ', chisq
-
- LSS_lyalike = chisq/2.
-
- end function LSS_lyalike
-
- end module lya
--- 0 ----
diff -r -c -b -B -N cosmomc/source/Makefile cosmomc_sampler/source/Makefile
*** cosmomc/source/Makefile 2010-05-04 11:07:37.000000000 +0200
--- cosmomc_sampler/source/Makefile 2009-10-28 17:56:08.384509654 +0100
***************
*** 1,198 ****
! #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 mpif90 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)
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 -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
!
! #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 =
! PROPOSE = propose.o
! 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)
- DISTFILES = utils.o ParamNames.o Matrix_utils.o settings.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)
! 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
! else
! F90FLAGS += -DNOWMAP
! endif
! default: cosmomc
! all : cosmomc getdist
! utils.o: ../camb/libcamb.a
! settings.o: utils.o
! cmbtypes.o: settings.o
! Planck_like.o: cmbtypes.o
! cmbdata.o: Planck_like.o $(WMAPOBJS)
! WeakLen.o: cmbtypes.o
! bbn.o: settings.o
! bao.o: cmbtypes.o
! mpk.o: cmbtypes.o lrggettheory.o
! HST.o: cmbtypes.o
! supernovae.o: cmbtypes.o
! SDSSLy-a-v3.o: cmbtypes.o
! $(CLSFILE): cmbtypes.o mpk.o HST.o bao.o IO.o
! paramdef.o: $(CLSFILE)
! $(PROPOSE): paramdef.o
! $(PARAMETERIZATION): paramdef.o
! calclike.o: $(PARAMETERIZATION)
! conjgrad_wrapper.o: calclike.o
! EstCovmat.o: conjgrad_wrapper.o
! 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
-
%.o: %.f90
$(F90C) $(F90FLAGS) -c $*.f90
--- 1,70 ----
! # >>> DESIGNED FOR GMAKE <<<
! # Unified Systems makefile for GENEMC
! # Add FLAGS -DMPI for using MPI
!
! ext=$(shell uname | cut -c1-3)
!
! ifeq ($(ext),IRI)
! F90C= f90
! FFLAGS= -Ofast -mp -n32 -LANG:recursive=ON -lmpi -DMPI
! LAPACKL = -lcomplib.sgimath_mp
! INCLUDE =
endif
! ifeq ($(ext),Lin)
! F90C=gfortran
! FFLAGS= -O -fopenmp
! #LAPACKL = -L/opt/intel/mkl/10.1.2.024/lib/em64t -lmkl -lmkl_lapack
! LAPACKL = -llapack
! INCLUDE = -I/usr/include
! endif
! ifeq ($(ext),OSF)
! F90C=f90
! FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1
! WMAPFLAGS= $(FFLAGS)
! LAPACKL = -lcxml
! INCLUDE =
! endif
! ifeq ($(ext),Sun)
! F90C=f90
! FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none
! WMAPFLAGS= $(FFLAGS)
! LAPACKL = -lsunperf -lfsu
! INCLUDE =
! endif
! ifeq ($(ext),AIX)
! F90C = mpxlf90_r
! FFLAGS = -O4 -WF,-DIBMXL,-DMPI -qstrict -qsmp=omp -qmaxmem=-1 -qsuffix=f=f90:cpp=F90
! LAPACKL = -lessl
! INCLUDE =
! endif
! PROPOSE = propose.o
+ PARAMETERIZATION = params_EXT.o
! MCMCLIB = $(LAPACKL)
! F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(INCLUDE)
! DISTFILES = utils.o ParamNames.o Matrix_utils.o settings.o GetDist.o
! OBJFILES= inifile.o utils.o ParamNames.o Matrix_utils.o settings.o IO.o \
! paramdef.o wrapper.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \
! conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o
! default: genemc.$(ext)
! all : genemc.$(ext) getdist.$(ext)
.f.o:
f77 $(F90FLAGS) -c $<
%.o: %.f90
$(F90C) $(F90FLAGS) -c $*.f90
***************
*** 200,218 ****
$(F90C) $(F90FLAGS) -c $*.F90
! cosmomc: camb $(OBJFILES)
! $(F90C) -o ../cosmomc $(OBJFILES) $(LINKFLAGS) $(F90FLAGS)
!
! clean: cleancosmomc
! rm -f ../camb/*.o ../camb/*.obj ../camb/*.mod
!
! cleancosmomc:
rm -f *.o *.mod *.d *.pc *.obj ../core
!
! getdist: camb $(DISTFILES)
! $(F90C) -o ../getdist $(DISTFILES) $(LINKFLAGS) $(F90FLAGS)
!
! camb:
! cd ../camb && $(MAKE) --file=Makefile_main libcamb.a
--- 72,82 ----
$(F90C) $(F90FLAGS) -c $*.F90
! genemc.$(ext): $(OBJFILES)
! $(F90C) -o ../$@ $(OBJFILES) $(MCMCLIB) $(F90FLAGS)
! clean:
rm -f *.o *.mod *.d *.pc *.obj ../core
! getdist.$(ext): $(DISTFILES)
! $(F90C) -o ../$@ $(DISTFILES) $(CLSLIB) $(F90FLAGS)
diff -r -c -b -B -N cosmomc/source/MCMC.f90 cosmomc_sampler/source/MCMC.f90
*** cosmomc/source/MCMC.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/MCMC.f90 2010-05-27 16:16:10.543842397 +0200
***************
*** 8,13 ****
--- 8,14 ----
use CalcLike
use Random
use propose
+ use wrapper
use IO
implicit none
diff -r -c -b -B -N cosmomc/source/mpk.f90 cosmomc_sampler/source/mpk.f90
*** cosmomc/source/mpk.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/mpk.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,1148 ****
- !Module storing observed matter power spectrum datasets, their points and window functions
- !and routines for computing the likelihood
-
- !This code is based on that in cmbdata.f90
- !and on Sam Leach's incorporation of Max Tegmark's SDSS code
- !
- !Originally SLB Sept 2004
- !AL April 2006: added covariance matrix support (following 2df 2005)
- !LV_06 : incorporation of LRG DR4 from Tegmark et al . astroph/0608632
- !AL: modified LV SDSS to do Q and b^2 or b^2*Q marge internally as for 2df
- !BR09: added model LRG power spectrum.
- !AL Oct 20: switch to Ini_Read_xxx_File; fortran compatibility changes
-
-
- module LRGinfo
- use settings
- use cmbtypes
- use Precision
- use lrggettheory
-
- !use CMB_Cls
-
- implicit none
-
- !! these are the LRG redshift subsample weights.
- real(dl), parameter :: w0 = 0.0d0, wNEAR = 0.395d0, wMID = 0.355d0, wFAR = 0.250d0
-
- !in CAMB: 4=now (z=0), 3=NEAR, 2=MID, 1=FAR; opposite order in matter_power
- !! now generalized indices iz0lrg, izNEARlrg, izMIDlrg, izFARlrg
- real(dl), dimension(4) :: zeval, zweight, sigma2BAOfid, sigma2BAO
-
- real(dl) om_val, ol_val, ok_check, wval ! passed in from CMBparams CMB
-
- ! power spectra evaluated at fiducial cosmological theory (WMAP5 recommended values)
- real, allocatable :: ratio_power_nw_nl_fid(:,:)
- !real,dimension(num_matter_power,matter_power_lnzsteps) :: ratio_power_nw_nl_fid
- !make allocatable to avoid compile-time range errors when matter_power_lnzsteps<4
-
- contains
-
- subroutine LRGinfo_init()
- integer :: iopb, i, ios
- real(dl) :: omegakdummy,omegavdummy,wdummy,getabstransferscalefiddummy
- real(dl) :: kval, plin, psmooth, rationwhalofit
-
- !!BR09 only needed for LRGs, so only 4 redshifts no matter what matter_power_lnzsteps is
- allocate(ratio_power_nw_nl_fid(num_matter_power,4))
-
- sigma2BAOfid(1) = 1.0e-5 !! don't do any smearing at z=0; this won't be used anyway.
- sigma2BAOfid(2) = sigma2BAONEAR
- sigma2BAOfid(3) = sigma2BAOMID
- sigma2BAOfid(4) = sigma2BAOFAR
-
- zeval(1) = z0
- zeval(2) = zNEAR
- zeval(3) = zMID
- zeval(4) = zFAR
-
- zweight(1) = w0
- zweight(2) = wNEAR
- zweight(3) = wMID
- zweight(4) = wFAR
-
- !! first read in everything needed from the CAMB output files.
- iopb = 0 !! check later if there was an error
-
- open(unit=tmp_file_unit,file=trim(DataDir)//'lrgdr7fiducialmodel_matterpowerzNEAR.dat',form='formatted',err=500, iostat=ios)
- read (tmp_file_unit,*,iostat=iopb) getabstransferscalefiddummy, omegakdummy,omegavdummy,wdummy
- do i = 1, num_matter_power
- read (tmp_file_unit,*,iostat=iopb) kval, plin, psmooth, rationwhalofit
- ratio_power_nw_nl_fid(i,2) = rationwhalofit
- end do
- close(tmp_file_unit)
-
- open(unit=tmp_file_unit,file=trim(DataDir)//'lrgdr7fiducialmodel_matterpowerzMID.dat',form='formatted',err=500, iostat=ios)
- read (tmp_file_unit,*,iostat=iopb) getabstransferscalefiddummy,omegakdummy,omegavdummy,wdummy
- do i = 1, num_matter_power
- read (tmp_file_unit,*,iostat=iopb) kval, plin, psmooth, rationwhalofit
- ratio_power_nw_nl_fid(i,3) = rationwhalofit
- end do
- close(tmp_file_unit)
-
- open(unit=tmp_file_unit,file=trim(DataDir)//'lrgdr7fiducialmodel_matterpowerzFAR.dat',form='formatted',err=500,iostat=ios)
- read (tmp_file_unit,*,iostat=iopb) getabstransferscalefiddummy,omegakdummy,omegavdummy,wdummy
- do i = 1, num_matter_power
- read (tmp_file_unit,*,iostat=iopb) kval, plin, psmooth, rationwhalofit
- ratio_power_nw_nl_fid(i,4) = rationwhalofit
- end do
- close(tmp_file_unit)
-
- 500 if(ios .ne. 0) stop 'Unable to open file'
- if(iopb .ne. 0) stop 'Error reading model or fiducial theory files.'
- end subroutine LRGinfo_init
-
- ! HARD CODING OF POLYNOMIAL FITS TO NEAR, MID, FAR SUBSAMPLES.
- subroutine LRGtoICsmooth(k,fidpolys)
- real(dl), intent(in) :: k
- real(dl) :: fidNEAR, fidMID, fidFAR
- real(dl), dimension(2:4), intent(out) :: fidpolys
-
- if(k < 0.194055d0) then !!this is where the two polynomials are equal
- fidNEAR = (1.0d0 - 0.680886d0*k + 6.48151d0*k**2)
- else
- fidNEAR = (1.0d0 - 2.13627d0*k + 21.0537d0*k**2 - 50.1167d0*k**3 + 36.8155d0*k**4)*1.04482d0
- end if
-
- if(k < 0.19431) then
- fidMID = (1.0d0 - 0.530799d0*k + 6.31822d0*k**2)
- else
- fidMID = (1.0d0 - 1.97873d0*k + 20.8551d0*k**2 - 50.0376d0*k**3 + 36.4056d0*k**4)*1.04384
- end if
-
- if(k < 0.19148) then
- fidFAR = (1.0d0 - 0.475028d0*k + 6.69004d0*k**2)
- else
- fidFAR = (1.0d0 - 1.84891d0*k + 21.3479d0*k**2 - 52.4846d0*k**3 + 38.9541d0*k**4)*1.03753
- end if
- fidpolys(2) = fidNEAR
- fidpolys(3) = fidMID
- fidpolys(4) = fidFAR
- end subroutine LRGtoICsmooth
-
- subroutine fill_LRGTheory(Theory, minkh, dlnkh)
- Type(CosmoTheory) Theory
- real, intent(in) :: minkh, dlnkh
- real(dl) :: logmink, xi, kval, expval, psmear, nlrat
- real(dl), dimension(2:4) :: fidpolys, holdval
-
- integer :: iz, ik, matterpowerindx
-
- do iz = 1, 4
- sigma2BAO(iz) = sigma2BAOfid(iz)
- end do
-
- logmink = log(minkh)
- do ik=1,num_matter_power
- xi = logmink + dlnkh*(ik-1)
- kval = exp(xi)
- Theory%finalLRGtheoryPk(ik) = 0.
- do iz = 2,4
- if(iz == 2) matterpowerindx = izNEARlrg
- if(iz == 3) matterpowerindx = izMIDlrg
- if(iz == 4) matterpowerindx = izFARlrg
- expval = exp(-kval**2*sigma2BAO(iz)*0.5)
- psmear = (Theory%matter_power(ik,matterpowerindx))*expval + (Theory%mpk_nw(ik,matterpowerindx))*(1.0-expval)
- psmear = psmear*powerscaletoz0(iz)
- nlrat = (Theory%mpkrat_nw_nl(ik,matterpowerindx))/(ratio_power_nw_nl_fid(ik,matterpowerindx))
- call LRGtoICsmooth(kval,fidpolys)
- holdval(iz) = zweight(iz)*psmear*nlrat*fidpolys(iz)
- Theory%finalLRGtheoryPk(ik) = Theory%finalLRGtheoryPk(ik) + holdval(iz)
- end do
-
- end do
-
- end subroutine fill_LRGTheory
-
- end module
-
- module mpk
- use precision
- use settings
- use cmbtypes
- use LRGinfo
- implicit none
-
- Type mpkdataset
- logical :: use_set
- integer :: num_mpk_points_use ! total number of points used (ie. max-min+1)
- integer :: num_mpk_kbands_use ! total number of kbands used (ie. max-min+1)
- character(LEN=20) :: name
- real, pointer, dimension(:,:) :: N_inv
- real, pointer, dimension(:,:) :: mpk_W, mpk_invcov
- real, pointer, dimension(:) :: mpk_P, mpk_sdev, mpk_k
- real, pointer, dimension(:) :: mpk_zerowindowfxn
- real, pointer, dimension(:) :: mpk_zerowindowfxnsubtractdat
- real :: mpk_zerowindowfxnsubdatnorm !!the 0th entry in windowfxnsubtract file
- logical :: use_scaling !as SDSS_lrgDR3
- !for Q and A see e.g. astro-ph/0501174, astro-ph/0604335
- logical :: Q_marge, Q_flat
- real :: Q_mid, Q_sigma, Ag
- end Type mpkdataset
-
- integer :: num_mpk_datasets = 0
- Type(mpkdataset) mpkdatasets(10)
-
- !Note all units are in k/h here
-
- integer, parameter :: mpk_d = kind(1.d0)
-
- logical :: use_mpk = .false.
-
- ! constants describing the allowed a1,a2 regions.
- ! must check the functions below before changing these, because the shape of the space may change!
-
- integer, parameter :: wp = selected_real_kind(11,99)
-
- !!these are the 'nonconservative' nuisance parameter bounds
- !!real(dl), parameter :: k1 = 0.1d0, k2 = 0.2d0, s1 = 0.02d0, s2 = 0.05d0, a1maxval = 0.5741d0
- real(dl), parameter :: k1 = 0.1d0, k2 = 0.2d0, s1 = 0.04d0, s2 = 0.10d0, a1maxval = 1.1482d0
- integer, parameter :: nptsa1 = 41, nptsa2 = 41, nptstot = 325
- !! but total number of points to evaluate is much smaller than 41**2 because lots of the space
- !is not allowed by the s1,s2 constraints.
-
- ! only want to compute these once.
- real(dl), dimension(nptstot) :: a1list, a2list
-
- contains
-
- subroutine mpk_SetTransferRedshifts(redshifts)
- real, intent(inout) :: redshifts(*)
- !input is default log z spacing; can change here; check for consistency with other (e.g. lya)
-
- !Note internal ordering in CAMB is the opposite to that used in cosmomc transfer arrays (as here)
- !first index here must be redshift zero
-
- if(use_dr7lrg .and. matter_power_lnzsteps < 4) &
- call MpiStop('For LRGs matter_power_lnzsteps should be set to at least 4 (hardcoded in cmbtypes)')
-
- if (matter_power_lnzsteps==1 .or. .not. use_dr7lrg) return
-
- !! assigning indices to LRG NEAR, MID, FAR. If you want to reorder redshifts, just change here.
- iz0lrg = 1 !! we use the z=0 output to normalize things; this is already assumed index 1 elsewhere
- !(like in calculation of sigma8).
- izNEARlrg = 2
- izMIDlrg = 3
- izFARlrg = 4
- redshifts(izNEARlrg) = zNEAR
- redshifts(izMIDlrg) = zMID
- redshifts(izFARlrg) = zFAR
- if(iz0lrg /= 1) then
- redshifts(iz0lrg) = 0.0d0
- else
- if(redshifts(1) > 0.001) call MpiStop('redshifts(1) should be at z=0!')
- endif
-
- end subroutine mpk_SetTransferRedshifts
-
- subroutine ReadmpkDataset(gname)
- use MatrixUtils
- character(LEN=*), intent(IN) :: gname
- character(LEN=Ini_max_string_len) :: kbands_file, measurements_file, windows_file, cov_file
- !! added for the LRG window function subtraction
- character(LEN=Ini_max_string_len) :: zerowindowfxn_file, zerowindowfxnsubtractdat_file
-
- Type (mpkdataset) :: mset
-
- integer i,iopb
- real keff,klo,khi,beff
- integer :: num_mpk_points_full ! actual number of bandpowers in the infile
- integer :: num_mpk_kbands_full ! actual number of k positions " in the infile
- integer :: max_mpk_points_use ! in case you don't want the smallest scale modes (eg. sdss)
- integer :: min_mpk_points_use ! in case you don't want the largest scale modes
- integer :: max_mpk_kbands_use ! in case you don't want to calc P(k) on the smallest scales (will truncate P(k) to zero here!)
- integer :: min_mpk_kbands_use ! in case you don't want to calc P(k) on the largest scales (will truncate P(k) to zero here!)
- real, dimension(:,:), allocatable :: mpk_Wfull, mpk_covfull
- real, dimension(:), allocatable :: mpk_kfull, mpk_fiducial
-
- real, dimension(:), allocatable :: mpk_zerowindowfxnfull
- real, dimension(:), allocatable :: mpk_zerowindowfxnsubfull
-
- character(80) :: dummychar
- logical bad
- Type(TIniFile) :: Ini
- integer file_unit
-
-
- num_mpk_datasets = num_mpk_datasets + 1
- if (num_mpk_datasets > 10) stop 'too many datasets'
- file_unit = new_file_unit()
- call Ini_Open_File(Ini, gname, file_unit, bad, .false.)
- if (bad) then
- write (*,*) 'Error opening dataset file '//trim(gname)
- stop
- end if
-
- mset%name = Ini_Read_String_File(Ini,'name')
- Ini_fail_on_not_found = .false.
- mset%use_set =.true.
- if (Feedback > 0) write (*,*) 'reading: '//trim(mset%name)
- num_mpk_points_full = Ini_Read_Int_File(Ini,'num_mpk_points_full',0)
- if (num_mpk_points_full.eq.0) write(*,*) ' ERROR: parameter num_mpk_points_full not set'
- num_mpk_kbands_full = Ini_Read_Int_File(Ini,'num_mpk_kbands_full',0)
- if (num_mpk_kbands_full.eq.0) write(*,*) ' ERROR: parameter num_mpk_kbands_full not set'
- min_mpk_points_use = Ini_Read_Int_File(Ini,'min_mpk_points_use',1)
- min_mpk_kbands_use = Ini_Read_Int_File(Ini,'min_mpk_kbands_use',1)
- max_mpk_points_use = Ini_Read_Int_File(Ini,'max_mpk_points_use',num_mpk_points_full)
- max_mpk_kbands_use = Ini_Read_Int_File(Ini,'max_mpk_kbands_use',num_mpk_kbands_full)
- mset%num_mpk_points_use = max_mpk_points_use - min_mpk_points_use +1
- mset%num_mpk_kbands_use = max_mpk_kbands_use - min_mpk_kbands_use +1
-
- allocate(mpk_Wfull(num_mpk_points_full,num_mpk_kbands_full))
- allocate(mpk_kfull(num_mpk_kbands_full))
- allocate(mset%mpk_P(mset%num_mpk_points_use))
- allocate(mset%mpk_sdev(mset%num_mpk_points_use)) ! will need to replace with the covmat
- allocate(mset%mpk_k(mset%num_mpk_kbands_use))
- allocate(mset%mpk_W(mset%num_mpk_points_use,mset%num_mpk_kbands_use))
- allocate(mset%mpk_zerowindowfxn(mset%num_mpk_kbands_use))
- allocate(mset%mpk_zerowindowfxnsubtractdat(mset%num_mpk_points_use))
- allocate(mpk_fiducial(mset%num_mpk_points_use))
- allocate(mpk_zerowindowfxnsubfull(num_mpk_points_full+1))
- !!need to add 1 to get the normalization held in the first (really zeroth) entry
- allocate(mpk_zerowindowfxnfull(num_mpk_kbands_full))
-
- kbands_file = ReadIniFileName(Ini,'kbands_file')
- call ReadVector(kbands_file,mpk_kfull,num_mpk_kbands_full)
- mset%mpk_k(1:mset%num_mpk_kbands_use)=mpk_kfull(min_mpk_kbands_use:max_mpk_kbands_use)
- if (Feedback > 1) then
- write(*,*) 'reading: ',mset%name,' data'
- write(*,*) 'Using kbands windows between',mset%mpk_k(1),' < k/h < ',mset%mpk_k(mset%num_mpk_kbands_use)
- endif
- if (mset%mpk_k(1) < matter_power_minkh) then
- write (*,*) 'WARNING: k_min in '//trim(mset%name)//'less than setting in cmbtypes.f90'
- write (*,*) 'all k 1 .and. min_mpk_points_use>1) write(*,*) 'Not using bands with keff= ',keff,' or below'
- do i =1, mset%num_mpk_points_use
- read (tmp_file_unit,*, iostat=iopb) keff,klo,khi,mset%mpk_P(i),mset%mpk_sdev(i),mpk_fiducial(i)
- end do
- close(tmp_file_unit)
- if (Feedback > 1) write(*,*) 'bands truncated at keff= ',keff
-
- windows_file = ReadIniFileName(Ini,'windows_file')
- if (windows_file.eq.'') write(*,*) 'ERROR: mpk windows_file not specified'
- call ReadMatrix(windows_file,mpk_Wfull,num_mpk_points_full,num_mpk_kbands_full)
- mset%mpk_W(1:mset%num_mpk_points_use,1:mset%num_mpk_kbands_use)= &
- mpk_Wfull(min_mpk_points_use:max_mpk_points_use,min_mpk_kbands_use:max_mpk_kbands_use)
-
-
- if (mset%name == 'lrg_2009') then
- #ifndef DR71RG
- call MpiStop('mpk: edit makefile to have "EXTDATA = LRG" to inlude LRGs')
- #else
- use_dr7lrg = .true.
- zerowindowfxn_file = ReadIniFileName(Ini,'zerowindowfxn_file')
-
- print *, 'trying to read this many points', num_mpk_kbands_full
- if (zerowindowfxn_file.eq.'') write(*,*) 'ERROR: mpk zerowindowfxn_file not specified'
- call ReadVector(zerowindowfxn_file,mpk_zerowindowfxnfull,num_mpk_kbands_full)
- mset%mpk_zerowindowfxn(1:mset%num_mpk_kbands_use) = mpk_zerowindowfxnfull(min_mpk_kbands_use:max_mpk_kbands_use)
- zerowindowfxnsubtractdat_file = ReadIniFileName(Ini,'zerowindowfxnsubtractdat_file')
- if (zerowindowfxnsubtractdat_file.eq.'') write(*,*) 'ERROR: mpk zerowindowfxnsubtractdat_file not specified'
- call ReadVector(zerowindowfxnsubtractdat_file,mpk_zerowindowfxnsubfull,num_mpk_points_full+1)
- mset%mpk_zerowindowfxnsubtractdat(1:mset%num_mpk_points_use) = &
- mpk_zerowindowfxnsubfull(min_mpk_points_use+1:max_mpk_points_use+1)
- mset%mpk_zerowindowfxnsubdatnorm = mpk_zerowindowfxnsubfull(1)
- #endif
- end if
-
- cov_file = ReadIniFileName(Ini,'cov_file')
- if (cov_file /= '') then
- allocate(mpk_covfull(num_mpk_points_full,num_mpk_points_full))
- call ReadMatrix(cov_file,mpk_covfull,num_mpk_points_full,num_mpk_points_full)
- allocate(mset%mpk_invcov(mset%num_mpk_points_use,mset%num_mpk_points_use))
- mset%mpk_invcov= mpk_covfull(min_mpk_points_use:max_mpk_points_use,min_mpk_points_use:max_mpk_points_use)
- call Matrix_Inverse(mset%mpk_invcov)
- deallocate(mpk_covfull)
- else
- nullify(mset%mpk_invcov)
- end if
-
- mset%use_scaling = Ini_Read_Logical_File(Ini,'use_scaling',.false.)
-
- mset%Q_marge = Ini_Read_Logical_File(Ini,'Q_marge',.false.)
- if (mset%Q_marge) then
- mset%Q_flat = Ini_Read_Logical_File(Ini,'Q_flat',.false.)
- if (.not. mset%Q_flat) then
- !gaussian prior on Q
- mset%Q_mid = Ini_Read_Real_File(Ini,'Q_mid')
- mset%Q_sigma = Ini_Read_Real_File(Ini,'Q_sigma')
- end if
- mset%Ag = Ini_Read_Real_File(Ini,'Ag', 1.4)
- end if
- if (iopb.ne.0) then
- stop 'Error reading mpk file'
- endif
-
- call Ini_Close_File(Ini)
- call ClearFileUnit(file_unit)
-
- deallocate(mpk_Wfull, mpk_kfull,mpk_fiducial)
-
- mpkdatasets(num_mpk_datasets) = mset
-
- if (mset%name == 'lrg_2009') call LSS_LRG_mpklike_init()
-
- end subroutine ReadmpkDataset
-
-
- function LSS_mpklike(Theory,mset,CMB) result(LnLike) ! LV_06 added CMB here
- Type (mpkdataset) :: mset
- Type (CosmoTheory) Theory
- Type(CMBparams) CMB !LV_06 added for LRGDR4
- real LnLike
- real, dimension(:), allocatable :: mpk_Pth, mpk_k2,mpk_lin,k_scaled !LV_06 added for LRGDR4
- real, dimension(:), allocatable :: w
- real, dimension(:), allocatable :: mpk_WPth, mpk_WPth_k2
- real :: covdat(mset%num_mpk_points_use), covth(mset%num_mpk_points_use), covth_k2(mset%num_mpk_points_use)
- real :: normV, Q, minchisq
- real :: a_scl !LV_06 added for LRGDR4
- integer :: i, iQ
- logical :: do_marge
- integer, parameter :: nQ=6
- real :: tmp, dQ = 0.4
- real chisq(-nQ:nQ)
- real calweights(-nQ:nQ)
- real vec2(2),Mat(2,2)
-
- allocate(mpk_lin(mset%num_mpk_kbands_use) ,mpk_Pth(mset%num_mpk_kbands_use))
- allocate(mpk_WPth(mset%num_mpk_points_use))
- allocate(k_scaled(mset%num_mpk_kbands_use))!LV_06 added for LRGDR4
- allocate(w(mset%num_mpk_points_use))
-
- chisq = 0
-
- if (.not. mset%use_set) then
- LnLike = 0
- return
- end if
-
- ! won't actually want to do this multiple times for multiple galaxy pk data sets?..
-
- IF(mset%use_scaling) then
- call compute_scaling_factor(dble(CMB%omk),dble(CMB%omv),dble(CMB%w),a_scl)
- else
- a_scl = 1
- end if
-
-
- do i=1, mset%num_mpk_kbands_use
- !Errors from using matter_power_minkh at lower end should be negligible
- k_scaled(i)=max(matter_power_minkh,a_scl*mset%mpk_k(i))
- mpk_lin(i)=MatterPowerAt(Theory,k_scaled(i))/a_scl**3
- end do
-
-
- do_marge = mset%Q_Marge
- if (do_marge .and. mset%Q_flat) then
- !Marginalize analytically with flat prior on b^2 and b^2*Q
- !as recommended by Max Tegmark for SDSS
- allocate(mpk_k2(mset%num_mpk_kbands_use))
- allocate(mpk_WPth_k2(mset%num_mpk_points_use))
-
- mpk_Pth=mpk_lin/(1+mset%Ag*k_scaled)
- mpk_k2=mpk_Pth*k_scaled**2
- mpk_WPth = matmul(mset%mpk_W,mpk_Pth)
- mpk_WPth_k2 = matmul(mset%mpk_W,mpk_k2)
-
- if (associated(mset%mpk_invcov)) then
- covdat = matmul(mset%mpk_invcov,mset%mpk_P)
- covth = matmul(mset%mpk_invcov,mpk_WPth)
- covth_k2 = matmul(mset%mpk_invcov,mpk_WPth_k2)
- else
- w=1/(mset%mpk_sdev**2)
- covdat = mset%mpk_P*w
- covth = mpk_WPth*w
- covth_k2 = mpk_WPth_k2*w
- end if
-
- Mat(1,1) = sum(covth*mpk_WPth)
- Mat(2,2) = sum(covth_k2*mpk_WPth_k2)
- Mat(1,2) = sum(covth*mpk_WPth_k2)
- Mat(2,1) = Mat(1,2)
- LnLike = log( Mat(1,1)*Mat(2,2)-Mat(1,2)**2)
- call inv_mat22(Mat)
- vec2(1) = sum(covdat*mpk_WPth)
- vec2(2) = sum(covdat*mpk_WPth_k2)
- LnLike = (sum(mset%mpk_P*covdat) - sum(vec2*matmul(Mat,vec2)) + LnLike ) /2
-
- deallocate(mpk_k2,mpk_WPth_k2)
- else
-
- if (mset%Q_sigma==0) do_marge = .false.
-
- do iQ=-nQ,nQ
- Q = mset%Q_mid +iQ*mset%Q_sigma*dQ
-
- if (mset%Q_marge) then
- mpk_Pth=mpk_lin*(1+Q*k_scaled**2)/(1+mset%Ag*k_scaled)
- else
- mpk_Pth = mpk_lin
- end if
-
- mpk_WPth = matmul(mset%mpk_W,mpk_Pth)
-
- !with analytic marginalization over normalization nuisance (flat prior on b^2)
- !See appendix F of cosmomc paper
-
- if (associated(mset%mpk_invcov)) then
- covdat = matmul(mset%mpk_invcov,mset%mpk_P)
- covth = matmul(mset%mpk_invcov,mpk_WPth)
- normV = sum(mpk_WPth*covth)
- chisq(iQ) = sum(mset%mpk_P*covdat) - sum(mpk_WPth*covdat)**2/normV + log(normV)
-
- else
-
- !with analytic marginalization over normalization nuisance (flat prior on b^2)
- w=1/(mset%mpk_sdev**2)
- normV = sum(mpk_WPth*mpk_WPth*w)
- tmp=sum(mpk_WPth*mset%mpk_P*w)/normV ! avoid subtracting one large number from another
- chisq(iQ) = sum(mset%mpk_P*(mset%mpk_P - mpk_WPth*tmp)*w) + log(normV)
- end if
-
- if (do_marge) then
- calweights(iQ) = exp(-(iQ*dQ)**2/2)
- else
- LnLike = chisq(iQ)/2
- exit
- end if
-
- end do
-
- !without analytic marginalization
- !! chisq = sum((mset%mpk_P(:) - mpk_WPth(:))**2*w) ! uncommented for debugging purposes
-
- if (do_marge) then
- minchisq=minval(chisq)
- LnLike = sum(exp(-(chisq-minchisq)/2)*calweights)/sum(calweights)
- if (LnLike == 0) then
- LnLike = LogZero
- else
- LnLike = -log(LnLike) + minchisq/2
- end if
- end if
-
- end if !not analytic over Q
-
- if (Feedback>1) write(*,*) 'mpk chi-sq:', LnLike*2
-
- if (LnLike > 1e8) then
- write(*,*) 'Chisq is huge, maybe there is a problem? chisq=',chisq
- end if
-
- deallocate(mpk_Pth,mpk_lin)
- deallocate(mpk_WPth,k_scaled,w)
-
- end function LSS_mpklike
-
-
- function LSSLnLike(CMB, Theory)
- Type (CMBParams) CMB
- Type (CosmoTheory) Theory
- real LSSLnLike
- integer i
- real tot(num_mpk_datasets)
-
- do i=1, num_mpk_datasets
- if (mpkdatasets(i)%name == 'twodf') then
- stop 'twodf no longer supported - use data/2df_2005.dataset'
- else if (mpkdatasets(i)%name == 'lrg_2009') then
- tot(i) = LSS_LRG_mpklike(Theory,mpkdatasets(i),CMB)
- else
- tot(i) = LSS_mpklike(Theory,mpkdatasets(i),CMB) !LV_06 added CMB here
- end if
- end do
- LSSLnLike = SUM(tot)
-
- end function LSSLnLike
-
- subroutine inv_mat22(M)
- real M(2,2), Minv(2,2), det
-
- det = M(1,1)*M(2,2)-M(1,2)*M(2,1)
- Minv(1,1)=M(2,2)
- Minv(2,2) = M(1,1)
- Minv(1,2) = - M(2,1)
- Minv(2,1) = - M(1,2)
- M = Minv/det
-
- end subroutine inv_mat22
-
- !-----------------------------------------------------------------------------
- !LV added to include lrg DR4
-
- subroutine compute_scaling_factor(Ok,Ol,w,a)
- ! a = dV for z=0.35 relative to its value for flat Om=0.25 model.
- ! This is the factor by which the P(k) measurement would shift
- ! sideways relative to what we got for this fiducial flat model.
- ! * a = (a_angular**2 * a_radial)**(1/3)
- ! * a_angular = comoving distance to z=0.35 in Mpc/h relative to its value for flat Om=0.25 model
- ! dA = (c/H)*eta = (2997.92458 Mpc/h)*eta, so we care only about
- ! eta scaling, not h scaling.
- ! For flat w=-1 models, a ~ (Om/0.25)**(-0.065)
- ! For the LRG mean redshift z=0.35, the power law fit
- ! dA(z,Om= 0.3253 (Om/0.25)^{-0.065}c H_0^{-1} is quite good within
- ! our range of interest,
- ! accurate to within about 0.1% for 0.2 0 & Omega_k > 1
- ! or if w = 0 & Omega_l < 1
- ! g(1) = Omega_m + Omega_k + Omega_l = 1 > 0
- implicit none
- real(mpk_d) Ok, Ol, w, Om, tmp, a, epsilon
- integer failure
- failure = 0
- epsilon = 0
- !epsilon = 0.04 ! Numerical integration fails even before H^2 goes negative.
- Om = 1.d0 - Ok - Ol
- if (w*Ol.ne.0) then
- tmp = Ok/(3*w*Ol)
- if ((tmp.gt.0).and.(1+3*w.ne.0)) then ! f'(0)=0 for some a>0
- a = tmp**(-1/(1+3*w))
- if (a.lt.1) then
- if (Om + Ok*a + Ol*a**(-3*w).lt.epsilon) failure = 1
- end if
- end if
- end if
- if ((w.eq.0).and.(Ok.gt.1)) failure = 2
- if ((w.gt.0).and.(Ol.lt.0)) failure = 3
- nobigbang2 = (failure.gt.0)
- if (failure.gt.0) print *,'Big Bang failure mode ',failure
- return
- end function nobigbang2
- !END INTERFACE
-
- real(mpk_d) function eta_integrand(a)
- implicit none
- real(mpk_d) Or, Ok, Ox, w
- common/eta/Or, Ok, Ox, w
- real(mpk_d) a, Om
- ! eta = int (H0/H)dz = int (H0/H)(1+z)dln(1+z) = int (H0/H)/a dlna = int (H0/H)/a^2 da =
- ! Integrand = (H0/H)/a^2
- ! (H/H0)**2 = Ox*a**(-3*(1+w)) + Ok/a**2 + Om/a**3 + Or/a**4
- if (a.eq.0.d0) then
- eta_integrand = 0.d0
- else
- Om = 1.d0 - Or - Ok - Ox
- eta_integrand = 1.d0/sqrt(Ox*a**(1-3*w) + Ok*a**2 + Om*a + Or)
- end if
- return
- end function eta_integrand
-
- subroutine eta_z_integral(Omega_r,Omega_k,Omega_x,w_eos,z,eta)
- ! Computes eta as a function
- ! of the curvature Omega_k, the dark energy density Omega_x
- ! and its equation of state w.
- implicit none
- real(mpk_d) Or, Ok, Ox, w
- common/eta/Or, Ok, Ox, w
- real(mpk_d) Omega_r, Omega_k,Omega_x,w_eos, z, eta, epsabs, epsrel, amin, amax!, eta_integrand
- Or = Omega_r
- Ok = Omega_k
- Ox = Omega_x
- w = w_eos
- epsabs = 0
- epsrel = 1.d-10
- amin= 1/(1+z)
- amax= 1
- call qromb2(eta_integrand,amin,amax,epsabs,epsrel,eta)
- return
- end subroutine eta_z_integral
-
- subroutine compute_z_eta(Or,Ok,Ox,w,z,eta)
- ! Computes the conformal distance eta(z)
- implicit none
- real(mpk_d) Or, Ok, Ox, w, z, eta
- ! logical nobigbang2
- if (nobigbang2(Ok,Ox,w)) then
- print *,'No big bang, so eta undefined if z>zmax.'
- eta = 99
- else
- call eta_z_integral(Or,Ok,Ox,w,z,eta)
- ! print *,'Or, Ok, Ox, w, z, H_0 t_0...',Or, Ok, Ox, w, eta
- end if
- return
- end subroutine compute_z_eta
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!!! num rec routines
- !!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE qromb2(func,a,b,epsabs,epsrel,ss)
- ! The numerical recipes routine, but modified so that is decides
- ! it's done when either the relative OR the absolute accuracy has been attained.
- ! The old version used relative errors only, so it always failed when
- ! when the integrand was near zero.
- ! epsabs = epsrel = 1e-6 are canonical choices.
- INTEGER JMAX,JMAXP,K,KM
- real(mpk_d) a,b,func,ss,epsabs,epsrel
- EXTERNAL func
- PARAMETER (JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1)
- ! USES polint,trapzd
- INTEGER j
- real(mpk_d) dss,h(JMAXP),s(JMAXP)
- h(1)=1.d0
- do j=1,JMAX
- call trapzd(func,a,b,s(j),j)
- if (j.ge.K) then
- call polint(h(j-KM),s(j-KM),K,0.d0,ss,dss)
- if (abs(dss).le.epsrel*abs(ss)) return
- if (abs(dss).le.epsabs) return
- endif
- s(j+1)=s(j)
- h(j+1)=0.25d0*h(j)
- ENDDO
- print *,'Too many steps in qromb'
-
- RETURN
- END SUBROUTINE qromb2
-
- SUBROUTINE polint(xa,ya,n,x,y,dy) ! From Numerical Recipes
- INTEGER n,NMAX
- real(mpk_d) dy,x,y,xa(n),ya(n)
- PARAMETER (NMAX=10)
- INTEGER i,m,ns
- real(mpk_d) den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
- ns=1
- dif=abs(x-xa(1))
- do i=1,n
- dift=abs(x-xa(i))
- if (dift.lt.dif) then
- ns=i
- dif=dift
- endif
- c(i)=ya(i)
- d(i)=ya(i)
- enddo
- y=ya(ns)
- ns=ns-1
- do m=1,n-1
- do i=1,n-m
- ho=xa(i)-x
- hp=xa(i+m)-x
- w=c(i+1)-d(i)
- den=ho-hp
- if(den.eq.0.) then
- print*, 'failure in polint'
- stop
- endif
- den=w/den
- d(i)=hp*den
- c(i)=ho*den
- enddo
- if (2*ns.lt.n-m)then
- dy=c(ns+1)
- else
- dy=d(ns)
- ns=ns-1
- endif
- y=y+dy
- enddo
- return
- END SUBROUTINE polint
-
- SUBROUTINE trapzd(func,a,b,s,n) ! From Numerical Recipes
- INTEGER n
- real(mpk_d) a,b,s,func
- EXTERNAL func
- INTEGER it,j
- real(mpk_d) del,sum,tnm,x
- if (n.eq.1) then
- s=0.5*(b-a)*(func(a)+func(b))
- else
- it=2**(n-2)
- tnm=it
- del=(b-a)/tnm
- x=a+0.5*del
- sum=0.
- do j=1,it
- sum=sum+func(x)
- x=x+del
- enddo
- s=0.5*(s+(b-a)*sum/tnm)
- endif
- return
- END SUBROUTINE trapzd
-
-
-
- !! added by Beth Reid for LRG P(k) analysis
-
- function a2maxpos(a1val) result(a2max)
- real(dl), intent(in) :: a1val
- real(dl) a2max
- a2max = -1.0d0
- if (a1val <= min(s1/k1,s2/k2)) then
- a2max = min(s1/k1**2 - a1val/k1, s2/k2**2 - a1val/k2)
- end if
- end function a2maxpos
-
- function a2min1pos(a1val) result(a2min1)
- real(dl), intent(in) :: a1val
- real(dl) a2min1
- a2min1 = 0.0d0
- if(a1val <= 0.0d0) then
- a2min1 = max(-s1/k1**2 - a1val/k1, -s2/k2**2 - a1val/k2, 0.0d0)
- end if
- end function a2min1pos
-
- function a2min2pos(a1val) result(a2min2)
- real(dl), intent(in) :: a1val
- real(dl) a2min2
- a2min2 = 0.0d0
- if(abs(a1val) >= 2.0d0*s1/k1 .and. a1val <= 0.0d0) then
- a2min2 = a1val**2/s1*0.25d0
- end if
- end function a2min2pos
-
- function a2min3pos(a1val) result(a2min3)
- real(dl), intent(in) :: a1val
- real(dl) a2min3
- a2min3 = 0.0d0
- if(abs(a1val) >= 2.0d0*s2/k2 .and. a1val <= 0.0d0) then
- a2min3 = a1val**2/s2*0.25d0
- end if
- end function a2min3pos
-
- function a2minfinalpos(a1val) result(a2minpos)
- real(dl), intent(in) :: a1val
- real(dl) a2minpos
- a2minpos = max(a2min1pos(a1val),a2min2pos(a1val),a2min3pos(a1val))
- end function a2minfinalpos
-
- function a2minneg(a1val) result(a2min)
- real(dl), intent(in) :: a1val
- real(dl) a2min
- if (a1val >= max(-s1/k1,-s2/k2)) then
- a2min = max(-s1/k1**2 - a1val/k1, -s2/k2**2 - a1val/k2)
- else
- a2min = 1.0d0
- end if
- end function a2minneg
-
- function a2max1neg(a1val) result(a2max1)
- real(dl), intent(in) :: a1val
- real(dl) a2max1
- if(a1val >= 0.0d0) then
- a2max1 = min(s1/k1**2 - a1val/k1, s2/k2**2 - a1val/k2, 0.0d0)
- else
- a2max1 = 0.0d0
- end if
- end function a2max1neg
-
- function a2max2neg(a1val) result(a2max2)
- real(dl), intent(in) :: a1val
- real(dl) a2max2
- a2max2 = 0.0d0
- if(abs(a1val) >= 2.0d0*s1/k1 .and. a1val >= 0.0d0) then
- a2max2 = -a1val**2/s1*0.25d0
- end if
- end function a2max2neg
-
- function a2max3neg(a1val) result(a2max3)
- real(dl), intent(in) :: a1val
- real(dl) a2max3
- a2max3 = 0.0d0
- if(abs(a1val) >= 2.0d0*s2/k2 .and. a1val >= 0.0d0) then
- a2max3 = -a1val**2/s2*0.25d0
- end if
- end function a2max3neg
-
- function a2maxfinalneg(a1val) result(a2maxneg)
- real(dl), intent(in) :: a1val
- real(dl) a2maxneg
- a2maxneg = min(a2max1neg(a1val),a2max2neg(a1val),a2max3neg(a1val))
- end function a2maxfinalneg
-
-
- function testa1a2(a1val, a2val) result(testresult)
- real(dl), intent(in) :: a1val,a2val
- logical :: testresult
-
- real(dl) :: kext, diffval
- testresult = .true.
-
- ! check if there's an extremum; either a1val or a2val has to be negative, not both
- kext = -a1val/2.0d0/a2val
- diffval = abs(a1val*kext + a2val*kext**2)
- if(kext > 0.0d0 .and. kext <= k1 .and. diffval > s1) testresult = .false.
- if(kext > 0.0d0 .and. kext <= k2 .and. diffval > s2) testresult = .false.
-
- if (abs(a1val*k1 + a2val*k1**2) > s1) testresult = .false.
- if (abs(a1val*k2 + a2val*k2**2) > s2) testresult = .false.
-
- end function testa1a2
-
- !! copying LSS_mpklike above.
- !! points_use is how many points to use in the likelihood calculation;
- !!kbands_use is how many points you need to have a theory for in order to convolve the theory with the window function.
-
-
- ! this subroutine fills in the a1 and a2 values only once.
- subroutine LSS_LRG_mpklike_init()
- real(dl) :: a1val, a2val
- real(dl) :: da1, da2 ! spacing of numerical integral over nuisance params.
- integer :: countcheck = 0
- integer :: i, j
- !! this is just for checking the 'theory' curves for fiducial model
- real :: fidLnLike
- type(CosmoTheory) :: temptheory
- type(CMBparams) :: tempCMB
-
- da1 = a1maxval/(nptsa1/2)
- da2 = a2maxpos(-a1maxval)/(nptsa2/2)
- do i = -nptsa1/2, nptsa1/2
- do j = -nptsa2/2, nptsa2/2
- a1val = da1*i
- a2val = da2*j
-
- if ((a2val >= 0.0d0 .and. a2val <= a2maxpos(a1val) .and. a2val >= a2minfinalpos(a1val)) .or. &
- & (a2val <= 0.0d0 .and. a2val <= a2maxfinalneg(a1val) .and. a2val >= a2minneg(a1val))) then
- if(testa1a2(a1val,a2val) .eqv. .false.) then
- print *,'Failed a1, a2: ',a1val,a2val
- if (a2val >= 0.0d0) print *,'pos', a2maxpos(a1val), a2minfinalpos(a1val)
- if (a2val <= 0.0d0) print *,'neg', a2maxfinalneg(a1val), a2minneg(a1val)
- stop
- end if
- countcheck = countcheck + 1
- if(countcheck > nptstot) then
- print *, 'countcheck > nptstot failure.'
- stop
- end if
- a1list(countcheck) = a1val
- a2list(countcheck) = a2val
- !print *, countcheck, a1list(countcheck), a2list(countcheck)
- end if
- end do
- end do
- if(countcheck .ne. nptstot) then
- print *, 'countcheck issue', countcheck, nptstot
- stop
- end if
- call LRGinfo_init()
- end subroutine LSS_LRG_mpklike_init
-
-
- function LSS_LRG_mpklike(Theory,mset,CMB) result(LnLike) ! LV_06 added CMB here
- Type (mpkdataset) :: mset
- Type (CosmoTheory) Theory
- Type(CMBparams) CMB !LV_06 added for LRGDR4
- real LnLike
- integer :: i
- real, dimension(:), allocatable :: mpk_raw, mpk_Pth, mpk_Pth_k, mpk_Pth_k2, k_scaled
- real, dimension(:), allocatable :: mpk_WPth, mpk_WPth_k, mpk_WPth_k2
- real :: covdat(mset%num_mpk_points_use), covth(mset%num_mpk_points_use), &
- & covth_k(mset%num_mpk_points_use), covth_k2(mset%num_mpk_points_use), &
- & covth_zerowin(mset%num_mpk_points_use)
-
- real, dimension(nptstot) :: chisq, chisqmarg !! minus log likelihood list
- real :: minchisq,maxchisq,deltaL
-
- real(dl) :: a1val, a2val, zerowinsub
- real :: sumDD, sumDT, sumDT_k, sumDT_k2, sumTT,&
- & sumTT_k, sumTT_k2, sumTT_k_k, sumTT_k_k2, sumTT_k2_k2, &
- & sumDT_tot, sumTT_tot, &
- & sumDT_zerowin, sumTT_zerowin, sumTT_k_zerowin, sumTT_k2_zerowin, sumTT_zerowin_zerowin
-
- real :: sumzerow_Pth, sumzerow_Pth_k, sumzerow_Pth_k2
-
- real :: a_scl !LV_06 added for LRGDR4
-
- real(wp) :: temp1,temp2,temp3
- real :: temp4
-
- !! added for no marg
- integer :: myminchisqindx
- real :: currminchisq, currminchisqmarg, minchisqtheoryamp, chisqnonuis
- real :: minchisqtheoryampnonuis, minchisqtheoryampminnuis
- real(dl), dimension(2) :: myerfval
-
- call fill_LRGTheory(Theory,matter_power_minkh,matter_power_dlnkh)
- allocate(mpk_raw(mset%num_mpk_kbands_use) ,mpk_Pth(mset%num_mpk_kbands_use))
- allocate(mpk_Pth_k(mset%num_mpk_kbands_use) ,mpk_Pth_k2(mset%num_mpk_kbands_use))
- allocate(mpk_WPth(mset%num_mpk_points_use),mpk_WPth_k(mset%num_mpk_points_use),mpk_WPth_k2(mset%num_mpk_points_use))
- allocate(k_scaled(mset%num_mpk_kbands_use))!LV_06 added for LRGDR4
-
- chisq = 0
-
- if (.not. mset%use_set) then
- LnLike = 0
- return
- end if
-
- IF(mset%use_scaling) then
- call compute_scaling_factor(dble(CMB%omk),dble(CMB%omv),dble(CMB%w),a_scl)
- !! this step now applied in compute_scaling_factor
- !! this fixes the bug most easily !!
- !!a_scl = 1.0d0/a_scl
- else
- a_scl = 1
- stop 'use_scaling should be set to true for the LRGs!'
- end if
-
- do i=1, mset%num_mpk_kbands_use
- k_scaled(i)=max(matter_power_minkh,a_scl*mset%mpk_k(i))
- mpk_raw(i)=LRGPowerAt(Theory,k_scaled(i))/a_scl**3
- end do
-
- mpk_Pth = mpk_raw
-
- mpk_Pth_k = mpk_Pth*k_scaled
- mpk_Pth_k2 = mpk_Pth*k_scaled**2
- mpk_WPth = matmul(mset%mpk_W,mpk_Pth)
- mpk_WPth_k = matmul(mset%mpk_W,mpk_Pth_k)
- mpk_WPth_k2 = matmul(mset%mpk_W,mpk_Pth_k2)
-
- sumzerow_Pth = sum(mset%mpk_zerowindowfxn*mpk_Pth)/mset%mpk_zerowindowfxnsubdatnorm
- sumzerow_Pth_k = sum(mset%mpk_zerowindowfxn*mpk_Pth_k)/mset%mpk_zerowindowfxnsubdatnorm
- sumzerow_Pth_k2 = sum(mset%mpk_zerowindowfxn*mpk_Pth_k2)/mset%mpk_zerowindowfxnsubdatnorm
-
-
- covdat = matmul(mset%mpk_invcov,mset%mpk_P)
- covth = matmul(mset%mpk_invcov,mpk_WPth)
- covth_k = matmul(mset%mpk_invcov,mpk_WPth_k)
- covth_k2 = matmul(mset%mpk_invcov,mpk_WPth_k2)
- covth_zerowin = matmul(mset%mpk_invcov,mset%mpk_zerowindowfxnsubtractdat)
-
- sumDD = sum(mset%mpk_P*covdat)
- sumDT = sum(mset%mpk_P*covth)
- sumDT_k = sum(mset%mpk_P*covth_k)
- sumDT_k2 = sum(mset%mpk_P*covth_k2)
- sumDT_zerowin = sum(mset%mpk_P*covth_zerowin)
-
- sumTT = sum(mpk_WPth*covth)
- sumTT_k = sum(mpk_WPth*covth_k)
- sumTT_k2 = sum(mpk_WPth*covth_k2)
- sumTT_k_k = sum(mpk_WPth_k*covth_k)
- sumTT_k_k2 = sum(mpk_WPth_k*covth_k2)
- sumTT_k2_k2 = sum(mpk_WPth_k2*covth_k2)
- sumTT_zerowin = sum(mpk_WPth*covth_zerowin)
- sumTT_k_zerowin = sum(mpk_WPth_k*covth_zerowin)
- sumTT_k2_zerowin = sum(mpk_WPth_k2*covth_zerowin)
- sumTT_zerowin_zerowin = sum(mset%mpk_zerowindowfxnsubtractdat*covth_zerowin)
-
- currminchisq = 1000.0d0
- do i=1,nptstot
- a1val = a1list(i)
- a2val = a2list(i)
- zerowinsub = -(sumzerow_Pth + a1val*sumzerow_Pth_k + a2val*sumzerow_Pth_k2)
-
- sumDT_tot = sumDT + a1val*sumDT_k + a2val*sumDT_k2 + zerowinsub*sumDT_zerowin
- sumTT_tot = sumTT + a1val**2.0d0*sumTT_k_k + a2val**2.0d0*sumTT_k2_k2 + &
- & zerowinsub**2.0d0*sumTT_zerowin_zerowin &
- & + 2.0d0*a1val*sumTT_k + 2.0d0*a2val*sumTT_k2 + 2.0d0*a1val*a2val*sumTT_k_k2 &
- & + 2.0d0*zerowinsub*sumTT_zerowin + 2.0d0*zerowinsub*a1val*sumTT_k_zerowin &
- & + 2.0d0*zerowinsub*a2val*sumTT_k2_zerowin
- minchisqtheoryamp = sumDT_tot/sumTT_tot
- chisq(i) = sumDD - 2.0d0*minchisqtheoryamp*sumDT_tot + minchisqtheoryamp**2.0d0*sumTT_tot
- #ifdef DR71RG
- myerfval(1) = sumDT_tot/2.0d0/sqrt(sumTT_tot)
- call geterf(myerfval)
- chisqmarg(i) = sumDD - sumDT_tot**2.0d0/sumTT_tot &
- & + log(sumTT_tot) &
- & - 2.0*log(1.0d0 + myerfval(2))
- #else
- !!leave out the erf term, just to get it to compile. This should never run.
- chisqmarg(i) = sumDD - sumDT_tot**2.0d0/sumTT_tot &
- & + log(sumTT_tot)
- if(0 .eq. 0) stop 'Logic problem. Shouldnt be here.'
- #endif
- !this should always be here, but we're using gsl to call erf, so this function is only available if gsl is installed.
- if(i == 1 .or. chisq(i) < currminchisq) then
- myminchisqindx = i
- currminchisq = chisq(i)
- currminchisqmarg = chisqmarg(i)
- minchisqtheoryampminnuis = minchisqtheoryamp
- end if
- if(i == int(nptstot/2)+1) then
- chisqnonuis = chisq(i)
- minchisqtheoryampnonuis = minchisqtheoryamp
- if(abs(a1val) > 0.001 .or. abs(a2val) > 0.001) then
- print *, 'ahhhh! violation!!', a1val, a2val
- end if
- end if
-
- end do
-
- ! numerically marginalize over a1,a2 now using values stored in chisq
- minchisq = minval(chisqmarg)
- maxchisq = maxval(chisqmarg)
-
- LnLike = sum(exp(-(chisqmarg-minchisq)/2.0d0)/(nptstot*1.0d0))
- if(LnLike == 0) then
- LnLike = LogZero
- else
- LnLike = -log(LnLike) + minchisq/2.0d0
- end if
- deltaL = (maxchisq - minchisq)*0.5
- if(Feedback > 1) print *,'LRG P(k) LnLike = ',LnLike
-
- deallocate(mpk_raw, mpk_Pth)
- deallocate(mpk_Pth_k, mpk_Pth_k2)
- deallocate(mpk_WPth, mpk_WPth_k, mpk_WPth_k2)
- deallocate(k_scaled)
-
- end function LSS_LRG_mpklike
-
- end module
--- 0 ----
diff -r -c -b -B -N cosmomc/source/paramdef.F90 cosmomc_sampler/source/paramdef.F90
*** cosmomc/source/paramdef.F90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/paramdef.F90 2010-05-27 16:15:24.513018225 +0200
***************
*** 1,16 ****
!Defines a parameterization, computes likelihoods and defined proposal density
!Change this file to change these things, and MPI updating
- !The Cls are computed using routines defined in the CMB_Cls module
module ParamDef
!module defines a parameterization, and works out power spectra
! use CMB_Cls
! use cmbtypes
! use cmbdata
use Random
use settings
implicit none
Type ParamSet
real P(num_params)
Type(ParamSetInfo) Info
--- 1,20 ----
!Defines a parameterization, computes likelihoods and defined proposal density
!Change this file to change these things, and MPI updating
module ParamDef
!module defines a parameterization, and works out power spectra
! ! use cmbtypes
! ! use cmbdata
use Random
use settings
+
implicit none
+ Type ParamSetInfo
+ integer :: infoInt
+ real :: infoReal
+ end Type ParamSetInfo
+
Type ParamSet
real P(num_params)
Type(ParamSetInfo) Info
***************
*** 135,141 ****
Ini_fail_on_not_found = .false.
! call CMB_Initialize(Params%Info)
prop_mat = trim(Ini_Read_String_File(Ini,'propose_matrix'))
has_propose_matrix = prop_mat /= ''
--- 139,145 ----
Ini_fail_on_not_found = .false.
! ! call CMB_Initialize(Params%Info)
prop_mat = trim(Ini_Read_String_File(Ini,'propose_matrix'))
has_propose_matrix = prop_mat /= ''
***************
*** 352,393 ****
end subroutine SetProposeMatrix
-
-
- subroutine WriteCMBParams(CMB,Theory,mult,like, with_data)
- Type (CosmoTheory) Theory
- real, intent(in) :: mult, like
- logical, intent(in), optional :: with_data
- Type(ParamSet) P
- Type(CMBParams) CMB
-
-
- call CMBParamsToParams(CMB,P%P)
-
- P%Info%Theory = Theory
- if (present(with_data)) then
- if (with_data) then
- call WriteParamsAndDat(P, mult,like)
- else
- call WriteParams(P, mult,like)
- end if
- else
- call WriteParams(P, mult,like)
- end if
-
- end subroutine WriteCMBParams
-
subroutine WriteIndepSample(P, like)
Type(ParamSet) P
real like
! Type(CMBParams) C
if (indepfile_handle ==0) return
! call ParamsToCMBParams(P%P,C)
! call WriteModel(indepfile_handle, C,P%Info%Theory,like)
end subroutine WriteIndepSample
subroutine AddMPIParams(P,like, checkpoint_start)
real, intent(in) ::like
real P(:)
logical, intent(in), optional :: checkpoint_start
--- 356,373 ----
end subroutine SetProposeMatrix
subroutine WriteIndepSample(P, like)
Type(ParamSet) P
real like
!
if (indepfile_handle ==0) return
!
end subroutine WriteIndepSample
subroutine AddMPIParams(P,like, checkpoint_start)
+ use IO
+ use MAtrixUtils
real, intent(in) ::like
real P(:)
logical, intent(in), optional :: checkpoint_start
***************
*** 722,727 ****
--- 702,708 ----
#ifdef MPI
subroutine CheckLimitsConverge(L)
+ use IO
!Check limits from last half chains agree well enough across chains to be confident of result
!Slowly explored tails will cause problems (long time till stops)
Type(TList_RealArr), intent(in) :: L
diff -r -c -b -B -N cosmomc/source/params_CMB.f90 cosmomc_sampler/source/params_CMB.f90
*** cosmomc/source/params_CMB.f90 2010-05-20 12:13:02.000000000 +0200
--- cosmomc_sampler/source/params_CMB.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,336 ****
- !Parameterization using theta = r_s/D_a instead of H_0, and tau instead of z_re
- !and log(A_s) instead of A_s
- !Less general, but should give better performance
- !
- !The well-determined parameter A_s exp(-2tau) should be found by the covariance matrix
- !parameter 3 is 100*theta, parameter 4 is tau, others same as params_H except A->log(A)
- !Theta is much better constrained than H_0
- !
- !AL Jul 2005 - fixed bug which screwed up tau values for later importance sampling
- !AL Feb 2004 - fixed compiler compatibility issue with **-number, typo in zstar
- !AL Dec 2003 - renamed from params_Kowosky, changed to tau - log(A)
- !AL Sept 2003 - fixed bug in declaration of dtauda routine
- !AL June 2003
- !Assumes prior 0.4 < h < 1
-
- function CMBToTheta(CMB)
- use settings
- use cmbtypes
- use ModelParams
- use CMB_Cls
- use Precision
- implicit none
- Type(CMBParams) CMB
- double precision zstar, astar, atol, rs, DA
- double precision, external :: dsoundda, rombint
- real CMBToTheta
- integer error
-
- call InitCAMB(CMB,error,.false.)
-
- !!From Hu & Sugiyama
- zstar = 1048*(1+0.00124*CMB%ombh2**(-0.738))*(1+ &
- (0.0783*CMB%ombh2**(-0.238)/(1+39.5*CMB%ombh2**0.763)) * &
- (CMB%omdmh2+CMB%ombh2)**(0.560/(1+21.1*CMB%ombh2**1.81)))
-
- astar = 1/(1+zstar)
- atol = 1e-6
- rs = rombint(dsoundda,1d-8,astar,atol)
- DA = AngularDiameterDistance(zstar)/astar
- CMBToTheta = rs/DA
- ! print *,'z* = ',zstar, 'r_s = ',rs, 'DA = ',DA, rs/DA
-
- end function CMBToTheta
-
-
-
-
- !Mapping between array of power spectrum parameters and CAMB
- subroutine SetCAMBInitPower(P,CMB,in)
- use camb
- use settings
- use cmbtypes
- implicit none
- type(CAMBParams) P
- Type(CMBParams) CMB
-
- integer, intent(in) :: in
-
-
- if (Power_Name == 'power_tilt') then
-
- 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
- stop 'params_CMB:Wrong initial power spectrum'
- end if
-
- end subroutine SetCAMBInitPower
-
-
- subroutine SetForH(Params,CMB,H0, firsttime)
- use settings
- use cmbtypes
- use CMB_Cls
- use bbn
- implicit none
- real Params(num_Params)
- logical, intent(in), optional :: firsttime
- Type(CMBParams) CMB
- real h2,H0
-
-
- CMB%H0=H0
- if (present(firsttime)) then
- CMB%ombh2 = Params(1)
- CMB%omdmh2 = Params(2)
- CMB%zre = Params(4) !!Not actually used.. is tau in this parameterization
- CMB%Omk = Params(5)
- CMB%nufrac = Params(6)
- CMB%w = Params(7)
-
- CMB%nnu = 3.046
- if (bbn_consistency) then
- CMB%YHe = yp_bbn(CMB%ombh2,CMB%nnu - 3.046)
- else
- !e.g. set from free parameter..
- CMB%YHe = 0.24
- !call MpiStop('params_CMB: YHe not free parameter in default parameterization')
- end if
-
- CMB%InitPower(1:num_initpower) = Params(index_initpower:index_initpower+num_initPower-1)
- CMB%norm(1) = exp(Params(index_norm))
- CMB%norm(2:num_norm) = Params(index_norm+1:index_norm+num_norm-1)
- CMB%nuisance(1:num_nuisance_params) = Params(index_nuisance:index_nuisance+num_nuisance_params-1)
- end if
-
- CMB%h = CMB%H0/100
- h2 = CMB%h**2
- CMB%omnuh2 = CMB%omdmh2*CMB%nufrac
- CMB%omch2 = CMB%omdmh2 - CMB%omnuh2
- CMB%omb = CMB%ombh2/h2
- CMB%omc = CMB%omch2/h2
- CMB%omnu = CMB%omnuh2/h2
- CMB%omdm = CMB%omdmh2/h2
- CMB%omv = 1- CMB%omk - CMB%omb - CMB%omdm
-
- end subroutine SetForH
-
- subroutine ParamsToCMBParams(Params, CMB)
- use settings
- use cmbtypes
- use CMB_Cls
-
- implicit none
- real Params(num_params)
- real, save :: LastParams(num_params) = 0.
- real, save :: LastH0, Lastzre
-
- Type(CMBParams) CMB
- real DA
- real D_b,D_t,D_try,try_b,try_t, CMBToTheta, lasttry,tau
- external CMBToTheta
-
- if (all(Params(1:num_hard) == Lastparams(1:num_hard))) then
- call SetForH(Params,CMB,LastH0, .true.)
- CMB%zre = Lastzre
- CMB%reserved(1) = params(4)
- else
-
- DA = Params(3)/100
- try_b = 40
- call SetForH(Params,CMB,try_b, .true.)
- D_b = CMBToTheta(CMB)
- try_t = 100
- call SetForH(Params,CMB,try_t)
- D_t = CMBToTheta(CMB)
- if (DA < D_b .or. DA > D_t) then
- cmb%H0=0 !Reject it
- else
- lasttry = -1
- do
- call SetForH(Params,CMB,(try_b+try_t)/2)
- D_try = CMBToTheta(CMB)
- if (D_try < DA) then
- try_b = (try_b+try_t)/2
- else
- try_t = (try_b+try_t)/2
- end if
- if (abs(D_try - lasttry)< 1e-7) exit
- lasttry = D_try
- end do
-
- !!call InitCAMB(CMB,error)
- tau = params(4)
- CMB%zre = GetZreFromTau(CMB, tau)
-
- LastH0 = CMB%H0
- Lastzre = CMB%zre
- LastParams = Params
- end if
-
- CMB%reserved = 0
- CMB%reserved(1) = params(4) !tau
-
- end if
-
- end subroutine ParamsToCMBParams
-
- subroutine CMBParamsToParams(CMB, Params)
- use settings
- use cmbtypes
- implicit none
- real Params(num_Params)
- Type(CMBParams) CMB
- real CMBToTheta
- external CMBToTheta
-
- Params(1) = CMB%ombh2
- Params(2) = CMB%omdmh2
-
- Params(3) = CMBToTheta(CMB)*100
- Params(4) = CMB%reserved(1)
- Params(5) = CMB%omk
-
- Params(6) = CMB%nufrac
- Params(7) = CMB%w
- Params(index_initpower:index_initpower+num_initpower-1) =CMB%InitPower(1:num_initpower)
- Params(index_norm) = log(CMB%norm(1))
- Params(index_norm+1:index_norm+num_norm-1) = CMB%norm(2:num_norm)
- Params(index_nuisance:index_nuisance+num_nuisance_params-1)=CMB%nuisance(1:num_nuisance_params)
-
- end subroutine CMBParamsToParams
-
- subroutine SetParamNames(Names)
- use settings
- use ParamNames
- Type(TParamNames) :: Names
-
- if (ParamNamesFile /='') then
- call ParamNames_init(Names, ParamNamesFile)
- else
- if (generic_mcmc) then
- Names%nnames=0
- if (Feedback>0) write (*,*) 'edit SetParamNames in params_CMB.f90 if you want to use named params'
- else
- call ParamNames_init(Names, trim(LocalDir)//'params_CMB.paramnames')
- end if
- end if
- end subroutine SetParamNames
-
-
- subroutine WriteParams(P, mult, like)
- use settings
- use cmbtypes
- use ParamDef
- use IO
- implicit none
- Type(ParamSet) P
- real, intent(in) :: mult, like
- Type(CMBParams) CMB
- real r10
- real, allocatable :: output_array(:)
-
- if (outfile_handle ==0) return
-
- if (generic_mcmc) then
-
- call IO_OutputChainRow(outfile_handle, mult, like, P%P)
-
- else
-
- call ParamsToCMBParams(P%P,CMB)
-
- if (lmax_tensor /= 0 .and. compute_tensors) then
- r10 = P%Info%Theory%cl_tensor(10,1)/P%Info%Theory%cl(10,1)
- else
- r10 = 0
- end if
- allocate(output_array(num_real_params + 7 + nuisance_params_used ))
- output_array(1:num_real_params) = P%P(1:num_real_params)
- output_array(num_real_params+1) = CMB%omv
- output_array(num_real_params+2) = P%Info%Theory%Age
- output_array(num_real_params+3) = CMB%omdm+CMB%omb
- output_array(num_real_params+4) = P%Info%Theory%Sigma_8
- output_array(num_real_params+5) = CMB%zre
- output_array(num_real_params+6) = r10
- output_array(num_real_params+7) = CMB%H0
- if (nuisance_params_used>0) then
- output_array(num_real_params+8:num_real_params+8+nuisance_params_used-1) = &
- P%P(num_real_params+1:num_real_params+nuisance_params_used)
- end if
-
- call IO_OutputChainRow(outfile_handle, mult, like, output_array)
- deallocate(output_array)
- end if
-
- end subroutine WriteParams
-
-
-
-
- subroutine WriteParamsAndDat(P, mult, like)
- use settings
- use cmbtypes
- use ParamDef
- use IO
- implicit none
- Type(ParamSet) P
- real, intent(in) :: mult, like
- character(LEN =30) fmt
- Type(CMBParams) CMB
- real r10
- real,allocatable :: output_array(:)
-
- if (outfile_handle ==0) return
- call ParamsToCMBParams(P%P,CMB)
-
- if (lmax_tensor /= 0 .and. compute_tensors) then
- r10 = P%Info%Theory%cl_tensor(10,1)/P%Info%Theory%cl(10,1)
- else
- r10 = 0
- end if
-
- allocate(output_array(num_real_params + 7 + num_matter_power ))
- output_array(1:num_real_params) = P%P(1:num_real_params)
- output_array(num_real_params+1) = CMB%omv
- output_array(num_real_params+2) = P%Info%Theory%Age
- output_array(num_real_params+3) = CMB%omdm+CMB%omb
- output_array(num_real_params+4) = P%Info%Theory%Sigma_8
- output_array(num_real_params+5) = CMB%zre
- output_array(num_real_params+6) = r10
- output_array(num_real_params+7) = CMB%H0
- output_array(num_real_params+8:num_real_params+8+num_matter_power-1) = &
- P%Info%Theory%matter_power(:,1)
-
- call IO_OutputChainRow(outfile_handle, mult, like, output_array)
- deallocate(output_array)
-
- end subroutine WriteParamsAndDat
-
-
- function dsoundda(a)
- use Precision
- use ModelParams
-
- implicit none
- real(dl) dsoundda,dtauda,a,R,cs
- external dtauda
-
- R=3.0d4*a*CP%omegab*(CP%h0/100.0d0)**2
- cs=1.0d0/sqrt(3*(1+R))
- dsoundda=dtauda(a)*cs
-
- end function dsoundda
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/params_EXT.f90 cosmomc_sampler/source/params_EXT.f90
*** cosmomc/source/params_EXT.f90 1970-01-01 01:00:00.000000000 +0100
--- cosmomc_sampler/source/params_EXT.f90 2009-10-28 17:57:12.524467968 +0100
***************
*** 0 ****
--- 1,63 ----
+ subroutine SetParamNames(Names)
+ use settings
+ use ParamNames
+ Type(TParamNames) :: Names
+
+ if (generic_mcmc) then
+ Names%nnames=0
+ if (Feedback>0) write (*,*) 'edit SetParamNames in params_CMB.f90 if you want to use named params'
+ ! call ParamNames_init(Names, './params_EXT.paramnames')
+ end if
+ end subroutine SetParamNames
+
+
+ subroutine WriteParams(P, mult, like)
+ use settings
+ use ParamDef
+ use IO
+ implicit none
+ Type(ParamSet) P
+ real, intent(in) :: mult, like
+ real r10
+ real, allocatable :: output_array(:)
+
+ if (outfile_handle ==0) return
+
+ if (generic_mcmc) then
+
+ call IO_OutputChainRow(outfile_handle, mult, like, P%P)
+
+ else
+
+ stop
+
+ end if
+
+ end subroutine WriteParams
+
+
+
+
+ subroutine WriteParamsAndDat(P, mult, like)
+ use settings
+ use ParamDef
+ use IO
+ implicit none
+ Type(ParamSet) P
+ real, intent(in) :: mult, like
+ character(LEN =30) fmt
+ real r10
+ real,allocatable :: output_array(:)
+
+ if (outfile_handle ==0) return
+
+ allocate(output_array(num_real_params))
+ output_array(1:num_real_params) = P%P(1:num_real_params)
+
+ call IO_OutputChainRow(outfile_handle, mult, like, output_array)
+ deallocate(output_array)
+
+ end subroutine WriteParamsAndDat
+
+
+
diff -r -c -b -B -N cosmomc/source/postprocess.f90 cosmomc_sampler/source/postprocess.f90
*** cosmomc/source/postprocess.f90 2009-12-09 18:15:48.000000000 +0100
--- cosmomc_sampler/source/postprocess.f90 2010-05-27 16:16:13.553017514 +0200
***************
*** 7,15 ****
module posthoc
use settings
- use cmbtypes
- use CMB_Cls
- use cmbdata
use CalcLike
implicit none
--- 7,12 ----
***************
*** 71,287 ****
subroutine postprocess(InputFile)
use IO
character(LEN=*), intent(INOUT):: InputFile
- Type(CMBParams) LastCMB,CMB, newCMB
- Type(CosmoTheory) Theory, CorrectTheory
- Type(ParamSetInfo) Info
- real Cls(lmax,num_cls_tot), truelike,mult,like
- real weight_min, weight_max, mult_sum, mult_ratio, mult_max,weight
! real max_like, max_truelike
! integer error,num, debug
! character (LEN=120) :: post_root
! real Params(num_params)
! integer infile_handle, outdata_handle
!
! flush_write = .false.
! weight_min= 1e30
! weight_max = -1e30
! mult_sum = 0
! mult_ratio = 0
! mult_max = -1e30
! max_like = 1e30
!
! max_truelike =1e30
!
! debug = 0
! Info%Theory%Sn_LogLike = 0
! Info%Theory%HST_LogLike = 0
! Info%Theory%BAO_LogLike = 0
!
! infile_handle = 0
! Temperature = PostParams%redo_temperature
!
! if (Feedback>0 .and. PostParams%redo_change_like_only) &
! write (*,*) 'Warning: only changing likelihoods not weights'
!
! if (PostParams%redo_datafile /= '') InputFile = PostParams%redo_datafile
!
! if (PostParams%redo_from_text) then
!
! infile_handle = IO_OpenChainForRead(trim(InputFile)//'.txt')
!
! if (.not. PostParams%redo_theory) write (*,*) '**You probably want to set redo_theory**'
! if (.not. PostParams%redo_cls .and. Use_CMB) write (*,*) '**You probably want to set redo_cls**'
! if (.not. PostParams%redo_pk .and. Use_mpk) write (*,*) '**You probably want to set redo_pk**'
!
! if (PostParams%redo_thin>1) write (*,*) 'redo_thin only OK with redo_from_text if input weights are 1'
!
! else
! infile_handle = IO_OpenDataForRead(trim(InputFile)//'.data')
! end if
!
!
! if (PostParams%redo_outroot == '') then
! post_root = trim(ExtractFilePath(InputFile))//'post_'// trim(ExtractFileName(InputFile))
! else
! post_root = PostParams%redo_outroot
! if (instance /= 0) post_root = numcat(trim(post_root)//'_',instance)
! end if
!
! if (Feedback > 0) then
! if (PostParams%redo_from_text) then
! write (*,*) 'reading from: ' // trim(InputFile)//'.txt'
! else
! write (*,*) 'reading from: ' // trim(InputFile)//'.data'
! end if
! write (*,*) 'writing to: ' // trim(post_root)//'.*'
! end if
!
! write (*,*) 'Using temperature: ', Temperature
!
! outfile_handle = IO_OutputOpenForWrite(trim(post_root)//'.txt')
!
! outdata_handle = IO_DataOpenForWrite(trim(post_root)//'.data')
!
! num = 0
! do
!
! if (PostParams%redo_from_text) then
! error = 0
! if (.not. IO_ReadChainRow(infile_handle, mult, like, Params, num_params)) exit
! call ParamsToCMBParams(Params, CMB)
!
! else
! call ReadModel(infile_handle,CMB,Theory,mult,like, error)
! end if
!
!
! if (error ==1) then
! if (num==0) call MpiStop('Error reading data file.')
!
! exit
! end if
! num=num+1
! if (num>PostParams%redo_skip .and. mod(num,PostParams%redo_thin) == 0) then
!
! LastCMB = CMB
!
! newCMB = CMB
! if (PostParams%redo_theory) then
!
! call GetClsInfo(newCMB, CorrectTheory, error, PostParams%redo_cls, PostParams%redo_pk)
!
! if (PostParams%redo_cls) then
! Theory%cl = CorrectTheory%cl
! Theory%cl_tensor = CorrectTheory%cl_tensor
! !!In last version redo_cls just for going to higher l on temperature
!
! end if
!
! if (PostParams%redo_pk) then
! Theory%sigma_8 = CorrectTheory%sigma_8
! Theory%Matter_Power = CorrectTheory%Matter_Power
! end if
!
! Theory%Age = CorrectTheory%Age
!
! else
! error = 0
! end if
!
!
! CorrectTheory = Theory
!
!
! if (error ==0) then
!
! if (PostParams%redo_like) then
!
!
! if (Use_LSS .and. CorrectTheory%sigma_8==0) &
! call MpiStop('Matter power/sigma_8 have not been computed. Use redo_theory and redo_pk.')
!
!
! call ClsFromTheoryData(CorrectTheory, newCMB, Cls)
! Info%Theory = CorrectTheory
!
! if (any(Cls(2:lmax,1) < 0)) then
! write (*,*) 'WARNING: bad model with C_l < 0 being rejected'
! write (*,*) 'in '//trim(InputFile)
! !This shouldn't happen.
! !But good sanity check, esp when playing around with extended models
! !Think have fixed problems with Om_k \sim -7e-4, w\sim -0.7.
! write (*,*) newCMB
! write (*,*)
! truelike = logZero
! else
! truelike = GetLogLikePost(newCMB, Info, Cls,.true.)
! end if
! if (truelike == logZero) then
! weight = 0
! else
! if (PostParams%redo_add) truelike = like + truelike
!
! weight = exp(like-truelike+PostParams%redo_likeoffset)
! end if
!
! if (.not. PostParams%redo_change_like_only) mult = mult*weight
! else
! truelike = like
! weight = 1
! end if
!
!
! max_like = min(max_like,like)
!
! max_truelike = min(max_truelike,truelike)
!
! mult_ratio = mult_ratio + weight
! mult_sum = mult_sum + mult
!
! if (mult /= 0) then
! call WriteCMBParams(newCMB, CorrectTheory, mult, truelike,txt_theory)
! call WriteModel(outdata_handle, newCMB, CorrectTheory,truelike,mult)
!
! else
!
! if (Feedback >1 ) write (*,*) 'Zero weight: new like = ', truelike
! end if
!
! if (Feedback > 1) write (*,*) 'done ', num, 'mult= ', mult,' weight = ', weight
! weight_max = max(weight,weight_max)
! weight_min = min(weight,weight_min)
! mult_max = max(mult_max,mult)
!
! end if
! end if
!
! end do
!
! call IO_Close(infile_handle)
! call IO_Close(outfile_handle)
! call IO_DataCloseWrite(outdata_handle)
!
! num = (num - PostParams%redo_skip) / PostParams%redo_thin
! if (Feedback>0) then
! write(*,*) 'finished. Processed ',num,' models'
! write (*,*) 'max weight= ',weight_max, ' min weight = ',weight_min
! write (*,*) 'mean mult = ', mult_sum/num
! write (*,*) 'mean importance weight (approx evidence ratio) = ',mult_ratio/num
! write (*,*) 'effective number of samples =',mult_sum/mult_max
! write (*,*) 'Best redo_likeoffset = ',max_truelike - max_like
! end if
!
! if ((mult_ratio < 1e-6 .or. mult_ratio > 1e8) &
!
! .and. .not.PostParams%redo_change_like_only) then
!
! write (*,*) 'WARNING: use redo_likeoffset to rescale likelihoods'
! end if
!
!
!
! return
end subroutine postprocess
--- 68,75 ----
subroutine postprocess(InputFile)
use IO
character(LEN=*), intent(INOUT):: InputFile
! stop 'postprocess not implemented!'
end subroutine postprocess
diff -r -c -b -B -N cosmomc/source/SDSSLy-a-v3.f90 cosmomc_sampler/source/SDSSLy-a-v3.f90
*** cosmomc/source/SDSSLy-a-v3.f90 2006-10-05 01:22:56.000000000 +0200
--- cosmomc_sampler/source/SDSSLy-a-v3.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,277 ****
- ! Module for using SDSS McDonald et al. (2004) Ly-alpha data
-
- ! NOTE: Not valid in growth function calculation for dark matter equations
- ! of state away from -1;
- ! also, this does not use alpha (running) information from McDonald chi^2 table
-
- ! If using SDSS Ly-alpha data: cite
- ! P.~McDonald {\it et al.},
- ! %``The Linear Theory Power Spectrum from the Lyman-alpha Forest in the Sloan
- ! %Digital Sky Survey,''
- ! arXiv:astro-ph/0407377.
-
- ! implemented for CosmoMC by Kevork Abazajian
-
- ! AL: note requires *linear* power spectrum input
- ! AL: April 2006: added assumption violation traps
-
- module Lya
- use settings
- use cmbtypes
- use Precision
- implicit none
-
- !Note all units are in k/h here
- logical :: Use_Lya = .false.
-
-
- integer, parameter :: c_lya_points = 12
-
- logical, parameter :: use_sdsslyaP = .true.
-
- integer, parameter :: n_SDSSLya = 41
-
- real(dl) :: SDSSLya_delta(n_SDSSLya)
- real(dl) :: SDSSLya_neff(n_SDSSLya)
- real(dl) :: SDSSLya_chi2(n_SDSSLya,n_SDSSLya)
- real(dl) :: SDSSLya_chi2a(n_SDSSLya,n_SDSSLya)
-
- real :: kh_pts0(c_lya_points),pk_pts0(c_lya_points),err_pts0(c_lya_points),z_pts
-
- logical :: do_lya_init = .true.
- real(dl) :: ommpass,omlpass
- real :: lya_kmax = 1.5
- real(dl) :: z_SDSSP,kh_SDSSP,minSDSSPchi
- contains
-
- function dgrowth(zz)
- real(dl) dgrowth
- real(dl) zz
-
- dgrowth = (1.d0+zz)/((ommpass*(1.d0+zz)**3+omlpass)**1.5d0)
-
- end function dgrowth
-
-
- subroutine lya_init
- integer i,j
- real temp
- if (Feedback > 0) write(*,*) 'reading: SDSS Ly-alpha data'
-
- if(use_SDSSLyaP)then
- minSDSSPchi = 1.d30
- z_SDSSP = 3.d0
- kh_SDSSP = 0.009d0
- call OpenTxtFile('data/SDSSPlyachi2.txt', tmp_file_unit)
- do i=1,n_SDSSLya
- do j=1,n_SDSSLya
- read(tmp_file_unit,*)SDSSLya_delta(i),SDSSLya_neff(j),temp,SDSSLya_chi2(i,j)
- if(SDSSLya_chi2(i,j)>0.)minSDSSPchi = min(SDSSLya_chi2(i,j),minSDSSPchi)
- end do
- end do
-
- if (Feedback > 0) write(*,*) 'done reading: SDSS Ly-alpha data'
-
- call splie2(SDSSLya_delta,SDSSLya_neff,SDSSLya_chi2,n_SDSSLya,n_SDSSLya,SDSSLya_chi2a)
- end if
- if (Feedback > 0) write(*,*) 'done reading: SDSS Ly-alpha data'
-
- do_lya_init = .false.
-
- end subroutine lya_init
-
-
- function LSS_Lyalike(CMB, Theory)
- Type (CMBParams) CMB
- Type (CosmoTheory) Theory
- real LSS_Lyalike
-
- real hubz,h,omm,oml
- real logdelta,normf
- real(dl) chi2
- real(dl) delta,neff
-
- real D0,D2,khlya,pk0,lnkhlya1,lnkhlya2,lnpk1,lnpk2
-
- real(dl) rombint
- external rombint
-
- if (do_lya_init) then
- call lya_init
- endif
-
- if (CMB%W /= -1. .or. CMB%omnu/=0. .or. CMB%InitPower(3)/= 0.) then
- write (*,*) 'This SDSS Lya module does not support extended models'
- write (*,*) 'for extensions see http://www.slosar.com/aslosar/lya.html'
- stop
- end if
-
-
- omm = CMB%omc+CMB%omb+CMB%omnu
- oml = CMB%omv
- h = CMB%H0/100.
-
- ommpass = omm
- omlpass = oml
- D0 = rombint(dgrowth,0.d0,10000.d0,1.d-6) !5 omm / 2 not needed since only want ratio
- LSS_Lyalike = 0.
-
- if(use_sdsslyaP)then ! use pt. slope
-
- normf = 1./(19.739209) ! 1/(2*pi**2)
-
- hubz= CMB%H0*sqrt(omm*(1.+z_SDSSP)**3+oml)
-
- D2 = (hubz/CMB%H0*rombint(dgrowth,z_SDSSP,10000.d0,1.d-6)/D0)**2 ! Note: not valid for w.ne.-1
-
- khlya = kh_SDSSP * hubz/h/(1.+z_SDSSP)
- pk0 = MatterPowerAt(Theory,khlya)*D2
- lnkhlya1 = log(khlya)*0.99
- lnkhlya2 = log(khlya)*1.01
- lnpk1 = log(MatterPowerAt(Theory,exp(lnkhlya1))*D2)
- lnpk2 = log(MatterPowerAt(Theory,exp(lnkhlya2))*D2)
- neff = (lnpk2-lnpk1)/(lnkhlya2-lnkhlya1)
-
- delta = (pk0*khlya**3*normf)
-
- neff = (lnpk2-lnpk1)/(lnkhlya2-lnkhlya1)
-
- call splin2(SDSSLya_delta,SDSSLya_neff,SDSSLya_chi2,SDSSLya_chi2a,n_SDSSLya,n_SDSSLya &
- ,delta,neff,chi2)
-
- if(chi2= xx(1))
- jl=0
- ju=n+1
- do
- if (ju-jl <= 1) exit
- jm=(ju+jl)/2
- if (ascnd .eqv. (x >= xx(jm))) then
- jl=jm
- else
- ju=jm
- end if
- end do
- if (x == xx(1)) then
- locate=1
- else if (x == xx(n)) then
- locate=n-1
- else
- locate=jl
- end if
- END FUNCTION locate
-
- end module Lya
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/settings.f90 cosmomc_sampler/source/settings.f90
*** cosmomc/source/settings.f90 2010-05-19 13:23:38.000000000 +0200
--- cosmomc_sampler/source/settings.f90 2010-05-27 16:15:34.963456422 +0200
***************
*** 43,49 ****
real, parameter :: cl_norm = 1e-10 !units for As
! logical, parameter :: generic_mcmc= .false.
!set to true to not call CAMB, etc.
!write GenericLikelihoodFunction in calclike.f90
--- 43,49 ----
real, parameter :: cl_norm = 1e-10 !units for As
! logical, parameter :: generic_mcmc= .true.
!set to true to not call CAMB, etc.
!write GenericLikelihoodFunction in calclike.f90
diff -r -c -b -B -N cosmomc/source/sn_sdss_parser.f90 cosmomc_sampler/source/sn_sdss_parser.f90
*** cosmomc/source/sn_sdss_parser.f90 2009-10-22 13:22:29.000000000 +0200
--- cosmomc_sampler/source/sn_sdss_parser.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,721 ****
- ! A parser for SDSS Supernovae FITRES
- ! Wessel Valkenburg, LAPTH, 2009
- ! E-mail: wessel.valkenburg@lapp.in2p3.fr
- !
- !
- ! Usage:
- ! "use sn_sdss_parser"
- !
- ! declare a structure of type sdssdata (already publicly defined in this module)
- ! e.g.
- ! "type(sdssdata) :: thisdata"
- !
- ! then simply call GetSDSSSN
- ! "call GetSDSSSN('a', thisdata)"
- !
- ! where a can be any single character a,b,c,d,e or f, specifying the subset of SNe:
- ! a: SDSS only
- ! b: SDSS+ESSENCE+SNLS
- ! c: LOWZ+SDSS
- ! d: LOWZ+SDSS+ESSENCE+SNLS
- ! e: LOWZ+SDSS+ESSENCE+SNLS+HST
- ! f: LOWZ+ESSENCE+SNLS
- !
- ! or
- ! "call GetSDSSSN('1 3 4 50 100', thisdata)"
- ! with any space-seperated list of arbitrary selectrion of the following id's:
- !
- ! 1 = SDSS
- ! 3 = ESSE
- ! 4 = SNLS
- ! 50 = Nearby
- ! 100 = HST
- !
- ! eg. 'e' is equivalent to '1 3 4 50 100'
- !
- ! the structure thisdata will be allocated and returned containing
- ! thisdata%z(:) - redshift
- ! thisdata%zerr(:) - error in redshift
- ! thisdata%mu(:) - apparent brightness
- ! thisdata%muerr(:) - error on brightness
- ! thisdata%sigint(:) - intrinsic error
- !
- ! all these arrays will have exactly the size that corresponds to the number of SNe
- ! in the chosen subset.
- !
- !!
- !AL sept 09: changed not to use non-standard allocatable arrays in derived types
- ! .dataset read using standard INI framework
- module sn_sdss_parser
- use AmlUtils
- use IniFile
- implicit none
- private
-
- logical :: sdss_sn_ini = .false.
- integer, parameter :: maxit = 10000, sn_len=128, sn_head=32, sn_dlen=Ini_max_string_len
- integer, parameter :: dp=KIND(1.d0)
- ! character(len=32), parameter :: sntag(3)=/'NVAR:','VARNAMES:','SN:'/
-
- type ReallocArray2
- real(dp), dimension(:,:), pointer :: Arr
- end type ReallocArray2
-
- type sdssvars
- character(len=sn_dlen) :: filename(2)
- character(len=sn_head) :: tagnvar, tagvarnames, tagsn, subset
- character(len=sn_head), pointer :: colnames(:)
- character(len=1) :: presets(6)
- integer :: ntags, telids(10), set
- real(dp), pointer :: sdss_sigint(:)
- end type sdssvars
- type(sdssvars) :: sv
-
- type sdssdata
- real(dp), pointer :: mu(:), muerr(:), z(:), sigint(:), sigz(:)
- end type sdssdata
-
- public GetSDSSSn, sdssdata
-
- contains
-
- subroutine GetSDSSSn(thisfilename, thedata, feedback)
- character(len=*) :: thisfilename
- ! character(len=sn_head) :: thissubset, thissubsetb
- ! integer :: thisset, thissetb
- integer :: feedback
- type(sdssdata) :: thedata
- character(len=128) :: mystring
-
- call ReadSDSSdataset(thisfilename)
-
- ! thissubsetb = thissubset
- ! thissetb = thisset
- call InitializeSN(sv%set, sv%subset)
-
-
- call ReadSDSSSN(sv%set, sv%subset, thedata)
-
- ! Feedback which telescopes are uesd.
- if(feedback>0)then
- write(*,*)'Reading: '//trim(adjustl(sv%filename(sv%set)))
- write(mystring,*)size(thedata%z)
- mystring = 'Using '//trim(adjustl(mystring))//' SNe'
- mystring = trim(adjustl(mystring))//' from subset '
- if(any(sv%telids.eq.1))mystring = trim(adjustl(mystring))//' SDSS +'
- if(any(sv%telids.eq.3))mystring = trim(adjustl(mystring))//' ESSENCE +'
- if(any(sv%telids.eq.4))mystring = trim(adjustl(mystring))//' SNLS +'
- if(any(sv%telids.eq.50))mystring = trim(adjustl(mystring))//' LOWZ +'
- if(any(sv%telids.eq.100))mystring = trim(adjustl(mystring))//' HST +'
- mystring=mystring(1:len(trim(mystring))-2)//' '
- write(*,*)trim(adjustl(mystring))//'.'
- end if
-
- end subroutine GetSDSSSn
-
-
- subroutine InitializeSN(thisset, thissubset)
- implicit none
- character :: mychar
- character(len=*) :: thissubset
- integer :: ntel, thisset, maxtel
-
-
- if(sdss_sn_ini)stop 'Calling InitializeSN more than once.'
-
- ! All in upper case
- sv%tagnvar = 'NVAR:'
- sv%tagvarnames = 'VARNAMES:'
- sv%tagsn = 'SN:'
-
- ! These are the names of the columns, where MU gets the extra character that is the input in
- ! GetSDSSSn('x',...). That is, the actual column becomes sv%colnames(2)//'x'. If this is
- ! not present in your file, then input ' ' in stead of 'x'.
-
- sv%ntags=5
-
- allocate(sv%colnames(sv%ntags))
-
- sv%colnames(1) = 'Z'
- sv%colnames(2) = 'MU'
- sv%colnames(3) = 'MUERR'
- sv%colnames(4) = 'ZERR'
- sv%colnames(5) = 'IDTEL'
-
- ! If SALT-II, then:
- ! attach 'e' because we want the column that contains just all the data.
- ! We then select the proper telescopes for our subset ourselves, as the
- ! a - f subsets are hardcoded in the next lines.
- if (thisset .eq.2) then
- sv%colnames(2) = trim(adjustl(sv%colnames(2))) //'E'
- sv%colnames(3) = trim(adjustl(sv%colnames(3))) //'E'
- end if
-
- ! interpret thisset:
- thissubset = adjustl(thissubset)
- sv%telids = 0
- sv%presets(:)=(/'a','b','c','d','e','f'/)
-
- mychar = thissubset(1:1)
- if(ichar(thissubset(1:1)).lt.58)then ! then it's a number
- ntel = CountItemsIn(trim(adjustl(thissubset)))
- read(thissubset,*)sv%telids(1:ntel)
- else if (any(thissubset(1:1).eq.sv%presets))then
- if(thissubset(1:1).eq.'a')sv%telids(1)=1
- if(thissubset(1:1).eq.'b')sv%telids(1:3)=(/1,3,4/)
- if(thissubset(1:1).eq.'c')sv%telids(1:2)=(/1,50/)
- if(thissubset(1:1).eq.'d')sv%telids(1:4)=(/1,3,4,50/)
- if(thissubset(1:1).eq.'e')sv%telids(1:5)=(/1,3,4,50,100/)
- if(thissubset(1:1).eq.'f')sv%telids(1:3)=(/3,4,50/)
- else
- stop 'No subset defined for sn_sdss!'
- end if
-
-
- ! set intrinsic uncertainty for this dataset
- maxtel = 100 ! highest telesope id
- ! if(allocated(sv%sdss_sigint))deallocate(sv%sdss_sigint)
- allocate(sv%sdss_sigint(1:maxtel))
-
- ! As specified in arXiv:0908.4274v1
- ! table 11 for SALT and paragraph 8.1 for MLCS
-
- if(thisset.eq.1)then ! MLCS
- sv%sdss_sigint = 0.16 ! use same intrinsic error for all telescopes
- else if (thisset .eq.2) then !SALT-II
- sv%sdss_sigint = 0.d0
- sv%sdss_sigint(1) = 0.09 ! SDSS
- sv%sdss_sigint(3) = 0.13 ! ESSENCE
- sv%sdss_sigint(4) = 0.16 ! SNLS
- sv%sdss_sigint(50) = 0.16 ! LOWZ
- sv%sdss_sigint(100) = 0.15 ! HST
- else
- stop 'Need to define intrinsic errors for this set.'
- end if
- sdss_sn_ini = .true.
-
-
- end subroutine InitializeSN
-
-
- ! Open the actual file and process it, returns thedata containing
- ! only the SNe from subset of nset.
- subroutine ReadSDSSSN(nset, thisset, thedata)
- character(len=512) :: thisline
- character(len=sn_head) :: thistag, thisfmt, thisname
- character(len = 1) :: thisset
- integer :: fnum,nset,myiostat
- logical :: snexist
-
- integer :: nvar, i
- Type(ReallocArray2) ::sdss_file
- character(len=sn_head), allocatable :: header(:)
-
- type(sdssdata) :: thedata
-
- fnum=NewIONum()
-
- inquire(file=sv%filename(nset),exist=snexist)
- if(.not.snexist)then
- write(*,*)'File '//trim(sv%filename(nset))//' not found. ABORTING.'
- stop 'File not found.'
- end if
- open(fnum, file=sv%filename(nset), status='OLD', iostat=myiostat)
-
-
- ! First get nvar
- myiostat=0
- Do while (myiostat.eq.0)
-
- read(fnum,'(A)',iostat=myiostat)thisline
-
- if(myiostat.ne.0)then
- write(*,*)'Tag '//trim(sv%tagnvar)//' not found in file '//trim(sv%filename(nset))//' not found. ABORTING.'
- stop 'Tag not found.'
- end if
-
- thisline=trim(adjustl(thisline))
- thistag = thisline(1:len(trim(sv%tagnvar)))
- call s_cap(thistag)
- if(trim(thistag).eq.sv%tagnvar)then
- call RemoveExp(thisline,trim(sv%tagnvar))
- read(thisline,*)nvar
- exit
- end if
- end Do
-
-
- ! Get header
- allocate(header(nvar))
- myiostat=0
- Do while (myiostat.eq.0)
- read(fnum,'(A)',iostat=myiostat)thisline
- if(myiostat.ne.0)then
- write(*,*)'Tag '//trim(sv%tagvarnames)//' not found in file '//trim(sv%filename(nset))//' not found. ABORTING.'
- stop 'Tag not found.'
- end if
- thisline=trim(adjustl(thisline))
- thistag =thisline(1:len(trim(sv%tagvarnames)))
- call s_cap(thistag)
- if(trim(thistag).eq.trim(sv%tagvarnames))then
- call RemoveExp(thisline,trim(sv%tagvarnames))
- read(thisline,*)header(:)
- exit
- end if
- end Do
-
- ! make header data uppercase:
- do i=1,nvar
- call s_cap(header(i))
- end do
-
- ! We could make the code more flexible
- ! in order to deal with CID in any other column,
- ! but why bother...
- if(trim(adjustl(header(1))).ne.'CID')then
- stop 'Wrong file layout: first column must be SN:, second column CID.'
- end if
- ! anticipate the ignoring of the CID, the real array sdss_file starts
- ! at second column in stead of first.
- header=header(2:)
- header(size(header))=''
-
-
- ! Get data
- call AllocDble(sdss_file,nvar-1)
- myiostat=0
- i=0
- Do while (myiostat .eq.0)
- read(fnum,'(A)',iostat=myiostat)thisline
- if(myiostat.ne.0)exit
- thisline=trim(adjustl(thisline))
-
-
- ! ignore lines that do not start with 'SN:'
- if(thisline(1:len(trim(sv%tagsn))).eq.sv%tagsn)then
-
- i=i+1
- ! check array size, if necessary increase
- if(i.gt.size(sdss_file%arr(1,:)))call IncreaseDble(sdss_file)
-
- call RemoveExp(thisline,trim(sv%tagsn))
- read(thisline,*)thisname,sdss_file%arr(:,i)
- end if
-
- end Do
-
- call TrimDble(sdss_file,i)
-
- call TranslateSDSS(thisset, header, sdss_file, thedata)
-
-
- deallocate(header)
- deallocate(sdss_file%arr)
-
- end subroutine ReadSDSSSN
-
-
- ! Go from full fitres file to only interesting columns
- ! from subset.
- subroutine TranslateSDSS(thissetd, header, sdss_file, thedata)
- implicit none
- character(len=1) :: thissetd, thissetabc
- character(len=sn_head) :: header(:), tags(sv%ntags)
- Type(ReallocArray2) :: sdss_file
- type(sdssdata) :: thedata
- integer :: i,j, totsn, setsn, tagn(sv%ntags)
-
- thissetabc=thissetd
- call s_cap(thissetabc)
-
- tags(1) = trim(adjustl(sv%colnames(1)))
- tags(2) = trim(adjustl(sv%colnames(2)))
- tags(3) = trim(adjustl(sv%colnames(3)))
- ! we are taking set 'thisset', that is MUA, or MUB, or MUC etc..
- tags(4) = trim(adjustl(sv%colnames(4)))
- tags(5) = trim(adjustl(sv%colnames(5)))
-
-
- ! get column number of tags:
- tagn=0
- do i=1,size(header)
- do j=1,sv%ntags
- if(trim(adjustl(header(i))).eq.trim(adjustl(tags(j))))tagn(j)=i
- end do
- end do
- if(any(tagn.eq.0))stop 'Tags not found in translatesdss (in sn_sdss_parser.f90).'
-
- ! count SN in set:
- totsn =size(sdss_file%arr(1,:))
- setsn=0
-
- do i=1,totsn
- if(any(int(sdss_file%arr(tagn(5),i)+0.001).eq.sv%telids))setsn=setsn+1
- end do
-
-
- ! if(allocated(thedata%z))deallocate(thedata%z)
- ! if(allocated(thedata%mu))deallocate(thedata%mu)
- ! if(allocated(thedata%muerr))deallocate(thedata%muerr)
- ! if(allocated(thedata%sigint))deallocate(thedata%sigint)
- ! if(allocated(thedata%sigz))deallocate(thedata%sigz)
- allocate(thedata%z(setsn))
- allocate(thedata%mu(setsn))
- allocate(thedata%muerr(setsn))
- allocate(thedata%sigint(setsn))
- allocate(thedata%sigz(setsn))
-
- j=0
- do i=1,totsn
-
- ! if(sdss_file(tagn(2),i).gt.-8.9999)then
- if(any(int(sdss_file%arr(tagn(5),i)+0.001).eq.sv%telids))then
- j=j+1
- thedata%z(j)=sdss_file%arr(tagn(1),i)
- thedata%mu(j)=sdss_file%arr(tagn(2),i)
- thedata%muerr(j)=sdss_file%arr(tagn(3),i)
- thedata%sigz(j)=sdss_file%arr(tagn(4),i)
- thedata%sigint(j)=sv%sdss_sigint(int(sdss_file%arr(tagn(5),i)+0.001))
- end if
-
- end do
-
- if(j.ne.setsn) stop 'There is a bug in the code, TranslateSDSS in sn_sdss_parser.f90.'
-
- end subroutine TranslateSDSS
-
- ! Allocate a double precision array with two indices
- subroutine AllocDble(A,somesize1)
- Type(ReallocArray2) :: A
- integer :: somesize1
-
- !if(associated(A%arr))deallocate(A%arr)
- allocate(A%arr(somesize1,sn_len))
-
- end subroutine AllocDble
-
- ! Increase the size in second index of a double precision array with two indices
- subroutine IncreaseDble(A)
- Type(ReallocArray2) :: A
- real(dp), allocatable :: arr2(:,:)
- integer :: arrsize(2)
-
- arrsize(1) = size(A%arr(:,1))
- arrsize(2) = size(A%arr(1,:))
- allocate(arr2(arrsize(1),arrsize(2)))
- arr2=A%arr
- deallocate(A%arr)
- allocate(A%arr(arrsize(1),arrsize(2)+sn_len))
- A%arr=0
- A%arr(:,1:arrsize(2))=arr2(:,:)
-
- deallocate(arr2)
- end subroutine IncreaseDble
-
- ! Trim in second index of a double precision array with two indices to size 'finsize'
- subroutine TrimDble(A,finsize)
- Type(ReallocArray2) :: A
- real(dp), allocatable :: arr2(:,:)
- integer, optional :: finsize
- integer :: arrsize(2)
-
- if(.not.present(finsize))call fatalerror('TrimSing called without final size. Faulty code.')
-
- arrsize(1) = size(A%arr(:,1))
- arrsize(2) = size(A%arr(1,:))
- allocate(arr2(arrsize(1),arrsize(2)))
- arr2=A%arr
- deallocate(A%arr)
- allocate(A%arr(arrsize(1),finsize))
- A%arr=0
- A%arr=arr2(:,1:finsize)
-
- deallocate(arr2)
- end subroutine TrimDble
-
- ! return a free io-number for file-io
- function NewIONum()
- integer :: NewIONum, i
- logical :: notfree
-
- notfree = .true.
- i=20
-
- do while (notfree)
- i=i+1
- inquire(i,opened=notfree)
- if(i.gt.maxit)call FatalError('NewIONum could not find free filenumber.')
- end do
- NewIONum = i
-
- endfunction NewIONum
-
- ! open existing file for append, or create if nonexistent.
- subroutine OpenAppend(fnum,fname)
- character(len=*) :: fname
- integer :: fnum
- logical fpresent
-
- inquire(file=trim(adjustl(fname)),exist=fpresent)
-
- if(fpresent)then
- open(fnum,file=fname,status='OLD',access='APPEND')
- else
- open(fnum,file=fname,status='NEW')
- end if
-
- end subroutine OpenAppend
-
-
- ! split string into two pieces, first half goes into word, second half
- ! into string. Split point is set by 'seperator', which itself is thrown away
- subroutine split(string,word,seperator)
- character(len=*)::string,word,seperator
- integer :: i,sep
-
- string = adjustl(string)
- sep = len(seperator)-1
- do i = 1,len(trim(string))!+2
- if(string(i:i+sep).eq.seperator)then
- word=trim(string(1:i-1))
- string=trim(string(i+sep+1:))
- exit
- end if
- enddo
- end subroutine split
-
- ! Remove an expression from string.
- subroutine RemoveExp(string,seperator)
- character(len=*)::string,seperator
- integer :: i,sep
-
- !string = adjustl(string)
- sep = len(seperator)
- do i = 1,len(trim(string))-sep+1
- if(string(i:i+sep-1).eq.seperator)then
- if(i.gt.1)then
- string=string(:i-1)//trim(string(i+sep:))
- else
- string=trim(string(i+sep:))
- end if
- end if
- enddo
- end subroutine RemoveExp
-
- ! Replace expression 'seperator' in 'string' by 'word'.
- subroutine ReplaceExp(string,seperator,word)
- character(len=*)::string,seperator,word
- integer :: i,sep,j
-
- !if(seperator.eq.'%fnumber')then
- !debug=.false.
- !else
- !debug=.false.
- !end if
- !string = adjustl(string)
- sep = len(seperator)
- i=0
- j=0
- do
- i=i+1
- j=j+1
- ! if(debug)write(*,*)string(i:i+sep-1),',',seperator
- if(string(i:i+sep-1).eq.seperator)then
- ! if(debug)then
- ! write(*,*)'Whoopie!'
- !write(*,*)'----------------------------------------------------------'
- ! write(*,*)string(:i-1)
- !write(*,*)'----------------------------------------------------------'
- ! write(*,*)adjustl(word)
- !write(*,*)'----------------------------------------------------------'
- ! write(*,*)string(i+sep:)
- !write(*,*)'----------------------------------------------------------'
- !stop
- ! end if
- if(i.gt.1)then
- string=string(:i-1)//adjustl(word)//string(i+sep:)
- else
- string=adjustl(word)//string(i+sep:)
- end if
- if (sep.ne.len(word)) i=i+len(word)-sep
- end if
- if (i .ge. len(trim(string))-sep+1) exit
- if (j.gt. 1000*len(string))call fatalerror('ReplaceExp is hanging.')
- enddo
- end subroutine ReplaceExp
-
- ! Grab expression surrounded by initag and endtag in string.
- ! Result is word.
- ! Stops is tags are not found.
- subroutine GetFromTags(string,word,initag,endtag)
- character(len=*), intent(in) :: string
- character(len=len(string)) :: mystring1, mystring2
- character(len=*), intent(out) :: word
- character(len=*), intent(in) :: initag
- character(len=*), intent(in) :: endtag
-
- mystring1 = string
-
- mystring2=''
- call split(mystring1,mystring2,initag)
- if(len(trim(mystring2)).eq.0)then
- write(*,*)'Tag '//trim(adjustl(initag))//' not found.'
- stop 'Tag not found (GetFromTags in sn_sdss_parser).'
- end if
-
- mystring2=''
- call split(mystring1,mystring2,endtag)
- if(len(trim(mystring2)).eq.0)then
- write(*,*)'Tag '//trim(adjustl(initag))//' not found.'
- stop 'Tag not found (GetFromTags in sn_sdss_parser).'
- end if
-
- word = trim(adjustl(mystring2))
-
- end subroutine GetFromTags
-
-
- ! Count the number of space-separated items in mystr
- function CountItemsIn(mystr)
- implicit none
- integer :: CountItemsIn, i, j
- character(len=*) :: mystr
-
- j=0
- do i=1,len(mystr)
- if(mystr(i:i).eq.' ')then
- if(i.eq.1)then
- j=j+1
- else if((i.gt.1).and.(mystr(i-1:i-1).ne.' '))then
- j=j+1
- end if
- end if
- end do
- CountItemsIn = j + 1
-
- end function CountItemsIn
-
- ! subroutine ch_cap taken from chrpak at
- ! http://orion.math.iastate.edu/burkardt/f_src/chrpak/chrpak.html
- ! at 08/09/2009
- subroutine ch_cap ( c )
- !
- !*******************************************************************************
- !
- !! CH_CAP capitalizes a single character.
- !
- !
- ! Modified:
- !
- ! 19 July 1998
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input/output, character C, the character to capitalize.
- !
- implicit none
- !
- character c
- integer itemp
- !
- itemp = ichar ( c )
-
- if ( 97 <= itemp .and. itemp <= 122 ) then
- c = char ( itemp - 32 )
- end if
-
- return
- end subroutine ch_cap
-
-
- ! subroutine ch_cap taken from chrpak at
- ! http://orion.math.iastate.edu/burkardt/f_src/chrpak/chrpak.html
- ! at 08/09/2009
- subroutine s_cap ( s )
- !
- !*******************************************************************************
- !
- !! S_CAP replaces any lowercase letters by uppercase ones in a string.
- !
- !
- ! Modified:
- !
- ! 28 June 2000
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input/output, character ( len = * ) S, the string to be transformed.
- !
- implicit none
- !
- character c
- integer i
- integer nchar
- character ( len = * ) s
- !
- nchar = len_trim ( s )
-
- do i = 1, nchar
-
- c = s(i:i)
- call ch_cap ( c )
- ! if(len(s).eq.1)then
- ! s=''
- ! s=c
- ! else
- s(i:i) = c
- ! end if
-
- end do
- return
- end subroutine s_cap
-
- subroutine FatalError(msg)
- character(len=*) :: msg
-
- write(*,*) msg
- call MpiStop('sn_sdsss_parser: ABORTING DUE TO FATAL ERROR.')
-
- end subroutine FatalError
-
-
- ! Open and parse the .dataset-file which contains
- ! the parameters needed in order to
- ! parse the FITRES files
- ! (paths, set and subset)
- subroutine ReadSDSSdataset(thisfilename)
- use Settings
- character(len=*) :: thisfilename
- character(len=sn_head) :: setstring
- integer :: fnum
- type(TIniFile) :: Ini
- logical bad
-
-
- fnum = NewIONum()
- call Ini_Open_File(Ini, thisfilename, fnum, bad, .false.)
-
- if(bad)then
- write(*,*)'File '//trim(thisfilename)//' not found. ABORTING.'
- call MpiStop('File not found.')
- end if
-
- sv%filename(1) = ReadIniFileName(Ini,'MLCSfile')
- sv%filename(2) = ReadIniFileName(Ini,'SALTfile')
- setstring = Ini_Read_String_File(Ini,'SDSS_set')
- sv%subset = Ini_Read_String_File(Ini,'SDSS_subset')
-
- read(setstring,*)sv%set
- call Ini_Close_File(Ini)
-
- end subroutine ReadSDSSdataset
-
- end module sn_sdss_parser
--- 0 ----
diff -r -c -b -B -N cosmomc/source/supernovae.f90 cosmomc_sampler/source/supernovae.f90
*** cosmomc/source/supernovae.f90 2010-05-10 17:28:00.000000000 +0200
--- cosmomc_sampler/source/supernovae.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,153 ****
- !
- ! UNION2 Supernovae Ia dataset
- !
- ! This module uses the SCP (Supernova Cosmology Project) Union 2
- ! compilation. Please cite
- ! "Amanullah et al. (SCP) 2010, arXiv:1004.1711 (ApJ accepted)".
- ! and the references of other compiled supernovae data are in there.
- !
- ! By A Slosar, heavily based on the original code by A Lewis, S Bridle
- ! and D Rapetti. E-mail: Anze Slosar (anze@berkeley.edu) for questions
- ! about the code and David Rubin (rubind@berkeley.edu) for questions
- ! regarding the dataset itself.
- !
- ! Marginalizes anayltically over H_0 with flat prior. (equivalent to
- ! marginalizing over M, absolute magnitude; see appendix F of cosmomc
- ! paper). Resultant log likelihood has arbitary origin and is
- ! numerically equal to -chi^2/2 value at the best-fit value.
- !
- ! Update Note :
- !
- ! Union1 (Kowalski et al 2008) : 307 SNe with SALT1 fit (Guy et al 2005)
- ! Union2 (Amanullah et al 2010) : 557 SNe with SALT2 fit (Guy et al 2007)
- !
- ! The following parameters are used to calculate distance moduli
- ! (see Amanullah et al. 2010 for complete description)
- !
- ! alpha 0.120887675685 ! Stretch Correction Factor
- ! beta 2.51356117225 ! Color Correction Factor
- ! M(h=0.7, statistical only) -19.3111817501 ! Absolute B Magnitue of SNIa
- ! M(h=0.7, with systematics) -19.3146267582
- !
- ! Tips for running cosmomc (ver Jan, 2010) with SCP UNION2 data
- !
- ! 1) Place the following 3 data files in your cosmomc data dir (DataDir)
- ! sn_z_mu_dmu_union2.txt : SN data : SN name, z, distance moduli mu, mu error
- ! sn_covmat_sys_union2.txt : Covariance Matrix with systematic error
- ! sn_covmat_nosys_union2.txt : Covariance Matrix without systematic error
- !
- ! 2) Make sure DataDir is set in your settings.f90
- ! character(LEN=1024) :: DataDir='yourdirpathto/cosmomc/data/'
- ! The default is 'data/' and if it works for you, just leave it as it is
- !
- ! 3) Pick SN data 'with' or 'without' systematic error
- ! (default is 'with' systematic error)
- ! Modify the folowing SN_syscovamat=.True. or .False.
- !
- ! 4) To make UNION2 as your default,
- ! either rename supernovae_union2.f90 as supernovae.f90 and recompile it
- ! or change targets in your Makefile from supernova to supernovae_union2
- !
- ! Note: In your default params.ini, there is a line for 'SN_filename', but this
- ! union2 module does not use it. You can leave it as it is, and cosmomc
- ! runs without any error but that information is not used.
- ! To avoid confusion, you may want to comment it out.
- !
- ! Update Note by Nao Suzuki (LBNL)
-
- module snovae
- use cmbtypes
- use MatrixUtils
- implicit none
-
- integer, parameter :: SN_num = 557
- double precision, parameter :: Pi_num = 3.14159265359D0
- double precision :: SN_z(SN_num), SN_moduli(SN_num)
- double precision :: SN_Ninv(SN_num,SN_Num)
- double precision :: SN_sumninv
-
- logical, parameter :: SN_marg = .True.
-
- ! The following line selects which error estimate to use
- ! default .True. = with systematic errors
- logical, parameter :: SN_syscovmat = .True. !! Use covariance matrix with or without systematics
-
- ! The following line is not used by this module but it is needed for SDSSII supernova module
- character(len=256) :: SN_filename = ''
-
- contains
-
-
- subroutine SN_init
- use settings
- character (LEN=20):: name
- integer i
- real :: tmp_mat(sn_num, sn_num)
-
- if (Feedback > 0) write (*,*) 'Reading: supernovae data'
- call OpenTxtFile(trim(DataDir)//'sn_z_mu_dmu_union2.txt',tmp_file_unit)
- do i=1, sn_num
- read(tmp_file_unit, *) name, SN_z(i), SN_moduli(i)
- end do
- close(tmp_file_unit)
-
- if (SN_syscovmat) then
- call OpenTxtFile(trim(DataDir)//'sn_covmat_sys_union2.txt',tmp_file_unit)
- else
- call OpenTxtFile(trim(DataDir)//'sn_covmat_nosys_union2.txt',tmp_file_unit)
- end if
-
- do i=1, sn_num
- read (tmp_file_unit,*) tmp_mat (i,1:sn_num)
- end do
-
- close (tmp_file_unit)
-
- call Matrix_Inverse(tmp_mat)
- sn_ninv = DBLE (tmp_mat)
-
- SN_sumninv = SUM(sn_ninv)
-
- end subroutine SN_init
-
- function SN_LnLike(CMB)
- use camb
- !Assume this is called just after CAMB with the correct model use camb
- implicit none
- type(CMBParams) CMB
- logical, save :: do_SN_init = .true.
-
- real SN_LnLike
- integer i
- double precision z, AT, BT
- real diffs(SN_num), chisq
-
- if (do_SN_init) then
- call SN_init
- do_SN_init = .false.
- end if
-
-
- !! This is actually seems to be faster without OMP
- do i=1, SN_num
- z= SN_z(i)
- diffs(i) = 5*log10((1+z)**2*AngularDiameterDistance(z))+25 -sn_moduli(i)
- end do
-
- AT = dot_product(diffs,matmul(sn_ninv,diffs))
- BT = SUM(matmul(sn_ninv,diffs))
-
- !! H0 normalisation alla Bridle and co.
- chisq = AT-BT**2/sn_sumninv
-
- if (Feedback > 1) write (*,*) 'SN chisq: ', chisq
-
-
-
- SN_LnLike = chisq/2
-
-
- end function SN_LnLike
-
-
- end module snovae
--- 0 ----
diff -r -c -b -B -N cosmomc/source/supernovae_ReissSNLS.f90 cosmomc_sampler/source/supernovae_ReissSNLS.f90
*** cosmomc/source/supernovae_ReissSNLS.f90 2006-05-03 01:24:20.000000000 +0200
--- cosmomc_sampler/source/supernovae_ReissSNLS.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,143 ****
- !Edit SN_usexxx parameters below; SNLS by default
- !SN_useRiess: Use the gold sample SNe Ia of Riess et al.(2004)
- ! See astro-ph/0402512
- !SN_useSNLS: use SNLS astro-ph/0510447
-
- !May 2004 (modified by David Rapetti)
- !May 2006: includes SNLS option (thanks to Anze Slosar)
-
- !Marginalize anayltically over H_0 with flat prior
- !(equivalent to mariganlize over M, absolute magnitude; see appendix F of cosmomc paper)
- !resultant log likelihood has arbitary origin, but is returned equal
- !to the best-fit value.
- module snovae
- use cmbtypes
- implicit none
-
- integer, parameter :: riessN=157, snlsN=115
- integer, parameter :: SN_num = riessN+snlsN
- double precision, parameter :: Pi_num = 3.14159265359D0
- double precision :: SN_z(SN_num), SN_moduli(SN_num), SN_diagerr(SN_num)
- double precision :: SN_Ninv(SN_num,SN_Num), SN_Ninvmarge(SN_num,SN_Num)
- double precision :: aprima, bprima, cprima, a1
- double precision :: SN_trNinv
- logical :: do_SN_init = .true.
-
- logical, parameter :: SN_marg = .true.
- logical, parameter :: SN_useRiess=.false.
- logical, parameter :: SN_useSNLS=.true.
-
- contains
-
-
- subroutine SN_init
- character (LEN=1200) :: InLine
- character (LEN=20) :: names(186)
- double precision :: input (186,3)
- integer gold(riessN)
- integer i
-
- if (Feedback > 0) write (*,*) 'reading: supernovae data'
- call OpenTxtFile('data/sn_data_riess.dat',tmp_file_unit)
- read(tmp_file_unit,'(a)') InLine
- do i=1, 186
- read(tmp_file_unit, *) names(i), input(i,:)
- end do
- close(tmp_file_unit)
-
- !Use only those supernovae used for `gold sample'
- gold = (/(I, I=1, 29), 32, 33, 34, 35, 37, (I, I=42,45)&
- ,(I,I=48,57),60,62,63,64,65,68,69,(I,I=71,90),(I,I=92,105)&
- ,107,(I,I=109,121),(I,I=123,131),133,134,135,136,137,138&
- ,(I,I=140,144),(I,I=146,161),163,164,169,170,171,173&
- ,174,(I,I=176,186)/)
-
- SN_z(1:riessN) = input(gold,1)
- SN_moduli(1:riessN) = input(gold,2)
- SN_diagerr(1:riessN) = 1/input(gold,3)**2 !included the extra velocities (see Riess et al.(2004))
-
- !!! Now add snls
- call OpenTxtFile('data/snls.dat',tmp_file_unit)
- do i=riessN+1, sn_Num
- read(tmp_file_unit, *) SN_z(i), sn_moduli(i), sn_diagerr(i)
- sn_diagerr(i)=1d0/sn_diagerr(i)**2
- end do
- close(tmp_file_unit)
-
-
- SN_trNinv = sum(SN_diagerr)
- do_SN_init = .false.
-
- end subroutine SN_init
-
- function SN_LnLike(CMB)
- !Assume this is called just after CAMB with the correct model
- use camb
- implicit none
- type(CMBParams) CMB
- real SN_LnLike
- integer i,kk,aa,bb
- double precision z
- real diffs(SN_num), chisq
-
- if (do_SN_init) call SN_init
-
- !$OMP PARALLEL DO DEFAULT(SHARED),SCHEDULE(STATIC), PRIVATE(z,i)
- do i=1, SN_num
- !Obviously this is not v efficient...
-
- if ((i.le.riessN).and.(.not.SN_useRiess)) cycle
- if ((i.gt.riessn).and.(.not.SN_useSNLS)) cycle
- z= SN_z(i)
- diffs(i) = 5*log10((1+z)**2*AngularDiameterDistance(z))+25 - SN_moduli(i)
- ! print *, 5*log10((1+z)**2*AngularDiameterDistance(z)*1e5/CMB%h), SN_moduli(i), cmb%h
- end do
- !$OMP END PARALLEL DO
-
-
- !!! WE do analytical marginalisation separatelly for riess and SNLS
-
- chisq=0
-
- do kk=1,2
-
- if ((kk.eq.1).and.(.not.SN_useRiess)) cycle
- if ((kk.eq.2).and.(.not.SN_useSNLS)) cycle
-
-
- if (kk.eq.1) then
- aa=1
- bb=riessN
- else
- aa=riessN+1
- bb=SN_Num
- end if
-
- !analytical marginalization over H_0 (equivaltent for M, absolute magnitude)
-
-
- aprima = sum(diffs(aa:bb)**2*SN_diagerr(aa:bb))
- bprima = sum(diffs(aa:bb)*SN_diagerr(aa:bb))
- cprima = sum(SN_diagerr(aa:bb))
- ! print *,aprima, cprima
-
- if (sn_marg) then
- ! to calculate the abslolute chisquare
-
- a1=log(cprima/(2*Pi_num))
- chisq=chisq+a1+aprima-((bprima**2)/(cprima))
- else
- chisq=chisq+aprima
- end if
-
- end do
-
-
- ! if (Feedback > 1) write (*,*) 'SN chisq: ', chisq
- SN_LnLike = chisq/2
-
- ! stop
- end function SN_LnLike
-
-
- end module snovae
--- 0 ----
diff -r -c -b -B -N cosmomc/source/supernovae_SDSS.f90 cosmomc_sampler/source/supernovae_SDSS.f90
*** cosmomc/source/supernovae_SDSS.f90 2009-09-15 18:02:10.000000000 +0200
--- cosmomc_sampler/source/supernovae_SDSS.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,138 ****
- !
- ! SDSS MLSC / SALT-II Supernovae Ia datasets,
- ! Including HST, SNLS, ESSENCE and Lowz
- !
- !
- ! This module uses the data as presented in arXiv:0908.4274v1
- !
- ! By Wessel Valkenburg, LAPTH, 2009, containing traces of the original
- ! code by A Lewis, S Bridle and D Rapetti.
- ! E-mail: wessel.valkenburg@lapp.in2p3.fr
-
- include 'sn_sdss_parser.f90'
-
- module snovae
- use cmbtypes
- use MatrixUtils
- implicit none
-
- private
-
- integer :: SN_num
- double precision, parameter :: Pi_num = 3.14159265359D0
- double precision, allocatable :: SN_z(:), SN_moduli(:)
- double precision, allocatable :: SN_Ninv(:,:)
- double precision, allocatable :: allDA(:)
- double precision :: SN_sumninv
-
- character(len=256) :: SN_filename = ''
-
- logical, parameter :: SN_marg = .True.
-
- public SN_LnLike, SN_filename
-
- contains
-
- subroutine SN_init
- use sn_sdss_parser
- implicit none
-
- type(sdssdata) :: thisdata
-
- character (LEN=20):: name
- integer i
- real :: tmp_mat(sn_num, sn_num)
- double precision :: thissigz
-
- if (Feedback > 0) write (*,*) 'Reading: supernovae data (SDSS).'
-
- ! Get the data - hardcode the right path here:
- if (SN_filename =='') SN_filename = trim(DataDir) // 'supernovae.dataset'
- call GetSDSSSN(SN_filename, thisdata, feedback)
-
-
- ! Set the sigmas etc
- SN_Num = size(thisdata%z)
-
- allocate(SN_z(SN_Num))
- allocate(allDA(SN_Num))
- allocate(SN_moduli(SN_Num))
- allocate(SN_Ninv(SN_Num,SN_Num))
-
- SN_z = thisdata%z
- SN_moduli = thisdata%mu
-
- SN_Ninv = 0.d0
- do i=1,SN_Num
- thissigz = thisdata%sigz(i) * (5.d0/dLog(10.d0)) * (1+thisdata%z(i))/(1+thisdata%z(i)/2.d0)/thisdata%z(i)
- SN_Ninv(i,i) = (thisdata%muerr(i)**2+thisdata%sigint(i)**2+thissigz**2)**(-1)
- end do
-
-
- SN_sumninv = SUM(sn_ninv)
-
-
- end subroutine SN_init
-
- function SN_LnLike(CMB)
- use camb
- !Assume this is called just after CAMB with the correct model use camb
- implicit none
- type(CMBParams) CMB
- logical, save :: do_SN_init = .true.
-
- real SN_LnLike
- integer i, sni
- double precision z, AT, BT
- real, allocatable :: diffs(:)
- real chisq
-
- if (do_SN_init) then
- call SN_init
- do_SN_init = .false.
- end if
-
- allocate(diffs(SN_Num))
-
- call DzArray(SN_z,allDA)
-
-
- diffs(:) = 5*log10((1+SN_z(:))**2*allDA(:))+25 - SN_moduli(:)
-
-
- AT = dot_product(diffs,matmul(sn_ninv,diffs))
- if(SN_marg)then
- BT = SUM(matmul(sn_ninv,diffs))
- else
- BT=0.d0
- end if
-
- deallocate(diffs)
-
- !! H0 normalisation alla Bridle and co.
- chisq = AT-BT**2/sn_sumninv
-
- if (Feedback > 1) write (*,*) 'SN chisq: ', chisq
-
- SN_LnLike = chisq/2.
-
- end function SN_LnLike
-
- subroutine DzArray(SNz,ThisDz)
- use camb
- implicit none
- !real(dl) :: z, dum
- real(dl), intent(in) :: SNz(:)
- real(dl), intent(out) :: ThisDz(:)
- integer :: i
-
-
- do i = 1,size(SNz)
- ThisDz(i) = AngularDiameterDistance(SNz(i))
- end do
-
- ! Or write code here for other distances, in a void etc. etc.
-
- end subroutine DzArray
-
- end module snovae
--- 0 ----
diff -r -c -b -B -N cosmomc/source/supernovae_Union.f90 cosmomc_sampler/source/supernovae_Union.f90
*** cosmomc/source/supernovae_Union.f90 2009-05-19 16:34:31.000000000 +0200
--- cosmomc_sampler/source/supernovae_Union.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,111 ****
- !
- ! UNION Supernovae Ia dataset
- !
- !
- ! This module uses the Union compilation. Please cite "Kowalski et
- ! al. (The Supernova Cosmology Project), Ap.J., 2008.". If the Union
- ! compilation is included in any other data sets that are distributed,
- ! please include this citation request there too.
- !
- ! By A Slosar, heavily based on the original code by A Lewis, S Bridle
- ! and D Rapetti. E-mail: Anze Slosar (anze@berkeley.edu) for questions
- ! about the code and David Rubin (rubind@berkeley.edu) for questions
- ! regarding the dataset itself.
- !
- ! Marginalizes anayltically over H_0 with flat prior. (equivalent to
- ! marginalizing over M, absolute magnitude; see appendix F of cosmomc
- ! paper). Resultant log likelihood has arbitary origin and is
- ! numerically equal to -chi^2/2 value at the best-fit value.
-
-
- module snovae
- use cmbtypes
- use MatrixUtils
- implicit none
-
- integer, parameter :: SN_num = 307
- double precision, parameter :: Pi_num = 3.14159265359D0
- double precision :: SN_z(SN_num), SN_moduli(SN_num)
- double precision :: SN_Ninv(SN_num,SN_Num)
- double precision :: SN_sumninv
-
- logical, parameter :: SN_marg = .True.
- logical, parameter :: SN_syscovmat = .True. !! Use covariance matrix with or without systematics
-
-
- contains
-
-
- subroutine SN_init
- use settings
- character (LEN=20):: name
- integer i
- real :: tmp_mat(sn_num, sn_num)
-
- if (Feedback > 0) write (*,*) 'Reading: supernovae data'
- call OpenTxtFile(trim(DataDir)//'sn_z_mu_dmu.txt',tmp_file_unit)
- do i=1, sn_num
- read(tmp_file_unit, *) name, SN_z(i), SN_moduli(i)
- end do
- close(tmp_file_unit)
-
- if (SN_syscovmat) then
- call OpenTxtFile(trim(DataDir)//'sn_covmat_sys.txt',tmp_file_unit)
- else
- call OpenTxtFile(trim(DataDir)//'sn_covmat_nosys.txt',tmp_file_unit)
- end if
-
- do i=1, sn_num
- read (tmp_file_unit,*) tmp_mat (i,1:sn_num)
- end do
-
- close (tmp_file_unit)
-
- call Matrix_Inverse(tmp_mat)
- sn_ninv = DBLE (tmp_mat)
-
- SN_sumninv = SUM(sn_ninv)
-
- end subroutine SN_init
-
- function SN_LnLike(CMB)
- use camb
- !Assume this is called just after CAMB with the correct model use camb
- implicit none
- type(CMBParams) CMB
- logical, save :: do_SN_init = .true.
-
- real SN_LnLike
- integer i
- double precision z, AT, BT
- real diffs(SN_num), chisq
-
- if (do_SN_init) then
- call SN_init
- do_SN_init = .false.
- end if
-
-
- !! This is actually seems to be faster without OMP
- do i=1, SN_num
- z= SN_z(i)
- diffs(i) = 5*log10((1+z)**2*AngularDiameterDistance(z))+25 -sn_moduli(i)
- end do
-
- AT = dot_product(diffs,matmul(sn_ninv,diffs))
- BT = SUM(matmul(sn_ninv,diffs))
-
- !! H0 normalisation alla Bridle and co.
- chisq = AT-BT**2/sn_sumninv
-
- if (Feedback > 1) write (*,*) 'SN chisq: ', chisq
-
-
-
- SN_LnLike = chisq/2
-
-
- end function SN_LnLike
-
-
- end module snovae
--- 0 ----
diff -r -c -b -B -N cosmomc/source/WeakLen.f90 cosmomc_sampler/source/WeakLen.f90
*** cosmomc/source/WeakLen.f90 2006-03-17 18:18:12.000000000 +0100
--- cosmomc_sampler/source/WeakLen.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,22 ****
-
- MODULE WeakLen
- use cmbtypes
- !Dummy module
-
- logical :: Use_WeakLen = .false.
-
- CONTAINS
-
- FUNCTION WeakLenLnLike(CMB, Theory)
- TYPE (CMBParams) CMB
- TYPE (CosmoTheory) Theory
- REAL :: WeakLenLnLike
-
- stop 'Weak lensing not implemented'
-
- WeakLenLnLike = 0
-
- END FUNCTION WeakLenLnLike
-
- end module
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/WMAP_1yr_likelihood.f90 cosmomc_sampler/source/WMAP_1yr_likelihood.f90
*** cosmomc/source/WMAP_1yr_likelihood.f90 2006-03-17 18:18:12.000000000 +0100
--- cosmomc_sampler/source/WMAP_1yr_likelihood.f90 1970-01-01 01:00:00.000000000 +0100
***************
*** 1,456 ****
- ! WMAP likelihood code
- ! Written by Licia Verde and Hiranya Peiris, Princeton University,
- ! December 2002.
- !
- ! F90 version by Antony Lewis Feb 03
-
- !****************************************************************************
- ! If you use this code in any publication, please cite Verde et al. (2003),
- ! Hinshaw et al. (2003) and Kogut et al. (2003).
- !****************************************************************************
-
-
- ! History
- ! 28 Feb 03: AL
- ! * Fixed reading in of lmax'th element of TE array
- ! * Uses packed array storage (1/2 memory use)
- ! * Switch to functions, consistent naming scheme
- ! 27 Feb 03: AL
- ! * Change to add in off-diagonal TT Fisher only if the model is not a very bad fit
- ! -- prevents erroneous high likelihoods being returned for very bad fit models
- ! * F90 translation, misc changes, deletion of separate Fisher routines
- ! * Re-organized to use symmetries (2*speed up)
- ! 21 Feb 03: WMAP
- ! * Fixed bug reading in off-diagonmal TE matrix.
- ! -- changed likelihoods slightly, no significant effect on parameter estimates
- ! (importance weights of order 3 relative to buggy version)
-
- ! This file contains a set of Fortran subroutines that compute likelihoods
- ! for a set of theoretical cl's:
- ! WMAP_init_TT - Loads TT data files
- ! Call this routine once before calling
- ! WMAP_LnLike_TT
- ! WMAP_init_TE - Loads TE data files.
- ! Call this routine once before calling
- ! WMAP_LnLike_TE
- ! WMAP_init - Calls WMAP_init_TT and WMAP_init_TE.
- ! WMAP_LnLike_TT - Computes temperature data likelihoods.
- ! WMAP_LnLike_TE - Computes TE data likelihoods.
- !
- ! The methods used here are described in the following references:
- ! Verde, L., et.al. 2003, ApJ, submitted. astro-ph/0302218
- ! Bond, J.R., Jaffe, A.H., and Knox, L., 2002, ApJ, 533
- !
- ! ===========================================================================
- ! "WMAP_init_TT" fills the common block used by
- ! "WMAP_LnLike_TT"---this is the initialization subroutine.
- !
- ! Inputs:
- ! clFile - The name of the file containing the cl data.
- ! offDiag - The name of the file containing the off-diagonal terms.
- !
- ! Outputs:
- ! stat - A status code: 0=success.
- !
- ! Written by Licia Verde and Hiranya Peiris, Princeton University,
- ! December 2002.
- ! ===========================================================================
-
- module WMAP
- implicit none
- private
-
- integer, parameter :: WMAP_lmax_TT = 900, WMAP_lmax_TE = 450, &
- WMAP_lmax_TE_file = 512
-
- integer, parameter :: WMAP_lmin_TT = 2, WMAP_lmin_TE = 2
- !Can change l_min here to remove e.g. quadrupole
-
- integer, parameter :: wp = KIND(1.0)
- integer, parameter :: WMAP_precision =wp
- !TT data
- real(wp) cl_data(WMAP_lmax_TT), neff(WMAP_lmax_TT), fskyeff(WMAP_lmax_TT)
- real(wp) r_off_diag(((WMAP_lmax_TT-1)*(WMAP_lmax_TT-2))/2)
- real(wp) off_diag(((WMAP_lmax_TT-1)*(WMAP_lmax_TT-2))/2)
-
- !TE data
- real(wp) te_data(WMAP_lmax_TE),ntt(WMAP_lmax_TE),nee(WMAP_lmax_TE)
- real(wp) te_off_diag(((WMAP_lmax_TE-1)*(WMAP_lmax_TE-2))/2)
- real(wp) te_tt(WMAP_lmax_TE)
-
- !Public constant and subroutines
- public WMAP_lmax_TT, WMAP_lmax_TE, WMAP_precision,&
- WMAP_LnLike_TT,WMAP_LnLike_TE, &
- WMAP_init_TT, WMAP_init_TE, WMAP_init
- contains
-
- SUBROUTINE WMAP_init_TT (clFile, offDiag, stat)
- !
- IMPLICIT NONE
- ! INPUT
- !
- character (*) clFile, offDiag
- !
- ! OUTPUT
- !
- integer stat
- !
- ! DATA/INTERNAL
- !
- integer idum, l, ll,i,j,ix
- ! ---------------------------------------------------------------------------
- ! Read the CL data.
- !
- open (11, file=clFile, status='old', IOStat=stat)
- if (stat .NE. 0) RETURN
- rewind(11)
- do l = 2, WMAP_lmax_TT
- read (11, *) idum, cl_data(l), neff(l), fskyeff(l)
- if (idum /= l) stop 'Error reading TT diag'
- end do
- close (11)
- !
- ! Read in off diag terms:
- ! In the *covariance* matrix there are 2 type of terms
- ! one that does scale with the clth (due to the mask) and
- ! one that does not (due to beam and point sources marginalization).
- ! In the curvature matrix (what we use here) all the off diagonal
- ! terms end up scaling with the clth but the 2 contributions scale
- ! in different ways see paper for details
- ! thus here we read them in separately
- !
- open(11,file=offDiag, status='old', IOStat=stat)
- if (stat .NE. 0) RETURN
- rewind(11)
- ix=1
- do l = 2,WMAP_lmax_TT
- do ll= l+1,WMAP_lmax_TT
- read(11,*) i,j,off_diag(ix),r_off_diag(ix)
- if (l >= WMAP_lmin_TT) ix=ix+1 !Skip all entries up to lmin
- if (l.ne.i .or. ll .ne. j) stop 'error reading TT off diag'
- end do
- end do
- close(11)
- ! ---------------------------------------------------------------------------
- END SUBROUTINE WMAP_init_TT
- ! ===========================================================================
- ! "WMAP_init_TE" fills the common block used by
- ! "compute_mapte_likelihood"---this is the initialization subroutine.
- !
- ! Inputs:
- ! clFile - The name of the file containing the cl data.
- ! offDiag - The name of the file containing the off-diagonal terms.
- !
- ! Outputs:
- ! stat - A status code: 0=success.
- !
- ! Common blocks:
- ! te_dat - This common block is used to pass/store information
- ! that does not change between calls.
- !
- ! Written by Licia Verde and Hiranya Peiris, Princeton University,
- ! December 2002.
- ! ===========================================================================
- SUBROUTINE WMAP_init_TE (clFile, offDiag, stat)
- ! INPUT
- character (*) clFile, offDiag
- !
- ! OUTPUT
- !
- integer stat
- !
- ! DATA/INTERNAL
- !
- integer idum, l, ll, i,j,ix
- real(wp) tmp
- ! ---------------------------------------------------------------------------
- ! Read the CL data.
- !
- if (WMAP_lmax_TE_file < WMAP_lmax_TE) stop 'Wrong WMAP_lmax_TE_file'
-
- open (11, file=clFile, status='old', IOStat=stat)
- if (stat .NE. 0) RETURN
- rewind(11)
- do l = 2, WMAP_lmax_TE
- read(11,*) idum,te_data(l),te_tt(l),ntt(l),nee(l)
- if (idum.ne.l) stop 'Error reading TE diag file'
- end do
- close(11)
- !
- ! Read in off diag terms.
- !
- te_off_diag = 0
- open(11,file=offDiag, status='old', IOStat=stat)
- if (stat .NE. 0) RETURN
- rewind(11)
- ix=1
- do l = 2,WMAP_lmax_TE
- do ll= l+1,WMAP_lmax_TE_file
- read(11,*) i,j,tmp
- if (l /= i .or. j /= ll) stop 'Error reading TE file'
- if (l>=WMAP_lmin_TE .and. ll<=WMAP_lmax_TE) then
- te_off_diag(ix) = tmp
- ix=ix+1
- end if
- end do
- end do
- close(11)
- ! ---------------------------------------------------------------------------
- END SUBROUTINE WMAP_init_TE
- ! ===========================================================================
- ! "WMAP_init" encapsulates "WMAP_init_TT" and
- ! "WMAP_init_TE" into a single call.
- !
- ! Inputs:
- ! TclFile - The name of the file containing the temp. cl data.
- ! ToffDiag - The name of the file containing the temp. off-diagonal terms.
- ! TEclFile - The name of the file containing the TE cl data.
- ! TEoffDiag - The name of the file containing the TE off-diagonal terms.
- !
- ! Outputs:
- ! stat - A status code: 0=success.
- !
- ! Written by Licia Verde and Hiranya Peiris, Princeton University,
- ! December 2002.
- ! ===========================================================================
- SUBROUTINE WMAP_init (TclFile, ToffDiag,&
- TEclFile, TEoffDiag, stat)
- ! INPUT
- !
- character (*) TclFile, ToffDiag, TEclFile, TEoffDiag
- !
- ! OUTPUT
- !
- integer stat
- ! ---------------------------------------------------------------------------
- Call WMAP_init_TT (TclFile, ToffDiag, stat)
- If (stat .NE. 0) Return
- Call WMAP_init_TE (TEclFile, TEoffDiag, stat)
- ! ---------------------------------------------------------------------------
- END SUBROUTINE WMAP_init
- ! ===========================================================================
- ! "WMAP_LnLike_TT" computes the likelihood for temperature data
- ! using the form for the likelihood as in Verde et al 2003 sec. 2.1
- !
- ! There are 2 contributions to the off diagonal terms of the fisher matrix:
- ! this is because in the covariance matrix the terms due to marginalization over
- ! point sources and beam uncertainties depend on the power spectrum that's out
- ! there in the sky while the coupling due to the mask depend on the Cl_theory
- ! (i.e. changes as the cosmological parameters change in exploring the
- ! likelihood surface) see Verde et al. 2003 , Hinshaw et al 2003.
- !
- ! WARNING: a 2% bias around the first peak results from incorrect scaling
- ! of the off diagonal terms.
- !
- ! Inputs:
- ! clth - An array of cl's describing the theory being tested.
- !
- ! Outputs:
- ! LnLike - The natural log of the likelihood for l >= 2.
- !
- ! Common blocks:
- ! tt_data - This common block is used to pass/store information
- ! that does not change between calls.
- !
- ! Written by Licia Verde and Hiranya Peiris, Princeton University,
- ! December 2002.
- ! ===========================================================================
- FUNCTION WMAP_LnLike_TT(clth)
- !
- IMPLICIT NONE
- !
- ! INPUT: clt_theory: l(l+1)C_l/2pi in microK^2
- !
- real(wp) clth(*)
- !
- ! OUTPUT: log(likelihood)
- !
- real(wp) WMAP_LnLike_TT
- !
- ! DATA/INTERNAL
- !
- integer l,ll,ix
- real(wp) chisq, offchisq
- real(wp) dchisq, Fisher, Fdiag(WMAP_lmax_TT)
- real(wp) z(WMAP_lmax_TT), zbar(WMAP_lmax_TT)
- real(wp) off_log_curv
- real(wp) Fdiagsqrt(WMAP_lmax_TT)
- ! ---------------------------------------------------------------------------
- chisq = 0
-
- ! prepare to compute the offset lognormal likelihood as in Bond Jaffe Knox.
- ! with the difference that the transformation we do on the curvature
- ! matrix is using clth not cltdata
- ! this is closer to the equal variance approx (see Bond Jaffe Knox again)
- ! form more details see Verde et al .2003
- !
- ! here Fdiag is the diagonal term of the covariance matrix
- ! Fisher denotes the curvature matrix.
- !
- do l = WMAP_lmin_TT, WMAP_lmax_TT
- Fdiag(l) = 2*(Clth(l)+neff(l))**2&
- / ((2*l+1)*fskyeff(l)**2)
- Fdiagsqrt(l) = 1/sqrt(Fdiag(l))
- z(l)=log(cl_data(l)+neff(l))
- zbar(l)=log(clth(l)+neff(l))
-
- ! Get the diagonal terms in the likelihood
- Fisher=1/Fdiag(l)
- off_log_curv=(clth(l)+neff(l))**2*Fisher
-
- dchisq=2._wp/3*(z(l)-zbar(l))**2*off_log_curv &
- +1._wp/3*(clth(l)-cl_data(l))**2*Fisher
- chisq=chisq+dchisq
-
- end do
-
- if (chisq < WMAP_lmax_TT*2) then
- !Only get off-diagonal terms if not a really bad fit, otherwise they will
- !be wildly wrong
- !In principle the likelihood may not be continuous, but likelihood is so low
- !model will always be rejected or contribute zero anyway
-
- offchisq=0
- ix =1
- do l = WMAP_lmin_TT,WMAP_lmax_TT
- do ll=l+1,WMAP_lmax_TT
- !
- ! here the two contributions to the off diagonal terms to the curvature matrix
- ! are treated separately
- !
- ! see Verde et.al. 2003 for details.
- ! note off_diag = -epsilon in the papers
- Fisher=r_off_diag(ix)*Fdiagsqrt(l)*Fdiagsqrt(ll) &
- +off_diag(ix)/(Fdiag(l)*Fdiag(ll))
- off_log_curv=(clth(l)+neff(l))*Fisher*(clth(ll)+neff(ll))
-
- ! to correct for residual 0.5% bias around the peak
- ! see Verde et.al. 2003 for more details
- !
- ! this is an interpolation between Bond Knox Jaffe and Gaussian Likelihood.
- ! works extremely well on sims (again see paper for details)
- !
- dchisq=2._wp/3*(z(l)-zbar(l))*off_log_curv*(z(ll)-zbar(ll))+ &
- 1._wp/3*(clth(l)-cl_data(l))*Fisher*(clth(ll)-cl_data(ll))
-
- offchisq=offchisq+dchisq
- ix=ix+1
- end do
- end do
-
- ! add it twice because of the symmetry of the matrix
- chisq=chisq+offchisq*2
-
- end if
-
- WMAP_LnLike_TT=-chisq/2.d0
- !
- ! write(*,*) ' MAP_T log(LnLike)=',LnLike,'chisq=',chisq
- !
- ! ---------------------------------------------------------------------------
- END FUNCTION WMAP_LnLike_TT
-
-
- ! "WMAP_LnLike_TE" computes the likelihood for TE data.
- !
- ! Uses the expression for the likelihood as in Kogut et al 2003 (ApJ in press)
- ! and Verde et al 2003.
- !
- ! The Curvature matrix has been calibrated from Monte Carlo simulations.
- ! fsky is set to 0.85, if not using the P2 cut (i.e. if not using the cl
- ! we provided you with) you should change fsky accordingly.
- !
- ! Inputs:
- ! cltt - An array of temperature cl's describing the theory
- ! being tested.
- ! clte - An array of TE cl's describing the theory
- ! being tested.
- ! clee - An array of EE cl's describing the theory
- ! being tested.
- !
- ! Outputs:
- ! LnLike - The natural log of the likelihood for all l.
- !
- ! Common blocks:
- ! te_dat - This common block is used to pass/store information
- ! that does not change between calls.
- !
- ! Written by Licia Verde and Hiranya Peiris, Princeton University,
- ! December 2002.
- ! ===========================================================================
- FUNCTION WMAP_LnLike_TE(cltt, clte, clee)
- !
- IMPLICIT NONE
-
- ! INPUT: clte_theory
- !
- real(wp) cltt(*),clte(*),clee(*)
- !
- ! OUTPUT: log(likelihood)
- !
- real(wp) WMAP_LnLike_TE
-
- integer il,ill,ix
- real(wp) fsky,delta_chisq,chisq, offchisq
- real(wp) Fdiag, Fdiagsqrt(WMAP_lmax_TE),Fisher
- ! real(wp) ct, ce
- ! ---------------------------------------------------------------------------
- fsky=0.85d0
- chisq=0
-
- !Alternative code that includes TT - TE correlations
- ! do il = WMAP_lmin_TE,WMAP_lmax_TE
- ! ct = cltt(il) + ntt(il)
- ! ce = clee(il) + nee(il)
- ! chisq = chisq+ (te_data(il) - clte(il) - clte(il)/ct*(te_tt(il)-ct))**2/ &
- ! (ct*ce-clte(il)**2) * (2*il+1)*fsky**2/1.14d0
- !
- ! end do
- ! WMAP_LnLike_TE=-chisq/2.d0
- ! return
-
-
- ! Fdiag is the diagonal element of the covariance matrix
- ! Fisher denotes the curvature matrix.
- !
- do il = WMAP_lmin_TE,WMAP_lmax_TE
- Fdiag=((cltt(il)+ntt(il))*(clee(il)+nee(il))&
- +clte(il)*clte(il))&
- /((2*il+1)*fsky**2/1.14d0)
- Fdiagsqrt(il) = 1/sqrt(Fdiag)
-
- ! this correction factor (1.14) has been obtained from a calibration of
- ! the covariance matrix on monte carlo sims (see papers for more details)
- !
- delta_chisq = (clte(il)-te_data(il))**2/Fdiag
-
- chisq=chisq+delta_chisq
- end do
-
- !
- ! include mask effect on off diagonal terms in the curvature matrix
-
- offchisq = 0
- ix = 1
- do il = WMAP_lmin_TE,WMAP_lmax_TE
- do ill=il+1,WMAP_lmax_TE
- Fisher=te_off_diag(ix)*Fdiagsqrt(il)*Fdiagsqrt(ill)
-
- delta_chisq = (clte(il)-te_data(il))*Fisher*&
- (clte(ill)-te_data(ill))
- offchisq=offchisq+delta_chisq
- ix=ix+1
- end do
- end do
-
- chisq = chisq+offchisq*2
-
- WMAP_LnLike_TE=-chisq/2.d0
- !
- ! write(*,*) ' MAP_TE log(LnLike)=',LnLike,'chisq=',chisq
- !
- ! ---------------------------------------------------------------------------
- END FUNCTION WMAP_LnLike_TE
-
- end module WMAP
-
--- 0 ----
diff -r -c -b -B -N cosmomc/source/wrapper.f90 cosmomc_sampler/source/wrapper.f90
*** cosmomc/source/wrapper.f90 1970-01-01 01:00:00.000000000 +0100
--- cosmomc_sampler/source/wrapper.f90 2009-04-30 16:51:19.474271389 +0200
***************
*** 0 ****
--- 1,23 ----
+ module wrapper
+ use paramdef, only : paramset, paramsetinfo
+ implicit none
+
+
+ contains
+
+
+ subroutine AcceptReject(accpt, CurParams, Trial)
+ logical, intent(in) :: accpt
+ Type(ParamSetInfo) CurParams, Trial
+
+
+ if (accpt) then
+ print *,'accepted'
+ else
+ print *,'rejected'
+ end if
+
+ end subroutine AcceptReject
+
+ end module wrapper
+