diff -c -b -B -r -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 -c -b -B -r -N cosmomc/camb/cmbmain.f90 cosmomc_fields/camb/cmbmain.f90 *** cosmomc/camb/cmbmain.f90 2008-03-17 17:01:34.000000000 +0100 --- cosmomc_fields/camb/cmbmain.f90 2008-04-29 19:38:21.000000000 +0200 *************** *** 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 -c -b -B -r -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 -c -b -B -r -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 2008-02-11 17:02:29.000000000 +0100 *************** *** 0 **** --- 1,1495 ---- + 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 = .true. + 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 + ! 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 (infIni%epsilon1.lt.epsilon(1._kp)) then + write(*,*) + write(*,*)'set_infbg_ini: epsilon1 < accuracy',infIni%epsilon1 + write(*,*) + 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,fieldStop,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) :: fieldStop + 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 :: checkEfoldMaxi = .false. + real(kp), parameter :: efoldMaxiStop = 200._kp + logical :: checkMatterStop, stopForMatterMax + + !field value at which we stop, and matterField index tested + real(kp) :: matterStop + integer, parameter :: iStopMin=1, iStopMax=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. + checkMatterStop = .false. + + if (checkEfoldMaxi) then + efoldHuge = min(efoldMaxiStop,efoldHuge) + endif + + + !checks + if (present(ptrStart)) then + if (associated(ptrStart)) then + stop 'bg_field_evol: ptr to bgdata already associated' + endif + endif + + if (present(efoldDataNum)) then + if (efoldDataNum.le.1) then + stop 'bg_field_evol: 2 points required & + &for drawing a line!' + endif + endif + + if ((.not.useVelocity).and.efoldExploreOsc.ne.0) then + write(*,*)'bg_field_evol: oscillation exploration disabled!' + efoldExploreOsc = 0. + endif + + if (present(isStopAtMax)) then + stopForMatterMax = isStopAtMax + else + stopForMatterMax = .false. + endif + + if (present(fieldStop)) then + matterStop = fieldStop + if (.not.checkMatterStop) then + write(*,*)'bg_field_evol: checkStop enabled' + write(*,*)'bg_field_evol: stopForMatterMax is',stopForMatterMax + checkMatterStop = .true. + endif + else + matterStop = 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 = stopForMatterMax + stopData%check = .false. + stopData%update = .false. + stopData%xend = efoldHuge + stopData%real1 = epsilon1Stop + stopData%real2 = matterStop! - 10._kp*tolEvol + stopData%int1 = iStopMin + stopData%int2 = iStopMax + + 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 (checkEfoldMaxi.and.(.not.stopData%yesno2)) then + + write(*,*)'bg_field_evol: efoldMaxi used to endinf' + 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 = stopForMatterMax + findData%real1 = efold + allocate(findData%ptrvector1(2*fieldNum)) + allocate(findData%ptrvector2(2*fieldNum)) + findData%ptrvector1 = bgVar + findData%real2 = tolEvol + findData%real3 = matterStop + findData%int1 = iStopMin + findData%int2 = iStopMax + + !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 (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(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), 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), intent(inout) :: findData + real(kp) :: find_endinf_matter + + integer :: iFieldMin, iFieldMax + 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 + iFieldMin = findData%int1 + iFieldMax = 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(iFieldMin:iFieldMax)) - matterStop + else + find_endinf_matter = minval(field(iFieldMin:iFieldMax)) - matterStop + endif + ! print *,'fn',find_endinf_matter,minval(field(1:matterNum)),matterMiniStop + + end function find_endinf_matter + + + + + + + + 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 + + logical :: stopNow + + 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 (epsilon1.gt.stopData%real1) then + stopData%update = .true. + stopData%xend = efold + 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 + if (stopNow) then + stopData%update = .true. + stopData%xend = efold + stopData%yesno2 = .false. + endif + 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 :: stopNow + + 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 (epsilon1.gt.stopData%real1) then + stopData%update = .true. + stopData%xend = efold + 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 + if (stopNow) then + stopData%update = .true. + stopData%xend = efold + stopData%yesno2 = .false. + endif + 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 -c -b -B -r -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 2007-05-09 20:00:02.000000000 +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 -c -b -B -r -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 -c -b -B -r -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 2006-03-31 18:55:56.000000000 +0200 *************** *** 0 **** --- 1,93 ---- + module infinout + + use infprec, only : kp + + interface livewrite + module procedure sp_livewrite, kp_livewrite + end interface + + + 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 + + + + end module infinout + + diff -c -b -B -r -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 2007-01-22 19:57:54.000000000 +0100 *************** *** 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), intent(in) :: 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), intent(in) :: 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 -c -b -B -r -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 -c -b -B -r -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 2008-04-29 21:04:41.000000000 +0200 *************** *** 0 **** --- 1,34 ---- + module infprec + implicit none + + public + + !quad precision + integer, parameter :: kp = kind(1.0_8) + + !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 = 1e-14 + + !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 + 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 -c -b -B -r -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 2007-05-25 15:06:13.000000000 +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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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), intent(in) :: 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 -c -b -B -r -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 2007-06-06 14:12:04.000000000 +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 -c -b -B -r -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 -c -b -B -r -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 2007-05-09 15:42:26.000000000 +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), intent(in) :: 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 -c -b -B -r -N cosmomc/camb/inidriver.F90 cosmomc_fields/camb/inidriver.F90 *** cosmomc/camb/inidriver.F90 2008-03-17 17:01:34.000000000 +0100 --- cosmomc_fields/camb/inidriver.F90 2008-04-29 19:44:04.000000000 +0200 *************** *** 293,298 **** --- 293,302 ---- call CAMB_cleanup + !fields + call FreePowers(P%InitPower) + !end fields + end program driver diff -c -b -B -r -N cosmomc/camb/Makefile cosmomc_fields/camb/Makefile *** cosmomc/camb/Makefile 2008-03-17 17:03:40.000000000 +0100 --- cosmomc_fields/camb/Makefile 2008-04-29 21:17:24.000000000 +0200 *************** *** 1,68 **** ! #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 ! #FLAGS = -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 #Files containing evolution equations initial power spectrum module EQUATIONS = equations ! POWERSPECTRUM = power_tilt REIONIZATION = reionization #Module doing non-linear scaling NONLINEAR = halofit --- 1,40 ---- ! # >>> 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 + #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 *************** *** 73,84 **** #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 CAMBLIB = libcamb.a #Shouldn't need to change anything else... --- 45,57 ---- #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... *************** *** 89,97 **** CAMBOBJ = utils.o subroutines.o inifile.o $(POWERSPECTRUM).o recfast.o $(REIONIZATION).o modules.o \ bessels.o $(EQUATIONS).o $(NONLINEAR).o lensing.o cmbmain.o camb.o ! default: camb ! all: camb $(CAMBLIB) subroutines: utils.o $(POWERSPECTRUM): subroutines.o --- 62,70 ---- CAMBOBJ = utils.o subroutines.o inifile.o $(POWERSPECTRUM).o recfast.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: utils.o $(POWERSPECTRUM): subroutines.o *************** *** 106,118 **** camb.o: cmbmain.o ! camb: $(CAMBOBJ) $(DRIVER) ! $(F90C) $(F90FLAGS) $(CAMBOBJ) $(DRIVER) -o $@ $(CAMBLIB): $(CAMBOBJ) ar -r $@ $? ! camb_fits: writefits.f90 $(CAMBOBJ) $(DRIVER) $(F90C) $(F90FLAGS) -I$(HEALPIXDIR)/include $(CAMBOBJ) writefits.f90 $(DRIVER) $(HEALPIXLD) -DWRITE_FITS -o $@ %.o: %.f90 --- 79,94 ---- 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 diff -c -b -B -r -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 2008-04-29 20:46:43.000000000 +0200 *************** *** 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 -c -b -B -r -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 2008-04-29 20:41:59.000000000 +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 = .true. + 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 -c -b -B -r -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 -c -b -B -r -N cosmomc/distparams.ini cosmomc_fields/distparams.ini *** cosmomc/distparams.ini 2008-03-07 15:48:00.000000000 +0100 --- cosmomc_fields/distparams.ini 2008-04-29 20:28:51.000000000 +0200 *************** *** 1,7 **** #Params for "getdist" - for processing .txt chain information #if zero, columnnum calculated automatically as total number of columns ! columnnum = 22 file_root = chains/test out_root = out_dir = --- 1,7 ---- #Params for "getdist" - for processing .txt chain information #if zero, columnnum calculated automatically as total number of columns ! columnnum = 0 file_root = chains/test out_root = out_dir = *************** *** 82,88 **** #Number of parameters to get covariance matrix for #If you are going to use the output as a proposal density make sure #you have map_params = F, and the dimension equal to the number of MCMC parameters ! cov_matrix_dimension = 13 #e.g. colormap('jet') matlab_colscheme = --- 82,88 ---- #Number of parameters to get covariance matrix for #If you are going to use the output as a proposal density make sure #you have map_params = F, and the dimension equal to the number of MCMC parameters ! cov_matrix_dimension = 19 #e.g. colormap('jet') matlab_colscheme = *************** *** 103,135 **** #w lab7 = ! lab8 = n_s ! #n_t ! lab9 = ! lab10 = n_{run} ! #markerx adds vertical line to MatLab 1D plot ! #marker10 = 0 ! ! lab11 = log[10^{10} A_s] ! #amp ratio ! lab12 = r ! lab13 = A_{SZ} ! ! lab14 = \Omega_\Lambda ! lab15 = Age/GYr ! lab16 = \Omega_m ! lab17 = \sigma_8 ! lab18 = z_{re} #r_{10} ! lab19 = ! lab20 = H_0 #Need to give limits if prior cuts off distribution where not very small limits4 = 0.01 N limits6 = 0 N limits7 = -1 N ! limits12 = 0 N ! limits13 = 0 2 #all_limits sets all limitsxx for all variables to the same; can be useful for bins all_limits = --- 103,156 ---- #w lab7 = ! #initial conformal factor in the Einstein frame ! lab8 = A_{ini} ! ! #initial field value ! lab9 = \kappa \chi_{ini} ! ! #field potential parameters ! lab10 = p ! lab11 = \mu ! lab12 = \nu ! lab13 = q ! ! #reheating parameter ! lab14 = ln R ! ! #bound on field values ! lab15 = \chi_{uv} ! ! #force inflation to stop ! lab16 = \chi_{stop} ! ! lab17 = ln(10^{10} P_*) ! lab18 = ! lab19 = A_{SZ} ! ! lab20 = \Omega_\Lambda ! lab21 = Age/GYr ! lab22 = \Omega_m ! lab23 = \sigma_8 ! lab24 = z_{re} #r_{10} ! lab25 = ! lab26 = H_0 ! ! #Derived parameters ! lab27 = log M ! #ln(a_{end}/a_{reh}) - 1/4 ln(\rho_{reh}/\rho_{end}) ! lab28 = ln R_{rad} ! lab29 = ln(a_0/a_{end}) ! lab30 = ln(\kappa^4 \rho_{end}) #Need to give limits if prior cuts off distribution where not very small limits4 = 0.01 N limits6 = 0 N limits7 = -1 N ! limits10 = 0.1 10 ! limits11 = 1 N ! #all_limits sets all limitsxx for all variables to the same; can be useful for bins all_limits = diff -c -b -B -r -N cosmomc/params.ini cosmomc_fields/params.ini *** cosmomc/params.ini 2008-03-07 19:11:58.000000000 +0100 --- cosmomc_fields/params.ini 2008-04-29 20:30:44.000000000 +0200 *************** *** 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 *************** *** 58,75 **** #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 --- 58,75 ---- #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 *************** *** 126,137 **** #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) --- 126,137 ---- #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) *************** *** 143,148 **** --- 143,151 ---- #(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 *************** *** 174,189 **** #w param7 = -1 -1 -1 0 0 ! #n_s ! param8 = 0.95 0.5 1.5 0.02 0.01 ! #n_t param9 = 0 0 0 0 0 - #n_run - param10 = 0 0 0 0 0 ! #log[10^10 A_s] ! param11 = 3 2.7 4 0.01 0.01 ! #amp_ratio param12 = 0 0 0 0 0 #SZ amplitude, as in WMAP analysis ! param13 = 1 0 2 0.4 0.4 --- 177,211 ---- #w param7 = -1 -1 -1 0 0 ! #initial field values ! #dilaton ! param8 = 1 1 1 0 0 ! #matter field X (0 to use guessed values) param9 = 0 0 0 0 0 ! #potential parameters: mu = nu = 0 for large fields ! #p ! param10 = 2 2 2 0 0 ! #mu ! param11 = 0 0 0 0 0 ! #nu param12 = 0 0 0 0 0 + #q + param13 = 1 1 1 0 0 + + #reheating correction + #ln(aend/areh) + 1/4 ln(1/rhoreh) - 1/2 ln(1/rhoend) + param14 = 0 -46 15 10 10 + + #bound on field values (need checkBound=T) + param15 = 0 0 0 0 0 + + #end field values (needs checkStop=T) + param16 = 0 0 0 0 0 + + #ln[Pstar/cl_norm] + param17 = 3.1 2.7 4 0.4 0.1 + #amp_ratio + param18 = 1 1 1 0 0 #SZ amplitude, as in WMAP analysis ! param19 = 1 0 2 0.4 0.4 diff -c -b -B -r -N cosmomc/source/CMB_Cls_simple.f90 cosmomc_fields/source/CMB_Cls_simple.f90 *** cosmomc/source/CMB_Cls_simple.f90 2008-03-13 20:19:20.000000000 +0100 --- cosmomc_fields/source/CMB_Cls_simple.f90 2008-04-29 20:31:06.000000000 +0200 *************** *** 99,106 **** !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 --- 99,111 ---- !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 *************** *** 173,180 **** Threadnum =num_threads call CMBToCAMB(CMB, P) P%OnlyTransfers = .false. ! call SetCAMBInitPower(P,CMB,1) ! MatterOnly = .false. if (DoPk) then P%WantTransfer = .true. --- 178,190 ---- 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. *************** *** 347,352 **** --- 357,366 ---- 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 diff -c -b -B -r -N cosmomc/source/driver.F90 cosmomc_fields/source/driver.F90 *** cosmomc/source/driver.F90 2008-04-04 10:55:33.000000000 +0200 --- cosmomc_fields/source/driver.F90 2008-04-29 20:31:50.000000000 +0200 *************** *** 53,64 **** #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') --- 53,72 ---- #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') *************** *** 80,86 **** 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. --- 88,96 ---- 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 -c -b -B -r -N cosmomc/source/Makefile cosmomc_fields/source/Makefile *** cosmomc/source/Makefile 2008-03-13 20:21:49.000000000 +0100 --- cosmomc_fields/source/Makefile 2008-04-29 21:21:06.000000000 +0200 *************** *** 1,138 **** ! #You may need to edit the library paths for MKL for Intel ! #Beware of using optmizations that lose accuracy - may give errors when running ! #Edit for CFITSIO directories ! cfitsio = /usr/local/cfitsio/intel10/64/3.040/lib ! #/usr/local/Cluster-Users/cpac/cmb/2.1.0/cfitsio ! ! WMAP = /home/aml1005/WMAP5/likelihood_v3 ! ! 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/9.0.018/lib/em64t -lmkl_lapack -lmkl -lguide -lpthread ! #INCLUDE= ! ! # Use with Intel 9 on the Altix (eg. COSMOS) [this is old] ! # (do "module load icomp90" before compiling, or add to .bashrc) ! #F90C = ifort ! #FFLAGS = -O3 -w -fpp2 -DMPI ! #LAPACKL = -lscs -lguide -lmpi -ldl ! ! #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 ! ! #Intel fortran 8 on COSMOS ! #F90C = ifort ! #FFLAGS = -O2 -Vaxlib -W0 -WB -openmp -fpp2 -lmpi -lscs -ldl -DMPI ! #LAPACKL = -L/opt/intel/mkl80/lib/64 -lmkl_lapack -lmkl_ipf -limf ! ! #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 ! ! #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 = gfc ! #FFLAGS = -O2 -ffree-form ! #LAPACKL = -Wl,-framework -Wl,accelerate ! ! #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 ! ! #Sun, single processor: ! #F90C = f90 ! #FFLAGS = -fast -ftrap=%none ! #LAPACKL = -lsunperf -lfsu ! #LAPACKL = -lsunperf -lfsu -lsocket -lm ! #IFLAG = -M ! ! #Sun MPI ! #F90C = mpf90 ! #FFLAGS = -O4 -openmp -ftrap=%none -dalign -DMPI ! #LAPACKL = -lsunperf -lfsu -lmpi_mt ! #IFLAG = -M ! ! #Sun parallel enterprise: ! #F90C = f95 ! #FFLAGS = -O4 -xarch=native64 -openmp -ftrap=%none ! #LAPACKL = -lsunperf -lfsu ! #IFLAG = -M ! ! ! #IBM XL Fortran, multi-processor (run "module load lapack" then run "gmake") ! # See also http://cosmocoffee.info/viewtopic.php?t=326 ! #F90C = xlf90_r $(LAPACK) ! #FFLAGS = -WF,-DIBMXL -qsmp=omp -qsuffix=f=f90:cpp=F90 -O3 -qstrict -qarch=pwr3 -qtune=pwr3 ! #INCLUDE = -lessl ! #LAPACKL = PROPOSE = propose.o CLSFILE = CMB_Cls_simple.o - #Can use params_H if you prefer more generic parameters PARAMETERIZATION = params_CMB.o ! WMAP_inc = $(IFLAG)$(cfitsio)/include $(IFLAG)$(WMAP) ! WMAP_lib = -L$(cfitsio)/lib -L$(WMAP) -lcfitsio ! CLSLIB = $(WMAP_lib) -L../camb -lcamb $(LAPACKL) ! F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(WMAP_inc) $(IFLAG)../camb $(INCLUDE) DISTFILES = utils.o Matrix_utils.o settings.o GetDist.o ! WMAPOBJS = $(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 OBJFILES= $(WMAPOBJS) utils.o Matrix_utils.o settings.o cmbtypes.o Planck_like.o \ cmbdata.o WeakLen.o mpk.o supernovae.o SDSSLy-a-v3.o\ $(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \ conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o ! default: cosmomc ! all : cosmomc getdist settings.o: utils.o cmbtypes.o: settings.o --- 1,92 ---- ! # >>> DESIGNED FOR GMAKE <<< ! # Unified Systems makefile for COSMOMC ! # Add FLAGS -DMPI for using MPI ! ! ext=$(shell uname | cut -c1-3) ! ! ifeq ($(ext),IRI) ! F90C= f90 ! FFLAGS= -Ofast -mp -n32 -LANG:recursive=ON -lmpi -DMPI ! WMAPFLAGS= $(FFLAGS) ! LAPACKL = -lcomplib.sgimath_mp ! INCLUDE = -I../camb ! CFITSIODIR = /people/ringeval/usr ! endif ! ! ifeq ($(ext),Lin) ! F90C=ifort ! FFLAGS= -O -openmp -fpp ! WMAPFLAGS= -O -fpp ! LAPACKL = -L/opt/intel/mkl/9.1/lib/64 -lmkl -lmkl_lapack ! INCLUDE = -I../camb ! CFITSIODIR = /opt/intel/cfitsio ! 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 = ! endif ! ! ifeq ($(ext),Sun) ! F90C=f90 ! FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none ! WMAPFLAGS= $(FFLAGS) ! LAPACKL = -lsunperf -lfsu ! INCLUDE = -I../camb -M../camb ! CFITSIODIR = ! 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 = ! endif ! ! ! WMAPDIR = ../WMAP PROPOSE = propose.o CLSFILE = CMB_Cls_simple.o PARAMETERIZATION = params_CMB.o ! WMAPINCLUDE = -I$(CFITSIODIR)/include ! CLSLIB = -L$(CFITSIODIR)/lib -L../camb -lcamb -linf -lcfitsio $(LAPACKL) ! F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(INCLUDE) DISTFILES = utils.o Matrix_utils.o settings.o GetDist.o ! 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 OBJFILES= $(WMAPOBJS) utils.o Matrix_utils.o settings.o cmbtypes.o Planck_like.o \ cmbdata.o WeakLen.o mpk.o supernovae.o SDSSLy-a-v3.o\ $(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \ conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o ! default: cosmomc.$(ext) ! all : cosmomc.$(ext) getdist.$(ext) settings.o: utils.o cmbtypes.o: settings.o *************** *** 156,161 **** --- 110,121 ---- .f.o: f77 $(F90FLAGS) -c $< + %.o: $(WMAPDIR)/%.f90 + $(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $< + + %.o: $(WMAPDIR)/%.F90 + $(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $< + %.o: %.f90 $(F90C) $(F90FLAGS) -c $*.f90 *************** *** 163,174 **** $(F90C) $(F90FLAGS) -c $*.F90 ! cosmomc: $(OBJFILES) ../camb/libcamb.a ! $(F90C) -o ../cosmomc $(OBJFILES) $(CLSLIB) $(F90FLAGS) clean: rm -f *.o *.mod *.d *.pc *.obj ../core ! getdist: $(DISTFILES) ! $(F90C) -o ../getdist $(DISTFILES) $(CLSLIB) $(F90FLAGS) --- 123,134 ---- $(F90C) $(F90FLAGS) -c $*.F90 ! cosmomc.$(ext): $(OBJFILES) ../camb/libcamb.a ! $(F90C) -o ../$@ $(OBJFILES) $(CLSLIB) $(F90FLAGS) clean: rm -f *.o *.mod *.d *.pc *.obj ../core ! getdist.$(ext): $(DISTFILES) ! $(F90C) -o ../$@ $(DISTFILES) $(CLSLIB) $(F90FLAGS) diff -c -b -B -r -N cosmomc/source/MCMC.f90 cosmomc_fields/source/MCMC.f90 *** cosmomc/source/MCMC.f90 2008-03-05 11:39:29.000000000 +0100 --- cosmomc_fields/source/MCMC.f90 2008-04-29 20:32:06.000000000 +0200 *************** *** 214,220 **** 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 --- 214,220 ---- 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 *************** *** 499,505 **** 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) --- 499,505 ---- 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) *************** *** 534,540 **** 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 --- 534,540 ---- 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 -c -b -B -r -N cosmomc/source/params_CMB.f90 cosmomc_fields/source/params_CMB.f90 *** cosmomc/source/params_CMB.f90 2008-04-04 10:55:33.000000000 +0200 --- cosmomc_fields/source/params_CMB.f90 2008-04-29 20:56:17.000000000 +0200 *************** *** 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) *************** *** 203,214 **** --- 248,265 ---- use settings use cmbtypes use ParamDef + !fields + use initialpower, only : exportinfprop,updateinfprop + !end fields implicit none Type(ParamSet) P real, intent(in) :: mult, like character(LEN =30) fmt Type(CMBParams) C real r10 + !fields + type(exportinfprop) :: infExport + !end fields if (outfile_unit ==0) return *************** *** 227,237 **** r10 = 0 end if ! fmt = trim(numcat('(2E16.7,',num_params))//'E16.7,7E16.7)' write (outfile_unit,fmt) mult,like, P%P, C%omv,P%Info%Theory%Age, C%omdm+C%omb, & ! P%Info%Theory%Sigma_8, C%zre,r10,C%H0 end if if (flush_write) call FlushFile(outfile_unit) end subroutine WriteParams --- 278,306 ---- r10 = 0 end if ! !fields ! ! fmt = trim(numcat('(2E16.7,',num_params))//'E16.7,7E16.7)' ! ! write (outfile_unit,fmt) mult,like, P%P, C%omv,P%Info%Theory%Age, C%omdm+C%omb, & ! ! P%Info%Theory%Sigma_8, C%zre,r10,C%H0 ! ! call UpdateInfProp(infExport) ! ! fmt = trim(numcat('(2E16.7,',num_params))//'E16.7,11E16.7)' write (outfile_unit,fmt) mult,like, P%P, C%omv,P%Info%Theory%Age, C%omdm+C%omb, & ! P%Info%Theory%Sigma_8, C%zre,r10,C%H0 & ! ! ,log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) & ! ,P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd & ! ,infExport%efoldEndToToday & ! ,infExport%lnEnergyEnd ! ! !end fields ! end if + + + if (flush_write) call FlushFile(outfile_unit) end subroutine WriteParams *************** *** 243,254 **** --- 312,329 ---- use settings use cmbtypes use ParamDef + !fields + use initialpower, only : exportinfprop,updateinfprop + !end fields implicit none Type(ParamSet) P real, intent(in) :: mult, like character(LEN =30) fmt Type(CMBParams) C real r10 + !fields + type(exportinfprop) :: infExport + !end fields if (outfile_unit ==0) return call ParamsToCMBParams(P%P,C) *************** *** 258,267 **** else r10 = 0 end if ! fmt = trim(numcat('(2E16.7,',num_params+num_matter_power))//'E16.7,7E16.7)' write (outfile_unit,fmt) mult,like, P%P, C%omv,P%Info%Theory%Age, C%omdm+C%omb, & ! P%Info%Theory%Sigma_8, C%zre,r10,C%H0, P%Info%Theory%matter_power(:,1) if (flush_write) call FlushFile(outfile_unit) --- 333,355 ---- else r10 = 0 end if + !fields + ! fmt = trim(numcat('(2E16.7,',num_params+num_matter_power))//'E16.7,7E16.7)' + ! write (outfile_unit,fmt) mult,like, P%P, C%omv,P%Info%Theory%Age, C%omdm+C%omb, & + ! P%Info%Theory%Sigma_8, C%zre,r10,C%H0, P%Info%Theory%matter_power(:,1) + + call UpdateInfProp(infExport) ! fmt = trim(numcat('(2E16.7,',num_params))//'E16.7,11E16.7)' write (outfile_unit,fmt) mult,like, P%P, C%omv,P%Info%Theory%Age, C%omdm+C%omb, & ! P%Info%Theory%Sigma_8, C%zre,r10,C%H0 & ! ! ,log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) & ! ,P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd & ! ,infExport%efoldEndToToday & ! ,infExport%lnEnergyEnd ! ! !end fields if (flush_write) call FlushFile(outfile_unit) diff -c -b -B -r -N cosmomc/source/settings.f90 cosmomc_fields/source/settings.f90 *** cosmomc/source/settings.f90 2008-04-04 10:55:34.000000000 +0200 --- cosmomc_fields/source/settings.f90 2008-04-29 20:32:16.000000000 +0200 *************** *** 5,10 **** --- 5,11 ---- 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) *************** *** 13,19 **** !num_hard is the number of 'hard' parameters integer, parameter :: num_hard =7 ! integer, parameter :: num_initpower = 3 integer, parameter :: num_norm = 3 !Should be 2 or larger (scale for the scalar Cl, and the T/S ratio --- 14,22 ---- !num_hard is the number of 'hard' parameters integer, parameter :: num_hard =7 ! !fields ! integer, parameter :: num_initpower = 9 ! !end fields integer, parameter :: num_norm = 3 !Should be 2 or larger (scale for the scalar Cl, and the T/S ratio *************** *** 48,53 **** --- 51,59 ---- integer :: num_threads = 0 integer :: instance = 0 + !addon + integer :: instance_shift = 0 + !end addon integer :: MPIchains = 1, MPIrank = 0 logical :: Use_LSS = .true.