diff -r -c -b -N cosmomc/camb/binfspline.f90 cosmomc_fields/camb/binfspline.f90 *** cosmomc/camb/binfspline.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/binfspline.f90 2006-03-31 18:55:57.000000000 +0200 *************** *** 0 **** --- 1,524 ---- + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! + ! + ! VERSION 2.2 + ! + ! f90 VERSION + ! + ! This library contains routines for B-spline interpolation in + ! one, two, and three dimensions. Part of the routines are based + ! on the book by Carl de Boor: A practical guide to Splines (Springer, + ! New-York 1978) and have the same calling sequence and names as + ! the corresponding routines from the IMSL library. For documen- + ! tation see the additional files. NOTE: The results in the demo + ! routines may vary slightly on different architectures. + ! + ! by W. Schadow 12/04/99 + ! last changed by W. Schadow 07/28/2000 + ! + ! + ! Wolfgang Schadow + ! TRIUMF + ! 4004 Wesbrook Mall + ! Vancouver, B.C. V6T 2A3 + ! Canada + ! + ! email: schadow@triumf.ca or schadow@physik.uni-bonn.de + ! + ! www : http://www.triumf.ca/people/schadow + ! + ! + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! + ! + ! Copyright (C) 2000 Wolfgang Schadow + ! + ! This library is free software; you can redistribute it and/or + ! modify it under the terms of the GNU Library General Public + ! License as published by the Free Software Foundation; either + ! version 2 of the License, or (at your option) any later version. + ! + ! This library is distributed in the hope that it will be useful, + ! but WITHOUT ANY WARRANTY; without even the implied warranty of + ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + ! Library General Public License for more details. + ! + ! You should have received a copy of the GNU Library General Public + ! License along with this library; if not, write to the + ! Free Software Foundation, Inc., 59 Temple Place - Suite 330, + ! Boston, MA 02111-1307, USA. + ! + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + !infmod + !remove unused routines + !module numeric + + ! integer, parameter :: sgl = kind(1.0) + ! integer, parameter :: dbl = kind(1.0d0) + + !end module numeric + + module numeric + use infprec + integer, parameter :: sgl = kind(1.0) + integer, parameter :: dbl = kp + end module numeric + !end infmod + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + module bspline + + ! + ! ------------------------------------------------------------------ + ! + ! + ! The following routines are included: + ! + ! dbsnak + ! + ! dbsint + ! dbsval + ! dbsder + ! dbs1gd + ! + ! dbs2in + ! dbs2dr + ! dbs2vl + ! dbs2gd + ! + ! dbs3in + ! dbs3vl + ! dbs3dr + ! dbs3gd + ! + ! ------------------------------------------------------------------ + ! + + private + + public dbsnak + public dbsint, dbsval + + + contains + + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine dbsnak(nx,xvec,kxord,xknot) + + ! + ! Compute the `not-a-knot' spline knot sequence. + ! (see de Boor p. 167) + ! + ! nx - number of data points. (input) + ! xvec - array of length ndata containing the location of the + ! data points. (input) + ! kxord - order of the spline. (input) + ! xknot - array of length ndata+korder containing the knot + ! sequence. (output) + ! + + use numeric + + implicit none + + integer, intent(in) :: nx, kxord + + real(kind=dbl), dimension(nx), intent(in) :: xvec + real(kind=dbl), dimension(nx+kxord), intent(out) :: xknot + + real(kind=dbl) :: eps + integer :: ix + + !infmod + ! logical :: first = .true. + ! save first,eps + + + ! if (first) then + ! first=.false. + eps = epsilon(1.0_dbl) + ! write(*,*) "subroutine dbsnak: " + ! write(*,*) "eps = ",eps + ! endif + !end infmod + + if((kxord .lt. 0) .or. (kxord .gt. nx)) then + write(*,*) "subroutine dbsnak: error" + write(*,*) "0 <= kxord <= nx is required." + write(*,*) "kxord = ", kxord, " and nx = ", nx, " is given." + stop + endif + + do ix = 1, kxord + xknot(ix) = xvec(1) + end do + + if(mod(kxord,2) .eq. 0) then + do ix = kxord+1, nx + xknot(ix) = xvec(ix-kxord/2) + end do + else + do ix = kxord+1, nx + xknot(ix) = 0.5_dbl * (xvec(ix-kxord/2) + xvec(ix-kxord/2-1)) + end do + endif + + do ix = nx+1, nx+kxord + xknot(ix) = xvec(nx) * (1.0_dbl + eps) + end do + + end subroutine dbsnak + + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine dbsint(nx,xvec,xdata,kx,xknot,bcoef) + + ! + ! Computes the spline interpolant, returning the B-spline coefficients. + ! (see de Boor p. 204) + ! + ! nx - number of data points. (input) + ! xvec - array of length nx containing the data point + ! abscissas. (input) + ! xdata - array of length ndata containing the data point + ! ordinates. (input) + ! kx - order of the spline. (input) + ! korder must be less than or equal to ndata. + ! xknot - array of length nx+kx containing the knot + ! sequence. (input) + ! xknot must be nondecreasing. + ! bscoef - array of length ndata containing the B-spline + ! coefficients. (output) + ! + + use numeric + + implicit none + + integer, intent(in) :: nx, kx + real(kind=dbl), dimension(nx), intent(in) :: xdata, xvec + real(kind=dbl), dimension(nx+kx), intent(in) :: xknot + real(kind=dbl), dimension(nx), intent(out) :: bcoef + + integer :: nxp1, kxm1, kpkm2, leftx, lenq + integer :: ix, ik,ilp1mx, jj, iflag + real(kind=dbl) :: xveci + real(kind=dbl), dimension((2*kx-1)*nx) :: work + + + nxp1 = nx + 1 + kxm1 = kx - 1 + kpkm2 = 2 * kxm1 + leftx = kx + lenq = nx * (kx + kxm1) + + do ix = 1, lenq + work(ix) = 0.0_dbl + end do + + do ix = 1, nx + xveci = xvec(ix) + ilp1mx = min0(ix+kx,nxp1) + leftx = max0(leftx,ix) + if (xveci .lt. xknot(leftx)) goto 998 + 30 if (xveci .lt. xknot(leftx+1)) go to 40 + leftx = leftx + 1 + if (leftx .lt. ilp1mx) go to 30 + leftx = leftx - 1 + if (xveci .gt. xknot(leftx+1)) goto 998 + 40 call bsplvb (xknot,nx+kx,kx,1,xveci,leftx,bcoef) + jj = ix - leftx + 1 + (leftx - kx) * (kx + kxm1) + do ik = 1, kx + jj = jj + kpkm2 + work(jj) = bcoef(ik) + end do + end do + + call banfac(work,kx+kxm1,nx,kxm1,kxm1,iflag) + + if (iflag .ne. 1) then + write(*,*) "subroutine dbsint: error" + write(*,*) "no solution of linear equation system !!!" + stop + end if + + do ix = 1, nx + bcoef(ix) = xdata(ix) + end do + + call banslv(work,kx+kxm1,nx,kxm1,kxm1,bcoef) + + return + + 998 write(*,*) "subroutine dbsint:" + write(*,*) "xknot(ix) <= xknot(ix+1) required." + write(*,*) ix,xknot(ix),xknot(ix+1) + + stop + + end subroutine dbsint + + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + function dbsval(x,kx,xknot,nx,bcoef) + + ! + ! Evaluates a spline, given its B-spline representation. + ! + ! x - point at which the spline is to be evaluated. (input) + ! kx - order of the spline. (input) + ! xknot - array of length nx+kx containing the knot + ! sequence. (input) + ! xknot must be nondecreasing. + ! nx - number of B-spline coefficients. (input) + ! bcoef - array of length nx containing the B-spline + ! coefficients. (input) + ! dbsval - value of the spline at x. (output) + ! + + use numeric + + implicit none + + integer, intent(in) :: nx, kx + real(kind=dbl) :: dbsval + real(kind=dbl) :: x + real(kind=dbl), dimension(nx+kx), intent(in) :: xknot + real(kind=dbl), dimension(nx), intent(in) :: bcoef + + integer :: il, ik, ix, leftx + real(kind=dbl) :: save1, save2 + real(kind=dbl), dimension(kx) :: work, dl, dr + + ! + ! check if xknot(i) <= xknot(i+1) and calculation of i so that + ! xknot(i) <= x < xknot(i+1) + ! + + leftx = 0 + + do ix = 1,nx+kx-1 + if (xknot(ix) .gt. xknot(ix+1)) then + write(*,*) "subroutine dbsval:" + write(*,*) "xknot(ix) <= xknot(ix+1) required." + write(*,*) ix,xknot(ix),xknot(ix+1) + stop + endif + if((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) leftx = ix + end do + + if(leftx .eq. 0) then + write(*,*) "subroutine dbsval:" + write(*,*) "ix with xknot(ix) <= x < xknot(ix+1) required." + write(*,*) "x = ", x + stop + endif + + do ik = 1, kx-1 + work(ik) = bcoef(leftx+ik-kx) + dl(ik) = x - xknot(leftx+ik-kx) + dr(ik) = xknot(leftx+ik) - x + end do + + work(kx) = bcoef(leftx) + dl(kx) = x - xknot(leftx) + + do ik = 1, kx-1 + save2 = work(ik) + do il = ik+1, kx + save1 = work(il) + work(il) = (dl(il) * work(il) + dr(il-ik) * save2) & + & / (dl(il) + dr(il - ik)) + save2 = save1 + end do + end do + + dbsval = work(kx) + + end function dbsval + + + + + subroutine bsplvb(t,n,jhigh,index,x,left,biatx) + + use numeric + + implicit none + + integer, intent(in) :: n, jhigh, index, left + + real(kind=dbl), intent(in) :: x + real(kind=dbl), dimension(n), intent(in) :: t + real(kind=dbl), dimension(jhigh), intent(out) :: biatx + + integer :: j = 1 + integer :: i, jp1 + real(kind=dbl) :: saved, term + real(kind=dbl), dimension(jhigh) :: dl, dr + + + if (index .eq. 1) then + j = 1 + biatx(1) = 1.0_dbl + if (j .ge. jhigh) return + end if + + 20 jp1 = j + 1 + + dr(j) = t(left+j) - x + dl(j) = x - t(left+1-j) + saved = 0._dbl + + do i = 1, j + term = biatx(i) / (dr(i) + dl(jp1-i)) + biatx(i) = saved + dr(i) * term + saved = dl(jp1-i) * term + end do + + biatx(jp1) = saved + j = jp1 + + if (j .lt. jhigh) go to 20 + + end subroutine bsplvb + + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine banfac(w,nroww,nrow,nbandl,nbandu,iflag) + + use numeric + + implicit none + + integer, intent(in) :: nroww,nrow + integer, intent(in) :: nbandl,nbandu + integer, intent(out) :: iflag + real(kind=dbl), dimension(nroww,nrow), intent(inout) :: w + + real(kind=dbl) :: pivot, factor + integer :: middle, nrowm1, jmax, kmax, ipk, midmk, i, j, k + + + iflag = 1 + middle = nbandu + 1 + nrowm1 = nrow - 1 + + if (nrowm1 .lt. 0) goto 999 + if (nrowm1 .eq. 0) goto 900 + if (nrowm1 .gt. 0) goto 10 + + 10 if (nbandl .gt. 0) go to 30 + + do i = 1, nrowm1 + if (w(middle,i) .eq. 0._dbl) go to 999 + end do + + go to 900 + + 30 if (nbandu .gt. 0) go to 60 + + do i = 1, nrowm1 + pivot = w(middle,i) + if(pivot .eq. 0._dbl) go to 999 + jmax = min0(nbandl, nrow - i) + do j = 1, jmax + w(middle+j,i) = w(middle+j,i) / pivot + end do + end do + + return + + 60 do i = 1, nrowm1 + pivot = w(middle,i) + if (pivot .eq. 0._dbl) go to 999 + jmax = min0(nbandl,nrow - i) + do j = 1,jmax + w(middle+j,i) = w(middle+j,i) / pivot + end do + + kmax = min0(nbandu,nrow - i) + + do k = 1, kmax + ipk = i + k + midmk = middle - k + factor = w(midmk,ipk) + do j = 1, jmax + w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i) & + & * factor + end do + end do + end do + + 900 if (w(middle,nrow) .ne. 0._dbl) return + 999 iflag = 2 + + end subroutine banfac + + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + subroutine banslv(w,nroww,nrow,nbandl,nbandu,b) + + use numeric + + implicit none + + integer, intent(in) :: nroww,nrow + integer, intent(in) :: nbandl,nbandu + real(kind=dbl), dimension(nroww,nrow), intent(in) :: w + real(kind=dbl), dimension(nrow), intent(inout) :: b + + integer :: middle, nrowm1, jmax, i, j + + middle = nbandu + 1 + if (nrow .eq. 1) goto 99 + nrowm1 = nrow - 1 + if (nbandl .eq. 0) goto 30 + + do i = 1, nrowm1 + jmax = min0(nbandl, nrow - i) + do j = 1, jmax + b(i+j) = b(i+j) - b(i) * w(middle+j,i) + end do + end do + + 30 if (nbandu .gt. 0) goto 50 + + do i = 1, nrow + b(i) = b(i) / w(1,i) + end do + + return + + 50 do i = nrow, 2, -1 + b(i) = b(i)/w(middle,i) + jmax = min0(nbandu,i-1) + do j = 1, jmax + b(i-j) = b(i-j) - b(i) * w(middle-j,i) + end do + end do + + 99 b(1) = b(1) / w(middle,1) + + end subroutine banslv + + + + end module bspline diff -r -c -b -N cosmomc/camb/cmbmain.f90 cosmomc_fields/camb/cmbmain.f90 *** cosmomc/camb/cmbmain.f90 2009-02-20 00:43:34.000000000 +0100 --- cosmomc_fields/camb/cmbmain.f90 2009-10-28 13:11:39.272958414 +0100 *************** *** 1924,1935 **** integer, intent(in) :: numks, pix real(dl) pows(numks), ks(numks) integer i ! do i = 1, numks !!change to vec... pows(i) = ScalarPower(ks(i) ,pix) end do ! end subroutine GetInitPowerArrayVec --- 1924,1940 ---- integer, intent(in) :: numks, pix real(dl) pows(numks), ks(numks) integer i ! !fields ! !$omp parallel do & ! !$omp default(shared) & ! !$omp private(i) & ! !$omp schedule(dynamic) do i = 1, numks !!change to vec... pows(i) = ScalarPower(ks(i) ,pix) end do ! !$omp end parallel do ! !end fields end subroutine GetInitPowerArrayVec *************** *** 1937,1947 **** integer, intent(in) :: numks, pix real(dl) pows(numks), ks(numks) integer i ! do i = 1, numks pows(i) = TensorPower(ks(i) ,pix) end do ! end subroutine GetInitPowerArrayTens --- 1942,1957 ---- integer, intent(in) :: numks, pix real(dl) pows(numks), ks(numks) integer i ! !fields ! !$omp parallel do & ! !$omp default(shared) & ! !$omp private(i) & ! !$omp schedule(dynamic) do i = 1, numks pows(i) = TensorPower(ks(i) ,pix) end do ! !$omp end parallel do ! !end fields end subroutine GetInitPowerArrayTens *************** *** 1955,1961 **** real(dl) ctnorm,dbletmp do pix=1,CP%InitPower%nn ! do q_ix = 1, CTrans%q%npoints if (CP%flat) then --- 1965,1975 ---- real(dl) ctnorm,dbletmp do pix=1,CP%InitPower%nn ! !field: calling ScalarPower is time consumming when it comes from inflation code. Better to parallelise ! !$omp parallel do & ! !$omp default(shared) & ! !$omp private(q_ix) & ! !$omp schedule(dynamic,1) do q_ix = 1, CTrans%q%npoints if (CP%flat) then *************** *** 1970,1976 **** end do ! !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) & !$OMP & PRIVATE(j,q_ix,dlnk,apowers,ctnorm,dbletmp) --- 1984,1991 ---- end do ! !$omp end parallel do ! !end field !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) & !$OMP & PRIVATE(j,q_ix,dlnk,apowers,ctnorm,dbletmp) diff -r -c -b -N cosmomc/camb/infbackmain.f90 cosmomc_fields/camb/infbackmain.f90 *** cosmomc/camb/infbackmain.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infbackmain.f90 2006-12-03 14:28:32.000000000 +0100 *************** *** 0 **** --- 1,138 ---- + program infbackmain + use infprec, only : kp + use infsrmodel + use infbgmodel + use infbg + use infinout + + implicit none + + + real(kp), dimension(fieldNum) :: field, fieldDot + type(infbgdata), pointer :: ptrToBgdata => null() + type(infbgdata), pointer :: ptrRun => null() + + type(infbgparam) :: infParam + type(infbgphys) :: infIni, infObs, infEnd + + integer :: inum = 0 + + real(kp) :: matter,efold,efoldGo,efoldFin,hubble,epsilon1,epsilon1JF + real(kp), dimension(dilatonNum) :: dilaton + real(kp), dimension(fieldNum,fieldNum) :: metricVal,metricInv + real(kp), dimension(2*fieldNum) :: bgVar + real(kp) :: tol + logical :: paramCheck = .false. + integer :: ind + + !inflation model + infParam%name = 'largef' + + !parameters (see infbgmodel.f90) + infParam%consts(1) = 10**(-5.21351) + infParam%consts(2) = 2. + infParam%consts(3) = 0. + infParam%consts(4) = 0. + + !initial field value. + infParam%conforms(1) = 1 + infParam%matters(1) = 1e-6 + + + + !set the parameters + paramCheck = set_infbg_param(infParam) + print *,'setup params', paramCheck + print *,'infPAram',infParam + + !set initial condition + infIni = set_infbg_ini(infParam) + print *,'infIni',infIni + + !evolves the background till the end of inflation and store the + !results with 5000 points + infEnd = bg_field_evol(infIni,5000,infObs,ptrToBgdata) + + + !physical quantities at the end of inflation + print *,'infEnd', infEnd, (infEnd==infIni) + print *,'infObs',infObs + print * + read(*,*) + + !test the chain list + inum =0 + if (associated(ptrToBgdata)) then + ptrRun => ptrToBgdata + do while (associated(ptrRun)) + ! print *,'efold hubble =',ptrRun%bg%efold, ptrRun%bg%hubble + inum = inum + 1 + ptrRun => ptrRun%ptr + enddo + ptrRun => null() + print *,'inum',inum + print *,'count',count_infbg_data(ptrToBgdata) + endif + + + ! stop + + !test rescaling + call rescale_potential(2._kp,infParam,infIni,infEnd,infObs,ptrToBgdata) + + print *,'afterRescale' + print *,'mass=',matterParam(1) + print *,'infParam',infParam + print *,'infIni',infIni + print *,'infEnd',infEnd + print *,'infObs',infObs + print * + read(*,*) + inum=0 + if (associated(ptrToBgdata)) then + ptrRun => ptrToBgdata + do while (associated(ptrRun)) + ! print *,'efold hubble =',ptrRun%bg%efold, ptrRun%bg%hubble + efold = ptrRun%bg%efold + field = ptrRun%bg%field + fieldDot = ptrRun%bg%fieldDot + hubble = ptrRun%bg%hubble + epsilon1 = ptrRun%bg%epsilon1 + epsilon1JF = ptrRun%bg%epsilon1JF + call livewrite('resfield.dat',efold,field(1),field(2),field(3)) + call livewrite('resfieldDot.dat',efold,fieldDot(1),fieldDot(2),fieldDot(3)) + call livewrite('reshubble.dat',efold,hubble) + call livewrite('resepsilons.dat',efold,epsilon1,epsilon1JF) + inum = inum + 1 + ptrRun => ptrRun%ptr + enddo + ptrRun => null() + print *,'inum',inum + print *,'count',count_infbg_data(ptrToBgdata) + endif + + if (associated(ptrToBgdata)) then + call free_infbg_data(ptrToBgdata) + endif + + + infIni = set_infbg_ini(infParam) + print *,'After ini again' + print *,'mass=',matterParam(1) + print *,'infPAram',infParam + print *,'infIni',infIni + + !evolves the background + infEnd = bg_field_evol(infIni,100,infObs,ptrToBgdata) + + + !print the physical quantities at the end of inflation + print *,'infEnd', infEnd, (infEnd==infIni) + print *,'infObs',infObs + print * + + + end program infbackmain + + + diff -r -c -b -N cosmomc/camb/infbg.f90 cosmomc_fields/camb/infbg.f90 *** cosmomc/camb/infbg.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infbg.f90 2009-04-24 16:32:15.031150060 +0200 *************** *** 0 **** --- 1,1577 ---- + module infbg + use infprec, only : kp, tolkp + use infbgmodel, only : matterNum, dilatonNum, fieldNum + !background evolution in the Einstein FLRW Frame for multifields: + !scalar gravity + matter fields. + + implicit none + + private + + + !for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_file = .false. + + + !to store snapshot (ini or end, or more) + type infbgphys + sequence + real(kp) :: efold, hubble, epsilon1, epsilon1JF + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum) :: fieldDot + end type infbgphys + + + !to store the bg integration as chained list + type infbgdata + type(infbgphys) :: bg + type(infbgdata), pointer :: ptr => null() + end type infbgdata + + + interface operator (==) + module procedure infbgphys_equal + end interface + + + interface operator (/=) + module procedure infbgphys_unequal + end interface + + + + public infbgdata, infbgphys + public operator(==),operator(/=) + public free_infbg_data, count_infbg_data + + public set_infbg_ini + public rescale_potential + public bg_field_evol, bg_field_dot_coupled + + public slowroll_first_parameter, slowroll_first_parameter_JF + public slowroll_second_parameter, hubble_parameter_square + + public potential, deriv_potential, deriv_second_potential + + public connection_affine, deriv_connection_affine + + public matter_energy_density, matter_energy_density_JF + + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !recursivity need enough stacksize for big lists, otherwise it + !segfaults. Only needed to store and free the data in memory. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function infbgphys_equal(infbgphysA, infbgphysB) + implicit none + type(infbgphys), intent(in) :: infbgphysA, infbgphysB + logical :: infbgphys_equal + + infbgphys_equal = ((infbgphysA%efold == infbgphysB%efold) & + .and. (infbgphysA%hubble == infbgphysB%hubble) & + .and. (infbgphysA%epsilon1 == infbgphysB%epsilon1) & + .and. (infbgphysA%epsilon1JF == infbgphysB%epsilon1JF) & + .and. all(infbgphysA%field == infbgphysB%field) & + .and. all(infbgphysA%fieldDot == infbgphysB%fieldDot)) + + end function infbgphys_equal + + + + function infbgphys_unequal(infbgphysA, infbgphysB) + implicit none + type(infbgphys), intent(in) :: infbgphysA, infbgphysB + logical :: infbgphys_unequal + + infbgphys_unequal = ((infbgphysA%efold /= infbgphysB%efold) & + .or. (infbgphysA%hubble /= infbgphysB%hubble) & + .or. (infbgphysA%epsilon1 /= infbgphysB%epsilon1) & + .or. (infbgphysA%epsilon1JF /= infbgphysB%epsilon1JF) & + .or. any(infbgphysA%field /= infbgphysB%field) & + .or. any(infbgphysA%fieldDot /= infbgphysB%fieldDot)) + + end function infbgphys_unequal + + + + recursive subroutine free_infbg_data(ptrFirst) + implicit none + type(infbgdata), pointer :: ptrFirst + + if (associated(ptrFirst%ptr)) call free_infbg_data(ptrFirst%ptr) + deallocate(ptrFirst) + + end subroutine free_infbg_data + + + + recursive function count_infbg_data(ptrFirst) result(bgdataCount) + implicit none + integer :: bgdataCount + type(infbgdata), pointer :: ptrFirst + + bgdataCount = 1 + if (associated(ptrFirst%ptr)) then + bgdataCount = count_infbg_data(ptrFirst%ptr) + 1 + endif + + end function count_infbg_data + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !inflation settings: initial conditions, rescaling, normalisation... + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function set_infbg_ini(infParam) + !to start on the attractor. This is epsilon2 = 0 for epsilon1<<1 + !initialy. + use infbgmodel, only : infbgparam, metric_inverse + use infsrmodel, only : slowroll_initial_matter_lf + use infsrmodel, only : slowroll_initial_matter_sf + use infsrmodel, only : slowroll_initial_matter_hy + use infsrmodel, only : slowroll_initial_matter_rm + use infsrmodel, only : slowroll_initial_matter_kksf + use infsrmodel, only : slowroll_initial_matter_kklt + + implicit none + type(infbgparam), intent(in) :: infParam + type(infbgphys) :: set_infbg_ini + + real(kp) :: hubbleSquareIni + type(infbgphys) :: infIni + + + infIni%field(1:matterNum) = infParam%matters + infIni%field(matterNum+1:fieldNum) = infParam%conforms + + + !if the matter fields are set to 0, use slow-roll guesses + if (all(infParam%matters == 0._kp)) then + + select case (infParam%name) + + case ('largef') + infIni%field(1:matterNum) = slowroll_initial_matter_lf(infParam) + + case ('smallf') + infIni%field(1:matterNum) = slowroll_initial_matter_sf(infParam) + + case ('hybrid') + infIni%field(1:matterNum) = slowroll_initial_matter_hy(infParam) + + case ('runmas') + infIni%field(1:matterNum) = slowroll_initial_matter_rm(infParam) + + case ('kklmmt') + infIni%field(1:matterNum) = slowroll_initial_matter_kklt(infParam) + + end select + + endif + + + infIni%fieldDot & + = - matmul(metric_inverse(infIni%field),deriv_ln_potential(infIni%field)) + ! infIni%fieldDot = 0._kp + ! print *,'initial condition fieldDot=',infIni%fieldDot + + ! infIni%fieldDot(1)=1. + ! infIni%fieldDot(2)=-0.5 + ! infIni%fieldDot(3)=0.6 + + hubbleSquareIni = hubble_parameter_square(infIni%field,infIni%fieldDot,.false.) + + if (hubbleSquareIni.ge.0._kp) then + infIni%hubble = sqrt(hubbleSquareIni) + else + stop 'H^2 < 0, check initial condition' + endif + + infIni%epsilon1 = slowroll_first_parameter(infIni%field,infIni%fieldDot, .false.) + infIni%epsilon1JF = slowroll_first_parameter_JF(infIni%field, infIni%fieldDot,.false.) + infIni%efold = 0._kp + + set_infbg_ini = infIni + + if (display) then + if (infIni%epsilon1.lt.epsilon(1._kp)) then + write(*,*) + write(*,*)'set_infbg_ini: epsilon1 < accuracy',infIni%epsilon1 + write(*,*) + endif + endif + + end function set_infbg_ini + + + + + + subroutine rescale_potential(scale,infParam,infIni,infEnd,infObs,ptrBgdata) + !update all relevant data such as Unew = scale*Uold + use infbgmodel, only : infbgparam, conformal_factor_square + use infbgmodel, only : set_infbg_param + implicit none + type(infbgparam), intent(inout) :: infParam + type(infbgphys), intent(inout) :: infIni,infEnd,infObs + type(infbgdata), optional, pointer :: ptrBgdata + real(kp), intent(in) :: scale + + type(infbgdata), pointer :: ptrRun + logical :: updateBgParams + + ptrRun => null() + + !see infbgmodel U propto M^4 + infParam%consts(1) = infParam%consts(1)*scale**0.25 + + updateBgParams = set_infbg_param(infParam) + if (.not.updateBgParams) stop 'rescale_potential: updating params failed!' + + infIni%hubble = infIni%hubble * sqrt(scale) + infEnd%hubble = infEnd%hubble * sqrt(scale) + infObs%hubble = infObs%hubble * sqrt(scale) + + if (present(ptrBgData)) then + if (associated(ptrBgdata)) then + ptrRun => ptrBgdata + do while (associated(ptrRun)) + ptrRun%bg%hubble = ptrRun%bg%hubble * sqrt(scale) + ptrRun => ptrRun%ptr + enddo + ptrRun => null() + else + stop 'rescale_potential_by: data not found' + endif + endif + + end subroutine rescale_potential + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !inflationary evolution: find end of inflation + store relevant quantities + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function bg_field_evol(infIni,efoldDataNum,infObs,ptrStart,stopAtThisValue,isStopAtMax) + !integrate the background until epsilon > epsilonStop, and returns some + !physical values (type infbgphys) for which epsilon = epsilon1EndInf (=1) + + use infprec, only : transfert + use inftools, only : easydverk, tunedverk, zbrent + use infbgmodel, only : conformal_factor_square + use infinout + + implicit none + + type(infbgphys), intent(in) :: infIni + !number of wanted stored efold. If accuracy is not enough, the real + !number of stored efold is modified !up to + !efoldBeforeEndObs/efoldStepDefault + integer, optional, intent(in) :: efoldDataNum + type(infbgphys), optional, intent(out) :: infObs + type(infbgdata), optional, pointer :: ptrStart + real(kp), optional, intent(in) :: stopAtThisValue + logical, optional, intent(in) :: isStopAtMax + type(infbgphys) :: bg_field_evol + + + real(kp) :: epsilon1, epsilon1JF + real(kp) :: epsilon2 + + !if ptrBgdata input without data number, this is the default storage step + real(kp), parameter :: efoldStepDefault = 1._kp + + !we cannot discover inflation longer on this computer + real(kp) :: efoldHuge + + !how many efold after end inflation are stored (work only with + !useVelocity=T) + real(kp) :: efoldExploreOsc + + !observable perturbations were produced after that + real(kp), parameter :: efoldBeforeEndObs = 120._kp + real(kp) :: efoldObs + + real(kp) :: hubbleSquare, hubble, hubbleEndInf + real(kp) :: hubbleSquareIni, hubbleIni + + real(kp) :: efold,efoldNext,efoldStepObs, efoldStepNoObs + + real(kp) :: efoldBeforeEndInf,efoldEndInf + real(kp) :: efoldAfterEndInf + + real(kp), dimension(fieldNum) :: field,derivField + real(kp), dimension(fieldNum) :: fieldEndInf,derivFieldEndInf + real(kp), dimension(fieldNum) :: derivFieldAfterEndInf + real(kp), dimension(2*fieldNum) :: bgVar, bgVarIni + + !standard integration accuracy + ! real(kp), parameter :: tolEvol = 1e-11 + real(kp), parameter :: tolEvol = tolkp + + !backward integration accuracy (sometime instable, mayneed extra precision) + real(kp) :: tolBackEvol + + !if true derivField=Dfield/Dtphys, otherwise derivField=Dfield/Defold is + !used for the integration. In both cases, only Dfield/Defold is + !stored + logical, parameter :: useVelocity = .true. + !end inflation when epsilon1=1 in Jordan Frame, or in Einstein Frame + !Physics says in JF, but both are the same up to 2% when the dilaton coupling are set to 1 + !Today dilaton couplings are 0.01 maxi, and they are constant or null in our model. + !Integration stops when epsilon1(useJF or not) > epsilon1Stop + real(kp), parameter :: epsilon1Stop = 1. + logical, parameter :: useEpsilon1JF = .true. + + !zbrent accuracy on efoldEnd for which epsilon=epsilon1Stop + real(kp), parameter :: tolEfoldEnd = tolkp + + !another test, checked after epsilon1 values to stop integration. May + !be convenient for hybrid-like one field potential: stop integration + !when the min value of the matter fields is below matterMiniStop, or + !according to the total number of efolds + logical, parameter :: accurateEndInf = .true. + real(kp) :: efoldMaxiStop + logical :: checkHubbleStop + logical :: checkMatterStop + logical :: stopForMax + + real(kp) :: valueStop + integer, parameter :: stopIndexMin = 1, stopIndexMax = 1 + + logical :: inflate, longEnoughObs + + !to make f77 routines discussing together + type(transfert) :: stopData, findData + + !to store the data as chained list + type(infbgdata), pointer :: ptrCurrent + type(infbgdata), pointer :: ptrPrevious + + integer :: neqs + + + !initialisation !!!!!!!!!!!!!!! + tolBackEvol = tolEvol + efoldHuge = 1._kp/epsilon(1._kp) + neqs = 2*fieldNum + + if (present(infObs)) then + infObs = infIni + endif + + efoldExploreOsc = 0. + + !enabled by true + + checkHubbleStop = .false. + + checkMatterStop = .false. + + efoldMaxiStop = 200. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + efoldHuge = min(efoldMaxiStop,efoldHuge) + + + !checks + if (present(ptrStart)) then + if (associated(ptrStart)) then + stop 'bg_field_evol: ptr to bgdata already associated' + endif + endif + + + + if ((.not.useVelocity).and.efoldExploreOsc.ne.0) then + write(*,*)'bg_field_evol: oscillation exploration disabled!' + efoldExploreOsc = 0. + endif + + if (present(isStopAtMax)) then + stopForMax = isStopAtMax + else + stopForMax = .false. + endif + + if (present(stopAtThisValue)) then + valueStop = stopAtThisValue + if ((.not.checkMatterStop).and.checkHubbleStop) then + if (display) write(*,*)'bg_field_evol: check for Hubble stop enabled' + else + if (display) write(*,*)'bg_field_evol: check for Matter stop enabled' + if (display) write(*,*)'bg_field_evol: stopForMax is',stopForMax + checkHubbleStop = .false. + checkMatterStop = .true. + endif + else + valueStop = tolEvol + endif + + !set initial conditions + + hubbleSquareIni = hubble_parameter_square(infIni%field,infIni%fieldDot,.false.) + if (hubbleSquareIni.ge.0d0) then + hubbleIni = sqrt(hubbleSquareIni) + else + stop 'bg_field_evol: hubbleSquareIni < 0' + endif + bgVarIni(1:fieldNum) = infIni%field(1:fieldNum) + if (useVelocity) then + bgVarIni(fieldNum+1:2*fieldNum) = infIni%fieldDot(1:fieldNum)*hubbleIni + else + bgVarIni(fieldNum+1:2*fieldNum) = infIni%fieldDot(1:fieldNum) + endif + + + !localize rougthly the end of inflation: in fprime, a test stops dverk when epsilon>1 + efold = infIni%efold + bgVar = bgVarIni + + !initialize (all other subtypes may change) + stopData%yesno1 = useEpsilon1JF + stopData%yesno2 = checkMatterStop + stopData%yesno3 = stopForMax + stopData%yesno4 = checkHubbleStop + stopData%check = .false. + stopData%update = .false. + stopData%xend = efoldHuge + stopData%real1 = epsilon1Stop + stopData%real2 = valueStop! - 10._kp*tolEvol + stopData%int1 = stopIndexMin + stopData%int2 = stopIndexMax + + if (useVelocity) then + !derivField=Dfield/Dtphys + call easydverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldHuge,tolEvol & + ,stopData) + else + !derivField=Dfield/Defold + call easydverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldHuge,tolEvol & + ,stopData) + endif + + !up to dverk exploration + ! efoldAfterEndInf = stopData%xend and something like bgVar = + ! stopData%ptr after allocation + + ! print *,'efold bg',efold,bgVar + ! print *,'epsilon1',slowroll_first_parameter(bgVar(1:2), bgVar(3:4) & + ! , useVelocity) + + + derivFieldAfterEndInf(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum) + + efoldAfterEndInf = efold + efoldBeforeEndInf = efoldAfterEndInf - efoldStepDefault + + + if (efoldBeforeEndInf.le.infIni%efold) then + if (display) write(*,*)'bg_field_evol: inflation too short' + bg_field_evol = infIni + return + endif + + + + + !precise determination of efoldEndInf up to tolEfoldEnd provided + !inflation is longer than efoldStepDefault efold + + !checkMatterMini stands for cases when epsilon1=epsilon1Stop does not + !define the end of inflation, so who cares about accurate + !determination + if ((.not.accurateEndInf).or.(efoldAfterEndInf.eq.efoldMaxiStop)) then + if (display) write(*,*)'bg_field_evol: endinf not determined accurately' + efoldEndInf = efoldAfterEndInf + fieldEndInf = bgVar(1:fieldNum) + derivFieldEndInf = bgVar(fieldNum+1:2*fieldNum) + hubbleEndInf & + = sqrt(hubble_parameter_square(fieldEndInf,derivFieldEndInf,useVelocity)) + + else + + + !careful localisation of the end of inflation move to + !efoldBeforeEndInf: background integration maybe unstable, precision + !is pushed to maximum accuracy + + + tolBackEvol = epsilon(1._kp) + + if (useVelocity) then + call tunedverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldBeforeEndInf & + ,tolBackEvol) + else + call tunedverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldBeforeEndInf & + ,tolBackEvol) + endif + + !use zbrent zero finder in [efoldBeforeEndInf, efoldAfterEndInf] + findData%yesno1 = useVelocity + findData%yesno2 = useEpsilon1JF + findData%yesno3 = stopForMax + findData%real1 = efold + allocate(findData%ptrvector1(2*fieldNum)) + allocate(findData%ptrvector2(2*fieldNum)) + findData%ptrvector1 = bgVar + findData%real2 = tolEvol + findData%real3 = valueStop + + findData%int1 = stopIndexMin + findData%int2 = stopIndexMax + + !find at tolEfoldEnd precision: the interval should be small + !(background integration of inflation is unstable) + ! print *,'go in zbrent set',efoldBeforeEndInf,efoldAfterEndInf,findData%real1 + + if (checkHubbleStop.and.(.not.stopData%yesno2)) then + efoldEndInf = zbrent(find_endinf_hubble,efoldBeforeEndInf & + ,efoldAfterEndInf,tolEfoldEnd,findData) + elseif (checkMatterStop.and.(.not.stopData%yesno2)) then + efoldEndInf = zbrent(find_endinf_matter,efoldBeforeEndInf & + ,efoldAfterEndInf,tolEfoldEnd,findData) + else + efoldEndInf = zbrent(find_endinf_epsilon,efoldBeforeEndInf & + ,efoldAfterEndInf,tolEfoldEnd,findData) + endif + + !read the results in the findData buffer + fieldEndInf = findData%ptrvector2(1:fieldNum) + derivFieldEndInf = findData%ptrvector2(fieldNum+1:2*fieldNum) + hubbleEndInf & + = sqrt(hubble_parameter_square(fieldEndInf,derivFieldEndInf,useVelocity)) + endif + + + + !set the output values to bg_field_evol return + + bg_field_evol%hubble = hubbleEndInf + bg_field_evol%efold = efoldEndInf + bg_field_evol%field = fieldEndInf + + if (useVelocity) then + bg_field_evol%fieldDot = derivFieldEndInf/hubbleEndInf + else + bg_field_evol%fieldDot = derivFieldEndInf + endif + bg_field_evol%epsilon1 = slowroll_first_parameter(fieldEndInf, derivFieldEndInf & + , useVelocity) + bg_field_evol%epsilon1JF = slowroll_first_parameter_JF(fieldEndInf, derivFieldEndInf & + , useVelocity) + + if (associated(findData%ptrvector1)) deallocate(findData%ptrvector1) + if (associated(findData%ptrvector2)) deallocate(findData%ptrvector2) + + + !save some data in memory if ptr input is present, recomputes the + !background knowing the end of inflation. Whatever the total number of + !efold, the last relevant efold (after efoldBeforeEndObs) are + !sampled according to efoldStepDefault + + efoldObs = efoldEndInf - efoldBeforeEndObs + ! print *,'efoldObs efoldEndInf',efoldObs,efoldEndInf + + if (present(efoldDataNum)) then + if (efoldDataNum.le.1) return + endif + + + + if (present(ptrStart)) then + !for debugging + if (dump_file) then + call delete_file('field.dat') + call delete_file('derivfield.dat') + call delete_file('geom.dat') + call delete_file('epsilon1.dat') + call delete_file('epsilon2.dat') + call delete_file('hubble.dat') + call delete_file('potential.dat') + call delete_file('confsquare.dat') + call delete_file('a2chi2.dat') + endif + + + if (present(efoldDataNum)) then + if (efoldObs - infIni%efold.gt.0.) then + longEnoughObs = .true. + efoldStepNoObs = 2.*(efoldObs - infIni%efold)/real(efoldDataNum-1) + efoldStepObs = 2.*efoldBeforeEndObs/real(efoldDataNum-1) + efoldStepNoObs = max(efoldStepNoObs,efoldStepObs) + else + longEnoughObs = .false. + efoldStepNoObs = 0. + efoldStepObs = (efoldEndInf - infIni%efold)/real(efoldDataNum/2-1) + endif + else + longEnoughObs = .false. + efoldStepNoObs = efoldStepDefault + efoldStepObs = efoldStepDefault + endif + + !initialisation + efold = infIni%efold + bgVar = bgVarIni + + inflate = .true. + + ptrCurrent => null() + ptrPrevious => null() + + ! i=0 + + do + + !compute the saved physical quantities + field = bgVar(1:fieldNum) + derivField = bgVar(fieldNum+1:2*fieldNum) + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + epsilon1 = slowroll_first_parameter(field,derivField,useVelocity) + epsilon1JF = slowroll_first_parameter_JF(field,derivField,useVelocity) + + if (hubbleSquare.ge.0d0) then + hubble = sqrt(hubbleSquare) + else + print *,'efold',efold + stop 'bg_field_evol: hubbleSquare < 0' + endif + + + !save the physical quantities as a chained list + + if (.not.associated(ptrStart)) then + allocate(ptrStart); ptrStart%ptr => null(); ptrCurrent => ptrStart + else + allocate(ptrCurrent); ptrCurrent%ptr => null(); ptrPrevious%ptr => ptrCurrent + endif + ptrCurrent%bg%efold = efold + ptrCurrent%bg%hubble = hubble + ptrCurrent%bg%epsilon1 = epsilon1 + ptrCurrent%bg%epsilon1JF = epsilon1JF + ptrCurrent%bg%field = field + ! i=i+1 + ! print *,'stored efold',ptrCurrent%bg%efold,i + if (useVelocity) then + ptrCurrent%bg%fieldDot = derivField/hubble + else + ptrCurrent%bg%fieldDot = derivField + endif + ptrPrevious => ptrCurrent + + !slow down a lot the computation: for test! + if (dump_file) then + call livewrite('field.dat',efold,bgVar(1),bgVar(2),bgVar(3)) + call livewrite('derivfield.dat',efold, ptrCurrent%bg%fieldDot(1) & + ,ptrCurrent%bg%fieldDot(2)) + call livewrite('hubble.dat',efold,hubble) + call livewrite('epsilon1.dat',efold,epsilon1,epsilon1JF) + epsilon2 = slowroll_second_parameter(field,derivField,useVelocity) + call livewrite('epsilon2.dat',efold,epsilon2) + call livewrite('potential.dat',efold,potential(bgVar(1:fieldNum))) + call livewrite('confsquare.dat',efold & + ,conformal_factor_square(bgVar(matterNum+1:fieldNum))) + call livewrite('a2chi2.dat',efold & + ,conformal_factor_square(bgVar(matterNum+1:fieldNum)) & + *bgVar(1)*bgVar(1)) + endif + + + if (efold.eq.efoldObs) then + if (present(infObs)) then + if (infObs%efold.eq.infIni%efold) then + infObs%efold = efold + infObs%field = field + infObs%hubble = hubble + infObs%fieldDot = ptrCurrent%bg%fieldDot + infObs%epsilon1 = epsilon1 + infObs%epsilon1JF = slowroll_first_parameter_JF(field, derivField & + , useVelocity) + ! print *,'infObs set',infObs + endif + endif + endif + + + if (longEnoughObs.and.(efold.lt.efoldObs)) then + efoldNext = min(efold + efoldStepNoObs,efoldObs) + else + efoldNext = min(efold + efoldStepObs,efoldAfterEndInf + efoldExploreOsc) + endif + + ! print *,'efoldNExt',efoldNext + ! read(*,*) + + + !avoid the next step + if (.not.inflate) exit + + !integration again with the stopping criteria + if (useVelocity) then + if (efoldNext.ge.(efoldAfterEndInf + efoldExploreOsc)) then + inflate = .false. + endif + !derivField=Dfield/Dtphys + call easydverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldNext,tolEvol) + + else + if (efoldNext.ge.efoldAfterEndInf) then + inflate = .false. + endif + !derivField=Dfield/Defold + call easydverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldNext,tolEvol) + endif + + enddo + + ptrCurrent => null() + ptrPrevious => null() + + endif + + + end function bg_field_evol + + + + + function find_endinf_epsilon(efold,findData) + use inftools, only : tunedverk + use infprec, only : transfert + implicit none + real(kp), intent(in) :: efold + type(transfert), optional, intent(inout) :: findData + real(kp) :: find_endinf_epsilon + + logical :: useVelocity, useEpsilon1JF + real(kp) :: efoldStart + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum) :: field, derivField + + useEpsilon1JF = findData%yesno2 + useVelocity = findData%yesno1 + efoldStart = findData%real1 + + + if ((.not.associated(findData%ptrvector1)) & + .or.(.not.associated(findData%ptrvector2))) then + stop 'find_endif: ptrvector not associated' + endif + + bgVar = findData%ptrvector1 + + !backward integration from efoldStart found in bg_evol to the wanted efold + if (useVelocity) then + call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar & + ,efold,findData%real2) + else + call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar & + ,efold,findData%real2) + endif + + findData%ptrvector2 = bgVar + + field = bgVar(1:fieldNum) + derivField = bgVar(fieldNum+1:2*fieldNum) + + + !difference between the epsilon corresponding to the current efold and + !the one wanted to end inflation (=1). The efoldEnd is the zero of + !this function. Striclty speaking inflation ends when epsilon1JF=1. + + if (useEpsilon1JF) then + find_endinf_epsilon & + = slowroll_first_parameter_JF(field,derivField,findData%yesno1) - 1._kp + else + find_endinf_epsilon & + = slowroll_first_parameter(field,derivField,findData%yesno1) - 1._kp + endif + + findData%real3 = find_endinf_epsilon + 1._kp + + + end function find_endinf_epsilon + + + + + function find_endinf_matter(efold,findData) + use inftools, only : tunedverk + use infprec, only : transfert + implicit none + real(kp), intent(in) :: efold + type(transfert), optional, intent(inout) :: findData + real(kp) :: find_endinf_matter + + integer :: ifMin,ifMax + logical :: useVelocity, stopForMatterMax + real(kp) :: efoldStart, matterStop + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum) :: field + + + useVelocity = findData%yesno1 + stopForMatterMax = findData%yesno3 + efoldStart = findData%real1 + matterStop = findData%real3 + + ifMin = findData%int1 + ifMax = findData%int2 + + + if ((.not.associated(findData%ptrvector1)) & + .or.(.not.associated(findData%ptrvector2))) then + stop 'find_endif: ptrvector not associated' + endif + + bgVar = findData%ptrvector1 + + !backward integration from efoldStart found in bg_evol to the wanted efold + if (useVelocity) then + call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar & + ,efold,findData%real2) + else + call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar & + ,efold,findData%real2) + endif + + findData%ptrvector2 = bgVar + + field = bgVar(1:fieldNum) + + !difference between the min matter field value corresponding to the + !current efold and the one wanted to end inflation + !(matterMinStop). The efoldEnd is the zero of this function. + + if (stopForMatterMax) then + find_endinf_matter = maxval(field(ifMin:ifMax)) - matterStop + else + find_endinf_matter = minval(field(ifMin:ifMax)) - matterStop + endif + + + end function find_endinf_matter + + + + function find_endinf_hubble(efold,findData) + use inftools, only : tunedverk + use infprec, only : transfert + implicit none + real(kp), intent(in) :: efold + type(transfert), optional, intent(inout) :: findData + real(kp) :: find_endinf_hubble + + logical :: useVelocity + real(kp) :: efoldStart, hubbleStop,hubbleSquare + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum) :: field,derivField + + + useVelocity = findData%yesno1 + + efoldStart = findData%real1 + hubbleStop = findData%real3 + + + if ((.not.associated(findData%ptrvector1)) & + .or.(.not.associated(findData%ptrvector2))) then + stop 'find_endif: ptrvector not associated' + endif + + bgVar = findData%ptrvector1 + + !backward integration from efoldStart found in bg_evol to the wanted efold + if (useVelocity) then + call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar & + ,efold,findData%real2) + else + call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar & + ,efold,findData%real2) + endif + + findData%ptrvector2 = bgVar + + field = bgVar(1:fieldNum) + derivField = bgVar(fieldNum+1:2*fieldNum) + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + + + find_endinf_hubble = hubbleSquare - hubbleStop**2 + + + end function find_endinf_hubble + + + + + subroutine bg_field_dot_decoupled(neqs,efold,bgVar,bgVarDot,stopData) + !for derivField=Dfield/Defold the field equations decouple from the + !Hubble flow. However, this decomposition becomes singular when the + !potential vanishes and the integration fails a that point. Harmless + !for the inflationary era. + + use infprec, only : transfert + use infbgmodel, only : metric, metric_inverse + implicit none + + integer :: neqs + real(kp) :: efold + real(kp), dimension(neqs) :: bgVar + real(kp), dimension(neqs) :: bgVarDot + type(transfert), optional, intent(inout) :: stopData + + integer :: i + real(kp), dimension(fieldNum) :: dlnPotVec + real(kp), dimension(fieldNum) :: field, christVec + real(kp), dimension(fieldNum) :: fieldDot, fieldDotDot + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel + real(kp) :: fieldDotSquare, epsilon1, hubbleSquare + + logical, save :: stopNow=.false. + + + field = bgVar(1:fieldNum) + fieldDot = bgVar(fieldNum+1:2*fieldNum) + christoffel = connection_affine(field) + + fieldDotSquare = dot_product(fieldDot,matmul(metric(field),fieldDot)) + + if (present(stopData)) then + !use epsilon1JF or not to stop inflation + if (stopData%check) then + + if (stopData%yesno1) then + epsilon1 = slowroll_first_parameter_JF(field,fieldDot,.false.) + else + epsilon1 = fieldDotSquare/2d0 + endif + + if (stopData%yesno2) then + if (stopData%yesno3) then + stopNow = (maxval(field(stopData%int1:stopData%int2)) & + .gt.stopData%real2) + else + stopNow = (minval(field(stopData%int1:stopData%int2)) & + .lt.stopData%real2) + endif + endif + + if (stopData%yesno4) then + hubbleSquare = hubble_parameter_square(field,fieldDot,.false.) + stopNow = (hubbleSquare.lt.(stopData%real2)**2) + endif + + if (stopNow.or.(epsilon1.gt.stopData%real1)) then + stopData%update = .true. + stopData%xend = efold + stopData%yesno2 = .false. + stopData%yesno4 = .false. + endif + + endif + endif + + do i=1,fieldNum + christVec(i) = dot_product(fieldDot,matmul(christoffel(i,:,:),fieldDot)) + enddo + + ! dlnPotVec = deriv_ln_potential_vec(field) + + dlnPotVec = matmul(metric_inverse(field),deriv_ln_potential(field)) + + fieldDotDot = -christVec - (3d0 - fieldDotSquare/2d0)*(fieldDot + dlnPotVec) + + bgVarDot(1:fieldNum) = fieldDot + bgVarDot(fieldNum+1:2*fieldNum) = fieldDotDot + + end subroutine bg_field_dot_decoupled + + + + + + subroutine bg_field_dot_coupled(neqs,efold,bgVar,bgVarDot,stopData) + !for derivField=Dfield/Dtphys the field equations are coupled to the + !hubble flow. This avoid the singular behavior of the decoupled + !equations and allows to properly sample the oscillations of the field + !at the end of inflation. + + use infprec, only : transfert + use infbgmodel, only : metric, metric_inverse + implicit none + + integer :: neqs + real(kp) :: efold + real(kp), dimension(neqs) :: bgVar + real(kp), dimension(neqs) :: bgVarDot + type(transfert), optional, intent(inout) :: stopData + + integer :: i + real(kp), dimension(fieldNum) :: dPotVec + real(kp), dimension(fieldNum) :: field, velocity + real(kp), dimension(fieldNum) :: fieldDot, velocityDot, christVec + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel + real(kp) :: velocitySquare, epsilon1, hubbleSquare, hubble + + logical, save :: stopNow = .false. + + + field = bgVar(1:fieldNum) + velocity = bgVar(fieldNum+1:2*fieldNum) + christoffel = connection_affine(field) + + velocitySquare = dot_product(velocity,matmul(metric(field),velocity)) + + do i=1,fieldNum + christVec(i) = dot_product(velocity(:),matmul(christoffel(i,:,:),velocity(:))) + enddo + + ! dPotVec = deriv_potential_vec(field) + dPotVec = matmul(metric_inverse(field),deriv_potential(field)) + + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + if (hubbleSquare.ge.0.) then + hubble = sqrt(hubbleSquare) + else + print *,'field= ',field + print *,'velocity= ',velocity + stop 'bg_field_dot_coupled: hubbleSquare < 0' + endif + + if (present(stopData)) then + !use epsilon1JF or not to stop inflation + if (stopData%check) then + if (stopData%yesno1) then + epsilon1 = slowroll_first_parameter_JF(field,velocity,.true.) + else + epsilon1 = velocitySquare/2d0/hubbleSquare + endif + + if (stopData%yesno2) then + if (stopData%yesno3) then + stopNow = (maxval(field(stopData%int1:stopData%int2)) & + .gt.stopData%real2) + else + stopNow = (minval(field(stopData%int1:stopData%int2)) & + .lt.stopData%real2) + endif + endif + + if (stopData%yesno4) stopNow = hubble.le.stopData%real2 + + + if (stopNow.or.(epsilon1.gt.stopData%real1)) then + stopData%update = .true. + stopData%xend = efold + stopData%yesno2 = .false. + stopData%yesno4 = .false. + endif + + ! print *,'efold field',efold,field + ! print *,'eps1 eps2',epsilon1,slowroll_second_parameter(field,velocity,.true.) + ! read(*,*) + endif + endif + + fieldDot = velocity/hubble + velocityDot = -3d0*velocity - (christVec + dPotVec)/hubble + + bgVarDot(1:fieldNum) = fieldDot + bgVarDot(fieldNum+1:2*fieldNum) = velocityDot + + end subroutine bg_field_dot_coupled + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !geometrical functions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + + function hubble_parameter_square(field,derivField,useVelocity) + !in unit of kappa^2 + use infbgmodel, only : metric + implicit none + real(kp) :: hubble_parameter_square + real(kp), dimension(fieldNum), intent(in) :: field, derivfield + logical, intent(in) :: useVelocity + + real(kp) :: derivFieldSquare + + derivFieldSquare = dot_product(derivField,matmul(metric(field),derivField)) + + if (useVelocity) then + hubble_parameter_square = (derivFieldSquare + 2d0*potential(field))/6d0 + else + hubble_parameter_square = 2d0*potential(field)/(6d0 - derivFieldSquare) + endif + + end function hubble_parameter_square + + + + + function slowroll_first_parameter(field,derivField,useVelocity) + !epsilon1 = epsilon + use infbgmodel, only : metric + implicit none + real(kp) :: slowroll_first_parameter + real(kp), dimension(fieldNum), intent(in) :: field, derivField + logical, intent(in) :: useVelocity + + real(kp) :: derivFieldSquare, hubbleSquare + + derivFieldSquare = dot_product(derivField,matmul(metric(field),derivField)) + + if (useVelocity) then + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + slowroll_first_parameter = derivFieldSquare/2d0/hubbleSquare + else + slowroll_first_parameter = derivFieldSquare/2d0 + endif + + + end function slowroll_first_parameter + + + + + function slowroll_second_parameter(field,derivField,useVelocity) + !epsilon2 = 2(epsilon - delta) + implicit none + real(kp) :: slowroll_second_parameter + real(kp), dimension(fieldNum), intent(in) :: field, derivField + logical, intent(in) :: useVelocity + + real(kp), dimension(fieldNum) :: fieldDot + real(kp) :: epsilon1 + real(kp) :: hubbleSquare, derivPotFieldDot + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + + if (useVelocity) then + fieldDot = derivField/sqrt(hubbleSquare) + else + fieldDot = derivField + endif + + epsilon1 = slowroll_first_parameter(field,derivField,useVelocity) + + if (epsilon1.ne.0.) then + derivPotFieldDot = dot_product(deriv_potential(field),fieldDot) + + slowroll_second_parameter = -6d0 + 2d0*epsilon1 & + - derivPotFieldDot/(epsilon1*hubbleSquare) + else + slowroll_second_parameter = 0. + endif + + end function slowroll_second_parameter + + + + + function slowroll_first_parameter_JF(field,derivField,useVelocity) + !this is epsilon1 EF, up to 2% when dilaton couplings = 1 + use infbgmodel, only : conformal_first_gradient, conformal_second_gradient + use infbgmodel, only : metric_inverse + implicit none + real(kp) :: slowroll_first_parameter_JF + real(kp), dimension(fieldNum), intent(in) :: field, derivField + logical, intent(in) :: useVelocity + + real(kp), dimension(fieldNum) :: christVec, fieldDot, potDerivVec + real(kp), dimension(dilatonNum) :: dilaton, dilatonDot,confFirstGrad + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel + real(kp) :: derivFieldSquare, hubbleSquare, epsilon1, epsilon1Xfactor, shift + real(kp) :: confFirstGradXdilDot + + integer :: i + + hubbleSquare = hubble_parameter_square(field,derivField,useVelocity) + + if (useVelocity) then + fieldDot = derivField/sqrt(hubbleSquare) + else + fieldDot = derivField + endif + + dilaton = field(matterNum+1:fieldNum) + dilatonDot = fieldDot(matterNum+1:fieldNum) + confFirstGrad = conformal_first_gradient(dilaton) + confSecondGrad = conformal_second_gradient(dilaton) + ! potDerivVec = deriv_potential_vec(field) + potDerivVec = matmul(metric_inverse(field),deriv_potential(field)) + christoffel = connection_affine(field) + + do i=1,fieldNum + christVec(i) = dot_product(fieldDot(:),matmul(christoffel(i,:,:),fieldDot(:))) + enddo + + confFirstGradXdilDot = dot_product(confFirstGrad,dilatonDot) + + epsilon1 = slowroll_first_parameter(field,derivField,useVelocity) + + + epsilon1Xfactor = (epsilon1 + confFirstGradXdilDot)/(1._kp + confFirstGradXdilDot) + + + shift = ((3._kp - epsilon1)*confFirstGradXdilDot & + + dot_product(confFirstGrad,christVec(matterNum+1:fieldNum)) & + + dot_product(confFirstGrad,potDerivVec(matterNum+1:fieldNum)/hubbleSquare) & + - dot_product(dilatonDot, matmul(confSecondGrad,dilatonDot))) & + / (1._kp + confFirstGradXdilDot)**2 + + + slowroll_first_parameter_JF = epsilon1Xfactor + shift + + + end function slowroll_first_parameter_JF + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !gravity sector functions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function connection_affine(field) + !first index contravariant, 2 others covariant and symmetric + use infbgmodel, only : metric_inverse, conformal_first_gradient + use infbgmodel, only : conformal_factor_square + implicit none + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum,fieldNum) :: metricInv + real(kp), dimension(dilatonNum,dilatonNum) :: metricInvConf + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: connection_affine + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton + real(kp), dimension(dilatonNum) :: confFirstGradVec, confFirstGrad + + integer :: i + + connection_affine = 0._kp + + metricInv = metric_inverse(field) + metricInvConf(1:dilatonNum,1:dilatonNum) & + = metricInv(matterNum+1:fieldNum,matterNum+1:fieldNum) + + dilaton=field(matterNum+1:fieldNum) + confFirstGrad = conformal_first_gradient(dilaton) + confFirstGradVec = matmul(metricInvConf,confFirstGrad) + confSquare = conformal_factor_square(dilaton) + + do i=1,dilatonNum + connection_affine(1:matterNum,1:matterNum,matterNum+i) & + = confFirstGrad(i) + connection_affine(1:matterNum,matterNum+i,1:matterNum) & + = confFirstGrad(i) + enddo + + do i=1,matterNum + connection_affine(matterNum+1:fieldNum,i,i) & + = - confSquare * confFirstGradVec(1:dilatonNum) + enddo + + + end function connection_affine + + + + + function deriv_connection_affine(field) + !first partial derivative of the christoffel: first index contrariant, + !3 others covariant + use infbgmodel, only : metric_inverse, conformal_first_gradient + use infbgmodel, only : conformal_second_gradient, conformal_factor_square + implicit none + + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum,fieldNum) :: metricInv + real (kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv + real(kp), dimension(fieldNum,fieldNum,fieldNum,fieldNum) :: deriv_connection_affine + + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad, confFirstGradVec + real(kp), dimension(dilatonNum,dilatonNum) :: metricInvConf + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad, confSecondGradVec + integer :: i,j,k + + deriv_connection_affine = 0._kp + + dilaton(1:dilatonNum) = field(matterNum+1:fieldNum) + confSquare = conformal_factor_square(dilaton) + + ! metricDeriv = deriv_metric(field) + metricInv = metric_inverse(field) + metricInvConf = metricInv(matterNum+1:fieldNum,matterNum+1:fieldNum) + + confFirstGrad = conformal_first_gradient(dilaton) + confFirstGradVec = matmul(metricInvConf,confFirstGrad) + confSecondGrad = conformal_second_gradient(dilaton) + confSecondGradVec = matmul(metricInvConf,confSecondGrad) + + + do j=1,dilatonNum + do i=1,dilatonNum + + deriv_connection_affine(1:matterNum,1:matterNum,matterNum+i,matterNum+j) & + = confSecondGrad(i,j) + deriv_connection_affine(1:matterNum,matterNum+i,1:matterNum,matterNum+j) & + = confSecondGrad(i,j) + + do k=1,matterNum + deriv_connection_affine(matterNum+i,k,k,matterNum+j) & + = - confSquare * (confSecondGradVec(i,j) & + + 2._kp * confFirstGradVec(i) * confFirstGrad(j)) + + !zero when the the metric for the dilaton is constant and diagonal + ! + confSquare * dot_product(metricInvConf(i,:) & + ! ,matmul(metricDeriv(matterNum+1:fieldNum,matterNum+1:fieldNum,j) & + ! ,confFirstGradVec)) + enddo + + enddo + enddo + + + end function deriv_connection_affine + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !overall potential (matter + gravity) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function potential(field) + !S=1/(2kappa^2) {{ int{sqrt(-g) d^4 x} [ R - metric Dfield Dfield - 2*potential(Field)] }} + use infbgmodel, only : matter_potential, conformal_factor_square + implicit none + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(matterNum) :: matter + real(kp), dimension(dilatonNum) :: dilaton + real(kp) :: potential + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + potential = matter_potential(matter)*(conformal_factor_square(dilaton))**2 + + end function potential + + + + + function deriv_potential(field) + !with respect to the fields + use infbgmodel, only : deriv_matter_potential, conformal_first_gradient + use infbgmodel, only : conformal_factor_square + implicit none + real(kp), dimension(fieldNum) :: deriv_potential + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(matterNum) :: matter, derivMatterPot + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + + real(kp) :: potentialVal + + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + potentialVal = potential(field) + derivMatterPot = deriv_matter_potential(matter) + confFirstGrad = conformal_first_gradient(dilaton) + + deriv_potential(1:matterNum) & + = derivMatterPot(1:matterNum)*(conformal_factor_square(dilaton))**2 + + deriv_potential(matterNum+1:fieldNum) & + = 4._kp*confFirstGrad(1:dilatonNum)*potentialVal + + end function deriv_potential + + + + + function deriv_second_potential(field) + use infbgmodel, only : deriv_matter_potential, deriv_second_matter_potential + use infbgmodel, only : conformal_first_gradient, conformal_second_gradient + use infbgmodel, only : conformal_factor_square + implicit none + real(kp), dimension(fieldNum,fieldNum) :: deriv_second_potential + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(fieldNum) :: derivPot + real(kp), dimension(matterNum) :: matter, derivMatterPot + real(kp), dimension(matterNum,matterNum) :: derivSecondMatterPot + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad + + real(kp) :: potentialVal + integer :: i,j + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + potentialVal = potential(field) + + derivPot = deriv_potential(field) + derivMatterPot = deriv_matter_potential(matter) + derivSecondMatterPot = deriv_second_matter_potential(matter) + + confFirstGrad = conformal_first_gradient(dilaton) + confSecondGrad = conformal_second_gradient(dilaton) + + deriv_second_potential(1:matterNum,1:matterNum) & + = derivSecondMatterPot(1:matterNum,1:matterNum) & + *(conformal_factor_square(dilaton))**2 + + do i=1,matterNum + deriv_second_potential(i,matterNum+1:fieldNum) & + = derivPot(i) * 4._kp*confFirstGrad(1:dilatonNum) + deriv_second_potential(matterNum+1:fieldNum,i) & + = deriv_second_potential(i,matterNum+1:fieldNum) + enddo + + do i=1,dilatonNum + do j=1,dilatonNum + deriv_second_potential(matterNum+i,matterNum+j) = potentialVal & + * (4._kp*confSecondGrad(i,j) + 4._kp*confFirstGrad(i) & + * 4._kp*confFirstGrad(j)) + enddo + enddo + + end function deriv_second_potential + + + + + function deriv_ln_potential(field) + use infbgmodel, only : conformal_first_gradient + implicit none + real(kp), dimension(fieldNum) :: deriv_ln_potential + real(kp), dimension(fieldNum), intent(in) :: field + + real(kp), dimension(matterNum) :: matter,derivLnMatterPot + real(kp), dimension(dilatonNum) :: dilaton,confFirstGrad + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + + derivLnMatterPot = deriv_ln_matter_potential(matter) + confFirstGrad = conformal_first_gradient(dilaton) + + deriv_ln_potential(1:matterNum) = derivLnMatterPot(1:matterNum) + + deriv_ln_potential(matterNum+1:fieldNum) = 4._kp*confFirstGrad(1:dilatonNum) + + end function deriv_ln_potential + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !matter sector functions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function deriv_ln_matter_potential(matter) + use infbgmodel, only : matter_potential, deriv_matter_potential + implicit none + real(kp), dimension(matterNum) :: deriv_ln_matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: matterPotential + + matterPotential = matter_potential(matter) + + if (matterPotential.ne.0._kp) then + deriv_ln_matter_potential = deriv_matter_potential(matter)/matterPotential + else + stop 'infbg:deriv_ln_matter_potential: matter_potential vanishes!' + endif + + ! deriv_ln_matter_potential(1) = 2._kp/chi + + end function deriv_ln_matter_potential + + + + + function matter_energy_density(field,velocity) + !energy density of the matter fields in the Einstein Frame + !A^2 (Dchi/Dtphys)^2 + A^4 U + use infbgmodel, only : matter_potential, conformal_factor_square + implicit none + real(kp) :: matter_energy_density + real(kp), dimension(fieldNum), intent(in) :: field,velocity + + real(kp), dimension(matterNum) :: matter, matterVel + real(kp), dimension(dilatonNum) :: dilaton + real(kp) :: confSquare + + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + matterVel = velocity(1:matterNum) + confSquare = conformal_factor_square(dilaton) + + matter_energy_density & + = 0.5d0*confSquare * dot_product(matterVel,matterVel) & + + matter_potential(matter) * confSquare**2 + + end function matter_energy_density + + + + + function matter_energy_density_JF(field,velocity) + !energy density of the matter fields in the Jordan Frame + !EF/A^4 + use infbgmodel, only : conformal_factor_square + implicit none + real(kp) :: matter_energy_density_JF + real(kp), dimension(fieldNum), intent(in) :: field,velocity + + real(kp), dimension(dilatonNum) :: dilaton + real(kp) :: confSquare + real(kp) :: matterEnergyDensEF + + dilaton = field(matterNum+1:fieldNum) + + confSquare = conformal_factor_square(dilaton) + matterEnergyDensEF = matter_energy_density(field,velocity) + + matter_energy_density_JF = matterEnergyDensEF/confSquare**2 + + end function matter_energy_density_JF + + + + end module infbg diff -r -c -b -N cosmomc/camb/infbgmodel.f90 cosmomc_fields/camb/infbgmodel.f90 *** cosmomc/camb/infbgmodel.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infbgmodel.f90 2009-04-27 13:35:14.151148526 +0200 *************** *** 0 **** --- 1,597 ---- + module infbgmodel + use infprec, only : kp + implicit none + + private + + logical, parameter :: display = .true. + + + integer, parameter :: matterNum = 1 + integer, parameter :: dilatonNum = 1 + integer, parameter :: fieldNum = matterNum + dilatonNum + + integer, parameter :: potParamNum = 5 + integer, parameter :: matterParamNum = potParamNum + 2 + integer, parameter :: dilatonParamNum = 0 + integer, parameter :: infParamNum = matterParamNum + dilatonParamNum + + + + type infbgparam + !label identifier + character(len=6) :: name + !coupling constants [mattercouplings,dilatoncouplings] + real(kp), dimension(infParamNum) :: consts + ![dilaton degrees of freedom] + real(kp), dimension(dilatonNum) :: conforms + !matterfield values + real(kp), dimension(matterNum) :: matters + end type infbgparam + + + + real(kp), dimension(matterParamNum), save :: matterParam = 0._kp + real(kp), dimension(potParamNum), save :: potParam = 0._kp + + + interface operator (==) + module procedure infparam_equal + end interface + + + interface operator (/=) + module procedure infparam_unequal + end interface + + + public infbgparam + public operator(==),operator(/=) + + public matterParam + public fieldNum, dilatonNum, matterNum + public infParamNum, matterParamNum, dilatonParamNum + + public set_infbg_param + + public matter_potential + public deriv_matter_potential, deriv_second_matter_potential + + public conformal_factor_square + public conformal_first_gradient, conformal_second_gradient + + public metric, metric_inverse, deriv_metric + + + contains + + + function infparam_equal(infparamA, infparamB) + implicit none + type(infbgparam), intent(in) :: infparamA, infparamB + logical :: infparam_equal + + infparam_equal = ((infparamA%name == infparamB%name) & + .and. all(infparamA%conforms == infParamB%conforms) & + .and. all(infparamA%matters == infparamA%matters) & + .and. all(infparamA%consts == infparamB%consts)) + + end function infparam_equal + + + + + function infparam_unequal(infparamA, infparamB) + implicit none + type(infbgparam), intent(in) :: infparamA, infparamB + logical :: infparam_unequal + + infparam_unequal = ((infparamA%name /= infparamB%name) & + .or. any(infparamA%conforms /= infParamB%conforms) & + .or. any(infparamA%matters /= infparamA%matters) & + .or. any(infparamA%consts /= infparamB%consts)) + + end function infparam_unequal + + + + + + + function set_infbg_param(infParam) + implicit none + logical :: set_infbg_param + type(infbgparam), intent(in) :: infParam + + logical :: badParams = .true. + + real(kp) :: kpbuffer + + set_infbg_param=.false. + + !the matter potential is parametrized as + ! + ! U = [(p1 + p4 ln F) F^p2 + p3]^p5 + ! + !where the pi are the potential params. In terms of the "matterParams", they read + ! + ! p1 = sign(m1) m1^4 + ! p2 = m2 + ! p3 = m3^4 + ! p4 = sign(m4) m4^4 + ! p5 = m5 + !The matterParams mi are set from the ci params according to the model + !under scrutiny. Only the ci (infparam%consts) are public. + ! + ! m6=c6 + ! + ! is a field value that bounds the initial field values (ex, the throat size for kklt) + ! + ! m7=c7 + ! + !is a field value that stops inflation (ex, hybrid, kklt) instead of + ! the condition epsilon1 = 1 + ! + ! c8,c9, etc.. no yet used + ! + !Other notations: M=c1; mu=c3, p=c2; nu=c4 + + + + select case (infParam%name) + + + case ('largef') + + ! U = c1^4 F^c2 + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).ne.0._kp).or.(infParam%consts(5).ne.1._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'large field: improper params' + endif + + + matterParam(1) = infParam%consts(1) + matterParam(2) = infParam%consts(2) + matterParam(3) = 0._kp + matterParam(4) = 0._kp + matterParam(5) = 1._kp + + !fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) + !fieldStop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + case ('smallf') + + ! U = c1^4 [1 - (F/c3)^c2] + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).le.0._kp).or.(infParam%consts(5).ne.1._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'small field: improper params' + endif + + matterParam(1) = - infParam%consts(1) & + /(infParam%consts(3)**(infParam%consts(2)/4._kp)) + matterParam(2) = infParam%consts(2) + matterParam(3) = infParam%consts(1) + matterParam(4) = 0._kp + matterParam(5) = 1._kp + + !fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) + !fieldStop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + if (maxval(infParam%matters/infParam%conforms(1)) & + .gt.infParam%consts(3)) then + write(*,*)'set_infbg_param: not small fields initially' + write(*,*)'model name: ',infParam%name + write(*,*)'matterScale = ',infParam%consts(3) + write(*,*)'matterField = ',maxval(infParam%matters) + endif + + + + + case ('hybrid') + + ! U = c1^4 [1 + (F/c3)^c2] + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).le.0._kp) & + .or.(infParam%consts(5).ne.1._kp)) + + + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'hybrid models: improper params' + endif + + matterParam(1) = infParam%consts(1) & + /(infParam%consts(3)**(infParam%consts(2)/4._kp)) + matterParam(2) = infParam%consts(2) + matterParam(3) = infParam%consts(1) + matterParam(4) = 0._kp + matterParam(5) = 1._kp + + !fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) + !fieldstop value + matterParam(matterParamNum) =infParam%consts(matterParamNum) + + + + case ('runmas') + + ! U = c1^4 { 1 + c4[1/c2 - ln(F/c3)] F^c2 } + + badParams = ((infParam%consts(3).le.0._kp).or.(infParam%consts(3).gt.1._kp) & + .or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(1).le.0._kp) & + .or.(infParam%consts(5).ne.1._kp)) + + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'running mass: improper params' + endif + + kpbuffer = infParam%consts(4)/infParam%consts(2) & + + infParam%consts(4)*log(infParam%consts(3)) + matterParam(1) = infParam%consts(1)*kpbuffer**0.25_kp + + matterParam(2) = infParam%consts(2) + matterParam(3) = infParam%consts(1) + + kpbuffer = infParam%consts(4) + matterParam(4) = -infParam%consts(1)*kpbuffer**0.25_kp + + matterParam(1) = infParam%consts(1) * sign(abs(kpbuffer)**0.25,kpbuffer) + + kpbuffer = infParam%consts(4) + matterParam(4) = - infParam%consts(1) * sign(abs(kpbuffer)**0.25,kpbuffer) + + matterParam(5) = 1._kp + + !fieldUv limit + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) + !fieldstop value + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + + case('kklmmt') + + ! U = c1^4 * [1 - (F/c3)^(-c2)] with c2 > 0 for c5=1 or + ! U = c1^4 / [1 + (F/c3)^(-c2)] with c2 > 0 for c5=-1 + ! + ! c6 is Phi_string related to the flux number N + ! + ! c7 is PhiUv related to the brane tension of the string coupling + + + badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) & + .or.(infParam%consts(3).le.0._kp) & + .or.(abs(infParam%consts(5)).ne.1._kp) & + .or.(infParam%consts(matterParamNum-1).lt.0._kp)) + + if (badParams) then + write(*,*)'model name: ',infParam%name + write(*,*)'consts = ',infParam%consts(1:infParamNum) + stop 'kklmmt: improper params' + endif + + + matterParam(1) = - sign(infParam%consts(1)**infParam%consts(5) & + /(infParam%consts(3)**(-infParam%consts(2)/4._kp)) & + ,infParam%consts(5)) + matterParam(2) = -infParam%consts(2) + matterParam(3) = infParam%consts(1)**infParam%consts(5) + matterParam(4) = 0._kp + matterParam(5) = infParam%consts(5) + + !fieldUv: prevents brane out of the throat + matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1) + !flux number N + matterParam(matterParamNum) = infParam%consts(matterParamNum) + + + case default + stop 'set_infbg_param: no such a model' + + end select + + + if (display) then + write(*,*)'set_infbg_param: model is ',infParam%name + ! write(*,*)'matterParam = ',matterParam + endif + + + !update static potential parameters + call set_potential_param() + set_infbg_param = .true. + + end function set_infbg_param + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !full numerical integration functions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !matter sector: potentials + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine set_potential_param() + implicit none + + potParam(1) = sign(matterParam(1)**4,matterParam(1)) !/matterParam(3)**4 + potParam(2) = matterParam(2) + potParam(3) = matterParam(3)**4 + potParam(4) = sign(matterParam(4)**4,matterParam(4)) !/matterParam(3)**4 + potParam(5) = matterParam(5) + + if (display) write(*,*)'set_potential_param: potParam = ',potParam + + end subroutine set_potential_param + + + + + function matter_potential(matter) + implicit none + real(kp) :: matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: chi + + chi = matter(1) + + ! matter_potential = (potParam(1) + potParam(4)*log(chi)) * chi**potParam(2) & + ! + potParam(3) + + + ! matter_potential = potParam(3) * (1._kp + & + ! (potParam(1) + potParam(4)*log(chi))*chi**potParam(2) & + ! )**potParam(5) + + + matter_potential = (potParam(3) + & + (potParam(1) + potParam(4)*log(chi))*chi**potParam(2) & + )**potParam(5) + + + if (matter_potential.lt.0._kp) then + write(*,*)'matterField = ',chi + write(*,*)'potParam = ',potParam + write(*,*)'matter_potential = ',matter_potential + stop 'infbgmodel: matter_potential < 0!' + endif + end function matter_potential + + + + function deriv_matter_potential(matter) + implicit none + real(kp), dimension(matterNum) :: deriv_matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: chi + + chi = matter(1) + + ! deriv_matter_potential(1) = (potParam(1)*potParam(2) + potParam(4) & + ! + potParam(4)*potParam(2)*log(chi)) * chi**(potParam(2) - 1._kp) + + + ! deriv_matter_potential(1) = potParam(3) * & + ! (potParam(1)*potParam(2) + potParam(4) & + ! + potParam(4)*potParam(2)*log(chi)) * chi**(potParam(2) - 1._kp) & + ! * potParam(5) & + ! * ((potParam(1) + potParam(4)*log(chi))*chi**(potParam(2)) & + ! + 1._kp)**(potParam(5)-1._kp) + + + deriv_matter_potential(1) = potParam(5)*chi**(potParam(2)-1._kp) & + * (potParam(1)*potParam(2) + potParam(4) + potParam(4)*potParam(2)*log(chi)) & + * ( (potParam(1) + potParam(4)*log(chi))*chi**potParam(2) + potParam(3) ) & + ** (potParam(5)-1._kp) + + end function deriv_matter_potential + + + + function deriv_second_matter_potential(matter) + implicit none + real(kp), dimension(matterNum,matterNum) :: deriv_second_matter_potential + real(kp), dimension(matterNum) :: matter + + real(kp) :: chi + + chi = matter(1) + + + ! deriv_second_matter_potential(1,1) = ((potParam(1)*potParam(2) + potParam(4)) & + ! * (potParam(2) - 1._kp) + potParam(4)*potParam(2) & + ! + potParam(4)*potParam(2)*(potParam(2) - 1._kp)*log(chi)) & + ! * chi**(potParam(2) - 2._kp) + + ! deriv_second_matter_potential(1,1) = chi**(-2._kp + potParam(2)) * potParam(3) & + ! * (1._kp + chi**potParam(2) * (potParam(1) & + ! + Log(chi)*potParam(4)))**(-2._kp + potParam(5)) * ((potParam(1) & + ! * (-1._kp + potParam(2)) * potParam(2) + Log(chi)*(-1._kp + potParam(2)) & + ! * potParam(2) * potParam(4) + (-1._kp + 2._kp * potParam(2)) * potParam(4)) & + ! * (1._kp + chi**potParam(2) * (potParam(1) + Log(chi) * potParam(4))) & + ! + chi**potParam(2) * (potParam(1) * potParam(2) + potParam(4) & + ! + Log(chi) * potParam(2) * potParam(4))**2 * (-1._kp + potParam(5))) & + ! * potParam(5) + + + + deriv_second_matter_potential(1,1) = chi**(-2._kp + potParam(2)) * (potParam(3) & + + chi**potParam(2)*(potParam(1) + Log(chi)*potParam(4)))**(-2._kp & + + potParam(5))*((potParam(1)*(-1._kp + potParam(2))*potParam(2) & + + Log(chi)*(-1._kp + potParam(2))*potParam(2)*potParam(4) & + + (-1._kp + 2._kp*potParam(2))*potParam(4))*(potParam(3)+chi**potParam(2) & + * (potParam(1) + Log(chi)*potParam(4))) + chi**potParam(2) & + * (potParam(1)*potParam(2)+potParam(4)+Log(chi)*potParam(2)*potParam(4))**2._kp & + * (-1._kp + potParam(5)))*potParam(5) + + + + end function deriv_second_matter_potential + + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !gravity sector: metric on the sigma-model field manifold + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + + function metric(field) + implicit none + real(kp), dimension(fieldNum), intent(in) :: field + real(kp), dimension(fieldNum,fieldNum) :: metric + + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton + integer :: i + + metric = 0._kp + + dilaton = field(matterNum+1:fieldNum) + confSquare = conformal_factor_square(dilaton) + + do i=1,matterNum + metric(i,i) = confSquare + enddo + + do i=1,dilatonNum + metric(i+matterNum,i+matterNum) = 1._kp + enddo + + end function metric + + + + function metric_inverse(field) + implicit none + real(kp), dimension(fieldNum) :: field + real(kp), dimension(fieldNum,fieldNum) :: metricVal, metric_inverse + real(kp) :: det + + integer :: i + + metric_inverse = 0._kp + + metricVal = metric(field) + + det = 1._kp + do i=1,fieldNum + det = det*metricVal(i,i) + enddo + + if (det.ne.0.) then + do i=1,fieldNum + metric_inverse(i,i) = 1._kp/metricVal(i,i) + enddo + else + stop 'inverse_metric: singularity in the sigma-model!' + endif + + end function metric_inverse + + + + function deriv_metric(field) + implicit none + real(kp), dimension(fieldNum), intent(in) :: field + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: deriv_metric + + real(kp) :: confSquare + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + integer :: i + + deriv_metric = 0._kp + + dilaton = field(matterNum+1:fieldNum) + confSquare = conformal_factor_square(dilaton) + confFirstGrad = conformal_first_gradient(dilaton) + + do i=1,matterNum + deriv_metric(i,i,matterNum+1:fieldNum) & + = 2._kp * confFirstGrad(1:dilatonNum)* confSquare + enddo + + + + end function deriv_metric + + + + function conformal_factor_square(dilaton) + !A^2 + implicit none + real(kp), dimension(dilatonNum), intent(in) :: dilaton + real(kp) :: conformal_factor_square + + conformal_factor_square = 1._kp + + + end function conformal_factor_square + + + + function conformal_first_gradient(dilaton) + !alpha_field = Dln(A)/Dfield + implicit none + real(kp), dimension(dilatonNum) :: conformal_first_gradient + real(kp), dimension(dilatonNum) :: dilaton + + + conformal_first_gradient = 0._kp + + + end function conformal_first_gradient + + + + function conformal_second_gradient(dilaton) + !D alpha_field / D field + implicit none + real(kp), dimension(dilatonNum,dilatonNum) :: conformal_second_gradient + real(kp), dimension(dilatonNum) :: dilaton + + conformal_second_gradient = 0._kp + + + end function conformal_second_gradient + + + + + end module infbgmodel diff -r -c -b -N cosmomc/camb/infbgspline.f90 cosmomc_fields/camb/infbgspline.f90 *** cosmomc/camb/infbgspline.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infbgspline.f90 2006-05-18 18:05:05.000000000 +0200 *************** *** 0 **** --- 1,297 ---- + module infbgspline + !splinning and interpolation routines for the background. Apart for + !test they are only used to determine rapidly the bfold of quantum + !mode creation + + use infprec, only : kp + implicit none + + private + + !for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_file = .false. + + + !bad idea, force the compiler to make copy of pointer arrays at each + !call of bspline (involves explicit shape array) + ! type splineinfbg + ! integer :: order + ! integer :: bcoefNum + ! integer :: fieldNum + ! real(kp), dimension(:), pointer :: bfoldKnot, epsilon1JFBcoef + ! real(kp), dimension(:), pointer :: hubbleBcoef, epsilon1Bcoef + ! real(kp), dimension(:,:), pointer :: fieldBcoef, fieldDotBcoef + ! end type splineinfbg + + + !to be initialized explicitely from bg computation + + ! type(splineinfbg) :: splineBg + + integer, save :: order + integer, save :: bcoefNum + integer, save :: splineNum + real(kp), dimension(:), allocatable, save :: bfoldKnot, epsilon1JFBcoef + real(kp), dimension(:), allocatable, save :: hubbleBcoef, epsilon1Bcoef + real(kp), dimension(:,:), allocatable, save :: fieldBcoef, fieldDotBcoef + + + + public free_infbg_spline,set_infbg_spline, check_infbg_spline + public splineval_hubble_parameter,splineval_epsilon1,splineval_epsilon1JF + public splineval_field,splineval_fielddot + + contains + + + + function check_infbg_spline() + implicit none + logical :: check_infbg_spline + + check_infbg_spline = (allocated(bfoldKnot) & + .or. allocated(epsilon1JFBcoef) & + .or. allocated(hubbleBcoef) & + .or. allocated(epsilon1Bcoef) & + .or. allocated(fieldBcoef) & + .or. allocated(fieldDotBcoef)) + + end function check_infbg_spline + + + + + subroutine free_infbg_spline() + implicit none + if (check_infbg_spline()) then + deallocate(bfoldKnot) + deallocate(hubbleBcoef) + deallocate(epsilon1Bcoef) + deallocate(epsilon1JFBcoef) + deallocate(fieldBcoef) + deallocate(fieldDotBcoef) + if (display) write(*,*)'free_infbg_spline: infbg spline freed' + else + stop 'free_infbg_spline: not infbg spline data allocated' + endif + + end subroutine free_infbg_spline + + + + + + subroutine set_infbg_spline(bgEnd,ptrFirstBgdata) + !initialize the spline and set efoldIni, efoldEnd + use infbgmodel, only : fieldNum + use infbg, only : infbgdata, infbgphys + use infbg, only : count_infbg_data + use bspline + implicit none + type(infbgphys), intent(in) :: bgEnd + type(infbgdata), pointer :: ptrFirstBgdata + + integer :: bgdataNum + + integer :: i + type(infbgdata), pointer :: ptrRun + + !the background computation need to go further than epsilon1 > 1 (spline). + real(kp), allocatable, dimension(:) :: bcoefTemp, dataTemp + real(kp), allocatable, dimension(:) :: bfold, hubble, epsilon1,epsilon1JF + real(kp), allocatable, dimension(:,:) :: field, fieldDot + + i = 0 + ptrRun => null() + + if (check_infbg_spline()) then + stop 'set_infbg_spline: splineBg already associated' + endif + + + bgdataNum = count_infbg_data(ptrFirstBgdata) + if (display) then + write(*,*) + write(*,*)'-------------------set_infbg_spline-------------------' + write(*,*) + write(*,*)'bgdataNum = ',bgdataNum + endif + order = 3 + bcoefNum = bgdataNum + splineNum = fieldNum + + allocate(bfold(bgdataNum)) + allocate(hubble(bgdataNum)) + allocate(epsilon1(bgdataNum)) + allocate(epsilon1JF(bgdataNum)) + allocate(field(bgdataNum,fieldNum)) + allocate(fieldDot(bgdataNum,fieldNum)) + + allocate(bfoldKnot(bgdataNum + order)) + allocate(hubbleBcoef(bcoefNum)) + allocate(epsilon1Bcoef(bcoefNum)) + allocate(epsilon1JFBcoef(bcoefNum)) + allocate(fieldBcoef(bcoefNum,splineNum)) + allocate(fieldDotBcoef(bcoefNum,splineNum)) + + if (associated(ptrFirstBgdata)) then + ptrRun => ptrFirstBgdata + i = 0 + do while (associated(ptrRun)) + i = i + 1 + bfold(i) = ptrRun%bg%efold - bgEnd%efold + if (bfold(i).eq.0.) bfold(i) = epsilon(1.0_kp) + hubble(i) = ptrRun%bg%hubble + epsilon1(i) = ptrRun%bg%epsilon1 + epsilon1JF(i) = ptrRun%bg%epsilon1JF + field(i,:) = ptrRun%bg%field(:) + fieldDot(i,:) = ptrRun%bg%fieldDot(:) + ptrRun => ptrRun%ptr + enddo + + if (display) then + write(*,*) + write(*,*)'assoNum = ',i + write(*,*)'bgdataNum = ',bgdataNum + write(*,*)'splinning range:' + write(*,*)'bfoldIni = bfoldEndData = ',bfold(1),bfold(i) + write(*,*) + write(*,*)'------------------------------------------------------' + write(*,*) + endif + ptrRun => null() + else + stop 'no bgdata found' + endif + + call dbsnak(bgdataNum,bfold,order,bfoldKnot) + call dbsint(bgdataNum,bfold,hubble,order,bfoldKnot & + ,hubbleBcoef) + call dbsint(bgdataNum,bfold,epsilon1,order,bfoldKnot & + ,epsilon1Bcoef) + call dbsint(bgdataNum,bfold,epsilon1JF,order,bfoldKnot & + ,epsilon1JFBcoef) + + allocate(bcoefTemp(bgDataNum)) + allocate(dataTemp(bgDataNum)) + + do i=1,splineNum + dataTemp(:) = field(:,i) + call dbsint(bgdataNum,bfold,dataTemp,order,bfoldKnot,bcoefTemp) + fieldBcoef(:,i) = bcoefTemp + + dataTemp(:) = fieldDot(:,i) + call dbsint(bgdataNum,bfold,dataTemp,order,bfoldKnot,bcoefTemp) + fieldDotBcoef(:,i) = bcoefTemp + enddo + + deallocate(bcoefTemp) + deallocate(dataTemp) + + deallocate(bfold,hubble,epsilon1,epsilon1JF,field,fieldDot) + + end subroutine set_infbg_spline + + + + + + + + function splineval_hubble_parameter(bfold) + use bspline + implicit none + + real(kp) :: splineval_hubble_parameter + real(kp), intent(in) :: bfold + + splineval_hubble_parameter = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,hubbleBcoef) + + end function splineval_hubble_parameter + + + + function splineval_epsilon1(bfold) + use bspline + implicit none + + real(kp) :: splineval_epsilon1 + real(kp), intent(in) :: bfold + + splineval_epsilon1 = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,epsilon1Bcoef) + + end function splineval_epsilon1 + + + + function splineval_epsilon1JF(bfold) + use bspline + implicit none + + real(kp) :: splineval_epsilon1JF + real(kp), intent(in) :: bfold + + splineval_epsilon1JF = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,epsilon1JFBcoef) + + end function splineval_epsilon1JF + + + + + function splineval_field(bfold) + use bspline + implicit none + + real(kp), dimension(splineNum) :: splineval_field + real(kp), intent(in) :: bfold + real(kp), dimension(:), allocatable :: bcoefTemp + integer :: i,bgDataNum + bgDataNum = bcoefNum + + allocate(bcoefTemp(bgDataNum)) + + i = 0 + do i=1,splineNum + bcoefTemp(:) = fieldBcoef(:,i) + splineval_field(i) = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,bcoefTemp) + enddo + + deallocate(bcoefTemp) + + end function splineval_field + + + + + function splineval_fielddot(bfold) + !reminder: this is the efold(bfold) fieldDot = Dfield/De(b)fold + use bspline + implicit none + + real(kp), dimension(splineNum) :: splineval_fielddot + real(kp), intent(in) :: bfold + real(kp), dimension(:), allocatable :: bcoefTemp + integer :: i,bgDataNum + bgDataNum = bcoefNum + + allocate(bcoefTemp(bgDataNum)) + + i = 0 + do i=1,splineNum + bcoefTemp(:) = fieldDotBcoef(:,i) + splineval_fielddot(i) = dbsval(bfold,order,bfoldKnot & + ,bcoefNum,bcoefTemp) + enddo + + deallocate(bcoefTemp) + + end function splineval_fielddot + + + + end module infbgspline diff -r -c -b -N cosmomc/camb/infinout.f90 cosmomc_fields/camb/infinout.f90 *** cosmomc/camb/infinout.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infinout.f90 2008-11-24 20:20:23.000000000 +0100 *************** *** 0 **** --- 1,367 ---- + module infinout + + use infprec, only : kp + + private + + interface livewrite + module procedure sp_livewrite, kp_livewrite + end interface + + interface allwrite + module procedure sp_allwrite, kp_allwrite + end interface + + interface binallwrite + module procedure sp_binallwrite, kp_binallwrite + end interface + + integer, parameter :: reclUnit = 4 + + public delete_file + public livewrite, allwrite, binallwrite + + contains + + + subroutine delete_file(name) + implicit none + character(len=*) :: name + logical :: isthere + + inquire(file=name,exist=isthere) + + if (isthere) then + open(unit=10,file=name) + close(unit=10,status='delete') + endif + + end subroutine delete_file + + + subroutine sp_livewrite(name,x,a,b,c,d,e,f,g) + implicit none + character(len=*) :: name + real :: x,a + real, optional :: b,c,d,e,f,g + + open(10,file=name,position='append',status='unknown') + + if (.not.present(b)) then + write(10,100) x,a + elseif (.not.present(c)) then + write(10,100) x,a,b + elseif (.not.present(d)) then + write(10,100) x,a,b,c + elseif (.not.present(e)) then + write(10,100) x,a,b,c,d + elseif (.not.present(f)) then + write(10,100) x,a,b,c,d,e + elseif (.not.present(g)) then + write(10,100) x,a,b,c,d,e,f + else + write(10,100) x,a,b,c,d,e,f,g + endif + + close(10) + + 100 format(8(ES25.16E3)) + + end subroutine sp_livewrite + + + subroutine kp_livewrite(name,x,a,b,c,d,e,f,g) + implicit none + character(len=*) :: name + real(kp) :: x,a + real(kp), optional :: b,c,d,e,f,g + + open(10,file=name,position='append',status='unknown') + + if (.not.present(b)) then + write(10,100) x,a + elseif (.not.present(c)) then + write(10,100) x,a,b + elseif (.not.present(d)) then + write(10,100) x,a,b,c + elseif (.not.present(e)) then + write(10,100) x,a,b,c,d + elseif (.not.present(f)) then + write(10,100) x,a,b,c,d,e + elseif (.not.present(g)) then + write(10,100) x,a,b,c,d,e,f + else + write(10,100) x,a,b,c,d,e,f,g + endif + + close(10) + + 100 format(8(ES25.16E3)) + + end subroutine kp_livewrite + + + subroutine sp_allwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real :: x(:),a(:) + real, optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + npts=ubound(x,1) + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + open(10,file=name,status='unknown') + + if (.not.present(b)) then + do j=1,npts + write(10,100) x(j),a(j) + enddo + elseif (.not.present(c)) then + do j=1,npts + write(10,100) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + + 100 format(8(ES25.16E3)) + + end subroutine sp_allwrite + + + + subroutine kp_allwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real(kp) :: x(:),a(:) + real(kp), optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + npts=ubound(x,1) + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + open(10,file=name,status='unknown') + + if (.not.present(b)) then + do j=1,npts + write(10,100) x(j),a(j) + enddo + elseif (.not.present(c)) then + do j=1,npts + write(10,100) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + do j=1,npts + write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + + 100 format(8(ES25.16E3)) + + end subroutine kp_allwrite + + + + subroutine sp_binallwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real :: x(:),a(:) + real, optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + integer :: datarecl + integer :: recnum + + + recnum = 0 + npts=ubound(x,1) + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + + + if (.not.present(b)) then + datarecl=2*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j) + enddo + elseif (.not.present(c)) then + datarecl=3*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + datarecl=4*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + datarecl=5*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + datarecl=6*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + datarecl=7*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + datarecl=8*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + + end subroutine sp_binallwrite + + + + subroutine kp_binallwrite(name,x,a,b,c,d,e,f,g) + implicit none + character(*) :: name + integer :: j,npts + real(kp) :: x(:),a(:) + real(kp), optional :: b(:),c(:),d(:),e(:),f(:),g(:) + + integer :: recnum + integer :: datarecl + + npts=ubound(x,1) + recnum=0 + + if (ubound(a,1).ne.npts) then + write(*,*)'WARNING: vectors length differ' + endif + + write(*,*)'__write: save in ',name + + if (.not.present(b)) then + datarecl = 4*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum=recnum+1 + write(10,rec=recnum) x(j),a(j) + enddo + elseif (.not.present(c)) then + datarecl = 6*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum =recnum+1 + write(10,rec=recnum) x(j),a(j),b(j) + enddo + elseif (.not.present(d)) then + datarecl = 8*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum =recnum+1 + write(10,rec=recnum) x(j),a(j),b(j),c(j) + enddo + elseif (.not.present(e)) then + datarecl = 10*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j) + enddo + elseif (.not.present(f)) then + datarecl = 12*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j) + enddo + elseif (.not.present(g)) then + datarecl = 14*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j) + enddo + else + datarecl = 16*reclUnit + open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl) + do j=1,npts + recnum = recnum + 1 + write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j) + enddo + endif + + close(10) + + end subroutine kp_binallwrite + + + end module infinout + + diff -r -c -b -N cosmomc/camb/infpert.f90 cosmomc_fields/camb/infpert.f90 *** cosmomc/camb/infpert.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infpert.f90 2009-04-24 14:37:03.994897641 +0200 *************** *** 0 **** --- 1,1202 ---- + module infpert + !inflationary perturbations for scalar fields and tensor modes, in the + !original field basis (might have precision issues in the + !determination of ridiculously small entropy modes). efold is the + !number of efold running from efoldIni to efoldEnd during the + !inflationary era. bfold is the number of efold before the end of + !inflation: bfold = efold - efoldEnd running from efoldIni-efoldEnd to + !0. + + use infprec, only : kp, tolkp + use infbgmodel, only : matterNum, dilatonNum, fieldNum + use infbg, only : infbgphys + use inftorad, only : inftoradcosmo + implicit none + + private + + + !for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_spectra = .false. + logical, parameter :: dump_modes = .false. + + !+1 due to the bardeen potential. + integer, parameter :: scalNum = fieldNum + 1 + + real(kp), parameter :: kphysOverHubbleCreate = 10._kp + + integer, parameter :: entroRef = 2 + + + public scalNum + public power_spectrum_tens, power_spectrum_scal + + + contains + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !gravitational waves + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function power_spectrum_tens(infCosmo,kmpc) + use inftorad, only : infhubblexit, hubble_splinexit + use infinout, only : livewrite + implicit none + real(kp) :: power_spectrum_tens + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + + type(infhubblexit) :: atHkExit + complex(kp) :: tensEnd + real(kp) :: pi + + pi=acos(-1._kp) + + !evolution of k^3/2 x h by recomputing the background (faster) + tensEnd = pert_tens_bgevol(infCosmo,kmpc) + + power_spectrum_tens = (2._kp/pi/pi)*real(conjg(tensEnd)*tensEnd) + + if (dump_spectra) then + call livewrite('powerhK.dat',kmpc,power_spectrum_tens) + atHkExit = hubble_splinexit(infCosmo,kmpc) + call livewrite('powerhN.dat',atHkExit%bfold,power_spectrum_tens) + endif + + if (display) then + write(*,*)'power_spectrum_tens:' + write(*,*)'kmpc= Ph= '& + ,kmpc,power_spectrum_tens + endif + + + if (dump_modes) then + write(*,*)'tensor evolution dumped!' + read(*,*) + endif + + end function power_spectrum_tens + + + + + function pert_tens_bgevol(infCosmo,kmpc) + !this evolves the bg and tens = k^3/2 * h simultaneously + use inftools, only : easydverk + use infprec, only : transfert + use infbg, only : operator(/=) + use infbg, only : bg_field_dot_coupled + use infbg, only : hubble_parameter_square + use inftorad, only : bfold_hubble_fraction, ln_mpc_to_kappaeff + use infinout + + implicit none + + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + complex(kp) :: pert_tens_bgevol + + type(transfert) :: cosmoData + + !we do not want to recompute the background from billion efolds. It is + !enough to start just before the relevant modes today are created + + !workaround for old omp threadprivate directive (common for + !static + save) + real(kp) :: efoldTune + real(kp), dimension(fieldNum) :: fieldTune, velocityTune + type(infbgphys) :: bgPrevious + common /bgTensSave/ efoldTune, fieldTune, velocityTune, bgPrevious + save /bgTensSave/ + !$omp threadprivate(/bgTensSave/) + + real(kp) :: bfold, efold, efoldStart, bfoldStart, bfoldNext + + !output files steps + integer, parameter :: bfoldDataNum = 5000 + real(kp) :: bfoldStep + + !accuracy for the forward integration of background only and both + !background and perturbations (any backward (unstable) integration is + !avoided). Since sub-Hubble perturbations oscillate, funny low + !accuracy on pertevol lead to funny long integration time + real(kp), parameter :: tolBgEvol = tolkp + real(kp), parameter :: tolEvol = 1e-11 + + integer, parameter :: neqs = 4 + 2*fieldNum + integer, parameter :: neqsbg = 2*fieldNum + + complex(kp) :: tens,tensDot,tensStart,tensDotStart + real(kp), dimension(2*fieldNum) :: bgVar + !tens and bg together + real(kp), dimension(neqs) :: allVar + real(kp), dimension(fieldNum) :: field,velocity + real(kp) :: hubbleSquare,kphysOverHubbleStart + + + + + !for transferring kmpc + other cosmo to the differential equations + cosmoData%real1 = kmpc + cosmoData%real2 = infCosmo%bgEnd%efold + cosmoData%real3 = infCosmo%efoldEndToToday + + !find the bfold of creation + ! solution of N + ln[kappa H(N)] = ln(kmpc) -ln(aend/a0) -Nc -ln[(k/aH)_creation] + kphysOverHubbleStart = kphysOverHubbleCreate + bfoldStart = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleStart) + + if (display) then + write(*,*) + write(*,*)'tensor modes: kmpc = ',kmpc + write(*,*)'bfold quantum = ',bfoldStart + write(*,*) + endif + + + if (dump_modes) then + if (bfoldDataNum.le.1) stop 'pert_tens_bgevol: 1 data point?' + bfoldStep = (infCosmo%bfoldEnd - bfoldStart)/real(bfoldDataNum-1) + call delete_file('tens.dat') + else + !turbo settings, let's go to the end of inflation + bfoldStep = 1._kp/epsilon(1._kp) + endif + + + !evolve the bg from efoldIni to efoldStart of mode creation only + !once. After move from previous bgStart to the new efoldStart of mode + !creation, ONLY if the mode creation is at greater efold than the + !efoldStart of the previous mode: backward integration of the bg is + !unstable by rk methods. We also check that the bginf + !model is the same to do that. When all these conditions are not filled + !we start again from infCosmo + + !test if the bg model change print *,'testcond', + ! ((infCosmo%bgIni%efold.ne.bgPrevious%efold) & + ! .or.(any(infCosmo%bgIni%field.ne.bgPrevious%field)) & + ! .or.(any(infCosmo%bgIni%fieldDot.ne.bgPrevious%fieldDot))), + ! (infCosmo%bgIni /= bgPrevious) + + if (infCosmo%bgIni /= bgPrevious) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + endif + + bgPrevious = infCosmo%bgIni + + efoldStart = bfoldStart + infCosmo%bgEnd%efold + + !only forward integration allowed + if (efoldStart.lt.efoldTune) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + if (efoldStart.lt.infCosmo%bgIni%efold) then + write(*,*) 'pert_tens_bgevol: kmpc =',kmpc + write(*,*) 'bfoldCreate= bfoldExtrem= ',bfoldStart,infCosmo%bgIni%efold + stop + endif + endif + + + efold = efoldTune + + bgVar(1:fieldNum) = fieldTune(1:fieldNum) + bgVar(fieldNum+1:2*fieldNum) = velocityTune(1:fieldNum) + + call easydverk(neqsbg,bg_field_dot_coupled,efold,bgVar,efoldStart,tolBgEvol) + + efoldTune = efold + fieldTune(1:fieldNum) = bgVar(1:fieldNum) + velocityTune(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum) + + + !set the quantum initial conditions for the perturbations at bfoldStart + + call pert_creation_standard(tensStart,tensDotStart,bfoldStart,infCosmo,kmpc) + + + !evolve bg + tens pert from mode creation to end of inflation + + allVar(1) = real(tensStart) + allVar(2) = aimag(tensStart) + allVar(3) = real(tensDotStart) + allVar(4) = aimag(tensDotStart) + + allVar(5:4+fieldNum) = bgVar(1:fieldNum) + allVar(5+fieldNum:4+2*fieldNum) = bgVar(fieldNum+1:2*fieldNum) + + bfold = bfoldStart + + do while (bfold.lt.infCosmo%bfoldEnd) + + bfoldNext = min(bfold + bfoldStep, infCosmo%bfoldEnd) + + call easydverk(neqs,pert_tens_bgdot,bfold,allVar,bfoldNext,tolEvol,cosmoData) + + tens = cmplx(AllVar(1),AllVar(2)) + tensDot = cmplx(AllVar(3), AllVar(4)) + + !for test + if (dump_modes) then + field = allVar(5:4+fieldNum) + velocity = allVar(5+fieldNum:4+2*fieldNum) + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + call livewrite('kmpc.dat',bfold, & + kmpc*exp(-bfold)*exp(infCosmo%efoldEndToToday) & + *exp(-ln_mpc_to_kappaeff)) + call livewrite('tens.dat',bfold,abs(tens),abs(real(tens)),abs(aimag(tens))) + call livewrite('hubble.dat',bfold,sqrt(hubbleSquare)) + endif + + enddo + + pert_tens_bgevol = tens + + end function pert_tens_bgevol + + + + + subroutine pert_tens_bgdot(neqs,bfold,allVar,allVarDot,cosmoData) + use infprec, only : transfert + use infbg, only : bg_field_dot_coupled, slowroll_first_parameter & + , hubble_parameter_square + use inftorad, only : ln_mpc_to_kappaeff + implicit none + + integer, intent(in) :: neqs + real(kp), intent(in) :: bfold + type(transfert), optional, intent(inout) :: cosmoData + real(kp), dimension(neqs), intent(in) :: allVar + real(kp), dimension(neqs), intent(out) :: allVarDot + + real(kp), dimension(fieldNum) :: field, velocity + real(kp), dimension(2*fieldNum) :: bgVar, bgVarDot + real(kp), dimension(4) :: pertVar, pertVarDot + + real(kp) :: kmpc, efoldEnd, efoldEndToToday + real(kp) :: efold, epsilon1, hubble, kphysOverHubble + + kmpc = cosmoData%real1 + efoldEnd = cosmoData%real2 + efoldEndToToday = cosmoData%real3 + + !equation of motion for the background + bgVar(1:2*fieldNum) = allVar(5:4+2*fieldNum) + + efold = bfold + efoldEnd + call bg_field_dot_coupled(2*fieldNum,efold,bgVar,bgVarDot) + + !need the background for the equations of the perturbations + field = bgVar(1:fieldNum) + velocity = bgVar(fieldNum+1:2*fieldNum) + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + hubble = sqrt(hubble_parameter_square(field,velocity,.true.)) + + kphysOverHubble = (kmpc/hubble)* exp(-bfold + efoldEndToToday & + - ln_mpc_to_kappaeff) + ! print *,'kphysOverHubble',kphysOverHubble + ! read(*,*) + !equations of motion for the tensor modes + pertVar(1:4) = allVar(1:4) + + pertVarDot(1:2) = pertVar(3:4) + pertVarDot(3:4) = - (kphysOverHubble**2) * pertVar(1:2) & + - (3d0 - epsilon1)*pertVar(3:4) + + !set the return value + allVarDot(1:4) = pertVarDot(1:4) + allVarDot(5:4+2*fieldNum) = bgVarDot(1:2*fieldNum) + + end subroutine pert_tens_bgdot + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !scalar modes + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function power_spectrum_scal(infCosmo,kmpc) + !computes 1/(2pi^2) * , , , , etc... + !the evolved variables already include the k^3/2 factor. + use inftorad, only : infhubblexit, hubble_splinexit + use infinout, only : livewrite + + implicit none + real(kp), dimension(scalNum,scalNum) :: power_spectrum_scal + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + + type(infhubblexit) :: atHkExit + integer :: vacuumNum + complex(kp) :: powerFrom + + real(kp) :: pi + complex(kp), dimension(scalNum,fieldNum) :: obsPertFrom + + integer :: i,j,k,whichInVac + + + obsPertFrom = 0._kp + + ! vacuumNum = fieldNum + + !when the dilaton is not coupled + vacuumNum = matterNum + + pi=acos(-1._kp) + + do whichInVac=1,vacuumNum + obsPertFrom(:,whichInVac) = pert_scal_bgevol(infCosmo,kmpc,whichInVac) + enddo + + !the two-points correlation functions + !mind the modulus --> cross correlations are complex in Fourier Space. + + do j=1,scalNum + do i=1,scalNum + powerFrom = 0._kp + do k=1,vacuumNum + powerFrom = powerFrom + conjg(obsPertFrom(i,k))*obsPertFrom(j,k) + enddo + power_spectrum_scal(i,j) = (0.5_kp/pi/pi)*real(powerFrom) + enddo + enddo + + if (dump_spectra) then + call livewrite('powerzetaK.dat',kmpc & + ,power_spectrum_scal(scalNum,scalNum)) + atHkExit = hubble_splinexit(infCosmo,kmpc) + call livewrite('powerzetaN.dat',atHkExit%bfold & + ,power_spectrum_scal(scalNum,scalNum)) + endif + + if (display) then + write(*,*)'power_spectrum_scal:' + write(*,*)'kmpc= Ps= '& + ,kmpc,power_spectrum_scal(scalNum,scalNum) + endif + + if (dump_modes) then + write(*,*)'scalar evolution dumped!' + read(*,*) + endif + + + end function power_spectrum_scal + + + + + + function pert_scal_bgevol(infCosmo,kmpc,whichInVacuum) + !this evolves the bg and scalar = k^3/2 *(fieldPert,Psi) simultaneously and + !return the final values of . zeta comoving + !curvature perturbation, Psi Bardeen potential, Q Mukhanov variable. + + use inftools, only : easydverk + use infprec, only : transfert + use infbgmodel, only : metric,deriv_metric,conformal_factor_square + use infbgmodel, only : conformal_first_gradient + use infbg, only : operator(/=) + use infbg, only : bg_field_dot_coupled + use infbg, only : slowroll_first_parameter, slowroll_second_parameter + use infbg, only : hubble_parameter_square + use infbg, only : potential, deriv_potential + use inftorad, only : bfold_hubble_fraction + use infinout + + implicit none + + complex(kp), dimension(scalNum) :: pert_scal_bgevol + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: kmpc + integer, intent(in) :: whichInVacuum + + type(transfert) :: cosmoData + + !not intialized + real(kp) :: efoldTune, hubbleTune, hubble + real(kp), dimension(fieldNum) :: fieldTune, velocityTune + type(infbgphys) :: bgPrevious + common /bgScalSave/ efoldTune, fieldTune, velocityTune, bgPrevious + save /bgScalSave/ + !$omp threadprivate(/bgScalSave/) + + real(kp) :: bfold, efold, efoldStart, bfoldStart, bfoldNext + + !output files number of steps + integer, parameter :: bfoldDataNum = 5000 + real(kp) :: bfoldStep + + !field, fieldDot real; pert, pertDot complex. + + !accuracy for the forward integration of background only and both + !background and perturbations (any backward (unstable) integration is + !avoided). Since sub-Hubble perturbations oscillate, funny low + !accuracy on pertevol lead to funny long integration time + real(kp), parameter :: tolBgEvol = tolkp + real(kp), parameter :: tolEvol = 1e-11 + + integer, parameter :: neqs = 4*scalNum + 2*fieldNum + integer, parameter :: neqsbg = 2*fieldNum + + complex(kp) :: pertStart, pertDotStart + complex(kp), dimension(2) :: bardeensStart + complex(kp), dimension(scalNum) :: scalStart, scalDotStart + complex(kp), dimension(scalNum) :: scal,scalDot + + real(kp) :: epsilon1 + real(kp) :: kphysOverHubbleStart, kinetic, kineticDot + + !observable quantites, total and partial comoving curvature perturbations + complex(kp) :: zeta, zetaJF + complex(kp), dimension(fieldNum) :: mukhaScal,zetaScal !,entro + complex(kp), dimension(matterNum) :: zetaMatterDensJF + + real(kp) :: sigmaDot + real(kp), dimension(fieldNum) :: unitDot + real(kp), dimension(fieldNum) :: field,velocity,fieldDot + real(kp), dimension(2*fieldNum) :: bgVar + real(kp), dimension(fieldNum,fieldNum) :: metricVal + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv + !field and scal together + real(kp), dimension(neqs) :: allVar + + integer :: i + character(len=15) :: strgWhich, strgCount + + + !bugbuster + complex(kp), dimension(2) :: bardeenTest + logical, parameter :: doJordanFrame = .false. + + if ((whichInVacuum.gt.fieldNum).or.(whichInVacuum.le.0)) then + stop 'pert_scalar_bgevol: no such scalar perturbations' + endif + + + !to pass kmpc to differential equations throught dverk + cosmoData%real1 = kmpc + cosmoData%real2 = infCosmo%bgEnd%efold + cosmoData%real3 = infCosmo%efoldEndToToday + + !find the bfold of creation + ! solution of N + ln[kappa H(N)] = ln(kmpc) -ln(aend/a0) -Nc -ln[(k/aH)_creation] + kphysOverHubbleStart = kphysOverHubbleCreate + bfoldStart = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleStart) + + if (display) then + write(*,*) + write(*,*)'scalar modes: kmpc = ',kmpc + write(*,*)'bfold quantum = ',bfoldStart + write(*,*)'mode in vacuum: ',whichInVacuum + write(*,*) + endif + + if (dump_modes) then + if (bfoldDataNum.le.1) stop 'pert_scal_bgevol: 1 data point?' + bfoldStep = (infCosmo%bfoldEnd - bfoldStart)/real(bfoldDataNum-1) + write(strgWhich,*) whichInVacuum + call delete_file('zeta2_'//trim(adjustl(strgWhich))//'.dat') + call delete_file('psi_'//trim(adjustl(strgWhich))//'.dat') + call delete_file('zeta2JF_'//trim(adjustl(strgWhich))//'.dat') + do i=1,fieldNum + write(strgCount,*) i + call delete_file('scal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat') + ! call delete_file('entro_'//trim(adjustl(strgCount))// & + ! '_'//trim(adjustl(strgWhich))//'.dat') + call delete_file('zetascal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat') + enddo + else + !turbo settings, let's go to the end of inflation + bfoldStep = 1._kp/epsilon(1._kp) + endif + + + !test if the bg model change + if (infCosmo%bgIni /= bgPrevious) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + endif + + bgPrevious = infCosmo%bgIni + + efoldStart = bfoldStart + infCosmo%bgEnd%efold + + !only forward integration allowed + if (efoldStart.lt.efoldTune) then + efoldTune = infCosmo%bgIni%efold + fieldTune = infCosmo%bgIni%field + velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble + if (efoldStart.lt.infCosmo%bgIni%efold) then + write(*,*) 'pert_scalar_bgevol: kmpc =',kmpc + write(*,*) 'bfoldCreate= bfoldExtrem= ',bfoldStart,infCosmo%bgIni%efold + stop + endif + endif + + + !evolve the bg from 0 to bfold of mode creation + efold = efoldTune + bgVar(1:fieldNum) = fieldTune(1:fieldNum) + bgVar(fieldNum+1:2*fieldNum) = velocityTune(1:fieldNum) + + call easydverk(neqsbg,bg_field_dot_coupled,efold,bgVar,efoldStart,tolBgEvol) + + !update varTune to the bfold of mode creation (the bg will be computed + !from here next time) + efoldTune = efold + fieldTune(1:fieldNum) = bgVar(1:fieldNum) + velocityTune(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum) + hubbleTune = sqrt(hubble_parameter_square(fieldTune,velocityTune,.true.)) + + !the field initial quantum states have to be normalised with respect + !to their kinetic term (done by calling pert_creation_kinetic) + metricVal = metric(fieldTune) + metricDeriv = deriv_metric(fieldTune) + + kinetic = metricVal(whichInVacuum,whichInVacuum) + kineticDot = dot_product(metricDeriv(whichInVacuum,whichInVacuum,:) & + ,velocityTune/hubbleTune) + + ! print *,'kinteic',kinetic,kineticDot + + call pert_creation_kinetic(pertStart,pertDotStart & + ,bfoldStart,kinetic,kineticDot,infCosmo,kmpc) + ! print *,'kinetic' + ! print *,'pertStart',pertStart + ! print *,'pertDotStart',pertDotStart + + ! call pert_creation_standard(pertStart,pertDotStart,bfoldStart,infCosmo,kmpc) + ! print *,'standard' + ! print *,'pertStart',pertStart + ! print *,'pertDotStart',pertDotStart + + !reset everyone + scalStart = 0._kp + scalDotStart = 0._kp + + !there is a sqrt(2) factor between scalar and tensor modes. + scalStart(whichInVacuum) = pertStart /sqrt(2._kp) + scalDotStart(whichInVacuum) = pertDotStart /sqrt(2._kp) + + + !The initial value of the Bardeen potential is fixed by the constraint + !equuations, i.e. momemtum and energy conservation. It is a bad idea + !to use these equations during the evolution since they are singular + !at Hubble exit and epsilon=1, but are fine initially, for quantum + !wavelength well below the Hubble radius + bardeensStart = bardeen_bardeen_dot(bfoldStart,fieldTune,velocityTune & + ,scalStart(1:fieldNum),scalDotStart(1:fieldNum),cosmoData) + + scalStart(scalNum) = bardeensStart(1) + scalDotStart(scalNum) = bardeensStart(2) + + + !evolve bg + tens pert from mode creation to end of inflation + !pert variables and their derivatives + do i=1,scalNum + allVar(2*i-1) = real(scalStart(i)) + allVar(2*i) = aimag(scalStart(i)) + allVar(2*scalNum + 2*i-1) = real(scalDotStart(i)) + allVar(2*scalNum + 2*i) = aimag(scalDotStart(i)) + enddo + + !bg field and velocity + allVar(4*scalNum+1:4*scalNum+2*fieldNum) = bgVar(1:2*fieldNum) + + bfold = bfoldStart + + do while (bfold.lt.infCosmo%bfoldEnd) + + bfoldNext = min(bfold + bfoldStep, infCosmo%bfoldEnd) + + ! print * + ! print *,'allVar',allVar + ! print * + + call easydverk(neqs,pert_scalar_bgdot,bfold,allVar,bfoldNext,tolEvol,cosmoData) + + field = allVar(4*scalNum+1:4*scalNum+fieldNum) + metricVal = metric(field) + velocity = allVar(4*scalNum+fieldNum+1:4*scalNum+2*fieldNum) + hubble = sqrt(hubble_parameter_square(field,velocity,.true.)) + fieldDot = velocity/hubble + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + sigmaDot = sqrt(2._kp*epsilon1) + + do i=1,scalNum + scal(i) = cmplx(allVar(2*i-1),allVar(2*i)) + scalDot(i) = cmplx(allVar(2*scalNum+2*i-1),allVar(2*scalNum+2*i)) + enddo + + unitDot = fieldDot/sigmaDot + + !curvature perturbation for each field: Psi + + !deltaField/(Dfield/Dbfold) + do i=1,fieldNum + mukhaScal(i) = scal(i) + fieldDot(i)*scal(scalNum) + if (fieldDot(i).ne.0._kp) then + zetaScal(i) = scal(scalNum) + scal(i)/fieldDot(i) + else + zetaScal(i) = 0._kp + endif + ! entro(i) = scal(i) - unitDot(i) & + ! * dot_product(matmul(metricVal,unitDot),scal(1:fieldNum)) + enddo + + + + !zeta constant density hypersurface in Jordan Frame for matter fields + if (doJordanFrame) then + zetaMatterDensJF(1:matterNum) & + = curvature_matter_density_JF(field,velocity,scal,scalDot) + zetaJF = curvature_comoving_JF(field,velocity,scal,scalDot) + else + !comoving curvature perturbation: Psi + deltaSigma/(DSigma/Dbfold) + zeta = scal(scalNum) & + + (dot_product(matmul(metricVal,fieldDot),scal(1:fieldNum))) & + /(2._kp*epsilon1) + endif + + !for test (fully inefficient way of writing files) + if (dump_modes) then + + + bardeenTest = bardeen_bardeen_dot(bfold,field,velocity & + ,scal(1:fieldNum),scalDot(1:fieldNum),cosmoData) + + ! print *,'Psi',bardeenTest(1)-scal(scalNum) + ! print *,'Psidot',bardeenTest(2)-scalDot(scalNum) + ! print *,'zeta',zeta-(bardeenTest(1)+ (bardeenTest(2) + bardeenTest(1))/epsilon1) + ! print *,'ZetaScal' + ! print *,'zeta -each',zeta & + ! - (dot_product(matmul(metricVal,velocity/hubble) & + ! ,velocity/hubble*zetaScal)/(2.*epsilon1)) + ! read(*,*) + + call livewrite('zeta2_'//trim(adjustl(strgWhich))//'.dat' & + , bfold, abs(conjg(zeta)*zeta),abs(real(zeta)),abs(aimag(zeta))) + + call livewrite('zeta2JF_'//trim(adjustl(strgWhich))//'.dat' & + ,bfold,real(conjg(zetaJF)*zetaJF),abs(real(zetaJF)) & + ,abs(aimag(zetaJF))) + + do i=1,fieldNum + write(strgCount,*) i + call livewrite('scal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat' & + , bfold, abs(scal(i)),abs(real(scal(i))), abs(aimag(scal(i)))) + call livewrite('zetascal_'//trim(adjustl(strgCount))// & + '_'//trim(adjustl(strgWhich))//'.dat' & + ,bfold,abs(zetaScal(i)),abs(real(zetaScal(i)))& + ,abs(aimag(zetaScal(i)))) + enddo + + call livewrite('psi_'//trim(adjustl(strgWhich))//'.dat' & + , bfold, abs(scal(scalNum)),abs(real(scal(scalNum))) & + ,abs(aimag(scal(scalNum)))) + + endif + enddo + + + !zeta is returned instead from the mukhanov variable Q + !zeta = Q/sigmaDot = Q/(sqrt(2epsilon1)) + !rescaled entropic perturbations are returned: S1(2) = entro1(2)/sigmaDot + + ! pert_scal_bgevol(1:fieldNum) = entro(1:fieldNum)/sigmaDot + ! pert_scal_bgevol(scalNum) = zeta + + + if (doJordanFrame) then + pert_scal_bgevol(1:matterNum) = zetaMatterDensJF + pert_scal_bgevol(matterNum+1:fieldNum) = scal(matterNum+1:fieldNum) + pert_scal_bgevol(scalNum) = zetaJF + else + do i=1,fieldNum + pert_scal_bgevol(i) = zetaScal(i)-zetaScal(entroRef) + enddo + pert_scal_bgevol(scalNum) = zeta + endif + + end function pert_scal_bgevol + + + + + + + + subroutine pert_scalar_bgdot(neqs,bfold,allVar,allVarDot,cosmoData) + use infprec, only : transfert + use infbgmodel, only : metric, metric_inverse, deriv_metric + use infbg, only : potential, deriv_potential, deriv_second_potential + use infbg, only : bg_field_dot_coupled, slowroll_first_parameter + use infbg, only : hubble_parameter_square + use infbg, only : connection_affine, deriv_connection_affine + use inftorad, only : ln_mpc_to_kappaeff + + implicit none + + integer, intent(in) :: neqs + real(kp), intent(in) :: bfold + type(transfert), optional, intent(inout) :: cosmoData + real(kp), dimension(neqs), intent(in) :: allVar + real(kp), dimension(neqs), intent(out) :: allVarDot + + real(kp), dimension(fieldNum) :: field, velocity, fieldDot + + real(kp), dimension(2*fieldNum) :: bgVar, bgVarDot + + real(kp) :: kmpc, efoldEnd, efoldEndToToday + real(kp) :: efold, kphysOverHubble, pot + real(kp) :: hubbleSquare, hubble, epsilon1 + + + !temp variable for writing the equations of motion... + complex(kp) :: bardeenPsi, bardeenPsiDot, bardeenPsiDotDot + complex(kp), dimension(fieldNum) :: fieldPert,fieldPertDot,fieldPertDotDot + + !the coefficients entering in the equations of motion + + + !the physical quantities entering in the above coefficients + real(kp), dimension(fieldNum) :: potDeriv, potDerivVec + real(kp), dimension(fieldNum,fieldNum) :: metricVal, metricInv, potSecond + real(kp), dimension(fieldNum,fieldNum) :: connectXfieldDot, potSecondVec + real(kp), dimension(fieldNum,fieldNum) :: connectDerivXfieldDotSquare + real(kp), dimension(fieldNum,fieldNum) :: metricPotDerivs, Vff + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv,connect + real(kp), dimension(fieldNum,fieldNum,fieldNum,fieldNum) :: connectDeriv + + integer :: i,j + + + + !get the wave number from dverk + kmpc = cosmoData%real1 + efoldEnd = cosmoData%real2 + efoldEndToToday = cosmoData%real3 + + !equation of motion for the background (we use the physical velocity) + bgVar(1:2*fieldNum) = allVar(4*scalNum+1:4*scalNum+2*fieldNum) + + efold = bfold + efoldEnd + call bg_field_dot_coupled(2*fieldNum,efold,bgVar,bgVarDot) + + + !need some background quantities for the perturbations + field = bgVar(1:fieldNum) + velocity = bgVar(fieldNum+1:2*fieldNum) + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + hubble = sqrt(hubbleSquare) + fieldDot = velocity/hubble + + !remind this is also: -(DHubble/Dbfold)/Hubble and sigmaDot^2/2 + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + + kphysOverHubble = (kmpc/hubble) * exp(-bfold + efoldEndToToday & + - ln_mpc_to_kappaeff) + + + !the scalar perturbations (real and imaginary parts) + ! fieldPert(1:fieldNum) = allVar(1:2*fieldNum) + ! bardeenPsi = allVar(2*fieldNum+1:2*scalNum) + + !their derivatives + ! fieldPertDot(1:fieldNum) = allVar(2*scalNum+1:2*scalNum+2*fieldNum) + ! bardeenPsiDot = allVar(2*scalNum+2*fieldNum+1:4*scalNum) + + do i=1,fieldNum + fieldPert(i) = cmplx(allVar(2*i-1),allVar(2*i)) + fieldPertDot(i) = cmplx(allVar(2*scalNum+2*i-1),allVar(2*scalNum+2*i)) + enddo + bardeenPsi = cmplx(allVar(2*fieldNum+1),allVar(2*scalNum)) + bardeenPsiDot = cmplx(allVar(2*scalNum+2*fieldNum+1),allVar(4*scalNum)) + + + + !their equations of motion + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! warm up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + metricVal = metric(field) + metricInv = metric_inverse(field) + metricDeriv = deriv_metric(field) + + connect = connection_affine(field) + connectDeriv = deriv_connection_affine(field) + + !all potential related functions are in unit of H^2 + pot = potential(field)/hubbleSquare + potDeriv = deriv_potential(field)/hubbleSquare + potSecond = deriv_second_potential(field)/hubbleSquare + + potDerivVec = matmul(metricInv,potDeriv) + potSecondVec = matmul(metricInv,potSecond) + + do i=1,fieldNum + connectXfieldDot(i,:) = matmul(connect(i,:,:),fieldDot) + do j=1,fieldNum + connectDerivXfieldDotSquare(i,j) & + = dot_product(matmul(connectDeriv(i,:,:,j),fieldDot),fieldDot) + metricPotDerivs(i,j) & + = dot_product(matmul(metricDeriv(:,:,j),potDerivVec),metricInv(i,:)) + Vff(i,j) = connectDerivXfieldDotSquare(i,j) + potSecondVec(i,j) & + - metricPotDerivs(i,j) + enddo + enddo + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! equations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + fieldPertDotDot = - (3._kp - epsilon1) * fieldPertDot & + - 2._kp * matmul(connectXfieldDot,fieldPertDot) - matmul(Vff,fieldPert) & + - kphysOverHubble**2 * fieldPert & + + 4._kp * fieldDot * bardeenPsiDot - 2._kp * potDerivVec * bardeenPsi + + bardeenPsiDotDot = - (7._kp - epsilon1) * bardeenPsiDot & + - (2._kp * pot + kphysOverHubble**2) * bardeenPsi & + - dot_product(potDeriv,fieldPert) + + ! + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end equations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !specify the return value: glue all things together for integration. + + ! allVarDot(1:2*fieldNum) = fieldPertDot(1:fieldNum) + ! allVarDot(2*fieldNum+1:2*scalNum) = bardeenPsiDot + ! allVarDot(2*scalNum+1:2*scalNum+2*fieldNum) = fieldpertDotDot(1:fieldNum) + ! allVarDot(2*scalNum+2*fieldNum+1:4*scalNum) = bardeenPsiDotDot + + do i=1,fieldNum + allVarDot(2*i-1)=real(fieldPertDot(i)) + allVarDot(2*i) = aimag(fieldPertDot(i)) + allVarDot(2*scalNum+2*i-1) = real(fieldPertDotDot(i)) + allVarDot(2*scalNum+2*i) = aimag(fieldPertDotDot(i)) + enddo + + allVarDot(2*fieldNum+1) = real(bardeenPsiDot) + allVarDot(2*scalNum) = aimag(bardeenPsiDot) + allVarDot(2*scalNum+2*fieldNum+1) = real(bardeenPsiDotDot) + allVarDot(4*scalNum) = aimag(bardeenPsiDotDot) + + allVarDot(4*scalNum+1:4*scalNum+2*fieldNum) = bgVarDot(1:2*fieldNum) + + end subroutine pert_scalar_bgdot + + + + + + function bardeen_bardeen_dot(bfold,field,velocity,fieldPert,fieldPertDot,cosmoData) + !return the Bardeen potential and its derivative wrt efold from the + !constraint equations + use infprec, only : transfert + use infbgmodel, only : metric, deriv_metric + use infbg, only : deriv_potential, hubble_parameter_square + use infbg, only : slowroll_first_parameter + use inftorad, only : ln_mpc_to_kappaeff + + implicit none + complex(kp), dimension(2) :: bardeen_bardeen_dot + real(kp), intent(in) :: bfold + real(kp), dimension(fieldNum), intent(in) :: field, velocity + complex(kp), dimension(fieldNum), intent(in) :: fieldPert,fieldPertDot + type(transfert), intent(in) :: cosmoData + + + real(kp) :: epsilon1, hubbleSquare, hubble + real(kp) :: kmpc, efoldEndToToday, kphysOverHubble + + + real(kp), dimension(fieldNum) :: potDeriv,metricDerivXFieldDotSquare, fieldDot + real(kp), dimension(fieldNum) :: metricXFieldDot + real(kp), dimension(fieldNum,fieldNum) :: metricVal + real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv + + integer :: i + + + kmpc = cosmoData%real1 + efoldEndToToday = cosmoData%real3 + + epsilon1 = slowroll_first_parameter(field,velocity,.true.) + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + hubble = sqrt(hubbleSquare) + + fieldDot = velocity/hubble + + metricVal = metric(field) + metricDeriv = deriv_metric(field) + potDeriv = deriv_potential(field)/hubbleSquare + + kphysOverHubble = (kmpc/hubble) * exp(-bfold + efoldEndToToday & + - ln_mpc_to_kappaeff) + + metricXFieldDot = matmul(metricVal,fieldDot) + + do i=1,fieldNum + metricDerivXFieldDotSquare(i) = dot_product(matmul(metricDeriv(:,:,i),fieldDot) & + ,fieldDot) + enddo + + !bardeen potential + bardeen_bardeen_dot(1) & + = (1.5_kp * dot_product(metricXFieldDot,fieldPert) & + + 0.25_kp * dot_product(metricDerivXFieldDotSquare,fieldPert) & + + 0.5_kp * dot_product(potDeriv,fieldPert) & + + 0.5_kp * dot_product(metricXFieldDot,fieldPertDot)) & + / (epsilon1 - kphysOverHubble**2) + + !bardeen potential derivative wrt bfold time + bardeen_bardeen_dot(2) = 0.5_kp * dot_product(metricXFieldDot,fieldPert) & + - bardeen_bardeen_dot(1) + + + end function bardeen_bardeen_dot + + + + + function curvature_matter_density_JF(field,velocity,scal,scalDot) + !this is the curvature on constant density hypersurface for the matter + !fields zetamat = Psi + (delta Rho) / (DRho/Defold), if one matter + !field only. zetamat_i = Psi + (delta Rho_i) / (DField_i/Defold)^2 + !otherwise. In case of multiple matter fields, rho_i is not well + !defined due to possible couplings through the matter potential. + + use infbgmodel, only : conformal_factor_square, conformal_first_gradient + use infbgmodel, only : deriv_matter_potential + use infbg, only : hubble_parameter_square + implicit none + + complex(kp), dimension(matterNum) :: curvature_matter_density_JF + real(kp), dimension(fieldNum), intent(in) :: field, velocity + complex(kp), dimension(scalNum), intent(in) :: scal, scalDot + + + complex(kp), dimension(matterNum) :: matterPert, matterPertDot + complex(kp), dimension(dilatonNum) :: dilatonPert, dilatonPertDot + complex(kp) :: bardeenPsi, bardeenPhi + + real(kp) :: hubbleSquare, confSquare + real(kp), dimension(matterNum) :: matter, matterDot,derivMatterPot + real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad + real(kp), dimension(fieldNum) :: fieldDot + + bardeenPsi = scal(scalNum) + bardeenPhi = bardeenPsi + + matterPert = scal(1:matterNum) + matterPertDot = scalDot(1:matterNum) + dilatonPert = scal(matterNum+1:fieldNum) + dilatonPertDot = scalDot(matterNum+1:fieldNum) + + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + fieldDot = velocity/sqrt(hubbleSquare) + matterDot(1:matterNum) = fieldDot(1:matterNum) + + matter = field(1:matterNum) + dilaton = field(matterNum+1:fieldNum) + derivMatterPot = deriv_matter_potential(matter) + confSquare = conformal_factor_square(dilaton) + confFirstGrad = conformal_first_gradient(dilaton) + + + curvature_matter_density_JF = bardeenPsi + bardeenPhi/3._kp & + - (2._kp/3._kp) * dot_product(confFirstGrad,dilatonPert) & + - (1._kp/3._kp) * (matterPertDot/matterDot & + + confSquare * derivMatterPot / hubbleSquare / matterDot**2._kp & + * matterPert) + + end function curvature_matter_density_JF + + + + + function curvature_comoving_JF(field,velocity,scal,scalDot) + !this is the comoiving curvature perturbation in the Jordan Frame, + !i.e. zeta = PsiJF + (PsiJF' + HubbleConfJF x PhiJF)/(HubbleConfJF x + !epsilon1JF) + + use infbgmodel, only : conformal_first_gradient, conformal_second_gradient + use infbg, only : slowroll_first_parameter_JF, hubble_parameter_square + implicit none + + complex(kp) :: curvature_comoving_JF + real(kp), dimension(fieldNum), intent(in) :: field, velocity + complex(kp), dimension(scalNum), intent(in) :: scal, scalDot + + + complex(kp), dimension(dilatonNum) :: dilatonPert, dilatonPertDot + complex(kp) :: bardeenPsi, bardeenPsiDot, bardeenPhi + complex(kp) :: bardeenPsiJF, bardeenPsiJFDot, bardeenPhiJF + + real(kp) :: hubbleSquare, epsilon1JF + real(kp), dimension(fieldNum) :: fieldDot + real(kp), dimension(dilatonNum) :: dilaton, dilatonDot,confFirstGrad + real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad + + + hubbleSquare = hubble_parameter_square(field,velocity,.true.) + epsilon1JF = slowroll_first_parameter_JF(field,velocity,.true.) + + fieldDot = velocity/sqrt(hubbleSquare) + + dilaton = field(matterNum+1:fieldNum) + dilatonDot = fieldDot(matterNum+1:fieldNum) + + bardeenPsi = scal(scalNum) + bardeenPhi = bardeenPsi + bardeenPsiDot = scalDot(scalNum) + + dilatonPert = scal(matterNum+1:fieldNum) + dilatonPertDot = scalDot(matterNum+1:fieldNum) + + + confFirstGrad = conformal_first_gradient(dilaton) + confSecondGrad = conformal_second_gradient(dilaton) + + bardeenPsiJF = bardeenPsi - dot_product(confFirstGrad,dilatonPert) + bardeenPhiJF = bardeenPhi + dot_product(confFirstGrad,dilatonPert) + + bardeenPsiJFDot = bardeenPsiDot - dot_product(confFirstGrad,dilatonPertDot) & + - dot_product(matmul(confSecondGrad,dilatonDot),dilatonPert) + + curvature_comoving_JF = bardeenPsiJF + (bardeenPsiJFDot & + + (1._kp + dot_product(confFirstGrad,dilatonDot))*bardeenPhiJF) & + / ((1._kp + dot_product(confFirstGrad,dilatonDot))*epsilon1JF) + + end function curvature_comoving_JF + + + + + subroutine pert_creation_standard(pertIni,pertDotIni,bfoldCreate,infCosmo,kmpc) + !For standard constant kinetic terms. + !mode creation at different times corresponding to a fix physical + !scale with respect to the Hubble radius: k/aH = Cte + !kmpc is the wavenumber today in unit of Mpc^-1. H is the Hubble + !parameter during inflation in unit of kappa. Evolution of the perturbations + !involve the dimensionless quantity: k/(aH) + ! k/aH = (k/a0)/(kappa H) x aend/a x a0/aend x kappa + ! = kmpc/kappaH x exp[-N] x a0/aend x (kappa/1Mpc) + ! = kmpc/kappaH x exp[-N] x exp[ln(a0/aend)] x exp[-Nc] + ! where Nc = ln[1Mpc/sqrt(8pi)/lPl] <---- Nc=ln_mpc_to_kappaeff() + ! N number of efold before the end of inflation (efold-efoldEnd) + + use inftorad, only : scaleFactorToday, ln_mpc_to_kappaeff + implicit none + + real(kp), intent(in) :: kmpc + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: bfoldCreate + complex(kp), intent(out) :: pertIni, pertDotIni + + complex(kp) :: qMode, qModePrimeOverk + + + !set the quantum initial conditions at found bfold, in bfold time + !ex: for grav wav + ! h = qmode/a + ! h = a0/aend x aend/acreate x qmode/a0 + ! Dh/Dbfold = a H h' = a H (qmode/a)' = (k/aH) x a0/aend x aend/acreate + ! x (qmode'/k)/a0 - h + + call quantum_creation(kmpc,qmode,qmodePrimeOverk) + + pertIni = qmode/scaleFactorToday + pertDotIni = (kphysOverHubbleCreate*qmodePrimeOverk - qmode)/scaleFactorToday + + !normalisation of k in Mpc^-1 today + pertIni = pertIni*exp(infCosmo%efoldEndToToday - bfoldCreate - ln_mpc_to_kappaeff) + pertDotIni = pertDotIni*exp(infCosmo%efoldEndToToday - bfoldCreate - ln_mpc_to_kappaeff) + + end subroutine pert_creation_standard + + + + + subroutine pert_creation_kinetic(pertIni,pertDotIni,bfoldCreate,kinetic,kineticDot & + ,infCosmo,kmpc) + !for non-standard kinetic terms K(eta) Dfield Dfield instead of Dfield Dfield + use inftorad, only : scaleFactorToday, ln_mpc_to_kappaeff + implicit none + + real(kp), intent(in) :: kmpc + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), intent(in) :: bfoldCreate, kinetic, kineticDot + complex(kp), intent(out) :: pertIni, pertDotIni + + real(kp) :: sqrtKinetic, lnDotSqrtKinetic + complex(kp) :: qMode, qModePrimeOverk + + !set the quantum initial conditions at found bfold, in bfold time + !ex: for grav wav, qmod designs the standard normalised quantum mode + ! h = qmode/a/K^1/2 + ! h = a0/aend x aend/acreate x qmode/a0/K^1/2 + ! Dh/Dbfold = a H h' = a H (qmode/a/K^1/2)' + ! =(k/aH) x a0/aend x aend/acreate x (qmode'/k)/a0/K^1/2 - h x (1+1/2 DLn(K)/Dbfold) + + call quantum_creation(kmpc,qmode,qmodePrimeOverk) + + sqrtKinetic = sqrt(kinetic) + lnDotSqrtKinetic = 0.5_kp * kineticDot/kinetic + + pertIni = qmode /scaleFactorToday /sqrtKinetic + pertDotIni = (kphysOverHubbleCreate*qmodePrimeOverk - (1._kp + lnDotSqrtKinetic)*qmode) & + /scaleFactorToday /sqrtKinetic + + !normalisation of k in Mpc^-1 today + pertIni = pertIni*exp(infCosmo%efoldEndToToday - bfoldCreate - ln_mpc_to_kappaeff) + pertDotIni = pertDotIni*exp(infCosmo%efoldEndToToday - bfoldCreate - ln_mpc_to_kappaeff) + + end subroutine pert_creation_kinetic + + + + + subroutine quantum_creation(k,modeIni,modePrimeIniOverFreq) + !creates the initial quantum mode for a given k. The Bogoliubov + !coefficients are alpha and beta such as |alpha|^2 - |beta|^2 = 1. The + !creation time is not specified here and Prime denotes derivative with + !respect to the conformal time. Calling this function for all k at a + !same given conformal time with alpha=1,beta=0 is a Bunch-Davies vacuum. + !This is for rescaled modes in Fourier space: k^{3/2}*mode and + !in unit hbar=c=1, k is in unit of what you wish (cause rescaled modes). + + implicit none + real(kp), intent(in) :: k + complex(kp), intent(out) :: modeIni, modePrimeIniOverFreq + real(kp), parameter :: pi = 3.141592653589793238 + complex(kp), parameter :: alpha = (1._kp,0._kp) + complex(kp), parameter :: beta = (0._kp,0._kp) + + + modeIni = k*(alpha + beta) + modePrimeIniOverFreq = - k*cmplx(0._kp,1._kp)*(alpha - beta) + ! print *,'qmode qmodeDot',modeIni,modePrimeIniOverFreq + end subroutine quantum_creation + + + + end module infpert diff -r -c -b -N cosmomc/camb/infpowspline.f90 cosmomc_fields/camb/infpowspline.f90 *** cosmomc/camb/infpowspline.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infpowspline.f90 2008-03-05 17:35:04.000000000 +0100 *************** *** 0 **** --- 1,292 ---- + module infpowspline + !compute the primordial power spectra for few values of k and set a + !spline at intermediate k + + use infprec, only : kp + + implicit none + + private + + logical, parameter :: display = .false. + + + integer, save :: scalOrder + integer, save :: scalBcoefNum + integer, save :: scalModeNum + real(kp), dimension(:), allocatable, save :: scalLnkmpcKnot + real(kp), dimension(:,:,:), allocatable, save :: scalPowerBcoef + + integer, save :: tensOrder + integer, save :: tensBcoefNum + integer, save :: tensModeNum + real(kp), dimension(:), allocatable, save :: tensLnkmpcKnot + real(kp), dimension(:), allocatable, save :: tensPowerBcoef + + + + public check_power_scal_spline, check_power_tens_spline + public free_power_scal_spline, free_power_tens_spline + public set_power_scal_spline, set_power_tens_spline + public splineval_power_scal, splineval_power_tens + + contains + + + function check_power_scal_spline() + implicit none + logical :: check_power_scal_spline + + check_power_scal_spline = (allocated(scalLnkmpcKnot) & + .or. allocated(scalPowerBcoef)) + + end function check_power_scal_spline + + + + + subroutine free_power_scal_spline() + implicit none + + if (check_power_scal_spline()) then + deallocate(scalLnkmpcKnot) + deallocate(scalPowerBcoef) + if (display) write(*,*) 'free_power_scal_spline: powerscalar spline freed' + else + write(*,*) 'free_power_scal_spline: not powerscalar spline data allocated' + endif + + end subroutine free_power_scal_spline + + + + + function check_power_tens_spline() + implicit none + logical :: check_power_tens_spline + + check_power_tens_spline = (allocated(tensLnkmpcKnot) & + .or. allocated(tensPowerBcoef)) + + end function check_power_tens_spline + + + + + subroutine free_power_tens_spline() + implicit none + + if (check_power_tens_spline()) then + deallocate(tensLnkmpcKnot) + deallocate(tensPowerBcoef) + if (display) write(*,*) 'free_power_tens_spline: powertensor spline freed' + else + write(*,*) 'free_power_tens_spline: not powertensor spline data allocated' + endif + + end subroutine free_power_tens_spline + + + + + subroutine set_power_scal_spline(infCosmo,lnkmpcVec) + use bspline, only : dbsnak, dbsint + use inftorad, only : inftoradcosmo + use infpert, only : scalNum, power_spectrum_scal + implicit none + + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), dimension(:), intent(in) :: lnkmpcVec + + real(kp), dimension(:), allocatable :: lnPowerScalTemp + real(kp), dimension(:), allocatable :: scalPowerBcoefTemp + real(kp), dimension(:,:,:), allocatable :: lnPowerScal + real(kp), dimension(scalNum,scalNum) :: powerScal + real(kp) :: kmpc + + integer :: i,j,k,lnkmpcNum + + lnkmpcNum = size(lnkmpcVec,1) + + scalOrder = 3 + scalBcoefNum = lnkmpcNum + scalModeNum = scalNum + + !spline allocation + if (check_power_scal_spline()) then + write(*,*) 'set_power_scal_spline: spline already allocated' + stop + endif + + allocate(scalLnkmpcKnot(lnkmpcNum + scalOrder)) + allocate(scalPowerBcoef(scalBcoefNum,scalNum,scalNum)) + + !local + allocate(lnPowerScal(lnkmpcNum,scalNum,scalNum)) + + if (display) then + write(*,*)'set_power_scal_spline: computing knots' + endif + + !$omp parallel do & + !$omp default(shared) & + !$omp private(i,kmpc,powerScal,j,k) & + !$omp schedule(dynamic) + do i=1,lnkmpcNum + kmpc = exp(lnkmpcVec(i)) + powerScal = power_spectrum_scal(infCosmo,kmpc) + do k=1,scalNum + do j=1,scalNum + if (powerScal(j,k).eq.0._kp) then + powerScal(j,k) = tiny(1.0_kp) + endif + lnPowerScal(i,j,k) = log(powerScal(j,k)) + enddo + enddo + enddo + !$omp end parallel do + + if (display) then + write(*,*)'set_power_scal_spline: end computing knots' + endif + + call dbsnak(lnkmpcNum,lnkmpcVec,scalOrder,scalLnkmpcKnot) + + !to avoid race conditions + allocate(scalPowerBcoefTemp(scalBcoefNum)) + allocate(lnPowerScalTemp(lnkmpcNum)) + + do j=1,scalNum + do i=1,scalNum + lnPowerScalTemp(:) = lnPowerScal(:,i,j) + call dbsint(lnkmpcNum,lnkmpcVec,lnPowerScalTemp,scalOrder,scalLnkmpcKnot & + ,scalPowerBcoefTemp) + scalPowerBcoef(:,i,j) = scalPowerBcoefTemp(:) + enddo + enddo + + deallocate(scalPowerBcoefTemp) + deallocate(lnPowerScalTemp) + deallocate(lnPowerScal) + + + end subroutine set_power_scal_spline + + + + + + subroutine set_power_tens_spline(infCosmo,lnkmpcVec) + use bspline, only : dbsnak, dbsint + use infbgmodel, only : fieldNum + use inftorad, only : inftoradcosmo + use infpert, only : scalNum, power_spectrum_tens + implicit none + + type(inftoradcosmo), intent(in) :: infCosmo + real(kp), dimension(:), intent(in) :: lnkmpcVec + + real(kp), dimension(:), allocatable :: lnPowerTens + real(kp) :: kmpc, powerTens + integer :: i,lnkmpcNum + + + lnkmpcNum = size(lnkmpcVec,1) + tensOrder = 3 + tensBcoefNum = lnkmpcNum + tensModeNum = 1 + + !spline allocation + if (check_power_tens_spline()) then + write(*,*) 'set_power_tens_spline: spline already allocated' + stop + endif + + allocate(tensLnkmpcKnot(lnkmpcNum + tensOrder)) + allocate(tensPowerBcoef(tensBcoefNum)) + + !local + allocate(lnPowerTens(lnkmpcNum)) + + if (display) then + write(*,*)'set_power_tens_spline: computing knots' + endif + + + !$omp parallel do & + !$omp default(shared) & + !$omp private(i,kmpc,powerTens) & + !$omp schedule(dynamic) + do i=1,lnkmpcNum + kmpc = exp(lnkmpcVec(i)) + powerTens = power_spectrum_tens(infCosmo,kmpc) + if (powerTens.eq.0._kp) then + powerTens = tiny(1.0_kp) + endif + lnPowerTens(i) = log(powerTens) + enddo + !$omp end parallel do + + if (display) then + write(*,*)'set_power_scal_spline: end computing knots' + endif + + call dbsnak(lnkmpcNum,lnkmpcVec,tensOrder,tensLnkmpcKnot) + + call dbsint(lnkmpcNum,lnkmpcVec,lnPowerTens,tensOrder,tensLnkmpcKnot & + ,tensPowerBcoef) + + deallocate(lnPowerTens) + + end subroutine set_power_tens_spline + + + + + + function splineval_power_scal(kmpc) + use bspline, only : dbsval + implicit none + real(kp), intent(in) :: kmpc + real(kp), dimension(scalModeNum,scalModeNum) :: splineval_power_scal + real(kp) :: lnkmpc + real(kp), dimension(:), allocatable :: scalPowerBcoefTemp + integer :: i,j + + lnkmpc = log(kmpc) + + !avoid race condition + allocate(scalPowerBcoefTemp(scalBcoefNum)) + + do j=1,scalModeNum + do i=1,scalModeNum + scalPowerBcoefTemp = scalPowerBcoef(:,i,j) + splineval_power_scal(i,j) = exp(dbsval(lnkmpc,scalOrder,scalLnkmpcKnot & + ,scalBcoefNum,scalPowerBcoefTemp)) + enddo + enddo + + deallocate(scalPowerBcoefTemp) + + end function splineval_power_scal + + + + + function splineval_power_tens(kmpc) + use bspline, only : dbsval + implicit none + real(kp), intent(in) :: kmpc + real(kp) :: splineval_power_tens + real(kp) :: lnkmpc + + lnkmpc = log(kmpc) + + splineval_power_tens = exp(dbsval(lnkmpc,tensOrder,tensLnkmpcKnot & + ,tensBcoefNum,tensPowerBcoef)) + + end function splineval_power_tens + + + + end module infpowspline diff -r -c -b -N cosmomc/camb/infprec.f90 cosmomc_fields/camb/infprec.f90 *** cosmomc/camb/infprec.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infprec.f90 2009-10-22 17:47:39.428733617 +0200 *************** *** 0 **** --- 1,34 ---- + module infprec + implicit none + + public + + !quad precision + ! integer, parameter :: kp = kind(1.0_16) + + !double precision + integer, parameter :: kp = kind(1.0_8) + + !home made precision: p number of digit + ! integer, parameter :: kp = selected_real_kind(p=32) + + !default integration accuracy + real(kp), parameter :: tolkp = 1.d-12 + + !workaround for passing argument to old f77 functions. Only pointer + !can be deferred shape in derived data type. + !Allows to stop integration from conditions coming from called + !functions (find the end of inflation) + type transfert + logical :: yesno1,yesno2, yesno3, yesno4 + integer :: int1, int2, int3 + real(kp) :: real1, real2, real3 + real(kp), dimension(:), pointer :: ptrvector1 => null() + real(kp), dimension(:), pointer :: ptrvector2 => null() + !reserved + logical :: check,update + real(kp) :: xend + end type transfert + + + end module infprec diff -r -c -b -N cosmomc/camb/infsrmodel.f90 cosmomc_fields/camb/infsrmodel.f90 *** cosmomc/camb/infsrmodel.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/infsrmodel.f90 2009-04-24 14:24:03.611148493 +0200 *************** *** 0 **** --- 1,1062 ---- + Module infsrmodel + use infprec, only : kp + use infbgmodel, only : matterNum + implicit none + + private + + logical, parameter :: display = .true. + + integer, parameter :: efoldBound = 110._kp + + + public field_stopinf, field_thbound + public slowroll_initial_matter_lf, slowroll_initial_matter_sf + public slowroll_initial_matter_hy, slowroll_initial_matter_rm + public slowroll_initial_matter_kksf, slowroll_initial_matter_kklt + + public sr_efold_sf, sr_endinf_sf, sr_iniinf_sf + public sr_efold_kklt, sr_endinf_kklt, sr_iniinf_kklt + public sr_efold_rm, sr_iniinf_rm + + + contains + + + + function field_stopinf(infParam) + !return the field stop value in (1) and if it is a maximum (+1) or + !minimum (-1) in (2) + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), dimension(2) :: field_stopinf + + + select case (infParam%name) + + case ('largef') + field_stopinf(1) = infParam%consts(matterParamNum) + field_stopinf(2) = -1._kp + + case ('smallf') + field_stopinf(1) = infParam%consts(matterParamNum)*infParam%consts(3) + field_stopinf(2) = 1._kp + + case ('hybrid') + field_stopinf(1) = infParam%consts(matterParamNum) & + * slowroll_stopmax_matter_hy(infParam) + field_stopinf(2) = -1._kp + + case ('runmas') + + field_stopinf(1) = infParam%consts(matterParamNum) + !for nu>0 + if (infParam%consts(matterParamNum).lt.infParam%consts(3)) then + field_stopinf(2) = -1._kp + else + field_stopinf(2) = +1._kp + endif + !reverse if nu<0 + if (infParam%consts(4).lt.0._kp) then + field_stopinf(2) = -field_stopinf(2) + endif + + case ('kklmmt') + field_stopinf(1) = infParam%consts(matterParamNum)*infParam%consts(3) + field_stopinf(2) = -1._kp + print *, 'fieldStop = infParam(matterParamNum)' + end select + + end function field_stopinf + + + + function field_thbound(infParam) + !returns a theoretical bound on the allowed field values if any. May be + !from the stochastic regime or uv limit in brane setup + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), dimension(2) :: field_thbound + + + select case (infParam%name) + + case ('kklmmt') + field_thbound(1) = infParam%consts(matterParamNum-1) + field_thbound(2) = +1._kp + print *, 'fieldUv = infParam%consts(matterParamNum-1)' + + case default + stop 'no theoretical field bound implemented for this model!' + + end select + + end function field_thbound + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !large field models + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function slowroll_initial_matter_lf(infParam,efoldWanted) + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_lf + + real(kp), parameter :: efoldDefault = efoldBound + real(kp) :: matterEnd, matterIni + real(kp) :: p,mu,efold + + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + mu = infParam%consts(3) + if (mu.ne.0._kp) stop 'slowroll_initial_matter_lf: improper parameters' + + + p = infParam%consts(2) + + matterEnd = p/sqrt(2._kp) + + matterIni = sqrt(p**2/2._kp + 2._kp*p*efold) + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_lf: (*kappa)' + write(*,*)'matterEnd = ',matterEnd + write(*,*)'matterIni = ',matterIni + write(*,*) + endif + + slowroll_initial_matter_lf = matterIni + + end function slowroll_initial_matter_lf + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !small field models + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function slowroll_initial_matter_sf(infParam,efoldWanted) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_sf + + type(transfert) :: sfData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + + real(kp) :: matterOverMuEnd, matterOverMuIni + real(kp) :: mini,maxi + real(kp) :: p, mu, efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_sf: improper parameters' + endif + + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_sf: p = ',p + stop + endif + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + !find the end of inflation + + mini = epsilon(1._kp) + maxi = 1._kp + epsilon(1._kp) + + sfData%real1 = p + sfData%real2 = mu + + matterOverMuEnd = zbrent(sr_endinf_sf,mini,maxi,tolFind,sfData) + + + + !find the initial field values efolds before + + mini = epsilon(1._kp) + maxi = matterOverMuEnd + + sfData%real1 = p + sfData%real2 = 2._kp*p*efold/mu**2 + sr_efold_sf(matterOverMuEnd,p) + + + matterOverMuIni = zbrent(sr_iniinf_sf,mini,maxi,tolFind,sfData) + + slowroll_initial_matter_sf = matterOverMuIni*mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_sf: (*kappa) (/mu)' + write(*,*)'matterEnd = ',matterOverMuEnd*mu,matterOverMuEnd + write(*,*)'matterIni = ',matterOverMuIni*mu,matterOverMuIni + write(*,*) + endif + + + end function slowroll_initial_matter_sf + + + + + function sr_endinf_sf(x,sfData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: sfData + real(kp) :: sr_endinf_sf + real(kp) :: p,mu + + p=sfData%real1 + mu=sfData%real2 + + sr_endinf_sf = x**(p-1._kp) + sqrt(2._kp)*mu/abs(p) * (x**p - 1._kp) + + end function sr_endinf_sf + + + + + function sr_iniinf_sf(x,sfData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: sfData + real(kp) :: sr_iniinf_sf + real(kp) :: p + + p=sfData%real1 + + sr_iniinf_sf = sr_efold_sf(x,p) - sfData%real2 + + end function sr_iniinf_sf + + + + + function sr_efold_sf(x,p) + implicit none + real(kp), intent(in) :: x,p + real(kp) :: sr_efold_sf + + if (p == 2._kp) then + sr_efold_sf = x**2 - 2._kp * log(x) + else + sr_efold_sf = x**2 + 2._kp/(p-2._kp) * x**(2._kp-p) + endif + + end function sr_efold_sf + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !kklmmt + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !some function call the small field ones since kklmmt potential looks + !like the small field ones with p->-p + + + function slowroll_initial_matter_kksf(infParam,efoldWanted) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_kksf + + type(transfert) :: sfData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + + real(kp) :: matterOverMuEnd, matterOverMuIni + real(kp) :: mini,maxi + real(kp) :: p, mu, efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_kksf: improper parameters' + endif + + + if (p.lt.0._kp) then + write(*,*) 'slowroll_initial_matter_kksf: p = ',p + stop + endif + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + !find the end of inflation + + mini = 1._kp + epsilon(1._kp) + maxi = 1._kp/epsilon(1._kp) + + sfData%real1 = -p + sfData%real2 = mu + + matterOverMuEnd = zbrent(sr_endinf_sf,mini,maxi,tolFind,sfData) + + + + !find the initial field values efolds before + + mini = matterOverMuEnd + maxi = 1._kp/epsilon(1._kp) + + sfData%real1 = -p + sfData%real2 = 2._kp*(-p)*efold/mu**2 + sr_efold_sf(matterOverMuEnd,-p) + + + matterOverMuIni = zbrent(sr_iniinf_sf,mini,maxi,tolFind,sfData) + + slowroll_initial_matter_kksf = matterOverMuIni*mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_kksf: (*kappa) (/mu)' + write(*,*)'matterEnd = ',matterOverMuEnd*mu,matterOverMuEnd + write(*,*)'matterIni = ',matterOverMuIni*mu,matterOverMuIni + write(*,*) + endif + + + end function slowroll_initial_matter_kksf + + + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !hybrid models + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + + function slowroll_initial_matter_hy(infParam,efoldWanted) + use infprec, only : transfert, tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_hy + + type(transfert) :: hyData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + real(kp), dimension(2) :: fieldStop + real(kp) :: matterOverMuMax, matterOverMuIni, matterOverMuStop + real(kp) :: mini,maxi + real(kp) :: p, mu + real(kp) :: muConnex, efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + + !sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_hy: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_hy: p = ',p + stop + endif + + if (infParam%consts(matterParamNum).gt.1._kp) then + stop 'slowroll_initial_matter_hy: improper consts(5)' + endif + + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + + !determines the maximum allowed field value to stop hybrid inflation + !(see the called function) + ! matterOverMuStopMax = slowroll_stopmax_matter_hy(infParam) / mu + + !for hybrid inflation, it assumes that consts(matparamnum) is in unit of + !mattertopMax + fieldStop = field_stopinf(infParam) + matterOverMuStop = fieldStop(1) / mu + + + !upper field value bound + matterOverMuMax = slowroll_startmax_matter_hy(infParam) + + + !find matterIni otherwise to get the right number of efolds + + mini = matterOverMuStop + maxi = matterOverMuMax + + hyData%real1 = p + hyData%real2 = 2._kp*p*(efold)/mu**2 + sr_efold_hy(matterOverMuStop,p) + + matterOverMuIni = zbrent(sr_iniinf_hy,mini,maxi,tolFind,hyData) + + slowroll_initial_matter_hy = matterOverMuIni * mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_hy: (*kappa) (/mu)' + write(*,*)'matterStop = ',matterOverMuStop*mu, matterOverMuStop + write(*,*)'matterIni = ',matterOverMuIni*mu, matterOverMuIni + write(*,*) + endif + + + end function slowroll_initial_matter_hy + + + + + + function slowroll_stopmax_matter_hy(infParam) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp) :: slowroll_stopmax_matter_hy + + real(kp), parameter :: efoldHybrid = efoldBound + + real(kp), parameter :: tolFind = tolkp + type(transfert) :: hyData + real(kp) :: p,mu, mini,maxi + real(kp) :: matterOverMuMax, matterOverMuStopMax + + p = infParam%consts(2) + mu = infParam%consts(3) + + !sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_stopmax_matter_hy: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_stopmax_matter_hy: p = ',p + stop + endif + + matterOverMuMax = slowroll_startmax_matter_hy(infParam)/mu + + !MatterStopMax is the zero of the sr evolution equation with N --> -N + !and set to efoldHybrid. + + mini = epsilon(1._kp) + maxi = matterOverMuMax + + hyData%real1 = p + hyData%real2 = -2._kp*p*(efoldHybrid)/mu**2 + sr_efold_hy(matterOverMuMax,p) + + matterOverMuStopMax = zbrent(sr_iniinf_hy,mini,maxi,tolFind,hyData) + + !return the field value, in unit of kappa + slowroll_stopmax_matter_hy = matterOverMuStopMax * mu + + if (display) then + write(*,*) + write(*,*)'slowroll_matter_stopmax_hy: (*kappa) (/mu)' + write(*,*)'efold definition = ',efoldHybrid + write(*,*)'matterStopMax = ',matterOverMuStopMax*mu, matterOverMuStopMax + write(*,*) + endif + + end function slowroll_stopmax_matter_hy + + + + + + + function slowroll_startmax_matter_hy(infParam) + use infprec, only : transfert,tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp) :: slowroll_startmax_matter_hy + + real(kp), parameter :: tolFind = tolkp + type(transfert) :: hyData + real(kp) :: p,mu,mini,maxi, muConnex + real(kp) :: matterOverMuTrans, matterOverMuMax + + p = infParam%consts(2) + mu = infParam%consts(3) + + !sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_startmax_matter_hy: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_startmax_matter_hy: p = ',p + stop + endif + + + !this is the mu above which eps1 = 1 has no solution and for which + !inflationary domains in field space are simply connected + muConnex = p/sqrt(8._kp) + + !this is the matter/mu for which eps1 is maximum. eps1(matter) is a + !increasing function wrt the field under this value, and decreasing + !above. So hybrid like behaviour only appears for matter < + !matterTrans. Otherwise, this is a mixture between large field like + !and hybrid inflation during which the sign of eps2 changes + matterOverMuTrans = (p - 1._kp)**(1._kp/p) + + + !We are looking to the maximum allowed value of the field to stop + !inflation and to get at least "efoldHybrid" efolds of inflation. Here + !we discard the case where inflation may start for matterIni > + !matterTrans since it would be large field like inflation. So the + !ultimate upper limit for matterIni, defined as matterMax, is the + !min(matterTrans,matterOne) where eps1(matterOne) = 1. MatterOne is + !seeked in [0,matterTrans]: this selects only the lower root, the + !other corresponding to the end of a large field like inflation) + mini = epsilon(1._kp) + maxi = matterOverMuTrans + + hyData%real1 = p + hyData%real2 = mu + + if (mu.le.muConnex) then + matterOverMuMax = zbrent(sr_endinf_hy,mini,maxi,tolFind,hyData) + else + matterOverMuMax = matterOverMuTrans + endif + + slowroll_startmax_matter_hy = matterOverMuMax * mu + + if (display) then + write(*,*)'slowroll_startmax_matter_hy: (*kappa) (/mu)' + write(*,*)'matterMax = ',matterOverMuMax*mu,matterOverMuMax + if (mu.lt.muConnex) then + write(*,*) '<--- due to epsilon1 > 1 above' + else + write(*,*) '<--- due to epsilon2 > 0 above' + endif + endif + + end function slowroll_startmax_matter_hy + + + + function sr_endinf_hy(x,hyData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: hyData + real(kp) :: sr_endinf_hy + real(kp) :: p,mu + + p=hyData%real1 + mu=hyData%real2 + + sr_endinf_hy = x**(p-1._kp) - sqrt(2._kp)*mu/p * (x**p + 1._kp) + + end function sr_endinf_hy + + + + + function sr_iniinf_hy(x,hyData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: hyData + real(kp) :: sr_iniinf_hy + real(kp) :: p + + p=hyData%real1 + + sr_iniinf_hy = sr_efold_hy(x,p) - hyData%real2 + + end function sr_iniinf_hy + + + + + function sr_efold_hy(x,p) + implicit none + real(kp), intent(in) :: x,p + real(kp) :: sr_efold_hy + + if (p == 2._kp) then + sr_efold_hy = x**2 + 2._kp * log(x) + else + sr_efold_hy = x**2 - 2._kp/(p-2._kp) * x**(2._kp-p) + endif + + + end function sr_efold_hy + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !running mass models + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + function slowroll_initial_matter_rm(infParam,efoldWanted) + use infprec, only : transfert, tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_rm + + type(transfert) :: rmData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + real(kp) :: efold + real(kp) :: mini,maxi,randnum + real(kp) :: p,mu,nu,lambda + real(kp) :: matterOverMuStop,matterStop,matterEnd,matterIni + real(kp) :: matterZero + real(kp), dimension(2) :: fieldStop + + !should match with the definition of consts! + p = infParam%consts(2) + mu = infParam%consts(3) + nu = infParam%consts(4) + + !sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_rm: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_rm: p = ',p + stop + endif + + if ((abs(infParam%consts(4)).gt.0.5_kp).or.(infParam%consts(4).eq.0._kp)) then + write(*,*)'slowroll_initial_matter_rm: improper consts(4) = ',infParam%consts(4) + read(*,*) + endif + + lambda = nu * mu**p + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + + + !the potential is + ! U = M^4 { 1 + nu*[1/p - ln(matter/mu)]*matter^p} + + + !matterstop required + fieldStop = field_stopinf(infParam) + matterStop = fieldStop(1) + + + + !for nu>0 there is matterEnd such as eps1(matterEnd) = 1. So the end + !of inflation in that case is either given by matterEnd or by + !matterStop. Note however that eps2 is usually big in that case which + !makes this calculation useless DAMNED!!. The eps1=1 eq has + !one solution only in [mu,matterZero] where U(matterZero) = 0 + if ((nu.gt.0._kp).and.(matterStop.gt.mu)) then + mini = mu + epsilon(1._kp) + maxi = 1._kp/epsilon(1._kp) + + rmData%real1 = p + rmData%real2 = mu + rmData%real3 = nu + + matterZero = zbrent(rm_potential,mini,maxi,tolFind,rmData) + + mini = mu + maxi = matterZero + + rmData%real1 = p + rmData%real2 = mu + rmData%real3 = nu + + matterEnd = zbrent(sr_endinf_rm,mini,maxi,tolFind,rmData) + + if (display) then + if (matterEnd.lt.matterStop) then + write(*,*)'slowroll_initial_matter_rm: epsilon1 stops inflation in SR approx' + endif + endif + + !useless matterStop = min(matterStop,matterEnd) + endif + + + !find matterIni according to matterStop to get the right number of + !efolds. The choice between the 4 models is done according to the + !value of matterStop. matterIni>1 has been allowed for RM4, with still + !matterStop < 1 + + if (matterStop.eq.mu) then + write(*,*)'slowroll_initial_matter_rm: matterStop/mu = ',matterStop/mu + stop + endif + + if (matterStop.lt.mu) then + mini = epsilon(1._kp) + maxi = mu - epsilon(1._kp) + elseif (matterStop.gt.mu) then + mini = mu + epsilon(1._kp) + if (nu.gt.0._kp) then + maxi = 1._kp + else + maxi = 1._kp/epsilon(1._kp) + endif + else + stop 'slowroll_initial_matter_rm: error' + endif + + matterOverMuStop = matterStop/mu + + ! print *,'mini maxi',mini,maxi + + rmData%real1 = p + rmData%real2 = mu + rmData%real3 = nu + rmData%xend = sr_efold_rm(matterOverMuStop,p,lambda) + 2._kp*p*efold/mu**2 + + matterIni = zbrent(sr_iniinf_rm,mini,maxi,tolFind,rmData) + + slowroll_initial_matter_rm = matterIni + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_rm: (*kappa)' + write(*,*)'matterZero = ',matterZero + write(*,*)'matterEnd = ',matterEnd + write(*,*)'matterStop = ',matterStop + write(*,*)'matterIni = ',matterIni + write(*,*) + endif + + + end function slowroll_initial_matter_rm + + + + + function sr_efold_rm(x,p,l) + use specialinf, only : dp, dei + implicit none + real(kp), intent(in) :: x,p,l + real(kp) :: sr_efold_rm + real(dp) :: argei1,argei2 + + !l=nu*mu^p + + if (p == 2._kp) then + argei1 = 2._dp*log(x) + sr_efold_rm = x**2 - (2._kp/l)*log(abs(log(x))) - dei(argei1) + else + argei1 = (2._dp-p)*log(x) + argei2 = 2._dp*log(x) + sr_efold_rm = x**2 - (2._kp/l)*dei(argei1) - (2._kp/p)*dei(argei2) + endif + + ! print *,'arg ei',argei1,dei(argei1) + + end function sr_efold_rm + + + + + function sr_endinf_rm(matter,rmData) + !vanishes for eps1=1 in the sr approx + use infprec, only : transfert + implicit none + real(kp), intent(in) :: matter + type(transfert), optional, intent(inout) :: rmData + real(kp) :: sr_endinf_rm + real(kp) :: p,mu,nu,x + + p=rmData%real1 + mu=rmData%real2 + nu=rmData%real3 + + x = matter/mu + + sr_endinf_rm = 1._kp + nu*(1._kp/p - log(x))*matter**p & + - (nu*p/sqrt(2._kp))*log(x)*matter**(p-1._kp) + + end function sr_endinf_rm + + + + + + function sr_iniinf_rm(matter,rmData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: matter + type(transfert), optional, intent(inout) :: rmData + real(kp) :: sr_iniinf_rm + real(kp) :: p,mu,nu,x,l + + p=rmData%real1 + mu=rmData%real2 + nu=rmData%real3 + + x = matter/mu + l = nu * mu**p + + sr_iniinf_rm = sr_efold_rm(x,p,l) - rmData%xend + + end function sr_iniinf_rm + + + + function rm_potential(matter,rmData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: matter + type(transfert), optional, intent(inout) :: rmData + real(kp) :: rm_potential + real(kp) :: p,mu,nu,x + + p=rmData%real1 + mu=rmData%real2 + nu=rmData%real3 + + x = matter/mu + + rm_potential = 1._kp + nu*(1._kp/p - log(x))*matter**p + + end function rm_potential + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !kklmmt models with m2=0: V = M^4 / [1 + (mu/phi)^p] + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function slowroll_initial_matter_kklt(infParam,efoldWanted) + use infprec, only : transfert, tolkp + use inftools, only : zbrent + use infbgmodel, only : infbgparam, matterParamNum + implicit none + type(infbgparam), intent(in) :: infParam + real(kp), optional, intent(in) :: efoldWanted + real(kp), dimension(matterNum) :: slowroll_initial_matter_kklt + + type(transfert) :: kkltData + real(kp), parameter :: efoldDefault = efoldBound + real(kp), parameter :: tolFind = tolkp + + real(kp), dimension(2) :: fieldStop, fieldUv + real(kp) :: matterOverMuUv, matterOverMuString + real(kp) :: matterOverMuEps, matterOverMuIni, matterOverMuEnd + real(kp) :: mini,maxi + real(kp) :: p, mu + real(kp) :: efold + + + p = infParam%consts(2) + mu = infParam%consts(3) + + !sanity checks + if (infParam%consts(3).le.0._kp) then + stop 'slowroll_initial_matter_kklt: improper consts(3)' + endif + + if (p.lt.2._kp) then + write(*,*) 'slowroll_initial_matter_kklt: p = ',p + stop + endif + + if (infParam%consts(5).ne.-1._kp) then + stop 'slowroll_initial_matter_kklt: improper consts(5)' + endif + + + if (present(efoldWanted)) then + efold = efoldWanted + else + efold = efoldDefault + endif + + + !upper field value bound + fieldUv = field_thbound(infParam) + matterOverMuUv = fieldUv(1)/mu + + + !inflation stops at matterOverMuEps1 (its determination is no accurate + !since eps2>1 in that region, but the number of efold in between is + !small. This condition could be replaced by matterOverMuEps2 as well + + mini = 0._kp + maxi = 1._kp/epsilon(1._kp) + + kkltData%real1 = p + kkltData%real2 = mu + + matterOverMuEps = zbrent(sr_endinf_kklt,mini,maxi,tolFind,kkltData) + + + !the branes collide at matterString + fieldStop = field_stopinf(infParam) + matterOverMuString = fieldStop(1)/mu + + if (matterOverMuString.lt.1.) then + write(*,*)'slowroll_initial_matter_kklt: matterOverMuString < mu' + endif + + + matterOverMuEnd = max(matterOverMuString,MatterOverMuEps) + + + if (matterOverMuEnd.gt.matterOverMuUv) then + write(*,*)'slowroll_initial_matter_kklt: matterOverMuEnd > matterOverMuUv' + endif + + !find matterIni that gives the wanted number of efolds + + mini = 0._kp + maxi = 1._kp/epsilon(1._kp) + + kkltData%real1 = p + kkltData%real2 = p*(efold)/mu**2 + sr_efold_kklt(matterOverMuEnd,p) + + matterOverMuIni = zbrent(sr_iniinf_kklt,mini,maxi,tolFind,kkltData) + + slowroll_initial_matter_kklt = matterOverMuIni * mu + + if (display) then + write(*,*) + write(*,*)'slowroll_initial_matter_kklt: (*kappa) (/mu)' + write(*,*)'matterEnd = ',matterOverMuEnd*mu, matterOverMuEnd + write(*,*)'matterString = ',matterOverMuString*mu, matterOverMuString + write(*,*)'matterEps = ',matterOverMuEps*mu, matterOverMuEps + write(*,*)'matterIni = ',matterOverMuIni*mu, matterOverMuIni + write(*,*)'matterUv = ',matterOverMuUv*mu, matterOverMuUv + write(*,*) + endif + + + end function slowroll_initial_matter_kklt + + + + + function sr_endinf_kklt(x,kkltData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: kkltData + logical, parameter :: endinfIsEpsOne=.true. + real(kp) :: sr_endinf_kklt + real(kp) :: p,mu + + p=kkltData%real1 + mu=kkltData%real2 + + if (endinfIsEpsOne) then + !epsilon1=1 + sr_endinf_kklt = x**(p+1._kp) + x - p/(mu*sqrt(2._kp)) + else + !epsilon2=1 + sr_endinf_kklt = (x**(p+1._kp) + x)**2 - (2._kp*p/mu/mu) & + *( (p+1._kp)*x**p + 1._kp) + endif + + end function sr_endinf_kklt + + + + + function sr_iniinf_kklt(x,kkltData) + use infprec, only : transfert + implicit none + real(kp), intent(in) :: x + type(transfert), optional, intent(inout) :: kkltData + real(kp) :: sr_iniinf_kklt + real(kp) :: p + + p=kkltData%real1 + + sr_iniinf_kklt = sr_efold_kklt(x,p) - kkltData%real2 + + end function sr_iniinf_kklt + + + + + function sr_efold_kklt(x,p) + implicit none + real(kp), intent(in) :: x,p + real(kp) :: sr_efold_kklt + + sr_efold_kklt = 0.5_kp*x**2 + x**(p+2._kp)/(p+2._kp) + + + end function sr_efold_kklt + + + + + + end module infsrmodel diff -r -c -b -N cosmomc/camb/inftools.f90 cosmomc_fields/camb/inftools.f90 *** cosmomc/camb/inftools.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/inftools.f90 2009-04-24 14:31:38.003022702 +0200 *************** *** 0 **** --- 1,1078 ---- + module inftools + use infprec, only : kp,transfert + implicit none + + private + + public easydverk, tunedverk + public zbrent + + + + contains + + + + subroutine easydverk(n,fcn,x,y,xend,tol,extradata) + implicit none + + integer :: n,ind + real(kp) :: x,y(n),xend,tol,c(24),w(n,9) + type(transfert), optional,intent(inout) :: extradata + + ! external :: fcn + + include 'inftools.h' + + + ! ind=1 + ind=2 + c = 0._kp + c(3) = epsilon(1._kp) + + call dverk(n,fcn,x,y,xend,tol,ind,c,n,w,extradata) + + if (ind.ne.3) then + write(*,*) 'easydverk: stop ind = ',ind + write(*,*) 'try to reduce tolerance' + stop + endif + end subroutine easydverk + + + + subroutine tunedverk(n,fcn,x,y,xend,tol,extradata) + implicit none + + integer :: n,ind + real(kp) :: x,y(n),xend,tol,c(24),w(n,9) + type(transfert), optional,intent(inout) :: extradata + + ! external :: fcn + + include 'inftools.h' + + + + ind=2 + c = 0._kp + c(3) = epsilon(1._kp) + c(4) = epsilon(1._kp) + + call dverk(n,fcn,x,y,xend,tol,ind,c,n,w,extradata) + + if (ind.ne.3) then + write(*,*) 'unsanedverk: stop ind = ',ind + write(*,*) 'desesperate accuracy unreachable...' + write(*,*) 'try tuning c(4) and c(6) in inftools:unsanedverk!' + stop + endif + end subroutine tunedverk + + + + + + + subroutine diydverk(n,fcn,x,y,xend,tol,ind,c,extradata) + implicit none + + integer :: n,ind + real(kp) :: x,y(n),xend,tol,c(24),w(n,9) + type(transfert), optional, intent(inout) :: extradata + + ! external :: fcn + + include 'inftools.h' + + ind=2 + c = 0._kp + + c(3) = epsilon(1._kp) + c(4) = 0.001_kp + + call dverk(n,fcn,x,y,xend,tol,ind,c,n,w,extradata) + + if ((ind.ne.3).and.(ind.ne.7)) then + write(*,*) 'diydverk: stop ind = ',ind + stop + endif + end subroutine diydverk + + + + + ! function easyfixpnf(xstart,f,fjac,extradata) + ! use hompack, only : rhodum, rhojacdum,fixpnf + ! implicit none + + ! real(kp) :: xstart, easyfixpnf + ! type(transfert), optional :: extradata + + + ! real(kp), parameter :: tolZero = 1e-5 + + ! integer, parameter :: n = 1 + ! integer :: iflag, trace, nfe + ! real(kp) :: arcre,arcae + ! real(kp) :: ansre,ansae + ! real(kp) :: arclen + + ! real(kp), dimension(n) :: a + ! real(kp), dimension(n+1) :: y,yp,yold,ypold + + ! real(kp), dimension(1:N,1:N+2) :: qr + ! real(kp), dimension(n) :: alpha + ! real(kp), dimension(n+1) :: tz,w,wp,z0,z1 + + ! real(kp), dimension(8) :: sspar + + ! integer, dimension(n+1) :: pivot + + ! include 'hominfpack.h' + + ! iflag = -1 + ! trace = -1 + ! sspar = -1 + + ! arcre = -1. + ! arcae = -1. + ! ansre = tolZero + ! ansae = tolZero + + + ! y(n+1) = xstart + + ! call fixpnf(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE, & + ! ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR, & + ! f,fjac,rhodum,rhojacdum,extradata) + + ! if (iflag.ne.1) then + ! write(*,*)'easyzero: iflag = ',iflag + ! stop + ! endif + + ! easyfixpnf = y(n+1) + + ! end function easyfixpnf + + + + + + + + subroutine dverk(n,fcn,x,y,xend,tol,ind,c,nw,w,extradata) + implicit none + integer :: n, ind, nw, k + real(kp) :: x, y(n), xend, tol, c(*), w(nw,9), temp + type(transfert), optional, intent(inout) :: extradata + + + ! + !*********************************************************************** + ! * + ! note added 11/14/85. * + ! * + ! if you discover any errors in this subroutine, please contact * + ! * + ! kenneth r. jackson * + ! department of computer science * + ! university of toronto * + ! toronto, ontario, * + ! canada m5s 1a4 * + ! * + ! phone: 416-978-7075 * + ! * + ! electroni! mail: * + ! uucp: {cornell,decvax,ihnp4,linus,uw-beaver}!utcsri!krj * + ! csnet: krj@toronto * + ! arpa: krj.toronto@csnet-relay * + ! bitnet: krj%toronto@csnet-relay.arpa * + ! * + ! dverk is written in fortran 66. * + ! * + ! the constants dwarf and rreb -- c(10) and c(11), respectively -- are * + ! set for a vax in double precision. they should be reset, as * + ! described below, if this program is run on another machine. * + ! * + ! the c array is declared in this subroutine to have one element only, * + ! although more elements are referenced in this subroutine. this * + ! causes some compilers to issue warning messages. there is, though, * + ! no error provided c is declared sufficiently large in the calling * + ! program, as described below. * + ! * + ! the following external statement for fcn was added to avoid a * + ! warning message from the unix f77 compiler. the original dverk * + ! comments and code follow it. * + ! * + !*********************************************************************** + ! + + !EXTRADATA + + !might be dangerous (xlf90) with optional argument, rather use explicit + !interface + ! external fcn + include 'inftools.h' + + if (present(extradata)) extradata%update = .false. + ! + !*********************************************************************** + ! * + ! purpose - this is a runge-kutta subroutine based on verner's * + ! fifth and sixth order pair of formulas for finding approximations to * + ! the solution of a system of first order ordinary differential * + ! equations with initial conditions. it attempts to keep the global * + ! error proportional to a tolerance specified by the user. (the * + ! proportionality depends on the kind of error control that is used, * + ! as well as the differential equation and the range of integration.) * + ! * + ! various options are available to the user, including different * + ! kinds of error control, restrictions on step sizes, and interrupts * + ! which permit the user to examine the state of the calculation (and * + ! perhaps make modifications) during intermediate stages. * + ! * + ! the program is efficient for non-stiff systems. however, a good * + ! variable-order-adams method will probably be more efficient if the * + ! function evaluations are very costly. such a method would also be * + ! more suitable if one wanted to obtain a large number of intermediate * + ! solution values by interpolation, as might be the case for example * + ! with graphical output. * + ! * + ! hull-enright-jackson 1/10/76 * + ! * + !*********************************************************************** + ! * + ! use - the user must specify each of the following * + ! * + ! n number of equations * + ! * + ! fcn name of subroutine for evaluating functions - the subroutine * + ! itself must also be provided by the user - it should be of * + ! the following form * + ! subroutine fcn(n, x, y, yprime) * + ! integer n * + ! double precision x, y(n), yprime(n) * + ! *** etc *** * + ! and it should evaluate yprime, given n, x and y * + ! * + ! x independent variable - initial value supplied by user * + ! * + ! y dependent variable - initial values of components y(1), y(2), * + ! ..., y(n) supplied by user * + ! * + ! xend value of x to which integration is to be carried out - it may * + ! be less than the initial value of x * + ! * + ! tol tolerance - the subroutine attempts to control a norm of the * + ! local error in such a way that the global error is * + ! proportional to tol. in some problems there will be enough * + ! damping of errors, as well as some cancellation, so that * + ! the global error will be less than tol. alternatively, the * + ! control can be viewed as attempting to provide a * + ! calculated value of y at xend which is the exact solution * + ! to the problem y' = f(x,y) + e(x) where the norm of e(x) * + ! is proportional to tol. (the norm is a max norm with * + ! weights that depend on the error control strategy chosen * + ! by the user. the default weight for the k-th component is * + ! 1/max(1,abs(y(k))), which therefore provides a mixture of * + ! absolute and relative error control.) * + ! * + ! ind indicator - on initial entry ind must be set equal to either * + ! 1 or 2. if the user does not wish to use any options, he * + ! should set ind to 1 - all that remains for the user to do * + ! then is to declare c and w, and to specify nw. the user * + ! may also select various options on initial entry by * + ! setting ind = 2 and initializing the first 9 components of * + ! c as described in the next section. he may also re-enter * + ! the subroutine with ind = 3 as mentioned again below. in * + ! any event, the subroutine returns with ind equal to * + ! 3 after a normal return * + ! 4, 5, or 6 after an interrupt (see options c(8), c(9)) * + ! -1, -2, or -3 after an error condition (see below) * + ! * + ! c communications vector - the dimension must be greater than or * + ! equal to 24, unless option c(1) = 4 or 5 is used, in which * + ! case the dimension must be greater than or equal to n+30 * + ! * + ! nw first dimension of workspace w - must be greater than or * + ! equal to n * + ! * + ! w workspace matrix - first dimension must be nw and second must * + ! be greater than or equal to 9 * + ! * + ! the subroutine will normally return with ind = 3, having * + ! replaced the initial values of x and y with, respectively, the value * + ! of xend and an approximation to y at xend. the subroutine can be * + ! called repeatedly with new values of xend without having to change * + ! any other argument. however, changes in tol, or any of the options * + ! described below, may also be made on such a re-entry if desired. * + ! * + ! three error returns are also possible, in which case x and y * + ! will be the most recently accepted values - * + ! with ind = -3 the subroutine was unable to satisfy the error * + ! requirement with a particular step-size that is less than or * + ! equal to hmin, which may mean that tol is too small * + ! with ind = -2 the value of hmin is greater than hmax, which * + ! probably means that the requested tol (which is used in the * + ! calculation of hmin) is too small * + ! with ind = -1 the allowed maximum number of fcn evaluations has * + ! been exceeded, but this can only occur if option c(7), as * + ! described in the next section, has been used * + ! * + ! there are several circumstances that will cause the calculations * + ! to be terminated, along with output of information that will help * + ! the user determine the cause of the trouble. these circumstances * + ! involve entry with illegal or inconsistent values of the arguments, * + ! such as attempting a normal re-entry without first changing the * + ! value of xend, or attempting to re-enter with ind less than zero. * + ! * + !*********************************************************************** + ! * + ! options - if the subroutine is entered with ind = 1, the first 9 * + ! components of the communications vector are initialized to zero, and * + ! the subroutine uses only default values for each option. if the * + ! subroutine is entered with ind = 2, the user must specify each of * + ! these 9 components - normally he would first set them all to zero, * + ! and then make non-zero those that correspond to the particular * + ! options he wishes to select. in any event, options may be changed on * + ! re-entry to the subroutine - but if the user changes any of the * + ! options, or tol, in the course of a calculation he should be careful * + ! about how such changes affect the subroutine - it may be better to * + ! restart with ind = 1 or 2. (components 10 to 24 of c are used by the * + ! program - the information is available to the user, but should not * + ! normally be changed by him.) * + ! * + ! c(1) error control indicator - the norm of the local error is the * + ! max norm of the weighted error estimate vector, the * + ! weights being determined according to the value of c(1) - * + ! if c(1)=1 the weights are 1 (absolute error control) * + ! if c(1)=2 the weights are 1/abs(y(k)) (relative error * + ! control) * + ! if c(1)=3 the weights are 1/max(abs(c(2)),abs(y(k))) * + ! (relative error control, unless abs(y(k)) is less * + ! than the floor value, abs(c(2)) ) * + ! if c(1)=4 the weights are 1/max(abs(c(k+30)),abs(y(k))) * + ! (here individual floor values are used) * + ! if c(1)=5 the weights are 1/abs(c(k+30)) * + ! for all other values of c(1), including c(1) = 0, the * + ! default values of the weights are taken to be * + ! 1/max(1,abs(y(k))), as mentioned earlier * + ! (in the two cases c(1) = 4 or 5 the user must declare the * + ! dimension of c to be at least n+30 and must initialize the * + ! components c(31), c(32), ..., c(n+30).) * + ! * + ! c(2) floor value - used when the indicator c(1) has the value 3 * + ! * + ! c(3) hmin specification - if not zero, the subroutine chooses hmin * + ! to be abs(c(3)) - otherwise it uses the default value * + ! 10*max(dwarf,rreb*max(weighted norm y/tol,abs(x))), * + ! where dwarf is a very small positive machine number and * + ! rreb is the relative roundoff error bound * + ! * + ! c(4) hstart specification - if not zero, the subroutine will use * + ! an initial hmag equal to abs(c(4)), except of course for * + ! the restrictions imposed by hmin and hmax - otherwise it * + ! uses the default value of hmax*(tol)**(1/6) * + ! * + ! c(5) scale specification - this is intended to be a measure of the * + ! scale of the problem - larger values of scale tend to make * + ! the method more reliable, first by possibly restricting * + ! hmax (as described below) and second, by tightening the * + ! acceptance requirement - if c(5) is zero, a default value * + ! of 1 is used. for linear homogeneous problems with * + ! constant coefficients, an appropriate value for scale is a * + ! norm of the associated matrix. for other problems, an * + ! approximation to an average value of a norm of the * + ! jacobian along the trajectory may be appropriate * + ! * + ! c(6) hmax specification - four cases are possible * + ! if c(6).ne.0 and c(5).ne.0, hmax is taken to be * + ! min(abs(c(6)),2/abs(c(5))) * + ! if c(6).ne.0 and c(5).eq.0, hmax is taken to be abs(c(6)) * + ! if c(6).eq.0 and c(5).ne.0, hmax is taken to be * + ! 2/abs(c(5)) * + ! if c(6).eq.0 and c(5).eq.0, hmax is given a default value * + ! of 2 * + ! * + ! c(7) maximum number of function evaluations - if not zero, an * + ! error return with ind = -1 will be caused when the number * + ! of function evaluations exceeds abs(c(7)) * + ! * + ! c(8) interrupt number 1 - if not zero, the subroutine will * + ! interrupt the calculations after it has chosen its * + ! preliminary value of hmag, and just before choosing htrial * + ! and xtrial in preparation for taking a step (htrial may * + ! differ from hmag in sign, and may require adjustment if * + ! xend is near) - the subroutine returns with ind = 4, and * + ! will resume calculation at the point of interruption if * + ! re-entered with ind = 4 * + ! * + ! c(9) interrupt number 2 - if not zero, the subroutine will * + ! interrupt the calculations immediately after it has * + ! decided whether or not to accept the result of the most * + ! recent trial step, with ind = 5 if it plans to accept, or * + ! ind = 6 if it plans to reject - y(*) is the previously * + ! accepted result, while w(*,9) is the newly computed trial * + ! value, and w(*,2) is the unweighted error estimate vector. * + ! the subroutine will resume calculations at the point of * + ! interruption on re-entry with ind = 5 or 6. (the user may * + ! change ind in this case if he wishes, for example to force * + ! acceptance of a step that would otherwise be rejected, or * + ! vice versa. he can also restart with ind = 1 or 2.) * + ! * + !*********************************************************************** + ! * + ! summary of the components of the communications vector * + ! * + ! prescribed at the option determined by the program * + ! of the user * + ! * + ! c(10) rreb(rel roundoff err bnd) * + ! c(1) error control indicator c(11) dwarf (very small mach no) * + ! c(2) floor value c(12) weighted norm y * + ! c(3) hmin specification c(13) hmin * + ! c(4) hstart specification c(14) hmag * + ! c(5) scale specification c(15) scale * + ! c(6) hmax specification c(16) hmax * + ! c(7) max no of fcn evals c(17) xtrial * + ! c(8) interrupt no 1 c(18) htrial * + ! c(9) interrupt no 2 c(19) est * + ! c(20) previous xend * + ! c(21) flag for xend * + ! c(22) no of successful steps * + ! c(23) no of successive failures * + ! c(24) no of fcn evals * + ! * + ! if c(1) = 4 or 5, c(31), c(32), ... c(n+30) are floor values * + ! * + !*********************************************************************** + ! * + ! an overview of the program * + ! * + ! begin initialization, parameter checking, interrupt re-entries * + ! ......abort if ind out of range 1 to 6 * + ! . cases - initial entry, normal re-entry, interrupt re-entries * + ! . case 1 - initial entry (ind .eq. 1 or 2) * + ! v........abort if n.gt.nw or tol.le.0 * + ! . if initial entry without options (ind .eq. 1) * + ! . set c(1) to c(9) equal to zero * + ! . else initial entry with options (ind .eq. 2) * + ! . make c(1) to c(9) non-negative * + ! . make floor values non-negative if they are to be used * + ! . end if * + ! . initialize rreb, dwarf, prev xend, flag, counts * + ! . case 2 - normal re-entry (ind .eq. 3) * + ! .........abort if xend reached, and either x changed or xend not * + ! . re-initialize flag * + ! . case 3 - re-entry following an interrupt (ind .eq. 4 to 6) * + ! v transfer control to the appropriate re-entry point....... * + ! . end cases . * + ! . end initialization, etc. . * + ! . v * + ! . loop through the following 4 stages, once for each trial step . * + ! . stage 1 - prepare . * + !***********error return (with ind=-1) if no of fcn evals too great . * + ! . calc slope (adding 1 to no of fcn evals) if ind .ne. 6 . * + ! . calc hmin, scale, hmax . * + !***********error return (with ind=-2) if hmin .gt. hmax . * + ! . calc preliminary hmag . * + !***********interrupt no 1 (with ind=4) if requested.......re-entry.v * + ! . calc hmag, xtrial and htrial . * + ! . end stage 1 . * + ! v stage 2 - calc ytrial (adding 7 to no of fcn evals) . * + ! . stage 3 - calc the error estimate . * + ! . stage 4 - make decisions . * + ! . set ind=5 if step acceptable, else set ind=6 . * + !***********interrupt no 2 if requested....................re-entry.v * + ! . if step accepted (ind .eq. 5) * + ! . update x, y from xtrial, ytrial * + ! . add 1 to no of successful steps * + ! . set no of successive failures to zero * + !**************return(with ind=3, xend saved, flag set) if x .eq. xend * + ! . else step not accepted (ind .eq. 6) * + ! . add 1 to no of successive failures * + !**************error return (with ind=-3) if hmag .le. hmin * + ! . end if * + ! . end stage 4 * + ! . end loop * + ! . * + ! begin abort action * + ! output appropriate message about stopping the calculations, * + ! along with values of ind, n, nw, tol, hmin, hmax, x, xend, * + ! previous xend, no of successful steps, no of successive * + ! failures, no of fcn evals, and the components of y * + ! stop * + ! end abort action * + ! * + !*********************************************************************** + ! + ! ****************************************************************** + ! * begin initialization, parameter checking, interrupt re-entries * + ! ****************************************************************** + ! + ! ......abort if ind out of range 1 to 6 + if (ind.lt.1 .or. ind.gt.6) go to 500 + ! + ! cases - initial entry, normal re-entry, interrupt re-entries + go to (5, 5, 45, 1111, 2222, 2222), ind + ! case 1 - initial entry (ind .eq. 1 or 2) + ! .........abort if n.gt.nw or tol.le.0 + 5 if (n.gt.nw .or. tol.le.0._kp) go to 500 + if (ind.eq. 2) go to 15 + ! initial entry without options (ind .eq. 1) + ! set c(1) to c(9) equal to 0 + do 10 k = 1, 9 + c(k) = 0._kp + 10 continue + go to 35 + 15 continue + ! initial entry with options (ind .eq. 2) + ! make c(1) to c(9) non-negative + do 20 k = 1, 9 + c(k) = abs(c(k)) + 20 continue + ! make floor values non-negative if they are to be used + if (c(1).ne.4._kp .and. c(1).ne.5._kp) go to 30 + do 25 k = 1, n + c(k+30) = abs(c(k+30)) + 25 continue + 30 continue + 35 continue + ! initialize rreb, dwarf, prev xend, flag, counts + c(10) = 2._kp**(-56) + c(11) = 1.d-35 + ! set previous xend initially to initial value of x + c(20) = x + do 40 k = 21, 24 + c(k) = 0._kp + 40 continue + go to 50 + ! case 2 - normal re-entry (ind .eq. 3) + ! .........abort if xend reached, and either x changed or xend not + 45 if (c(21).ne.0._kp .and. & + (x.ne.c(20) .or. xend.eq.c(20))) go to 500 + ! re-initialize flag + c(21) = 0._kp + go to 50 + ! case 3 - re-entry following an interrupt (ind .eq. 4 to 6) + ! transfer control to the appropriate re-entry point.......... + ! this has already been handled by the computed go to . + ! end cases v + 50 continue + ! + ! end initialization, etc. + ! + ! ****************************************************************** + ! * loop through the following 4 stages, once for each trial step * + ! * until the occurrence of one of the following * + ! * (a) the normal return (with ind .eq. 3) on reaching xend in * + ! * stage 4 * + ! * (b) an error return (with ind .lt. 0) in stage 1 or stage 4 * + ! * (c) an interrupt return (with ind .eq. 4, 5 or 6), if * + ! * requested, in stage 1 or stage 4 * + ! ****************************************************************** + ! + 99999 continue + ! + ! *************************************************************** + ! * stage 1 - prepare - do calculations of hmin, hmax, etc., * + ! * and some parameter checking, and end up with suitable * + ! * values of hmag, xtrial and htrial in preparation for taking * + ! * an integration step. * + ! *************************************************************** + ! + !***********error return (with ind=-1) if no of fcn evals too great + if (c(7).eq.0._kp .or. c(24).lt.c(7)) go to 100 + ind = -1 + return + 100 continue + ! + ! calculate slope (adding 1 to no of fcn evals) if ind .ne. 6 + if (ind .eq. 6) go to 105 + !EXTRADATA call fcn(n, x, y, w(1,1)) + if (present(extradata)) extradata%check=.true. + call fcn(n, x, y, w(1,1),extradata) + if (present(extradata)) then + if (extradata%update) xend = extradata%xend + extradata%check=.false. + endif + !END EXTRADATA + c(24) = c(24) + 1._kp + 105 continue + ! + ! calculate hmin - use default unless value prescribed + c(13) = c(3) + if (c(3) .ne. 0._kp) go to 165 + ! calculate default value of hmin + ! first calculate weighted norm y - c(12) - as specified + ! by the error control indicator c(1) + temp = 0._kp + if (c(1) .ne. 1._kp) go to 115 + ! absolute error control - weights are 1 + do 110 k = 1, n + temp = max(temp, abs(y(k))) + 110 continue + c(12) = temp + go to 160 + 115 if (c(1) .ne. 2._kp) go to 120 + ! relative error control - weights are 1/abs(y(k)) so + ! weighted norm y is 1 + c(12) = 1._kp + go to 160 + 120 if (c(1) .ne. 3._kp) go to 130 + ! weights are 1/max(c(2),abs(y(k))) + do 125 k = 1, n + temp = max(temp, abs(y(k))/c(2)) + 125 continue + c(12) = min(temp, 1._kp) + go to 160 + 130 if (c(1) .ne. 4._kp) go to 140 + ! weights are 1/max(c(k+30),abs(y(k))) + do 135 k = 1, n + temp = max(temp, abs(y(k))/c(k+30)) + 135 continue + c(12) = min(temp, 1._kp) + go to 160 + 140 if (c(1) .ne. 5._kp) go to 150 + ! weights are 1/c(k+30) + do 145 k = 1, n + temp = max(temp, abs(y(k))/c(k+30)) + 145 continue + c(12) = temp + go to 160 + 150 continue + ! default case - weights are 1/max(1,abs(y(k))) + do 155 k = 1, n + temp = max(temp, abs(y(k))) + 155 continue + c(12) = min(temp, 1._kp) + 160 continue + c(13) = 10._kp*max(c(11),c(10)*max(c(12)/tol,abs(x))) + 165 continue + ! + ! calculate scale - use default unless value prescribed + c(15) = c(5) + if (c(5) .eq. 0._kp) c(15) = 1._kp + ! + ! calculate hmax - consider 4 cases + ! case 1 both hmax and scale prescribed + if (c(6).ne.0._kp .and. c(5).ne.0._kp) & + c(16) = min(c(6), 2._kp/c(5)) + ! case 2 - hmax prescribed, but scale not + if (c(6).ne.0._kp .and. c(5).eq.0._kp) c(16) = c(6) + ! case 3 - hmax not prescribed, but scale is + if (c(6).eq.0._kp .and. c(5).ne.0._kp) c(16) = 2._kp/c(5) + ! case 4 - neither hmax nor scale is provided + if (c(6).eq.0._kp .and. c(5).eq.0._kp) c(16) = 2._kp + ! + !***********error return (with ind=-2) if hmin .gt. hmax + if (c(13) .le. c(16)) go to 170 + ind = -2 + return + 170 continue + ! + ! calculate preliminary hmag - consider 3 cases + if (ind .gt. 2) go to 175 + ! case 1 - initial entry - use prescribed value of hstart, if + ! any, else default + c(14) = c(4) + if (c(4) .eq. 0._kp) c(14) = c(16)*tol**(1./6.) + go to 185 + 175 if (c(23) .gt. 1._kp) go to 180 + ! case 2 - after a successful step, or at most one failure, + ! use min(2, .9*(tol/est)**(1/6))*hmag, but avoid possible + ! overflow. then avoid reduction by more than half. + temp = 2._kp*c(14) + if (tol .lt. (2._kp/.9_kp)**6*c(19)) & + temp = .9_kp*(tol/c(19))**(1./6.)*c(14) + c(14) = max(temp, .5_kp*c(14)) + go to 185 + 180 continue + ! case 3 - after two or more successive failures + c(14) = .5_kp*c(14) + 185 continue + ! + ! check against hmax + c(14) = min(c(14), c(16)) + ! + ! check against hmin + c(14) = max(c(14), c(13)) + ! + !***********interrupt no 1 (with ind=4) if requested + if (c(8) .eq. 0._kp) go to 1111 + ind = 4 + return + ! resume here on re-entry with ind .eq. 4 ........re-entry.. + 1111 continue + ! + ! calculate hmag, xtrial - depending on preliminary hmag, xend + if (c(14) .ge. abs(xend - x)) go to 190 + ! do not step more than half way to xend + c(14) = min(c(14), .5_kp*abs(xend - x)) + c(17) = x + sign(c(14), xend - x) + go to 195 + 190 continue + ! hit xend exactly + c(14) = abs(xend - x) + c(17) = xend + 195 continue + ! + ! calculate htrial + c(18) = c(17) - x + ! + ! end stage 1 + ! + ! *************************************************************** + ! * stage 2 - calculate ytrial (adding 7 to no of fcn evals). * + ! * w(*,2), ... w(*,8) hold intermediate results needed in * + ! * stage 3. w(*,9) is temporary storage until finally it holds * + ! * ytrial. * + ! *************************************************************** + ! + temp = c(18)/1398169080000._kp + ! + do 200 k = 1, n + w(k,9) = y(k) + temp*w(k,1)*233028180000._kp + 200 continue + call fcn(n, x + c(18)/6._kp, w(1,9), w(1,2),extradata) + ! + do 205 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*74569017600._kp & + + w(k,2)*298276070400._kp ) + 205 continue + call fcn(n, x + c(18)*(4._kp/15._kp), w(1,9), w(1,3),extradata) + ! + do 210 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*1165140900000._kp & + - w(k,2)*3728450880000._kp & + + w(k,3)*3495422700000._kp ) + 210 continue + call fcn(n, x + c(18)*(2._kp/3._kp), w(1,9), w(1,4),extradata) + ! + do 215 k = 1, n + w(k,9) = y(k) + temp*( - w(k,1)*3604654659375._kp & + + w(k,2)*12816549900000._kp & + - w(k,3)*9284716546875._kp & + + w(k,4)*1237962206250._kp ) + 215 continue + call fcn(n, x + c(18)*(5._kp/6._kp), w(1,9), w(1,5),extradata) + ! + do 220 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*3355605792000._kp & + - w(k,2)*11185352640000._kp & + + w(k,3)*9172628850000._kp & + - w(k,4)*427218330000._kp & + + w(k,5)*482505408000._kp ) + 220 continue + call fcn(n, x + c(18), w(1,9), w(1,6),extradata) + ! + do 225 k = 1, n + w(k,9) = y(k) + temp*( - w(k,1)*770204740536._kp & + + w(k,2)*2311639545600._kp & + - w(k,3)*1322092233000._kp & + - w(k,4)*453006781920._kp & + + w(k,5)*326875481856._kp ) + 225 continue + call fcn(n, x + c(18)/15._kp, w(1,9), w(1,7),extradata) + ! + do 230 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*2845924389000._kp & + - w(k,2)*9754668000000._kp & + + w(k,3)*7897110375000._kp & + - w(k,4)*192082660000._kp & + + w(k,5)*400298976000._kp & + + w(k,7)*201586000000._kp ) + 230 continue + call fcn(n, x + c(18), w(1,9), w(1,8),extradata) + ! + ! calculate ytrial, the extrapolated approximation and store + ! in w(*,9) + do 235 k = 1, n + w(k,9) = y(k) + temp*( w(k,1)*104862681000._kp & + + w(k,3)*545186250000._kp & + + w(k,4)*446637345000._kp & + + w(k,5)*188806464000._kp & + + w(k,7)*15076875000._kp & + + w(k,8)*97599465000._kp ) + 235 continue + ! + ! add 7 to the no of fcn evals + c(24) = c(24) + 7._kp + ! + ! end stage 2 + ! + ! *************************************************************** + ! * stage 3 - calculate the error estimate est. first calculate * + ! * the unweighted absolute error estimate vector (per unit * + ! * step) for the unextrapolated approximation and store it in * + ! * w(*,2). then calculate the weighted max norm of w(*,2) as * + ! * specified by the error control indicator c(1). finally, * + ! * modify this result to produce est, the error estimate (per * + ! * unit step) for the extrapolated approximation ytrial. * + ! *************************************************************** + ! + ! calculate the unweighted absolute error estimate vector + do 300 k = 1, n + w(k,2) = ( w(k,1)*8738556750._kp & + + w(k,3)*9735468750._kp & + - w(k,4)*9709507500._kp & + + w(k,5)*8582112000._kp & + + w(k,6)*95329710000._kp & + - w(k,7)*15076875000._kp & + - w(k,8)*97599465000._kp)/1398169080000._kp + 300 continue + ! + ! calculate the weighted max norm of w(*,2) as specified by + ! the error control indicator c(1) + temp = 0._kp + if (c(1) .ne. 1._kp) go to 310 + ! absolute error control + do 305 k = 1, n + temp = max(temp,abs(w(k,2))) + 305 continue + go to 360 + 310 if (c(1) .ne. 2._kp) go to 320 + ! relative error control + do 315 k = 1, n + temp = max(temp, abs(w(k,2)/y(k))) + 315 continue + go to 360 + 320 if (c(1) .ne. 3._kp) go to 330 + ! weights are 1/max(c(2),abs(y(k))) + do 325 k = 1, n + temp = max(temp, abs(w(k,2)) & + / max(c(2), abs(y(k))) ) + 325 continue + go to 360 + 330 if (c(1) .ne. 4._kp) go to 340 + ! weights are 1/max(c(k+30),abs(y(k))) + do 335 k = 1, n + temp = max(temp, abs(w(k,2)) & + / max(c(k+30), abs(y(k))) ) + 335 continue + go to 360 + 340 if (c(1) .ne. 5._kp) go to 350 + ! weights are 1/c(k+30) + do 345 k = 1, n + temp = max(temp, abs(w(k,2)/c(k+30))) + 345 continue + go to 360 + 350 continue + ! default case - weights are 1/max(1,abs(y(k))) + do 355 k = 1, n + temp = max(temp, abs(w(k,2)) & + / max(1._kp, abs(y(k))) ) + 355 continue + 360 continue + ! + ! calculate est - (the weighted max norm of w(*,2))*hmag*scale + ! - est is intended to be a measure of the error per unit + ! step in ytrial + c(19) = temp*c(14)*c(15) + ! + ! end stage 3 + ! + ! *************************************************************** + ! * stage 4 - make decisions. * + ! *************************************************************** + ! + ! set ind=5 if step acceptable, else set ind=6 + ind = 5 + if (c(19) .gt. tol) ind = 6 + ! + !***********interrupt no 2 if requested + if (c(9) .eq. 0._kp) go to 2222 + return + ! resume here on re-entry with ind .eq. 5 or 6 ...re-entry.. + 2222 continue + ! + if (ind .eq. 6) go to 410 + ! step accepted (ind .eq. 5), so update x, y from xtrial, + ! ytrial, add 1 to the no of successful steps, and set + ! the no of successive failures to zero + x = c(17) + do 400 k = 1, n + y(k) = w(k,9) + 400 continue + c(22) = c(22) + 1._kp + c(23) = 0._kp + !**************return(with ind=3, xend saved, flag set) if x .eq. xend + if (x .ne. xend) go to 405 + ind = 3 + c(20) = xend + c(21) = 1._kp + return + 405 continue + go to 420 + 410 continue + ! step not accepted (ind .eq. 6), so add 1 to the no of + ! successive failures + c(23) = c(23) + 1._kp + !**************error return (with ind=-3) if hmag .le. hmin + if (c(14) .gt. c(13)) go to 415 + ind = -3 + return + 415 continue + 420 continue + ! + ! end stage 4 + ! + go to 99999 + ! end loop + ! + ! begin abort action + 500 continue + write(6,*)'Computation stopped in dverk with' + write(6,*)'ind= tol= ',ind,tol + write(6,*)'x= n= ',x,n + write(6,*)'c(13)= xend= ',c(13),xend + write(6,*)'nw= c(16)= c(20)= ',nw, c(16),c(20) + write(6,*)'c(22)= c(23)= c(24)= ',c(22),c(23),c(24) + write(6,*)'y(:)= ',y + ! write(6,*) ind, tol, x, n, c(13), xend, nw, c(16), c(20), & + ! c(22), c(23), c(24), (y(k), k = 1, n) + ! 505 format( /// 1h0, 58hcomputation stopped in dverk with the following values - / 1h0, 5hind =, i4, 5x, 6htol =, 1pd13.6, 5x, 11hx =,& + ! 1pd22.15& + ! / 1h , 5hn =, i4, 5x, 6hhmin =, 1pd13.6, 5x, 11hxend =,& + ! 1pd22.15& + ! / 1h , 5hnw =, i4, 5x, 6hhmax =, 1pd13.6, 5x, 11hprev xend =,& + ! 1pd22.15& + ! / 1h0, 14x, 27hno of successful steps =, 0pf8.0& + ! / 1h , 14x, 27hno of successive failures =, 0pf8.0& + ! / 1h , 14x, 27hno of function evals =, 0pf8.0& + ! / 1h0, 23hthe components of y are& + ! // (1h , 1p5d24.15) ) + ! + stop + ! + ! end abort action + ! + end subroutine dverk + + + + + + + function zbrent(func,x1,x2,tol,extradata) + INTEGER ITMAX + real(kp) zbrent,tol,x1,x2,EPS + type(transfert) :: extradata + + !real(kp) :: func + ! EXTERNAL func + PARAMETER (ITMAX=1000,EPS=1d-15) + INTEGER iter + real(kp) a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm + + integer, parameter :: iexmax = 1000 + real(kp), parameter :: tolExpand = 1e-2 + integer :: iex + logical :: notbracketed + + interface + function func(x,otherdata) + use infprec, only : kp,transfert + implicit none + real(kp) :: func + real(kp) :: x + type(transfert), optional, intent(inout) :: otherdata + end function func + end interface + + notbracketed = .true. + iex = 0 + + a=x1 + b=x2 + + do while (notbracketed.and.(iex.lt.iexmax)) + fa=func(a,extradata) + fb=func(b,extradata) + if((fa.gt.0..and.fb.gt.0.).or.(fa.lt.0..and.fb.lt.0.)) then + write(*,*)'x1= fa= ',a,fa + write(*,*)'x2= fb= ',b,fb + write(*,*)'zbrent: expanding interval!' + a = a - abs(a)*tolExpand + b = b + abs(b)*tolExpand + iex = iex + 1 + notbracketed = .true. + else + notbracketed = .false. + endif + enddo + + if (notbracketed) stop 'root must be bracketed for zbrent' + + c=b + fc=fb + do iter=1,ITMAX + if((fb.gt.0..and.fc.gt.0.).or.(fb.lt.0..and.fc.lt.0.))then + c=a + fc=fa + d=b-a + e=d + endif + if(abs(fc).lt.abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2.*EPS*abs(b)+0.5*tol + xm=.5*(c-b) + if(abs(xm).le.tol1 .or. fb.eq.0.)then + zbrent=b + return + endif + if(abs(e).ge.tol1 .and. abs(fa).gt.abs(fb)) then + s=fb/fa + if(a.eq.c) then + p=2.*xm*s + q=1.-s + else + q=fa/fc + r=fb/fc + p=s*(2.*xm*q*(q-r)-(b-a)*(r-1.)) + q=(q-1.)*(r-1.)*(s-1.) + endif + if(p.gt.0.) q=-q + p=abs(p) + if(2.*p .lt. min(3.*xm*q-abs(tol1*q),abs(e*q))) then + e=d + d=p/q + else + d=xm + e=d + endif + else + d=xm + e=d + endif + a=b + fa=fb + if(abs(d) .gt. tol1) then + b=b+d + else + b=b+sign(tol1,xm) + endif + fb=func(b,extradata) + enddo + stop 'zbrent exceeding maximum iterations' + zbrent=b + return + end function zbrent + + + + + + + + end module inftools + + diff -r -c -b -N cosmomc/camb/inftools.h cosmomc_fields/camb/inftools.h *** cosmomc/camb/inftools.h 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/inftools.h 2006-04-14 19:40:52.000000000 +0200 *************** *** 0 **** --- 1,11 ---- + interface + subroutine fcn(n, x, y, yprime, otherdata) + use infprec, only : kp,transfert + implicit none + integer :: n + real(kp) :: x + real(kp), dimension(n) :: y, yprime + type(transfert), optional, intent(inout) :: otherdata + end subroutine fcn + end interface + diff -r -c -b -N cosmomc/camb/inftorad.f90 cosmomc_fields/camb/inftorad.f90 *** cosmomc/camb/inftorad.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/inftorad.f90 2009-04-24 14:35:24.593023030 +0200 *************** *** 0 **** --- 1,426 ---- + module inftorad + use infprec, only : kp + use infbgmodel, only : fieldNum + use infbg, only : infbgphys + implicit none + + private + + + !we use this everywhere + type inftoradcosmo + real(kp) :: bfoldIni + real(kp) :: bfoldEnd + real(kp) :: efoldEndToToday + real(kp) :: lnEnergyEnd + type(infbgphys) :: bgIni + type(infbgphys) :: bgEnd + end type inftoradcosmo + + + !for debugging, physical quantities at hubble exit + type infhubblexit + real(kp) :: kmpc + real(kp) :: bfold + real(kp) :: hubble + real(kp) :: epsilon1 + real(kp) :: epsilon1JF + end type infhubblexit + + + !for debugging + logical, parameter :: display = .false. + logical, parameter :: dump_file = .false. + + + !some physical constants + real(kp), parameter :: scaleFactorToday = 1._kp + ! ln[1Mpc/sqrt(8pi)/lPl] = 130.282 + + real(kp), parameter :: ln_mpc_to_kappaeff = 130.282_kp + + public inftoradcosmo + public scaleFactorToday, ln_mpc_to_kappaeff + + public set_inftorad_cosmo, bfold_hubble_fraction + + + !for test + public infhubblexit, hubble_splinexit + + contains + + + + + + function set_inftorad_cosmo(bgIni,bgEnd,lnReheat,inferror) + use infbg, only : infbgdata, infbgphys + use infbg, only : matter_energy_density, matter_energy_density_JF + use infbgspline, only : set_infbg_spline + implicit none + + type(inftoradcosmo) :: set_inftorad_cosmo + + type(infbgphys), intent(in) :: bgIni + type(infbgphys), intent(in) :: bgEnd + + !ln(aend/areh) + (1/4)ln(rhoend/rhoreh). This is the deviations + !expected from either instantaneous reheating or radiation dominated + !like reheating + real(kp), intent(in) :: lnReheat + + !useful for setting hard prior + integer, optional :: inferror + + !rho at the end of inflation + real(kp) :: lnEnergyEndInf + + !bound on lnReheat + real(kp) :: lnReheatMin, lnReheatMax + + !kappaeff^4 x rhonuc with rhonuc~1MeV + !energyNuc = 2.9d-82 + real(kp), parameter :: lnEnergyNuc = -187.747 + + real(kp), dimension(fieldNum) :: velocityEnd, fieldEnd + + fieldEnd = bgEnd%field + velocityEnd = bgEnd%fieldDot*bgEnd%hubble + + !if epsilon1=1 at the end of inflation, it should be Hend^2/3 (for one + !field models) + + lnEnergyEndInf = log(matter_energy_density(fieldEnd,velocityEnd)) + + !comes from -1/3 rhonuc + + lnReheatMax = (1._kp/12._kp)* (-lnEnergyNuc) & + - (1._kp/3._kp) * (-lnEnergyEndInf) + + lnReheatMin = - (1._kp/4._kp)* (-lnEnergyNuc) + + + set_inftorad_cosmo%lnEnergyEnd = lnEnergyEndInf + set_inftorad_cosmo%bfoldIni = bgIni%efold - bgEnd%efold + set_inftorad_cosmo%bfoldEnd = 0._kp + + set_inftorad_cosmo%efoldEndToToday = - ln_scale_factor_scale_inv(lnEnergyEndInf) & + - lnReheat + + !TODELETE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! set_inftorad_cosmo%efoldEndToToday = 60._kp + ! write(*,*)'efoldEndToToday fixed to: ',set_inftorad_cosmo%efoldEndToToday + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + set_inftorad_cosmo%bgIni = bgIni + set_inftorad_cosmo%bgEnd = bgEnd + + + !hard priors: inflation should occur at energy scale higher than bbn, + !as well as reheating + if (lnEnergyEndInf.le.lnEnergyNuc) then + write(*,*)'set_inftorad_cosmo: inflation till bbn (111)' + if (display) then + write(*,*)'lnEnergyEndInf = ',lnEnergyEndInf + write(*,*)'lnEnergyNucSynth = ',lnEnergyNuc + endif + if (present(inferror)) then + inferror = 111 + return + else + stop + endif + endif + + if (lnReheat.gt.lnReheatMax) then + write(*,*)'set_inftorad_cosmo: higher reheating limit reached (w=1 rho=bbn) (222)' + write(*,*)'lnReheat = ',lnReheat + write(*,*)'lnReheatMax= ',lnReheatMax + if (present(inferror)) then + inferror = 112 + return + else + stop + endif + endif + + if (lnReheat.lt.lnReheatMin) then + write(*,*)'set_inftorad_cosmo: lower reheating limit reached (w=-1/3 rho=bbn) (333)' + write(*,*)'lnReheat = ',lnReheat + write(*,*)'lnReheatMin = ',lnReheatMin + if (present(inferror)) then + inferror = 113 + return + else + stop + endif + endif + + + if (display) then + write(*,*)'--------------- set_inftorad_cosmo ---------------' + write(*,*) + write(*,*)'a0 = ',scaleFactorToday + write(*,*)'bfoldIni = ',set_inftorad_cosmo%bfoldIni + write(*,*)'bfoldEnd = ',set_inftorad_cosmo%bfoldEnd + write(*,*)'efoldIni = ',set_inftorad_cosmo%bgIni%efold + write(*,*)'efoldEnd = ',set_inftorad_cosmo%bgEnd%efold + write(*,*)'lnReheatMin = ',lnReheatMin + write(*,*)'lnReheat = ',lnReheat + write(*,*)'lnReheatMax = ',lnReheatMax + write(*,*)'efoldEndToToday = ',set_inftorad_cosmo%efoldEndToToday + write(*,*)'ln[1Mpc/kappaeff] = ',ln_mpc_to_kappaeff + write(*,*) + write(*,*)'fieldEnd = ',set_inftorad_cosmo%bgEnd%field + write(*,*) + write(*,*)'energyEnd^1/2 = ',exp(0.5*set_inftorad_cosmo%lnEnergyEnd) + write(*,*)'hubbleEnd.3^1/2 = ',sqrt(3.)*set_inftorad_cosmo%bgEnd%hubble + write(*,*) + write(*,*)'-------------------------------------------------' + endif + + + end function set_inftorad_cosmo + + + + + function ln_scale_factor_eq() + !this is a rough approximation of the physical scale factor at the end + !of inflation. Assumes instantenous reheating and + !instantenous transitions, all in unit of kappa = sqrt(8pi)/Mpl. The + !input is supposed to be the energy transfered after inflation to the + !"matter sector", in our case this is the energy density of the + !matter field at the end of inflation. This assumes pure GR after + !the end of inflation. + + implicit none + + real(kp) :: ln_scale_factor_eq + + real(kp), parameter :: HubbleSquareRootOf2OmegaRad = 8.00d-63 !x kappaendinf(#kappatoday) + + + !this is: 1/4 ln(rhoeq) + ln(aeq/a0) + ! = (1/4) ln(rhoeq) - ln(1+zeq) + ! = -(1/4) ln(2/3) + (1/2) ln[Heq/(1+zeq)^2] + ! where used has been made of: rhoeq = (3/2) Heq^2 (in kappa unit) + ! + ! Heq/(1+zeq)^2 = sqrt(2 Omega0) H0 / sqrt(1+zeq) + ! 1+zeq = Omega0/OmegaRadiation0 <---- photons + neutrinos + ! H0 = 100h km/s/Mpc = 1.74717d-61 Mpl + ! There is no dependency in h and Omega0 in Heq/(1+zeq)^2 = sqrt(2 OmegaRad0) H0 (x kappatoday) + + ln_scale_factor_eq = log(scaleFactorToday) & + + 0.5_kp*log(HubbleSquareRootOf2OmegaRad) & + - 0.25_kp*log(2._kp/3._kp) + + end function ln_scale_factor_eq + + + + + + function ln_scale_factor_scale_inv(lnEnergyEndInf) + !in that case we have: + ! ln(aend/a0) = + ! ln(aend/areh) - 1/4 ln(rhoreh) + 1/2 ln(rhoend) <--lnReheat + ! + ln(aeq/a0) + 1/4 ln(rhoeq) - 1/2 ln(rhoend) <-- ln_scale_inv + + implicit none + real(kp), intent(in) :: lnEnergyEndInf + real(kp) :: ln_scale_factor_scale_inv + + + ln_scale_factor_scale_inv = ln_scale_factor_eq() - 0.5_kp*lnEnergyEndInf + + end function ln_scale_factor_scale_inv + + + + + + + function ln_scale_factor_radreheat(lnEnergyEndInf) + !this is a rough approximation of the physical scale factor at the end + !of inflation. Assumes instantenous reheating and + !instantenous transitions, all in unit of kappa = sqrt(8pi)/Mpl. The + !input is supposed to be the energy transfered after inflation to the + !"matter sector", in our case this is the energy density of the + !matter field at the end of inflation. This assumes pure GR after + !the end of inflation. + + implicit none + + real(kp), intent(in) :: lnEnergyEndInf + real(kp) :: ln_scale_factor_radreheat + + ! ln(aend/a0) = ln(aend/areh) + ln(areh/aeq) + ln(aeq/a0) + ! ~ (1/4) ln(rhoeq/rhoend) - ln(1+zeq) + ! = -(1/4) ln(2rhoend/3) + (1/2) ln[Heq/(1+zeq)^2] + ! where used has been made of: rhoeq = (3/2) Heq^2 (in kappa unit) + ! + ! Heq/(1+zeq)^2 = sqrt(2 Omega0) H0 / sqrt(1+zeq) + ! 1+zeq = Omega0/OmegaRadiation0 <---- photons + neutrinos + ! H0 = 100h km/s/Mpc = 1.74717d-61 Mpl + ! There is no dependency in h and Omega0 in Heq/(1+zeq)^2 = sqrt(2 OmegaRad0) H0 (x kappatoday) + + ln_scale_factor_radreheat = ln_scale_factor_eq() - 0.25_kp*lnEnergyEndInf + + end function ln_scale_factor_radreheat + + + + + function ln_scale_factor_corr_radreheat(lnEnergyEndInf,lnEnergyEndReh,wreh) + !Correction from a rad-like reheating period which expands as a P=wre + !rho cosmo fluid: + + ! ln(aend/areh) + (1/4) ln(rhoend/rhoreheat) = (1/4) x + ! (w-1/3)/(w+1) x ln(rhoend/rhoreheat) + + implicit none + + real(kp), intent(in) :: lnEnergyEndInf, lnEnergyEndReh, wreh + real(kp) :: ln_scale_factor_corr_radreheat + + ln_scale_factor_corr_radreheat = 0.25 * (wreh - 1./3.)/(wreh + 1) & + * (lnEnergyEndInf - lnEnergyEndReh) + + end function ln_scale_factor_corr_radreheat + + + + + + function bfold_plus_ln_hubble(bfold,cosmoData) + !returns N + ln[H(N)] - cosmoData%real1, required by zeros finder subroutine: + !zbrent + use infprec, only : transfert + use infbgspline, only : splineval_hubble_parameter + implicit none + + type(transfert), optional, intent(inout) :: cosmoData + real(kp), intent(in) :: bfold + real(kp) :: bfold_plus_ln_hubble + + real(kp) :: hubble + + hubble = splineval_hubble_parameter(bfold) + + bfold_plus_ln_hubble = bfold + log(hubble) - cosmoData%real1 + + ! print *,'bfold',bfold,bfold_plus_ln_hubble,cosmoData%real1 + ! print *,'hubble^2',hubble**2 + + end function bfold_plus_ln_hubble + + + + + + + function bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubble,inferror) + !return the bfold at which k/aH = kphysOverHubble + use inftools, only : zbrent + use infprec, only : transfert + implicit none + real(kp), intent(in) :: kmpc + real(kp), intent(inout) :: kphysOverHubble + type(inftoradcosmo), intent(in) :: infCosmo + real(kp) :: bfold_hubble_fraction + + !hard prior if quantum ic cannot be set + integer, optional :: inferror + + type(transfert) :: cosmoData + real(kp), parameter :: tolBfold = 1e-6 + real(kp) :: bfoldSign + + + cosmoData%real1 = log(kmpc) + infCosmo%efoldEndToToday - ln_mpc_to_kappaeff & + - log(kphysOverHubble) + + bfoldSign = bfold_plus_ln_hubble(infCosmo%bfoldIni,cosmoData) + + if (bfoldSign.ge.0d0) then + write(*,*)'no crossing found (444) for mode k = ',kmpc, 'at k/aH = ' & + ,kphysOverHubble + write(*,*)'bfoldIni = ',infCosmo%bfoldIni + if (present(inferror)) then + inferror = 222 + return + else + if (bfoldSign.lt.log(kphysOverHubble)) then + write(*,*)'setting initial condition at bfoldIni' + write(*,*)'ln(k/aH) = ', -bfoldSign + log(kphysOverHubble) + kphysOverHubble = exp(-bfoldSign) * kphysOverHubble + bfold_hubble_fraction = infCosmo%bfoldIni + return + else + stop + endif + endif + endif + + bfold_hubble_fraction = zbrent(bfold_plus_ln_hubble,infCosmo%bfoldIni & + , infCosmo%bfoldEnd ,tolBfold, cosmoData) + + + end function bfold_hubble_fraction + + + + + function hubble_splinexit(infCosmo,kmpc) + !spline evaluation of physical quantities at hubble exit (k/aH=1) for the mode kmpc + use infinout + use infbgspline, only : splineval_hubble_parameter + use infbgspline, only : splineval_epsilon1 + use infbgspline, only : splineval_epsilon1JF + implicit none + + real(kp), intent(in) :: kmpc + type(infhubblexit) :: hubble_splinexit + type(inftoradcosmo) :: infCosmo + real(kp) :: bfoldExit, hubbleExit + real(kp) :: epsilon1Exit, epsilon1JFExit + real(kp) :: kphysOverHubbleExit + real(kp) :: pi + + pi = acos(-1._kp) + kphysOverHubbleExit = 1._kp + + bfoldExit = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleExit) + hubbleExit = splineval_hubble_parameter(bfoldExit) + epsilon1Exit = splineval_epsilon1(bfoldExit) + epsilon1JFExit = splineval_epsilon1JF(bfoldExit) + + if (display) then + !this is the tensor spectrum, up to a negligeable relaxation after Hubble exit + write(*,*) + write(*,*)'kmpc = ',kmpc + write(*,*)'hubble crossing at bfold = ',bfoldExit + write(*,*)'2(Hk/pi)^2 = ',(2._kp/pi/pi)*hubbleExit**2 + write(*,*)'epsilon1 = ',epsilon1Exit + write(*,*)'epsilon1JF = ',epsilon1JFExit + write(*,*) + endif + + if (dump_file) then + call livewrite('hubblexit.dat',kmpc,(2._kp/pi/pi)*hubbleExit**2) + call livewrite('epsilonexit.dat',kmpc,epsilon1Exit,epsilon1JFExit) + call livewrite('bfoldexit.dat',kmpc,bfoldExit) + endif + + hubble_splinexit%kmpc = kmpc + hubble_splinexit%bfold = bfoldExit + hubble_splinexit%hubble = hubbleExit + hubble_splinexit%epsilon1 = epsilon1Exit + hubble_splinexit%epsilon1 = epsilon1JFExit + + end function hubble_splinexit + + + end module inftorad diff -r -c -b -N cosmomc/camb/inidriver.F90 cosmomc_fields/camb/inidriver.F90 *** cosmomc/camb/inidriver.F90 2008-09-16 18:04:28.000000000 +0200 --- cosmomc_fields/camb/inidriver.F90 2009-10-28 13:11:52.120022132 +0100 *************** *** 297,302 **** --- 297,306 ---- call CAMB_cleanup + !fields + call FreePowers(P%InitPower) + !end fields + end program driver diff -r -c -b -N cosmomc/camb/Makefile cosmomc_fields/camb/Makefile *** cosmomc/camb/Makefile 2009-10-22 15:59:31.000000000 +0200 --- cosmomc_fields/camb/Makefile 2009-10-28 15:46:44.084255766 +0100 *************** *** 1,69 **** ! #CAMB Makefile ! #Edit for your compiler ! #Note there are many ifc versions, some of which behave oddly ! #Intel , -openmp toggles mutli-processor: ! #note version 10.0 gives wrong result for lensed when compiled with -openmp [fixed in 10.1] ! F90C = ifort ! FFLAGS = -openmp -O2 -ip -W0 -WB -fpp2 -vec_report0 ! ! # Intel 9 on IA-64 (eg. COSMOS) ! # (do "module load icomp90" before compiling) ! #F90C = ifort ! #FFLAGS = -openmp -fpp2 -w -O3 -ip -mP2OPT_hlo_prefetch=F ! ! #Intel ifc, add -openmp for multi-processor (some have bugs): ! #F90C = ifc ! #FFLAGS = -O2 -Vaxlib -ip -W0 -WB -quiet -fpp2 ! #some systems can can also add e.g. -tpp7 -xW ! ! #G95 compiler ! #F90C = g95 ! #FFLAGS = -O2 ! ! #Gfortran compiler: if pre v4.3 add -D__GFORTRAN__ ! #F90C = gfc ! #FFLAGS = -O2 ! ! #SGI, -mp toggles multi-processor. Use -O2 if -Ofast gives problems. ! #F90C = f90 ! #FFLAGS = -Ofast -mp ! ! #Digital/Compaq fortran, -omp toggles multi-processor ! #F90C = f90 ! #FFLAGS = -omp -O4 -arch host -math_library fast -tune host -fpe1 ! ! #Absoft ProFortran, single processor: ! #F90C = f95 ! #FFLAGS = -O2 -cpu:athlon -s -lU77 -w -YEXT_NAMES="LCS" -YEXT_SFX="_" ! ! #NAGF95, single processor: ! #F90C = f95 ! #FFLAGS = -DNAGF95 -O3 ! ! #PGF90 ! #F90C = pgf90 ! #FFLAGS = -O2 -DESCAPEBACKSLASH ! ! #Sun V880 ! #F90C = mpf90 ! #FFLAGS = -O4 -openmp -ftrap=%none -dalign -DMPI ! ! #Sun parallel enterprise: ! #F90C = f95 ! #FFLAGS = -O2 -xarch=native64 -openmp -ftrap=%none ! #try removing -openmp if get bus errors. -03, -04 etc are dodgy. ! ! #IBM XL Fortran, multi-processor (run gmake) ! #F90C = xlf90_r ! #FFLAGS = -DESCAPEBACKSLASH -DIBMXL -qsmp=omp -qsuffix=f=f90:cpp=F90 -O3 -qstrict -qarch=pwr3 -qtune=pwr3 #Settings for building camb_fits #Location of FITSIO and name of library ! FITSDIR = /home/cpac/cpac-tools/lib FITSLIB = cfitsio #Location of HEALPIX for building camb_fits ! HEALPIXDIR = /home/cpac/cpac-tools/healpix - include ./Makefile_main \ No newline at end of file --- 1,109 ---- ! # >>> DESIGNED FOR GMAKE <<< ! #CAMB System unified Makefile ! ext=$(shell uname | cut -c1-3) ! ifeq ($(ext),IRI) ! F90C=f90 ! FFLAGS = -Ofast=ip35 -n32 ! endif ! ! ifeq ($(ext),Lin) ! F90C=gfortran ! FFLAGS= -O -fopenmp #-D__GFORTRAN__ ! endif ! ! ifeq ($(ext),OSF) ! F90C=f90 ! FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1 ! endif ! ! ifeq ($(ext),Sun) ! F90C=f90 ! FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none ! endif ! ! ifeq ($(ext),AIX) ! F90C=xlf90_r ! FFLAGS= -O4 -q64 -qsmp=omp -qmaxmem=-1 -qstrict -qfree=f90 -qsuffix=f=f90:cpp=F90 ! endif ! ! ! #Files containing evolution equations initial power spectrum module ! EQUATIONS = equations ! POWERSPECTRUM = power_inf ! REIONIZATION = reionization ! RECOMBINATION = recfast ! ! #inf module ! INFOBJ = infprec.o binfspline.o specialinf.o infinout.o inftools.o infbgmodel.o infsrmodel.o infbg.o infbgspline.o inftorad.o infpert.o infpowspline.o ! ! #Module doing non-linear scaling ! NONLINEAR = halofit ! ! #Driver program ! DRIVER = inidriver.F90 ! #DRIVER = sigma8.f90 ! #DRIVER = tester.f90 #Settings for building camb_fits #Location of FITSIO and name of library ! FITSDIR = /usr FITSLIB = cfitsio #Location of HEALPIX for building camb_fits ! HEALPIXDIR = /usr ! ! CAMBLIB = libcamb.a ! INFLIB = libinf.a ! ! #Shouldn't need to change anything else... ! ! F90FLAGS = $(FFLAGS) ! HEALPIXLD = -L$(HEALPIXDIR)/lib -lhealpix -L$(FITSDIR) -l$(FITSLIB) ! FC = $(F90C) ! ! CAMBOBJ = constants.o utils.o subroutines.o inifile.o $(POWERSPECTRUM).o\ ! $(RECOMBINATION).o $(REIONIZATION).o modules.o \ ! bessels.o $(EQUATIONS).o $(NONLINEAR).o lensing.o cmbmain.o camb.o ! ! ! default: camb.$(ext) ! ! all: camb.$(ext) $(CAMBLIB) $(INFLIB) ! ! ! subroutines.o: constants.o utils.o ! $(POWERSPECTRUM): subroutines.o inifile.o ! $(RECOMBINATION).o: subroutines.o inifile.o ! $(REIONIZATION).o: constants.o inifile.o ! modules.o: $(REIONIZATION).o ! bessels.o: modules.o ! $(EQUATIONS): bessels.o ! $(NONLINEAR).o: modules.o ! lensing.o: bessels.o ! cmbmain.o: lensing.o ! camb.o: cmbmain.o ! ! ! camb.$(ext): $(INFOBJ) $(CAMBOBJ) $(DRIVER) ! $(F90C) $(F90FLAGS) $(INFOBJ) $(CAMBOBJ) $(DRIVER) -o $@ ! ! $(CAMBLIB): $(CAMBOBJ) ! ar -r $@ $? ! ! $(INFLIB): $(INFOBJ) ! ar -r $@ $? ! ! camb_fits.$(ext): writefits.f90 $(CAMBOBJ) $(DRIVER) ! $(F90C) $(F90FLAGS) -I$(HEALPIXDIR)/include $(CAMBOBJ) writefits.f90 $(DRIVER) $(HEALPIXLD) -DWRITE_FITS -o $@ ! ! %.o: %.f90 ! $(F90C) $(F90FLAGS) -c $*.f90 ! ! utils.o: ! $(F90C) $(F90FLAGS) -c utils.F90 ! ! clean: ! -rm -f *.o *.a *.d core *.mod ! diff -r -c -b -N cosmomc/camb/Makefile~ cosmomc_fields/camb/Makefile~ *** cosmomc/camb/Makefile~ 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/Makefile~ 2009-10-28 13:16:48.436523807 +0100 *************** *** 0 **** --- 1,109 ---- + # >>> DESIGNED FOR GMAKE <<< + #CAMB System unified Makefile + + ext=$(shell uname | cut -c1-3) + + ifeq ($(ext),IRI) + F90C=f90 + FFLAGS = -Ofast=ip35 -n32 + endif + + ifeq ($(ext),Lin) + F90C=ifort + FFLAGS= -O -openmp #-D__GFORTRAN__ + endif + + ifeq ($(ext),OSF) + F90C=f90 + FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1 + endif + + ifeq ($(ext),Sun) + F90C=f90 + FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none + endif + + ifeq ($(ext),AIX) + F90C=xlf90_r + FFLAGS= -O4 -q64 -qsmp=omp -qmaxmem=-1 -qstrict -qfree=f90 -qsuffix=f=f90:cpp=F90 + endif + + + #Files containing evolution equations initial power spectrum module + EQUATIONS = equations + POWERSPECTRUM = power_inf + REIONIZATION = reionization + RECOMBINATION = recfast + + #inf module + INFOBJ = infprec.o binfspline.o specialinf.o infinout.o inftools.o infbgmodel.o infsrmodel.o infbg.o infbgspline.o inftorad.o infpert.o infpowspline.o + + #Module doing non-linear scaling + NONLINEAR = halofit + + #Driver program + DRIVER = inidriver.F90 + #DRIVER = sigma8.f90 + #DRIVER = tester.f90 + + #Settings for building camb_fits + #Location of FITSIO and name of library + FITSDIR = /usr + FITSLIB = cfitsio + #Location of HEALPIX for building camb_fits + HEALPIXDIR = /usr + + CAMBLIB = libcamb.a + INFLIB = libinf.a + + #Shouldn't need to change anything else... + + F90FLAGS = $(FFLAGS) + HEALPIXLD = -L$(HEALPIXDIR)/lib -lhealpix -L$(FITSDIR) -l$(FITSLIB) + FC = $(F90C) + + CAMBOBJ = constants.o utils.o subroutines.o inifile.o $(POWERSPECTRUM).o\ + $(RECOMBINATION).o $(REIONIZATION).o modules.o \ + bessels.o $(EQUATIONS).o $(NONLINEAR).o lensing.o cmbmain.o camb.o + + + default: camb.$(ext) + + all: camb.$(ext) $(CAMBLIB) $(INFLIB) + + + subroutines.o: constants.o utils.o + $(POWERSPECTRUM): subroutines.o inifile.o + $(RECOMBINATION).o: subroutines.o inifile.o + $(REIONIZATION).o: constants.o inifile.o + modules.o: $(REIONIZATION).o + bessels.o: modules.o + $(EQUATIONS): bessels.o + $(NONLINEAR).o: modules.o + lensing.o: bessels.o + cmbmain.o: lensing.o + camb.o: cmbmain.o + + + camb.$(ext): $(INFOBJ) $(CAMBOBJ) $(DRIVER) + $(F90C) $(F90FLAGS) $(INFOBJ) $(CAMBOBJ) $(DRIVER) -o $@ + + $(CAMBLIB): $(CAMBOBJ) + ar -r $@ $? + + $(INFLIB): $(INFOBJ) + ar -r $@ $? + + camb_fits.$(ext): writefits.f90 $(CAMBOBJ) $(DRIVER) + $(F90C) $(F90FLAGS) -I$(HEALPIXDIR)/include $(CAMBOBJ) writefits.f90 $(DRIVER) $(HEALPIXLD) -DWRITE_FITS -o $@ + + %.o: %.f90 + $(F90C) $(F90FLAGS) -c $*.f90 + + utils.o: + $(F90C) $(F90FLAGS) -c utils.F90 + + clean: + -rm -f *.o *.a *.d core *.mod + + diff -r -c -b -N cosmomc/camb/params.ini cosmomc_fields/camb/params.ini *** cosmomc/camb/params.ini 2008-03-26 15:24:18.000000000 +0100 --- cosmomc_fields/camb/params.ini 2009-10-28 13:17:25.556264076 +0100 *************** *** 1,12 **** #Parameters for CAMB #output_root is prefixed to output file names ! output_root = test #What to do get_scalar_cls = T get_vector_cls = F ! get_tensor_cls = F get_transfer = F #if do_lensing then scalar_output_file contains additional columns of l^4 C_l^{pp} and l^3 C_l^{pT} --- 1,12 ---- #Parameters for CAMB #output_root is prefixed to output file names ! output_root = fields #What to do get_scalar_cls = T get_vector_cls = F ! get_tensor_cls = T get_transfer = F #if do_lensing then scalar_output_file contains additional columns of l^4 C_l^{pp} and l^3 C_l^{pT} *************** *** 63,81 **** #Fraction of total omega_nu h^2 accounted for by each eigenstate, eg. 0.5 0.5 nu_mass_fractions = 1 - #Initial power spectrum, amplitude, spectral index and running. Pivot k in Mpc^{-1}. - initial_power_num = 1 - pivot_scalar = 0.05 - pivot_tensor = 0.05 - scalar_amp(1) = 2.3e-9 - scalar_spectral_index(1) = 1 - scalar_nrun(1) = 0 - tensor_spectral_index(1) = 0 - #ratio is that of the initial tens/scal power spectrum amplitudes - initial_ratio(1) = 1 - #note vector modes use the scalar settings above - - #Reionization, ignored unless reionization = T, re_redshift measures where x_e=0.5 reionization = T --- 63,68 ---- *************** *** 96,101 **** --- 83,145 ---- RECFAST_Heswitch = 6 + #inflationary model parameters (see infbgmodel.f90) + #param(1)=M; param(2)=p; param(3)=nu; param(4)=mu, param(5)=q + #largef: V = M^4 phi^p p > 0 + #smallf: V = M^4 [1 - (phi/mu)^p] p > 2 + #hybrid: V = M^4 [1 + (phi/mu)^p] + #runmas: V = M^4 {1 + nu [1/p + ln(phi/mu)]phi^p} + #kklmmt: V = M^4 [1 - q (phi/mu)^-p]^q p > 0; q=+-1 + + #number of read parameters + inf_param_number = 7 + + #should be consistent with the above defs + inf_model_name = largef + inf_param(1) = 1 + inf_param(2) = 2 + inf_param(3) = 0 + inf_param(4) = 0 + inf_param(5) = 1 + + + #Hard prior that reject models with field values greater that + #field_bound. May be used for keeping models out of the + #self-reproducing regime, or constrain the branes to be inside the + #throat. In unit of kappa + inf_check_bound = F + inf_param(6) = 0 + + + #stops artificially inflation for this matter field value. Unit of + #kappa for large field and running mass; unit of mu for small fields + #and kklmmt; unit of a maximal field value that gives 120 efolds of + #hybrid inflation + inf_check_stop = F + inf_param(7) = 0 + + #initial fields value. Unit of kappa for large field and running; unit + #of mu for small field, hybrid and kklmmt. For inf_matter = 0, uses + #a slow-roll approximation to guess the relevant values + inf_conform(1) = 1 + inf_matter(1) = 0 + + #This is ln(aend/areh) - 1/4 ln(rhoreh kappa^4) + 1/2 ln(rhoend kappa^4) + inf_ln_reheat = 0 + + + #speed up A LOT the computations (only for featureless power spectra) + power_spectra_spline = T + + #if false then every k required are computed from their quantum birth + #during the inflationary era. Otherwise, only a few of them are + #computed and the others interpolated. The following parameters set + #the range and number (ln=log base e) + spline_lnkmpc_min = -14 + spline_lnkmpc_max = 0 + spline_lnkmpc_num = 12 + + #Initial scalar perturbation mode (adiabatic=1, CDM iso=2, Baryon iso=3, # neutrino density iso =4, neutrino velocity iso = 5) initial_condition = 1 diff -r -c -b -N cosmomc/camb/power_inf.f90 cosmomc_fields/camb/power_inf.f90 *** cosmomc/camb/power_inf.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/power_inf.f90 2009-04-24 17:02:35.222397157 +0200 *************** *** 0 **** --- 1,946 ---- + !This module provides the initial power spectra, computed from the inflationary module + + module InitialPower + use precision, only : dl + use infprec, only : kp + use infbgmodel, only : infbgparam + use infbg, only : infbgphys, infbgdata + use inftorad, only : inftoradcosmo + + implicit none + + private + + logical, parameter :: display=.true. + + character(LEN=*), parameter :: Power_Name = 'power_inf' + integer, parameter :: nnmax= 1 + + !mind that for mcmc + logical, parameter :: checkStopDefault = .false. + logical, parameter :: checkBoundDefault = .false. + logical, parameter :: useSplineDefault = .true. + + + type InitialPowerParams + integer :: nn + integer :: bgParamNum + logical :: checkStop + logical :: checkBound + logical :: useSpline + integer :: lnkmpcNum + real(kp) :: lnkmpcMax, lnkmpcMin + real(kp) :: lnReheat + real(kp) :: kstar + type(infbgparam) :: infParam + end type InitialPowerParams + + + type InitialPowerData + type(initialpowerparams) :: initP + type(infbgphys) :: infIni + type(infbgphys) :: infObs + type(infbgphys) :: infEnd + type(inftoradcosmo) :: infCosmo + type(infbgdata), pointer :: ptrBgdata => null() + end type InitialPowerData + + + type ExportInfProp + real(kp) :: lnEnergyEnd + real(kp) :: efoldEndToToday + end type ExportInfProp + + + real(dl) :: curv !Curvature contant, set in InitializePowers + + + + type(InitialPowerData), save :: powerD + + + + + interface operator (==) + module procedure inipowerparams_equal + end interface + + interface operator (/=) + module procedure inipowerparams_unequal + end interface + + private operator(==),operator(/=) + + public nnmax + public SetInfBg, SetInfBgSpline, SetInfCosmo, SetInfScalPow + public InitializePowers, FreePowers, ScalarPower, TensorPower + public InitialPowerParams,Power_Descript, Power_Name, SetDefPowerParams + + public exportinfprop, UpdateInfProp + + public InitialPower_ReadParams + + contains + + + + + + function inipowerparams_equal(PinA, PinB) + use infbgmodel, only : operator(==) + implicit none + type(initialpowerparams), intent(in) :: PinA, PinB + logical :: inipowerparams_equal + + inipowerparams_equal = ((PinA%infParam == PinB%infParam) & + .and. (PinA%lnReheat == PinB%lnReheat) & + .and. (PinA%nn == PinB%nn) & + .and. (PinA%bgParamNum == PinB%bgParamNum) & + .and. (PinA%checkStop .eqv. PinB%checkStop) & + .and. (PinA%checkBound .eqv. PinB%checkBound) & + .and. (PinA%useSpline .eqv. PinB%useSpline) & + .and. (PinA%lnkmpcNum == PinB%lnkmpcNum) & + .and. (PinA%lnkmpcMax == PinB%lnkmpcMax) & + .and. (PinA%lnkmpcMin == PinB%lnkmpcMin)) + + end function inipowerparams_equal + + + + + function inipowerparams_unequal(PinA, PinB) + implicit none + type(initialpowerparams), intent(in) :: PinA, PinB + logical :: inipowerparams_unequal + + inipowerparams_unequal = .not.(inipowerparams_equal(PinA,PinB)) + + end function inipowerparams_unequal + + + + + subroutine UpdateInfProp(export) + implicit none + type(exportinfprop), intent(out) :: export + + export%lnEnergyEnd = powerD%infCosmo%lnEnergyEnd + export%efoldEndToToday = powerD%infCosmo%efoldEndToToday + + end subroutine UpdateInfProp + + + + + + subroutine SetDefPowerParams(Pin) + use infbgmodel, only : fieldNum, dilatonNum + use infbgmodel, only : matterParamNum, dilatonParamNum + use infbgmodel, only : infParamNum + implicit none + type (InitialPowerParams), intent(out) :: Pin + + Pin%nn = 1 + + Pin%bgParamNum = matterParamNum + dilatonParamNum + + !stop inflation according to field values + Pin%checkStop = checkStopDefault + + !impose hard prior from theoretical bounds on field values + Pin%checkBound = checkBoundDefault + + !range and sampling of the power spectra spline + Pin%useSpline = useSplineDefault + Pin%lnkmpcMin = -14. + Pin%lnkmpcMax = 0. + Pin%lnkmpcNum = 12 + + Pin%lnReheat = 0. + Pin%kstar = 0.05 + + !value for the parameters (see infbg.f90) + Pin%infParam%name = 'largef' + Pin%infParam%consts(1:infParamNum) = 0. + Pin%infParam%conforms(1:dilatonNum) = 1. + + Pin%infParam%consts(1) = 1e-5 + Pin%infParam%consts(2) = 2. + Pin%infParam%consts(3:4) = 0. + Pin%infParam%consts(5) = 1. + + if (infParamNum.gt.5) then + Pin%infParam%consts(6:infParamNum) = 0. + endif + + end subroutine SetDefPowerParams + + + + + subroutine InitializePowers(Pin,acurv,wantScalars,wantTensors) + implicit none + + type (initialpowerparams) :: Pin + !Called before computing final Cls in cmbmain.f90 + !Could read spectra from disk here, do other processing, etc. + real(dl) :: acurv + logical, optional, intent(in) :: wantScalars, wantTensors + integer :: inferror + logical, parameter :: usePstar=.false. + real(kp), parameter :: Pstar = 1._kp + + inferror = 0 + + if (Pin%nn > nnmax) then + stop 'can only used one initial power spectrum' + end if + curv=acurv + + if (curv.ne.0d0) stop 'flat universe only' + + !one background for all k (that's why nnmax=1) + ! print *,'we are in initialize power',(Pin%infParam == powerD%initP%infParam) & + ! ,(Pin%infParam /= powerD%initP%infParam) + + call SetInfBg(Pin,inferror) + if (inferror.ne.0) stop 'InitializePowers: unproper infbg' + + if (usePstar) then + !this is only for playing with normalised power spectra to Pstar. + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'InitializePower: renormalising P(k*) to Pstar=',Pstar + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + read(*,*) + call SetInfScalPow(Pin,Pstar) + endif + + call SetInfBgSpline(Pin) + + call SetInfCosmo(Pin,inferror) + if (inferror.ne.0) stop 'InitializePowers: unproper inftorad' + + end subroutine InitializePowers + + + + + subroutine SetInfBg(Pin,inferror) + use infbgmodel, only : operator(==) + use infbgmodel, only : set_infbg_param, matterNum + use infsrmodel, only : field_stopinf + use infbg, only : operator(==) + use infbg, only : set_infbg_ini, bg_field_evol + implicit none + + type (initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + logical :: areTryParamsOk, areInfIniOk, isThBoundOk + logical :: areParamsSet + integer, parameter :: infbgPoints = 1000 + type(initialpowerparams) :: Pstack + real(kp), dimension(2) :: fieldStop + logical :: stopAtMax + + ! print *,'Pin',Pin + if (associated(powerD%ptrBgdata)) then + if (Pin%infParam == powerD%initP%infParam) then + if (display) then + write(*,*)'SetInfBg: same infbg params' + write(*,*)'Pin%infParam= ',Pin%infParam + endif + return + else + if (display) then + write(*,*)'SetInfBg: new infbgparams' + write(*,*)'Pin%infParam= ',Pin%infParam + endif + Pstack = powerD%initP + call FreePowers(Pstack) + endif + endif + + !hard prior tests on the parameters + areTryParamsOk = HardPriorAcceptParam(Pin%infParam,inferror) + if (.not.areTryParamsOk) then + if (present(inferror)) write(*,*)'SetInfBg: inferror ',inferror + return + endif + + + !update powerD%initP according to Pin (may be modified in) + areParamsSet = set_infbg_param(Pin%infParam) + powerD%initP = Pin + if (.not.(areParamsSet)) then + stop 'SetInfBg: params initialisation failed!' + endif + + powerD%infIni = set_infbg_ini(Pin%infParam) + + + + !hard prior tests on the initial field values + areInfIniOk = HardPriorAcceptInfIni(powerD%infIni,inferror) + if (.not.areInfIniOk) then + if (present(inferror)) write(*,*)'SetInfBg: inferror ',inferror + powerD%infEnd = powerD%infIni + return + endif + + + + !hard prior tests for theoretical bound on initial field values + if (powerD%initP%checkBound) then + + isThBoundOk = HardPriorInThBound(powerD%initP%infParam & + ,powerD%infIni,inferror) + + if (.not.isThBoundOk) then + powerD%infEnd = powerD%infIni + if (present(inferror)) write(*,*)'SetInfBg: inferror ',inferror + return + endif + + endif + + + if (powerD%initP%checkStop) then + fieldStop = field_stopinf(powerD%initP%infParam) + if (fieldStop(2).gt.0._kp) then + stopAtMax = .true. + else + stopAtMax = .false. + endif + + powerD%infEnd = bg_field_evol(powerD%infIni,infbgPoints & + ,powerD%infObs,powerD%ptrBgdata,fieldStop(1),stopAtMax) + else + + powerD%infEnd = bg_field_evol(powerD%infIni,infbgPoints & + ,powerD%infObs,powerD%ptrBgdata) + + endif + + !last hard prior: the number of efolds is not enough + if (powerD%infEnd == powerD%infIni) then + if (display) write(*,*)'SetInfBg: infEnd = infIni (4444)' + if (present(inferror)) inferror = 4444 + return + endif + + + end subroutine SetInfBg + + + + function HardPriorAcceptParam(infParam,inferror) + use infbgmodel, only : matterParamNum + implicit none + logical :: HardPriorAcceptParam + type(infbgparam), intent(in) :: infParam + integer, optional :: inferror + + HardPriorAcceptParam = .true. + + !if during mcmc, consts(4)=0 is unprobably tested (singular for this value) + if (infParam%name=='runmas') then + if (infParam%consts(4).eq.0._kp) then + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)'HardPriorAcceptParam: infParam%consts(4)=0 (1111)' + write(*,*)'for running mass model!' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + if (present(inferror)) inferror = 1111 + HardPriorAcceptParam=.false. + endif + endif + + if (infParam%name=='kklmmt') then + if (infParam%consts(matterParamNum).lt.infParam%consts(3)) then + write(*,*)'HardPriorAcceptParam: MatterString < mu (1112)' + if (present(inferror)) inferror = 1112 + HardPriorAcceptParam=.false. + endif + endif + + + end function HardPriorAcceptParam + + + + function HardPriorAcceptInfIni(infIni,inferror) + implicit none + logical :: HardPriorAcceptInfIni + type(infbgphys), intent(in) :: infIni + integer, optional :: inferror + + HardPriorAcceptInfIni=.true. + + if (infIni%epsilon1.gt.1._kp) then + if (display) write(*,*) 'HardPriorAcceptInfIni: epsilon1 > 1 (2222) ' + if (present(inferror)) inferror = 2222 + HardPriorAcceptInfIni = .false. + endif + + end function HardPriorAcceptInfIni + + + + + function HardPriorInThBound(infParam,infIni,inferror) + use infbgmodel, only : matterNum + use infsrmodel, only : field_thbound + implicit none + logical :: HardPriorInThBound + type(infbgparam), intent(in) :: infParam + type(infbgphys), intent(in) :: infIni + integer, optional :: inferror + + real(kp), dimension(2) :: fieldBound + + HardPriorInThBound = .true. + + fieldBound = field_thbound(infParam) + if (fieldBound(2).gt.0._kp) then + HardPriorInThBound = (maxval(infIni%field(1:matterNum)) & + .lt.fieldBound(1)) + else + HardPriorInThBound = (minval(infIni%field(1:matterNum)) & + .lt.fieldBound(1)) + endif + + if (.not.HardPriorInthBound) then + if (display) write(*,*) 'HardPriorInThBound: bound violated (3333)' + if (present(inferror)) inferror = 3333 + endif + + end function HardPriorInThBound + + + + + subroutine SetInfBgSpline(Pin) + use infbgmodel, only : operator(==) + use infbgspline, only : set_infbg_spline,check_infbg_spline + implicit none + + type (initialpowerparams), intent(in) :: Pin + + if (check_infbg_spline()) return + + !sanity checks + if (Pin%infParam == powerD%initP%infParam) then + call set_infbg_spline(powerD%infEnd,powerD%ptrBgdata) + else + stop 'SetInfBgSpline: Pin%params >< Data params' + endif + + end subroutine SetInfBgSpline + + + + + + subroutine FreeInfBgSpline(Pin) + use infbgmodel, only : operator(==) + use infbgspline, only : free_infbg_spline, check_infbg_spline + implicit none + + type (initialpowerparams), intent(in) :: Pin + + if (.not. check_infbg_spline()) return + + !sanity checks + if (Pin%infParam == powerD%initP%infParam) then + call free_infbg_spline() + else + stop 'FreeInfBgSpline: Pin%params >< Data params' + endif + + end subroutine FreeInfBgSpline + + + + + + subroutine FreeInfBgData(Pin) + use infbgmodel, only : operator(==) + use infbg, only : free_infbg_data + implicit none + + type (initialpowerparams), intent(in) :: Pin + + if (.not.associated(powerD%ptrBgdata)) stop 'FreeInfBgData: no bgdata found!' + + !sanity checks + if (Pin%infParam == powerD%initP%infParam) then + call free_infbg_data(powerD%ptrBgdata) + else + stop 'FreeInfBgData: Pin%params >< Data params' + endif + + end subroutine FreeInfBgData + + + + + + subroutine SetInfCosmo(Pin,inferror) + use infbgmodel, only : operator(/=) + use inftorad, only : set_inftorad_cosmo + use infpowspline, only : check_power_scal_spline, check_power_tens_spline + + implicit none + + type (initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + !sanity checks + if (Pin%infParam /= powerD%initP%infParam) then + stop 'SetInfCosmo: Pin%params >< Data params' + endif + + + if (Pin /= powerD%initP) then + if (Pin%useSpline) call FreePowSpline(Pin) + if (display) then + write(*,*)'SetInfCosmo: new inftorad params' + write(*,*)'lnReheat = ',Pin%lnReheat + endif + powerD%initP = Pin + else + if (display) then + write(*,*)'SetInfCosmo: same inftorad params' + write(*,*)'lnReheat = ',Pin%lnReheat + endif + endif + + powerD%infCosmo = set_inftorad_cosmo(powerD%infObs,powerD%infEnd & + ,powerD%InitP%lnReheat,inferror) + + if (present(inferror)) then + if (inferror.ne.0) return + endif + + if (Pin%useSpline) then + call SetScalPowSpline(Pin,inferror) + call SetTensPowSpline(Pin,inferror) + endif + + end subroutine SetInfCosmo + + + + + + subroutine SetTensPowSpline(Pin,inferror) + use inftorad, only : bfold_hubble_fraction + use infpowspline, only : set_power_tens_spline + use infpowspline, only : check_power_tens_spline + implicit none + type(initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcKnots + + if (check_power_tens_spline()) return + + call IniPowSpline(Pin,lnkmpcKnots,inferror) + + if (present(inferror)) then + if (inferror.ne.0) return + endif + + call set_power_tens_spline(powerD%infCosmo,lnkmpcKnots) + + ! if (present(inferror)) inferror = 0 + + end subroutine SetTensPowSpline + + + + + + subroutine SetScalPowSpline(Pin,inferror) + use infpowspline, only : set_power_scal_spline + use infpowspline, only : check_power_scal_spline + implicit none + type(initialpowerparams), intent(in) :: Pin + integer, optional :: inferror + + real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcKnots + + if (check_power_scal_spline()) return + + call IniPowSpline(Pin,lnkmpcKnots,inferror) + + if (present(inferror)) then + if (inferror.ne.0) return + endif + + call set_power_scal_spline(powerD%infCosmo,lnkmpcKnots) + + end subroutine SetScalPowSpline + + + + + + + subroutine IniPowSpline(Pin,lnkmpcVec,inferror) + use inftorad, only : bfold_hubble_fraction + implicit none + type(initialpowerparams), intent(in) :: Pin + real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcVec + integer, optional :: inferror + + integer :: i + real(kp) :: kmpcMin, bfoldSmallest + real(kp) :: kphysOverHubbleInit + + kphysOverHubbleInit = 100._kp + + !sanity checks + if (.not.associated(powerD%ptrBgdata)) then + stop 'SetInfPowSpline: no InfBg found, call SetInfBg before!' + else + if (Pin /= powerD%initP) then + write(*,*)'SetInfPowSpline: Pin >< Data' + stop + endif + endif + if (.not.Pin%useSpline) stop 'SetInfPowSpline: useSpline is F' + + do i=1,powerD%initP%lnkmpcNum + lnkmpcVec(i) = powerD%initP%lnkmpcMin + real(i-1)*(powerD%initP%lnkmpcMax & + - powerD%initP%lnkmpcMin)/real(powerD%initP%lnkmpcNum-1) + enddo + + !this test that initial conditions at kphysOverHubbleInit can be set, + !or in other words that there are enough efold to do it + if (present(inferror)) then + kmpcMin = exp(powerD%InitP%lnkmpcMin) + bfoldSmallest = bfold_hubble_fraction(kmpcMin,powerD%infCosmo & + ,kphysOverHubbleInit,inferror) + endif + + end subroutine IniPowSpline + + + + + + subroutine FreePowSpline(Pin) + use infpowspline, only : check_power_scal_spline + use infpowspline, only : check_power_tens_spline + use infpowspline, only : free_power_scal_spline + use infpowspline, only : free_power_tens_spline + implicit none + type(initialpowerparams), intent(in) :: Pin + + if (Pin%useSPline) then + if (check_power_scal_spline()) call free_power_scal_spline() + if (check_power_tens_spline()) call free_power_tens_spline() + else + stop 'FreePowSpline: useSpline is false!' + endif + + end subroutine FreePowSpline + + + + + + subroutine SetInfScalPow(Pin,Pwanted) + !to normalise the scalar spectrum to Pwanted at kpivot + use infbgmodel, only : operator(/=) + use infbg, only : rescale_potential + use inftorad, only : set_inftorad_cosmo + use infpert, only : scalNum + use infpert, only : power_spectrum_scal + implicit none + + type (initialpowerparams), intent(inout) :: Pin + real(kp), intent(in) :: Pwanted + + real(kp) :: scale + real(kp) :: Pscal(scalNum,scalNum) + + integer :: ierror + + !sanity checks + if (Pin%infParam /= powerD%initP%infParam) then + stop 'SetInfScalPow: Pin%params >< Data params' + endif + + powerD%infCosmo = set_inftorad_cosmo(powerD%infObs,powerD%infEnd & + ,powerD%InitP%lnReheat,ierror) + + !the bg spline should be set to compute the power spectrum (if not + !already) TODO: not optimal at all + call SetInfBgSpline(Pin) + + Pscal = power_spectrum_scal(powerD%infCosmo,Pin%kstar) + + if (Pscal(scalNum,scalNum).ne.0.) then + scale = Pwanted/Pscal(scalNum,scalNum) + else + stop 'SetInfScalPow: Pscal = 0' + endif + + !rescale all the relevant quantities. After this call, everything + !should be as if the potential has been normalised according to Pwanted + call rescale_potential(scale,powerD%initP%infParam,powerD%infIni & + ,powerD%infEnd,powerD%infObs,powerD%ptrBgdata) + + !update the external infParam + Pin%infParam = powerD%initP%infParam + + !but the background spline is not longer up to date + call FreeInfBgSpline(Pin) + + + !for debugging only + if (display) then + write(*,*) + write(*,*)'SetInfScalPow:' + write(*,*)'Pwanted = ',Pwanted + write(*,*)'Pnow = ',Pscal(scalNum,scalNum) + call SetInfBgSpline(Pin) + powerD%infCosmo = set_inftorad_cosmo(powerD%infObs,powerD%infEnd & + ,powerD%InitP%lnReheat,ierror) + Pscal = power_spectrum_scal(powerD%infCosmo,Pin%kstar) + call FreeInfBgSpline(Pin) + write(*,*)'Pafter = ',Pscal(scalNum,scalNum) + write(*,*) + endif + + + end subroutine SetInfScalPow + + + + + + subroutine FreePowers(Pin) + use infbgmodel, only : operator(==) + implicit none + type(initialpowerparams), intent(in) :: Pin + + if (.not.associated(powerD%ptrBgdata)) then + write(*,*) 'FreePowers: powerD%ptrBgdata not associated!' + return + endif + + if (Pin%infParam == powerD%initP%infParam) then + if (display) write(*,*) 'FreePowers: freeing infbg spline' + call FreeInfBgSpline(Pin) + + if (display) write(*,*) 'FreePowers: freeing infbg data' + call FreeInfBgData(Pin) + + if (powerD%initP%useSpline) then + if (display) write(*,*) 'FreePowers: freeing powspline data' + call FreePowSpline(Pin) + endif + else + write(*,*) + write(*,*) 'FreePowers: Pin <> Data' + write(*,*) 'FreePowers: Pin%Param = ',Pin%infParam + write(*,*) 'FreePowers: Data%Param = ',powerD%initP%infParam + write(*,*) + stop + endif + + end subroutine FreePowers + + + + + + + function ScalarPower(k,in) + !"in" gives the index of the power to return for this k + !ScalarPower = const for scale invariant spectrum + !The normalization is defined so that for adiabatic perturbations the gradient of the 3-Ricci + !scalar on co-moving hypersurfaces receives power + ! < |D_a R^{(3)}|^2 > = int dk/k 16 k^6/S^6 (1-3K/k^2)^2 ScalarPower(k) + !In other words ScalarPower is the power spectrum of the conserved curvature perturbation given by + !-chi = \Phi + 2/3*\Omega^{-1} \frac{H^{-1}\Phi' - \Psi}{1+w} + !(w=p/\rho), so < |\chi(x)|^2 > = \int dk/k ScalarPower(k). + !Near the end of inflation chi is equal to 3/2 Psi. + !Here nu^2 = (k^2 + curv)/|curv| + + !This power spectrum is also used for isocurvature modes where + !< |\Delta(x)|^2 > = \int dk/k ScalarPower(k) + !For the isocurvture velocity mode ScalarPower is the power in the neutrino heat flux. + use infpert, only : power_spectrum_scal + use infpert, only : scalNum + use infpowspline, only : splineval_power_scal + implicit none + + real(kp), dimension(scalNum,scalNum) :: powerSpectrumScal + real(dl) :: ScalarPower,k + integer :: in + + if (in.ne.1) stop 'ScalarPower: only 1 Ps allowed' + + if (powerD%initP%useSpline) then + powerSpectrumScal = splineval_power_scal(k*1._kp) + else + powerSpectrumScal = power_spectrum_scal(powerD%infCosmo,k*1._kp) + endif + + ScalarPower = powerSpectrumScal(scalNum,scalNum) + + end function ScalarPower + + + + + + function TensorPower(k,in) + !TensorPower= const for scale invariant spectrum + !The normalization is defined so that + ! < h_{ij}(x) h^{ij}(x) > = \sum_nu nu /(nu^2-1) (nu^2-4)/nu^2 TensorPower(k) + !for a closed model + ! < h_{ij}(x) h^{ij}(x) > = int d nu /(nu^2+1) (nu^2+4)/nu^2 TensorPower(k) + !for an open model + !"in" gives the index of the power spectrum to return + !Here nu^2 = (k^2 + 3*curv)/|curv| + use infpert, only : power_spectrum_tens + use infpowspline, only : splineval_power_tens + implicit none + + real(dl) :: TensorPower,k + real(kp), parameter :: PiByTwo=3.14159265d0/2._kp + + integer :: in + + if (in.ne.1) stop 'TensorPower: only 1 Pt allowed' + + if (powerD%initP%useSpline) then + TensorPower = splineval_power_tens(k*1._kp) + else + TensorPower = power_spectrum_tens(powerD%infCosmo,k*1._kp) + endif + + if (curv < 0) TensorPower=TensorPower*tanh(PiByTwo*sqrt(-k**2/curv-3)) + + end function TensorPower + + + + + + + function Power_Descript(in, Scal, Tens, Keys, Vals) + !Get parameters describing parameterisation (for FITS file) + character(LEN=8), intent(out) :: Keys(*) + real(kp), intent(out) :: Vals(*) + integer, intent(IN) :: in + logical, intent(IN) :: Scal, Tens + integer num, Power_Descript + num=0 + if ((Scal).or.(Tens)) then + num=num+1 + Keys(num) = 'C1' + Vals(num) = powerD%initP%infParam%consts(1) + num=num+1 + Keys(num) = 'C2' + Vals(num) = powerD%initP%infParam%consts(2) + num=num+1 + Keys(num) = 'C3' + Vals(num) = powerD%initP%infParam%consts(3) + num=num+1 + Keys(num) = 'C4' + Vals(num) = powerD%initP%infParam%consts(4) + num=num+1 + Keys(num) = 'Conf' + Vals(num) = powerD%initP%infParam%conforms(1) + num=num+1 + Keys(num) = 'Field' + Vals(num) = powerD%initP%infParam%matters(1) + num=num+1 + Keys(num) = 'lnReheat' + Vals(num) = powerD%initP%lnReheat + num=num+1 + Keys(num) = 'HubbleEnd' + Vals(num) = powerD%infCosmo%bgEnd%hubble + num=num+1 + Keys(num) = 'EnergyEndInf' + Vals(num) = powerD%infCosmo%lnEnergyEnd + num=num+1 + Keys(num) = 'EfoldEndToToday' + Vals(num) = powerD%infCosmo%efoldEndToToday + end if + Power_Descript = num + + end function Power_Descript + + + subroutine InitialPower_ReadParams(InitPower, Ini, WantTensors) + use IniFile + !fields + use infbgmodel, only : dilatonNum, matterNum + real :: mu,nu + !end fields + + Type(InitialPowerParams) :: InitPower + Type(TIniFile) :: Ini + logical, intent(in) :: WantTensors + integer i + + !fields + + InitPower%nn = Ini_Read_Int('initial_power_num',1) + if (InitPower%nn>nnmax) stop 'Too many initial power spectra - increase nnmax in InitialPower' + InitPower%infParam%name = Ini_Read_String('inf_model_name') + InitPower%bgParamNum = Ini_Read_Int('inf_param_number',3) + + do i=1, InitPower%bgParamNum + InitPower%infParam%consts(i) & + = Ini_Read_Double_Array_File(Ini,'inf_param',i,0._dl) + end do + + do i=1,dilatonNum + InitPower%infParam%conforms(i) & + = Ini_Read_Double_Array_File(Ini,'inf_conform',i,1d0) + enddo + + do i=1,matterNum + InitPower%infParam%matters(i) & + = Ini_Read_Double_Array_File(Ini,'inf_matter',i,1d1) + enddo + + InitPower%checkBound = Ini_Read_Logical('inf_check_bound',.false.) + InitPower%checkStop = Ini_Read_Logical('inf_check_stop',.false.) + + InitPower%lnReheat = Ini_Read_Double('inf_ln_reheat',0d0) + + InitPower%useSpline = Ini_Read_Logical('power_spectra_spline',.false.) + if (InitPower%useSpline) then + InitPower%lnkmpcMin = Ini_Read_Double('spline_lnkmpc_min',-14d0) + InitPower%lnkmpcMax = Ini_Read_Double('spline_lnkmpc_max',0d0) + InitPower%lnkmpcNum = Ini_Read_Int('spline_lnkmpc_num',10) + endif + + + !convenient rescalings + ! InitPower%infParam%consts(1) = 10.**InitPower%infParam%consts(1) + ! InitPower%infParam%consts(4) = 10.**InitPower%infParam%consts(4) + mu = InitPower%infParam%consts(3) + nu = InitPower%infParam%consts(4) + if ((mu.ne.0.).and.(nu.eq.0.)) then + InitPower%infParam%matters = InitPower%infParam%matters & + *abs(mu) + endif + + !end fields + + + end subroutine InitialPower_ReadParams + + + + end module InitialPower diff -r -c -b -N cosmomc/camb/specialinf.f90 cosmomc_fields/camb/specialinf.f90 *** cosmomc/camb/specialinf.f90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/camb/specialinf.f90 2007-06-19 17:14:58.000000000 +0200 *************** *** 0 **** --- 1,522 ---- + module specialprec + use infprec, only : kp + implicit none + integer, parameter :: dp = selected_real_kind(12,60) + ! integer, parameter :: dp = kp + end module specialprec + + + module specialinf + use specialprec, only : dp,kp + implicit none + contains + + + function lambertw(x) + implicit none + real(kp) :: lambertw + real(kp), intent(in) :: x + real(kp) :: w,wTimesExpW,wPlusOneTimesExpW + real(kp), parameter :: tol=1d-15 + + !rough estimation + + if ((x.le.500._kp).and.(x.ge.0._kp)) then + w = 0.665_kp * (1._kp + 0.0195*log(x+1._kp)) & + *log(x+1._kp) + 0.04_kp + elseif (x.gt.500._kp) then + w = log(x-4._kp) - (1._kp - 1._kp/log(x)) & + *log(log(x)) + elseif (x.ge.-1._kp/exp(1._kp)) then + w=-0.5 + else + stop 'x<-1/e' + endif + + !recurrence + + do + wTimesExpW = w*exp(w) + wPlusOneTimesExpW = (w+1._kp)*exp(w) + if (tol.gt.(abs((x-wTimesExpW)/wPlusOneTimesExpW))) then + exit + else + w = w-(wTimesExpW-x) & + /(wPlusOneTimesExpW-(w+2._kp)*(wTimesExpW-x) & + /(2._kp*w+2._kp)) + endif + enddo + + lambertw = w + + end function lambertw + + + + + + + + !DECK DLI + ! Code converted using TO_F90 by Alan Miller + ! Date: 2002-02-26 Time: 16:43:57 + FUNCTION dli(x) RESULT(fn_val) + !***BEGIN PROLOGUE DLI + !***PURPOSE Compute the logarithmic integral. + !***LIBRARY SLATEC (FNLIB) + !***CATEGORY C5 + !***TYPE REAL (dp) (ALI-S, DLI-D) + !***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS + !***AUTHOR Fullerton, W., (LANL) + !***DESCRIPTION + ! DLI(X) calculates the REAL (dp) logarithmic integral + ! for REAL (dp) argument X. + !***REFERENCES (NONE) + !***ROUTINES CALLED DEI, XERMSG + !***REVISION HISTORY (YYMMDD) + ! 770701 DATE WRITTEN + ! 890531 Changed all specific intrinsics to generic. (WRB) + ! 890531 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) + !***END PROLOGUE DLI + REAL (dp), INTENT(IN) :: x + REAL (dp) :: fn_val + !***FIRST EXECUTABLE STATEMENT DLI + IF (x <= 0.d0) CALL xermsg('SLATEC', 'DLI', 'LOG INTEGRAL UNDEFINED FOR X <= 0') + IF (x == 1.d0) CALL xermsg('SLATEC', 'DLI', 'LOG INTEGRAL UNDEFINED FOR X = 0') + fn_val = dei(LOG(x)) + RETURN + END FUNCTION dli + !DECK DCSEVL + FUNCTION dcsevl(x, cs, n) RESULT(fn_val) + !***BEGIN PROLOGUE DCSEVL + !***PURPOSE Evaluate a Chebyshev series. + !***LIBRARY SLATEC (FNLIB) + !***CATEGORY C3A2 + !***TYPE REAL (dp) (CSEVL-S, DCSEVL-D) + !***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS + !***AUTHOR Fullerton, W., (LANL) + !***DESCRIPTION + ! Evaluate the N-term Chebyshev series CS at X. Adapted from + ! a method presented in the paper by Broucke referenced below. + ! Input Arguments -- + ! X value at which the series is to be evaluated. + ! CS array of N terms of a Chebyshev series. In evaluating + ! CS, only half the first coefficient is summed. + ! N number of terms in array CS. + !***REFERENCES R. Broucke, Ten subroutines for the manipulation of Chebyshev + ! series, Algorithm 446, Communications of the A.C.M. 16, + ! (1973) pp. 254-256. + ! L. Fox and I. B. Parker, Chebyshev Polynomials in Numerical + ! Analysis, Oxford University Press, 1968, page 56. + !***ROUTINES CALLED D1MACH, XERMSG + !***REVISION HISTORY (YYMMDD) + ! 770401 DATE WRITTEN + ! 890831 Modified array declarations. (WRB) + ! 890831 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) + ! 900329 Prologued revised extensively and code rewritten to allow + ! X to be slightly outside interval (-1,+1). (WRB) + ! 920501 Reformatted the REFERENCES section. (WRB) + !***END PROLOGUE DCSEVL + REAL (dp), INTENT(IN) :: x + REAL (dp), INTENT(IN) :: cs(:) + INTEGER, INTENT(IN) :: n + REAL (dp) :: fn_val + REAL (dp) :: b0, b1, b2, twox + REAL (dp), SAVE :: onepl + LOGICAL, SAVE :: first = .TRUE. + INTEGER :: i, ni + !***FIRST EXECUTABLE STATEMENT DCSEVL + IF (first) onepl = 1.0_dp + 2*EPSILON(0.0_dp) + first = .false. + IF (n < 1) CALL xermsg('SLATEC','DCSEVL', 'NUMBER OF TERMS <= 0') + IF (n > 1000) CALL xermsg('SLATEC', 'DCSEVL', 'NUMBER OF TERMS > 1000') + IF (ABS(x) > onepl) CALL xermsg('SLATEC','DCSEVL', 'X OUTSIDE THE INTERVAL (-1,+1)') + b1 = 0.0_dp + b0 = 0.0_dp + twox = 2.0_dp * x + DO i = 1, n + b2 = b1 + b1 = b0 + ni = n + 1 - i + b0 = twox * b1 - b2 + cs(ni) + END DO + fn_val = 0.5_dp * (b0-b2) + RETURN + END FUNCTION dcsevl + !DECK DE1 + FUNCTION de1(x) RESULT(fn_val) + !***BEGIN PROLOGUE DE1 + !***PURPOSE Compute the exponential integral E1(X). + !***LIBRARY SLATEC (FNLIB) + !***CATEGORY C5 + !***TYPE REAL (dp) (E1-S, DE1-D) + !***KEYWORDS E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, + ! SPECIAL FUNCTIONS + !***AUTHOR Fullerton, W., (LANL) + !***DESCRIPTION + ! DE1 calculates the REAL (dp) exponential integral, E1(X), for positive + ! REAL (dp) argument X and the Cauchy principal value for negative X. + ! If principal values are used everywhere, then, for all X, + ! E1(X) = -Ei(-X) + ! or + ! Ei(X) = -E1(-X). + ! Series for AE10 on the interval -3.12500E-02 to 0. + ! with weighted error 4.62E-32 + ! log weighted error 31.34 + ! significant figures required 29.70 + ! decimal places required 32.18 + ! Series for AE11 on the interval -1.25000E-01 to -3.12500E-02 + ! with weighted error 2.22E-32 + ! log weighted error 31.65 + ! significant figures required 30.75 + ! decimal places required 32.54 + ! Series for AE12 on the interval -2.50000E-01 to -1.25000E-01 + ! with weighted error 5.19E-32 + ! log weighted error 31.28 + ! significant figures required 30.82 + ! decimal places required 32.09 + ! Series for E11 on the interval -4.00000E+00 to -1.00000E+00 + ! with weighted error 8.49E-34 + ! log weighted error 33.07 + ! significant figures required 34.13 + ! decimal places required 33.80 + ! Series for E12 on the interval -1.00000E+00 to 1.00000E+00 + ! with weighted error 8.08E-33 + ! log weighted error 32.09 + ! approx significant figures required 30.4 + ! decimal places required 32.79 + ! Series for AE13 on the interval 2.50000E-01 to 1.00000E+00 + ! with weighted error 6.65E-32 + ! log weighted error 31.18 + ! significant figures required 30.69 + ! decimal places required 32.03 + ! Series for AE14 on the interval 0. to 2.50000E-01 + ! with weighted error 5.07E-32 + ! log weighted error 31.30 + ! significant figures required 30.40 + ! decimal places required 32.20 + !***REFERENCES (NONE) + !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG + !***REVISION HISTORY (YYMMDD) + ! 770701 DATE WRITTEN + ! 890531 Changed all specific intrinsics to generic. (WRB) + ! 891115 Modified prologue description. (WRB) + ! 891115 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) + ! 920618 Removed space from variable names. (RWC, WRB) + !***END PROLOGUE DE1 + REAL (dp), INTENT(IN) :: x + REAL (dp) :: fn_val + REAL (dp) :: eta, xmaxt + REAL (dp), SAVE :: xmax + INTEGER, SAVE :: ntae10, ntae11, ntae12, nte11, nte12, ntae13, ntae14 + LOGICAL, SAVE :: first = .TRUE. + REAL (dp), PARAMETER :: ae10cs(50) = (/ +.3284394579616699087873844201881E-1_dp, & + -.1669920452031362851476184343387E-1_dp, +.2845284724361346807424899853252E-3_dp, & + -.7563944358516206489487866938533E-5_dp, +.2798971289450859157504843180879E-6_dp, & + -.1357901828534531069525563926255E-7_dp, +.8343596202040469255856102904906E-9_dp, & + -.6370971727640248438275242988532E-10_dp, +.6007247608811861235760831561584E-11_dp, & + -.7022876174679773590750626150088E-12_dp, +.1018302673703687693096652346883E-12_dp, & + -.1761812903430880040406309966422E-13_dp, +.3250828614235360694244030353877E-14_dp, & + -.5071770025505818678824872259044E-15_dp, +.1665177387043294298172486084156E-16_dp, & + +.3166753890797514400677003536555E-16_dp, -.1588403763664141515133118343538E-16_dp, & + +.4175513256138018833003034618484E-17_dp, -.2892347749707141906710714478852E-18_dp, & + -.2800625903396608103506340589669E-18_dp, +.1322938639539270903707580023781E-18_dp, & + -.1804447444177301627283887833557E-19_dp, -.7905384086522616076291644817604E-20_dp, & + +.4435711366369570103946235838027E-20_dp, -.4264103994978120868865309206555E-21_dp, & + -.3920101766937117541553713162048E-21_dp, +.1527378051343994266343752326971E-21_dp, & + +.1024849527049372339310308783117E-22_dp, -.2134907874771433576262711405882E-22_dp, & + +.3239139475160028267061694700366E-23_dp, +.2142183762299889954762643168296E-23_dp, & + -.8234609419601018414700348082312E-24_dp, -.1524652829645809479613694401140E-24_dp, & + +.1378208282460639134668480364325E-24_dp, +.2131311202833947879523224999253E-26_dp, & + -.2012649651526484121817466763127E-25_dp, +.1995535662263358016106311782673E-26_dp, & + +.2798995808984003464948686520319E-26_dp, -.5534511845389626637640819277823E-27_dp, & + -.3884995396159968861682544026146E-27_dp, +.1121304434507359382850680354679E-27_dp, & + +.5566568152423740948256563833514E-28_dp, -.2045482929810499700448533938176E-28_dp, & + -.8453813992712336233411457493674E-29_dp, +.3565758433431291562816111116287E-29_dp, & + +.1383653872125634705539949098871E-29_dp, -.6062167864451372436584533764778E-30_dp, & + -.2447198043989313267437655119189E-30_dp, +.1006850640933998348011548180480E-30_dp, & + +.4623685555014869015664341461674E-31_dp /) + REAL (dp), PARAMETER :: ae11cs(60) = (/ +.20263150647078889499401236517381_dp, & + -.73655140991203130439536898728034E-1_dp, +.63909349118361915862753283840020E-2_dp, & + -.60797252705247911780653153363999E-3_dp, -.73706498620176629330681411493484E-4_dp, & + +.48732857449450183453464992488076E-4_dp, -.23837064840448290766588489460235E-5_dp, & + -.30518612628561521027027332246121E-5_dp, +.17050331572564559009688032992907E-6_dp, & + +.23834204527487747258601598136403E-6_dp, +.10781772556163166562596872364020E-7_dp, & + -.17955692847399102653642691446599E-7_dp, -.41284072341950457727912394640436E-8_dp, & + +.68622148588631968618346844526664E-9_dp, +.53130183120506356147602009675961E-9_dp, & + +.78796880261490694831305022893515E-10_dp, -.26261762329356522290341675271232E-10_dp, & + -.15483687636308261963125756294100E-10_dp, -.25818962377261390492802405122591E-11_dp, & + +.59542879191591072658903529959352E-12_dp, +.46451400387681525833784919321405E-12_dp, & + +.11557855023255861496288006203731E-12_dp, -.10475236870835799012317547189670E-14_dp, & + -.11896653502709004368104489260929E-13_dp, -.47749077490261778752643019349950E-14_dp, & + -.81077649615772777976249734754135E-15_dp, +.13435569250031554199376987998178E-15_dp, & + +.14134530022913106260248873881287E-15_dp, +.49451592573953173115520663232883E-16_dp, & + +.79884048480080665648858587399367E-17_dp, -.14008632188089809829248711935393E-17_dp, & + -.14814246958417372107722804001680E-17_dp, -.55826173646025601904010693937113E-18_dp, & + -.11442074542191647264783072544598E-18_dp, +.25371823879566853500524018479923E-20_dp, & + +.13205328154805359813278863389097E-19_dp, +.62930261081586809166287426789485E-20_dp, & + +.17688270424882713734999261332548E-20_dp, +.23266187985146045209674296887432E-21_dp, & + -.67803060811125233043773831844113E-22_dp, -.59440876959676373802874150531891E-22_dp, & + -.23618214531184415968532592503466E-22_dp, -.60214499724601478214168478744576E-23_dp, & + -.65517906474348299071370444144639E-24_dp, +.29388755297497724587042038699349E-24_dp, & + +.22601606200642115173215728758510E-24_dp, +.89534369245958628745091206873087E-25_dp, & + +.24015923471098457555772067457706E-25_dp, +.34118376888907172955666423043413E-26_dp, & + -.71617071694630342052355013345279E-27_dp, -.75620390659281725157928651980799E-27_dp, & + -.33774612157467324637952920780800E-27_dp, -.10479325703300941711526430332245E-27_dp, & + -.21654550252170342240854880201386E-28_dp, -.75297125745288269994689298432000E-30_dp, & + +.19103179392798935768638084000426E-29_dp, +.11492104966530338547790728833706E-29_dp, & + +.43896970582661751514410359193600E-30_dp, +.12320883239205686471647157725866E-30_dp, & + +.22220174457553175317538581162666E-31_dp /) + REAL (dp), PARAMETER :: ae12cs(41) = (/ +.63629589796747038767129887806803_dp, & + -.13081168675067634385812671121135E+0_dp, -.84367410213053930014487662129752E-2_dp, & + +.26568491531006685413029428068906E-2_dp, +.32822721781658133778792170142517E-3_dp, & + -.23783447771430248269579807851050E-4_dp, -.11439804308100055514447076797047E-4_dp, & + -.14405943433238338455239717699323E-5_dp, +.52415956651148829963772818061664E-8_dp, & + +.38407306407844323480979203059716E-7_dp, +.85880244860267195879660515759344E-8_dp, & + +.10219226625855003286339969553911E-8_dp, +.21749132323289724542821339805992E-10_dp, & + -.22090238142623144809523503811741E-10_dp, -.63457533544928753294383622208801E-11_dp, & + -.10837746566857661115340539732919E-11_dp, -.11909822872222586730262200440277E-12_dp, & + -.28438682389265590299508766008661E-14_dp, +.25080327026686769668587195487546E-14_dp, & + +.78729641528559842431597726421265E-15_dp, +.15475066347785217148484334637329E-15_dp, & + +.22575322831665075055272608197290E-16_dp, +.22233352867266608760281380836693E-17_dp, & + +.16967819563544153513464194662399E-19_dp, -.57608316255947682105310087304533E-19_dp, & + -.17591235774646878055625369408853E-19_dp, -.36286056375103174394755328682666E-20_dp, & + -.59235569797328991652558143488000E-21_dp, -.76030380926310191114429136895999E-22_dp, & + -.62547843521711763842641428479999E-23_dp, +.25483360759307648606037606400000E-24_dp, & + +.25598615731739857020168874666666E-24_dp, +.71376239357899318800207052800000E-25_dp, & + +.14703759939567568181578956800000E-25_dp, +.25105524765386733555198634666666E-26_dp, & + +.35886666387790890886583637333333E-27_dp, +.39886035156771301763317759999999E-28_dp, & + +.21763676947356220478805333333333E-29_dp, -.46146998487618942367607466666666E-30_dp, & + -.20713517877481987707153066666666E-30_dp, -.51890378563534371596970666666666E-31_dp /) + REAL (dp), PARAMETER :: e11cs(29) = (/ -.16113461655571494025720663927566180E+2_dp, & + +.77940727787426802769272245891741497E+1_dp, -.19554058188631419507127283812814491E+1_dp, & + +.37337293866277945611517190865690209E+0_dp, -.56925031910929019385263892220051166E-1_dp, & + +.72110777696600918537847724812635813E-2_dp, -.78104901449841593997715184089064148E-3_dp, & + +.73880933562621681878974881366177858E-4_dp, -.62028618758082045134358133607909712E-5_dp, & + +.46816002303176735524405823868362657E-6_dp, -.32092888533298649524072553027228719E-7_dp, & + +.20151997487404533394826262213019548E-8_dp, -.11673686816697793105356271695015419E-9_dp, & + +.62762706672039943397788748379615573E-11_dp, -.31481541672275441045246781802393600E-12_dp, & + +.14799041744493474210894472251733333E-13_dp, -.65457091583979673774263401588053333E-15_dp, & + +.27336872223137291142508012748799999E-16_dp, -.10813524349754406876721727624533333E-17_dp, & + +.40628328040434303295300348586666666E-19_dp, -.14535539358960455858914372266666666E-20_dp, & + +.49632746181648636830198442666666666E-22_dp, -.16208612696636044604866560000000000E-23_dp, & + +.50721448038607422226431999999999999E-25_dp, -.15235811133372207813973333333333333E-26_dp, & + +.44001511256103618696533333333333333E-28_dp, -.12236141945416231594666666666666666E-29_dp, & + +.32809216661066001066666666666666666E-31_dp, -.84933452268306432000000000000000000E-33_dp /) + REAL (dp), PARAMETER :: e12cs(25) = (/ -.3739021479220279511668698204827E-1_dp, & + +.4272398606220957726049179176528E-1_dp, -.130318207984970054415392055219726_dp, & + +.144191240246988907341095893982137E-1_dp, -.134617078051068022116121527983553E-2_dp, & + +.107310292530637799976115850970073E-3_dp, -.742999951611943649610283062223163E-5_dp, & + +.453773256907537139386383211511827E-6_dp, -.247641721139060131846547423802912E-7_dp, & + +.122076581374590953700228167846102E-8_dp, -.548514148064092393821357398028261E-10_dp, & + +.226362142130078799293688162377002E-11_dp, -.863589727169800979404172916282240E-13_dp, & + +.306291553669332997581032894881279E-14_dp, -.101485718855944147557128906734933E-15_dp, & + +.315482174034069877546855328426666E-17_dp, -.923604240769240954484015923200000E-19_dp, & + +.255504267970814002440435029333333E-20_dp, -.669912805684566847217882453333333E-22_dp, & + +.166925405435387319431987199999999E-23_dp, -.396254925184379641856000000000000E-25_dp, & + +.898135896598511332010666666666666E-27_dp, -.194763366993016433322666666666666E-28_dp, & + +.404836019024630033066666666666666E-30_dp, -.807981567699845120000000000000000E-32_dp /) + REAL (dp), PARAMETER :: ae13cs(50) = (/ -.60577324664060345999319382737747_dp, & + -.11253524348366090030649768852718E+0_dp, +.13432266247902779492487859329414E-1_dp, & + -.19268451873811457249246838991303E-2_dp, +.30911833772060318335586737475368E-3_dp, & + -.53564132129618418776393559795147E-4_dp, +.98278128802474923952491882717237E-5_dp, & + -.18853689849165182826902891938910E-5_dp, +.37494319356894735406964042190531E-6_dp, & + -.76823455870552639273733465680556E-7_dp, +.16143270567198777552956300060868E-7_dp, & + -.34668022114907354566309060226027E-8_dp, +.75875420919036277572889747054114E-9_dp, & + -.16886433329881412573514526636703E-9_dp, +.38145706749552265682804250927272E-10_dp, & + -.87330266324446292706851718272334E-11_dp, +.20236728645867960961794311064330E-11_dp, & + -.47413283039555834655210340820160E-12_dp, +.11221172048389864324731799928920E-12_dp, & + -.26804225434840309912826809093395E-13_dp, +.64578514417716530343580369067212E-14_dp, & + -.15682760501666478830305702849194E-14_dp, +.38367865399315404861821516441408E-15_dp, & + -.94517173027579130478871048932556E-16_dp, +.23434812288949573293896666439133E-16_dp, & + -.58458661580214714576123194419882E-17_dp, +.14666229867947778605873617419195E-17_dp, & + -.36993923476444472706592538274474E-18_dp, +.93790159936721242136014291817813E-19_dp, & + -.23893673221937873136308224087381E-19_dp, +.61150624629497608051934223837866E-20_dp, & + -.15718585327554025507719853288106E-20_dp, +.40572387285585397769519294491306E-21_dp, & + -.10514026554738034990566367122773E-21_dp, +.27349664930638667785806003131733E-22_dp, & + -.71401604080205796099355574271999E-23_dp, +.18705552432235079986756924211199E-23_dp, & + -.49167468166870480520478020949333E-24_dp, +.12964988119684031730916087125333E-24_dp, & + -.34292515688362864461623940437333E-25_dp, +.90972241643887034329104820906666E-26_dp, & + -.24202112314316856489934847999999E-26_dp, +.64563612934639510757670475093333E-27_dp, & + -.17269132735340541122315987626666E-27_dp, +.46308611659151500715194231466666E-28_dp, & + -.12448703637214131241755170133333E-28_dp, +.33544574090520678532907007999999E-29_dp, & + -.90598868521070774437543935999999E-30_dp, +.24524147051474238587273216000000E-30_dp, & + -.66528178733552062817107967999999E-31_dp /) + REAL (dp), PARAMETER :: ae14cs(64) = (/ -.1892918000753016825495679942820_dp, & + -.8648117855259871489968817056824E-1_dp, +.7224101543746594747021514839184E-2_dp, & + -.8097559457557386197159655610181E-3_dp, +.1099913443266138867179251157002E-3_dp, & + -.1717332998937767371495358814487E-4_dp, +.2985627514479283322825342495003E-5_dp, & + -.5659649145771930056560167267155E-6_dp, +.1152680839714140019226583501663E-6_dp, & + -.2495030440269338228842128765065E-7_dp, +.5692324201833754367039370368140E-8_dp, & + -.1359957664805600338490030939176E-8_dp, +.3384662888760884590184512925859E-9_dp, & + -.8737853904474681952350849316580E-10_dp, +.2331588663222659718612613400470E-10_dp, & + -.6411481049213785969753165196326E-11_dp, +.1812246980204816433384359484682E-11_dp, & + -.5253831761558460688819403840466E-12_dp, +.1559218272591925698855028609825E-12_dp, & + -.4729168297080398718476429369466E-13_dp, +.1463761864393243502076199493808E-13_dp, & + -.4617388988712924102232173623604E-14_dp, +.1482710348289369323789239660371E-14_dp, & + -.4841672496239229146973165734417E-15_dp, +.1606215575700290408116571966188E-15_dp, & + -.5408917538957170947895023784252E-16_dp, +.1847470159346897881370231402310E-16_dp, & + -.6395830792759094470500610425050E-17_dp, +.2242780721699759457250233276170E-17_dp, & + -.7961369173983947552744555308646E-18_dp, +.2859308111540197459808619929272E-18_dp, & + -.1038450244701137145900697137446E-18_dp, +.3812040607097975780866841008319E-19_dp, & + -.1413795417717200768717562723696E-19_dp, +.5295367865182740958305442594815E-20_dp, & + -.2002264245026825902137211131439E-20_dp, +.7640262751275196014736848610918E-21_dp, & + -.2941119006868787883311263523362E-21_dp, +.1141823539078927193037691483586E-21_dp, & + -.4469308475955298425247020718489E-22_dp, +.1763262410571750770630491408520E-22_dp, & + -.7009968187925902356351518262340E-23_dp, +.2807573556558378922287757507515E-23_dp, & + -.1132560944981086432141888891562E-23_dp, +.4600574684375017946156764233727E-24_dp, & + -.1881448598976133459864609148108E-24_dp, +.7744916111507730845444328478037E-25_dp, & + -.3208512760585368926702703826261E-25_dp, +.1337445542910839760619930421384E-25_dp, & + -.5608671881802217048894771735210E-26_dp, +.2365839716528537483710069473279E-26_dp, & + -.1003656195025305334065834526856E-26_dp, +.4281490878094161131286642556927E-27_dp, & + -.1836345261815318199691326958250E-27_dp, +.7917798231349540000097468678144E-28_dp, & + -.3431542358742220361025015775231E-28_dp, +.1494705493897103237475066008917E-28_dp, & + -.6542620279865705439739042420053E-29_dp, +.2877581395199171114340487353685E-29_dp, & + -.1271557211796024711027981200042E-29_dp, +.5644615555648722522388044622506E-30_dp, & + -.2516994994284095106080616830293E-30_dp, +.1127259818927510206370368804181E-30_dp, & + -.5069814875800460855562584719360E-31_dp /) + !***FIRST EXECUTABLE STATEMENT DE1 + IF (first) THEN + eta = 0.1 * EPSILON(0.0_dp) + ntae10 = initds(ae10cs, 50, eta) + ntae11 = initds(ae11cs, 60, eta) + ntae12 = initds(ae12cs, 41, eta) + nte11 = initds(e11cs, 29, eta) + nte12 = initds(e12cs, 25, eta) + ntae13 = initds(ae13cs, 50, eta) + ntae14 = initds(ae14cs, 64, eta) + xmaxt = -LOG( TINY(0.0_dp) ) + xmax = xmaxt - LOG(xmaxt) + END IF + first = .false. + IF (x <= -1._dp) THEN + IF (x <= -32._dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl(64._dp/x+1._dp, ae10cs, ntae10)) + RETURN + END IF + IF (x <= -8._dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl((64._dp/x+5._dp)/3._dp, ae11cs, ntae11)) + RETURN + END IF + IF (x <= -4._dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl(16._dp/x+3._dp, ae12cs, ntae12)) + RETURN + END IF + fn_val = -LOG(-x) + dcsevl((2._dp*x+5._dp)/3._dp, e11cs, nte11) + RETURN + END IF + IF (x <= 1.0_dp) THEN + IF (x == 0._dp) CALL xermsg('SLATEC', 'DE1', 'X IS 0') + fn_val = (-LOG(ABS(x)) - 0.6875_dp+x) + dcsevl(x, e12cs, nte12) + RETURN + END IF + IF (x <= 4.0_dp) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl((8._dp/x-5._dp)/3._dp, ae13cs, ntae13)) + RETURN + END IF + IF (x <= xmax) THEN + fn_val = EXP(-x) / x * (1._dp + dcsevl(8._dp/x-1._dp, ae14cs, ntae14)) + RETURN + END IF + CALL xermsg('SLATEC', 'DE1', 'X SO BIG E1 UNDERFLOWS') + fn_val = 0._dp + RETURN + END FUNCTION de1 + !DECK DEI + FUNCTION dei(x) RESULT(fn_val) + !***BEGIN PROLOGUE DEI + !***PURPOSE Compute the exponential integral Ei(X). + !***LIBRARY SLATEC (FNLIB) + !***CATEGORY C5 + !***TYPE REAL (dp) (EI-S, DEI-D) + !***KEYWORDS EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, + ! SPECIAL FUNCTIONS + !***AUTHOR Fullerton, W., (LANL) + !***DESCRIPTION + ! DEI calculates the REAL (dp) exponential integral, Ei(X), for + ! positive REAL (dp) argument X and the Cauchy principal value + ! for negative X. If principal values are used everywhere, then, for + ! all X, + ! Ei(X) = -E1(-X) + ! or + ! E1(X) = -Ei(-X). + !***REFERENCES (NONE) + !***ROUTINES CALLED DE1 + !***REVISION HISTORY (YYMMDD) + ! 770701 DATE WRITTEN + ! 891115 Modified prologue description. (WRB) + ! 891115 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + !***END PROLOGUE DEI + REAL (dp), INTENT(IN) :: x + REAL (dp) :: fn_val + !***FIRST EXECUTABLE STATEMENT DEI + fn_val = -de1(-x) + RETURN + END FUNCTION dei + !DECK INITDS + FUNCTION initds(os, nos, eta) RESULT(ival) + !***BEGIN PROLOGUE INITDS + !***PURPOSE Determine the number of terms needed in an orthogonal + ! polynomial series so that it meets a specified accuracy. + !***LIBRARY SLATEC (FNLIB) + !***CATEGORY C3A2 + !***TYPE REAL (dp) (INITS-S, INITDS-D) + !***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, + ! ORTHOGONAL SERIES, SPECIAL FUNCTIONS + !***AUTHOR Fullerton, W., (LANL) + !***DESCRIPTION + ! Initialize the orthogonal series, represented by the array OS, so that + ! INITDS is the number of terms needed to insure the error is no larger than + ! ETA. Ordinarily, ETA will be chosen to be one-tenth machine precision. + ! Input Arguments -- + ! OS REAL (dp) array of NOS coefficients in an orthogonal series. + ! NOS number of coefficients in OS. + ! ETA single precision scalar containing requested accuracy of series. + !***REFERENCES (NONE) + !***ROUTINES CALLED XERMSG + !***REVISION HISTORY (YYMMDD) + ! 770601 DATE WRITTEN + ! 890531 Changed all specific intrinsics to generic. (WRB) + ! 890831 Modified array declarations. (WRB) + ! 891115 Modified error message. (WRB) + ! 891115 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) + !***END PROLOGUE INITDS + REAL (dp), INTENT(IN) :: os(:) + INTEGER, INTENT(IN) :: nos + REAL (dp), INTENT(IN) :: eta + INTEGER :: ival + INTEGER :: i, ii + REAL (dp) :: ERR + !***FIRST EXECUTABLE STATEMENT INITDS + IF (nos < 1) CALL xermsg('SLATEC', 'INITDS', 'Number of coefficients < 1') + ERR = 0.0_dp + DO ii = 1, nos + i = nos + 1 - ii + ERR = ERR + ABS(os(i)) + IF (ERR > eta) GO TO 20 + END DO + 20 IF (i == nos) CALL xermsg('SLATEC', 'INITDS', & + 'Chebyshev series too short for specified accuracy') + ival = i + RETURN + END FUNCTION initds + + SUBROUTINE xermsg(text1, text2, text3) + CHARACTER (LEN= *), INTENT(IN) :: text1 + CHARACTER (LEN= *), INTENT(IN) :: text2 + CHARACTER (LEN= *), INTENT(IN) :: text3 + WRITE(*, '(6a)') ' Error in call to ', text1, ' routine: ', text2, ' Mesg: ', text3 + return + END SUBROUTINE xermsg + + + end module specialinf diff -r -c -b -N cosmomc/distparams.ini cosmomc_fields/distparams.ini *** cosmomc/distparams.ini 2009-09-17 15:14:51.000000000 +0200 --- cosmomc_fields/distparams.ini 2009-10-28 16:10:56.228209339 +0100 *************** *** 100,106 **** #Parameters to use. If zero use all parameters which have lables. plotparams_num = 0 ! plotparams = omegabh2 omegadmh2 tau ns #Get set label to empty to not include a parameter in the parameter_names file #lab[asz]= --- 100,106 ---- #Parameters to use. If zero use all parameters which have lables. plotparams_num = 0 ! plotparams = omegabh2 omegadmh2 tau ns p mu nu q lnR Xend Xstop lnA asz #Get set label to empty to not include a parameter in the parameter_names file #lab[asz]= *************** *** 130,132 **** --- 130,133 ---- PCA_params = omegam H0 tau #L for log(x), M for log(-x), N for no log PCA_func = LLL + diff -r -c -b -N cosmomc/params_CMB.paramnames cosmomc_fields/params_CMB.paramnames *** cosmomc/params_CMB.paramnames 2009-09-17 17:47:04.000000000 +0200 --- cosmomc_fields/params_CMB.paramnames 2009-10-28 16:16:05.692218134 +0100 *************** *** 5,14 **** omegak \Omega_K fnu f_\nu #neutrino energy density as fraction of omegadmh2 w w #constant equation of state parameter for scalar field dark energy ! ns n_s #beware that pivot scale can change in .ini file ! nt n_t ! nrun n_{run} ! logA log[10^{10} A_s] r r #ratio of tensor to scalar primordial amplitudes at pivot scale asz A_{SZ} #SZ template amplitude, as in WMAP omegal* \Omega_\Lambda --- 5,20 ---- omegak \Omega_K fnu f_\nu #neutrino energy density as fraction of omegadmh2 w w #constant equation of state parameter for scalar field dark energy ! Aini A_{ini} #initial conformal factor in the Einstein frame ! Xini \kappa\chi_{ini} #initiai field value ! p p #potential parameter p ! mu \mu #potential parameter mu ! nu \nu #potential parameter nu ! q q #potential parameter q ! lnR ln(R) #reheating parameter ! Xend \kappa\chi_{uv} #bound on fields values ! Xstop \kappa\chi_{stop} #force inflation to stop at this fied value ! lnA ln[10^{10} P_*] #scalar power spectrum amplitude r r #ratio of tensor to scalar primordial amplitudes at pivot scale asz A_{SZ} #SZ template amplitude, as in WMAP omegal* \Omega_\Lambda *************** *** 18,20 **** --- 24,31 ---- zrei* z_{re} r10* r_{10} #tensor-scalar C_l amplitude at l=10 H0* H_0 #hubble parameter is H0 km/s/Mpc + logM* log(M) #potential normalisation + lnRrad* ln(R_{rad}) #derived reheating parameter ln(a_{end}/a_{reh}) - 1/4 ln(\rho_{reh}/\rho_{end}) + lnzinf* ln(a_0/a_{end}) #redshit of the end of inflation + lnrhoinf* ln(kappa^4\rho_{\end}) #energy at the end of inflation + diff -r -c -b -N cosmomc/params.ini cosmomc_fields/params.ini *** cosmomc/params.ini 2009-10-27 15:35:25.000000000 +0100 --- cosmomc_fields/params.ini 2009-10-28 13:33:04.908363793 +0100 *************** *** 1,7 **** #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 --- 1,7 ---- #Sample parameters for cosmomc in default parameterization #Root name for files produced ! file_root = chains/fields #action = 0: MCMC, action=1: postprocess .data file, action=2: find best fit point only action = 0 *************** *** 10,16 **** samples = 200000 #Feedback level ( 2=lots,1=chatty,0=none) ! feedback = 1 #Temperature at which to Monte-Carlo temperature = 1 --- 10,16 ---- samples = 200000 #Feedback level ( 2=lots,1=chatty,0=none) ! feedback = 3 #Temperature at which to Monte-Carlo temperature = 1 *************** *** 67,84 **** #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 --- 67,84 ---- #use fast-slow parameter distinctions to speed up #(note for basic models WMAP3 code is only ~3x as fast as CAMB) ! use_fast_slow = T #Can use covariance matrix for proposal density, otherwise use settings below #Covariance matrix can be produced using "getdist" program. ! #propose_matrix = params_CMB.covmat #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 = 0.1 #Scale of proposal relative to covariance; 2.4 is recommended by astro-ph/0405462 for Gaussians #If propose_matrix is much broader than the new distribution, make proportionately smaller *************** *** 135,146 **** #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) --- 135,146 ---- #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 = T #CAMB parameters #If we are including tensors ! compute_tensors = T #Initial power spectrum amplitude point (Mpc^{-1}) pivot_k = 0.05 #If using tensors, enforce n_T = -A_T/(8A_s) *************** *** 152,157 **** --- 152,160 ---- #(default is about 0.3%, accuracy_level=2 around 0.1% at high l) accuracy_level = 1 + #select the inflationary model + inflation_model = largef + #If action = 1 redo_likelihoods = T redo_theory = F *************** *** 176,187 **** 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 --- 179,211 ---- param[fnu] = 0 0 0 0 0 param[w] = -1 -1 -1 0 0 ! #initial field values ! #dilaton ! param[Aini] = 1 1 1 0 0 ! #matter field X (0 to use guessed values) ! param[Xini] = 0 0 0 0 0 ! #potential parameters: mu = nu = 0 for large fields ! #p ! param[p] = 2 2 2 0 0 ! #mu ! param[mu] = 0 0 0 0 0 ! #nu ! param[nu] = 0 0 0 0 0 ! #q ! param[q] = 1 1 1 0 0 ! ! #reheating correction ! #ln(aend/areh) + 1/4 ln(1/rhoreh) - 1/2 ln(1/rhoend) ! param[lnR] = 0 -46 15 10 10 ! ! #bound on field values (need checkBound=T) ! param[Xend] = 0 0 0 0 0 ! ! #end field values (needs checkStop=T) ! param[Xstop] = 0 0 0 0 0 #log[10^10 A_s] ! param[lnA] = 3 2.7 4 0.01 0.01 ! param[r] = 1 1 1 0 0 #SZ amplitude, as in WMAP analysis param[asz]= 1 0 2 0.4 0.4 diff -r -c -b -N cosmomc/source/CMB_Cls_simple.f90 cosmomc_fields/source/CMB_Cls_simple.f90 *** cosmomc/source/CMB_Cls_simple.f90 2009-10-21 22:14:28.000000000 +0200 --- cosmomc_fields/source/CMB_Cls_simple.f90 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,506 **** - !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(3) = (/1,3,2/), TensClOrder(4) = (/1,4,2,3/) - !Mapping of CAMB CL array ordering to TT , TE, EE, BB - 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 - 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) - - 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) - 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 = 2.726e6**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 (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 - end do - - if (num_cls>num_clsS) Theory%cl(:,num_clsS+1:num_cls) = 0 - - - 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 - P%Num_Nu_Massless = 0.04 - P%InitPower%nn = 1 - P%AccuratePolarization = num_cls/=1 - P%Reion%use_optical_depth = .false. - P%OnlyTransfers = .true. - - 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 -N cosmomc/source/CMB_Cls_simple.F90 cosmomc_fields/source/CMB_Cls_simple.F90 *** cosmomc/source/CMB_Cls_simple.F90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/source/CMB_Cls_simple.F90 2009-10-28 13:33:30.396353285 +0100 *************** *** 0 **** --- 1,520 ---- + !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(3) = (/1,3,2/), TensClOrder(4) = (/1,4,2,3/) + !Mapping of CAMB CL array ordering to TT , TE, EE, BB + 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 + 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) + + 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) + 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 + + !fields call SetCAMBInitPower(Info%Transfers%Params,CMB,1) + call SetCAMBInitPower(Info%Transfers%Params,CMB,1,error) + if (error.ne.0) then + if (Feedback > 1) write(*,*)'CMB_Cls_simple: out of prior error =',error + return + endif + !end fields + call CAMB_TransfersToPowers(Info%Transfers) + !this sets slow CAMB params correctly from value stored in Transfers + + 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 = 2.726e6**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 (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 + end do + + if (num_cls>num_clsS) Theory%cl(:,num_clsS+1:num_cls) = 0 + + + 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. + !fields call SetCAMBInitPower(P,CMB,1) + call SetCAMBInitPower(P,CMB,1,error) + if (error.ne.0) then + if (Feedback > 1) write(*,*)'GetClsInfo: out of prior error =',error + stop + endif + !end fields + MatterOnly = .false. + if (DoPk) then + P%WantTransfer = .true. + 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 + P%Num_Nu_Massless = 0.04 + P%InitPower%nn = 1 + P%AccuratePolarization = num_cls/=1 + P%Reion%use_optical_depth = .false. + P%OnlyTransfers = .true. + + !fields + P%InitPower%infParam%name = InfModelName + !end fields + + 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 + diff -r -c -b -N cosmomc/source/cmbtypes.f90 cosmomc_fields/source/cmbtypes.f90 *** cosmomc/source/cmbtypes.f90 2009-10-20 16:45:00.000000000 +0200 --- cosmomc_fields/source/cmbtypes.f90 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,425 **** - !Define the data types and read/writes them to disk. Also change l_max here. - - module cmbtypes - use settings - implicit none - - - !Number of Cls, 1 for just temperature, 3 (4) for polarization (with B) - integer, parameter :: num_cls = 3 - - !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 - !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 - - !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) - - !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 reserved(5) - - end Type CMBParams - - Type CosmoTheory - real Age, r10 - real SN_loglike, HST_loglike, BAO_loglike, reserved(1) - real cl(lmax,num_cls), cl_tensor(lmax_tensor,num_cls) !TT, TE, EE and BB 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%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) - 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) - do j=30,90,10 - write(i) T%cl(j,1:num_cls) - end do - do j=110,130, 20 - write(i) T%cl(j,1:num_cls) - end do - do j=150,lmax, 50 - write(i) T%cl(j,1:num_cls) - 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) - 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 more Cls (polarization)' - - read(i) T%SN_loglike, T%HST_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:anumcls) - read(i) T%cl_tensor(2:almaxtensor,1:anumcls) - else - - read(i) icl(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) icl(ind,1:num_cls) - ix(ind) = j - ind = ind + 1 - end do - do j=110,130,20 - read(i) icl(ind,1:num_cls) - ix(ind) = j - ind = ind + 1 - end do - do j=150,almax, 50 - read(i) icl(ind,1:num_cls) - ix(ind) = j - ind = ind+1 - end do - ind = ind-1 - - call InterpCls(ix,icl, T%cl, ind, almax, num_Cls) - - if (almaxtensor /= 0) then - read(i) icl(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) icl(ind,1:num_cls) - ix(ind) = j - ind = ind + 1 - end do - do j=110,130,20 - read(i) icl(ind,1:num_cls) - ix(ind) = j - ind = ind + 1 - end do - do j=150,almaxtensor, 50 - read(i) icl(ind,1:num_cls) - ix(ind) = j - ind = ind+1 - end do - ind = ind-1 - call InterpCls(ix,icl, 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:num_cls) - 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) - 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 - - 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,:) = Cls(2:lmax_tensor,:)+ T%cl_tensor(2:lmax_tensor,:) - !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) - - 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,:)*l*(l+1)/(2*pi) - 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 -N cosmomc/source/cmbtypes.F90 cosmomc_fields/source/cmbtypes.F90 *** cosmomc/source/cmbtypes.F90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/source/cmbtypes.F90 2009-10-28 15:43:48.956707547 +0100 *************** *** 0 **** --- 1,425 ---- + !Define the data types and read/writes them to disk. Also change l_max here. + + module cmbtypes + use settings + implicit none + + + !Number of Cls, 1 for just temperature, 3 (4) for polarization (with B) + integer, parameter :: num_cls = 3 + + !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 + !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 + + !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) + + !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 reserved(5) + + end Type CMBParams + + Type CosmoTheory + real Age, r10 + real SN_loglike, HST_loglike, BAO_loglike, reserved(1) + real cl(lmax,num_cls), cl_tensor(lmax_tensor,num_cls) !TT, TE, EE and BB 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%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) + 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) + do j=30,90,10 + write(i) T%cl(j,1:num_cls) + end do + do j=110,130, 20 + write(i) T%cl(j,1:num_cls) + end do + do j=150,lmax, 50 + write(i) T%cl(j,1:num_cls) + 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) + 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 more Cls (polarization)' + + read(i) T%SN_loglike, T%HST_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:anumcls) + read(i) T%cl_tensor(2:almaxtensor,1:anumcls) + else + + read(i) icl(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) icl(ind,1:num_cls) + ix(ind) = j + ind = ind + 1 + end do + do j=110,130,20 + read(i) icl(ind,1:num_cls) + ix(ind) = j + ind = ind + 1 + end do + do j=150,almax, 50 + read(i) icl(ind,1:num_cls) + ix(ind) = j + ind = ind+1 + end do + ind = ind-1 + + call InterpCls(ix,icl, T%cl, ind, almax, num_Cls) + + if (almaxtensor /= 0) then + read(i) icl(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) icl(ind,1:num_cls) + ix(ind) = j + ind = ind + 1 + end do + do j=110,130,20 + read(i) icl(ind,1:num_cls) + ix(ind) = j + ind = ind + 1 + end do + do j=150,almaxtensor, 50 + read(i) icl(ind,1:num_cls) + ix(ind) = j + ind = ind+1 + end do + ind = ind-1 + call InterpCls(ix,icl, 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:num_cls) + 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) + 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 + + 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,:) = Cls(2:lmax_tensor,:)+ T%cl_tensor(2:lmax_tensor,:) + !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) + + 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,:)*l*(l+1)/(2*pi) + 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 diff -r -c -b -N cosmomc/source/driver.F90 cosmomc_fields/source/driver.F90 *** cosmomc/source/driver.F90 2009-10-20 15:24:17.000000000 +0200 --- cosmomc_fields/source/driver.F90 2009-10-28 13:36:51.444745349 +0100 *************** *** 58,68 **** #ifdef MPI ! if (instance /= 0) call DoStop('With MPI should not have second parameter') call mpi_comm_rank(mpi_comm_world,MPIrank,ierror) instance = MPIrank +1 !start at 1 for chains ! write (numstr,*) instance rand_inst = instance if (ierror/=MPI_SUCCESS) call DoStop('MPI fail') --- 58,77 ---- #ifdef MPI ! !fields ! ! if (instance /= 0) call DoStop('With MPI should not have second parameter') ! instance_shift=instance ! write(*,*)'MPI file names shifted by: ',instance_shift ! !end fields call mpi_comm_rank(mpi_comm_world,MPIrank,ierror) + instance = MPIrank +1 !start at 1 for chains ! !fields ! ! write (numstr,*) instance ! instance_shift = MPIrank + instance_shift ! write (numstr,*) instance_shift ! !end fields rand_inst = instance if (ierror/=MPI_SUCCESS) call DoStop('MPI fail') *************** *** 85,91 **** propose_scale = Ini_Read_Real('propose_scale',2.4) AccuracyLevel = Ini_Read_Real('accuracy_level',1.) ! checkpoint = Ini_Read_Logical('checkpoint',.false.) if (checkpoint) flush_write = .true. --- 94,102 ---- propose_scale = Ini_Read_Real('propose_scale',2.4) AccuracyLevel = Ini_Read_Real('accuracy_level',1.) ! !fields ! InfModelName = Ini_Read_String('inflation_model') ! !end fields checkpoint = Ini_Read_Logical('checkpoint',.false.) if (checkpoint) flush_write = .true. diff -r -c -b -N cosmomc/source/lrggettheory.f90 cosmomc_fields/source/lrggettheory.f90 *** cosmomc/source/lrggettheory.f90 2009-10-27 00:48:14.000000000 +0100 --- cosmomc_fields/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 -N cosmomc/source/lrggettheory.F90 cosmomc_fields/source/lrggettheory.F90 *** cosmomc/source/lrggettheory.F90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/source/lrggettheory.F90 2009-10-28 15:43:48.956707547 +0100 *************** *** 0 **** --- 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 diff -r -c -b -N cosmomc/source/Makefile cosmomc_fields/source/Makefile *** cosmomc/source/Makefile 2009-10-27 16:42:57.000000000 +0100 --- cosmomc_fields/source/Makefile 2009-10-28 13:55:14.725283789 +0100 *************** *** 1,118 **** ! #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/WMAP5/likelihood_v3 ! #Only needed for WMAP ! cfitsio = /usr/local/cfitsio/intel10/64/3.040 - #GSL only needed for DR7 LRG - GSLPATH = /home/aml1005/libs/gsl - IFLAG = -I - INCLUDE= - - #Intel MPI (assuming mpif77 set to point to ifort) - #change -lmkl_ia32 to -lmkl_p3 for MKL versions earlier than 6 (6 needed for ifc 8+) - F90C = mpif90 - FFLAGS = -O2 -ip -W0 -WB -openmp -fpp -DMPI -vec_report0 - LAPACKL = -L/usr/local/intel/mkl/9.1/lib/em64t -lmkl_lapack -lmkl_em64t -lguide -lpthread - - #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" "module load latest" "module load gsl.stable" - #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 = /home/cosmos/share-ia64/likelihood_v3 - 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 --- 1,84 ---- ! # >>> DESIGNED FOR GMAKE <<< ! # Unified Systems makefile for COSMOMC ! # Add FLAGS -DMPI for using MPI ! ! ext=$(shell uname | cut -c1-3) ! CC=cc ! ! ifeq ($(ext),IRI) ! F90C= f90 ! FFLAGS= -Ofast -mp -n32 -LANG:recursive=ON -lmpi -DMPI ! WMAPFLAGS= $(FFLAGS) ! LAPACKL = -lcomplib.sgimath_mp ! INCLUDE = -I../camb ! CFITSIODIR = /people/ringeval/usr ! GSLDIR = ! endif ! ifeq ($(ext),Lin) ! F90C=gfortran ! FFLAGS= -O -fopenmp ! WMAPFLAGS= -O ! LAPACKL = -llapack ! INCLUDE = -I../camb ! CFITSIODIR = /opt/gnu/cfitsio ! GSLDIR = /usr ! endif ! ! ifeq ($(ext),OSF) ! F90C=f90 ! FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1 ! WMAPFLAGS= $(FFLAGS) ! LAPACKL = -lcxml ! INCLUDE = -I../camb ! CFITSIODIR = ! GSLDIR = ! endif ! ! ifeq ($(ext),Sun) ! F90C=f90 ! FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none ! WMAPFLAGS= $(FFLAGS) ! LAPACKL = -lsunperf -lfsu ! INCLUDE = -I../camb -M../camb ! CFITSIODIR = ! GSLDIR = ! endif ! ! ifeq ($(ext),AIX) ! F90C = mpxlf90_r ! FFLAGS = -O4 -WF,-DIBMXL,-DMPI -qstrict -qsmp=omp -qmaxmem=-1 -qsuffix=f=f90:cpp=F90 ! WMAPFLAGS= $(FFLAGS) ! LAPACKL = -lessl ! INCLUDE = -I../camb ! CFITSIODIR = ! GSLDIR = ! endif ! ! #EXTDATA = LRG ! EXTDATA = LRG ! EXTINCLUDE = -I$(GSLDIR)/include ! EXTOBJS = bsplinepk.o ! ! ! WMAPDIR = ../WMAP ! WMAPINCLUDE = -I$(CFITSIODIR)/include ! WMAPOBJS = read_archive_map.o \ ! read_fits.o \ ! healpix_types.o \ ! br_mod_dist.o \ ! WMAP_5yr_options.o \ ! WMAP_5yr_util.o \ ! WMAP_5yr_gibbs.o \ ! WMAP_5yr_tt_pixlike.o \ ! WMAP_5yr_tt_beam_ptsrc_chisq.o \ ! WMAP_5yr_teeebb_pixlike.o \ ! WMAP_5yr_tetbeebbeb_pixlike.o \ ! WMAP_5yr_likelihood.o PROPOSE = propose.o CLSFILE = CMB_Cls_simple.o *************** *** 120,163 **** #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 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)/WMAP_5yr_options.o \ ! $(WMAP)/WMAP_5yr_util.o \ ! $(WMAP)/WMAP_5yr_tt_pixlike.o \ ! $(WMAP)/WMAP_5yr_teeebb_pixlike.o \ ! $(WMAP)/WMAP_5yr_likelihood.o \ ! $(WMAP)/WMAP_5yr_gibbs.o \ ! $(WMAP)/WMAP_5yr_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 --- 86,124 ---- #Can use params_H if you prefer more generic parameters PARAMETERIZATION = params_CMB.o ! LINKFLAGS = -L../camb -lcamb -linf $(LAPACKL) ! ! F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(INCLUDE) 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 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 ! EXTINCLUDE = -I$(GSLDIR)/include ! LINKFLAGS += -lgsl -lgslcblas ! OBJFILES += $(EXTOBJS) ! endif ! ! ifneq ($(WMAPDIR),) ! F90FLAGS += $(WMAPINCLUDE) ! LINKFLAGS += -L$(CFITSIODIR)/lib -lcfitsio ! OBJFILES += $(WMAPOBJS) else F90FLAGS += -DNOWMAP endif ! ! default: cosmomc.$(ext) ! ! all : cosmomc.$(ext) getdist.$(ext) utils.o: ../camb/libcamb.a settings.o: utils.o *************** *** 181,194 **** 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 --- 142,159 ---- MCMC.o: calclike.o driver.o: MCMC.o .f.o: f77 $(F90FLAGS) -c $< %.o: %.c ! $(CC) $(EXTINCLUDE) -c $*.c ! ! %.o: $(WMAPDIR)/%.f90 ! $(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $< ! ! %.o: $(WMAPDIR)/%.F90 ! $(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $< ! %.o: %.f90 $(F90C) $(F90FLAGS) -c $*.f90 *************** *** 197,215 **** $(F90C) $(F90FLAGS) -c $*.F90 ! cosmomc: camb $(OBJFILES) ! $(F90C) -o ../cosmomc $(OBJFILES) $(LINKFLAGS) $(F90FLAGS) ! - clean: cleancosmomc - rm -f ../camb/*.o ../camb/*.obj ! 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 --- 162,175 ---- $(F90C) $(F90FLAGS) -c $*.F90 ! cosmomc.$(ext): $(OBJFILES) ../camb/libcamb.a ../camb/libinf.a ! $(F90C) -o ../$@ $(OBJFILES) $(LINKFLAGS) $(F90FLAGS) ! clean: rm -f *.o *.mod *.d *.pc *.obj ../core + getdist.$(ext): $(DISTFILES) + $(F90C) -o ../$@ $(DISTFILES) $(LINKFLAGS) $(F90FLAGS) diff -r -c -b -N cosmomc/source/MCMC.f90 cosmomc_fields/source/MCMC.f90 *** cosmomc/source/MCMC.f90 2009-09-18 18:32:05.000000000 +0200 --- cosmomc_fields/source/MCMC.f90 2009-10-28 13:37:18.797363255 +0100 *************** *** 215,221 **** Like = GetLogLike(grid(r)) ! if (Feedback > 1) write (*,*) r, 'Likelihood: ', Like, 'Current Like:', CurLike if ((Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike)) then !Accept --- 215,221 ---- Like = GetLogLike(grid(r)) ! if (Feedback > 1) write (*,*) r, 'Likelihood: ', Like, 'Current Like:', CurLike, 'Rank', MPIRank if ((Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike)) then !Accept *************** *** 501,507 **** output_lines = output_lines +1 call WriteParams(CurParams, real(mult), CurLike) end if ! if (Feedback > 1) write (*,*) instance, 'Slicing, Current Like:', CurLike mult = 1 if (num_slow /=0) call SliceSampleSlowParam(CurParams, CurLike) if (num_fast /=0) call SliceSampleFastParams(CurParams, CurLike) --- 501,507 ---- output_lines = output_lines +1 call WriteParams(CurParams, real(mult), CurLike) end if ! if (Feedback > 1) write (*,*) instance, 'Slicing, Current Like:', CurLike, 'Rank', MPIRank mult = 1 if (num_slow /=0) call SliceSampleSlowParam(CurParams, CurLike) if (num_fast /=0) call SliceSampleFastParams(CurParams, CurLike) *************** *** 536,542 **** Like = GetLogLike(Trial) ! if (Feedback > 1) write (*,*) 'Likelihood: ', Like, 'Current Like:', CurLike !!! accpt = (Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike) !Include the min() so that compilers not doing optimal compilation don't complain --- 536,542 ---- Like = GetLogLike(Trial) ! if (Feedback > 1) write (*,*) 'Likelihood: ', Like, 'Current Like:', CurLike, 'Rank', MPIRank !!! accpt = (Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike) !Include the min() so that compilers not doing optimal compilation don't complain diff -r -c -b -N cosmomc/source/mpk.f90 cosmomc_fields/source/mpk.f90 *** cosmomc/source/mpk.f90 2009-10-23 10:48:04.000000000 +0200 --- cosmomc_fields/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 -N cosmomc/source/mpk.F90 cosmomc_fields/source/mpk.F90 *** cosmomc/source/mpk.F90 1970-01-01 01:00:00.000000000 +0100 --- cosmomc_fields/source/mpk.F90 2009-10-28 15:43:48.956707547 +0100 *************** *** 0 **** --- 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 diff -r -c -b -N cosmomc/source/params_CMB.f90 cosmomc_fields/source/params_CMB.f90 *** cosmomc/source/params_CMB.f90 2009-10-02 12:16:48.000000000 +0200 --- cosmomc_fields/source/params_CMB.f90 2009-10-28 13:50:38.216855185 +0100 *************** *** 46,52 **** !Mapping between array of power spectrum parameters and CAMB ! subroutine SetCAMBInitPower(P,CMB,in) use camb use settings use cmbtypes --- 46,54 ---- !Mapping between array of power spectrum parameters and CAMB ! !fields subroutine SetCAMBInitPower(P,CMB,in) ! subroutine SetCAMBInitPower(P,CMB,in,inferror) ! use infprec, only : kp use camb use settings use cmbtypes *************** *** 56,82 **** 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) --- 58,127 ---- integer, intent(in) :: in + integer :: inferror ! real(kp) :: Pstar ! if (Power_Name /= 'power_inf') then stop 'params_CMB:Wrong initial power spectrum' ! endif ! ! P%InitPower%kstar = pivot_k ! Pstar = cl_norm*CMB%norm(norm_As) ! ! ! !fields ! P%InitPower%infParam%conforms(1) = CMB%InitPower(1) ! P%InitPower%infParam%matters(1) = CMB%InitPower(2) ! ! !power ! P%InitPower%infParam%consts(2) = CMB%InitPower(3) ! ! !mu ! P%InitPower%infParam%consts(3) = CMB%InitPower(4) ! ! !nu ! P%InitPower%infParam%consts(4) = CMB%InitPower(5) ! ! !q ! P%InitPower%infParam%consts(5) = CMB%InitPower(6) ! ! !changed below ! P%InitPower%infParam%consts(1) = 1. ! ! P%InitPower%lnReheat = CMB%InitPower(7) ! ! ! !field bound related ! P%InitPower%infParam%consts(6) = CMB%InitPower(8) ! ! !field stop related ! P%InitPower%infParam%consts(7) = CMB%InitPower(9) ! ! ! call SetInfBg(P%InitPower,inferror) ! if (inferror.ne.0) then ! write(*,*)'SetCAMBInitPower: infbg out of prior',inferror ! return ! endif ! ! ! call SetInfScalPow(P%InitPower,Pstar) ! ! call SetInfBgSpline(P%InitPower) ! ! ! call SetInfCosmo(P%InitPower,inferror) ! if (inferror.ne.0) then ! write(*,*)'SetCAMBInitPower: inftorad out of prior',inferror ! return ! endif ! end subroutine SetCAMBInitPower + !end fields + subroutine SetForH(Params,CMB,H0) *************** *** 217,228 **** --- 262,279 ---- use settings use cmbtypes use ParamDef + !fields + use initialpower, only : exportinfprop,updateinfprop + !end fields use IO implicit none Type(ParamSet) P real, intent(in) :: mult, like Type(CMBParams) CMB real r10 + !fields + type(exportinfprop) :: infExport + !end fields real, allocatable :: output_array(:) if (outfile_handle ==0) return *************** *** 240,246 **** 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 --- 291,301 ---- else r10 = 0 end if ! !fields ! call UpdateInfProp(infExport) ! ! allocate(output_array(num_real_params + 7 + nuisance_params_used )) ! allocate(output_array(num_real_params + 11 + nuisance_params_used )) ! !end fields 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 *************** *** 253,259 **** 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 --- 308,321 ---- 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 ! !fields ! output_array(num_real_params+nuisance_params_used+8) & ! = log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) ! output_array(num_real_params+nuisance_params_used+9) & ! = P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd ! output_array(num_real_params+nuisance_params_used+10) = infExport%efoldEndToToday ! output_array(num_real_params+nuisance_params_used+11) = infExport%lnEnergyEnd ! !end fields call IO_OutputChainRow(outfile_handle, mult, like, output_array) deallocate(output_array) end if *************** *** 267,272 **** --- 329,337 ---- use settings use cmbtypes use ParamDef + !fields + use initialpower, only : exportinfprop,updateinfprop + !end fields use IO implicit none Type(ParamSet) P *************** *** 274,279 **** --- 339,347 ---- character(LEN =30) fmt Type(CMBParams) CMB real r10 + !fields + type(exportinfprop) :: infExport + !end fields real,allocatable :: output_array(:) if (outfile_handle ==0) return *************** *** 284,291 **** 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 --- 352,362 ---- else r10 = 0 end if ! !fields ! call UpdateInfProp(infExport) ! ! allocate(output_array(num_real_params + 7 + num_matter_power )) ! allocate(output_array(num_real_params + 11 + num_matter_power )) ! !end fields 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 *************** *** 296,302 **** 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) --- 367,380 ---- 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) ! !fields ! output_array(num_real_params+num_matter_power+8) & ! = log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) ! output_array(num_real_params+num_matter_power+9) & ! = P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd ! output_array(num_real_params+num_matter_power+10) = infExport%efoldEndToToday ! output_array(num_real_params+num_matter_power+11) = infExport%lnEnergyEnd ! !end fields call IO_OutputChainRow(outfile_handle, mult, like, output_array) deallocate(output_array) diff -r -c -b -N cosmomc/source/settings.f90 cosmomc_fields/source/settings.f90 *** cosmomc/source/settings.f90 2009-10-22 11:33:09.000000000 +0200 --- cosmomc_fields/source/settings.f90 2009-10-28 13:51:45.272863685 +0100 *************** *** 6,11 **** --- 6,12 ---- implicit none real :: AccuracyLevel = 1. + character (len=6) :: InfModelName !Set to >1 to use CAMB etc on higher accuracy settings. !Does not affect MCMC (except making it all slower) *************** *** 19,25 **** ! (e.g. beam uncertainty modes, etc, specific to dataset) integer, parameter :: num_hard =7 ! integer, parameter :: num_initpower = 3 integer, parameter :: num_freq_params = 1 integer, parameter :: num_norm = 2 + num_freq_params integer, parameter :: num_nuisance_params= 0 --- 20,29 ---- ! (e.g. beam uncertainty modes, etc, specific to dataset) integer, parameter :: num_hard =7 ! !fields ! ! integer, parameter :: num_initpower = 3 ! integer, parameter :: num_initpower = 9 ! !end fields integer, parameter :: num_freq_params = 1 integer, parameter :: num_norm = 2 + num_freq_params integer, parameter :: num_nuisance_params= 0 *************** *** 61,66 **** --- 65,73 ---- integer :: num_threads = 0 integer :: instance = 0 + !addon + integer :: instance_shift = 0 + !end addon integer :: MPIchains = 1, MPIrank = 0 logical :: Use_LSS = .true.