diff -r -c -b -B -N cosmomc/camb/cmbmain.f90 cosmomc_fields/camb/cmbmain.f90
*** cosmomc/camb/cmbmain.f90	2011-07-11 18:00:59.000000000 +0200
--- cosmomc_fields/camb/cmbmain.f90	2011-08-02 16:13:34.311021268 +0200
***************
*** 1938,1949 ****
           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
  
  
--- 1938,1954 ----
           integer, intent(in) :: numks, pix
           real(dl) pows(numks), ks(numks)
           integer i
! !fields
! !$omp parallel do &
! !$omp default(shared) &
! !$omp private(i) &
! !$omp schedule(dynamic)      
           do i = 1, numks
           !!change to vec...
              pows(i) =  ScalarPower(ks(i) ,pix)
           end do
! !$omp end parallel do
! !end fields
          end subroutine GetInitPowerArrayVec
  
  
***************
*** 1951,1961 ****
           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
  
  
--- 1956,1971 ----
           integer, intent(in) :: numks, pix
           real(dl) pows(numks), ks(numks)
           integer i
! !fields
! !$omp parallel do &
! !$omp default(shared) &
! !$omp private(i) &
! !$omp schedule(dynamic)     
           do i = 1, numks
              pows(i) =  TensorPower(ks(i) ,pix)
           end do
! !$omp end parallel do
! !end fields
          end subroutine GetInitPowerArrayTens
  
  
***************
*** 1971,1977 ****
  
  
           do pix=1,CP%InitPower%nn
! 
            do q_ix = 1, CTrans%q%npoints 
  
               if (CP%flat) then
--- 1981,1991 ----
  
  
           do pix=1,CP%InitPower%nn
! !field: calling ScalarPower is time consumming when it comes from inflation code. Better to parallelise
! !$omp parallel do &
! !$omp default(shared) &
! !$omp private(q_ix) &
! !$omp schedule(dynamic,1)
            do q_ix = 1, CTrans%q%npoints 
  
               if (CP%flat) then
***************
*** 1986,1992 ****
  
        
            end do
! 
  
          !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) &
          !$OMP & PRIVATE(j,q_ix,dlnk,apowers,ctnorm,dbletmp)
--- 2000,2007 ----
  
        
            end do
! !$omp end parallel do
! !end field
  
          !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) &
          !$OMP & PRIVATE(j,q_ix,dlnk,apowers,ctnorm,dbletmp)
diff -r -c -b -B -N cosmomc/camb/inidriver.F90 cosmomc_fields/camb/inidriver.F90
*** cosmomc/camb/inidriver.F90	2011-07-01 15:53:23.000000000 +0200
--- cosmomc_fields/camb/inidriver.F90	2011-08-02 16:13:48.260364016 +0200
***************
*** 316,321 ****
--- 316,325 ----
  
          call CAMB_cleanup             
    
+ !fields
+         call FreePowers(P%InitPower) 
+ !end fields             
+   
          end program driver
  
  
diff -r -c -b -B -N cosmomc/camb/Makefile cosmomc_fields/camb/Makefile
*** cosmomc/camb/Makefile	2011-07-11 18:00:59.000000000 +0200
--- cosmomc_fields/camb/Makefile	2011-08-02 16:52:15.921726031 +0200
***************
*** 1,77 ****
! #CAMB Makefile
  
! #Set FISHER=Y to compile bispectrum fisher matrix code
! FISHER=
  
! #Edit for your compiler
! #Note there are many ifc versions, some of which behave oddly
  
! #Intel , -openmp toggles mutli-processor:
! #note version 10.0 gives wrong result for lensed when compiled with -openmp [fixed in 10.1]
! F90C     = ifort
! FFLAGS = -openmp -O2 -ip -W0 -WB -fpp2 -vec_report0
! ifneq ($(FISHER),)
! FFLAGS += -mkl
  endif
  
! #Intel ifc, add -openmp for multi-processor (some have bugs):
! #F90C     = ifc
! #FFLAGS = -O2 -Vaxlib -ip -W0 -WB -quiet -fpp2
! #some systems can can also add e.g. -tpp7 -xW
! 
! #G95 compiler
! #F90C   = g95
! #FFLAGS = -O2
! 
! #Gfortran compiler: if pre v4.3 add -D__GFORTRAN__
! #F90C     = gfortran
! #FFLAGS =  -O2  
! 
! #SGI, -mp toggles multi-processor. Use -O2 if -Ofast gives problems.
! #F90C     = f90
! #FFLAGS  = -Ofast -mp
! 
! #Digital/Compaq fortran, -omp toggles multi-processor
! #F90C    = f90
! #FFLAGS  = -omp -O4 -arch host -math_library fast -tune host -fpe1
! 
! #Absoft ProFortran, single processor:
! #F90C     = f95
! #FFLAGS = -O2 -cpu:athlon -s -lU77 -w -YEXT_NAMES="LCS" -YEXT_SFX="_"
! 
! #NAGF95, single processor:
! #F90C     = f95
! #FFLAGS = -DNAGF95 -O3
! 
! #PGF90
! #F90C = pgf90
! #FFLAGS = -O2 -DESCAPEBACKSLASH
! 
! #Sun V880
! #F90C = mpf90
! #FFLAGS =  -O4 -openmp -ftrap=%none -dalign -DMPI
! 
! #Sun parallel enterprise:
! #F90C     = f95
! #FFLAGS =  -O2 -xarch=native64 -openmp -ftrap=%none
! #try removing -openmp if get bus errors. -03, -04 etc are dodgy.
! 
! #IBM XL Fortran, multi-processor (run gmake)
! #F90C     = xlf90_r
! #FFLAGS  = -DESCAPEBACKSLASH -DIBMXL -qsmp=omp -qsuffix=f=f90:cpp=F90 -O3 -qstrict -qarch=pwr3 -qtune=pwr3
  
  #Settings for building camb_fits
  #Location of FITSIO and name of library
! FITSDIR       = /home/cpac/cpac-tools/lib
  FITSLIB       = cfitsio
  #Location of HEALPIX for building camb_fits
! HEALPIXDIR    = /home/cpac/cpac-tools/healpix
  
! ifneq ($(FISHER),)
! FFLAGS += -DFISHER
  EXTCAMBFILES = Matrix_utils.o
! else
! EXTCAMBFILES = 
! endif
  
- include ./Makefile_main
\ No newline at end of file
--- 1,130 ----
! # >>> DESIGNED FOR GMAKE <<<
! #CAMB System unified Makefile
  
! ext=$(shell uname | cut -c1-3)
  
! ifeq ($(ext),IRI)
! F90C=f90
! FFLAGS = -Ofast=ip35 -n32
! LFLAGS= -llapack
! endif
! 
! ifeq ($(ext),Lin)
! F90C=gfortran
! FFLAGS= -O -fopenmp #-DMPI
! LFLAGS= -llapack
! endif 
! 
! ifeq ($(ext),OSF)
! F90C=f90
! FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1
! LFLAGS= -llapack
! endif
! 
! ifeq ($(ext),Sun)
! F90C=f90
! FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none
! LFLAGS= -llapack
! endif
  
! ifeq ($(ext),AIX)
! F90C=xlf90_r
! FFLAGS= -O4 -q64 -qsmp=omp -qmaxmem=-1 -qstrict -qfree=f90 -qsuffix=f=f90:cpp=F90
! LFLAGS= -llapack
  endif
  
! 
! #Files containing evolution equations initial power spectrum module
! EQUATIONS     = equations
! POWERSPECTRUM = power_inf
! REIONIZATION = reionization
! RECOMBINATION = recfast
! BISPECTRUM = SeparableBispectrum
! 
! #inf module
! INFDIR	     = ../fieldinf
! INFOBJ       = infprec.o binfspline.o hyper2F1.o specialinf.o infinout.o inftools.o infbgmodel.o infsrmodel.o infbg.o infbgspline.o cosmopar.o inftorad.o infpert.o infpowspline.o
! 
! #Module doing non-linear scaling
! NONLINEAR     = halofit
! 
! #Driver program
! DRIVER        = inidriver.F90
! #DRIVER        = sigma8.f90
! #DRIVER        = tester.f90
  
  #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
  EXTCAMBFILES  = Matrix_utils.o
! INFLIB	      = libinf.a
! 
! #Shouldn't need to change anything else...
! 
! F90FLAGS      = $(FFLAGS) -DPP5
! HEALPIXLD     = -L$(HEALPIXDIR)/lib -lhealpix -L$(FITSDIR) -l$(FITSLIB)
! FC            = $(F90C)
! 
! CAMBOBJ       = constants.o utils.o subroutines.o inifile.o $(POWERSPECTRUM).o\
! 	$(RECOMBINATION).o $(REIONIZATION).o modules.o \
! 	bessels.o $(EQUATIONS).o $(NONLINEAR).o lensing.o $(BISPECTRUM).o \
! 	cmbmain.o camb.o
! 
! 
! default: camb.$(ext)
! 
! all: camb.$(ext) $(CAMBLIB) $(INFLIB)
! 
! 
! subroutines.o: constants.o utils.o
! $(POWERSPECTRUM): subroutines.o  inifile.o
! $(RECOMBINATION).o: subroutines.o inifile.o
! $(REIONIZATION).o: constants.o inifile.o
! modules.o: $(REIONIZATION).o $(POWERSPECTRUM).o $(RECOMBINATION).o
! bessels.o: modules.o
! $(EQUATIONS): bessels.o
! $(NONLINEAR).o:  modules.o
! lensing.o: bessels.o
! $(BISPECTRUM).o: lensing.o modules.o
! cmbmain.o: lensing.o $(NONLINEAR).o $(EQUATIONS).o $(BISPECTRUM).o
! camb.o: cmbmain.o
! Matrix_utils.o: utils.o
! 
! camb.$(ext): $(INFOBJ) $(CAMBOBJ) $(DRIVER)
! 	$(F90C) $(F90FLAGS) $(INFOBJ) $(CAMBOBJ) $(DRIVER) $(LFLAGS) -o $@
! 
! $(CAMBLIB): $(CAMBOBJ)
! 	ar -r $@ $?
! 
! $(INFLIB): $(INFOBJ)
! 	ar -r $@ $?
! 
! camb_fits.$(ext): writefits.f90 $(CAMBOBJ) $(DRIVER)
! 	$(F90C) $(F90FLAGS) -I$(HEALPIXDIR)/include $(CAMBOBJ) writefits.f90 $(DRIVER) $(HEALPIXLD) $(LFLAGS) -DWRITE_FITS -o $@
! 
! %.o: %.f90
! 	$(F90C) $(F90FLAGS) -c $<
! 
! %.o: $(INFDIR)/%.f90
! 	$(F90C) $(F90FLAGS) -c $<
! 
! %.o: $(INFDIR)/%.F90
! 	$(F90C) $(F90FLAGS) -c $<
! 
! utils.o:
! 	$(F90C) $(F90FLAGS) -c utils.F90	
! 
! $(BISPECTRUM).o:
! 	$(F90C) $(F90FLAGS) -c $(BISPECTRUM).F90	
! 
! Matrix_utils.o:
! 	$(F90C) $(F90FLAGS) -c Matrix_utils.F90	
! clean:
! 	-rm -f *.o *.a *.d core *.mod
! 
  
diff -r -c -b -B -N cosmomc/camb/params.ini cosmomc_fields/camb/params.ini
*** cosmomc/camb/params.ini	2011-07-06 12:40:42.000000000 +0200
--- cosmomc_fields/camb/params.ini	2011-08-02 17:03:02.291366869 +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}
***************
*** 65,83 ****
  #Fraction of total omega_nu h^2 accounted for by each eigenstate, eg. 0.5 0.5
  nu_mass_fractions = 1
  
- #Initial power spectrum, amplitude, spectral index and running. Pivot k in Mpc^{-1}.
- initial_power_num         = 1
- pivot_scalar              = 0.05
- pivot_tensor              = 0.05
- scalar_amp(1)             = 2.1e-9
- scalar_spectral_index(1)  = 0.96
- scalar_nrun(1)            = 0
- tensor_spectral_index(1)  = 0
- #ratio is that of the initial tens/scal power spectrum amplitudes
- initial_ratio(1)          = 1
- #note vector modes use the scalar settings above
- 
- 
  #Reionization, ignored unless reionization = T, re_redshift measures where x_e=0.5
  reionization         = T
  
--- 65,70 ----
***************
*** 98,103 ****
--- 85,147 ----
  RECFAST_Heswitch = 6
  RECFAST_Hswitch  = T
  
+ #inflationary model parameters (see infbgmodel.f90)
+ #param(1)=M; param(2)=p; param(3)=nu; param(4)=mu, param(5)=q
+ #largef:      V = M^4 phi^p                              p > 0
+ #smallf:      V = M^4 [1 - (phi/mu)^p]                   p > 2
+ #hybrid:      V = M^4 [1 + (phi/mu)^p]
+ #runmas:      V = M^4 {1 + nu [1/p + ln(phi/mu)]phi^p}          
+ #kklmmt:      V = M^4 [1 - q (phi/mu)^-p]^q              p > 0; q=+-1   
+ 
+ #number of read parameters
+ inf_param_number     = 7
+ 
+ #should be consistent with the above defs
+ inf_model_name       = largef
+ inf_param(1)         = 2e-3
+ inf_param(2)         = 2
+ inf_param(3)         = 0
+ inf_param(4)         = 0
+ inf_param(5)         = 1
+ 
+ 
+ #Hard prior that reject models with field values greater that
+ #field_bound. May be used for keeping models out of the
+ #self-reproducing regime, or constrain the branes to be inside the
+ #throat. In unit of kappa
+ inf_check_bound      = F
+ inf_param(6)         = 0
+ 
+ 
+ #stops artificially inflation for this matter field value.  Unit of
+ #kappa for large field and running mass; unit of mu for small fields
+ #and kklmmt; unit of a maximal field value that gives 120 efolds of
+ #hybrid inflation
+ inf_check_stop       = F
+ inf_param(7)         = 0
+ 
+ #initial fields value. Unit of kappa for large field and running; unit
+ #of mu for small field, hybrid and kklmmt. For inf_matter = 0, uses
+ #a slow-roll approximation to guess the relevant values
+ inf_conform(1) = 1
+ inf_matter(1) = 0
+ 
+ #This is ln(aend/areh) - 1/4 ln(rhoreh kappa^4) + 1/2 ln(rhoend kappa^4)
+ inf_ln_reheat       = 0
+ 
+ 
+ #speed up A LOT the computations (only for featureless power spectra)
+ power_spectra_spline = T
+ 
+ #if false then every k required are computed from their quantum birth
+ #during the inflationary era. Otherwise, only a few of them are
+ #computed and the others interpolated. The following parameters set
+ #the range and number (ln=log base e)
+ spline_lnkmpc_min   = -14
+ spline_lnkmpc_max   = 0
+ spline_lnkmpc_num   = 12
+ 
+ 
  #Initial scalar perturbation mode (adiabatic=1, CDM iso=2, Baryon iso=3, 
  # neutrino density iso =4, neutrino velocity iso = 5) 
  initial_condition   = 1
diff -r -c -b -B -N cosmomc/distparams.ini cosmomc_fields/distparams.ini
*** cosmomc/distparams.ini	2010-04-06 14:59:50.000000000 +0200
--- cosmomc_fields/distparams.ini	2011-08-02 16:18:43.876436276 +0200
***************
*** 94,100 ****
  
  #Parameters to use. If zero use all parameters which have lables.
  plotparams_num = 0
! plotparams = omegabh2 omegadmh2 tau ns
  
  #Get set label to empty to not include a parameter in the parameter_names file
  #lab[asz]=
--- 94,100 ----
  
  #Parameters to use. If zero use all parameters which have lables.
  plotparams_num = 0
! plotparams = omegabh2 omegadmh2 tau ns p mu nu q lnR Xend Xstop lnA asz
  
  #Get set label to empty to not include a parameter in the parameter_names file
  #lab[asz]=
diff -r -c -b -B -N cosmomc/fieldinf/binfspline.f90 cosmomc_fields/fieldinf/binfspline.f90
*** cosmomc/fieldinf/binfspline.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/binfspline.f90	2006-03-31 18:55:57.000000000 +0200
***************
*** 0 ****
--- 1,524 ----
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ !
+ !
+ !   VERSION 2.2
+ !
+ !   f90 VERSION
+ !
+ !   This library contains routines for B-spline interpolation in
+ !   one, two, and three dimensions. Part of the routines are based
+ !   on the book by Carl de Boor: A practical guide to Splines (Springer,
+ !   New-York 1978) and have the same calling sequence and names as
+ !   the corresponding routines from the IMSL library. For documen-
+ !   tation see the additional files. NOTE: The results in the demo
+ !   routines may vary slightly on different architectures.
+ !
+ !   by W. Schadow 12/04/99
+ !   last changed by W. Schadow 07/28/2000
+ !
+ !
+ !   Wolfgang Schadow
+ !   TRIUMF
+ !   4004 Wesbrook Mall
+ !   Vancouver, B.C. V6T 2A3
+ !   Canada
+ !
+ !   email: schadow@triumf.ca  or  schadow@physik.uni-bonn.de
+ !
+ !   www  : http://www.triumf.ca/people/schadow
+ !
+ !
+ !
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ !
+ !
+ !   Copyright (C) 2000 Wolfgang Schadow
+ !
+ !   This library is free software; you can redistribute it and/or
+ !   modify it under the terms of the GNU Library General Public
+ !   License as published by the Free Software Foundation; either
+ !   version 2 of the License, or (at your option) any later version.
+ !
+ !   This library is distributed in the hope that it will be useful,
+ !   but WITHOUT ANY WARRANTY; without even the implied warranty of
+ !   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ !   Library General Public License for more details.
+ !
+ !   You should have received a copy of the GNU Library General Public
+ !   License along with this library; if not, write to the
+ !   Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ !   Boston, MA  02111-1307, USA.
+ !
+ !
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+ !infmod
+ !remove unused routines
+ !module numeric
+ 
+ !  integer, parameter :: sgl = kind(1.0)
+ !  integer, parameter :: dbl = kind(1.0d0)
+ 
+ !end module numeric
+ 
+ module numeric
+   use infprec
+   integer, parameter :: sgl = kind(1.0)
+   integer, parameter :: dbl = kp
+ end module numeric
+ !end infmod
+ 
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+ module bspline
+ 
+ !
+ !  ------------------------------------------------------------------
+ !
+ !
+ !   The following routines are included:
+ !
+ !            dbsnak
+ !
+ !            dbsint
+ !            dbsval
+ !            dbsder
+ !            dbs1gd
+ !
+ !            dbs2in
+ !            dbs2dr
+ !            dbs2vl
+ !            dbs2gd
+ !
+ !            dbs3in
+ !            dbs3vl
+ !            dbs3dr
+ !            dbs3gd
+ !
+ !  ------------------------------------------------------------------
+ !
+ 
+   private
+ 
+   public dbsnak
+   public dbsint, dbsval
+ 
+ 
+ contains
+ 
+ 
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+   subroutine dbsnak(nx,xvec,kxord,xknot)
+ 
+ !
+ !  Compute the `not-a-knot' spline knot sequence.
+ !  (see de Boor p. 167)
+ !
+ !   nx     - number of data points.  (input)
+ !   xvec   - array of length ndata containing the location of the
+ !            data points.  (input)
+ !   kxord  - order of the spline.  (input)
+ !   xknot  - array of length ndata+korder containing the knot
+ !            sequence.  (output)
+ !
+ 
+     use numeric
+ 
+     implicit none
+ 
+     integer, intent(in) :: nx, kxord
+ 
+     real(kind=dbl), dimension(nx), intent(in)        :: xvec
+     real(kind=dbl), dimension(nx+kxord), intent(out) :: xknot
+ 
+     real(kind=dbl) :: eps
+     integer        :: ix
+ 
+ !infmod
+ !    logical        :: first = .true.
+ !    save first,eps
+ 
+ 
+ !    if (first) then
+ !       first=.false.
+        eps = epsilon(1.0_dbl)
+ !       write(*,*) "subroutine dbsnak: "
+ !       write(*,*) "eps = ",eps
+ !    endif
+ !end infmod
+ 
+     if((kxord .lt. 0) .or. (kxord .gt. nx)) then
+        write(*,*) "subroutine dbsnak: error"
+        write(*,*) "0 <= kxord <= nx is required."
+        write(*,*) "kxord = ", kxord, " and nx = ", nx,  " is given."
+        stop
+     endif
+ 
+     do ix = 1, kxord
+        xknot(ix) = xvec(1)
+     end do
+ 
+     if(mod(kxord,2) .eq. 0) then
+        do ix = kxord+1, nx
+           xknot(ix) = xvec(ix-kxord/2)
+        end do
+     else
+        do ix = kxord+1, nx
+           xknot(ix) = 0.5_dbl * (xvec(ix-kxord/2) + xvec(ix-kxord/2-1))
+        end do
+     endif
+ 
+     do ix = nx+1, nx+kxord
+        xknot(ix) = xvec(nx) * (1.0_dbl + eps)
+     end do
+ 
+   end subroutine dbsnak
+ 
+ 
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+   subroutine dbsint(nx,xvec,xdata,kx,xknot,bcoef)
+ 
+ !
+ !  Computes the spline interpolant, returning the B-spline coefficients.
+ !  (see de Boor p. 204)
+ !
+ !   nx     - number of data points.  (input)
+ !   xvec   - array of length nx containing the data point
+ !            abscissas.  (input)
+ !   xdata  - array of length ndata containing the data point
+ !            ordinates.  (input)
+ !   kx     - order of the spline.  (input)
+ !            korder must be less than or equal to ndata.
+ !   xknot  - array of length nx+kx containing the knot
+ !            sequence.  (input)
+ !            xknot must be nondecreasing.
+ !   bscoef - array of length ndata containing the B-spline
+ !            coefficients.  (output)
+ !
+ 
+     use numeric
+ 
+     implicit none
+ 
+     integer, intent(in)                          :: nx, kx
+     real(kind=dbl), dimension(nx), intent(in)    :: xdata, xvec
+     real(kind=dbl), dimension(nx+kx), intent(in) :: xknot
+     real(kind=dbl), dimension(nx), intent(out)   :: bcoef
+ 
+     integer                                :: nxp1, kxm1, kpkm2, leftx, lenq
+     integer                                :: ix, ik,ilp1mx, jj, iflag
+     real(kind=dbl)                         :: xveci
+     real(kind=dbl), dimension((2*kx-1)*nx) :: work
+ 
+ 
+     nxp1  = nx + 1
+     kxm1  = kx - 1
+     kpkm2 = 2 * kxm1
+     leftx = kx
+     lenq  = nx * (kx + kxm1)
+ 
+     do ix = 1, lenq
+        work(ix) = 0.0_dbl
+     end do
+ 
+     do  ix = 1, nx
+        xveci  = xvec(ix)
+        ilp1mx = min0(ix+kx,nxp1)
+        leftx   = max0(leftx,ix)
+        if (xveci .lt. xknot(leftx)) goto 998
+ 30     if (xveci .lt. xknot(leftx+1)) go to 40
+        leftx = leftx + 1
+        if (leftx .lt. ilp1mx) go to 30
+        leftx = leftx - 1
+        if (xveci .gt. xknot(leftx+1)) goto 998
+ 40     call bsplvb (xknot,nx+kx,kx,1,xveci,leftx,bcoef)
+        jj = ix - leftx + 1 + (leftx - kx) * (kx + kxm1)
+        do ik = 1, kx
+           jj       = jj + kpkm2
+           work(jj) = bcoef(ik)
+        end do
+     end do
+ 
+     call banfac(work,kx+kxm1,nx,kxm1,kxm1,iflag)
+ 
+     if (iflag .ne. 1) then
+        write(*,*) "subroutine dbsint: error"
+        write(*,*) "no solution of linear equation system !!!"
+        stop
+     end if
+ 
+     do ix = 1, nx
+        bcoef(ix) = xdata(ix)
+     end do
+ 
+     call banslv(work,kx+kxm1,nx,kxm1,kxm1,bcoef)
+ 
+     return
+ 
+ 998 write(*,*) "subroutine dbsint:"
+     write(*,*) "xknot(ix) <= xknot(ix+1) required."
+     write(*,*) ix,xknot(ix),xknot(ix+1)
+ 
+     stop
+ 
+   end subroutine dbsint
+ 
+ 
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+   function dbsval(x,kx,xknot,nx,bcoef)
+ 
+ !
+ !  Evaluates a spline, given its B-spline representation.
+ !
+ !   x      - point at which the spline is to be evaluated.  (input)
+ !   kx     - order of the spline.  (input)
+ !   xknot  - array of length nx+kx containing the knot
+ !            sequence.  (input)
+ !            xknot must be nondecreasing.
+ !   nx     - number of B-spline coefficients.  (input)
+ !   bcoef  - array of length nx containing the B-spline
+ !            coefficients.  (input)
+ !   dbsval - value of the spline at x.  (output)
+ !
+ 
+     use numeric
+ 
+     implicit none
+ 
+     integer, intent(in)                          :: nx, kx
+     real(kind=dbl)                               :: dbsval
+     real(kind=dbl)                               :: x
+     real(kind=dbl), dimension(nx+kx), intent(in) :: xknot
+     real(kind=dbl), dimension(nx), intent(in)    :: bcoef
+ 
+     integer                       :: il, ik, ix, leftx
+     real(kind=dbl)                :: save1, save2
+     real(kind=dbl), dimension(kx) :: work, dl, dr
+ 
+ !
+ !     check if xknot(i) <= xknot(i+1) and calculation of i so that
+ !     xknot(i) <= x < xknot(i+1)
+ !
+ 
+     leftx = 0
+ 
+     do ix = 1,nx+kx-1
+        if (xknot(ix) .gt. xknot(ix+1)) then
+           write(*,*) "subroutine dbsval:"
+           write(*,*) "xknot(ix) <= xknot(ix+1) required."
+           write(*,*) ix,xknot(ix),xknot(ix+1)
+           stop
+        endif
+        if((xknot(ix) .le. x) .and. (x .lt. xknot(ix+1))) leftx = ix
+     end do
+ 
+     if(leftx .eq. 0) then
+        write(*,*) "subroutine dbsval:"
+        write(*,*) "ix with xknot(ix) <= x < xknot(ix+1) required."
+        write(*,*) "x = ", x
+        stop
+     endif
+ 
+     do ik = 1, kx-1
+        work(ik) = bcoef(leftx+ik-kx)
+        dl(ik)   = x - xknot(leftx+ik-kx)
+        dr(ik)   = xknot(leftx+ik) - x
+     end do
+ 
+     work(kx)  = bcoef(leftx)
+     dl(kx)    = x - xknot(leftx)
+ 
+     do ik = 1, kx-1
+        save2 = work(ik)
+        do il = ik+1, kx
+           save1 = work(il)
+           work(il) = (dl(il) * work(il) + dr(il-ik) * save2)                  &
+                &           / (dl(il) + dr(il - ik))
+           save2 = save1
+        end do
+     end do
+ 
+     dbsval = work(kx)
+ 
+   end function dbsval
+ 
+ 
+ 
+ 
+   subroutine bsplvb(t,n,jhigh,index,x,left,biatx)
+ 
+     use numeric
+ 
+     implicit none
+ 
+     integer, intent(in) :: n, jhigh, index, left
+ 
+     real(kind=dbl), intent(in)                    :: x
+     real(kind=dbl), dimension(n), intent(in)      :: t
+     real(kind=dbl), dimension(jhigh), intent(out) :: biatx
+ 
+     integer                          :: j = 1
+     integer                          :: i, jp1
+     real(kind=dbl)                   :: saved, term
+     real(kind=dbl), dimension(jhigh) :: dl, dr
+ 
+ 
+     if (index .eq. 1) then
+        j = 1
+        biatx(1) = 1.0_dbl
+        if (j .ge. jhigh) return
+     end if
+ 
+ 20  jp1 = j + 1
+ 
+     dr(j) = t(left+j) - x
+     dl(j) = x - t(left+1-j)
+     saved = 0._dbl
+ 
+     do i = 1, j
+        term     = biatx(i) / (dr(i) + dl(jp1-i))
+        biatx(i) = saved + dr(i) * term
+        saved    = dl(jp1-i) * term
+     end do
+ 
+     biatx(jp1) = saved
+     j          = jp1
+ 
+     if (j .lt. jhigh) go to 20
+ 
+   end subroutine bsplvb
+ 
+ 
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+   subroutine banfac(w,nroww,nrow,nbandl,nbandu,iflag)
+ 
+     use numeric
+ 
+     implicit none
+ 
+     integer, intent(in)                                  :: nroww,nrow
+     integer, intent(in)                                  :: nbandl,nbandu
+     integer, intent(out)                                 :: iflag
+     real(kind=dbl), dimension(nroww,nrow), intent(inout) :: w
+ 
+     real(kind=dbl) :: pivot, factor
+     integer        :: middle, nrowm1, jmax, kmax, ipk, midmk, i, j, k
+ 
+ 
+     iflag  = 1
+     middle = nbandu + 1
+     nrowm1 = nrow - 1
+ 
+     if (nrowm1 .lt. 0) goto 999
+     if (nrowm1 .eq. 0) goto 900
+     if (nrowm1 .gt. 0) goto 10
+ 
+ 10  if (nbandl .gt. 0) go to 30
+ 
+     do i = 1, nrowm1
+        if (w(middle,i) .eq. 0._dbl) go to 999
+     end do
+ 
+     go to 900
+ 
+ 30  if (nbandu .gt. 0) go to 60
+ 
+     do i = 1, nrowm1
+        pivot = w(middle,i)
+        if(pivot .eq. 0._dbl) go to 999
+        jmax = min0(nbandl, nrow - i)
+        do j = 1, jmax
+           w(middle+j,i) = w(middle+j,i) / pivot
+        end do
+     end do
+ 
+     return
+ 
+ 60  do i = 1, nrowm1
+        pivot = w(middle,i)
+        if (pivot .eq. 0._dbl) go to 999
+        jmax = min0(nbandl,nrow - i)
+        do j = 1,jmax
+           w(middle+j,i) = w(middle+j,i) / pivot
+        end do
+ 
+        kmax = min0(nbandu,nrow - i)
+ 
+        do k = 1, kmax
+           ipk    = i + k
+           midmk  = middle - k
+           factor = w(midmk,ipk)
+           do j = 1, jmax
+              w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i)                  &
+                   &              * factor
+           end do
+        end do
+     end do
+ 
+ 900 if (w(middle,nrow) .ne. 0._dbl) return
+ 999 iflag = 2
+ 
+   end subroutine banfac
+ 
+ 
+ ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ 
+ 
+   subroutine banslv(w,nroww,nrow,nbandl,nbandu,b)
+ 
+     use numeric
+ 
+     implicit none
+ 
+     integer, intent(in)                               :: nroww,nrow
+     integer, intent(in)                               :: nbandl,nbandu
+     real(kind=dbl), dimension(nroww,nrow), intent(in) :: w
+     real(kind=dbl), dimension(nrow), intent(inout)    :: b
+ 
+     integer :: middle, nrowm1, jmax, i, j
+ 
+     middle = nbandu + 1
+     if (nrow .eq. 1) goto 99
+     nrowm1 = nrow - 1
+     if (nbandl .eq. 0) goto 30
+ 
+     do i = 1, nrowm1
+        jmax = min0(nbandl, nrow - i)
+        do j = 1, jmax
+           b(i+j) = b(i+j) - b(i) * w(middle+j,i)
+        end do
+     end do
+ 
+ 30  if (nbandu .gt. 0)  goto 50
+ 
+     do i = 1, nrow
+        b(i) = b(i) / w(1,i)
+     end do
+ 
+     return
+ 
+ 50  do i = nrow, 2, -1
+        b(i) = b(i)/w(middle,i)
+        jmax = min0(nbandu,i-1)
+        do j = 1, jmax
+           b(i-j) = b(i-j) - b(i) * w(middle-j,i)
+        end do
+     end do
+ 
+ 99  b(1) = b(1) / w(middle,1)
+ 
+   end subroutine banslv
+ 
+ 
+ 
+ end module bspline
diff -r -c -b -B -N cosmomc/fieldinf/cosmopar.f90 cosmomc_fields/fieldinf/cosmopar.f90
*** cosmomc/fieldinf/cosmopar.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/cosmopar.f90	2010-09-21 14:36:13.000000000 +0200
***************
*** 0 ****
--- 1,18 ----
+ module cosmopar
+   use infprec, only : kp
+   implicit none
+   
+   public
+ 
+   real(kp), parameter :: HubbleSquareRootOf3OmegaRad = 7.4585d-63
+   real(kp), parameter :: HubbleSquareRootOf2OmegaRad = sqrt(2._kp/3._kp)*HubbleSquareRootOf3OmegaRad
+ 
+   real(kp), parameter :: lnMpcToKappa = 130.282_kp
+ !1MeV
+ !!  real(kp), parameter :: lnRhoNuc = -196.97
+ !10MeV
+   real(kp), parameter :: lnRhoNuc = -187.747
+ !100MeV
+ !!  real(kp), parameter :: lnRhoNuc = -178.55
+ 
+ end module cosmopar
diff -r -c -b -B -N cosmomc/fieldinf/hyper2F1.f90 cosmomc_fields/fieldinf/hyper2F1.f90
*** cosmomc/fieldinf/hyper2F1.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/hyper2F1.f90	2010-03-02 12:17:03.000000000 +0100
***************
*** 0 ****
--- 1,1871 ----
+ !============== START HYP_2F1 FILE ====================================
+ !
+ ! Gamma_inv denotes the entire inverse of the Gamma function.
+ ! F(z) means 2F1(a,b,c,z) with the a, b, c and z given as inputs 
+ ! in the routine.
+ !
+ ! Elementary functions and standard constants 
+ ! are defined in the module.
+ ! See N.J.~Higham, ``Accuracy and Stability of Numerical Algorithms'',
+ ! SIAM, Philadelphia, 1996 for expm1 implementation.
+ ! log1p follows instantly.
+ !
+ !----------------------------------------------------------------------
+ MODULE HYP_2F1_MODULE
+   !--------------------------------------------------------------------
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: PR=KIND(1.0D0),IPR=KIND(1)
+   REAL(PR)     :: EPS15=1.0D-15
+   REAL(PR)     :: ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,HALF=0.50D0
+   REAL(PR)     :: M_PI=3.14159265358979323846D0
+   REAL(PR)     :: M_PI_2=1.57079632679489661923D0
+   REAL(PR)     :: M_1_PI=0.31830988618379067154D0 
+ CONTAINS
+   !
+   FUNCTION INF_NORM(Z)
+     COMPLEX(PR),INTENT(IN) :: Z
+     REAL(PR)  :: INF_NORM
+     INF_NORM=MAX(ABS(REAL(Z,PR)),ABS(AIMAG(Z)))
+     RETURN
+   END FUNCTION INF_NORM
+   !
+   FUNCTION TANZ(Z)
+     COMPLEX(PR),INTENT(IN) :: Z
+     COMPLEX(PR) :: TANZ
+     TANZ=SIN(Z)/COS(Z)
+     RETURN
+   END FUNCTION TANZ
+   !
+   FUNCTION LOG1P(Z)
+     COMPLEX(PR),INTENT(IN) :: Z
+     REAL(PR) :: X,XP1,LOG1P_X
+     REAL(PR) :: Y,YX,YX2,YX2P1,LOG1P_YX2
+     REAL(PR) :: RE_LOG1P,IM_LOG1P
+     COMPLEX(PR) :: LOG1P
+     IF(INF_NORM(Z).LT.ONE) THEN
+        X = REAL(Z,PR); XP1 = X+ONE
+        IF(XP1.EQ.ONE) THEN
+           LOG1P_X = X
+        ELSE
+           LOG1P_X = LOG(XP1)*X/(XP1-ONE)
+        ENDIF
+        Y = AIMAG(Z)
+        YX = Y/XP1; YX2 = YX*YX; YX2P1 = YX2+ONE
+        IF(YX2P1.EQ.ONE) THEN
+           LOG1P_YX2 = YX2
+        ELSE
+           LOG1P_YX2 = LOG(YX2P1)*YX2/(YX2P1-ONE)
+        ENDIF
+        RE_LOG1P = LOG1P_X + HALF*LOG1P_YX2
+        IM_LOG1P = ATAN2(Y,XP1)
+        LOG1P = CMPLX(RE_LOG1P,IM_LOG1P,PR)
+        RETURN
+     ELSE
+        LOG1P=LOG(ONE+Z)
+        RETURN
+     ENDIF
+   END FUNCTION LOG1P
+   !
+   FUNCTION EXPM1(Z)
+     COMPLEX(PR),INTENT(IN) :: Z
+     REAL(PR) :: X,EXPM1_X,EXP_X,Y,SIN_HALF_Y
+     REAL(PR) :: RE_EXPM1,IM_EXPM1
+     COMPLEX(PR) :: EXPM1
+     IF(INF_NORM(Z).LT.ONE) THEN
+        X = REAL(Z,PR); EXP_X = EXP(X)
+        Y = AIMAG(Z); SIN_HALF_Y=SIN(HALF*Y)
+        IF(EXP_X.EQ.ONE) THEN
+           EXPM1_X = X
+        ELSE 
+           EXPM1_X = (EXP_X-ONE)*X/LOG(EXP_X)
+        ENDIF
+        RE_EXPM1 = EXPM1_X-TWO*EXP_X*SIN_HALF_Y*SIN_HALF_Y 
+        IM_EXPM1 = EXP_X*SIN(Y)
+        EXPM1 = CMPLX(RE_EXPM1,IM_EXPM1,PR)
+        RETURN
+     ELSE
+        EXPM1=EXP(Z)-ONE
+        RETURN
+     ENDIF
+   END FUNCTION EXPM1
+   !
+ END MODULE HYP_2F1_MODULE
+ !
+ !----------------------------------------------------------------------
+ 
+ RECURSIVE FUNCTION LOG_GAMMA_CPLX(Z) RESULT(RES)
+ !----------------------------------------------------------------------
+ ! Logarithm of Gamma[z] and Gamma inverse function
+ ! ------------------------------------------------
+ !
+ ! For log[Gamma[z]],if z is not finite 
+ ! or is a negative integer, the program 
+ ! returns an error message and stops.
+ ! The Lanczos method is used. Precision : ~ 1E-15
+ ! The method works for Re[z]>0.5 .
+ ! If Re[z]<=0.5, one uses the formula Gamma[z].Gamma[1-z]=Pi/sin(Pi.z)
+ ! log[sin(Pi.z)] is calculated with the Kolbig method 
+ ! (K.S. Kolbig, Comp. Phys. Comm., Vol. 4, p.221(1972)): 
+ ! If z=x+iy and y>=0, log[sin(Pi.z)]=log[sin(Pi.eps)]-i.Pi.n, 
+ ! with z=n+eps so 0<=Re[eps]< 1 and n integer.
+ ! If y>110, log[sin(Pi.z)]=-i.Pi.z+log[0.5]+i.Pi/2 
+ ! numerically so that no overflow can occur.
+ ! If z=x+iy and y< 0, log[Gamma(z)]=[log[Gamma(z*)]]*, 
+ ! so that one can use the previous formula with z*.
+ !
+ ! For Gamma inverse, Lanczos method is also used 
+ ! with Euler reflection formula.
+ ! sin (Pi.z) is calculated as sin (Pi.(z-n)) 
+ ! to avoid inaccuracy with z = n + eps 
+ ! with n integer and |eps| as small as possible.
+ !
+ !
+ ! Variables:
+ ! ----------
+ ! x,y: Re[z], Im[z]
+ ! log_sqrt_2Pi,log_Pi : log[sqrt(2.Pi)], log(Pi).
+ ! sum : Rational function in the Lanczos method
+ ! log_Gamma_z : log[Gamma(z)] value.
+ ! c : table containing the fifteen coefficients in the expansion 
+ ! used in the Lanczos method.
+ ! eps,n : z=n+eps so 0<=Re[eps]< 1 and n integer for Log[Gamma].
+ !         z=n+eps and n integer 
+ !         so |eps| is as small as possible for Gamma_inv.
+ ! log_const : log[0.5]+i.Pi/2
+ ! g : coefficient used in the Lanczos formula. It is here 607/128.
+ ! z,z_m_0p5,z_p_g_m0p5,zm1 : argument of the Gamma function, 
+ ! z-0.5, z-0.5+g, z-1 
+ ! res: returned value
+ !----------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: Z
+   INTEGER(IPR) :: N,I
+   REAL(PR)     :: X,Y,LOG_SQRT_2PI,G,LOG_PI,M_LN2,C(0:14)
+   COMPLEX(PR)  :: GAMMA_SUM,Z_M_0P5,Z_P_G_M0P5,ZM1
+   COMPLEX(PR)  :: LOG_CONST,I_PI,EPS,LOG_SIN_PI_Z,RES
+   !
+   M_LN2=0.69314718055994530942D0; X=REAL(Z,PR); Y=AIMAG(Z)
+   IF((Z.EQ.NINT(X)).AND.(X.LE.ZERO)) &
+        STOP 'Z IS NEGATIVE INTEGER IN LOG_GAMMA_CPLX'
+   IF(X.GE.HALF) THEN
+      LOG_SQRT_2PI=0.91893853320467274177D0; G=4.7421875D0
+      Z_M_0P5=Z-HALF; Z_P_G_M0P5=Z_M_0P5+G; ZM1=Z-ONE
+      C=(/ 0.99999999999999709182D0,57.156235665862923517D0,       &
+           -59.597960355475491248D0,  14.136097974741747174D0,     &
+           -0.49191381609762019978D0, 0.33994649984811888699D-4,   &
+           0.46523628927048575665D-4, -0.98374475304879564677D-4,  &
+           0.15808870322491248884D-3, -0.21026444172410488319D-3,  &
+           0.21743961811521264320D-3, -0.16431810653676389022D-3,  &
+           0.84418223983852743293D-4, -0.26190838401581408670D-4,  &
+           0.36899182659531622704D-5 /)
+ 
+      GAMMA_SUM=C(0)
+      DO I=1,14
+         GAMMA_SUM=GAMMA_SUM+C(I)/(ZM1+I)
+      ENDDO
+      RES=LOG_SQRT_2PI+LOG(GAMMA_SUM)+Z_M_0P5*LOG(Z_P_G_M0P5) &
+           -Z_P_G_M0P5
+      RETURN
+   ELSE IF(Y.GE.ZERO) THEN
+      IF(X.LT.NINT(X)) THEN
+         N=NINT(X)-1
+      ELSE
+         N=NINT(X)
+      ENDIF
+      LOG_PI=1.1447298858494002D0
+      LOG_CONST=CMPLX(-M_LN2,M_PI_2,PR); I_PI=CMPLX(ZERO,M_PI,PR)
+      EPS=Z-N
+      IF(Y.GT.110.0D0) THEN
+         LOG_SIN_PI_Z=-I_PI*Z+LOG_CONST
+      ELSE
+         LOG_SIN_PI_Z=LOG(SIN(M_PI*EPS))-I_PI*N
+      ENDIF
+      RES=LOG_PI-LOG_SIN_PI_Z-LOG_GAMMA_CPLX(ONE-Z);
+      RETURN
+   ELSE
+      RES=CONJG(LOG_GAMMA_CPLX(CONJG(Z)))
+      RETURN
+   ENDIF
+ END FUNCTION LOG_GAMMA_CPLX
+ !
+ !----------------------------------------------------------------------
+ ! Inverse of the Gamma function [1/Gamma](z)
+ ! ------------------------------------------
+ ! It is calculated with the Lanczos method for Re[z] >= 0.5 
+ ! and is precise up to 10^{-15}.
+ ! If Re[z] <= 0.5, one uses the formula 
+ ! Gamma[z].Gamma[1-z] = Pi/sin (Pi.z).
+ ! sin (Pi.z) is calculated as sin (Pi.(z-n)) to avoid inaccuracy,
+ ! with z = n + eps with n integer and |eps| as small as possible.
+ ! 
+ ! Variables 
+ ! ---------
+ ! z : argument of the function
+ ! x: Re[z]
+ ! eps,n : z = n + eps with n integer and |eps| as small as possible.
+ ! res: returned value
+ !----------------------------------------------------------------------
+ RECURSIVE FUNCTION GAMMA_INV(Z) RESULT(RES)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: Z
+   INTEGER(IPR) :: N,I
+   REAL(PR)     :: X,LOG_SQRT_2PI,G,C(0:14)
+   COMPLEX(PR)  :: RES,GAMMA_SUM,Z_M_0P5,Z_P_G_M0P5,ZM1,EPS
+   !
+   X=REAL(Z,PR)
+   IF(X.GE.HALF) THEN
+      LOG_SQRT_2PI=0.91893853320467274177D0; G=4.7421875D0
+      Z_M_0P5=Z-HALF; Z_P_G_M0P5=Z_M_0P5+G; ZM1=Z-ONE
+      C=(/ 0.99999999999999709182D0,57.156235665862923517D0,       &
+           -59.597960355475491248D0,  14.136097974741747174D0,     &
+           -0.49191381609762019978D0, 0.33994649984811888699D-4,   &
+           0.46523628927048575665D-4, -0.98374475304879564677D-4,  &
+           0.15808870322491248884D-3, -0.21026444172410488319D-3,  &
+           0.21743961811521264320D-3, -0.16431810653676389022D-3,  &
+           0.84418223983852743293D-4, -0.26190838401581408670D-4,  &
+           0.36899182659531622704D-5 /)
+ 
+      GAMMA_SUM=C(0)
+      DO I=1,14
+         GAMMA_SUM=GAMMA_SUM+C(I)/(ZM1+I);
+      ENDDO
+      RES=EXP(Z_P_G_M0P5-Z_M_0P5*LOG(Z_P_G_M0P5)-LOG_SQRT_2PI) &
+           /GAMMA_SUM
+      RETURN
+   ELSE
+      X=REAL(Z,PR); N=NINT(X)
+      EPS=Z-N
+      IF(MOD(N,2).EQ.0) THEN
+         RES=SIN(M_PI*EPS)*M_1_PI/GAMMA_INV (ONE-Z)
+         RETURN
+      ELSE
+         RES=-SIN(M_PI*EPS)*M_1_PI/GAMMA_INV (ONE-Z)
+         RETURN
+      ENDIF
+   ENDIF
+ END FUNCTION GAMMA_INV
+ !----------------------------------------------------------------------
+ !
+ ! Calculation of H(z,eps) = [Gamma(z+eps)/Gamma(z) - 1]/eps, with e and
+ ! ---------------------------------------------------------------------
+ ! z complex so z,z+eps are not negative integers and 0 <= |eps|oo < 0.1
+ ! ---------------------------------------------------------------------
+ ! The function H(z,eps) = [Gamma(z+eps)/Gamma(z) - 1]/e is calculated 
+ ! here with the Lanczos method.
+ ! For the Lanczos method, the gamma parameter, denoted as g, 
+ ! is 4.7421875 and one uses a sum of 15 numbers with the table c[15], 
+ ! so that it is precise up to machine accuracy.
+ ! The H(z,eps) function is used in formulas occuring in1-z and 1/z 
+ ! transformations (see Comp. Phys. Comm. paper).
+ !
+ ! One must have z and z+eps not negative integers as otherwise 
+ ! it is clearly not defined.
+ ! As this function is meant to be precise for small |eps|oo, 
+ ! one has to have 0 <= |eps|oo < 0.1 .
+ ! Indeed, a direct implementation of H(z,eps) with Gamma_inv or 
+ ! log_Gamma for |eps|oo >= 0.1 is numerically stable.
+ ! The returned function has full numerical accuracy 
+ ! even if |eps|oo is very small.
+ !
+ ! eps not equal to zero
+ ! ---------------------
+ ! If Re(z) >= 0.5 or Re(z+eps) >= 0.5, one clearly has Re(z) > 0.4 
+ ! and Re(z+eps) > 0.4, 
+ ! so that the Lanczos summation can be used for both Gamma(z) 
+ ! and Gamma(z+eps).
+ ! One then has:
+ ! log[Gamma(z+eps)/Gamma(z)] = 
+ ! (z-0.5) log1p[eps/(z+g-0.5)] + eps log(z+g-0.5+eps) - eps 
+ ! + log1p[-eps \sum_{i=1}^{14} c[i]/((z-1+i)(z-1+i+eps)) 
+ ! / (c[0] + \sum_{i=1}^{14} c[i]/(z-1+i))]
+ ! H(z,eps) = expm1[log[Gamma(z+eps)/Gamma(z)]]/eps .
+ !
+ ! If Re(z) < 0.5 and Re(z+eps) < 0.5, 
+ ! Euler reflection formula is used for both Gamma(z) and Gamma(z+eps).
+ ! One then has: 
+ ! H(z+eps,-eps) = [cos(pi.eps) + sin(pi.eps)/tan(pi(z-n))].H(1-z,-eps) 
+ ! + (2/eps).sin^2(eps.pi/2) - sin(pi.eps)/(eps.tan(pi.(z-n)))
+ ! H(1-z,-eps) is calculated with the Lanczos summation 
+ ! as Re(1-z) >= 0.5 and Re(1-z-eps) >= 0.5 .
+ ! z-n is used in tan(pi.z) instead of z to avoid inaccuracies 
+ ! due the finite number of digits of pi.
+ ! H(z,eps) = H(z+eps,-eps)/(1 - eps.H(z+eps,-eps)) 
+ ! provides the final result.
+ !
+ ! eps equal to zero
+ ! -----------------
+ ! It is obtained with the previous case and eps -> 0 :
+ ! If Re(z) >= 0.5, one has:
+ ! H(z,eps) = (z-0.5)/(z+g-0.5) + log(z+g-0.5) - 1 -
+ ! \sum_{i=1}^{14} c[i]/((z-1+i)^2)/(c[0]+\sum_{i=1}^{14} c[i]/(z-1+i))
+ !
+ ! If Re(z) < 0.5, one has:
+ ! H(z,0) = H(1-z,0) - pi/tan(pi.(z-n))
+ !
+ ! Variables
+ ! ---------
+ ! z,eps: input variables of the function H(z,eps)
+ ! g,c[15]: double and table of 15 doubles defining the Lanczos sum 
+ ! so that it provides the Gamma function 
+ ! precise up to machine accuracy.
+ ! eps_pz,z_m_0p5,z_pg_m0p5,eps_pz_pg_m0p5,zm1,zm1_p_eps: 
+ ! z+eps,z-0.5,z+g-0.5,z+eps+g-0.5,z-1,z-1+eps
+ ! x,eps_px: real parts of z and z+eps.
+ ! n,m: closest integer ot the real part of z, same for z+eps.
+ ! sum_num,sum_den: \sum_{i=1}^{14} c[i]/((z-1+i)(z-1+i+eps)) 
+ ! and (c[0] + \sum_{i=1}^{14} c[i]/(z-1+i)). 
+ ! They appear respectively as numerator and denominator in formulas.
+ ! Pi_eps,term,T1_eps_z: pi.eps, sin (pi.eps)/tan(pi.(z-n)), 
+ ! [cos(pi.eps) + sin(pi.eps)/tan(pi(z-n))].H(1-z,-eps)
+ ! sin_Pi_2_eps,T2_eps_z,T_eps_z: sin^2(eps.pi/2), 
+ ! (2/eps).sin^2(eps.pi/2) - sin(pi.eps)/(eps.tan(pi.(z-n))), 
+ ! H(z+eps,-eps)
+ ! res: returned value
+ !----------------------------------------------------------------------
+ RECURSIVE FUNCTION GAMMA_RATIO_DIFF_SMALL_EPS(Z,EPS) RESULT(RES)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: Z,EPS
+   INTEGER(IPR) :: N,M,I
+   REAL(PR)     :: G,X,EPS_PX,C(0:14)
+   COMPLEX(PR)  :: RES,SUM_NUM,SUM_DEN
+   COMPLEX(PR)  :: EPS_PZ,Z_M_0P5,Z_PG_M0P5,EPS_PZ_PG_M0P5,ZM1
+   COMPLEX(PR)  :: CI_ZM1_PI_INV,PI_EPS,TT,T1_EPS_Z,SIN_PI_2_EPS
+   COMPLEX(PR)  :: ZM1_P_EPS,T2_EPS_Z,T_EPS_Z
+   !
+   G=4.74218750D0
+   IF(INF_NORM(EPS).GT.0.1D0) &
+        STOP 'ONE MUST HAVE |EPS|< 0.1 IN GAMMA_RATIO_DIFF_SMALL_EPS'
+   EPS_PZ=Z+EPS; Z_M_0P5=Z-HALF; Z_PG_M0P5=Z_M_0P5+G
+   EPS_PZ_PG_M0P5=Z_PG_M0P5+EPS; ZM1=Z-ONE; ZM1_P_EPS=ZM1+EPS
+   X=REAL(Z,PR); EPS_PX=REAL(EPS_PZ,PR); N=NINT(X); M=NINT(EPS_PX)
+   IF((Z.EQ.N).AND.(N.LE.0)) THEN
+      STOP 'Z IS NEGATIVE INTEGER IN GAMMA_RATIO_DIFF_SMALL_EPS'
+   ENDIF
+   IF((EPS_PZ.EQ.M).AND.(M.LE.0)) THEN
+      STOP 'Z+EPS IS NEGATIVE INTEGER IN GAMMA_RATIO_DIFF_SMALL_EPS'
+   ENDIF
+   C=(/ 0.99999999999999709182D0,57.156235665862923517D0,     &
+        -59.597960355475491248D0,14.136097974741747174D0,     &
+        -0.49191381609762019978D0,0.33994649984811888699D-4,  &
+        0.46523628927048575665D-4,-0.98374475304879564677D-4, &
+        0.15808870322491248884D-3,-0.21026444172410488319D-3, &
+        0.21743961811521264320D-3,-0.16431810653676389022D-3, &
+        0.84418223983852743293D-4,-0.26190838401581408670D-4, &
+        0.36899182659531622704D-5 /)
+   IF((X.GE.HALF).OR.(EPS_PX.GE.HALF)) THEN
+      SUM_NUM=ZERO;SUM_DEN=C(0)
+      DO I=1,14
+         CI_ZM1_PI_INV=C(I)/(ZM1+I)
+         SUM_NUM=SUM_NUM+CI_ZM1_PI_INV/(ZM1_P_EPS+I)
+         SUM_DEN=SUM_DEN+CI_ZM1_PI_INV
+      ENDDO
+      IF(EPS.NE.ZERO) THEN
+         RES=EXPM1(Z_M_0P5*LOG1P(EPS/Z_PG_M0P5) &
+              +EPS*LOG(EPS_PZ_PG_M0P5)-EPS+LOG1P(-EPS*SUM_NUM/SUM_DEN))&
+              /EPS
+         RETURN
+      ELSE
+         RES=Z_M_0P5/Z_PG_M0P5 &
+              +LOG(EPS_PZ_PG_M0P5)-ONE-SUM_NUM/SUM_DEN
+         RETURN
+      ENDIF
+   ELSE
+      IF(EPS.NE.ZERO) THEN
+         PI_EPS=M_PI*EPS
+         TT=SIN(PI_EPS)/TANZ(M_PI*(Z-N))
+         T1_EPS_Z=(COS(PI_EPS)+TT)*& 
+              GAMMA_RATIO_DIFF_SMALL_EPS(ONE-Z,-EPS)
+         SIN_PI_2_EPS=SIN(M_PI_2*EPS)
+         T2_EPS_Z=(TWO*SIN_PI_2_EPS*SIN_PI_2_EPS-TT)/EPS
+         T_EPS_Z=T1_EPS_Z+T2_EPS_Z
+         RES=(T_EPS_Z/(ONE-EPS*T_EPS_Z))
+         RETURN
+      ELSE
+         RES=GAMMA_RATIO_DIFF_SMALL_EPS(ONE-Z,-EPS) &
+              -M_PI/TANZ(M_PI*(Z-N))
+         RETURN
+      ENDIF
+   ENDIF
+ END FUNCTION GAMMA_RATIO_DIFF_SMALL_EPS
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of G(z,eps) = [Gamma_inv(z) - Gamma_inv(z+eps)]/eps 
+ ! ---------------------------------------------------------------
+ ! with e and z complex
+ !---------------------
+ ! The G(z,eps) function is used in formulas occuring in 1-z 
+ ! and 1/z transformations (see Comp. Phys. Comm. paper).
+ ! Several case have to be considered for its evaluation. 
+ ! eps is considered equal to zero 
+ ! if z+eps and z are equal numerically.
+ !
+ ! |eps|oo > 0.1
+ ! -------------
+ ! A direct evaluation with the values Gamma_inv(z) 
+ ! and Gamma_inv(z+eps) is stable and returned.
+ !
+ ! |eps|oo <= 0.1 with z+eps and z numerically different
+ ! -----------------------------------------------------
+ ! If z is a negative integer, z+eps is not, 
+ ! so that G(z,eps) = -Gamma_inv(z+eps)/eps, 
+ ! for which a direct evaluation is precise and returned.
+ ! If z+eps is a negative integer, z is not, 
+ ! so that G(z,eps) = Gamma_inv(z)/eps, 
+ ! for which a direct evaluation is precise and returned.
+ ! If both of them are not negative integers, 
+ ! one looks for the one of z and z+eps 
+ ! which is the closest to a negative integer.
+ ! If it is z, one returns H(z,eps).Gamma_inv(z+eps). 
+ ! If it is z+eps, one returns H(z+eps,-eps).Gamma_inv(z).
+ ! Both values are equal, so that one chooses the one 
+ ! which makes the Gamma ratio Gamma(z+eps)/Gamma(z) 
+ ! in H(z,eps) the smallest in modulus.
+ !
+ ! z+eps and z numerically equal
+ ! -----------------------------
+ ! If z is negative integer, G(z,0) = (-1)^(n+1) n!, 
+ ! where z = -n, n integer, which is returned.
+ ! If z is not negative integer, one returns H(z,eps).Gamma_inv(z+eps)
+ !
+ ! Variables
+ ! ---------
+ ! z,eps: input variables of the function G(z,eps)
+ ! eps_pz,x,eps_px: z+eps,real parts of z and z+eps.
+ ! n,m: closest integer ot the real part of z, same for z+eps.
+ ! fact,k: (-1)^(n+1) n!, returned when z = -n, n integer 
+ ! and z and z+eps identical numerically (eps ~ 0). 
+ ! It is calculated with integer index k.
+ ! is_z_negative_integer,is_eps_pz_negative_integer: 
+ ! true if z is a negative integer, false if not, same for z+eps.
+ ! z_neg_int_distance, eps_pz_neg_int_distance: 
+ ! |z + |n||oo, |z + eps + |m||oo. 
+ ! If |z + |n||oo < |z + eps + |m||oo, 
+ ! z is closer to the set of negative integers than z+eps.
+ ! Gamma_inv(z+eps) is then of moderate modulus 
+ ! if Gamma_inv(z) is very small. 
+ ! If z ~ n, H(z,eps) ~ -1/eps, 
+ ! that so returning 
+ ! G(z,eps) = H(z,eps).Gamma_inv(z+eps) here is preferred.
+ ! Same for |z + |n||oo > |z + eps + |m||oo with z <-> z+eps.
+ !
+ !----------------------------------------------------------------------
+ FUNCTION GAMMA_INV_DIFF_EPS(Z,EPS)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: Z,EPS
+   INTEGER(IPR) :: M,N,K
+   REAL(PR)     :: X,EPS_PX,FACT
+   REAL(PR)     :: Z_NEG_INT_DISTANCE
+   REAL(PR)     :: EPS_PZ_NEG_INT_DISTANCE
+   COMPLEX(PR)  :: GAMMA_INV_DIFF_EPS,EPS_PZ,GAMMA_INV
+   COMPLEX(PR)  :: GAMMA_RATIO_DIFF_SMALL_EPS
+   LOGICAL      :: IS_Z_NEG_INT,IS_EPS_PZ_NEG_INT
+ 
+   EPS_PZ=Z+EPS; X=REAL(Z,PR); EPS_PX=REAL(EPS_PZ,PR)
+   N=NINT(X); M=NINT(EPS_PX)
+   IS_Z_NEG_INT=(Z.EQ.N).AND.(N.LE.0)
+   IS_EPS_PZ_NEG_INT=(EPS_PZ.EQ.M).AND.(M.LE.0)
+   IF(INF_NORM(EPS).GT.0.10D0) THEN
+      GAMMA_INV_DIFF_EPS = (GAMMA_INV (Z) - GAMMA_INV (EPS_PZ))/EPS
+      RETURN
+   ELSE IF(EPS_PZ.NE.Z) THEN 
+      IF(IS_Z_NEG_INT) THEN
+         GAMMA_INV_DIFF_EPS = (-GAMMA_INV (EPS_PZ)/EPS)
+         RETURN
+      ELSE IF(IS_EPS_PZ_NEG_INT) THEN
+         GAMMA_INV_DIFF_EPS = (GAMMA_INV (Z)/EPS)
+         RETURN
+      ELSE
+         Z_NEG_INT_DISTANCE = INF_NORM (Z + ABS (N))
+         EPS_PZ_NEG_INT_DISTANCE = INF_NORM (EPS_PZ + ABS (M))
+         IF(Z_NEG_INT_DISTANCE.LT.EPS_PZ_NEG_INT_DISTANCE) THEN
+            GAMMA_INV_DIFF_EPS= &
+                 GAMMA_RATIO_DIFF_SMALL_EPS (Z,EPS)*GAMMA_INV (EPS_PZ)
+            RETURN
+         ELSE
+            GAMMA_INV_DIFF_EPS= &
+                 GAMMA_RATIO_DIFF_SMALL_EPS (EPS_PZ,-EPS)*GAMMA_INV (Z)
+            RETURN
+         ENDIF
+      ENDIF
+   ELSE IF(IS_Z_NEG_INT.AND.IS_EPS_PZ_NEG_INT) THEN
+      FACT = -ONE;K=-1
+      DO WHILE (K.GE.N) 
+         FACT=FACT*K
+         K=K-1 
+      ENDDO
+      GAMMA_INV_DIFF_EPS = FACT
+      RETURN
+   ELSE
+      GAMMA_INV_DIFF_EPS = &
+           GAMMA_RATIO_DIFF_SMALL_EPS (Z,EPS)*GAMMA_INV (EPS_PZ)
+      RETURN
+   ENDIF
+ END FUNCTION GAMMA_INV_DIFF_EPS
+ !----------------------------------------------------------------------
+ !
+ ! Calculation of Gamma_inv(1-m-eps)/eps of the A(z) polynomial in 1-z
+ ! -------------------------------------------------------------------
+ ! and 1/z transformations
+ ! -----------------------
+ ! This value occurs in A(z) in 1-z and 1/z transformations 
+ ! (see Comp. Phys. Comm. paper) for m > 0.
+ ! Both cases of 1-m-eps numerically negative integer 
+ ! or not have to be considered
+ ! 
+ ! 1-eps-m and 1-m numerically different
+ ! -------------------------------------
+ ! One returns Gamma_inv(1-m-eps)/eps directly 
+ ! as its value is accurate.
+ ! To calculate Gamma_inv(1-m-eps), 
+ ! one uses the value Gamma_inv(1-eps), 
+ ! needed in considered transformations,
+ ! and one uses the equality 
+ ! Gamma_inv(1-m-eps) = Gamma_inv(1-eps) \prod_{i=1}^{m} (1-eps-i) 
+ ! for m > 0.
+ ! It is trivially demonstrated 
+ ! from the equality Gamma(x+1) = x.Gamma(x). 
+ ! One Gamma function evaluation is removed this way 
+ ! from the calculation.
+ ! 
+ ! 1-eps-m and 1-m numerically equal
+ ! ---------------------------------
+ ! This implies that 1-m-eps is negative integer numerically.
+ ! Here, eps~0, so that one returns the limit of Gamma_inv(1-m-eps)/eps
+ ! for eps -> 0, which is (-1)^m (m-1)!
+ !
+ ! Variables
+ ! ---------
+ ! m,eps: variable inputs of the function 
+ ! (m,eps) -> Gamma_inv(1-m-eps)/eps
+ ! Gamma_inv_one_meps: Gamma_inv(1-eps), 
+ ! previously calculated and here recycled 
+ ! to quickly calculate Gamma_inv(1-m-eps).
+ ! one_meps: 1-eps
+ !----------------------------------------------------------------------
+ FUNCTION A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   INTEGER(IPR),INTENT(IN) :: M
+   COMPLEX(PR),INTENT(IN) :: EPS,GAMMA_INV_ONE_MEPS
+   INTEGER(IPR) :: N,I
+   REAL(PR)     :: FACT
+   COMPLEX(PR)  :: A_SUM_INIT,ONE_MEPS
+   COMPLEX(PR)  :: GAMMA_INV_ONE_MEPS_MM
+   !
+   ONE_MEPS = ONE - EPS
+   IF(ONE_MEPS-M.NE.1-M) THEN
+      GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS
+      DO I=1,M
+         GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS-I)
+      ENDDO
+      A_SUM_INIT=GAMMA_INV_ONE_MEPS_MM/EPS
+      RETURN
+   ELSE
+      FACT=ONE
+      DO N=2,M-1
+         FACT=FACT*N
+      ENDDO
+      IF(MOD(M,2).EQ.0) THEN
+         A_SUM_INIT=FACT
+      ELSE
+         A_SUM_INIT=-FACT
+      ENDIF
+      RETURN
+   ENDIF
+ END FUNCTION A_SUM_INIT
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the log of Gamma_inv(1-m-eps)/eps
+ ! ------------------------------------------------
+ ! See previous function. 
+ ! It is used in case Gamma_inv(1-m-eps)/eps might overflow.
+ !
+ ! Variables
+ ! ---------
+ ! m,eps: variable inputs of the function 
+ ! (m,eps) -> log[Gamma_inv(1-m-eps)/eps]
+ ! one_meps_mm: 1-eps-m
+ ! i_Pi: i.Pi
+ ! log_fact: logarithm of (-1)^m (m-1)!, 
+ ! here defined as log((m-1)!) + i.Pi if m is odd.
+ !----------------------------------------------------------------------
+ FUNCTION LOG_A_SUM_INIT(M,EPS)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   INTEGER(IPR),INTENT(IN) :: M
+   COMPLEX(PR),INTENT(IN) :: EPS
+   INTEGER(IPR) :: N
+   REAL(PR)     :: LOG_FACT
+   COMPLEX(PR)  :: ONE_MEPS_MM,LOG_A_SUM_INIT,LOG_GAMMA_CPLX
+   !
+   ONE_MEPS_MM=ONE-EPS-M
+   IF(ONE_MEPS_MM.NE.1-M) THEN
+      LOG_A_SUM_INIT=(-LOG_GAMMA_CPLX(ONE_MEPS_MM) - LOG(EPS))
+      RETURN
+   ELSE
+      LOG_FACT=ZERO
+      DO N=2,M-1
+         LOG_FACT=LOG_FACT + LOG(DBLE(N))
+      ENDDO
+      IF(MOD(M,2).EQ.0) THEN
+         LOG_A_SUM_INIT=LOG_FACT
+      ELSE
+         LOG_A_SUM_INIT=CMPLX(LOG_FACT,M_PI,PR)
+      ENDIF
+      RETURN
+   ENDIF
+ END FUNCTION LOG_A_SUM_INIT
+ !----------------------------------------------------------------------
+ ! Calculation of the first term of the B(z) power series
+ ! ------------------------------------------------------
+ ! in the 1-z transformation, divided by (1-z)^m
+ ! ----------------------------------------------
+ ! In the 1-z transformation, 
+ ! the power series B(z) = \sum_{n=0}^{+oo} \beta_n (1-z)^n occurs 
+ ! (see Comp. Phys. Comm. paper).
+ ! The first term \beta_0, divided by (1-z)^m, is calculated here. 
+ ! m is the closest integer to Re(c-a-b) >= 0 and eps = c-a-b-m.
+ !
+ ! One has to consider |eps|oo > 0.1 and |eps|oo <= 0.1, 
+ ! where 1-m-eps and 1-m can be different or equal numerically, 
+ ! leading to some changes in this last case.
+ !
+ ! |eps|oo > 0.1
+ ! -------------
+ ! One has \beta_0/(1-z)^m = [(a)_m (b)_m Gamma_inv(1-eps) 
+ ! Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) Gamma_inv(m+1)
+ ! - (1-z)^eps Gamma_inv(a) Gamma_inv(b) Gamma_inv(1+m+eps)]
+ ! [Gamma(c)/eps], stable in this regime for a direct evaluation.
+ !
+ ! The values of Gamma(c), Gamma_inv(a+m+eps) 
+ ! and Gamma_inv(b+m+eps) were already calculated and recycled here.
+ ! Gamma_inv(m+1) is calculated as 1/(m!).
+ !
+ ! Gamma_inv(1+m+eps) is calculated from Gamma_inv(1-eps), 
+ ! using the equalities:
+ ! Gamma_inv(1-m-eps) = Gamma_inv(1-eps) \prod_{i=1}^{m} (1-eps-i), 
+ ! where the product is 1 by definition if m = 0,
+ ! Gamma_inv(1+m+eps) = (-1)^m sin (pi.eps)
+ ! /[pi.(eps+m).Gamma_inv(1-m-eps)] 
+ ! from Euler reflection formula, Gamma(x+1) = x.Gamma(x) equality, 
+ ! and m+eps no zero.
+ ! This scheme is much faster than 
+ ! to recalculate Gamma_inv(1+m+eps) directly.
+ ! 
+ ! |eps|oo <= 0.1
+ ! --------------
+ ! The \beta_0/(1-z)^m expression is rewritten 
+ ! so that it contains no instabilities:
+ ! \beta_0/(1-z)^m = Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) 
+ ! [(G(1,-eps) Gamma_inv(m+1) + G(m+1,eps))
+ ! - Gamma_inv(1+m+eps) (G(a+m,eps) Gamma_inv(b+m+eps) 
+ ! + G(b+m,eps) Gamma_inv(a+m)) 
+ ! - E(log(1-z),eps) Gamma_inv(a+m) Gamma_inv(b+m) Gamma_inv(1+m+eps)] 
+ ! (a)_m (b)_m Gamma(c)
+ !
+ ! E(log(1-z),eps) is [(1-z)^eps - 1]/eps 
+ ! if 1-m-eps and 1-m are different numerically, 
+ ! and log(1-z) otherwise (eps ~ 0).
+ ! If 1-m-eps and 1-m are equal numerically, 
+ ! Gamma_inv(1+m+eps) is numerically equal to Gamma_inv(1+m), 
+ ! already calculated as 1/(m!).
+ ! See |eps|oo > 0.1 case for data recycling of other values 
+ ! or for 1-m-eps and 1-m different numerically.
+ !
+ !----------------------------------------------------------------------
+ ! Variables
+ ! ---------
+ ! a,b,c,one_minus_z: a,b,c and 1-z parameters and arguments 
+ ! of the 2F1(a,b,c,z) function.
+ ! m,eps: closest integer to c-a-b, with Re(c-a-b) >= 0 
+ ! and eps = c-a-b-m
+ ! Gamma_c,Gamma_inv_one_meps,Gamma_inv_eps_pa_pm, Gamma_inv_eps_pb_pm: 
+ ! recycled values of Gamma(c), Gamma_inv(1-eps), 
+ ! Gamma_inv(a+m+eps) and Gamma_inv(b+m+eps).
+ ! inf_norm_eps,phase,a_pm,b_pm,one_meps,Pi_eps,Pi_eps_pm: 
+ ! |eps|oo,(-1)^m,a+m,b+m,1-eps,pi.eps,pi.(eps+m)
+ ! Gamma_inv_one_meps_mm,Gamma_inv_eps_pm_p1: 
+ ! Gamma_inv(1-m-eps) and Gamma_inv(1+m+eps) 
+ ! calculated with the recycling scheme.
+ ! prod1: (a)_m (b)_m Gamma_inv(1-eps) Gamma_inv(a+m+eps) 
+ ! x Gamma_inv(b+m+eps) Gamma_inv(m+1) in |eps|oo > 0.1 case.
+ ! prod2: (1-z)^eps Gamma_inv(a) Gamma_inv(b) Gamma_inv(1+m+eps) 
+ ! in |eps|oo > 0.1 case.
+ ! Gamma_inv_mp1,prod_ab: Gamma_inv(m+1) calculated as 1/(m!) 
+ ! and (a)_m (b)_m in |eps|oo <= 0.1 case.
+ ! is_eps_non_zero: true if 1-m-eps and 1-m are different numerically,
+ ! false if not.
+ ! Gamma_inv_a_pm,Gamma_inv_b_pm,z_term: Gamma_inv(a+m),Gamma_inv(b+m),
+ ! E(eps,log(1-z))
+ ! prod1: Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) 
+ ! x [(G(1,-eps) Gamma_inv(m+1) + G(m+1,eps)) in |eps|oo <= 0.1 case.
+ ! prod2: Gamma_inv(1+m+eps) (G(a+m,eps) Gamma_inv(b+m+eps) 
+ ! + G(b+m,eps) Gamma_inv(a+m))
+ ! prod3: E(eps,log(1-z)) Gamma_inv(a+m) Gamma_inv(b+m) 
+ ! Gamma_inv(1+m+eps) 
+ ! res: returned \beta_0/(1-z)^m value in all cases.
+ !----------------------------------------------------------------------
+ FUNCTION B_SUM_INIT_PS_ONE(A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, &
+      GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,M,EPS)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   INTEGER(IPR),INTENT(IN) :: M
+   COMPLEX(PR),INTENT(IN) :: A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, &
+        GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,EPS
+   INTEGER(IPR) :: M_M1,N,I,PHASE
+   REAL(PR)     :: INF_NORM_EPS,GAMMA_INV_MP1
+   COMPLEX(PR)  :: A_PM,B_SUM_INIT_PS_ONE,PI_EPS,GAMMA_INV_ONE_MEPS_MM
+   COMPLEX(PR)  :: B_PM,TMP1,TMP2
+   COMPLEX(PR)  :: Z_TERM,PROD1,PROD2,PROD3,ONE_MEPS,PI_EPS_PM
+   COMPLEX(PR)  :: GAMMA_INV_A_PM,PROD_AB,GAMMA_INV,GAMMA_INV_B_PM
+   COMPLEX(PR)  :: GAMMA_INV_DIFF_EPS,GAMMA_INV_EPS_PM_P1
+   !       
+   INF_NORM_EPS=INF_NORM(EPS); M_M1=M-1; A_PM=A+M; B_PM=B+M
+   ONE_MEPS=ONE-EPS; PI_EPS=M_PI*EPS; PI_EPS_PM = M_PI*(EPS+M)
+   IF(MOD(M,2).EQ.0) THEN
+      PHASE = 1
+   ELSE
+      PHASE = -1
+   ENDIF
+   GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS
+   DO I=1,M
+      GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS - I)
+   ENDDO
+   IF(INF_NORM_EPS.GT.0.10D0) THEN
+      GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) &
+           /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM)
+      PROD1=GAMMA_INV_ONE_MEPS*GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM
+      DO N=0,M_M1
+         PROD1=PROD1*(A+N)*(B+N)/(N+ONE)
+      ENDDO
+      PROD2=GAMMA_INV(A)*GAMMA_INV(B)*GAMMA_INV_EPS_PM_P1*(MZP1**EPS)
+      B_SUM_INIT_PS_ONE=GAMMA_C*(PROD1-PROD2)/EPS
+      RETURN
+   ELSE
+      GAMMA_INV_MP1=ONE;PROD_AB=ONE
+      DO N=0,M_M1
+         GAMMA_INV_MP1 = GAMMA_INV_MP1/(N+ONE)
+         PROD_AB = PROD_AB*(A+N)*(B+N)
+      ENDDO
+      IF(ONE_MEPS-M.NE.1-M) THEN
+         Z_TERM=EXPM1(EPS*LOG(MZP1))/EPS
+         GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) &
+              /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM)
+      ELSE
+         Z_TERM=LOG(MZP1)
+         GAMMA_INV_EPS_PM_P1 = GAMMA_INV_MP1
+      ENDIF
+      GAMMA_INV_A_PM=GAMMA_INV(A_PM);GAMMA_INV_B_PM=GAMMA_INV(B_PM)
+      TMP1=ONE; TMP2=M+1;
+      PROD1 = GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM    &
+           *(GAMMA_INV_MP1*GAMMA_INV_DIFF_EPS(TMP1,-EPS) &
+           +GAMMA_INV_DIFF_EPS(TMP2,EPS))
+      PROD2 = GAMMA_INV_EPS_PM_P1 &
+           *(GAMMA_INV_EPS_PB_PM*GAMMA_INV_DIFF_EPS(A_PM,EPS) &
+           +GAMMA_INV_A_PM*GAMMA_INV_DIFF_EPS (B_PM,EPS))
+      PROD3 = GAMMA_INV_A_PM*GAMMA_INV_B_PM*GAMMA_INV_EPS_PM_P1*Z_TERM
+      B_SUM_INIT_PS_ONE=GAMMA_C*PROD_AB*(PROD1-PROD2-PROD3)
+      RETURN
+   ENDIF
+ END FUNCTION B_SUM_INIT_PS_ONE
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the first term of the B(z) power series 
+ ! ------------------------------------------------------
+ ! in the 1/z transformation, divided by z^{-m}
+ !---------------------------------------------
+ ! In the 1/z transformation, the power series 
+ ! B(z) = \sum_{n=0}^{+oo} \beta_n z^{-n} occurs 
+ ! (see Comp. Phys. Comm. paper).
+ ! The first term \beta_0, divided by z^{-m}, is calculated here. 
+ ! m is the closest integer to Re(b-a) >= 0 and eps = b-a-m.
+ !
+ ! One has to consider |eps|oo > 0.1 and |eps|oo <= 0.1, 
+ ! where 1-m-eps and 1-m can be different or equal numerically, 
+ ! leading to some changes in this last case.
+ !
+ ! |eps|oo > 0.1
+ ! -------------
+ ! One has \beta_0/z^{-m} = [(a)_m (1-c+a)_m Gamma_inv(1-eps) 
+ ! Gamma_inv(a+m+eps) Gamma_inv(c-a) Gamma_inv(m+1)
+ ! - (-z)^{-eps} (1-c+a+eps)_m Gamma_inv(a) Gamma_inv(c-a-eps) 
+ ! Gamma_inv(1+m+eps)].[Gamma(c)/eps], 
+ ! stable in this regime for a direct evaluation.
+ !
+ ! The values of Gamma(c), Gamma_inv(c-a) and Gamma_inv(a+m+eps) 
+ ! were already calculated and recycled here.
+ ! Gamma_inv(m+1) is calculated as 1/(m!). 
+ ! Gamma_inv(1+m+eps) is calculated from Gamma_inv(1-eps) 
+ ! as in the 1-z transformation routine.
+ ! 
+ ! |eps|oo <= 0.1
+ ! --------------
+ ! The \beta_0/z^{-m} expression is rewritten 
+ ! so that it contains no instabilities:
+ ! \beta_0/z^{-m} = [((1-c+a+eps)_m G(1,-eps) - P(m,eps,1-c+a) 
+ ! Gamma_inv(1-eps)) Gamma_inv(c-a) Gamma_inv(a+m+eps) Gamma_inv(m+1)
+ ! + (1-c+a+eps)_m [G(m+1,eps) Gamma_inv(c-a) Gamma_inv(a+m+eps) 
+ ! - G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)]
+ ! - (G(c-a,-eps) - E(log(-z),-eps)) Gamma_inv(m+1+eps) 
+ ! Gamma_inv(a+m)]] (a)_m Gamma(c)
+ !
+ ! Definitions and method are the same 
+ ! as in the 1-z transformation routine, except for P(m,eps,1-c+a).
+ ! P(m,eps,s) = [(s+eps)_m - (s)_m]/eps 
+ ! for eps non zero and has a limit for eps -> 0.
+ ! Let n0 be the closest integer to -Re(s) for s complex. 
+ ! A stable formula available for eps -> 0 for P(m,eps,s) is:
+ ! P(m,eps,s) = (s)_m E(\sum_{n=0}^{m-1} L(1/(s+n),eps),eps) 
+ ! if n0 is not in [0:m-1],
+ ! P(m,eps,s) = \prod_{n=0, n not equal to n0}^{m-1} (s+eps+n) 
+ ! + (s)_m E(\sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps),eps) 
+ ! if n0 is in [0:m-1].
+ ! L(s,eps) is log1p(s eps)/eps if eps is not zero, 
+ ! and L(s,0) = s.
+ ! This expression is used in the code.
+ !
+ ! Variables
+ ! ---------
+ ! a,b,c,z: a,b,c and z parameters 
+ ! and arguments of the 2F1(a,b,c,z) function.
+ ! m,eps: closest integer to b-a, with Re(b-a) >= 0 and eps = b-a-m.
+ ! Gamma_c,Gamma_inv_cma,Gamma_inv_one_meps,Gamma_inv_eps_pa_pm: 
+ ! recycled values of Gamma(c), Gamma_inv(c-a), Gamma_inv(1-eps) 
+ ! and Gamma_inv(a+m+eps).
+ ! inf_norm_eps,phase,cma,a_mc_p1,a_mc_p1_pm,cma_eps,eps_pa_mc_p1,a_pm: 
+ ! |eps|oo,(-1)^m,c-a,1-c+a+m,c-a-eps,1-c+a+eps,a+m
+ ! Gamma_inv_cma_meps,one_meps,Pi_eps,Pi_eps_pm: 
+ ! Gamma_inv(c-a-eps),1-eps,pi.eps,pi.(eps+m)
+ ! Gamma_inv_one_meps_mm,Gamma_inv_eps_pm_p1: Gamma_inv(1-m-eps) 
+ ! and Gamma_inv(1+m+eps) calculated with the recycling scheme.
+ ! prod1: (a)_m (1-c+a)_m Gamma_inv(1-eps) Gamma_inv(a+m+eps) 
+ ! x Gamma_inv(c-a) Gamma_inv(m+1) in |eps|oo > 0.1 case.
+ ! prod2: (-z)^{-eps} (1-c+a+eps)_m Gamma_inv(a) 
+ ! x Gamma_inv(c-a-eps) Gamma_inv(1+m+eps) in |eps|oo > 0.1 case.
+ ! n0: closest integer to -Re(1-c+a)
+ ! is_n0_here: true is n0 belongs to [0:m-1], false if not.
+ ! is_eps_non_zero: true if 1-m-eps and 1-m are different numerically, 
+ ! false if not.
+ ! Gamma_inv_mp1,prod_a,prod_a_mc_p1: 
+ ! Gamma_inv(m+1) calculated as 1/(m!), 
+ ! (a)_m and (1-c+a)_m in |eps|oo <= 0.1 case.
+ ! prod_eps_pa_mc_p1_n0: 
+ ! \prod_{n=0, n not equal to n0}^{m-1} (1-c+a+eps+n) 
+ ! if n0 belongs to [0:m-1], 0.0 if not, in |eps|oo <= 0.1 case.
+ ! prod_eps_pa_mc_p1: (1-c+a+eps)_m in |eps|oo <= 0.1 case.
+ ! sum: \sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps) if 1-m-eps 
+ ! and 1-m are different numerically, 
+ ! \sum_{n=0, n not equal to n0}^{m-1} 1/(s+n) if not.
+ ! a_pn,a_mc_p1_pn,eps_pa_mc_p1_pn: a+n,1-c+a+n,1-c+a+eps+n values 
+ ! used in (a)_m, (1-c+a)_m and (1-c+a+eps)_m evaluations.
+ ! sum_term,prod_diff_eps,z_term: 
+ ! E(\sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps),eps), 
+ ! P(m,eps,1-c+a), -E(-eps,log(-z))
+ ! Gamma_inv_a_pm,Gamma_prod1: Gamma_inv(a+m), 
+ ! Gamma_inv(c-a).Gamma_inv(a+m+eps)
+ ! prod1: ((1-c+a+eps)_m G(1,-eps) 
+ ! - P(m,eps,1-c+a) Gamma_inv(1-eps)) Gamma_inv(c-a) 
+ ! x Gamma_inv(a+m+eps) Gamma_inv(m+1)
+ ! prod_2a: Gamma_inv(c-a).Gamma_inv(a+m+eps).G(m+1,eps)
+ ! prod_2b: G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)
+ ! prod_2c: (G(c-a,-eps) 
+ ! - E(log(-z),-eps)) Gamma_inv(m+1+eps) Gamma_inv(a+m)
+ ! prod2: (1-c+a+eps)_m [G(m+1,eps) Gamma_inv(c-a) Gamma_inv(a+m+eps) 
+ ! - G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)] 
+ ! - (G(c-a,-eps) - E(log(-z),-eps)) 
+ ! x Gamma_inv(m+1+eps) Gamma_inv(a+m)]]
+ ! res: returned \beta_0/z^{-m} value in all cases.
+ !----------------------------------------------------------------------
+ FUNCTION B_SUM_INIT_PS_INFINITY(A,C,GAMMA_C,GAMMA_INV_CMA, &
+      GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM,Z,M,EPS)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   INTEGER(IPR),INTENT(IN) :: M
+   COMPLEX(PR),INTENT(IN) :: A,C,GAMMA_C,GAMMA_INV_CMA,Z,EPS
+   COMPLEX(PR),INTENT(IN) :: GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM
+   INTEGER(IPR) :: M_M1,I,N,N0,PHASE
+   LOGICAL      :: IS_N0_HERE,IS_EPS_NON_ZERO
+   REAL(PR)     :: INF_NORM_EPS,NP1,GAMMA_INV_MP1
+   COMPLEX(PR)  :: B_SUM_INIT_PS_INFINITY,GAMMA_INV,TMP1
+   COMPLEX(PR)  :: CMA,A_MC_P1,A_MC_P1_PM,CMA_MEPS,EPS_PA_MC_P1,A_PM
+   COMPLEX(PR)  :: GAMMA_INV_EPS_PM_P1,GAMMA_INV_CMA_MEPS,PI_EPS
+   COMPLEX(PR)  :: PROD1,PROD2,A_PN,A_MC_P1_PN,ONE_MEPS
+   COMPLEX(PR)  :: PROD_A,PROD_A_MC_P1,PROD_EPS_PA_MC_P1_N0,PI_EPS_PM
+   COMPLEX(PR)  :: PROD_EPS_PA_MC_P1,SUM_N0,Z_TERM,SUM_TERM
+   COMPLEX(PR)  :: PROD_DIFF_EPS,GAMMA_INV_A_PM,GAMMA_PROD1
+   COMPLEX(PR)  :: PROD_2A,PROD_2B,PROD_2C,GAMMA_INV_DIFF_EPS
+   COMPLEX(PR)  :: EPS_PA_MC_P1_PN,GAMMA_INV_ONE_MEPS_MM
+   !
+   INF_NORM_EPS=INF_NORM(EPS); CMA=C-A; A_MC_P1=A-C+ONE
+   A_MC_P1_PM=A_MC_P1+M; CMA_MEPS=CMA-EPS; EPS_PA_MC_P1=EPS+A_MC_P1
+   A_PM=A+M; M_M1=M-1; ONE_MEPS=ONE-EPS; PI_EPS=M_PI*EPS
+   PI_EPS_PM=M_PI*(EPS+M); GAMMA_INV_CMA_MEPS=GAMMA_INV(CMA_MEPS)
+   IF(MOD(M,2).EQ.0) THEN
+      PHASE = 1
+   ELSE
+      PHASE = -1
+   ENDIF
+   GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS
+   DO I=1,M
+      GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS - I)
+   ENDDO
+   IF(INF_NORM_EPS.GT.0.1D0) THEN
+      GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) &
+           /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM)
+      PROD1 = GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM*GAMMA_INV_ONE_MEPS
+      PROD2 = GAMMA_INV(A)*GAMMA_INV_CMA_MEPS*GAMMA_INV_EPS_PM_P1 &
+           *((-Z)**(-EPS))
+      DO N=0,M_M1
+         A_PN=A+N; A_MC_P1_PN=A_MC_P1+N
+         EPS_PA_MC_P1_PN=EPS+A_MC_P1_PN;NP1=N+ONE
+         PROD1 = PROD1*A_PN*A_MC_P1_PN/NP1
+         PROD2 = PROD2*EPS_PA_MC_P1_PN
+      ENDDO
+      B_SUM_INIT_PS_INFINITY = GAMMA_C*(PROD1-PROD2)/EPS
+      RETURN
+   ELSE
+      N0=-NINT(REAL(A_MC_P1,PR))
+      IS_EPS_NON_ZERO=ONE_MEPS-M.NE.1-M
+      IS_N0_HERE=(N0.GE.0).AND.(N0.LT.M)     
+      GAMMA_INV_MP1=ONE; PROD_A=ONE; PROD_A_MC_P1=ONE
+      PROD_EPS_PA_MC_P1=ONE; SUM_N0=ZERO
+      IF(IS_N0_HERE) THEN
+         PROD_EPS_PA_MC_P1_N0 = ONE
+      ELSE
+         PROD_EPS_PA_MC_P1_N0 = ZERO
+      ENDIF
+      DO N=0,M_M1
+         A_PN=A+N; A_MC_P1_PN=A_MC_P1+N
+         EPS_PA_MC_P1_PN=EPS+A_MC_P1_PN; NP1=N+ONE
+         PROD_A = PROD_A*A_PN
+         PROD_A_MC_P1 = PROD_A_MC_P1*A_MC_P1_PN
+         PROD_EPS_PA_MC_P1 = PROD_EPS_PA_MC_P1*EPS_PA_MC_P1_PN
+         GAMMA_INV_MP1 = GAMMA_INV_MP1/NP1
+         IF(N.NE.N0) THEN
+            IF(IS_N0_HERE) THEN
+               PROD_EPS_PA_MC_P1_N0=PROD_EPS_PA_MC_P1_N0 &
+                    *EPS_PA_MC_P1_PN
+            ENDIF
+            IF(IS_EPS_NON_ZERO) THEN
+               SUM_N0 = SUM_N0 + LOG1P(EPS/A_MC_P1_PN)
+            ELSE
+               SUM_N0 = SUM_N0 + ONE/A_MC_P1_PN
+            ENDIF
+         ENDIF
+      ENDDO
+      IF(IS_EPS_NON_ZERO) THEN
+         GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) &
+              /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM)
+         SUM_TERM = EXPM1(SUM_N0)/EPS
+         Z_TERM = EXPM1(-EPS*LOG(-Z))/EPS
+      ELSE
+         GAMMA_INV_EPS_PM_P1 = GAMMA_INV_MP1
+         SUM_TERM = SUM_N0
+         Z_TERM = -LOG(-Z)
+      ENDIF
+      PROD_DIFF_EPS = PROD_EPS_PA_MC_P1_N0 + PROD_A_MC_P1*SUM_TERM
+      GAMMA_INV_A_PM = GAMMA_INV(A_PM)
+      GAMMA_PROD1=GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM
+      TMP1=ONE
+      PROD1 = GAMMA_PROD1*GAMMA_INV_MP1*(GAMMA_INV_DIFF_EPS(TMP1,-EPS) &
+           *PROD_EPS_PA_MC_P1 - GAMMA_INV_ONE_MEPS*PROD_DIFF_EPS)
+      TMP1=M+1
+      PROD_2A = GAMMA_PROD1*GAMMA_INV_DIFF_EPS(TMP1,EPS) 
+      PROD_2B = GAMMA_INV_CMA*GAMMA_INV_EPS_PM_P1  &
+           *GAMMA_INV_DIFF_EPS(A_PM,EPS)
+      PROD_2C = GAMMA_INV_EPS_PM_P1*GAMMA_INV_A_PM &
+           *(GAMMA_INV_DIFF_EPS(CMA,-EPS) + GAMMA_INV_CMA_MEPS*Z_TERM)
+      PROD2 = PROD_EPS_PA_MC_P1*(PROD_2A - PROD_2B - PROD_2C)
+      B_SUM_INIT_PS_INFINITY = GAMMA_C*PROD_A*(PROD1+PROD2)
+      RETURN
+   ENDIF
+ END FUNCTION B_SUM_INIT_PS_INFINITY
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the derivative of the polynomial P(X) 
+ ! ----------------------------------------------------
+ ! testing power series convergence
+ ! --------------------------------
+ ! P(X) = |z(a+X)(b+X)|^2 - |(c+X)(X+1)|^2 
+ !      = \sum_{i=0}^{4} c[i] X^{i}, for |z| < 1.
+ ! It is positive when the power series term modulus increases 
+ ! and negative when it decreases, 
+ ! so that its derivative provides information on its convergence 
+ ! (see Comp. Phys. Comm. paper).
+ ! Its derivative components cv_poly_der_tab[i] = (i+1) c[i+1] 
+ ! for i in [0:3] 
+ ! so that P'(X) = \sum_{i=0}^{3} cv_poly_der_tab[i] X^{i} 
+ ! are calculated.
+ !
+ ! Variables:
+ ! ----------
+ ! a,b,c,z: a,b,c and z parameters and arguments 
+ ! of the 2F1(a,b,c,z) function.
+ ! cv_poly_der_tab[3]: table of four doubles 
+ ! containing the P'(X) components.
+ ! mod_a2,mod_b2,mod_c2,mod_z2,R_a,Re_b,Re_c: |a|^2, |b|^2, |c|^2, 
+ ! |z|^2, Re(a), Re(b), Re(c), with which P(X) can be expressed.
+ !----------------------------------------------------------------------
+ SUBROUTINE CV_POLY_DER_TAB_CALC(A,B,C,Z,CV_POLY_DER_TAB)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: A,B,C,Z
+   REAL(PR),INTENT(OUT) :: CV_POLY_DER_TAB(0:3)
+   REAL(PR)     :: MOD_A2,MOD_B2,MOD_C2,MOD_Z2
+   REAL(PR)     :: RE_A,RE_B,RE_C,IM_A,IM_B,IM_C,RE_Z,IM_Z
+   !
+   RE_A=REAL(A,PR); IM_A=AIMAG(A); MOD_A2=RE_A*RE_A+IM_A*IM_A
+   RE_B=REAL(B,PR); IM_B=AIMAG(B); MOD_B2=RE_B*RE_B+IM_B*IM_B
+   RE_C=REAL(C,PR); IM_C=AIMAG(C); MOD_C2=RE_C*RE_C+IM_C*IM_C
+   RE_Z=REAL(Z,PR); IM_Z=AIMAG(Z); MOD_Z2=RE_Z*RE_Z+IM_Z*IM_Z
+   CV_POLY_DER_TAB(0)=TWO*((RE_A*MOD_B2+RE_B*MOD_A2)*MOD_Z2-RE_C-MOD_C2)
+   CV_POLY_DER_TAB(1)=TWO*((MOD_A2+MOD_B2+4.0D0*RE_A*RE_B)*MOD_Z2 &
+        -ONE-4.0D0*RE_C-MOD_C2)
+   CV_POLY_DER_TAB(2)=6.0D0*((RE_A+RE_B)*MOD_Z2-RE_C-ONE)
+   CV_POLY_DER_TAB(3)=4.0D0*(MOD_Z2-ONE)
+ END SUBROUTINE CV_POLY_DER_TAB_CALC
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the derivative of the polynomial P(X) 
+ ! ----------------------------------------------------
+ ! testing power series convergence at one x value
+ ! -----------------------------------------------
+ ! P'(x) is calculated for a real x. 
+ ! See P'(X) components calculation routine for definitions.
+ !----------------------------------------------------------------------
+ FUNCTION CV_POLY_DER_CALC(CV_POLY_DER_TAB,X)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   REAL(PR),INTENT(IN) :: X
+   REAL(PR),INTENT(IN) :: CV_POLY_DER_TAB(0:3)
+   REAL(PR) :: CV_POLY_DER_CALC
+   !
+   CV_POLY_DER_CALC=CV_POLY_DER_TAB(0)+X*(CV_POLY_DER_TAB(1) &
+        +X*(CV_POLY_DER_TAB(2)+X*CV_POLY_DER_TAB(3)))
+   RETURN
+ END FUNCTION CV_POLY_DER_CALC
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of an integer after which false convergence cannot occur
+ ! --------------------------------------------------------------------
+ ! See cv_poly_der_tab_calc routine for definitions.
+ ! If P'(x) < 0 and P''(x) < 0 for x > xc, it will be so for all x > xc 
+ ! as P(x) -> -oo for x -> +oo 
+ ! and P(x) can have at most one maximum for x > xc. 
+ ! It means that the 2F1 power series term modulus will increase 
+ ! or decrease to 0 for n > nc, 
+ ! with nc the smallest positive integer larger than xc.
+ !
+ ! If P'(X) = C0 + C1.X + C2.X^2 + C3.X^3, 
+ ! the discriminant of P''(X) is Delta = C2^2 - 3 C1 C3.
+ !
+ ! If Delta > 0, P''(X) has two different real roots 
+ ! and its largest root is -(C2 + sqrt(Delta))/(3 C3), 
+ ! because C3 = 4(|z|^2 - 1) < 0.
+ ! One can take xc = -(C2 + sqrt(Delta))/(3 C3) 
+ ! and one returns its associated nc integer.
+ !
+ ! If Delta <= 0, P''(X) has at most one real root, 
+ ! so that P'(X) has only one root and then P(X) only one maximum.
+ ! In this case, one can choose xc = nc = 0, which is returned.
+ !
+ ! Variables
+ ! ---------
+ ! cv_poly_der_tab: table of four doubles 
+ ! containing the P'(X) coefficients
+ ! C1,C2,three_C3: cv_poly_der_tab[1], cv_poly_der_tab[2] 
+ ! and 3.0*cv_poly_der_tab[3], so that P''(X) = C1 + 2.C2.x + three_C3.x^2
+ ! Delta: discriminant of P''(X), equal to C2^2 - 3 C1 C3.
+ ! largest_root: if Delta > 0, 
+ ! P''(X) largest real root equal to -(C2 + sqrt(Delta))/(3 C3).
+ !----------------------------------------------------------------------
+ FUNCTION MIN_N_CALC(CV_POLY_DER_TAB)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   REAL(PR),INTENT(IN) :: CV_POLY_DER_TAB(0:3)
+   INTEGER(IPR) :: MIN_N_CALC
+   REAL(PR)     :: C1,C2,THREE_C3,DELTA,LARGEST_ROOT
+   !
+   C1=CV_POLY_DER_TAB(1); C2=CV_POLY_DER_TAB(2)
+   THREE_C3=3.0D0*CV_POLY_DER_TAB(3); DELTA = C2*C2 - THREE_C3*C1
+   IF(DELTA.LE.ZERO) THEN
+      MIN_N_CALC = 0
+      RETURN
+   ELSE
+      LARGEST_ROOT = -(C2 + SQRT (DELTA))/THREE_C3
+      MIN_N_CALC = MAX(CEILING(LARGEST_ROOT),0)
+      RETURN
+   ENDIF
+ END FUNCTION MIN_N_CALC
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the 2F1 power series converging for |z| < 1
+ ! ----------------------------------------------------------
+ ! One has 2F1(a,b,c,z) 
+ ! = \sum_{n = 0}^{+oo} (a)_n (b)_n / ((c)_n n!) z^n,
+ ! so that 2F1(a,b,c,z) = \sum_{n = 0}^{+oo} t[n] z^n, 
+ ! with t[0] = 1 and t[n+1] = (a+n)(b+n)/((c+n)(n+1)) t[n] for n >= 0.
+ ! If a or b are negative integers, 
+ ! F(z) is a polynomial of degree -a or -b, evaluated directly.
+ ! If not, one uses the test of convergence |t[n] z^n|oo < 1E-15 
+ ! to truncate the series after it was checked 
+ ! that false convergence cannot occur.
+ ! Variables:
+ ! ----------
+ ! a,b,c,z: a,b,c and z parameters and arguments 
+ ! of the 2F1(a,b,c,z) function. One must have here |z| < 1.
+ ! term,sum: term of the 2F1 power series equal to t[n] z^n, 
+ ! truncated sum at given n of the 2F1 power series.
+ ! na,nb: absolute values of the closest integers to Re(a) and Re(b). 
+ ! a = -na or b = -nb means one is in the polynomial case.
+ ! cv_poly_der_tab: coefficients of the derivative 
+ ! of the polynomial P(X) = |z(a+X)(b+X)|^2 - |(c+X)(X+1)|^2
+ ! min_n: smallest integer after which false convergence cannot occur. 
+ ! It is calculated in min_n_calc.
+ ! possible_false_cv: always true if n < min_n. 
+ ! If n >= min_n, it is true if P'(n) > 0. 
+ ! If n >= min_n and P'(n) < 0, 
+ ! it becomes false and remains as such for the rest of the calculation. 
+ ! One can then check if |t[n] z^n|oo < 1E-15 to truncate the series.
+ !----------------------------------------------------------------------
+ FUNCTION HYP_PS_ZERO(A,B,C,Z)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: A,B,C,Z
+   INTEGER(IPR) :: N,NA,NB,MIN_N,MIN_N_CALC
+   COMPLEX(PR)  :: HYP_PS_ZERO,TERM
+   LOGICAL :: POSSIBLE_FALSE_CV
+   REAL(PR) :: CV_POLY_DER_TAB(0:3)
+   REAL(PR) :: CV_POLY_DER_CALC
+   !
+   NA = ABS(NINT(REAL(A,PR)))
+   NB = ABS(NINT(REAL(B,PR)))
+   TERM=ONE; HYP_PS_ZERO=ONE  
+   IF(A.EQ.(-NA)) THEN
+      DO N=0,NA-1
+         TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N))
+         HYP_PS_ZERO = HYP_PS_ZERO + TERM
+      ENDDO
+      RETURN
+   ELSE IF(B.EQ.(-NB)) THEN
+      DO N=0,NB-1
+         TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N))
+         HYP_PS_ZERO = HYP_PS_ZERO + TERM
+      ENDDO
+      RETURN
+   ELSE
+      CALL CV_POLY_DER_TAB_CALC(A,B,C,Z,CV_POLY_DER_TAB)
+      POSSIBLE_FALSE_CV=.TRUE.
+      MIN_N=MIN_N_CALC(CV_POLY_DER_TAB);N=0
+      DO WHILE(POSSIBLE_FALSE_CV.OR.(INF_NORM(TERM).GT.EPS15))
+         TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N))
+         HYP_PS_ZERO = HYP_PS_ZERO + TERM
+         IF(POSSIBLE_FALSE_CV.AND.(N.GT.MIN_N)) THEN
+            POSSIBLE_FALSE_CV = &
+                 (CV_POLY_DER_CALC (CV_POLY_DER_TAB,DBLE(N)).GT.ZERO)
+         ENDIF
+         N=N+1 
+      ENDDO
+      RETURN
+   ENDIF
+ END FUNCTION HYP_PS_ZERO
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the 2F1 power series 
+ ! -----------------------------------
+ ! converging with the 1-z transformation
+ ! --------------------------------------
+ ! The formula for F(z) in the 1-z transformation holds:
+ ! F(z) = (-1)^m (pi.eps)/sin (pi.eps) [A(z) + B(z)] 
+ ! for eps not equal to zero, F(z) = (-1)^m [A(z) + B(z)] for eps = 0
+ ! where m = |Re(c-a-b)], eps = c-a-b-m, 
+ ! A(z) = \sum_{n=0}^{m-1} alpha[n] (1-z)^n, 
+ ! B(z) = \sum_{n=0}^{+oo} beta[n] (1-z)^n, and:
+ !
+ ! alpha[0] = [Gamma_inv(1-m-eps)/eps] Gamma_inv(a+m+eps) 
+ !          x Gamma_inv(b+m+eps) Gamma(c)
+ ! [Gamma_inv(1-m-eps)/eps] is calculated in A_sum_init. 
+ ! alpha[0] is calculated with log[Gamma] 
+ ! if the previous expression might overflow, 
+ ! and its imaginary part removed if a, b and c are real.
+ ! alpha[n+1] = (a+n)(b+n)/[(n+1)(1-m-eps+n)] alpha[n], n in [0:m-2].
+ !
+ ! beta[0] is defined in B_sum_init_PS_one function comments.
+ ! gamma[0] = Gamma(c) (a)_m (b)_m (1-z)^m Gamma_inv(a+m+eps) 
+ !          x Gamma_inv(b+m+eps) Gamma_inv(m+1) Gamma_inv(1-eps)
+ !
+ ! beta[n+1] = (a+m+n+eps)(b+m+n+eps)/[(m+n+1+eps)(n+1)] beta[n]
+ ! + [(a+m+n)(b+m+n)/(m+n+1) - (a+m+n) - (b+m+n) - eps 
+ ! + (a+m+n+eps)(b+m+n+eps)/(n+1)]
+ !             x gamma[n]/[(n+m+1+eps)(n+1+eps)], n >= 0.
+ ! gamma[n+1] = (a+m+n)(b+m+n)/[(m+n+1)(n+1-eps)] gamma[n], n >= 0.
+ !
+ ! B(z) converges <=> |1-z| < 1
+ ! The test of convergence is |beta[n] (1-z)^n|oo < 1E-15 |beta[0]|oo
+ ! for n large enough so that false convergence cannot occur.
+ !
+ ! Variables
+ ! ---------
+ ! a,b,c,one_minus_z: a,b,c parameters 
+ ! and 1-z from z argument of 2F1(a,b,c,z)
+ ! m,phase,m_p1,eps,eps_pm,eps_pm_p1,
+ ! a_pm,b_pm,one_meps,one_meps_pm: 
+ ! |Re(c-a-b)], (-1)^m, m+1, c-a-b-m, 
+ ! eps+m, eps+m+1, a+m, b+m, 1-eps, 1-eps-m
+ ! eps_pa,eps_pb,eps_pa_pm,eps_pb_pm,Pi_eps,Gamma_c: 
+ ! eps+a, eps+b, eps+a+m, eps+b+m, pi.eps, Gamma(c)
+ ! Gamma_inv_eps_pa_pm,Gamma_inv_eps_pb_pm,Gamma_prod: 
+ ! Gamma_inv(eps+a+m), Gamma_inv(eps+b+m), 
+ ! Gamma(c).Gamma_inv(eps+a+m).Gamma_inv(eps+b+m)
+ ! Gamma_inv_one_meps,A_first_term,A_sum,A_term: 
+ ! Gamma_inv(1-eps), alpha[0], A(z), alpha[n] (1-z)^n
+ ! pow_mzp1_m,B_first_term,prod_B,ratio: (1-z)^m, beta[0], 
+ ! (a)_m (b)_m (1-z)^m, (a+n)(b+n)/(n+1) for n in [0:m-2].
+ ! B_extra_term,B_term,B_sum,B_prec: 
+ ! gamma[n], beta[n] (1-z)^n, B(z), 1E-15 |beta[0|oo
+ ! cv_poly1_der_tab,cv_poly2_der_tab: P1'(X) and P2'(X) coefficients 
+ ! of the potentials derivatives of P1(X) and P2(X) 
+ ! defined in cv_poly_der_tab_calc with parameters 
+ ! a1 = a, b1 = b, c1 = 1-m-eps, z1 = 1-z 
+ ! and a2 = eps+b+m, b2 = eps+a+m,c2 = eps+m+1, z2 = 1-z.
+ ! min_n: smallest integer after which false convergence cannot occur. 
+ ! It is calculated in min_n_calc with both P1'(X) and P2'(X), 
+ ! so one takes the largest integer coming from both calculations.
+ ! possible_false_cv: always true if n < min_n. 
+ ! If n >= min_n, it is true if P1'(n) > 0 or P2'(n) > 0. 
+ ! If n >= min_n and P1'(n) < 0 and P2'(n) < 0, 
+ ! it becomes false and remains as such for the rest of the calculation.
+ ! One can then check if |beta[n] z^n|oo < 1E-15 to truncate the series.
+ ! n,n_pm_p1,n_p1,a_pm_pn,b_pm_pn,eps_pm_p1_pn,n_p1_meps,eps_pa_pm_pn,
+ ! eps_pb_pm_pn,eps_pm_pn: index of power series, n+m+1, n+1, 
+ ! a+m+n, b+m+n, eps+m+n+1, n+1-eps, eps+a+m+n, eps+b+m+n, eps+m+n,
+ ! prod1,prod2,prod3: (eps+a+m+n)(eps+b+m+n), 
+ ! (eps+m+1+n)(n+1), (a+m+n)(b+m+n)
+ !----------------------------------------------------------------------
+ FUNCTION HYP_PS_ONE(A,B,C,MZP1)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: A,B,C,MZP1
+   INTEGER(IPR) :: N,M,PHASE,M_M2,MIN_N,MIN_N_CALC,M_P1
+   REAL(PR)     :: B_PREC,N_P1,N_PM_P1,CV_POLY_DER_CALC 
+   COMPLEX(PR)  :: HYP_PS_ONE,EPS,EPS_PM,EPS_PM_P1,A_PM
+   COMPLEX(PR)  :: B_PM,ONE_MEPS_MM,EPS_PA,EPS_PB,PI_EPS,GAMMA_PROD
+   COMPLEX(PR)  :: EPS_PA_PM,EPS_PB_PM,GAMMA_INV,B_SUM_INIT_PS_ONE
+   COMPLEX(PR)  :: A_SUM_INIT,LOG_A_SUM_INIT,A_SUM,A_TERM,ONE_MEPS
+   COMPLEX(PR)  :: B_EXTRA_TERM,B_TERM,B_SUM,GAMMA_C,LOG_GAMMA_CPLX,RATIO
+   COMPLEX(PR)  :: A_PM_PN,B_PM_PN,EPS_PM_P1_PN,N_P1_MEPS
+   COMPLEX(PR)  :: PROD1,PROD2,PROD3
+   COMPLEX(PR)  :: EPS_PA_PM_PN,EPS_PB_PM_PN,EPS_PM_PN,PROD_B,POW_MZP1_M
+   COMPLEX(PR)  :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM
+   COMPLEX(PR)  :: GAMMA_INV_ONE_MEPS
+   LOGICAL :: POSSIBLE_FALSE_CV
+   REAL(PR) :: CV_POLY1_DER_TAB(0:3),CV_POLY2_DER_TAB(0:3)
+   !
+   M=NINT(REAL(C-A-B,PR)); M_M2=M-2; M_P1=M+1
+   IF(MOD(M,2).EQ.0) THEN
+      PHASE=1
+   ELSE
+      PHASE=-1
+   ENDIF
+   EPS=C-A-B-M; EPS_PM=EPS+M; EPS_PM_P1=EPS_PM+ONE; A_PM=A+M;B_PM=B+M
+   ONE_MEPS=ONE-EPS; ONE_MEPS_MM=ONE_MEPS-M; EPS_PA=EPS+A; EPS_PB=EPS+B 
+   PI_EPS=M_PI*EPS; EPS_PA_PM=EPS_PA+M; EPS_PB_PM=EPS_PB+M
+   GAMMA_C=ONE/GAMMA_INV(C)
+   GAMMA_INV_EPS_PA_PM=GAMMA_INV(EPS_PA_PM)
+   GAMMA_INV_EPS_PB_PM=GAMMA_INV(EPS_PB_PM)
+   GAMMA_PROD=GAMMA_C*GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM
+   GAMMA_INV_ONE_MEPS=GAMMA_INV(ONE_MEPS)
+   IF(M.EQ.0) THEN
+      A_TERM=ZERO
+   ELSE IF(INF_NORM(ONE_MEPS_MM &
+        *(LOG(ONE + ABS(ONE_MEPS_MM))-ONE)).LT.300.0d0) THEN
+      A_TERM=GAMMA_PROD*A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS)
+   ELSE
+      A_TERM=EXP(LOG_GAMMA_CPLX(C)-LOG_GAMMA_CPLX(EPS_PA_PM)&
+           -LOG_GAMMA_CPLX(EPS_PB_PM)+LOG_A_SUM_INIT(M,EPS))
+      IF((AIMAG(A).EQ.ZERO).AND.(AIMAG(B).EQ.ZERO)&
+           .AND.(AIMAG(C).EQ.ZERO)) THEN
+         A_TERM=REAL(A_TERM,PR)
+      ENDIF
+   ENDIF
+   A_SUM=A_TERM
+   POW_MZP1_M = MZP1**M
+   B_TERM=B_SUM_INIT_PS_ONE(A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, &
+        GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,M,EPS)*POW_MZP1_M
+   PROD_B=POW_MZP1_M
+   DO N=0,M_M2
+      RATIO=(A+N)*(B+N)/(N+ONE)
+      A_TERM=A_TERM*MZP1*RATIO/(N+ONE_MEPS_MM)
+      A_SUM=A_SUM+A_TERM
+      PROD_B = PROD_B*RATIO
+   ENDDO
+   IF(M.GT.0) THEN
+      PROD_B = PROD_B*(A+M-ONE)*(B+M-ONE)/DBLE(M)
+   ENDIF
+   B_EXTRA_TERM = PROD_B*GAMMA_PROD*GAMMA_INV_ONE_MEPS; B_SUM=B_TERM
+   B_PREC=EPS15*INF_NORM(B_TERM)
+   CALL CV_POLY_DER_TAB_CALC(A,B,ONE_MEPS_MM,MZP1,CV_POLY1_DER_TAB)
+   CALL CV_POLY_DER_TAB_CALC(EPS_PB_PM,EPS_PA_PM,EPS_PM_P1,MZP1, &
+        CV_POLY2_DER_TAB)
+   MIN_N=MAX(MIN_N_CALC(CV_POLY1_DER_TAB),MIN_N_CALC(CV_POLY2_DER_TAB))
+   POSSIBLE_FALSE_CV=.TRUE.; N=0
+   DO WHILE(POSSIBLE_FALSE_CV.OR.(INF_NORM(B_TERM).GT.B_PREC))
+      N_PM_P1=N+M_P1; N_P1=N+ONE; A_PM_PN=A_PM+N; B_PM_PN=B_PM+N
+      EPS_PM_P1_PN=EPS_PM_P1+N; N_P1_MEPS=ONE_MEPS+N
+      EPS_PM_PN=EPS_PM+N; EPS_PA_PM_PN=EPS_PA_PM+N 
+      EPS_PB_PM_PN=EPS_PB_PM+N
+      PROD1=EPS_PA_PM_PN*EPS_PB_PM_PN
+      PROD2=EPS_PM_P1_PN*N_P1
+      PROD3=A_PM_PN*B_PM_PN
+      B_TERM = MZP1*(B_TERM*PROD1/PROD2+B_EXTRA_TERM*(PROD3/N_PM_P1 &
+           -A_PM_PN-B_PM_PN-EPS+PROD1/N_P1)/(EPS_PM_P1_PN*N_P1_MEPS))
+      B_SUM=B_SUM+B_TERM
+      B_EXTRA_TERM=B_EXTRA_TERM*MZP1*PROD3/(N_PM_P1*N_P1_MEPS)
+      IF(POSSIBLE_FALSE_CV.AND.(N.GT.MIN_N)) THEN
+         POSSIBLE_FALSE_CV = &
+              (CV_POLY_DER_CALC(CV_POLY1_DER_TAB,DBLE(N)).GT.ZERO).OR. &
+              (CV_POLY_DER_CALC(CV_POLY2_DER_TAB,DBLE(N)).GT.ZERO)
+      ENDIF
+      N=N+1
+   ENDDO
+   IF(EPS.EQ.ZERO) THEN
+      HYP_PS_ONE=PHASE*(A_SUM+B_SUM)
+      RETURN
+   ELSE
+      HYP_PS_ONE=PHASE*(A_SUM+B_SUM)*PI_EPS/SIN(PI_EPS)
+      RETURN
+   ENDIF
+ END FUNCTION HYP_PS_ONE
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of the 2F1 power series 
+ ! -----------------------------------
+ ! converging with the 1/z transformation
+ ! --------------------------------------
+ ! The formula for F(z) in the 1/z transformation holds:
+ ! F(z) = (-1)^m (pi.eps)/sin (pi.eps) [A(z) + B(z)] 
+ ! for eps not equal to zero, 
+ ! F(z) = (-1)^m [A(z) + B(z)] for eps = 0
+ ! where m = |Re(b-a)], eps = b-a-m, 
+ ! A(z) = \sum_{n=0}^{m-1} alpha[n] z^{-n}, 
+ ! B(z) = \sum_{n=0}^{+oo} beta[n] z^{-n}, and:
+ !
+ ! alpha[0] = [Gamma_inv(1-m-eps)/eps] Gamma_inv(c-a) 
+ !          x Gamma_inv(a+m+eps) Gamma(c)
+ ! [Gamma_inv(1-m-eps)/eps] is calculated in A_sum_init. 
+ ! alpha[0] is calculated with log[Gamma] 
+ ! if the previous expression might overflow, 
+ ! and its imaginary part removed if a, b and c are real.
+ ! alpha[n+1] = (a+n)(1-c+a+n)/[(n+1)(1-m-eps+n)] alpha[n], 
+ ! n in [0:m-2].
+ !
+ ! beta[0] is defined in B_sum_init_PS_infinity function comments.
+ ! gamma[0] = Gamma(c) (a)_m (1-c+a)_m z^{-m} Gamma_inv(a+m+eps) 
+ !          x Gamma_inv(c-a) Gamma_inv(m+1) Gamma_inv(1-eps)
+ !
+ ! beta[n+1] = (a+m+n+eps)(1-c+a+m+n+eps)/[(m+n+1+eps)(n+1)] beta[n] 
+ ! + [(a+m+n)(1-c+a+m+n)/(m+n+1) - (a+m+n) - (1-c+a+m+n) 
+ ! - eps + (a+m+n+eps)(1-c+a+m+n+eps)/(n+1)]
+ ! x gamma[n]/[(n+m+1+eps)(n+1+eps)], n >= 0.
+ ! gamma[n+1] = (a+m+n)(b+m+n)/[(m+n+1)(n+1-eps)] gamma[n], n >= 0.
+ !
+ ! B(z) converges <=> |z| > 1
+ ! The test of convergence is |beta[n] z^{-n}|oo < 1E-15 |beta[0]|oo
+ ! for n large enough so that false convergence cannot occur.
+ !
+ ! Variables
+ ! ---------
+ ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z)
+ ! m,phase,m_p1,eps,a_mc_p1,one_meps,
+ ! one_meps_pm,a_pm,a_mc_p1_pm,cma: |Re(b-a)], (-1)^m, m+1, b-a-m, 
+ ! 1-c+a, 1-eps, 1-eps-m, a+m, 1-c+a+m, c-a
+ ! eps_pa,eps_pm_p1,eps_pa_mc_p1_pm,Pi_eps,eps_pa_pm,eps_pm,Gamma_c: 
+ ! eps+a, eps+m+1, eps+1-c+a+m, pi.eps, eps+a+m, eps+m, Gamma(c)
+ ! Gamma_inv_eps_pa_pm,Gamma_inv_cma,z_inv,pow_mz_ma,
+ ! Gamma_inv_one_meps,Gamma_prod: Gamma_inv(eps+a+m), Gamma_inv(c-a), 
+ ! 1/z, (-z)^(-a), Gamma_inv(1-eps), 
+ ! Gamma(c) Gamma_inv(c-a) Gamma_inv(eps+a+m)
+ ! A_first_term,A_sum,A_term: alpha[0], A(z), alpha[n] z^{-n}
+ ! pow_z_inv_m,B_first_term,prod_B,ratio: z^{-m}, beta[0], 
+ ! (a)_m (1-c+a)_m z^{-m}, (a+n)(1-c+a+n)/(n+1) for n in [0:m-2].
+ ! B_extra_term,B_term,B_sum,B_prec: 
+ ! gamma[n], beta[n] z^{-n}, B(z), 1E-15 |beta[0|oo
+ ! cv_poly1_der_tab,cv_poly2_der_tab: P1'(X) and P2'(X) coefficients 
+ ! of the potentials derivatives of P1(X) and P2(X) 
+ ! defined in cv_poly_der_tab_calc 
+ ! with parameters a1 = a, b1 = 1-c+a, c1 = 1-m-eps, z1 = 1/z 
+ ! and a2 = b, b2 = eps+1-c+a+m,c2 = eps+m+1, z2 = 1/z.
+ ! min_n: smallest integer after which false convergence cannot occur. 
+ !        It is calculated in min_n_calc with both P1'(X) and P2'(X), 
+ ! so one takes the largest integer coming from both calculations.
+ ! possible_false_cv: always true if n < min_n. If n >= min_n, 
+ ! it is true if P1'(n) > 0 or P2'(n) > 0. 
+ ! If n >= min_n and P1'(n) < 0 and P2'(n) < 0, 
+ ! it becomes false and remains as such for the rest of the calculation. 
+ ! One can then check if |beta[n] z^n|oo < 1E-15 to truncate the series.
+ ! n,n_pm_p1,n_p1,a_pm_pn,a_mc_p1_pm_pn,eps_pm_p1_pn,n_p1_meps,
+ ! eps_pa_pm_pn,eps_pa_mc_p1_pm_pn,eps_pm_pn: 
+ ! index of power series, n+m+1, n+1, a+m+n, 1-c+a+m+n, eps+m+n+1,
+ ! n+1-eps, eps+a+m+n, eps+1-c+a+m+n, eps+m+n,
+ ! prod1,prod2,prod3: (eps+a+m+n)(eps+1-c+a+m+n),
+ ! (eps+m+1+n)(n+1), (a+m+n)(1-c+a+m+n)
+ !----------------------------------------------------------------------
+ FUNCTION HYP_PS_INFINITY(A,B,C,Z)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: A,B,C,Z
+   INTEGER(IPR) :: N,M,PHASE,M_M2,MIN_N,MIN_N_CALC,M_P1
+   REAL(PR)     :: B_PREC,N_P1,N_PM_P1,CV_POLY_DER_CALC
+   COMPLEX(PR)  :: B_SUM_INIT_PS_INFINITY,LOG_GAMMA_CPLX,POW_Z_INV_M
+   COMPLEX(PR)  :: HYP_PS_INFINITY,Z_INV,GAMMA_INV,RATIO
+   COMPLEX(PR)  :: EPS,A_MC_P1,ONE_MEPS,ONE_MEPS_MM,A_PM,A_MC_P1_PM
+   COMPLEX(PR)  :: CMA,EPS_PA,EPS_PM_P1,EPS_PA_MC_P1_PM,PI_EPS
+   COMPLEX(PR)  :: EPS_PA_PM,EPS_PM,GAMMA_C,GAMMA_INV_CMA,POW_MZ_MA
+   COMPLEX(PR)  :: A_SUM_INIT,LOG_A_SUM_INIT,A_SUM,A_TERM
+   COMPLEX(PR)  :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_ONE_MEPS
+   COMPLEX(PR)  :: PROD_B,B_EXTRA_TERM,B_TERM,B_SUM,PROD1
+   COMPLEX(PR)  :: A_PM_PN,A_MC_P1_PM_PN,EPS_PM_P1_PN,N_P1_MEPS
+   COMPLEX(PR)  ::   PROD2,PROD3,GAMMA_PROD
+   COMPLEX(PR)  :: EPS_PA_PM_PN,EPS_PA_MC_P1_PM_PN,EPS_PM_PN
+   LOGICAL :: POSSIBLE_FALSE_CV
+   REAL(PR) :: CV_POLY1_DER_TAB(0:3),CV_POLY2_DER_TAB(0:3)
+   !
+   M=NINT(REAL(B-A,PR)); M_M2=M-2;M_P1=M+1
+   IF(MOD(M,2).EQ.0) THEN
+      PHASE=1
+   ELSE
+      PHASE=-1
+   ENDIF
+   EPS=B-A-M; A_MC_P1=ONE-C+A; ONE_MEPS=ONE-EPS; ONE_MEPS_MM=ONE_MEPS-M
+   A_PM=A+M; A_MC_P1_PM=A_MC_P1+M; CMA=C-A; EPS_PA=EPS+A
+   EPS_PM=EPS+M; EPS_PM_P1=EPS_PM+ONE; EPS_PA_MC_P1_PM=EPS+A_MC_P1_PM
+   PI_EPS=M_PI*EPS; EPS_PA_PM=EPS_PA+M
+   GAMMA_C=ONE/GAMMA_INV(C); GAMMA_INV_EPS_PA_PM = GAMMA_INV(EPS_PA_PM)
+   GAMMA_INV_ONE_MEPS = GAMMA_INV(ONE_MEPS)
+   GAMMA_INV_CMA=GAMMA_INV(CMA); Z_INV=ONE/Z;POW_MZ_MA=(-Z)**(-A)
+   GAMMA_PROD=GAMMA_C*GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM
+   IF(M.EQ.0) THEN
+      A_TERM=ZERO
+   ELSE IF(INF_NORM(ONE_MEPS_MM &
+        *(LOG(ONE + ABS(ONE_MEPS_MM))-ONE)).LT.300.0d0) THEN
+      A_TERM=GAMMA_PROD*A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS)
+   ELSE
+      A_TERM=EXP(LOG_GAMMA_CPLX(C)-LOG_GAMMA_CPLX(CMA)-LOG_GAMMA_CPLX(B) &
+           + LOG_A_SUM_INIT(M,EPS))
+      IF((AIMAG(A).EQ.ZERO).AND.(AIMAG(B).EQ.ZERO).AND.     &
+           (AIMAG(C).EQ.ZERO)) THEN
+         A_TERM=REAL(A_TERM,PR)
+      ENDIF
+   ENDIF
+   A_SUM=A_TERM
+   POW_Z_INV_M=Z_INV**M
+   B_TERM=B_SUM_INIT_PS_INFINITY(A,C,GAMMA_C,GAMMA_INV_CMA, &
+        GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM,Z,M,EPS)*POW_Z_INV_M
+   PROD_B=POW_Z_INV_M
+   DO N=0,M_M2
+      RATIO=(A+N)*(A_MC_P1+N)/(N+ONE)
+      A_TERM = A_TERM*Z_INV*RATIO/(N+ONE_MEPS_MM)
+      A_SUM = A_SUM+A_TERM
+      PROD_B = PROD_B*RATIO
+   ENDDO
+   IF (M.GT.0) THEN
+      PROD_B=PROD_B*(A+M-ONE)*(A_MC_P1+M-ONE)/DBLE(M)
+   ENDIF
+   B_EXTRA_TERM = PROD_B*GAMMA_PROD*GAMMA_INV_ONE_MEPS
+   B_SUM=B_TERM
+   B_PREC=EPS15*INF_NORM(B_TERM)
+   CALL CV_POLY_DER_TAB_CALC(A,A_MC_P1,ONE_MEPS_MM,Z_INV, &
+        CV_POLY1_DER_TAB)
+   CALL CV_POLY_DER_TAB_CALC(B,EPS_PA_MC_P1_PM,EPS_PM_P1, &
+        Z_INV,CV_POLY2_DER_TAB)
+   MIN_N=MAX(MIN_N_CALC(CV_POLY1_DER_TAB),MIN_N_CALC(CV_POLY2_DER_TAB))
+   POSSIBLE_FALSE_CV=.TRUE.; N=0
+   DO WHILE(POSSIBLE_FALSE_CV.OR.(INF_NORM(B_TERM).GT.B_PREC))
+      N_PM_P1=N+M_P1; N_P1=N+ONE; A_PM_PN=A_PM+N
+      A_MC_P1_PM_PN=A_MC_P1_PM+N; EPS_PM_P1_PN=EPS_PM_P1+N
+      N_P1_MEPS=N_P1-EPS; EPS_PA_PM_PN=EPS_PA_PM+N
+      EPS_PA_MC_P1_PM_PN=EPS_PA_MC_P1_PM+N; EPS_PM_PN=EPS_PM+N
+      PROD1=EPS_PA_PM_PN*EPS_PA_MC_P1_PM_PN; PROD2=EPS_PM_P1_PN*N_P1
+      PROD3=A_PM_PN*A_MC_P1_PM_PN
+      B_TERM = Z_INV*(B_TERM*PROD1/PROD2+B_EXTRA_TERM*(PROD3/N_PM_P1 &
+           -A_PM_PN-A_MC_P1_PM_PN-EPS+PROD1/N_P1)                    &
+           /(EPS_PM_P1_PN*N_P1_MEPS))
+      B_SUM=B_SUM+B_TERM
+      B_EXTRA_TERM=B_EXTRA_TERM*Z_INV*PROD3/(N_PM_P1*N_P1_MEPS)
+      IF(POSSIBLE_FALSE_CV.AND.(N.GT.MIN_N)) THEN
+         POSSIBLE_FALSE_CV = (CV_POLY_DER_CALC( &
+              CV_POLY1_DER_TAB,DBLE(N)).GT.ZERO).OR.(&
+              CV_POLY_DER_CALC(CV_POLY2_DER_TAB,DBLE(N)).GT.ZERO)
+      ENDIF
+      N=N+1
+   ENDDO
+   IF(EPS.EQ.ZERO) THEN
+      HYP_PS_INFINITY=PHASE*POW_MZ_MA*(A_SUM+B_SUM)
+      RETURN
+   ELSE
+      HYP_PS_INFINITY=PHASE*POW_MZ_MA*(A_SUM+B_SUM)*PI_EPS &
+           /SIN(PI_EPS)
+      RETURN
+   ENDIF
+ END FUNCTION HYP_PS_INFINITY
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of F(z) in transformation theory missing zones 
+ ! ----------------------------------------------------------
+ ! of the complex plane with a Taylor series
+ ! -----------------------------------------
+ ! If z is close to exp(+/- i.pi/3), no transformation in 1-z, z, 
+ ! z/(z-1) or combination of them can transform z in a complex number 
+ ! of modulus smaller than a given Rmax < 1 .
+ ! Rmax is a radius for which one considers power series summation 
+ ! for |z| > Rmax is too slow to be processed. One takes Rmax = 0.9 .
+ ! Nevertheless, for Rmax = 0.9, 
+ ! these zones are small enough to be handled 
+ ! with a Taylor series expansion around a point z0 close to z 
+ ! where transformation theory can be used to calculate F(z).
+ ! One then chooses z0 to be 0.9 z/|z| if |z| < 1, and 1.1 z/|z| 
+ ! if |z| > 1, 
+ ! so that hyp_PS_zero or hyp_PS_infinity can be used 
+ ! (see comments of these functions above).
+ ! For this z0, F(z) = \sum_{n=0}^{+oo} q[n] (z-z0)^n, with:
+ ! q[0] = F(z0), q[1] = F'(z0) = (a b/c) 2F1(a+1,b+1,c+1,z0)
+ ! q[n+2] = [q[n+1] (n (2 z0 - 1) - c + (a+b+c+1) z0) 
+ ! + q[n] (a+n)(b+n)/(n+1)]/(z0(1-z0)(n+2))
+ ! As |z-z0| < 0.1, it converges with around 15 terms, 
+ ! so that no instability can occur for moderate a, b and c.
+ ! Convergence is tested 
+ ! with |q[n] (z-z0)^n|oo + |q[n+1] (z-z0)^{n+1}|oo. 
+ ! Series is truncated when this test is smaller 
+ ! than 1E-15 (|q[0]|oo + |q[1] (z-z0)|oo).
+ ! No false convergence can happen here 
+ ! as q[n] behaves smoothly for n -> +oo.
+ !
+ ! Variables
+ ! ---------
+ ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z)
+ ! abs_z,is_abs_z_small: |z|, true if |z| < 1 and false if not.
+ ! z0,zc_z0_ratio,z0_term1,z0_term2: 0.9 z/|z| if |z| < 1, 
+ ! and 1.1 z/|z| if |z| > 1, (z-z0)/(z0 (1-z0)), 
+ ! 2 z0 - 1, c - (a+b+c+1) z0
+ ! hyp_PS_z0,dhyp_PS_z0,prec: F(z0), F'(z0) calculated with 2F1 
+ ! as F'(z0) = (a b/c) 2F1(a+1,b+1,c+1,z0), 
+ ! precision demanded for series truncation 
+ ! equal to 1E-15 (|q[0]|oo + |q[1] (z-z0)|oo).
+ ! n,an,anp1,anp2,sum: index of the series, q[n] (z-z0)^n, 
+ ! q[n+1] (z-z0)^{n+1}, q[n+2] (z-z0)^{n+2}, 
+ ! truncated sum of the power series.
+ !----------------------------------------------------------------------
+ FUNCTION HYP_PS_COMPLEX_PLANE_REST(A,B,C,Z)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: A,B,C,Z
+   INTEGER(IPR) :: N
+   REAL(PR)     :: ABS_Z,PREC
+   COMPLEX(PR)  :: HYP_PS_COMPLEX_PLANE_REST
+   COMPLEX(PR)  :: Z0,ZC,ZC_Z0_RATIO,Z0_TERM1,Z0_TERM2
+   COMPLEX(PR)  :: HYP_PS_Z0,DHYP_PS_Z0,AN,ANP1,ANP2
+   COMPLEX(PR)  :: HYP_PS_ZERO,HYP_PS_INFINITY
+   !
+   ABS_Z=ABS(Z)
+   IF(ABS_Z.LT.ONE) THEN
+      Z0=0.9D0*Z/ABS_Z; ZC=Z-Z0; ZC_Z0_RATIO=ZC/(Z0*(ONE-Z0))
+      Z0_TERM1=TWO*Z0 - ONE; Z0_TERM2=C-(A+B+ONE)*Z0
+      HYP_PS_Z0=HYP_PS_ZERO(A,B,C,Z0)
+      DHYP_PS_Z0=HYP_PS_ZERO(A+ONE,B+ONE,C+ONE,Z0)*A*B/C 
+   ELSE
+      Z0=1.1D0*Z/ABS_Z; ZC=Z-Z0; ZC_Z0_RATIO=ZC/(Z0*(ONE-Z0))
+      Z0_TERM1=TWO*Z0 - ONE; Z0_TERM2=C-(A+B+ONE)*Z0
+      HYP_PS_Z0=HYP_PS_INFINITY(A,B,C,Z0)
+      DHYP_PS_Z0=HYP_PS_INFINITY(A+ONE,B+ONE,C+ONE,Z0)*A*B/C 
+   ENDIF
+   AN=HYP_PS_Z0;ANP1=ZC*DHYP_PS_Z0;HYP_PS_COMPLEX_PLANE_REST=AN+ANP1
+   PREC=EPS15*(INF_NORM(AN)+INF_NORM(ANP1)); N=0
+   DO WHILE(INF_NORM(AN).GT.PREC)
+      ANP2=ZC_Z0_RATIO*(ANP1*(N*Z0_TERM1-Z0_TERM2)+AN*ZC*(A+N)*(B+N) &
+           /(N+ONE))/(N+TWO)
+      HYP_PS_COMPLEX_PLANE_REST = HYP_PS_COMPLEX_PLANE_REST + ANP2
+      N=N+1
+      AN=ANP1
+      ANP1=ANP2
+   ENDDO
+   RETURN
+ END FUNCTION HYP_PS_COMPLEX_PLANE_REST
+ 
+ !
+ !----------------------------------------------------------------------
+ ! Calculation of F(z) for arbitrary z using previous routines
+ ! -----------------------------------------------------------
+ ! Firstly, it is checked if a,b and c are negative integers.
+ ! If neither a nor b is negative integer but c is, 
+ ! F(z) is undefined so that the program stops with an error message.
+ ! If a and c are negative integers with c < a, 
+ ! or b and c are negative integers with b < a, 
+ ! or c is not negative integer integer but a or b is, 
+ ! one is in the polynomial case.
+ ! In this case, if |z| < |z/(z-1)| or z = 1, 
+ ! hyp_PS_zero is used directly, as then |z| <= 2 
+ ! and no instability arises with hyp_PS_zero 
+ ! as long the degree of the polynomial is small (<= 10 typically).
+ ! If not, one uses the transformation 
+ ! F(z) = (1-z)^{-a} 2F1(a,c-b,c,z/(z-1)) if a is negative integer 
+ ! or F(z) = (1-z)^{-b} 2F1(b,c-a,c,z/(z-1)) if b is negative integer 
+ ! along with hyp_PS_zero.
+ ! Indeed, 2F1(a,c-b,c,X) is a polynomial if a is negative integer, 
+ ! and so is 2F1(b,c-a,c,X) if b is negative integer, 
+ ! so that one has here |z/(z-1)| <= 2 
+ ! and the stability of the method is the same 
+ ! as for the |z| < |z/(z-1)| case.
+ ! If one is in the non-polynomial case, one checks if z >= 1. 
+ ! If it is, one is the cut of F(z) 
+ ! so that z is replaced by z - 10^{-307}i.
+ ! Then, using F(z) = 2F1(b,a,c,z) 
+ ! and F(z) = (1-z)^{c-a-b} 2F1(c-a,c-b,c,z), 
+ ! one replaces a,b,c parameters by combinations of them 
+ ! so that Re(b-a) >= 0 and Re(c-a-b) >= 0.
+ ! Exchanging a and b does not change convergence properties, 
+ ! while having Re(c-a-b) >= 0 accelerates it 
+ ! (In hyp_PS_zero, t[n] z^n ~ z^n/(n^{c-a-b}) for n -> +oo).
+ ! If |1-z| < 1E-5, one uses hyp_PS_one 
+ ! as the vicinity of the singular point z = 1 is treated properly.
+ ! After that, one compares |z| and |z/(z-1)| 
+ ! to R in {0.5,0.6,0.7,0.8,0.9}. 
+ ! If one of them is smaller than R, 
+ ! one uses hyp_PS_zero without transformation
+ ! or with the transformation F(z) = (1-z)^{-a} 2F1(a,c-b,c,z/(z-1)).
+ ! Then, if both of them are larger than 0.9, 
+ ! one compares |1/z|, |(z-1)/z|, |1-z| and |1/(1-z)| 
+ ! to R in {0.5,0.6,0.7,0.8,0.9}. 
+ ! If one of them is found smaller than R, 
+ ! with the condition that |c-b|oo < 5 for (z-1)/z transformation, 
+ ! |a,b,c|oo < 5 for |1-z| transformation 
+ ! and |a,c-b,c|oo < 5 for |1/(1-z)| transformation,
+ ! the corresponding transformation is used. 
+ ! If none of them was smaller than 0.9, 
+ ! one is in the missing zones of transformation theory 
+ ! so that the Taylor series of hyp_PS_complex_plane_rest is used.
+ !
+ ! Variables
+ ! ---------
+ ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z)
+ ! Re_a,Re_b,Re_c,na,nb,nc,is_a_neg_int,is_b_neg_int,is_c_neg_int: 
+ ! real parts of a,b,c, closest integers to a,b,c, 
+ ! true if a,b,c is negative integers and false if not.
+ ! zm1,z_over_zm1,z_shift: z-1, z/(z-1), z - 10^{-307}i in case z >= 1.
+ ! ab_condition, cab_condition: true if Re(b-a) >= 0 and false if not, 
+ ! true if Re(c-a-b) >= 0 and false if not.
+ ! abs_zm1,abz_z,abs_z_inv,abs_z_over_zm1,abs_zm1_inv,abs_zm1_over_z: 
+ ! |z-1|, |z|, |1/z|, |z/(z-1)|, |1/(z-1)|, |(z-1)/z|
+ ! are_ac_small: true if |a|oo < 5 and |c|oo < 5, false if not.
+ ! is_cmb_small: true if |c-b|oo < 5, false if not.
+ ! are_abc_small: true if |a|oo < 5, |b|oo < 5 and |c|oo < 5, 
+ ! false if not.
+ ! are_a_cmb_c_small: true if |a|oo < 5, |c-b|oo < 5 and |c|oo < 5, 
+ ! false if not.
+ ! R_tab,R: table of radii {0.5,0.6,0.7,0.8,0.9}, one of these radii.
+ ! res: returned result
+ !----------------------------------------------------------------------
+ RECURSIVE FUNCTION HYP_2F1(A,B,C,Z) RESULT(RES)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+   COMPLEX(PR),INTENT(IN) :: A,B,C,Z
+   INTEGER(IPR) :: NA,NB,NC,I
+   REAL(PR)     :: RE_A,RE_B,RE_C,ABS_Z,ABS_ZM1,ABS_Z_OVER_ZM1
+   REAL(PR)     :: ABS_ZM1_OVER_Z,ABS_ZM1_INV,R_TABLE(1:5),R,ABS_Z_INV
+   COMPLEX(PR)  :: RES,HYP_PS_INFINITY,HYP_PS_ZERO,Z_SHIFT
+   COMPLEX(PR)  :: HYP_PS_COMPLEX_PLANE_REST,HYP_PS_ONE,Z_OVER_ZM1,ZM1
+   LOGICAL      :: IS_A_NEG_INT,IS_B_NEG_INT,IS_C_NEG_INT
+   LOGICAL      :: AB_CONDITION,CAB_CONDITION,ARE_A_CMB_C_SMALL
+   LOGICAL      :: IS_CMB_SMALL,ARE_AC_SMALL,ARE_ABC_SMALL
+   !
+   RE_A=REAL(A,PR); RE_B=REAL(B,PR); RE_C=REAL(C,PR);
+   NA=NINT(RE_A); NB=NINT(RE_B); NC=NINT(RE_C);
+   IS_A_NEG_INT=A.EQ.NA.AND.NA.LE.0
+   IS_B_NEG_INT=B.EQ.NB.AND.NB.LE.0
+   IS_C_NEG_INT=C.EQ.NC.AND.NC.LE.0
+   ZM1=Z-ONE
+   IF(IS_C_NEG_INT) THEN
+      ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1
+      ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1)
+      IF(IS_A_NEG_INT.AND.(NC.LT.NA)) THEN
+         IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN
+            RES=HYP_PS_ZERO(A,B,C,Z)
+            RETURN
+         ELSE
+            RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z_OVER_ZM1)
+            RETURN
+         ENDIF
+      ELSE IF(IS_B_NEG_INT.AND.(NC.LT.NB)) THEN
+         IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN
+            RES=HYP_PS_ZERO(A,B,C,Z)
+            RETURN
+         ELSE
+            RES=((-ZM1)**(-B))*HYP_PS_ZERO(B,C-A,C,Z_OVER_ZM1)
+            RETURN
+         ENDIF
+      ELSE
+         STOP '2F1 UNDEFINED'
+      ENDIF
+   ENDIF
+   IF(IS_A_NEG_INT) THEN
+      ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1
+      ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1)
+      IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN
+         RES=HYP_PS_ZERO(A,B,C,Z)
+         RETURN
+      ELSE
+         RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z_OVER_ZM1)
+         RETURN
+      ENDIF
+   ELSE IF(IS_B_NEG_INT) THEN
+      ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1
+      ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1)
+      IF((Z.EQ.ONE).OR.(ABS_Z.LT.ABS_Z_OVER_ZM1)) THEN
+         RES=HYP_PS_ZERO(A,B,C,Z)
+         RETURN
+      ELSE
+         RES=((-ZM1)**(-B))*HYP_PS_ZERO(B,C-A,C,Z_OVER_ZM1)
+         RETURN
+      ENDIF
+   ENDIF
+   IF((REAL(Z,PR).GE.ONE).AND.(AIMAG(Z).EQ.ZERO)) THEN
+      Z_SHIFT=CMPLX(REAL(Z,PR),-1.0D-307,PR)
+      RES=HYP_2F1(A,B,C,Z_SHIFT)
+      RETURN
+   ENDIF
+   AB_CONDITION = (RE_B.GE.RE_A)
+   CAB_CONDITION = (RE_C.GE.RE_A + RE_B)
+   IF ((.NOT.AB_CONDITION).OR.(.NOT.CAB_CONDITION)) THEN
+      IF ((.NOT.AB_CONDITION).AND.(CAB_CONDITION)) THEN
+         RES=HYP_2F1(B,A,C,Z)
+         RETURN
+      ELSE IF((.NOT.CAB_CONDITION).AND.(AB_CONDITION)) THEN
+         RES=((-ZM1)**(C-A-B))*HYP_2F1(C-B,C-A,C,Z)
+         RETURN
+      ELSE
+         RES=((-ZM1)**(C-A-B))*HYP_2F1(C-A,C-B,C,Z)
+         RETURN 
+      ENDIF
+   ENDIF
+   ABS_ZM1=ABS(ZM1)
+   IF(ABS_ZM1.LT.1D-5) THEN 
+      RES=HYP_PS_ONE (A,B,C,-ZM1)
+      RETURN
+   ENDIF
+   ABS_Z=ABS(Z); ABS_Z_OVER_ZM1=ABS_Z/ABS_ZM1; ABS_Z_INV=ONE/ABS_Z
+   ABS_ZM1_OVER_Z=ONE/ABS_Z_OVER_ZM1; ABS_ZM1_INV=ONE/ABS_ZM1
+   IS_CMB_SMALL = INF_NORM(C-B).LT.5.0D0; 
+   ARE_AC_SMALL = (INF_NORM(A).LT.5.0D0).AND.(INF_NORM(C).LT.5.0D0)
+   ARE_ABC_SMALL = ARE_AC_SMALL.AND.(INF_NORM(B).LT.5.0D0)
+   ARE_A_CMB_C_SMALL = ARE_AC_SMALL.AND.IS_CMB_SMALL
+   R_TABLE=(/0.5D0,0.6D0,0.7D0,0.8D0,0.9D0/)
+   DO I=1,5
+      R=R_TABLE(I)
+      IF(ABS_Z.LE.R) THEN 
+         RES=HYP_PS_ZERO (A,B,C,Z)
+         RETURN
+      ENDIF
+      IF(IS_CMB_SMALL.AND.(ABS_Z_OVER_ZM1.LE.R)) THEN
+         RES=((-ZM1)**(-A))*HYP_PS_ZERO (A,C-B,C,Z/ZM1)
+         RETURN
+      ENDIF
+   ENDDO
+   DO I=1,5
+      R=R_TABLE(I)
+      IF(ABS_Z_INV.LE.R) THEN 
+         RES=HYP_PS_INFINITY (A,B,C,Z)
+         RETURN 
+      ENDIF
+      IF(IS_CMB_SMALL.AND.(ABS_ZM1_OVER_Z.LE.R)) THEN 
+         RES=((-ZM1)**(-A))*HYP_PS_INFINITY (A,C-B,C,Z/ZM1)
+         RETURN
+      ENDIF
+      IF(ARE_ABC_SMALL.AND.(ABS_ZM1.LE.R)) THEN 
+         RES=HYP_PS_ONE (A,B,C,-ZM1)
+         RETURN
+      ENDIF
+      IF(ARE_A_CMB_C_SMALL.AND.(ABS_ZM1_INV.LE.R)) THEN 
+         RES=((-ZM1)**(-A))*HYP_PS_ONE (A,C-B,C,-ONE/ZM1)
+         RETURN
+      ENDIF
+   ENDDO
+   RES=HYP_PS_COMPLEX_PLANE_REST (A,B,C,Z)
+   RETURN
+ END FUNCTION HYP_2F1
+ 
+ 
+ 
+ !
+ !----------------------------------------------------------------------
+ ! Test of 2F1 numerical accuracy 
+ ! ------------------------------
+ ! using hypergeometric differential equation
+ ! ------------------------------------------
+ ! If z = 0, F(z) = 1 so that this value is trivially tested.
+ ! To test otherwise if the value of F(z) is accurate, 
+ ! one uses the fact that 
+ ! z(z-1) F''(z) + (c - (a+b+1) z) F'(z) - a b F(z) = 0.
+ ! If z is not equal to one, a relative precision test is provided 
+ ! by |F''(z) + [(c - (a+b+1) z) F'(z) - a b F(z)]/[z(z-1)]|oo
+ ! /(|F(z)|oo + F'(z)|oo + |F''(z)|oo).
+ ! If z is equal to one, one uses |(c - (a+b+1)) F'(z) - a b F(z)|oo
+ ! /(|F(z)|oo + F'(z)|oo + 1E-307).
+ ! F'(z) and F''(z) are calculated using equalities 
+ ! F'(z) = (a b/c) 2F1(a+1,b+1,c+1,z) 
+ ! and F'(z) = ((a+1)(b+1)/(c+1)) (a b/c) 2F1(a+2,b+2,c+2,z).
+ !
+ ! Variables
+ ! ---------
+ ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z)
+ ! F,dF,d2F: F(z), F'(z) and F''(z) calculated with hyp_2F1 
+ ! using F'(z) = (a b/c) 2F1(a+1,b+1,c+1,z) 
+ ! and F'(z) = ((a+1)(b+1)/(c+1)) (a b/c) 2F1(a+2,b+2,c+2,z).
+ !----------------------------------------------------------------------
+ 
+ FUNCTION TEST_2F1(A,B,C,Z,F)
+   !--------------------------------------------------------------------
+   USE HYP_2F1_MODULE
+   IMPLICIT NONE
+ 
+   COMPLEX(PR),INTENT(IN) :: A,B,C,Z
+   REAL(PR)    :: TEST_2F1
+   COMPLEX(PR) :: F,DF,D2F,HYP_2F1  
+   !
+   IF(Z.EQ.ZERO) THEN
+      TEST_2F1=INF_NORM(F-ONE)
+      RETURN
+   ELSE IF(Z.EQ.ONE) THEN
+      DF = HYP_2F1(A+ONE,B+ONE,C+ONE,Z)*A*B/C
+      TEST_2F1=INF_NORM((C-(A+B+ONE))*DF-A*B*F) &
+           /(INF_NORM (F)+INF_NORM(DF)+1D-307)
+      RETURN
+   ELSE
+      DF = HYP_2F1(A+ONE,B+ONE,C+ONE,Z)*A*B/C
+      D2F = HYP_2F1(A+TWO,B+TWO,C+TWO,Z)*A*(A+ONE)*B*(B+ONE) &
+           /(C*(C+ONE))
+      TEST_2F1=INF_NORM(D2F+((C-(A+B+ONE)*Z)*DF-A*B*F)/(Z*(ONE-Z))) &
+           /(INF_NORM(F)+INF_NORM(DF)+INF_NORM(D2F))
+      RETURN
+   ENDIF
+ END FUNCTION TEST_2F1
+ !
+ !============== END HYP_2F1 FILE ======================================
+ 
diff -r -c -b -B -N cosmomc/fieldinf/infbackmain.f90 cosmomc_fields/fieldinf/infbackmain.f90
*** cosmomc/fieldinf/infbackmain.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infbackmain.f90	2010-07-13 14:52:23.000000000 +0200
***************
*** 0 ****
--- 1,155 ----
+ 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) :: ricci, ricciOverH2
+   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 = 'mixinf'
+ 
+ !parameters (see infbgmodel.f90)
+   infParam%consts(1) = 1e-5
+   infParam%consts(2) = 2
+   infParam%consts(3) = 0.
+   infParam%consts(4) = 0.
+   infParam%consts(5) = 1.
+   infParam%consts(6) = 0.5
+   infParam%consts(7:11) = 0.
+   infParam%consts(12) = 4
+ 
+ !initial field value.
+   infParam%conforms(1) = 1
+   infParam%matters(1) = 0
+ 
+ 
+ 
+ !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,50000,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
+ 
+      call delete_file('resfield.dat')
+      call delete_file('resfielDotd.dat')
+      call delete_file('reshubble.dat')
+      call delete_file('resepsilons.dat')
+      call delete_file('resricci.dat')
+ 
+      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
+         ricciOverH2 = 6._kp*(2._kp-epsilon1)
+         ricci = ricciOverH2*hubble*hubble
+         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)
+         call livewrite('resricci.dat',efold,riccioverH2,ricci)
+         inum = inum + 1
+         ptrRun => ptrRun%ptr             
+      enddo
+      ptrRun => null()
+      print *,'inum',inum
+      print *,'count',count_infbg_data(ptrToBgdata)
+   endif
+ 
+   if (associated(ptrToBgdata)) then
+      call free_infbg_data(ptrToBgdata)
+   endif
+ 
+  
+   infIni = set_infbg_ini(infParam)
+   print *,'After ini again'
+   print *,'mass=',matterParam(1)
+   print *,'infPAram',infParam
+   print *,'infIni',infIni
+ 
+ !evolves the background
+   infEnd = bg_field_evol(infIni,100,infObs,ptrToBgdata)
+   
+ 
+ !print the physical quantities at the end of inflation
+   print *,'infEnd', infEnd, (infEnd==infIni)
+   print *,'infObs',infObs
+   print *
+  
+ 
+ end program infbackmain
+ 
+ 
+  
diff -r -c -b -B -N cosmomc/fieldinf/infbg.f90 cosmomc_fields/fieldinf/infbg.f90
*** cosmomc/fieldinf/infbg.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infbg.f90	2010-07-13 14:38:34.000000000 +0200
***************
*** 0 ****
--- 1,1582 ----
+ module infbg
+   use infprec, only : kp, tolkp
+   use infbgmodel, only : matterNum, dilatonNum, fieldNum
+ !background evolution in the Einstein FLRW Frame for multifields:
+ !scalar gravity + matter fields.
+ 
+   implicit none
+ 
+   private
+ 
+    
+ !for debugging
+   logical, parameter :: display = .false.
+   logical, parameter :: dump_file = .false.
+  
+ 
+ !to store snapshot (ini or end, or more)
+   type infbgphys    
+      sequence
+      real(kp) :: efold, hubble, epsilon1, epsilon1JF
+      real(kp), dimension(fieldNum) :: field
+      real(kp), dimension(fieldNum) :: fieldDot
+   end type infbgphys
+ 
+ 
+ !to store the bg integration as chained list
+   type infbgdata
+      type(infbgphys) :: bg
+      type(infbgdata), pointer :: ptr => null()
+   end type infbgdata
+   
+ 
+   interface operator (==)     
+      module procedure infbgphys_equal
+   end interface
+ 
+ 
+   interface operator (/=)
+      module procedure infbgphys_unequal
+   end interface
+ 
+ 
+ 
+   public infbgdata, infbgphys
+   public operator(==),operator(/=)
+   public free_infbg_data, count_infbg_data
+ 
+   public set_infbg_ini
+   public rescale_potential
+   public bg_field_evol, bg_field_dot_coupled
+  
+   public slowroll_first_parameter, slowroll_first_parameter_JF
+   public slowroll_second_parameter, hubble_parameter_square
+ 
+   public potential, deriv_potential, deriv_second_potential
+ 
+   public connection_affine, deriv_connection_affine
+   
+   public matter_energy_density, matter_energy_density_JF
+ 
+ 
+ contains
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !recursivity need enough stacksize for big lists, otherwise it
+ !segfaults. Only needed to store and free the data in memory.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+   function infbgphys_equal(infbgphysA, infbgphysB)
+     implicit none
+     type(infbgphys), intent(in) :: infbgphysA, infbgphysB
+     logical :: infbgphys_equal
+ 
+     infbgphys_equal = ((infbgphysA%efold == infbgphysB%efold) &
+          .and. (infbgphysA%hubble == infbgphysB%hubble) &
+          .and. (infbgphysA%epsilon1 == infbgphysB%epsilon1) &
+          .and. (infbgphysA%epsilon1JF == infbgphysB%epsilon1JF) &
+          .and. all(infbgphysA%field == infbgphysB%field) &
+          .and. all(infbgphysA%fieldDot == infbgphysB%fieldDot))
+ 
+   end function infbgphys_equal
+ 
+ 
+ 
+   function infbgphys_unequal(infbgphysA, infbgphysB)
+     implicit none
+     type(infbgphys), intent(in) :: infbgphysA, infbgphysB
+     logical :: infbgphys_unequal
+ 
+     infbgphys_unequal = ((infbgphysA%efold /= infbgphysB%efold) &
+          .or. (infbgphysA%hubble /= infbgphysB%hubble) &
+          .or. (infbgphysA%epsilon1 /= infbgphysB%epsilon1) &
+          .or. (infbgphysA%epsilon1JF /= infbgphysB%epsilon1JF) &
+          .or. any(infbgphysA%field /= infbgphysB%field) &
+          .or. any(infbgphysA%fieldDot /= infbgphysB%fieldDot))
+ 
+   end function infbgphys_unequal
+ 
+ 
+ 
+   recursive subroutine free_infbg_data(ptrFirst)
+     implicit none
+     type(infbgdata), pointer :: ptrFirst
+ 
+     if (associated(ptrFirst%ptr)) call free_infbg_data(ptrFirst%ptr)
+     deallocate(ptrFirst)
+ 
+   end subroutine free_infbg_data
+ 
+ 
+ 
+   recursive function count_infbg_data(ptrFirst) result(bgdataCount)
+     implicit none    
+     integer :: bgdataCount
+     type(infbgdata), pointer :: ptrFirst
+ 
+     bgdataCount = 1
+     if (associated(ptrFirst%ptr)) then
+        bgdataCount =  count_infbg_data(ptrFirst%ptr) + 1       
+     endif
+ 
+   end function count_infbg_data
+ 
+   
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !inflation settings: initial conditions, rescaling, normalisation...
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function set_infbg_ini(infParam)
+ !to start on the attractor. This is epsilon2 = 0 for epsilon1<<1
+ !initialy.
+     use infbgmodel, only : infbgparam, metric_inverse
+     use infsrmodel, only : slowroll_initial_matter_lf
+     use infsrmodel, only : slowroll_initial_matter_sf
+     use infsrmodel, only : slowroll_initial_matter_hy
+     use infsrmodel, only : slowroll_initial_matter_rm
+     use infsrmodel, only : slowroll_initial_matter_kksf
+     use infsrmodel, only : slowroll_initial_matter_kklt
+     use infsrmodel, only : slowroll_initial_matter_mix
+ 
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     type(infbgphys) :: set_infbg_ini
+     
+     real(kp) :: hubbleSquareIni
+     type(infbgphys) :: infIni
+ 
+ 
+     infIni%field(1:matterNum) = infParam%matters
+     infIni%field(matterNum+1:fieldNum) = infParam%conforms
+ 
+ 
+ !if the matter fields are set to 0, use slow-roll guesses
+     if (all(infParam%matters == 0._kp)) then
+ 
+        select case (infParam%name)
+ 
+        case ('largef')
+           infIni%field(1:matterNum) = slowroll_initial_matter_lf(infParam)
+ 
+        case ('smallf')
+           infIni%field(1:matterNum) = slowroll_initial_matter_sf(infParam)
+              
+        case ('hybrid')
+           infIni%field(1:matterNum) = slowroll_initial_matter_hy(infParam)
+ 
+        case ('runmas')
+           infIni%field(1:matterNum) = slowroll_initial_matter_rm(infParam)
+           
+        case ('kklmmt')
+           infIni%field(1:matterNum) = slowroll_initial_matter_kklt(infParam)
+ 
+        case ('mixinf')
+           infIni%field(1:matterNum) = slowroll_initial_matter_mix(infParam)
+           
+ 
+        end select
+ 
+     endif
+ 
+ 
+     infIni%fieldDot &
+          = - matmul(metric_inverse(infIni%field),deriv_ln_potential(infIni%field))
+ !    infIni%fieldDot = 0._kp
+ !    print *,'initial condition fieldDot=',infIni%fieldDot
+ 
+ !    infIni%fieldDot(1)=1.
+ !    infIni%fieldDot(2)=-0.5
+ !    infIni%fieldDot(3)=0.6
+ 
+     hubbleSquareIni = hubble_parameter_square(infIni%field,infIni%fieldDot,.false.)
+ 
+     if (hubbleSquareIni.ge.0._kp) then
+        infIni%hubble = sqrt(hubbleSquareIni)       
+     else     
+        stop 'H^2 < 0, check initial condition'
+     endif
+ 
+     infIni%epsilon1 = slowroll_first_parameter(infIni%field,infIni%fieldDot, .false.)
+     infIni%epsilon1JF = slowroll_first_parameter_JF(infIni%field, infIni%fieldDot,.false.)
+     infIni%efold = 0._kp
+ 
+     set_infbg_ini = infIni
+    
+     if (display) then
+        if (infIni%epsilon1.lt.epsilon(1._kp)) then
+           write(*,*)
+           write(*,*)'set_infbg_ini: epsilon1 < accuracy',infIni%epsilon1
+           write(*,*)
+        endif
+     endif
+ 
+   end function  set_infbg_ini
+ 
+ 
+ 
+ 
+ 
+   subroutine rescale_potential(scale,infParam,infIni,infEnd,infObs,ptrBgdata)
+ !update all relevant data such as Unew = scale*Uold
+     use infbgmodel, only : infbgparam, conformal_factor_square
+     use infbgmodel, only : set_infbg_param
+     implicit none
+     type(infbgparam), intent(inout) :: infParam
+     type(infbgphys), intent(inout) :: infIni,infEnd,infObs
+     type(infbgdata), optional, pointer :: ptrBgdata
+     real(kp), intent(in) :: scale
+ 
+     type(infbgdata), pointer :: ptrRun    
+     logical :: updateBgParams
+ 
+     ptrRun => null()
+ 
+ !see infbgmodel U propto M^4
+     infParam%consts(1) = infParam%consts(1)*scale**0.25
+ 
+     updateBgParams = set_infbg_param(infParam)
+     if (.not.updateBgParams) stop 'rescale_potential: updating params failed!'
+     
+     infIni%hubble = infIni%hubble * sqrt(scale)
+     infEnd%hubble = infEnd%hubble * sqrt(scale)
+     infObs%hubble = infObs%hubble * sqrt(scale)
+ 
+     if (present(ptrBgData)) then
+        if (associated(ptrBgdata)) then
+           ptrRun => ptrBgdata
+           do while (associated(ptrRun))
+              ptrRun%bg%hubble = ptrRun%bg%hubble * sqrt(scale)
+              ptrRun => ptrRun%ptr
+           enddo
+           ptrRun => null()
+        else
+           stop 'rescale_potential_by: data not found'
+        endif
+     endif
+ 
+   end subroutine rescale_potential
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !inflationary evolution: find end of inflation + store relevant quantities
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function bg_field_evol(infIni,efoldDataNum,infObs,ptrStart,stopAtThisValue,isStopAtMax) 
+ !integrate the background until epsilon > epsilonStop, and returns some
+ !physical values (type infbgphys) for which epsilon = epsilon1EndInf  (=1)
+ 
+     use infprec, only : transfert
+     use inftools, only : easydverk, tunedverk, zbrent
+     use infbgmodel, only : conformal_factor_square
+     use infinout
+     
+     implicit none
+     
+     type(infbgphys), intent(in) :: infIni
+ !number of wanted stored efold. If accuracy is not enough, the real
+ !number of stored efold is modified !up to
+ !efoldBeforeEndObs/efoldStepDefault
+     integer, optional, intent(in) :: efoldDataNum
+     type(infbgphys), optional, intent(out) :: infObs
+     type(infbgdata), optional, pointer :: ptrStart    
+     real(kp), optional, intent(in) :: stopAtThisValue
+     logical, optional, intent(in) :: isStopAtMax
+     type(infbgphys) :: bg_field_evol
+     
+     
+     real(kp) :: epsilon1, epsilon1JF
+     real(kp) :: epsilon2
+ 
+ !if ptrBgdata input without data number, this is the default storage step
+     real(kp), parameter :: efoldStepDefault = 1._kp
+ 
+ !we cannot discover inflation longer on this computer
+     real(kp) :: efoldHuge
+ 
+ !how many efold after end inflation are stored (work only with
+ !useVelocity=T)
+     real(kp) :: efoldExploreOsc
+     
+ !observable perturbations were produced after that
+     real(kp), parameter :: efoldBeforeEndObs = 120._kp
+     real(kp) :: efoldObs
+ 
+     real(kp) :: hubbleSquare, hubble, hubbleEndInf
+     real(kp) :: hubbleSquareIni, hubbleIni
+     
+     real(kp) :: efold,efoldNext,efoldStepObs, efoldStepNoObs
+ 
+     real(kp) :: efoldBeforeEndInf,efoldEndInf
+     real(kp) :: efoldAfterEndInf
+ 
+     real(kp), dimension(fieldNum) :: field,derivField
+     real(kp), dimension(fieldNum) :: fieldEndInf,derivFieldEndInf
+     real(kp), dimension(fieldNum) :: derivFieldAfterEndInf
+     real(kp), dimension(2*fieldNum) :: bgVar, bgVarIni
+ 
+ !standard integration accuracy 
+ !    real(kp), parameter :: tolEvol = 1e-11
+     real(kp), parameter :: tolEvol = tolkp
+ 
+ !backward integration accuracy (sometime instable, mayneed extra precision)
+     real(kp) :: tolBackEvol
+ 
+ !if true derivField=Dfield/Dtphys, otherwise derivField=Dfield/Defold is
+ !used for the integration. In both cases, only Dfield/Defold is
+ !stored
+     logical, parameter :: useVelocity = .true.
+ !end inflation when epsilon1=1 in Jordan Frame, or in Einstein Frame
+ !Physics says in JF, but both are the same up to 2% when the dilaton coupling are set to 1
+ !Today dilaton couplings are 0.01 maxi, and they are constant or null in our model.
+ !Integration stops when epsilon1(useJF or not) > epsilon1Stop
+     real(kp), parameter :: epsilon1Stop = 1
+     logical, parameter :: useEpsilon1JF = .false.
+ 
+ !zbrent accuracy on efoldEnd for which epsilon=epsilon1Stop
+     real(kp), parameter :: tolEfoldEnd = tolkp
+ 
+ !another test, checked after epsilon1 values to stop integration. May
+ !be convenient for hybrid-like one field potential: stop integration
+ !when the min value of the matter fields is below matterMiniStop, or
+ !according to the total number of efolds
+     logical, parameter :: accurateEndInf = .true.
+     real(kp) :: efoldMaxiStop
+     logical :: checkHubbleStop
+     logical :: checkMatterStop
+     logical :: stopForMax   
+ 
+     real(kp) :: valueStop
+     integer, parameter :: stopIndexMin = 1, stopIndexMax = 1
+ 
+     logical :: inflate, longEnoughObs
+   
+ !to make f77 routines discussing together           
+     type(transfert) :: stopData, findData
+ 
+ !to store the data as chained list    
+     type(infbgdata), pointer :: ptrCurrent
+     type(infbgdata), pointer :: ptrPrevious
+        
+     integer :: neqs
+ 
+ 
+ !initialisation   !!!!!!!!!!!!!!!
+     tolBackEvol = tolEvol
+     efoldHuge = 1._kp/epsilon(1._kp)
+     neqs = 2*fieldNum
+ 
+     if (present(infObs)) then
+        infObs = infIni
+     endif
+ 
+     efoldExploreOsc = 5.
+ 
+ !enabled by true
+    
+     checkHubbleStop = .false.
+ 
+     checkMatterStop = .false.
+ 
+     efoldMaxiStop = 200.
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+     efoldHuge = min(efoldMaxiStop,efoldHuge)
+ 
+ 
+ !checks
+     if (present(ptrStart)) then
+        if (associated(ptrStart)) then
+           stop 'bg_field_evol: ptr to bgdata already associated'
+        endif
+     endif
+ 
+ 
+ 
+     if ((.not.useVelocity).and.efoldExploreOsc.ne.0) then
+        write(*,*)'bg_field_evol: oscillation exploration disabled!'
+        efoldExploreOsc = 0.
+     endif
+ 
+     if (present(isStopAtMax)) then
+        stopForMax = isStopAtMax
+     else
+        stopForMax = .false.
+     endif
+ 
+     if (present(stopAtThisValue)) then
+        valueStop = stopAtThisValue
+        if ((.not.checkMatterStop).and.checkHubbleStop) then
+           if (display) write(*,*)'bg_field_evol: check for Hubble stop enabled'          
+        else
+           if (display) write(*,*)'bg_field_evol: check for Matter stop enabled'          
+           if (display) write(*,*)'bg_field_evol: stopForMax is',stopForMax
+           checkHubbleStop = .false.
+           checkMatterStop = .true.
+        endif
+     else
+        valueStop = tolEvol
+     endif   
+     
+ !set initial conditions   
+ 
+     hubbleSquareIni = hubble_parameter_square(infIni%field,infIni%fieldDot,.false.)
+     if (hubbleSquareIni.ge.0d0) then
+        hubbleIni = sqrt(hubbleSquareIni)
+     else      
+        stop 'bg_field_evol: hubbleSquareIni < 0'
+     endif
+     bgVarIni(1:fieldNum) = infIni%field(1:fieldNum)
+     if (useVelocity) then
+        bgVarIni(fieldNum+1:2*fieldNum) = infIni%fieldDot(1:fieldNum)*hubbleIni
+     else
+        bgVarIni(fieldNum+1:2*fieldNum) = infIni%fieldDot(1:fieldNum)
+     endif
+ 
+ 
+ !localize rougthly the end of inflation: in fprime, a test stops dverk when epsilon>1
+     efold = infIni%efold
+     bgVar = bgVarIni
+ 
+ !initialize (all other subtypes may change)
+     stopData%yesno1 = useEpsilon1JF
+     stopData%yesno2 = checkMatterStop
+     stopData%yesno3 = stopForMax
+     stopData%yesno4 = checkHubbleStop
+     stopData%check = .false.    
+     stopData%update = .false.
+     stopData%xend = efoldHuge
+     stopData%real1 = epsilon1Stop
+     stopData%real2 = valueStop! - 10._kp*tolEvol
+     stopData%int1 = stopIndexMin
+     stopData%int2 = stopIndexMax
+ 
+     if (useVelocity) then
+ !derivField=Dfield/Dtphys
+        call easydverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldHuge,tolEvol &
+             ,stopData)
+     else
+ !derivField=Dfield/Defold
+        call easydverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldHuge,tolEvol &
+             ,stopData)
+     endif
+ 
+ !up to dverk exploration
+ !  efoldAfterEndInf = stopData%xend and something like bgVar =
+ !  stopData%ptr after allocation
+ 
+ !    print *,'efold bg',efold,bgVar
+ !    print *,'epsilon1',slowroll_first_parameter(bgVar(1:2), bgVar(3:4) &
+ !         , useVelocity)
+ 
+ 
+     derivFieldAfterEndInf(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum)
+ 
+     efoldAfterEndInf = efold
+     efoldBeforeEndInf = efoldAfterEndInf - efoldStepDefault
+   
+ 
+     if (efoldBeforeEndInf.le.infIni%efold) then
+        if (display) write(*,*)'bg_field_evol: inflation too short'
+        bg_field_evol = infIni       
+        return
+     endif
+ 
+     
+ 
+ 
+ !precise determination of efoldEndInf up to tolEfoldEnd provided
+ !inflation is longer than efoldStepDefault efold
+ 
+ !checkMatterMini stands for cases when epsilon1=epsilon1Stop does not
+ !define the end of inflation, so who cares about accurate
+ !determination
+     if ((.not.accurateEndInf).or.(efoldAfterEndInf.eq.efoldMaxiStop)) then
+        if (display) write(*,*)'bg_field_evol: endinf not determined accurately'
+        efoldEndInf = efoldAfterEndInf
+        fieldEndInf = bgVar(1:fieldNum)
+        derivFieldEndInf = bgVar(fieldNum+1:2*fieldNum)
+        hubbleEndInf  &
+             = sqrt(hubble_parameter_square(fieldEndInf,derivFieldEndInf,useVelocity))
+ 
+     else
+ 
+ 
+ !careful localisation of the end of inflation move to
+ !efoldBeforeEndInf: background integration maybe unstable, precision
+ !is pushed to maximum accuracy
+ 
+ 
+        tolBackEvol = epsilon(1._kp)
+ 
+        if (useVelocity) then
+           call tunedverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldBeforeEndInf &
+                ,tolBackEvol)        
+        else
+           call tunedverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldBeforeEndInf &
+                ,tolBackEvol)
+        endif
+     
+ !use zbrent zero finder in [efoldBeforeEndInf, efoldAfterEndInf]
+        findData%yesno1 = useVelocity
+        findData%yesno2 = useEpsilon1JF       
+        findData%yesno3 = stopForMax
+        findData%real1 = efold
+        allocate(findData%ptrvector1(2*fieldNum))
+        allocate(findData%ptrvector2(2*fieldNum))
+        findData%ptrvector1 = bgVar
+        findData%real2 = tolEvol       
+        findData%real3 = valueStop
+ 
+        findData%int1 = stopIndexMin
+        findData%int2 = stopIndexMax
+ 
+ !find at tolEfoldEnd precision: the interval should be small
+ !(background integration of inflation is unstable)
+ !    print *,'go in zbrent set',efoldBeforeEndInf,efoldAfterEndInf,findData%real1    
+ 
+        if (checkHubbleStop.and.(.not.stopData%yesno2)) then
+           efoldEndInf = zbrent(find_endinf_hubble,efoldBeforeEndInf &
+                ,efoldAfterEndInf,tolEfoldEnd,findData)
+        elseif (checkMatterStop.and.(.not.stopData%yesno2)) then
+           efoldEndInf = zbrent(find_endinf_matter,efoldBeforeEndInf &
+                ,efoldAfterEndInf,tolEfoldEnd,findData)
+        else
+           efoldEndInf = zbrent(find_endinf_epsilon,efoldBeforeEndInf &
+                ,efoldAfterEndInf,tolEfoldEnd,findData)
+        endif
+        
+ !read the results in the findData buffer
+        fieldEndInf = findData%ptrvector2(1:fieldNum)
+        derivFieldEndInf = findData%ptrvector2(fieldNum+1:2*fieldNum)
+        hubbleEndInf &
+             = sqrt(hubble_parameter_square(fieldEndInf,derivFieldEndInf,useVelocity))
+     endif
+ 
+ 
+ 
+ !set the output values to bg_field_evol return
+ 
+     bg_field_evol%hubble = hubbleEndInf
+     bg_field_evol%efold = efoldEndInf    
+     bg_field_evol%field = fieldEndInf
+ 
+     if (useVelocity) then
+         bg_field_evol%fieldDot = derivFieldEndInf/hubbleEndInf
+     else
+        bg_field_evol%fieldDot = derivFieldEndInf
+     endif
+     bg_field_evol%epsilon1 = slowroll_first_parameter(fieldEndInf, derivFieldEndInf &
+          , useVelocity)
+     bg_field_evol%epsilon1JF = slowroll_first_parameter_JF(fieldEndInf, derivFieldEndInf &
+          , useVelocity)
+ 
+     if (associated(findData%ptrvector1)) deallocate(findData%ptrvector1)
+     if (associated(findData%ptrvector2)) deallocate(findData%ptrvector2)
+ 
+    
+ !save some data in memory if ptr input is present, recomputes the
+ !background knowing the end of inflation. Whatever the total number of
+ !efold, the last relevant efold (after efoldBeforeEndObs) are
+ !sampled according to efoldStepDefault
+ 
+      efoldObs = efoldEndInf - efoldBeforeEndObs
+ !     print *,'efoldObs efoldEndInf',efoldObs,efoldEndInf
+ 
+     if (present(efoldDataNum)) then
+        if (efoldDataNum.le.1) return
+     endif
+ 
+ 
+ 
+     if (present(ptrStart)) then       
+ !for debugging       
+        if (dump_file) then
+           call delete_file('field.dat')
+           call delete_file('derivfield.dat')
+           call delete_file('geom.dat')
+           call delete_file('epsilon1.dat')
+           call delete_file('epsilon2.dat')
+           call delete_file('hubble.dat')
+           call delete_file('potential.dat')
+           call delete_file('confsquare.dat')
+           call delete_file('a2chi2.dat')
+        endif
+ 
+ 
+        if (present(efoldDataNum)) then          
+           if (efoldObs - infIni%efold.gt.0.) then
+              longEnoughObs = .true.
+              efoldStepNoObs = 2.*(efoldObs - infIni%efold)/real(efoldDataNum-1)
+              efoldStepObs = 2.*efoldBeforeEndObs/real(efoldDataNum-1)
+              efoldStepNoObs = max(efoldStepNoObs,efoldStepObs)
+           else
+              longEnoughObs = .false.              
+              efoldStepNoObs = 0.
+              efoldStepObs = (efoldEndInf  - infIni%efold)/real(efoldDataNum/2-1)
+           endif
+        else
+           longEnoughObs = .false.
+           efoldStepNoObs = efoldStepDefault
+           efoldStepObs = efoldStepDefault
+        endif
+ 
+ !initialisation      
+        efold = infIni%efold      
+        bgVar = bgVarIni
+ 
+        inflate = .true.
+        
+        ptrCurrent => null()
+        ptrPrevious => null()
+ 
+ !       i=0
+ 
+        do 
+ 
+ !compute the saved physical quantities    
+           field =  bgVar(1:fieldNum)
+           derivField = bgVar(fieldNum+1:2*fieldNum) 
+ 
+           hubbleSquare = hubble_parameter_square(field,derivField,useVelocity)
+           epsilon1 = slowroll_first_parameter(field,derivField,useVelocity)
+           epsilon1JF = slowroll_first_parameter_JF(field,derivField,useVelocity)
+ 
+           if (hubbleSquare.ge.0d0) then
+              hubble = sqrt(hubbleSquare)
+           else
+              print *,'efold',efold
+              stop 'bg_field_evol: hubbleSquare < 0'
+           endif
+           
+ 
+ !save the physical quantities as a chained list
+          
+           if (.not.associated(ptrStart)) then
+              allocate(ptrStart); ptrStart%ptr => null(); ptrCurrent => ptrStart
+           else
+              allocate(ptrCurrent); ptrCurrent%ptr => null(); ptrPrevious%ptr => ptrCurrent
+           endif
+           ptrCurrent%bg%efold = efold
+           ptrCurrent%bg%hubble = hubble
+           ptrCurrent%bg%epsilon1 = epsilon1
+           ptrCurrent%bg%epsilon1JF = epsilon1JF
+           ptrCurrent%bg%field = field
+ !          i=i+1
+ !             print *,'stored efold',ptrCurrent%bg%efold,i
+           if (useVelocity) then
+              ptrCurrent%bg%fieldDot = derivField/hubble             
+           else
+              ptrCurrent%bg%fieldDot = derivField
+           endif
+           ptrPrevious => ptrCurrent
+           
+ !slow down a lot the computation: for test!
+           if (dump_file) then
+              call livewrite('field.dat',efold,bgVar(1),bgVar(2),bgVar(3))
+              call livewrite('derivfield.dat',efold, ptrCurrent%bg%fieldDot(1) &
+                   ,ptrCurrent%bg%fieldDot(2))
+              call livewrite('hubble.dat',efold,hubble)
+              call livewrite('epsilon1.dat',efold,epsilon1,epsilon1JF)
+              epsilon2 = slowroll_second_parameter(field,derivField,useVelocity)
+              call livewrite('epsilon2.dat',efold,epsilon2)
+              call livewrite('potential.dat',efold,potential(bgVar(1:fieldNum)))
+              call livewrite('confsquare.dat',efold &
+                   ,conformal_factor_square(bgVar(matterNum+1:fieldNum)))
+              call livewrite('a2chi2.dat',efold &
+                   ,conformal_factor_square(bgVar(matterNum+1:fieldNum)) &
+                   *bgVar(1)*bgVar(1))
+           endif
+                        
+ 
+           if (efold.eq.efoldObs) then
+              if (present(infObs)) then
+                 if (infObs%efold.eq.infIni%efold) then
+                    infObs%efold = efold
+                    infObs%field = field
+                    infObs%hubble = hubble
+                    infObs%fieldDot = ptrCurrent%bg%fieldDot
+                    infObs%epsilon1 = epsilon1
+                    infObs%epsilon1JF = slowroll_first_parameter_JF(field, derivField &
+                         , useVelocity)
+ !                   print *,'infObs set',infObs
+                 endif
+              endif
+           endif
+ 
+           
+           if (longEnoughObs.and.(efold.lt.efoldObs)) then
+              efoldNext = min(efold + efoldStepNoObs,efoldObs)
+           else
+              efoldNext = min(efold + efoldStepObs,efoldAfterEndInf + efoldExploreOsc)
+           endif
+                
+ !          print *,'efoldNExt',efoldNext
+ !          read(*,*)
+ 
+ 
+ !avoid the next step
+           if (.not.inflate) exit
+ 
+ !integration again with the stopping criteria
+           if (useVelocity) then
+              if (efoldNext.ge.(efoldAfterEndInf + efoldExploreOsc)) then
+                 inflate = .false.
+              endif
+ !derivField=Dfield/Dtphys
+              call easydverk(neqs,bg_field_dot_coupled,efold,bgVar,efoldNext,tolEvol)
+ 
+           else
+              if (efoldNext.ge.efoldAfterEndInf) then
+                 inflate = .false.
+              endif
+ !derivField=Dfield/Defold
+              call easydverk(neqs,bg_field_dot_decoupled,efold,bgVar,efoldNext,tolEvol)
+           endif                      
+ 
+        enddo
+     
+        ptrCurrent => null()
+        ptrPrevious => null()
+ 
+     endif
+ 
+ 
+   end function bg_field_evol
+ 
+ 
+ 
+ 
+   function find_endinf_epsilon(efold,findData)
+     use inftools, only : tunedverk
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: efold
+     type(transfert), optional, intent(inout) :: findData
+     real(kp) :: find_endinf_epsilon
+ 
+     logical :: useVelocity, useEpsilon1JF
+     real(kp) :: efoldStart
+     real(kp), dimension(2*fieldNum) :: bgVar
+     real(kp), dimension(fieldNum) :: field, derivField
+ 
+     useEpsilon1JF = findData%yesno2
+     useVelocity = findData%yesno1
+     efoldStart = findData%real1
+ 
+ 
+     if ((.not.associated(findData%ptrvector1)) &
+          .or.(.not.associated(findData%ptrvector2))) then
+        stop 'find_endif: ptrvector not associated'
+     endif
+ 
+     bgVar = findData%ptrvector1
+        
+ !backward integration from efoldStart found in bg_evol to the wanted efold
+     if (useVelocity) then
+        call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar &
+             ,efold,findData%real2)
+     else
+        call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar &
+          ,efold,findData%real2)
+     endif
+ 
+     findData%ptrvector2 = bgVar
+ 
+     field = bgVar(1:fieldNum)
+     derivField = bgVar(fieldNum+1:2*fieldNum)
+ 
+ 
+ !difference between the epsilon corresponding to the current efold and
+ !the one wanted to end inflation (=1). The efoldEnd is the zero of
+ !this function. Striclty speaking inflation ends when epsilon1JF=1.
+         
+     if (useEpsilon1JF) then
+        find_endinf_epsilon &
+             = slowroll_first_parameter_JF(field,derivField,findData%yesno1) - 1._kp
+     else
+        find_endinf_epsilon &
+             = slowroll_first_parameter(field,derivField,findData%yesno1) - 1._kp
+     endif
+ 
+     findData%real3 = find_endinf_epsilon + 1._kp
+        
+ 
+   end function find_endinf_epsilon
+ 
+ 
+ 
+ 
+   function find_endinf_matter(efold,findData)
+     use inftools, only : tunedverk
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: efold
+     type(transfert), optional, intent(inout) :: findData
+     real(kp) :: find_endinf_matter
+ 
+     integer :: ifMin,ifMax
+     logical :: useVelocity, stopForMatterMax
+     real(kp) :: efoldStart, matterStop
+     real(kp), dimension(2*fieldNum) :: bgVar
+     real(kp), dimension(fieldNum) :: field
+ 
+     
+     useVelocity = findData%yesno1
+     stopForMatterMax = findData%yesno3
+     efoldStart = findData%real1
+     matterStop = findData%real3
+ 
+     ifMin = findData%int1
+     ifMax = findData%int2
+ 
+ 
+     if ((.not.associated(findData%ptrvector1)) &
+          .or.(.not.associated(findData%ptrvector2))) then
+        stop 'find_endif: ptrvector not associated'
+     endif
+ 
+     bgVar = findData%ptrvector1
+        
+ !backward integration from efoldStart found in bg_evol to the wanted efold
+     if (useVelocity) then
+        call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar &
+             ,efold,findData%real2)
+     else
+        call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar &
+          ,efold,findData%real2)
+     endif
+ 
+     findData%ptrvector2 = bgVar
+ 
+     field = bgVar(1:fieldNum)
+    
+ !difference between the min matter field value corresponding to the
+ !current efold and the one wanted to end inflation
+ !(matterMinStop). The efoldEnd is the zero of this function.
+      
+     if (stopForMatterMax) then
+        find_endinf_matter =  maxval(field(ifMin:ifMax)) -  matterStop
+     else
+        find_endinf_matter =  minval(field(ifMin:ifMax)) -  matterStop 
+     endif
+ 
+ 
+   end function find_endinf_matter
+ 
+   
+ 
+   function find_endinf_hubble(efold,findData)
+     use inftools, only : tunedverk
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: efold
+     type(transfert), optional, intent(inout) :: findData
+     real(kp) :: find_endinf_hubble
+     
+     logical :: useVelocity
+     real(kp) :: efoldStart, hubbleStop,hubbleSquare
+     real(kp), dimension(2*fieldNum) :: bgVar
+     real(kp), dimension(fieldNum) :: field,derivField
+ 
+     
+     useVelocity = findData%yesno1
+     
+     efoldStart = findData%real1
+     hubbleStop = findData%real3
+ 
+   
+     if ((.not.associated(findData%ptrvector1)) &
+          .or.(.not.associated(findData%ptrvector2))) then
+        stop 'find_endif: ptrvector not associated'
+     endif
+ 
+     bgVar = findData%ptrvector1
+        
+ !backward integration from efoldStart found in bg_evol to the wanted efold
+     if (useVelocity) then
+        call tunedverk(2*fieldNum,bg_field_dot_coupled,efoldStart,bgVar &
+             ,efold,findData%real2)
+     else
+        call tunedverk(2*fieldNum,bg_field_dot_decoupled,efoldStart,bgVar &
+          ,efold,findData%real2)
+     endif
+ 
+     findData%ptrvector2 = bgVar
+ 
+     field = bgVar(1:fieldNum)
+     derivField = bgVar(fieldNum+1:2*fieldNum)
+ 
+     hubbleSquare = hubble_parameter_square(field,derivField,useVelocity)
+ 
+ 
+     find_endinf_hubble =  hubbleSquare -  hubbleStop**2
+ 
+ 
+   end function find_endinf_hubble
+ 
+ 
+ 
+ 
+   subroutine bg_field_dot_decoupled(neqs,efold,bgVar,bgVarDot,stopData)                     
+ !for derivField=Dfield/Defold the field equations decouple from the
+ !Hubble flow. However, this decomposition becomes singular when the
+ !potential vanishes and the integration fails a that point. Harmless
+ !for the inflationary era.
+ 
+     use infprec, only : transfert
+     use infbgmodel, only : metric, metric_inverse
+     implicit none
+         
+     integer :: neqs    
+     real(kp) :: efold
+     real(kp), dimension(neqs) :: bgVar
+     real(kp), dimension(neqs) :: bgVarDot
+     type(transfert), optional, intent(inout) :: stopData
+    
+     integer :: i
+     real(kp), dimension(fieldNum) :: dlnPotVec
+     real(kp), dimension(fieldNum) :: field, christVec
+     real(kp), dimension(fieldNum) :: fieldDot, fieldDotDot 
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel 
+     real(kp) :: fieldDotSquare, epsilon1, hubbleSquare
+   
+     logical, save :: stopNow=.false.
+ 
+ 
+     field = bgVar(1:fieldNum)
+     fieldDot = bgVar(fieldNum+1:2*fieldNum)
+     christoffel = connection_affine(field)
+ 
+     fieldDotSquare = dot_product(fieldDot,matmul(metric(field),fieldDot))
+ 
+     if (present(stopData)) then
+ !use epsilon1JF or not to stop inflation
+        if (stopData%check) then
+           
+           if (stopData%yesno1) then
+              epsilon1 = slowroll_first_parameter_JF(field,fieldDot,.false.)
+           else
+              epsilon1 = fieldDotSquare/2d0
+           endif
+ 
+           if (stopData%yesno2) then
+              if (stopData%yesno3) then
+                 stopNow = (maxval(field(stopData%int1:stopData%int2)) &
+                      .gt.stopData%real2)
+              else
+                 stopNow = (minval(field(stopData%int1:stopData%int2)) &
+                      .lt.stopData%real2)
+              endif
+           endif
+ 
+           if (stopData%yesno4) then
+              hubbleSquare = hubble_parameter_square(field,fieldDot,.false.)
+              stopNow = (hubbleSquare.lt.(stopData%real2)**2)
+           endif
+           
+           if (stopNow.or.(epsilon1.gt.stopData%real1)) then
+              stopData%update = .true.
+              stopData%xend = efold 
+              stopData%yesno2 = .false.
+              stopData%yesno4 = .false.
+           endif
+ 
+        endif
+     endif
+     
+     do i=1,fieldNum
+        christVec(i) = dot_product(fieldDot,matmul(christoffel(i,:,:),fieldDot))
+     enddo
+  
+ !    dlnPotVec = deriv_ln_potential_vec(field)
+     
+     dlnPotVec = matmul(metric_inverse(field),deriv_ln_potential(field))
+           
+     fieldDotDot = -christVec - (3d0 - fieldDotSquare/2d0)*(fieldDot + dlnPotVec)
+ 
+     bgVarDot(1:fieldNum) = fieldDot
+     bgVarDot(fieldNum+1:2*fieldNum) = fieldDotDot
+        
+   end subroutine bg_field_dot_decoupled
+ 
+ 
+ 
+ 
+ 
+   subroutine bg_field_dot_coupled(neqs,efold,bgVar,bgVarDot,stopData)                       
+ !for derivField=Dfield/Dtphys the field equations are coupled to the
+ !hubble flow. This avoid the singular behavior of the decoupled
+ !equations and allows to properly sample the oscillations of the field
+ !at the end of inflation.
+ 
+     use infprec, only : transfert
+     use infbgmodel, only : metric, metric_inverse
+     implicit none
+         
+     integer :: neqs    
+     real(kp) :: efold
+     real(kp), dimension(neqs) :: bgVar
+     real(kp), dimension(neqs) :: bgVarDot
+     type(transfert), optional, intent(inout) :: stopData
+ 
+     integer :: i
+     real(kp), dimension(fieldNum) :: dPotVec
+     real(kp), dimension(fieldNum) :: field, velocity
+     real(kp), dimension(fieldNum) :: fieldDot, velocityDot, christVec
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel 
+     real(kp) :: velocitySquare, epsilon1, hubbleSquare, hubble
+     
+     logical, save :: stopNow = .false.
+ 
+ 
+     field = bgVar(1:fieldNum)
+     velocity = bgVar(fieldNum+1:2*fieldNum)
+     christoffel = connection_affine(field)
+    
+     velocitySquare = dot_product(velocity,matmul(metric(field),velocity))    
+ 
+     do i=1,fieldNum
+        christVec(i) = dot_product(velocity(:),matmul(christoffel(i,:,:),velocity(:)))
+     enddo
+    
+ !    dPotVec = deriv_potential_vec(field)
+     dPotVec = matmul(metric_inverse(field),deriv_potential(field))
+    
+     hubbleSquare = hubble_parameter_square(field,velocity,.true.)
+     if (hubbleSquare.ge.0.) then
+        hubble = sqrt(hubbleSquare)
+     else
+        print *,'field= ',field
+        print *,'velocity= ',velocity 
+        stop 'bg_field_dot_coupled: hubbleSquare < 0'
+     endif
+     
+     if (present(stopData)) then
+ !use epsilon1JF or not to stop inflation
+        if (stopData%check) then
+           if (stopData%yesno1) then
+              epsilon1 = slowroll_first_parameter_JF(field,velocity,.true.)
+           else
+              epsilon1 = velocitySquare/2d0/hubbleSquare
+           endif          
+                     
+           if (stopData%yesno2) then
+              if (stopData%yesno3) then
+                 stopNow = (maxval(field(stopData%int1:stopData%int2)) &
+                      .gt.stopData%real2)
+              else
+                 stopNow = (minval(field(stopData%int1:stopData%int2)) &
+                      .lt.stopData%real2)
+              endif
+           endif
+              
+           if (stopData%yesno4) stopNow = hubble.le.stopData%real2
+ 
+ 
+           if (stopNow.or.(epsilon1.gt.stopData%real1)) then
+              stopData%update = .true.
+              stopData%xend = efold 
+              stopData%yesno2 = .false.
+              stopData%yesno4 = .false.
+           endif
+           
+ !          print *,'efold field',efold,field
+ !          print *,'eps1 eps2',epsilon1,slowroll_second_parameter(field,velocity,.true.)
+ !          read(*,*)
+        endif              
+     endif
+    
+     fieldDot = velocity/hubble
+     velocityDot =  -3d0*velocity - (christVec + dPotVec)/hubble
+        
+     bgVarDot(1:fieldNum) = fieldDot
+     bgVarDot(fieldNum+1:2*fieldNum) = velocityDot
+             
+   end subroutine bg_field_dot_coupled
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !geometrical functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+ 
+ 
+ 
+ 
+   function hubble_parameter_square(field,derivField,useVelocity)
+ !in unit of kappa^2
+     use infbgmodel, only : metric
+     implicit none
+     real(kp) :: hubble_parameter_square
+     real(kp), dimension(fieldNum), intent(in) :: field, derivfield
+     logical, intent(in) :: useVelocity
+ 
+     real(kp) :: derivFieldSquare
+ 
+     derivFieldSquare = dot_product(derivField,matmul(metric(field),derivField))
+ 
+     if (useVelocity) then
+        hubble_parameter_square = (derivFieldSquare + 2._kp*potential(field))/6._kp
+     else
+        hubble_parameter_square = 2._kp*potential(field)/(6._kp - derivFieldSquare)       
+     endif
+    
+   end function hubble_parameter_square
+ 
+ 
+ 
+ 
+   function slowroll_first_parameter(field,derivField,useVelocity)
+ !epsilon1 = epsilon
+     use infbgmodel, only : metric
+     implicit none
+     real(kp) :: slowroll_first_parameter
+     real(kp), dimension(fieldNum), intent(in) :: field, derivField
+     logical, intent(in) :: useVelocity
+     
+     real(kp) :: derivFieldSquare, hubbleSquare
+ 
+     derivFieldSquare = dot_product(derivField,matmul(metric(field),derivField))
+     
+     if (useVelocity) then       
+        hubbleSquare = hubble_parameter_square(field,derivField,useVelocity)
+        slowroll_first_parameter = derivFieldSquare/2d0/hubbleSquare
+     else
+        slowroll_first_parameter = derivFieldSquare/2d0
+     endif
+     
+ 
+   end function slowroll_first_parameter
+ 
+ 
+ 
+ 
+   function slowroll_second_parameter(field,derivField,useVelocity)
+ !epsilon2 = 2(epsilon - delta)
+     implicit none
+     real(kp) :: slowroll_second_parameter
+     real(kp), dimension(fieldNum), intent(in) :: field, derivField
+     logical, intent(in) :: useVelocity
+ 
+     real(kp), dimension(fieldNum) :: fieldDot
+     real(kp) :: epsilon1
+     real(kp) :: hubbleSquare, derivPotFieldDot
+ 
+     hubbleSquare = hubble_parameter_square(field,derivField,useVelocity)
+     
+     if (useVelocity) then
+        fieldDot = derivField/sqrt(hubbleSquare)
+     else
+        fieldDot = derivField
+     endif
+ 
+     epsilon1 = slowroll_first_parameter(field,derivField,useVelocity)
+     
+     if (epsilon1.ne.0.) then
+        derivPotFieldDot = dot_product(deriv_potential(field),fieldDot)
+ 
+        slowroll_second_parameter = -6d0 + 2d0*epsilon1 &
+             - derivPotFieldDot/(epsilon1*hubbleSquare)
+     else
+        slowroll_second_parameter = 0.
+     endif
+ 
+   end function slowroll_second_parameter
+ 
+ 
+ 
+ 
+   function slowroll_first_parameter_JF(field,derivField,useVelocity)
+ !this is epsilon1 EF, up to 2% when dilaton couplings = 1
+     use infbgmodel, only : conformal_first_gradient, conformal_second_gradient
+     use infbgmodel, only : metric_inverse
+     implicit none
+     real(kp) :: slowroll_first_parameter_JF
+     real(kp), dimension(fieldNum), intent(in) :: field, derivField
+     logical, intent(in) :: useVelocity
+ 
+     real(kp), dimension(fieldNum) :: christVec, fieldDot, potDerivVec
+     real(kp), dimension(dilatonNum) :: dilaton, dilatonDot,confFirstGrad    
+     real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: christoffel
+     real(kp) :: derivFieldSquare, hubbleSquare, epsilon1, epsilon1Xfactor, shift
+     real(kp) :: confFirstGradXdilDot
+ 
+     integer :: i
+     
+     hubbleSquare = hubble_parameter_square(field,derivField,useVelocity)
+ 
+     if (useVelocity) then
+        fieldDot = derivField/sqrt(hubbleSquare)
+     else
+        fieldDot = derivField
+     endif
+ 
+     dilaton = field(matterNum+1:fieldNum)
+     dilatonDot = fieldDot(matterNum+1:fieldNum)
+     confFirstGrad = conformal_first_gradient(dilaton)
+     confSecondGrad = conformal_second_gradient(dilaton)
+ !    potDerivVec = deriv_potential_vec(field)
+     potDerivVec = matmul(metric_inverse(field),deriv_potential(field))
+     christoffel = connection_affine(field)
+ 
+     do i=1,fieldNum
+        christVec(i) = dot_product(fieldDot(:),matmul(christoffel(i,:,:),fieldDot(:)))
+     enddo
+    
+     confFirstGradXdilDot = dot_product(confFirstGrad,dilatonDot)
+ 
+     epsilon1 = slowroll_first_parameter(field,derivField,useVelocity)
+ 
+     
+     epsilon1Xfactor = (epsilon1 + confFirstGradXdilDot)/(1._kp + confFirstGradXdilDot)
+    
+ 
+     shift = ((3._kp - epsilon1)*confFirstGradXdilDot &
+          + dot_product(confFirstGrad,christVec(matterNum+1:fieldNum)) &
+          + dot_product(confFirstGrad,potDerivVec(matterNum+1:fieldNum)/hubbleSquare) &
+          - dot_product(dilatonDot, matmul(confSecondGrad,dilatonDot))) &
+          / (1._kp + confFirstGradXdilDot)**2
+          
+ 
+     slowroll_first_parameter_JF = epsilon1Xfactor + shift
+ 
+ 
+   end function slowroll_first_parameter_JF
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !gravity sector functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+   function connection_affine(field)
+ !first index contravariant, 2 others covariant and symmetric
+     use infbgmodel, only : metric_inverse, conformal_first_gradient
+     use infbgmodel, only : conformal_factor_square
+     implicit none
+     real(kp), dimension(fieldNum) :: field    
+     real(kp), dimension(fieldNum,fieldNum) :: metricInv
+     real(kp), dimension(dilatonNum,dilatonNum) :: metricInvConf
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: connection_affine
+     real(kp) ::  confSquare
+     real(kp), dimension(dilatonNum) :: dilaton
+     real(kp), dimension(dilatonNum) :: confFirstGradVec, confFirstGrad
+    
+     integer :: i
+ 
+     connection_affine = 0._kp
+ 
+     metricInv = metric_inverse(field)
+     metricInvConf(1:dilatonNum,1:dilatonNum) &
+          = metricInv(matterNum+1:fieldNum,matterNum+1:fieldNum)
+ 
+     dilaton=field(matterNum+1:fieldNum)
+     confFirstGrad = conformal_first_gradient(dilaton)
+     confFirstGradVec = matmul(metricInvConf,confFirstGrad)
+     confSquare = conformal_factor_square(dilaton)
+     
+     do i=1,dilatonNum
+        connection_affine(1:matterNum,1:matterNum,matterNum+i) &
+             = confFirstGrad(i)
+        connection_affine(1:matterNum,matterNum+i,1:matterNum) &
+             = confFirstGrad(i)       
+     enddo
+ 
+     do i=1,matterNum
+        connection_affine(matterNum+1:fieldNum,i,i) &
+             = - confSquare * confFirstGradVec(1:dilatonNum)
+     enddo
+ 
+    
+   end function connection_affine
+ 
+ 
+ 
+ 
+   function deriv_connection_affine(field)
+ !first partial derivative of the christoffel: first index contrariant,
+ !3 others covariant
+     use infbgmodel, only : metric_inverse, conformal_first_gradient
+     use infbgmodel, only : conformal_second_gradient, conformal_factor_square
+     implicit none
+ 
+     real(kp), dimension(fieldNum) :: field
+     real(kp), dimension(fieldNum,fieldNum) :: metricInv
+     real (kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv
+     real(kp), dimension(fieldNum,fieldNum,fieldNum,fieldNum) :: deriv_connection_affine    
+ 
+     real(kp) :: confSquare
+     real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad, confFirstGradVec
+     real(kp), dimension(dilatonNum,dilatonNum) :: metricInvConf
+     real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad, confSecondGradVec
+     integer :: i,j,k
+ 
+     deriv_connection_affine = 0._kp
+ 
+     dilaton(1:dilatonNum) = field(matterNum+1:fieldNum)
+     confSquare = conformal_factor_square(dilaton)
+ 
+ !    metricDeriv = deriv_metric(field)
+     metricInv = metric_inverse(field)
+     metricInvConf = metricInv(matterNum+1:fieldNum,matterNum+1:fieldNum)
+     
+     confFirstGrad = conformal_first_gradient(dilaton)
+     confFirstGradVec = matmul(metricInvConf,confFirstGrad)
+     confSecondGrad = conformal_second_gradient(dilaton)
+     confSecondGradVec = matmul(metricInvConf,confSecondGrad)
+     
+ 
+     do j=1,dilatonNum
+        do i=1,dilatonNum
+ 
+           deriv_connection_affine(1:matterNum,1:matterNum,matterNum+i,matterNum+j) &
+                = confSecondGrad(i,j)
+           deriv_connection_affine(1:matterNum,matterNum+i,1:matterNum,matterNum+j) & 
+                = confSecondGrad(i,j)
+ 
+           do k=1,matterNum
+              deriv_connection_affine(matterNum+i,k,k,matterNum+j) &
+                   = - confSquare * (confSecondGradVec(i,j) &
+                   + 2._kp * confFirstGradVec(i) * confFirstGrad(j)) 
+ 
+ !zero when the the metric for the dilaton is constant and diagonal
+ !                  + confSquare * dot_product(metricInvConf(i,:) &
+ !                  ,matmul(metricDeriv(matterNum+1:fieldNum,matterNum+1:fieldNum,j) &
+ !                  ,confFirstGradVec))
+           enddo
+ 
+        enddo
+     enddo
+ 
+ 
+   end function deriv_connection_affine
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !overall potential (matter + gravity)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function potential(field)
+ !S=1/(2kappa^2) {{ int{sqrt(-g) d^4 x} [ R - metric Dfield Dfield - 2*potential(Field)] }}
+     use infbgmodel, only : matter_potential, conformal_factor_square
+     implicit none
+     real(kp), dimension(fieldNum), intent(in) :: field
+ 
+     real(kp), dimension(matterNum) :: matter
+     real(kp), dimension(dilatonNum) :: dilaton
+     real(kp) :: potential  
+ 
+     matter = field(1:matterNum)
+     dilaton = field(matterNum+1:fieldNum)
+ 
+     potential = matter_potential(matter)*(conformal_factor_square(dilaton))**2
+ 
+   end function potential
+ 
+ 
+ 
+ 
+   function deriv_potential(field)
+ !with respect to the fields
+     use infbgmodel, only : deriv_matter_potential, conformal_first_gradient
+     use infbgmodel, only : conformal_factor_square
+     implicit none
+     real(kp), dimension(fieldNum) :: deriv_potential
+     real(kp), dimension(fieldNum), intent(in) :: field
+ 
+     real(kp), dimension(matterNum) :: matter, derivMatterPot
+     real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad
+ 
+     real(kp) :: potentialVal
+     
+ 
+     matter = field(1:matterNum)
+     dilaton = field(matterNum+1:fieldNum)
+ 
+     potentialVal = potential(field)
+     derivMatterPot = deriv_matter_potential(matter)
+     confFirstGrad = conformal_first_gradient(dilaton)
+ 
+     deriv_potential(1:matterNum) &
+          =  derivMatterPot(1:matterNum)*(conformal_factor_square(dilaton))**2
+ 
+     deriv_potential(matterNum+1:fieldNum) &
+          = 4._kp*confFirstGrad(1:dilatonNum)*potentialVal    
+        
+   end function deriv_potential
+ 
+ 
+ 
+ 
+   function deriv_second_potential(field)
+     use infbgmodel, only : deriv_matter_potential, deriv_second_matter_potential
+     use infbgmodel, only : conformal_first_gradient, conformal_second_gradient
+     use infbgmodel, only : conformal_factor_square
+     implicit none
+     real(kp), dimension(fieldNum,fieldNum) :: deriv_second_potential
+     real(kp), dimension(fieldNum), intent(in) :: field
+ 
+     real(kp), dimension(fieldNum) :: derivPot
+     real(kp), dimension(matterNum) :: matter, derivMatterPot
+     real(kp), dimension(matterNum,matterNum) :: derivSecondMatterPot
+     real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad
+     real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad
+ 
+     real(kp) :: potentialVal
+     integer :: i,j
+ 
+     matter = field(1:matterNum)
+     dilaton = field(matterNum+1:fieldNum)
+ 
+     potentialVal = potential(field)
+ 
+     derivPot = deriv_potential(field)
+     derivMatterPot = deriv_matter_potential(matter)
+     derivSecondMatterPot = deriv_second_matter_potential(matter)
+ 
+     confFirstGrad = conformal_first_gradient(dilaton)
+     confSecondGrad = conformal_second_gradient(dilaton)
+ 
+     deriv_second_potential(1:matterNum,1:matterNum) &
+          = derivSecondMatterPot(1:matterNum,1:matterNum) &
+          *(conformal_factor_square(dilaton))**2
+ 
+     do i=1,matterNum
+        deriv_second_potential(i,matterNum+1:fieldNum) &
+             = derivPot(i) * 4._kp*confFirstGrad(1:dilatonNum)
+        deriv_second_potential(matterNum+1:fieldNum,i) &
+             = deriv_second_potential(i,matterNum+1:fieldNum)
+     enddo
+ 
+     do i=1,dilatonNum
+        do j=1,dilatonNum
+           deriv_second_potential(matterNum+i,matterNum+j) = potentialVal &
+                * (4._kp*confSecondGrad(i,j) + 4._kp*confFirstGrad(i) &
+                * 4._kp*confFirstGrad(j))
+        enddo
+     enddo
+ 
+   end function deriv_second_potential
+ 
+ 
+ 
+ 
+   function deriv_ln_potential(field)
+     use infbgmodel, only : conformal_first_gradient
+     implicit none
+     real(kp), dimension(fieldNum) :: deriv_ln_potential
+     real(kp), dimension(fieldNum), intent(in) :: field
+ 
+     real(kp), dimension(matterNum) :: matter,derivLnMatterPot
+     real(kp), dimension(dilatonNum) :: dilaton,confFirstGrad
+ 
+     matter = field(1:matterNum)
+     dilaton = field(matterNum+1:fieldNum)
+ 
+     derivLnMatterPot = deriv_ln_matter_potential(matter)
+     confFirstGrad = conformal_first_gradient(dilaton)
+ 
+     deriv_ln_potential(1:matterNum) =  derivLnMatterPot(1:matterNum)
+ 
+     deriv_ln_potential(matterNum+1:fieldNum) = 4._kp*confFirstGrad(1:dilatonNum)
+     
+   end function deriv_ln_potential
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !matter sector functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function deriv_ln_matter_potential(matter)
+     use infbgmodel, only : matter_potential, deriv_matter_potential
+     implicit none
+     real(kp), dimension(matterNum) :: deriv_ln_matter_potential
+     real(kp), dimension(matterNum) :: matter
+ 
+     real(kp) :: matterPotential
+ 
+     matterPotential = matter_potential(matter)
+ 
+     if (matterPotential.ne.0._kp) then
+        deriv_ln_matter_potential = deriv_matter_potential(matter)/matterPotential      
+     else
+        stop 'infbg:deriv_ln_matter_potential: matter_potential vanishes!'
+     endif
+ 
+ !    deriv_ln_matter_potential(1) = 2._kp/chi
+ 
+   end function deriv_ln_matter_potential
+ 
+   
+ 
+ 
+   function matter_energy_density(field,velocity)
+ !energy density of the matter fields in the Einstein Frame
+ !A^2 (Dchi/Dtphys)^2 + A^4 U
+     use infbgmodel, only : matter_potential, conformal_factor_square
+     implicit none
+     real(kp) :: matter_energy_density
+     real(kp), dimension(fieldNum), intent(in) :: field,velocity
+ 
+     real(kp), dimension(matterNum) :: matter, matterVel
+     real(kp), dimension(dilatonNum) :: dilaton
+     real(kp) :: confSquare
+ 
+ 
+     matter = field(1:matterNum)
+     dilaton = field(matterNum+1:fieldNum)
+     matterVel = velocity(1:matterNum)
+     confSquare = conformal_factor_square(dilaton)
+ 
+     matter_energy_density &
+          = 0.5d0*confSquare * dot_product(matterVel,matterVel) &
+          + matter_potential(matter) * confSquare**2
+ 
+   end function matter_energy_density
+ 
+ 
+ 
+ 
+   function matter_energy_density_JF(field,velocity)
+ !energy density of the matter fields in the Jordan Frame
+ !EF/A^4
+     use infbgmodel, only : conformal_factor_square
+     implicit none
+     real(kp) :: matter_energy_density_JF
+     real(kp), dimension(fieldNum), intent(in) :: field,velocity
+     
+     real(kp), dimension(dilatonNum) :: dilaton
+     real(kp) :: confSquare
+     real(kp) :: matterEnergyDensEF
+ 
+     dilaton = field(matterNum+1:fieldNum)
+ 
+     confSquare = conformal_factor_square(dilaton)
+     matterEnergyDensEF = matter_energy_density(field,velocity)
+ 
+     matter_energy_density_JF = matterEnergyDensEF/confSquare**2
+ 
+   end function matter_energy_density_JF
+ 
+ 
+ 
+ end module infbg
diff -r -c -b -B -N cosmomc/fieldinf/infbgmodel.F90 cosmomc_fields/fieldinf/infbgmodel.F90
*** cosmomc/fieldinf/infbgmodel.F90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infbgmodel.F90	2010-07-05 14:24:13.000000000 +0200
***************
*** 0 ****
--- 1,691 ----
+ module infbgmodel
+   use infprec, only : kp
+   implicit none
+ 
+   private
+  
+   logical, parameter :: display = .true.
+ 
+   
+   integer, parameter :: matterNum = 1
+   integer, parameter :: dilatonNum = 1  
+   integer, parameter :: fieldNum = matterNum + dilatonNum
+ 
+ #ifdef PP5
+   integer, parameter :: potParamNum = 5
+ #elif defined(PP12)
+   integer, parameter :: potParamNum = 12
+ #else
+   integer, parameter :: potParamNum = 14
+ #endif
+ 
+ 
+ 
+   integer, parameter :: matterParamNum = potParamNum + 2
+   integer, parameter :: dilatonParamNum = 0
+   integer, parameter :: infParamNum = matterParamNum + dilatonParamNum
+ 
+ 
+ 
+   type infbgparam
+ !label identifier
+      character(len=6) :: name
+ !coupling constants [mattercouplings,dilatoncouplings]
+      real(kp), dimension(infParamNum) :: consts     
+ ![dilaton degrees of freedom]
+      real(kp), dimension(dilatonNum) :: conforms
+ !matterfield values
+      real(kp), dimension(matterNum) :: matters
+   end type infbgparam
+ 
+ 
+ 
+   real(kp), dimension(matterParamNum), save :: matterParam = 0._kp
+   real(kp), dimension(potParamNum), save :: potParam = 0._kp
+ 
+ 
+   interface operator (==)     
+      module procedure infparam_equal
+   end interface
+ 
+ 
+   interface operator (/=)
+      module procedure infparam_unequal
+   end interface
+ 
+ 
+   public infbgparam
+   public operator(==),operator(/=)
+ 
+   public matterParam
+   public fieldNum, dilatonNum, matterNum
+   public infParamNum, matterParamNum, dilatonParamNum
+ 
+   public set_infbg_param
+ 
+   public matter_potential
+   public deriv_matter_potential, deriv_second_matter_potential
+ 
+   public conformal_factor_square 
+   public conformal_first_gradient, conformal_second_gradient
+ 
+   public metric, metric_inverse, deriv_metric
+ 
+ 
+ contains
+ 
+ 
+   function infparam_equal(infparamA, infparamB)
+     implicit none
+     type(infbgparam), intent(in) :: infparamA, infparamB
+     logical :: infparam_equal
+ 
+     infparam_equal = ((infparamA%name == infparamB%name) &
+          .and. all(infparamA%conforms == infParamB%conforms) &
+          .and. all(infparamA%matters == infparamA%matters) &
+          .and. all(infparamA%consts == infparamB%consts))
+ 
+   end function infparam_equal
+ 
+ 
+ 
+ 
+   function infparam_unequal(infparamA, infparamB)
+     implicit none
+     type(infbgparam), intent(in) :: infparamA, infparamB
+     logical :: infparam_unequal
+ 
+     infparam_unequal = ((infparamA%name /= infparamB%name) &
+          .or. any(infparamA%conforms /= infParamB%conforms) &
+          .or. any(infparamA%matters /= infparamA%matters) &
+          .or. any(infparamA%consts /= infparamB%consts))
+ 
+   end function infparam_unequal
+ 
+ 
+     
+ 
+ 
+ 
+   function set_infbg_param(infParam)
+     implicit none
+     logical :: set_infbg_param
+     type(infbgparam), intent(in) :: infParam    
+ 
+     logical :: badParams = .true.
+ 
+     real(kp) :: kpbuffer
+ 
+     set_infbg_param=.false.
+ 
+ !the matter potential is parametrized as
+ !
+ ! U = [(p1 + p4 ln F) F^p2 + p3]^p5
+ !   + [p6 + p7 exp(p8 F) + p9 cos(p10 F + p11)] F^p12
+ !   + p13 F^p14
+ !
+ !where the p are the potential params. In terms of the  "matterParams", they read
+ !
+ ! p1 = sign(m1) m1^4 
+ ! p2 = m2
+ ! p3 = m3^4
+ ! p4 = sign(m4) m4^4
+ ! p5 = m5
+ ! p6 = sign(m6) m6^4 
+ ! p7 = sign(m7) m7^4 
+ ! p8 = m8
+ ! p9 = sign(m9) m9^4 
+ !p10 = m10
+ !p11 = m11
+ !p12 = m12
+ !p13 = sign(m13) m13^4
+ !p14 = m14
+ !
+ !The matterParams mi are set from the ci params according to the model
+ !under scrutiny. Only the ci (infparam%consts) are public.
+ !
+ ! m15=c15
+ !
+ ! is a field value that bounds the initial field values (ex, the throat size for kklt)
+ !
+ ! m16=c16
+ !
+ !is a field value that stops inflation (ex, hybrid, kklt) instead of
+ ! the condition epsilon1 = 1
+ !
+ !
+ !
+ !Other notations: M=c1; mu=c3, p=c2; nu=c4
+ 
+   
+ 
+   select case (infParam%name)
+ 
+ 
+     case ('largef')
+ 
+ ! U = c1^4 F^c2       
+ 
+        badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) &
+             .or.(infParam%consts(3).ne.0._kp).or.(infParam%consts(5).ne.1._kp))
+ 
+        if (badParams) then          
+           write(*,*)'model name: ',infParam%name
+           write(*,*)'consts = ',infParam%consts(1:infParamNum)
+           stop 'large field: improper params'
+        endif
+ 
+ 
+        matterParam(1) = infParam%consts(1)
+        matterParam(2) = infParam%consts(2)
+        matterParam(3) = 0._kp
+        matterParam(4) = 0._kp
+        matterParam(5) = 1._kp
+ 
+ !fieldUv limit
+        matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1)
+ !fieldStop value
+        matterParam(matterParamNum) = infParam%consts(matterParamNum)
+ 
+ 
+     case ('smallf')
+ 
+ ! U = c1^4 [1 - (F/c3)^c2]
+ 
+        badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) &
+             .or.(infParam%consts(3).le.0._kp).or.(infParam%consts(5).ne.1._kp))
+ 
+        if (badParams) then
+           write(*,*)'model name: ',infParam%name
+           write(*,*)'consts = ',infParam%consts(1:infParamNum)
+           stop 'small field: improper params'
+        endif
+ 
+        matterParam(1) = - infParam%consts(1) &
+             /(infParam%consts(3)**(infParam%consts(2)/4._kp))
+        matterParam(2) = infParam%consts(2)
+        matterParam(3) = infParam%consts(1)
+        matterParam(4) = 0._kp
+        matterParam(5) = 1._kp
+ 
+ !fieldUv limit
+        matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1)
+ !fieldStop value
+        matterParam(matterParamNum) = infParam%consts(matterParamNum)
+ 
+             
+        if (maxval(infParam%matters/infParam%conforms(1)) &
+             .gt.infParam%consts(3)) then
+           write(*,*)'set_infbg_param: not small fields initially'
+           write(*,*)'model name: ',infParam%name         
+           write(*,*)'matterScale = ',infParam%consts(3)
+           write(*,*)'matterField = ',maxval(infParam%matters)          
+        endif
+ 
+ 
+        
+ 
+     case ('hybrid')
+ 
+ ! U = c1^4 [1 + (F/c3)^c2]
+ 
+        badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) &
+             .or.(infParam%consts(3).le.0._kp) &
+             .or.(infParam%consts(5).ne.1._kp))
+ 
+        
+ 
+         if  (badParams) then
+           write(*,*)'model name: ',infParam%name
+           write(*,*)'consts = ',infParam%consts(1:infParamNum)
+           stop 'hybrid models: improper params'
+        endif
+           
+        matterParam(1) = infParam%consts(1) &
+                /(infParam%consts(3)**(infParam%consts(2)/4._kp))
+        matterParam(2) = infParam%consts(2)
+        matterParam(3) = infParam%consts(1)
+        matterParam(4) = 0._kp
+        matterParam(5) = 1._kp
+ 
+ !fieldUv limit
+        matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1)
+ !fieldstop value
+        matterParam(matterParamNum) =infParam%consts(matterParamNum)
+ 
+  
+ 
+     case ('runmas')
+ 
+ ! U = c1^4 { 1 + c4[1/c2 - ln(F/c3)] F^c2 }
+ 
+        badParams = ((infParam%consts(3).le.0._kp).or.(infParam%consts(3).gt.1._kp) &
+             .or.(infParam%consts(2).le.0._kp) &
+             .or.(infParam%consts(1).le.0._kp) &
+             .or.(infParam%consts(5).ne.1._kp))
+ 
+ 
+        if  (badParams) then
+           write(*,*)'model name: ',infParam%name
+           write(*,*)'consts = ',infParam%consts(1:infParamNum)
+           stop 'running mass: improper params'
+        endif
+        
+        kpbuffer = infParam%consts(4)/infParam%consts(2) &
+                + infParam%consts(4)*log(infParam%consts(3))
+        matterParam(1) = infParam%consts(1)*kpbuffer**0.25_kp
+ 
+        matterParam(2) = infParam%consts(2)
+        matterParam(3) = infParam%consts(1)
+ 
+        kpbuffer = infParam%consts(4)
+        matterParam(4) = -infParam%consts(1)*kpbuffer**0.25_kp
+        
+        matterParam(1) = infParam%consts(1) * sign(abs(kpbuffer)**0.25,kpbuffer)
+ 
+        kpbuffer = infParam%consts(4)
+        matterParam(4) = - infParam%consts(1) * sign(abs(kpbuffer)**0.25,kpbuffer)
+ 
+        matterParam(5) = 1._kp
+ 
+ !fieldUv limit
+        matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1)
+ !fieldstop value
+        matterParam(matterParamNum) = infParam%consts(matterParamNum)
+ 
+ 
+ 
+     case('kklmmt')
+ 
+ ! U = c1^4 * [1 - (F/c3)^(-c2)] with c2 > 0 for c5=1 or
+ ! U = c1^4 / [1 + (F/c3)^(-c2)] with c2 > 0 for c5=-1
+ !
+ ! c6 is Phi_string related to the flux number N
+ !
+ ! c7 is PhiUv related to the brane tension of the string coupling
+ 
+ 
+        badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) &
+             .or.(infParam%consts(3).le.0._kp) &
+             .or.(abs(infParam%consts(5)).ne.1._kp) &
+             .or.(infParam%consts(matterParamNum-1).lt.0._kp))
+ 
+        if (badParams) then
+           write(*,*)'model name: ',infParam%name
+           write(*,*)'consts = ',infParam%consts(1:infParamNum)
+           stop 'kklmmt: improper params'
+        endif
+ 
+ 
+        matterParam(1) = - sign(infParam%consts(1)**infParam%consts(5) &
+             /(infParam%consts(3)**(-infParam%consts(2)/4._kp)) &
+             ,infParam%consts(5))
+        matterParam(2) = -infParam%consts(2)
+        matterParam(3) = infParam%consts(1)**infParam%consts(5)
+        matterParam(4) = 0._kp
+        matterParam(5) = infParam%consts(5)
+ 
+ !fieldUv: prevents brane out of the throat
+        matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1)
+ !flux number N
+        matterParam(matterParamNum) = infParam%consts(matterParamNum)
+             
+ 
+ #ifndef PP5
+     case ('mixinf')
+ ! U = c1^4 [F^c2 + c6 F^c12]      
+ 
+        badParams = ((infParam%consts(1).le.0._kp).or.(infParam%consts(2).le.0._kp) &
+             .or.(infParam%consts(3).ne.0._kp).or.(infParam%consts(5).ne.1._kp) &
+             .or.(infParam%consts(6).le.0._kp).or.(infParam%consts(12).le.0._kp) &
+             .or.(infParam%consts(7).ne.0._kp).or.(infParam%consts(8).ne.0._kp) &
+             .or.(infParam%consts(9).ne.0._kp).or.(infParam%consts(10).ne.0._kp) &
+             .or.(infParam%consts(11).ne.0._kp))
+ 
+        if (badParams) then          
+           write(*,*)'model name: ',infParam%name
+           write(*,*)'infParamNum = ',infParamNum
+           write(*,*)'consts = ',infParam%consts(1:infParamNum)
+           stop 'mixed field: improper params'
+        endif
+ 
+ 
+        matterParam(1) = infParam%consts(1)
+        matterParam(2) = infParam%consts(2)
+        matterParam(3) = 0._kp
+        matterParam(4) = 0._kp
+        matterParam(5) = 1._kp
+        matterParam(6) = infParam%consts(1) &
+             *sign(abs(infParam%consts(6))**0.25_kp,infParam%consts(6))
+        matterParam(7:11) = 0._kp
+        matterParam(12) = infParam%consts(12)
+ 
+ !fieldUv limit
+        matterParam(matterParamNum-1) = infParam%consts(matterParamNum-1)
+ !fieldStop value
+        matterParam(matterParamNum) = infParam%consts(matterParamNum)
+ 
+ 
+ #endif
+ 
+ 
+ 
+     case default
+        stop 'set_infbg_param: no such a model'
+ 
+     end select
+ 
+   
+     if (display) then
+        write(*,*)'set_infbg_param: model is ',infParam%name
+ !       write(*,*)'matterParam = ',matterParam
+     endif
+ 
+ 
+ !update static potential parameters
+     call set_potential_param()
+     set_infbg_param = .true.
+     
+   end function set_infbg_param
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !full numerical integration functions
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !matter sector: potentials
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+   subroutine set_potential_param()
+     implicit none
+ 
+     potParam(1) = sign(matterParam(1)**4,matterParam(1)) !/matterParam(3)**4
+     potParam(2) = matterParam(2)
+     potParam(3) = matterParam(3)**4
+     potParam(4) = sign(matterParam(4)**4,matterParam(4)) !/matterParam(3)**4
+     potParam(5) = matterParam(5)
+ 
+ #ifndef PP5
+     potParam(6) = sign(matterParam(6)**4,matterParam(6))
+     potParam(7) = sign(matterParam(7)**4,matterParam(7))
+     potParam(8) = matterParam(8)
+     potParam(9) = sign(matterParam(9)**4,matterParam(9))
+     potParam(10) = matterParam(10)
+     potParam(11) = matterParam(11)
+     potParam(12) = matterParam(12)
+ 
+ 
+ #ifndef PP12
+     potParam(13) = sign(matterParam(13)**4,matterParam(13))
+     potParam(14) = matterParam(14)
+ #endif
+ #endif
+ 
+     if (display) write(*,*)'set_potential_param: potParam = ',potParam
+ 
+   end subroutine set_potential_param
+ 
+ 
+ 
+   
+   function matter_potential(matter)
+     implicit none
+     real(kp) :: matter_potential
+     real(kp), dimension(matterNum) :: matter
+ 
+     real(kp) :: chi,lnchi
+ 
+     chi = matter(1)
+ 
+     if (chi.gt.0._kp) then
+        lnchi = log(chi)
+     else
+        lnchi = -huge(1._kp)
+     endif
+ 
+ ! From p1 to p5
+     matter_potential = (potParam(3) + &
+          (potParam(1) + potParam(4)*lnchi)*chi**potParam(2) &
+          )**potParam(5)
+ 
+ ! From p6 to p12
+ #ifndef PP5
+     matter_potential = matter_potential &
+          + ( potParam(6) + potParam(7)*exp(potParam(8)*chi) &
+          + potParam(9)*cos(potParam(10)*chi+potParam(11)) ) * chi**(potParam(12))
+ 
+ ! From p13 to p14
+ #ifndef PP12
+     matter_potential = matter_potential + potParam(13)*chi**potParam(14)
+ #endif
+ #endif
+ 
+     if (matter_potential.lt.0._kp) then
+        write(*,*)'matterField = ',chi
+        write(*,*)'potParam = ',potParam
+        write(*,*)'matter_potential = ',matter_potential
+        stop 'infbgmodel: matter_potential < 0!'
+     endif
+   end function matter_potential
+  
+ 
+  
+   function deriv_matter_potential(matter)
+     implicit none
+     real(kp), dimension(matterNum) :: deriv_matter_potential
+     real(kp), dimension(matterNum) :: matter
+ 
+     real(kp) :: chi, lnchi
+ 
+     chi = matter(1)
+ 
+     if (chi.gt.0._kp) then
+        lnchi = log(chi)
+     else
+        lnchi = -huge(1._kp)
+     endif
+ 
+     deriv_matter_potential(1) = potParam(5)*chi**(potParam(2)-1._kp) &
+          * (potParam(1)*potParam(2) + potParam(4) + potParam(4)*potParam(2)*lnchi) &
+          * ( (potParam(1) + potParam(4)*lnchi)*chi**potParam(2) + potParam(3) ) &
+          ** (potParam(5)-1._kp)
+ 
+ #ifndef PP5
+     deriv_matter_potential(1) = deriv_matter_potential(1) &
+          + chi**(-1 + potParam(12))*(potParam(6) + exp(chi*potParam(8))*potParam(7) &
+          + Cos(chi*potParam(10)+potParam(11))*potParam(9))*potParam(12) &
+          + chi**potParam(12)*(exp(chi*potParam(8))*potParam(7)*potParam(8) &
+          - potParam(9)*potParam(10)*Sin(chi*potParam(10)+potParam(11)))
+ 
+ #ifndef PP12
+     deriv_matter_potential(1) = deriv_matter_potential(1) &
+          + potParam(13)*potParam(14)*chi**(potParam(14)-1._kp)
+ #endif
+ #endif
+ 
+   end function deriv_matter_potential
+   
+ 
+ 
+   function deriv_second_matter_potential(matter)
+     implicit none
+     real(kp), dimension(matterNum,matterNum) :: deriv_second_matter_potential
+     real(kp), dimension(matterNum) :: matter
+ 
+     real(kp) :: chi, lnchi
+ 
+     chi = matter(1)
+      
+     if (chi.gt.0._kp) then
+        lnchi = log(chi)
+     else
+        lnchi = -huge(1._kp)
+     endif
+ 
+     deriv_second_matter_potential(1,1) = chi**(-2._kp + potParam(2)) * (potParam(3) &
+          + chi**potParam(2)*(potParam(1) + lnchi*potParam(4)))**(-2._kp &
+          + potParam(5))*((potParam(1)*(-1._kp + potParam(2))*potParam(2) &
+          + lnchi*(-1._kp + potParam(2))*potParam(2)*potParam(4) &
+          + (-1._kp + 2._kp*potParam(2))*potParam(4))*(potParam(3)+chi**potParam(2) &
+          * (potParam(1) + lnchi*potParam(4))) + chi**potParam(2) &
+          * (potParam(1)*potParam(2)+potParam(4)+lnchi*potParam(2)*potParam(4))**2._kp &
+          * (-1._kp + potParam(5)))*potParam(5)
+ 
+ #ifndef PP5
+     deriv_second_matter_potential(1,1) = deriv_second_matter_potential(1,1) &
+          + chi**potParam(12)*(exp(chi*potParam(8))*potParam(7)*potParam(8)**2 &
+          - Cos(chi*potParam(10)+potParam(11))*potParam(9)*potParam(10)**2) &
+          + chi**(-2 + potParam(12))*(potParam(6)+exp(chi*potParam(8))*potParam(7)&
+          + Cos(chi*potParam(10)+potParam(11))*potParam(9))*(-1+potParam(12))*potParam(12)&
+          + 2*chi**(-1 + potParam(12))*potParam(12)*(exp(chi*potParam(8))&
+          *potParam(7)*potParam(8) - potParam(9)*potParam(10) &
+          *Sin(chi*potParam(10)+potParam(11)))
+ 
+ #ifndef PP12
+     deriv_second_matter_potential(1,1) = deriv_second_matter_potential(1,1) &
+          + potParam(13)*potParam(14)*(potParam(14)-1._kp)*chi**(potParam(14)-2._kp)
+ #endif
+ #endif
+ 
+   end function deriv_second_matter_potential
+ 
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !gravity sector: metric on the sigma-model field manifold
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+ 
+  function metric(field)
+     implicit none
+     real(kp), dimension(fieldNum), intent(in) :: field
+     real(kp), dimension(fieldNum,fieldNum) :: metric
+        
+     real(kp) :: confSquare
+     real(kp), dimension(dilatonNum) :: dilaton
+     integer :: i
+ 
+     metric = 0._kp
+ 
+     dilaton = field(matterNum+1:fieldNum)
+     confSquare = conformal_factor_square(dilaton)
+ 
+     do i=1,matterNum
+        metric(i,i) = confSquare
+     enddo
+ 
+     do i=1,dilatonNum
+        metric(i+matterNum,i+matterNum) = 1._kp
+     enddo
+ 
+   end function metric
+ 
+ 
+ 
+   function metric_inverse(field)
+     implicit none
+     real(kp), dimension(fieldNum) :: field
+     real(kp), dimension(fieldNum,fieldNum) :: metricVal, metric_inverse
+     real(kp) :: det
+ 
+     integer :: i
+ 
+     metric_inverse = 0._kp
+ 
+     metricVal = metric(field)
+        
+     det = 1._kp
+     do i=1,fieldNum
+        det = det*metricVal(i,i)
+     enddo
+ 
+     if (det.ne.0.) then
+        do i=1,fieldNum
+           metric_inverse(i,i) = 1._kp/metricVal(i,i)
+        enddo
+     else
+        stop 'inverse_metric: singularity in the sigma-model!'
+     endif
+ 
+   end function metric_inverse
+ 
+ 
+   
+   function deriv_metric(field)
+     implicit none
+     real(kp), dimension(fieldNum), intent(in) :: field
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: deriv_metric
+ 
+     real(kp) :: confSquare
+     real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad
+     integer :: i
+ 
+     deriv_metric = 0._kp
+ 
+     dilaton = field(matterNum+1:fieldNum)
+     confSquare = conformal_factor_square(dilaton)
+     confFirstGrad = conformal_first_gradient(dilaton)
+     
+     do i=1,matterNum
+        deriv_metric(i,i,matterNum+1:fieldNum) &
+             = 2._kp * confFirstGrad(1:dilatonNum)* confSquare
+     enddo
+     
+ 
+ 
+   end function deriv_metric
+ 
+ 
+     
+   function conformal_factor_square(dilaton)
+ !A^2
+     implicit none
+     real(kp), dimension(dilatonNum), intent(in) :: dilaton
+     real(kp) :: conformal_factor_square
+ 
+     conformal_factor_square = 1._kp
+ 
+ 
+   end function conformal_factor_square
+ 
+   
+ 
+   function conformal_first_gradient(dilaton)
+ !alpha_field = Dln(A)/Dfield
+     implicit none
+     real(kp), dimension(dilatonNum) :: conformal_first_gradient
+     real(kp), dimension(dilatonNum) :: dilaton
+ 
+         
+     conformal_first_gradient = 0._kp
+ 
+ 
+   end function conformal_first_gradient
+ 
+ 
+  
+   function conformal_second_gradient(dilaton)
+ !D alpha_field / D field
+     implicit none
+     real(kp), dimension(dilatonNum,dilatonNum) :: conformal_second_gradient
+     real(kp), dimension(dilatonNum) :: dilaton
+    
+     conformal_second_gradient = 0._kp   
+ 
+ 
+   end function conformal_second_gradient
+ 
+ 
+ 
+ 
+ end module infbgmodel
diff -r -c -b -B -N cosmomc/fieldinf/infbgspline.f90 cosmomc_fields/fieldinf/infbgspline.f90
*** cosmomc/fieldinf/infbgspline.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infbgspline.f90	2006-05-18 18:05:05.000000000 +0200
***************
*** 0 ****
--- 1,297 ----
+ module infbgspline
+ !splinning and interpolation routines for the background. Apart for
+ !test they are only used to determine rapidly the bfold of quantum
+ !mode creation
+ 
+   use infprec, only : kp
+   implicit none
+ 
+   private
+ 
+ !for debugging
+   logical, parameter :: display = .false.
+   logical, parameter :: dump_file = .false.
+ 
+ 
+ !bad idea, force the compiler to make copy of pointer arrays at each
+ !call of bspline (involves explicit shape array)
+ !  type splineinfbg
+ !     integer :: order
+ !     integer :: bcoefNum
+ !     integer :: fieldNum
+ !     real(kp), dimension(:), pointer :: bfoldKnot, epsilon1JFBcoef
+ !     real(kp), dimension(:), pointer :: hubbleBcoef, epsilon1Bcoef
+ !     real(kp), dimension(:,:), pointer :: fieldBcoef, fieldDotBcoef
+ !  end type splineinfbg
+   
+ 
+ !to be initialized explicitely from bg computation
+   
+ !  type(splineinfbg) :: splineBg
+ 
+   integer, save :: order
+   integer, save :: bcoefNum
+   integer, save :: splineNum
+   real(kp), dimension(:), allocatable, save :: bfoldKnot, epsilon1JFBcoef
+   real(kp), dimension(:), allocatable, save :: hubbleBcoef, epsilon1Bcoef
+   real(kp), dimension(:,:), allocatable, save :: fieldBcoef, fieldDotBcoef
+ 
+   
+ 
+   public free_infbg_spline,set_infbg_spline, check_infbg_spline
+   public splineval_hubble_parameter,splineval_epsilon1,splineval_epsilon1JF
+   public splineval_field,splineval_fielddot
+ 
+ contains
+ 
+ 
+ 
+   function check_infbg_spline()
+     implicit none
+     logical :: check_infbg_spline
+ 
+     check_infbg_spline = (allocated(bfoldKnot) &
+          .or. allocated(epsilon1JFBcoef) &
+          .or. allocated(hubbleBcoef) &
+          .or. allocated(epsilon1Bcoef) &
+          .or. allocated(fieldBcoef) &
+          .or. allocated(fieldDotBcoef))
+     
+   end function check_infbg_spline
+ 
+ 
+ 
+ 
+   subroutine free_infbg_spline()    
+     implicit none    
+     if (check_infbg_spline()) then       
+        deallocate(bfoldKnot)
+        deallocate(hubbleBcoef)
+        deallocate(epsilon1Bcoef)
+        deallocate(epsilon1JFBcoef)
+        deallocate(fieldBcoef)
+        deallocate(fieldDotBcoef)       
+        if (display) write(*,*)'free_infbg_spline: infbg spline freed'
+     else
+        stop 'free_infbg_spline: not infbg spline data allocated'
+     endif      
+    
+   end subroutine free_infbg_spline
+ 
+ 
+ 
+ 
+ 
+   subroutine set_infbg_spline(bgEnd,ptrFirstBgdata)
+ !initialize the spline and set efoldIni, efoldEnd
+     use infbgmodel, only : fieldNum
+     use infbg, only : infbgdata, infbgphys
+     use infbg, only : count_infbg_data
+     use bspline
+     implicit none 
+     type(infbgphys), intent(in) :: bgEnd
+     type(infbgdata), pointer :: ptrFirstBgdata
+        
+     integer :: bgdataNum
+ 
+     integer :: i
+     type(infbgdata), pointer :: ptrRun
+ 
+ !the background computation need to go further than epsilon1 > 1 (spline).
+     real(kp), allocatable, dimension(:) :: bcoefTemp, dataTemp
+     real(kp), allocatable, dimension(:) :: bfold, hubble, epsilon1,epsilon1JF
+     real(kp), allocatable, dimension(:,:) :: field, fieldDot
+ 
+     i = 0
+     ptrRun => null()
+ 
+     if (check_infbg_spline()) then
+        stop 'set_infbg_spline: splineBg already associated'
+     endif
+     
+ 
+     bgdataNum = count_infbg_data(ptrFirstBgdata)
+     if (display) then
+        write(*,*)
+        write(*,*)'-------------------set_infbg_spline-------------------'
+        write(*,*)
+        write(*,*)'bgdataNum = ',bgdataNum
+     endif
+     order = 3
+     bcoefNum = bgdataNum
+     splineNum = fieldNum
+ 
+     allocate(bfold(bgdataNum))
+     allocate(hubble(bgdataNum))
+     allocate(epsilon1(bgdataNum))
+     allocate(epsilon1JF(bgdataNum))
+     allocate(field(bgdataNum,fieldNum))
+     allocate(fieldDot(bgdataNum,fieldNum))
+ 
+     allocate(bfoldKnot(bgdataNum + order))
+     allocate(hubbleBcoef(bcoefNum))
+     allocate(epsilon1Bcoef(bcoefNum))
+     allocate(epsilon1JFBcoef(bcoefNum))
+     allocate(fieldBcoef(bcoefNum,splineNum))
+     allocate(fieldDotBcoef(bcoefNum,splineNum))
+     
+     if (associated(ptrFirstBgdata)) then
+        ptrRun => ptrFirstBgdata
+        i = 0       
+        do while (associated(ptrRun))      
+           i = i + 1
+           bfold(i) = ptrRun%bg%efold - bgEnd%efold
+           if (bfold(i).eq.0.) bfold(i) = epsilon(1.0_kp)
+           hubble(i) = ptrRun%bg%hubble
+           epsilon1(i) = ptrRun%bg%epsilon1
+           epsilon1JF(i) = ptrRun%bg%epsilon1JF
+           field(i,:) = ptrRun%bg%field(:)
+           fieldDot(i,:) = ptrRun%bg%fieldDot(:)
+           ptrRun => ptrRun%ptr               
+        enddo      
+          
+        if (display) then
+           write(*,*)
+           write(*,*)'assoNum = ',i
+           write(*,*)'bgdataNum = ',bgdataNum
+           write(*,*)'splinning range:'
+           write(*,*)'bfoldIni = bfoldEndData = ',bfold(1),bfold(i)
+           write(*,*)
+           write(*,*)'------------------------------------------------------'
+           write(*,*)
+        endif
+        ptrRun => null()
+     else
+        stop 'no bgdata found'
+     endif
+  
+     call dbsnak(bgdataNum,bfold,order,bfoldKnot)
+     call dbsint(bgdataNum,bfold,hubble,order,bfoldKnot &
+          ,hubbleBcoef)
+     call dbsint(bgdataNum,bfold,epsilon1,order,bfoldKnot &
+          ,epsilon1Bcoef)
+     call dbsint(bgdataNum,bfold,epsilon1JF,order,bfoldKnot &
+          ,epsilon1JFBcoef)
+ 
+     allocate(bcoefTemp(bgDataNum))
+     allocate(dataTemp(bgDataNum))
+ 
+     do i=1,splineNum
+        dataTemp(:) = field(:,i)
+        call dbsint(bgdataNum,bfold,dataTemp,order,bfoldKnot,bcoefTemp)
+        fieldBcoef(:,i) = bcoefTemp
+ 
+        dataTemp(:) = fieldDot(:,i)
+        call dbsint(bgdataNum,bfold,dataTemp,order,bfoldKnot,bcoefTemp)
+        fieldDotBcoef(:,i) = bcoefTemp
+     enddo
+ 
+     deallocate(bcoefTemp)
+     deallocate(dataTemp)
+ 
+     deallocate(bfold,hubble,epsilon1,epsilon1JF,field,fieldDot)
+ 
+   end subroutine set_infbg_spline
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+   function splineval_hubble_parameter(bfold)   
+     use bspline
+     implicit none
+        
+     real(kp) :: splineval_hubble_parameter    
+     real(kp), intent(in) :: bfold
+         
+     splineval_hubble_parameter = dbsval(bfold,order,bfoldKnot &
+          ,bcoefNum,hubbleBcoef)
+    
+   end function splineval_hubble_parameter
+ 
+ 
+ 
+    function splineval_epsilon1(bfold)   
+     use bspline
+     implicit none
+        
+     real(kp) :: splineval_epsilon1    
+     real(kp), intent(in) :: bfold
+         
+     splineval_epsilon1 = dbsval(bfold,order,bfoldKnot &
+          ,bcoefNum,epsilon1Bcoef)
+    
+   end function splineval_epsilon1
+ 
+ 
+ 
+   function splineval_epsilon1JF(bfold)   
+     use bspline
+     implicit none
+           
+     real(kp) :: splineval_epsilon1JF    
+     real(kp), intent(in) :: bfold
+         
+     splineval_epsilon1JF = dbsval(bfold,order,bfoldKnot &
+          ,bcoefNum,epsilon1JFBcoef)
+    
+   end function splineval_epsilon1JF
+ 
+ 
+ 
+ 
+   function splineval_field(bfold)   
+     use bspline
+     implicit none
+          
+     real(kp), dimension(splineNum) :: splineval_field
+     real(kp), intent(in) :: bfold
+     real(kp), dimension(:), allocatable :: bcoefTemp
+     integer :: i,bgDataNum
+     bgDataNum = bcoefNum
+ 
+     allocate(bcoefTemp(bgDataNum))
+ 
+     i = 0
+     do i=1,splineNum
+        bcoefTemp(:) = fieldBcoef(:,i)
+        splineval_field(i) = dbsval(bfold,order,bfoldKnot &
+             ,bcoefNum,bcoefTemp)
+     enddo
+    
+     deallocate(bcoefTemp)
+ 
+   end function splineval_field
+ 
+ 
+ 
+ 
+   function splineval_fielddot(bfold)
+ !reminder: this is the efold(bfold) fieldDot = Dfield/De(b)fold
+     use bspline
+     implicit none
+        
+     real(kp), dimension(splineNum) :: splineval_fielddot    
+     real(kp), intent(in) :: bfold
+     real(kp), dimension(:), allocatable :: bcoefTemp
+     integer :: i,bgDataNum
+     bgDataNum = bcoefNum
+ 
+     allocate(bcoefTemp(bgDataNum))
+ 
+     i = 0
+     do i=1,splineNum
+        bcoefTemp(:) = fieldDotBcoef(:,i)
+        splineval_fielddot(i) = dbsval(bfold,order,bfoldKnot &
+             ,bcoefNum,bcoefTemp)
+     enddo
+    
+     deallocate(bcoefTemp)
+ 
+   end function splineval_fielddot
+ 
+ 
+ 
+ end module infbgspline
diff -r -c -b -B -N cosmomc/fieldinf/infinout.f90 cosmomc_fields/fieldinf/infinout.f90
*** cosmomc/fieldinf/infinout.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infinout.f90	2008-11-24 20:20:23.000000000 +0100
***************
*** 0 ****
--- 1,367 ----
+ module infinout
+ 
+ use infprec, only : kp
+ 
+ private
+ 
+ interface livewrite
+    module procedure sp_livewrite, kp_livewrite
+ end interface
+ 
+ interface allwrite
+    module procedure sp_allwrite, kp_allwrite
+ end interface
+ 
+ interface binallwrite
+    module procedure sp_binallwrite, kp_binallwrite
+ end interface
+ 
+ integer, parameter :: reclUnit = 4
+ 
+ public delete_file
+ public livewrite, allwrite, binallwrite
+  
+ contains
+ 
+ 
+   subroutine delete_file(name)
+     implicit none
+     character(len=*) :: name
+     logical :: isthere
+ 
+     inquire(file=name,exist=isthere)
+ 
+     if (isthere) then
+        open(unit=10,file=name)
+        close(unit=10,status='delete')
+     endif
+ 
+   end subroutine delete_file
+ 
+ 
+   subroutine sp_livewrite(name,x,a,b,c,d,e,f,g)
+     implicit none
+     character(len=*) :: name    
+     real :: x,a
+     real, optional :: b,c,d,e,f,g
+       
+     open(10,file=name,position='append',status='unknown')
+     
+     if (.not.present(b)) then
+        write(10,100) x,a         
+     elseif (.not.present(c)) then           
+        write(10,100) x,a,b         
+     elseif (.not.present(d)) then             
+        write(10,100) x,a,b,c                    
+     elseif (.not.present(e)) then         
+        write(10,100) x,a,b,c,d                    
+     elseif (.not.present(f)) then
+        write(10,100) x,a,b,c,d,e            
+     elseif (.not.present(g)) then
+        write(10,100) x,a,b,c,d,e,f            
+     else
+        write(10,100) x,a,b,c,d,e,f,g            
+     endif
+     
+     close(10)
+ 
+ 100 format(8(ES25.16E3))
+ 
+   end subroutine sp_livewrite
+ 
+ 
+   subroutine kp_livewrite(name,x,a,b,c,d,e,f,g)
+     implicit none
+     character(len=*) :: name    
+     real(kp) :: x,a
+     real(kp), optional :: b,c,d,e,f,g
+     
+     open(10,file=name,position='append',status='unknown')
+     
+     if (.not.present(b)) then
+        write(10,100) x,a         
+     elseif (.not.present(c)) then           
+        write(10,100) x,a,b         
+     elseif (.not.present(d)) then             
+        write(10,100) x,a,b,c                    
+     elseif (.not.present(e)) then         
+        write(10,100) x,a,b,c,d                    
+     elseif (.not.present(f)) then
+        write(10,100) x,a,b,c,d,e            
+     elseif (.not.present(g)) then
+        write(10,100) x,a,b,c,d,e,f            
+     else
+        write(10,100) x,a,b,c,d,e,f,g            
+     endif
+     
+     close(10)
+     
+ 100 format(8(ES25.16E3))      
+     
+   end subroutine kp_livewrite
+ 
+ 
+   subroutine sp_allwrite(name,x,a,b,c,d,e,f,g)
+     implicit none
+     character(*) :: name
+     integer :: j,npts
+     real :: x(:),a(:)
+     real, optional :: b(:),c(:),d(:),e(:),f(:),g(:)
+     
+     npts=ubound(x,1)
+       
+     if (ubound(a,1).ne.npts) then
+        write(*,*)'WARNING: vectors length differ'
+     endif
+     
+     write(*,*)'__write: save in ',name
+     open(10,file=name,status='unknown')
+     
+     if (.not.present(b)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j)
+        enddo
+     elseif (.not.present(c)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j)
+        enddo
+     elseif (.not.present(d)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j)            
+        enddo
+     elseif (.not.present(e)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j)            
+        enddo
+     elseif (.not.present(f)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j),e(j)            
+        enddo
+     elseif (.not.present(g)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j)       
+        enddo
+     else
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j)            
+        enddo
+     endif
+     
+     close(10)
+     
+ 100 format(8(ES25.16E3))      
+ 
+   end subroutine sp_allwrite
+   
+ 
+ 
+   subroutine kp_allwrite(name,x,a,b,c,d,e,f,g)
+     implicit none
+     character(*) :: name
+     integer :: j,npts
+     real(kp) :: x(:),a(:)
+     real(kp), optional :: b(:),c(:),d(:),e(:),f(:),g(:)
+ 
+     npts=ubound(x,1)
+       
+     if (ubound(a,1).ne.npts) then
+        write(*,*)'WARNING: vectors length differ'
+     endif
+     
+     write(*,*)'__write: save in ',name
+     open(10,file=name,status='unknown')
+     
+     if (.not.present(b)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j)
+        enddo
+     elseif (.not.present(c)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j)
+        enddo
+     elseif (.not.present(d)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j)            
+        enddo
+     elseif (.not.present(e)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j)            
+        enddo
+     elseif (.not.present(f)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j),e(j)            
+        enddo
+     elseif (.not.present(g)) then
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j)       
+        enddo
+     else
+        do j=1,npts      
+           write(10,100) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j)            
+        enddo
+     endif
+     
+     close(10)
+     
+ 100 format(8(ES25.16E3))      
+     
+   end subroutine kp_allwrite
+ 
+ 
+ 
+   subroutine sp_binallwrite(name,x,a,b,c,d,e,f,g)
+     implicit none
+     character(*) :: name
+     integer :: j,npts
+     real :: x(:),a(:)
+     real, optional :: b(:),c(:),d(:),e(:),f(:),g(:)
+     
+     integer :: datarecl
+     integer :: recnum
+ 
+ 
+     recnum = 0
+     npts=ubound(x,1)
+       
+     if (ubound(a,1).ne.npts) then
+        write(*,*)'WARNING: vectors length differ'
+     endif
+     
+     write(*,*)'__write: save in ',name
+ 
+     
+     if (.not.present(b)) then
+        datarecl=2*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j)
+        enddo
+     elseif (.not.present(c)) then
+        datarecl=3*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j)
+        enddo
+     elseif (.not.present(d)) then
+        datarecl=4*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j)            
+        enddo
+     elseif (.not.present(e)) then
+        datarecl=5*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j)            
+        enddo
+     elseif (.not.present(f)) then
+        datarecl=6*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j)            
+        enddo
+     elseif (.not.present(g)) then
+        datarecl=7*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j)       
+        enddo
+     else
+        datarecl=8*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=datarecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j)            
+        enddo
+     endif
+     
+     close(10)
+     
+   end subroutine sp_binallwrite
+   
+ 
+ 
+   subroutine kp_binallwrite(name,x,a,b,c,d,e,f,g)
+     implicit none
+     character(*) :: name
+     integer :: j,npts
+     real(kp) :: x(:),a(:)
+     real(kp), optional :: b(:),c(:),d(:),e(:),f(:),g(:)
+ 
+     integer :: recnum
+     integer :: datarecl
+ 
+     npts=ubound(x,1)
+     recnum=0
+ 
+     if (ubound(a,1).ne.npts) then
+        write(*,*)'WARNING: vectors length differ'
+     endif
+     
+     write(*,*)'__write: save in ',name
+     
+     if (.not.present(b)) then
+        datarecl = 4*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum=recnum+1
+           write(10,rec=recnum) x(j),a(j)
+        enddo
+     elseif (.not.present(c)) then
+        datarecl = 6*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum =recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j)
+        enddo
+     elseif (.not.present(d)) then
+        datarecl = 8*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum =recnum+1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j)            
+        enddo
+     elseif (.not.present(e)) then
+        datarecl = 10*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum = recnum + 1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j)            
+        enddo
+     elseif (.not.present(f)) then
+        datarecl = 12*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum = recnum + 1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j)            
+        enddo
+     elseif (.not.present(g)) then
+        datarecl = 14*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum = recnum + 1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j)       
+        enddo
+     else
+        datarecl = 16*reclUnit
+        open(10,file=name,status='unknown',form='unformatted',access='direct',recl=dataRecl)
+        do j=1,npts      
+           recnum = recnum + 1
+           write(10,rec=recnum) x(j),a(j),b(j),c(j),d(j),e(j),f(j),g(j)            
+        enddo
+     endif
+     
+     close(10)
+         
+   end subroutine kp_binallwrite
+ 
+ 
+ end module infinout
+ 
+ 
diff -r -c -b -B -N cosmomc/fieldinf/infpert.f90 cosmomc_fields/fieldinf/infpert.f90
*** cosmomc/fieldinf/infpert.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infpert.f90	2010-08-25 14:38:52.000000000 +0200
***************
*** 0 ****
--- 1,1202 ----
+ module infpert  
+ !inflationary perturbations for scalar fields and tensor modes, in the
+ !original field basis (might have precision issues in the
+ !determination of ridiculously small entropy modes). efold is the
+ !number of efold running from efoldIni to efoldEnd during the
+ !inflationary era. bfold is the number of efold before the end of
+ !inflation: bfold = efold - efoldEnd running from efoldIni-efoldEnd to
+ !0.
+ 
+   use infprec, only : kp, tolkp
+   use infbgmodel, only : matterNum, dilatonNum, fieldNum
+   use infbg, only : infbgphys
+   use inftorad, only : inftoradcosmo
+   implicit none
+ 
+   private
+ 
+   
+ !for debugging
+   logical, parameter :: display = .false.
+   logical, parameter :: dump_spectra = .false.
+   logical, parameter :: dump_modes = .false.
+  
+ !+1 due to the bardeen potential.
+   integer, parameter :: scalNum = fieldNum + 1
+ 
+   real(kp), parameter :: kphysOverHubbleCreate = 10._kp
+  
+   integer, parameter :: entroRef = 2
+ 
+ 
+   public scalNum  
+   public power_spectrum_tens, power_spectrum_scal
+   
+ 
+ contains
+  
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !gravitational waves
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+   function power_spectrum_tens(infCosmo,kmpc)        
+     use inftorad, only : infhubblexit, hubble_splinexit
+     use infinout, only : livewrite
+     implicit none
+     real(kp) :: power_spectrum_tens
+     type(inftoradcosmo), intent(in) :: infCosmo    
+     real(kp), intent(in) :: kmpc
+     
+     type(infhubblexit) :: atHkExit
+     complex(kp) :: tensEnd
+     real(kp) :: pi
+ 
+     pi=acos(-1._kp)
+ 
+ !evolution of k^3/2 x h by recomputing the background (faster)
+     tensEnd = pert_tens_bgevol(infCosmo,kmpc)
+         
+     power_spectrum_tens = (2._kp/pi/pi)*real(conjg(tensEnd)*tensEnd)
+ 
+     if (dump_spectra) then      
+        call livewrite('powerhK.dat',kmpc,power_spectrum_tens)
+        atHkExit = hubble_splinexit(infCosmo,kmpc)
+        call livewrite('powerhN.dat',atHkExit%bfold,power_spectrum_tens)
+     endif
+ 
+     if (display) then
+         write(*,*)'power_spectrum_tens:'
+        write(*,*)'kmpc= Ph= '&
+             ,kmpc,power_spectrum_tens
+     endif
+ 
+ 
+     if (dump_modes) then
+        write(*,*)'tensor evolution dumped!'
+        read(*,*)
+     endif
+    
+   end function power_spectrum_tens
+ 
+ 
+ 
+ 
+   function pert_tens_bgevol(infCosmo,kmpc)
+ !this evolves the bg and tens = k^3/2 * h simultaneously
+     use inftools, only : easydverk
+     use infprec, only : transfert
+     use infbg, only : operator(/=)
+     use infbg, only : bg_field_dot_coupled
+     use infbg, only : hubble_parameter_square
+     use inftorad, only : bfold_hubble_fraction, lnMpcToKappa
+     use infinout
+ 
+     implicit none
+ 
+     type(inftoradcosmo), intent(in) :: infCosmo    
+     real(kp), intent(in) :: kmpc        
+     complex(kp) :: pert_tens_bgevol
+ 
+     type(transfert) :: cosmoData 
+ 
+ !we do not want to recompute the background from billion efolds. It is
+ !enough to start just before the relevant modes today are created
+ 
+ !workaround for old omp threadprivate directive (common for
+ !static + save)
+     real(kp) :: efoldTune
+     real(kp), dimension(fieldNum) :: fieldTune, velocityTune
+     type(infbgphys) :: bgPrevious
+     common /bgTensSave/ efoldTune, fieldTune, velocityTune, bgPrevious
+     save /bgTensSave/
+ !$omp threadprivate(/bgTensSave/)
+ 
+     real(kp) :: bfold, efold, efoldStart, bfoldStart, bfoldNext
+ 
+ !output files steps 
+     integer, parameter :: bfoldDataNum = 5000
+     real(kp) :: bfoldStep
+ 
+ !accuracy for the forward integration of background only and both
+ !background and perturbations (any backward (unstable) integration is
+ !avoided). Since sub-Hubble perturbations oscillate, funny low
+ !accuracy on pertevol lead to funny long integration time
+     real(kp), parameter :: tolBgEvol = tolkp
+     real(kp), parameter :: tolEvol = 1e-11   
+     
+     integer, parameter :: neqs = 4 + 2*fieldNum
+     integer, parameter :: neqsbg = 2*fieldNum
+ 
+     complex(kp) :: tens,tensDot,tensStart,tensDotStart    
+     real(kp), dimension(2*fieldNum) :: bgVar
+ !tens and bg together
+     real(kp), dimension(neqs) :: allVar
+     real(kp), dimension(fieldNum) :: field,velocity
+     real(kp) :: hubbleSquare,kphysOverHubbleStart
+ 
+ 
+ 
+ 
+ !for transferring kmpc + other cosmo to the differential equations
+     cosmoData%real1 = kmpc
+     cosmoData%real2 = infCosmo%bgEnd%efold
+     cosmoData%real3 = infCosmo%efoldEndToToday
+ 
+ !find the bfold of creation
+ ! solution of N + ln[kappa H(N)] = ln(kmpc) -ln(aend/a0) -Nc -ln[(k/aH)_creation]    
+     kphysOverHubbleStart = kphysOverHubbleCreate
+     bfoldStart = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleStart)
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'tensor modes: kmpc = ',kmpc
+        write(*,*)'bfold quantum = ',bfoldStart
+        write(*,*)
+     endif
+ 
+ 
+     if (dump_modes) then
+        if (bfoldDataNum.le.1) stop 'pert_tens_bgevol: 1 data point?'
+        bfoldStep = (infCosmo%bfoldEnd - bfoldStart)/real(bfoldDataNum-1)
+        call delete_file('tens.dat')
+     else
+ !turbo settings, let's go to the end of inflation
+        bfoldStep = 1._kp/epsilon(1._kp)
+     endif
+ 
+ 
+ !evolve the bg from efoldIni to efoldStart of mode creation only
+ !once. After move from previous bgStart to the new efoldStart of mode
+ !creation, ONLY if the mode creation is at greater efold than the
+ !efoldStart of the previous mode: backward integration of the bg is
+ !unstable by rk methods. We also check that the bginf
+ !model is the same to do that. When all these conditions are not filled
+ !we start again from infCosmo
+     
+ !test if the bg model change print *,'testcond',
+ !    ((infCosmo%bgIni%efold.ne.bgPrevious%efold) &
+ !    .or.(any(infCosmo%bgIni%field.ne.bgPrevious%field)) &
+ !    .or.(any(infCosmo%bgIni%fieldDot.ne.bgPrevious%fieldDot))),
+ !    (infCosmo%bgIni /= bgPrevious)
+ 
+     if (infCosmo%bgIni /= bgPrevious) then
+        efoldTune = infCosmo%bgIni%efold
+        fieldTune = infCosmo%bgIni%field
+        velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble
+     endif
+ 
+     bgPrevious = infCosmo%bgIni
+    
+     efoldStart = bfoldStart + infCosmo%bgEnd%efold
+ 
+ !only forward integration allowed
+     if (efoldStart.lt.efoldTune) then      
+        efoldTune = infCosmo%bgIni%efold
+        fieldTune = infCosmo%bgIni%field
+        velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble
+        if (efoldStart.lt.infCosmo%bgIni%efold) then
+           write(*,*) 'pert_tens_bgevol: kmpc =',kmpc
+           write(*,*) 'bfoldCreate= bfoldExtrem= ',bfoldStart,infCosmo%bgIni%efold
+           stop
+        endif
+     endif
+     
+ 
+     efold = efoldTune
+     
+     bgVar(1:fieldNum) = fieldTune(1:fieldNum)
+     bgVar(fieldNum+1:2*fieldNum) = velocityTune(1:fieldNum)
+     
+     call easydverk(neqsbg,bg_field_dot_coupled,efold,bgVar,efoldStart,tolBgEvol)
+ 
+     efoldTune = efold
+     fieldTune(1:fieldNum) = bgVar(1:fieldNum)
+     velocityTune(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum)
+ 
+ 
+ !set the quantum initial conditions for the perturbations at bfoldStart    
+ 
+     call pert_creation_standard(tensStart,tensDotStart,bfoldStart,infCosmo,kmpc)
+ 
+    
+ !evolve bg + tens pert from mode creation to end of inflation
+ 
+     allVar(1) = real(tensStart)
+     allVar(2) = aimag(tensStart)
+     allVar(3) = real(tensDotStart)    
+     allVar(4) = aimag(tensDotStart)
+ 
+     allVar(5:4+fieldNum) = bgVar(1:fieldNum)
+     allVar(5+fieldNum:4+2*fieldNum) = bgVar(fieldNum+1:2*fieldNum)
+ 
+     bfold = bfoldStart
+ 
+     do while (bfold.lt.infCosmo%bfoldEnd)
+     
+        bfoldNext = min(bfold + bfoldStep, infCosmo%bfoldEnd)
+ 
+        call easydverk(neqs,pert_tens_bgdot,bfold,allVar,bfoldNext,tolEvol,cosmoData)
+ 
+        tens =  cmplx(AllVar(1),AllVar(2))
+        tensDot = cmplx(AllVar(3), AllVar(4))       
+ 
+ !for test
+        if (dump_modes) then
+           field = allVar(5:4+fieldNum)
+           velocity = allVar(5+fieldNum:4+2*fieldNum)
+           hubbleSquare = hubble_parameter_square(field,velocity,.true.)
+           call livewrite('kmpc.dat',bfold, &
+                kmpc*exp(-bfold)*exp(infCosmo%efoldEndToToday) &
+                *exp(-lnMpcToKappa))
+           call livewrite('tens.dat',bfold,abs(tens),abs(real(tens)),abs(aimag(tens)))
+           call livewrite('hubble.dat',bfold,sqrt(hubbleSquare))
+        endif
+     
+     enddo
+   
+     pert_tens_bgevol = tens
+ 
+   end function  pert_tens_bgevol
+ 
+ 
+ 
+ 
+   subroutine pert_tens_bgdot(neqs,bfold,allVar,allVarDot,cosmoData)       
+     use infprec, only : transfert
+     use infbg, only : bg_field_dot_coupled, slowroll_first_parameter &
+          , hubble_parameter_square
+     use inftorad, only : lnMpcToKappa
+     implicit none
+         
+     integer :: neqs    
+     real(kp) :: bfold
+     type(transfert), optional, intent(inout) :: cosmoData    
+     real(kp), dimension(neqs) :: allVar
+     real(kp), dimension(neqs) :: allVarDot
+ 
+     real(kp), dimension(fieldNum) :: field, velocity
+     real(kp), dimension(2*fieldNum) :: bgVar, bgVarDot
+     real(kp), dimension(4) :: pertVar, pertVarDot
+ 
+     real(kp) :: kmpc, efoldEnd, efoldEndToToday
+     real(kp) :: efold, epsilon1, hubble, kphysOverHubble
+ 
+     kmpc = cosmoData%real1
+     efoldEnd = cosmoData%real2
+     efoldEndToToday = cosmoData%real3
+         
+ !equation of motion for the background
+     bgVar(1:2*fieldNum) = allVar(5:4+2*fieldNum)
+ 
+     efold = bfold + efoldEnd
+     call bg_field_dot_coupled(2*fieldNum,efold,bgVar,bgVarDot)  
+ 
+ !need the background for the equations of the perturbations
+     field = bgVar(1:fieldNum)
+     velocity = bgVar(fieldNum+1:2*fieldNum)
+     epsilon1 = slowroll_first_parameter(field,velocity,.true.)
+     hubble = sqrt(hubble_parameter_square(field,velocity,.true.))
+ 
+     kphysOverHubble = (kmpc/hubble)* exp(-bfold + efoldEndToToday &
+          - lnMpcToKappa)
+ !    print *,'kphysOverHubble',kphysOverHubble
+ !    read(*,*)
+ !equations of motion for the tensor modes
+     pertVar(1:4) = allVar(1:4)
+ 
+     pertVarDot(1:2) = pertVar(3:4)
+     pertVarDot(3:4) = - (kphysOverHubble**2) * pertVar(1:2) &
+          - (3d0 - epsilon1)*pertVar(3:4)
+ 
+ !set the return value 
+     allVarDot(1:4) = pertVarDot(1:4)
+     allVarDot(5:4+2*fieldNum) = bgVarDot(1:2*fieldNum)
+ 
+   end subroutine pert_tens_bgdot
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !scalar modes
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function power_spectrum_scal(infCosmo,kmpc)
+ !computes 1/(2pi^2) * <zeta,zeta>,  <zeta,S1>, <zeta,S2>, <S1,zeta>, <S1,S1> etc...
+ !the evolved variables already include the k^3/2 factor.   
+     use inftorad, only : infhubblexit, hubble_splinexit
+     use infinout, only : livewrite
+ 
+     implicit none
+     real(kp), dimension(scalNum,scalNum) :: power_spectrum_scal
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp), intent(in) :: kmpc
+ 
+     type(infhubblexit) :: atHkExit
+     integer :: vacuumNum
+     complex(kp) :: powerFrom
+   
+     real(kp) :: pi
+     complex(kp), dimension(scalNum,fieldNum) :: obsPertFrom
+    
+     integer :: i,j,k,whichInVac
+ 
+ 
+     obsPertFrom = 0._kp
+ 
+ !    vacuumNum = fieldNum
+ 
+ !when the dilaton is not coupled
+     vacuumNum = matterNum
+ 
+     pi=acos(-1._kp)
+ 
+     do whichInVac=1,vacuumNum
+        obsPertFrom(:,whichInVac) = pert_scal_bgevol(infCosmo,kmpc,whichInVac)
+     enddo
+ 
+ !the two-points correlation functions
+ !mind the modulus --> cross correlations are complex in Fourier Space.
+     
+     do j=1,scalNum
+        do i=1,scalNum
+           powerFrom = 0._kp
+           do k=1,vacuumNum
+              powerFrom = powerFrom + conjg(obsPertFrom(i,k))*obsPertFrom(j,k)             
+           enddo
+           power_spectrum_scal(i,j) = (0.5_kp/pi/pi)*real(powerFrom)
+        enddo
+     enddo
+ 
+     if (dump_spectra) then      
+        call livewrite('powerzetaK.dat',kmpc &
+             ,power_spectrum_scal(scalNum,scalNum))
+        atHkExit = hubble_splinexit(infCosmo,kmpc)
+        call livewrite('powerzetaN.dat',atHkExit%bfold &
+             ,power_spectrum_scal(scalNum,scalNum))
+     endif
+ 
+     if (display) then
+        write(*,*)'power_spectrum_scal:'
+        write(*,*)'kmpc= Ps= '&
+             ,kmpc,power_spectrum_scal(scalNum,scalNum)
+     endif
+ 
+     if (dump_modes) then
+        write(*,*)'scalar evolution dumped!'       
+        read(*,*)
+     endif
+     
+       
+   end function power_spectrum_scal
+ 
+ 
+ 
+ 
+ 
+    function pert_scal_bgevol(infCosmo,kmpc,whichInVacuum)
+ !this evolves the bg and scalar = k^3/2 *(fieldPert,Psi) simultaneously and
+ !return the final values of . zeta comoving
+ !curvature perturbation, Psi Bardeen potential, Q Mukhanov variable.
+ 
+     use inftools, only : easydverk
+     use infprec, only : transfert
+     use infbgmodel, only : metric,deriv_metric,conformal_factor_square
+     use infbgmodel, only : conformal_first_gradient
+     use infbg, only : operator(/=)
+     use infbg, only : bg_field_dot_coupled
+     use infbg, only : slowroll_first_parameter, slowroll_second_parameter    
+     use infbg, only : hubble_parameter_square
+     use infbg, only : potential, deriv_potential
+     use inftorad, only : bfold_hubble_fraction
+     use infinout
+ 
+     implicit none
+ 
+     complex(kp), dimension(scalNum) :: pert_scal_bgevol
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp), intent(in) :: kmpc
+     integer, intent(in) :: whichInVacuum
+    
+     type(transfert) :: cosmoData
+  
+ !not intialized
+     real(kp) :: efoldTune, hubbleTune, hubble
+     real(kp), dimension(fieldNum) :: fieldTune, velocityTune
+     type(infbgphys) :: bgPrevious
+     common /bgScalSave/ efoldTune, fieldTune, velocityTune, bgPrevious   
+     save /bgScalSave/
+ !$omp threadprivate(/bgScalSave/)
+ 
+     real(kp) :: bfold, efold, efoldStart, bfoldStart, bfoldNext
+   
+ !output files number of steps
+     integer, parameter :: bfoldDataNum = 5000
+     real(kp) :: bfoldStep
+ 
+ !field, fieldDot real; pert, pertDot complex.
+ 
+ !accuracy for the forward integration of background only and both
+ !background and perturbations (any backward (unstable) integration is
+ !avoided). Since sub-Hubble perturbations oscillate, funny low
+ !accuracy on pertevol lead to funny long integration time
+     real(kp), parameter :: tolBgEvol = tolkp
+     real(kp), parameter :: tolEvol = 1e-11
+ 
+     integer, parameter :: neqs = 4*scalNum + 2*fieldNum
+     integer, parameter :: neqsbg = 2*fieldNum
+ 
+     complex(kp) :: pertStart, pertDotStart    
+     complex(kp), dimension(2) :: bardeensStart
+     complex(kp), dimension(scalNum) :: scalStart, scalDotStart
+     complex(kp), dimension(scalNum) :: scal,scalDot
+ 
+     real(kp) :: epsilon1
+     real(kp) :: kphysOverHubbleStart, kinetic, kineticDot
+ 
+ !observable quantites, total and partial comoving curvature perturbations
+     complex(kp) :: zeta, zetaJF
+     complex(kp), dimension(fieldNum) :: mukhaScal,zetaScal !,entro
+     complex(kp), dimension(matterNum) :: zetaMatterDensJF
+ 
+     real(kp) :: sigmaDot
+     real(kp), dimension(fieldNum) :: unitDot
+     real(kp), dimension(fieldNum) :: field,velocity,fieldDot
+     real(kp), dimension(2*fieldNum) :: bgVar
+     real(kp), dimension(fieldNum,fieldNum) :: metricVal
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv
+ !field and scal together
+     real(kp), dimension(neqs) :: allVar
+ 
+     integer :: i
+     character(len=15) :: strgWhich, strgCount
+ 
+ 
+ !bugbuster
+     complex(kp), dimension(2) :: bardeenTest
+     logical, parameter :: doJordanFrame = .false.
+    
+     if ((whichInVacuum.gt.fieldNum).or.(whichInVacuum.le.0)) then
+        stop 'pert_scalar_bgevol: no such scalar perturbations'
+     endif
+ 
+ 
+ !to pass kmpc to differential equations throught dverk
+     cosmoData%real1 = kmpc
+     cosmoData%real2 = infCosmo%bgEnd%efold
+     cosmoData%real3 = infCosmo%efoldEndToToday
+    
+ !find the bfold of creation
+ ! solution of N + ln[kappa H(N)] = ln(kmpc) -ln(aend/a0) -Nc -ln[(k/aH)_creation]    
+     kphysOverHubbleStart = kphysOverHubbleCreate
+     bfoldStart = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleStart)
+     
+     if (display) then
+        write(*,*)
+        write(*,*)'scalar modes: kmpc = ',kmpc
+        write(*,*)'bfold quantum = ',bfoldStart
+        write(*,*)'mode in vacuum: ',whichInVacuum       
+        write(*,*)
+     endif
+ 
+     if (dump_modes) then
+        if (bfoldDataNum.le.1) stop 'pert_scal_bgevol: 1 data point?'
+        bfoldStep = (infCosmo%bfoldEnd - bfoldStart)/real(bfoldDataNum-1)       
+        write(strgWhich,*) whichInVacuum       
+        call delete_file('zeta2_'//trim(adjustl(strgWhich))//'.dat')
+        call delete_file('psi_'//trim(adjustl(strgWhich))//'.dat')
+        call delete_file('zeta2JF_'//trim(adjustl(strgWhich))//'.dat')
+        do i=1,fieldNum
+           write(strgCount,*) i
+           call delete_file('scal_'//trim(adjustl(strgCount))// &
+                   '_'//trim(adjustl(strgWhich))//'.dat')
+ !          call delete_file('entro_'//trim(adjustl(strgCount))// &
+ !                  '_'//trim(adjustl(strgWhich))//'.dat')         
+           call delete_file('zetascal_'//trim(adjustl(strgCount))// &
+                '_'//trim(adjustl(strgWhich))//'.dat')         
+        enddo
+     else
+ !turbo settings, let's go to the end of inflation
+        bfoldStep = 1._kp/epsilon(1._kp)
+     endif
+    
+ 
+ !test if the bg model change
+     if (infCosmo%bgIni /= bgPrevious) then
+        efoldTune = infCosmo%bgIni%efold
+        fieldTune = infCosmo%bgIni%field
+        velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble
+     endif
+ 
+     bgPrevious = infCosmo%bgIni
+    
+     efoldStart = bfoldStart + infCosmo%bgEnd%efold
+ 
+ !only forward integration allowed
+     if (efoldStart.lt.efoldTune) then
+        efoldTune = infCosmo%bgIni%efold
+        fieldTune = infCosmo%bgIni%field
+        velocityTune = infCosmo%bgIni%fieldDot * infCosmo%bgIni%hubble
+        if (efoldStart.lt.infCosmo%bgIni%efold) then
+           write(*,*) 'pert_scalar_bgevol: kmpc =',kmpc
+           write(*,*) 'bfoldCreate= bfoldExtrem= ',bfoldStart,infCosmo%bgIni%efold
+           stop
+        endif
+     endif
+     
+ 
+ !evolve the bg from 0 to bfold of mode creation
+     efold = efoldTune
+     bgVar(1:fieldNum) = fieldTune(1:fieldNum)
+     bgVar(fieldNum+1:2*fieldNum) = velocityTune(1:fieldNum)
+ 
+     call easydverk(neqsbg,bg_field_dot_coupled,efold,bgVar,efoldStart,tolBgEvol)
+    
+ !update varTune to the bfold of mode creation (the bg will be computed
+ !from here next time)
+     efoldTune = efold
+     fieldTune(1:fieldNum) = bgVar(1:fieldNum)
+     velocityTune(1:fieldNum) = bgVar(fieldNum+1:2*fieldNum)
+     hubbleTune = sqrt(hubble_parameter_square(fieldTune,velocityTune,.true.))
+ 
+ !the field initial quantum states have to be normalised with respect
+ !to their kinetic term (done by calling pert_creation_kinetic)
+     metricVal = metric(fieldTune)
+     metricDeriv = deriv_metric(fieldTune)
+ 
+     kinetic = metricVal(whichInVacuum,whichInVacuum)
+     kineticDot = dot_product(metricDeriv(whichInVacuum,whichInVacuum,:) &
+          ,velocityTune/hubbleTune)
+ 
+ !    print *,'kinteic',kinetic,kineticDot
+ 
+     call pert_creation_kinetic(pertStart,pertDotStart &
+          ,bfoldStart,kinetic,kineticDot,infCosmo,kmpc)
+ !    print *,'kinetic'
+ !    print *,'pertStart',pertStart
+ !    print *,'pertDotStart',pertDotStart
+ 
+ !    call pert_creation_standard(pertStart,pertDotStart,bfoldStart,infCosmo,kmpc)
+ !    print *,'standard'
+ !    print *,'pertStart',pertStart
+ !    print *,'pertDotStart',pertDotStart
+ 
+ !reset everyone
+     scalStart = 0._kp
+     scalDotStart = 0._kp
+ 
+ !there is a sqrt(2) factor between scalar and tensor modes.
+     scalStart(whichInVacuum) = pertStart /sqrt(2._kp)
+     scalDotStart(whichInVacuum) = pertDotStart /sqrt(2._kp)
+ 
+ 
+ !The initial value of the Bardeen potential is fixed by the constraint
+ !equuations, i.e. momemtum and energy conservation. It is a bad idea
+ !to use these equations during the evolution since they are singular
+ !at Hubble exit and epsilon=1, but are fine initially, for quantum
+ !wavelength well below the Hubble radius
+     bardeensStart = bardeen_bardeen_dot(bfoldStart,fieldTune,velocityTune &
+          ,scalStart(1:fieldNum),scalDotStart(1:fieldNum),cosmoData)
+ 
+     scalStart(scalNum) = bardeensStart(1)      
+     scalDotStart(scalNum) = bardeensStart(2)
+ 
+     
+ !evolve bg + tens pert from mode creation to end of inflation
+ !pert variables and their derivatives
+     do i=1,scalNum       
+        allVar(2*i-1) = real(scalStart(i))
+        allVar(2*i) = aimag(scalStart(i))
+        allVar(2*scalNum + 2*i-1) = real(scalDotStart(i))    
+        allVar(2*scalNum + 2*i) = aimag(scalDotStart(i))
+     enddo
+    
+ !bg field and velocity
+     allVar(4*scalNum+1:4*scalNum+2*fieldNum) = bgVar(1:2*fieldNum)
+     
+     bfold = bfoldStart
+   
+     do while (bfold.lt.infCosmo%bfoldEnd)
+     
+        bfoldNext = min(bfold + bfoldStep, infCosmo%bfoldEnd)
+ 
+ !       print *
+ !       print *,'allVar',allVar
+ !       print *
+ 
+        call easydverk(neqs,pert_scalar_bgdot,bfold,allVar,bfoldNext,tolEvol,cosmoData)
+ 
+        field = allVar(4*scalNum+1:4*scalNum+fieldNum)
+        metricVal = metric(field)       
+        velocity = allVar(4*scalNum+fieldNum+1:4*scalNum+2*fieldNum)
+        hubble = sqrt(hubble_parameter_square(field,velocity,.true.))
+        fieldDot = velocity/hubble
+        epsilon1 = slowroll_first_parameter(field,velocity,.true.)       
+        sigmaDot = sqrt(2._kp*epsilon1)
+ 
+        do i=1,scalNum
+           scal(i) = cmplx(allVar(2*i-1),allVar(2*i))
+           scalDot(i) = cmplx(allVar(2*scalNum+2*i-1),allVar(2*scalNum+2*i))          
+        enddo
+ 
+        unitDot = fieldDot/sigmaDot
+        
+ !curvature perturbation for each field: Psi +
+ !deltaField/(Dfield/Dbfold)
+        do i=1,fieldNum
+           mukhaScal(i) = scal(i) + fieldDot(i)*scal(scalNum)
+           if (fieldDot(i).ne.0._kp) then
+              zetaScal(i) = scal(scalNum) + scal(i)/fieldDot(i)
+           else
+              zetaScal(i) = 0._kp
+           endif
+ !          entro(i) = scal(i) - unitDot(i) &
+ !               * dot_product(matmul(metricVal,unitDot),scal(1:fieldNum))
+        enddo
+        
+ 
+       
+ !zeta constant density hypersurface in Jordan Frame for matter fields
+        if (doJordanFrame) then
+           zetaMatterDensJF(1:matterNum) &
+                = curvature_matter_density_JF(field,velocity,scal,scalDot)
+           zetaJF = curvature_comoving_JF(field,velocity,scal,scalDot)
+        else
+ !comoving curvature perturbation: Psi + deltaSigma/(DSigma/Dbfold)
+           zeta = scal(scalNum) & 
+                + (dot_product(matmul(metricVal,fieldDot),scal(1:fieldNum))) &
+                /(2._kp*epsilon1)
+        endif
+ 
+ !for test (fully inefficient way of writing files)
+        if (dump_modes) then                    
+ 
+ 
+           bardeenTest = bardeen_bardeen_dot(bfold,field,velocity &
+                ,scal(1:fieldNum),scalDot(1:fieldNum),cosmoData)
+ 
+ !          print *,'Psi',bardeenTest(1)-scal(scalNum)
+ !          print *,'Psidot',bardeenTest(2)-scalDot(scalNum)
+ !          print *,'zeta',zeta-(bardeenTest(1)+ (bardeenTest(2) + bardeenTest(1))/epsilon1)
+ !          print *,'ZetaScal'
+ !          print *,'zeta -each',zeta &
+ !               - (dot_product(matmul(metricVal,velocity/hubble) &
+ !               ,velocity/hubble*zetaScal)/(2.*epsilon1))
+ !          read(*,*)
+ 
+           call livewrite('zeta2_'//trim(adjustl(strgWhich))//'.dat' &
+                , bfold, abs(conjg(zeta)*zeta),abs(real(zeta)),abs(aimag(zeta)))
+ 
+           call livewrite('zeta2JF_'//trim(adjustl(strgWhich))//'.dat' &
+                   ,bfold,real(conjg(zetaJF)*zetaJF),abs(real(zetaJF)) &
+                   ,abs(aimag(zetaJF)))
+ 
+           do i=1,fieldNum
+              write(strgCount,*) i
+              call livewrite('scal_'//trim(adjustl(strgCount))// &
+                   '_'//trim(adjustl(strgWhich))//'.dat' &
+                   , bfold, abs(scal(i)),abs(real(scal(i))), abs(aimag(scal(i))))             
+              call livewrite('zetascal_'//trim(adjustl(strgCount))// &
+                   '_'//trim(adjustl(strgWhich))//'.dat' &
+                   ,bfold,abs(zetaScal(i)),abs(real(zetaScal(i)))&
+                   ,abs(aimag(zetaScal(i))))             
+           enddo
+ 
+           call livewrite('psi_'//trim(adjustl(strgWhich))//'.dat' &
+                , bfold, abs(scal(scalNum)),abs(real(scal(scalNum))) &
+                ,abs(aimag(scal(scalNum))))
+ 
+        endif
+     enddo
+ 
+ 
+ !zeta is returned instead from the mukhanov variable Q
+ !zeta = Q/sigmaDot = Q/(sqrt(2epsilon1))
+ !rescaled entropic perturbations are returned: S1(2) = entro1(2)/sigmaDot
+ 
+ !    pert_scal_bgevol(1:fieldNum) = entro(1:fieldNum)/sigmaDot
+ !    pert_scal_bgevol(scalNum) = zeta
+ 
+     
+     if (doJordanFrame) then
+        pert_scal_bgevol(1:matterNum) = zetaMatterDensJF
+        pert_scal_bgevol(matterNum+1:fieldNum) = scal(matterNum+1:fieldNum)
+        pert_scal_bgevol(scalNum) = zetaJF       
+     else
+        do i=1,fieldNum
+           pert_scal_bgevol(i) = zetaScal(i)-zetaScal(entroRef)
+        enddo                 
+        pert_scal_bgevol(scalNum) = zeta
+     endif
+ 
+   end function  pert_scal_bgevol
+ 
+ 
+ 
+ 
+ 
+ 
+   
+   subroutine pert_scalar_bgdot(neqs,bfold,allVar,allVarDot,cosmoData) 
+     use infprec, only : transfert
+     use infbgmodel, only : metric, metric_inverse, deriv_metric
+     use infbg, only : potential, deriv_potential, deriv_second_potential
+     use infbg, only : bg_field_dot_coupled, slowroll_first_parameter
+     use infbg, only : hubble_parameter_square
+     use infbg, only : connection_affine, deriv_connection_affine
+     use inftorad, only : lnMpcToKappa
+ 
+     implicit none
+         
+     integer :: neqs    
+     real(kp) :: bfold
+     type(transfert), optional, intent(inout) :: cosmoData    
+     real(kp), dimension(neqs) :: allVar
+     real(kp), dimension(neqs) :: allVarDot
+ 
+     real(kp), dimension(fieldNum) :: field, velocity, fieldDot
+     
+     real(kp), dimension(2*fieldNum) :: bgVar, bgVarDot
+    
+     real(kp) :: kmpc, efoldEnd, efoldEndToToday
+     real(kp) :: efold, kphysOverHubble, pot
+     real(kp) :: hubbleSquare, hubble, epsilon1
+ 
+ 
+ !temp variable for writing the equations of motion...   
+     complex(kp) :: bardeenPsi, bardeenPsiDot, bardeenPsiDotDot
+     complex(kp), dimension(fieldNum) :: fieldPert,fieldPertDot,fieldPertDotDot
+ 
+ !the coefficients entering in the equations of motion
+ 
+ 
+ !the physical quantities entering in the above coefficients
+     real(kp), dimension(fieldNum) :: potDeriv, potDerivVec
+     real(kp), dimension(fieldNum,fieldNum) :: metricVal, metricInv, potSecond
+     real(kp), dimension(fieldNum,fieldNum) :: connectXfieldDot, potSecondVec
+     real(kp), dimension(fieldNum,fieldNum) :: connectDerivXfieldDotSquare
+     real(kp), dimension(fieldNum,fieldNum) :: metricPotDerivs, Vff
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv,connect
+     real(kp), dimension(fieldNum,fieldNum,fieldNum,fieldNum) :: connectDeriv
+ 
+     integer :: i,j
+ 
+ 
+ 
+ !get the wave number from dverk
+     kmpc = cosmoData%real1       
+     efoldEnd = cosmoData%real2
+     efoldEndToToday = cosmoData%real3
+ 
+ !equation of motion for the background (we use the physical velocity)
+     bgVar(1:2*fieldNum) = allVar(4*scalNum+1:4*scalNum+2*fieldNum)
+ 
+     efold = bfold + efoldEnd
+     call bg_field_dot_coupled(2*fieldNum,efold,bgVar,bgVarDot)  
+ 
+ 
+ !need some background quantities for the perturbations
+     field = bgVar(1:fieldNum)
+     velocity = bgVar(fieldNum+1:2*fieldNum)
+     hubbleSquare = hubble_parameter_square(field,velocity,.true.)
+     hubble = sqrt(hubbleSquare)
+     fieldDot = velocity/hubble    
+ 
+ !remind this is also: -(DHubble/Dbfold)/Hubble and sigmaDot^2/2
+     epsilon1 = slowroll_first_parameter(field,velocity,.true.)    
+ 
+     kphysOverHubble = (kmpc/hubble) * exp(-bfold + efoldEndToToday &
+          - lnMpcToKappa)
+ 
+ 
+ !the scalar perturbations (real and imaginary parts)
+ !    fieldPert(1:fieldNum) = allVar(1:2*fieldNum)
+ !    bardeenPsi = allVar(2*fieldNum+1:2*scalNum)
+ 
+ !their derivatives
+ !    fieldPertDot(1:fieldNum) = allVar(2*scalNum+1:2*scalNum+2*fieldNum)
+ !    bardeenPsiDot = allVar(2*scalNum+2*fieldNum+1:4*scalNum)
+ 
+     do i=1,fieldNum
+        fieldPert(i) = cmplx(allVar(2*i-1),allVar(2*i))
+        fieldPertDot(i) = cmplx(allVar(2*scalNum+2*i-1),allVar(2*scalNum+2*i))
+     enddo
+     bardeenPsi = cmplx(allVar(2*fieldNum+1),allVar(2*scalNum))
+     bardeenPsiDot = cmplx(allVar(2*scalNum+2*fieldNum+1),allVar(4*scalNum))
+ 
+ 
+ 
+ !their equations of motion
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! warm up !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+     metricVal = metric(field)
+     metricInv = metric_inverse(field)
+     metricDeriv = deriv_metric(field)
+ 
+     connect = connection_affine(field)
+     connectDeriv = deriv_connection_affine(field)
+ 
+ !all potential related functions are in unit of H^2
+     pot = potential(field)/hubbleSquare
+     potDeriv = deriv_potential(field)/hubbleSquare
+     potSecond = deriv_second_potential(field)/hubbleSquare
+ 
+     potDerivVec = matmul(metricInv,potDeriv)
+     potSecondVec = matmul(metricInv,potSecond)
+ 
+     do i=1,fieldNum       
+        connectXfieldDot(i,:) = matmul(connect(i,:,:),fieldDot)
+        do j=1,fieldNum
+           connectDerivXfieldDotSquare(i,j) &
+                = dot_product(matmul(connectDeriv(i,:,:,j),fieldDot),fieldDot)
+           metricPotDerivs(i,j) &
+                = dot_product(matmul(metricDeriv(:,:,j),potDerivVec),metricInv(i,:))
+           Vff(i,j) = connectDerivXfieldDotSquare(i,j) + potSecondVec(i,j) &
+                - metricPotDerivs(i,j)
+        enddo
+     enddo
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! equations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+     fieldPertDotDot = - (3._kp - epsilon1) * fieldPertDot &
+          - 2._kp * matmul(connectXfieldDot,fieldPertDot) - matmul(Vff,fieldPert) &
+          - kphysOverHubble**2 * fieldPert &
+          + 4._kp * fieldDot * bardeenPsiDot - 2._kp * potDerivVec * bardeenPsi
+ 
+     bardeenPsiDotDot = - (7._kp - epsilon1) * bardeenPsiDot &
+          - (2._kp * pot + kphysOverHubble**2) * bardeenPsi &
+          - dot_product(potDeriv,fieldPert)
+              
+ !
+     
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end equations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ !specify the return value: glue all things together for integration.
+ 
+ !    allVarDot(1:2*fieldNum) = fieldPertDot(1:fieldNum)
+ !    allVarDot(2*fieldNum+1:2*scalNum) = bardeenPsiDot
+ !    allVarDot(2*scalNum+1:2*scalNum+2*fieldNum) = fieldpertDotDot(1:fieldNum)
+ !    allVarDot(2*scalNum+2*fieldNum+1:4*scalNum) = bardeenPsiDotDot
+ 
+     do i=1,fieldNum
+        allVarDot(2*i-1)=real(fieldPertDot(i))
+        allVarDot(2*i) = aimag(fieldPertDot(i))
+        allVarDot(2*scalNum+2*i-1) = real(fieldPertDotDot(i))
+        allVarDot(2*scalNum+2*i) = aimag(fieldPertDotDot(i))
+     enddo
+ 
+     allVarDot(2*fieldNum+1) = real(bardeenPsiDot)
+     allVarDot(2*scalNum) = aimag(bardeenPsiDot)
+     allVarDot(2*scalNum+2*fieldNum+1) = real(bardeenPsiDotDot)
+     allVarDot(4*scalNum) = aimag(bardeenPsiDotDot)
+     
+     allVarDot(4*scalNum+1:4*scalNum+2*fieldNum) = bgVarDot(1:2*fieldNum)
+ 
+   end subroutine pert_scalar_bgdot
+   
+ 
+ 
+ 
+   
+   function bardeen_bardeen_dot(bfold,field,velocity,fieldPert,fieldPertDot,cosmoData)
+ !return the Bardeen potential and its derivative wrt efold from the
+ !constraint equations
+     use infprec, only : transfert
+     use infbgmodel, only : metric, deriv_metric
+     use infbg, only : deriv_potential, hubble_parameter_square
+     use infbg, only : slowroll_first_parameter
+     use inftorad, only : lnMpcToKappa
+ 
+     implicit none
+     complex(kp), dimension(2) :: bardeen_bardeen_dot
+     real(kp), intent(in) :: bfold
+     real(kp), dimension(fieldNum), intent(in) :: field, velocity
+     complex(kp), dimension(fieldNum), intent(in) :: fieldPert,fieldPertDot    
+     type(transfert), intent(in) :: cosmoData 
+     
+     
+     real(kp) :: epsilon1, hubbleSquare, hubble
+     real(kp) :: kmpc, efoldEndToToday, kphysOverHubble
+     
+ 
+     real(kp), dimension(fieldNum) :: potDeriv,metricDerivXFieldDotSquare, fieldDot
+     real(kp), dimension(fieldNum) :: metricXFieldDot
+     real(kp), dimension(fieldNum,fieldNum) :: metricVal
+     real(kp), dimension(fieldNum,fieldNum,fieldNum) :: metricDeriv
+ 
+     integer :: i
+ 
+ 
+     kmpc = cosmoData%real1           
+     efoldEndToToday = cosmoData%real3
+ 
+     epsilon1 = slowroll_first_parameter(field,velocity,.true.)
+     hubbleSquare = hubble_parameter_square(field,velocity,.true.)
+     hubble = sqrt(hubbleSquare)
+ 
+     fieldDot = velocity/hubble
+ 
+     metricVal = metric(field)
+     metricDeriv = deriv_metric(field)
+     potDeriv = deriv_potential(field)/hubbleSquare
+     
+     kphysOverHubble = (kmpc/hubble) * exp(-bfold + efoldEndToToday &
+          - lnMpcToKappa)
+     
+     metricXFieldDot = matmul(metricVal,fieldDot)
+ 
+     do i=1,fieldNum
+        metricDerivXFieldDotSquare(i) = dot_product(matmul(metricDeriv(:,:,i),fieldDot) &
+             ,fieldDot)
+     enddo
+ 
+ !bardeen potential
+     bardeen_bardeen_dot(1) &
+          = (1.5_kp * dot_product(metricXFieldDot,fieldPert) &
+          + 0.25_kp * dot_product(metricDerivXFieldDotSquare,fieldPert) &
+          + 0.5_kp * dot_product(potDeriv,fieldPert) &
+          + 0.5_kp * dot_product(metricXFieldDot,fieldPertDot)) &
+          / (epsilon1 - kphysOverHubble**2)
+ 
+ !bardeen potential derivative wrt bfold time
+     bardeen_bardeen_dot(2) = 0.5_kp * dot_product(metricXFieldDot,fieldPert) &
+          - bardeen_bardeen_dot(1)
+ 
+ 
+   end function bardeen_bardeen_dot
+ 
+ 
+ 
+ 
+   function curvature_matter_density_JF(field,velocity,scal,scalDot)
+ !this is the curvature on constant density hypersurface for the matter
+ !fields zetamat = Psi + (delta Rho) / (DRho/Defold), if one matter
+ !field only. zetamat_i = Psi + (delta Rho_i) / (DField_i/Defold)^2
+ !otherwise. In case of multiple matter fields, rho_i is not well
+ !defined due to possible couplings through the matter potential.
+ 
+     use infbgmodel, only : conformal_factor_square, conformal_first_gradient
+     use infbgmodel, only : deriv_matter_potential
+     use infbg, only : hubble_parameter_square
+     implicit none
+ 
+     complex(kp), dimension(matterNum) :: curvature_matter_density_JF
+     real(kp), dimension(fieldNum), intent(in) :: field, velocity
+     complex(kp), dimension(scalNum), intent(in) :: scal, scalDot
+ 
+     
+     complex(kp), dimension(matterNum) :: matterPert, matterPertDot
+     complex(kp), dimension(dilatonNum) :: dilatonPert, dilatonPertDot
+     complex(kp) :: bardeenPsi, bardeenPhi
+ 
+     real(kp) :: hubbleSquare, confSquare
+     real(kp), dimension(matterNum) :: matter, matterDot,derivMatterPot
+     real(kp), dimension(dilatonNum) :: dilaton, confFirstGrad
+     real(kp), dimension(fieldNum) :: fieldDot
+     
+     bardeenPsi = scal(scalNum)
+     bardeenPhi = bardeenPsi
+ 
+     matterPert = scal(1:matterNum)
+     matterPertDot = scalDot(1:matterNum)
+     dilatonPert = scal(matterNum+1:fieldNum)
+     dilatonPertDot = scalDot(matterNum+1:fieldNum)
+ 
+     hubbleSquare = hubble_parameter_square(field,velocity,.true.)
+     fieldDot = velocity/sqrt(hubbleSquare)
+     matterDot(1:matterNum) = fieldDot(1:matterNum)
+     
+     matter = field(1:matterNum)
+     dilaton = field(matterNum+1:fieldNum)
+     derivMatterPot = deriv_matter_potential(matter)
+     confSquare = conformal_factor_square(dilaton)
+     confFirstGrad = conformal_first_gradient(dilaton)
+ 
+ 
+     curvature_matter_density_JF = bardeenPsi + bardeenPhi/3._kp &
+          - (2._kp/3._kp) * dot_product(confFirstGrad,dilatonPert) &
+          - (1._kp/3._kp) * (matterPertDot/matterDot &
+          + confSquare * derivMatterPot / hubbleSquare / matterDot**2._kp &
+          * matterPert)
+ 
+   end function curvature_matter_density_JF
+ 
+ 
+ 
+ 
+   function curvature_comoving_JF(field,velocity,scal,scalDot)
+ !this is the comoiving curvature perturbation in the Jordan Frame,
+ !i.e.  zeta = PsiJF + (PsiJF' + HubbleConfJF x PhiJF)/(HubbleConfJF x
+ !epsilon1JF)
+ 
+     use infbgmodel, only : conformal_first_gradient, conformal_second_gradient
+     use infbg, only : slowroll_first_parameter_JF, hubble_parameter_square
+     implicit none
+ 
+     complex(kp) :: curvature_comoving_JF
+     real(kp), dimension(fieldNum), intent(in) :: field, velocity
+     complex(kp), dimension(scalNum), intent(in) :: scal, scalDot
+ 
+         
+     complex(kp), dimension(dilatonNum) :: dilatonPert, dilatonPertDot
+     complex(kp) :: bardeenPsi, bardeenPsiDot, bardeenPhi
+     complex(kp) :: bardeenPsiJF, bardeenPsiJFDot, bardeenPhiJF
+ 
+     real(kp) :: hubbleSquare, epsilon1JF
+     real(kp), dimension(fieldNum) :: fieldDot
+     real(kp), dimension(dilatonNum) :: dilaton, dilatonDot,confFirstGrad
+     real(kp), dimension(dilatonNum,dilatonNum) :: confSecondGrad
+ 
+ 
+     hubbleSquare = hubble_parameter_square(field,velocity,.true.)
+     epsilon1JF = slowroll_first_parameter_JF(field,velocity,.true.)
+ 
+     fieldDot = velocity/sqrt(hubbleSquare)
+ 
+     dilaton = field(matterNum+1:fieldNum)
+     dilatonDot = fieldDot(matterNum+1:fieldNum)
+     
+     bardeenPsi = scal(scalNum)
+     bardeenPhi = bardeenPsi
+     bardeenPsiDot = scalDot(scalNum)
+ 
+     dilatonPert = scal(matterNum+1:fieldNum)
+     dilatonPertDot = scalDot(matterNum+1:fieldNum)
+ 
+       
+     confFirstGrad = conformal_first_gradient(dilaton)
+     confSecondGrad = conformal_second_gradient(dilaton)
+    
+     bardeenPsiJF = bardeenPsi - dot_product(confFirstGrad,dilatonPert)
+     bardeenPhiJF = bardeenPhi + dot_product(confFirstGrad,dilatonPert)
+ 
+     bardeenPsiJFDot = bardeenPsiDot - dot_product(confFirstGrad,dilatonPertDot) &
+          - dot_product(matmul(confSecondGrad,dilatonDot),dilatonPert)
+ 
+     curvature_comoving_JF = bardeenPsiJF + (bardeenPsiJFDot &
+          + (1._kp + dot_product(confFirstGrad,dilatonDot))*bardeenPhiJF) &
+          / ((1._kp + dot_product(confFirstGrad,dilatonDot))*epsilon1JF)
+ 
+   end function curvature_comoving_JF
+ 
+ 
+ 
+  
+   subroutine pert_creation_standard(pertIni,pertDotIni,bfoldCreate,infCosmo,kmpc)
+ !For standard constant kinetic terms.
+ !mode creation at different times corresponding to a fix physical
+ !scale with respect to the Hubble radius: k/aH = Cte
+ !kmpc is the wavenumber today in unit of Mpc^-1. H is the Hubble
+ !parameter during inflation in unit of kappa. Evolution of the perturbations
+ !involve the dimensionless quantity: k/(aH)
+ ! k/aH = (k/a0)/(kappa H) x aend/a x a0/aend x kappa
+ !      = kmpc/kappaH x exp[-N] x a0/aend x (kappa/1Mpc)
+ !      = kmpc/kappaH x exp[-N] x exp[ln(a0/aend)] x exp[-Nc]
+ ! where Nc = ln[1Mpc/sqrt(8pi)/lPl]   <---- Nc=lnMpcToKappa()
+ ! N number of efold before the end of inflation (efold-efoldEnd)
+ 
+     use inftorad, only : scaleFactorToday, lnMpcToKappa
+     implicit none
+    
+     real(kp), intent(in) :: kmpc
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp), intent(in) :: bfoldCreate
+     complex(kp), intent(out) :: pertIni, pertDotIni
+      
+     complex(kp) :: qMode, qModePrimeOverk
+    
+ 
+ !set the quantum initial conditions at found bfold, in bfold time
+ !ex: for grav wav
+ ! h = qmode/a
+ ! h = a0/aend x aend/acreate x qmode/a0
+ ! Dh/Dbfold = a H h' = a H (qmode/a)' = (k/aH) x a0/aend x aend/acreate 
+ !                                                   x (qmode'/k)/a0 - h
+ 
+     call quantum_creation(kmpc,qmode,qmodePrimeOverk)
+ 
+     pertIni = qmode/scaleFactorToday
+     pertDotIni = (kphysOverHubbleCreate*qmodePrimeOverk - qmode)/scaleFactorToday
+ 
+ !normalisation of k in Mpc^-1 today    
+     pertIni = pertIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa)
+     pertDotIni = pertDotIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa)
+ 
+   end subroutine pert_creation_standard
+ 
+ 
+ 
+ 
+   subroutine pert_creation_kinetic(pertIni,pertDotIni,bfoldCreate,kinetic,kineticDot &
+        ,infCosmo,kmpc)
+ !for non-standard kinetic terms K(eta) Dfield Dfield instead of Dfield Dfield
+     use inftorad, only : scaleFactorToday, lnMpcToKappa
+     implicit none
+    
+     real(kp), intent(in) :: kmpc
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp), intent(in) :: bfoldCreate, kinetic, kineticDot
+     complex(kp), intent(out) :: pertIni, pertDotIni
+ 
+     real(kp) :: sqrtKinetic, lnDotSqrtKinetic
+     complex(kp) :: qMode, qModePrimeOverk
+    
+ !set the quantum initial conditions at found bfold, in bfold time
+ !ex: for grav wav, qmod designs the standard normalised quantum mode
+ ! h = qmode/a/K^1/2
+ ! h = a0/aend x aend/acreate x qmode/a0/K^1/2
+ ! Dh/Dbfold = a H h' = a H (qmode/a/K^1/2)'
+ ! =(k/aH) x a0/aend x aend/acreate x (qmode'/k)/a0/K^1/2 - h x (1+1/2 DLn(K)/Dbfold)
+ 
+     call quantum_creation(kmpc,qmode,qmodePrimeOverk)
+ 
+     sqrtKinetic = sqrt(kinetic)
+     lnDotSqrtKinetic = 0.5_kp * kineticDot/kinetic
+ 
+     pertIni = qmode /scaleFactorToday /sqrtKinetic
+     pertDotIni = (kphysOverHubbleCreate*qmodePrimeOverk - (1._kp + lnDotSqrtKinetic)*qmode) &
+          /scaleFactorToday /sqrtKinetic
+ 
+ !normalisation of k in Mpc^-1 today  
+     pertIni = pertIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa)
+     pertDotIni = pertDotIni*exp(infCosmo%efoldEndToToday - bfoldCreate - lnMpcToKappa)
+ 
+   end subroutine pert_creation_kinetic
+ 
+ 
+ 
+ 
+   subroutine quantum_creation(k,modeIni,modePrimeIniOverFreq)
+ !creates the initial quantum mode for a given k. The Bogoliubov
+ !coefficients are alpha and beta such as |alpha|^2 - |beta|^2 = 1. The
+ !creation time is not specified here and Prime denotes derivative with
+ !respect to the conformal time. Calling this function for all k at a
+ !same given conformal time with alpha=1,beta=0 is a Bunch-Davies vacuum.
+ !This is for rescaled modes in Fourier space: k^{3/2}*mode and
+ !in unit hbar=c=1, k is in unit of what you wish (cause rescaled modes).
+ 
+     implicit none
+     real(kp), intent(in) :: k
+     complex(kp), intent(out) :: modeIni, modePrimeIniOverFreq
+     real(kp), parameter :: pi = 3.141592653589793238
+     complex(kp), parameter :: alpha = (1._kp,0._kp)
+     complex(kp), parameter :: beta = (0._kp,0._kp)
+ 
+   
+     modeIni = k*(alpha + beta)
+     modePrimeIniOverFreq = - k*cmplx(0._kp,1._kp)*(alpha - beta)
+ !    print *,'qmode qmodeDot',modeIni,modePrimeIniOverFreq
+   end subroutine quantum_creation
+ 
+ 
+   
+ end module infpert
diff -r -c -b -B -N cosmomc/fieldinf/infpowspline.f90 cosmomc_fields/fieldinf/infpowspline.f90
*** cosmomc/fieldinf/infpowspline.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infpowspline.f90	2008-03-05 17:35:04.000000000 +0100
***************
*** 0 ****
--- 1,292 ----
+ module infpowspline
+ !compute the primordial power spectra for few values of k and set a
+ !spline at intermediate k
+ 
+   use infprec, only : kp
+ 
+   implicit none
+ 
+   private
+ 
+   logical, parameter :: display = .false.
+ 
+  
+   integer, save :: scalOrder
+   integer, save :: scalBcoefNum
+   integer, save :: scalModeNum
+   real(kp), dimension(:), allocatable, save :: scalLnkmpcKnot
+   real(kp), dimension(:,:,:), allocatable, save :: scalPowerBcoef
+ 
+   integer, save :: tensOrder
+   integer, save :: tensBcoefNum
+   integer, save :: tensModeNum
+   real(kp), dimension(:), allocatable, save :: tensLnkmpcKnot
+   real(kp), dimension(:), allocatable, save :: tensPowerBcoef
+   
+ 
+ 
+   public check_power_scal_spline, check_power_tens_spline
+   public free_power_scal_spline, free_power_tens_spline
+   public set_power_scal_spline, set_power_tens_spline
+   public splineval_power_scal, splineval_power_tens
+ 
+ contains
+   
+ 
+   function check_power_scal_spline()
+     implicit none
+     logical :: check_power_scal_spline
+ 
+     check_power_scal_spline = (allocated(scalLnkmpcKnot) &
+          .or. allocated(scalPowerBcoef))
+ 
+   end function check_power_scal_spline
+       
+ 
+ 
+ 
+   subroutine free_power_scal_spline()
+     implicit none
+ 
+     if (check_power_scal_spline()) then
+        deallocate(scalLnkmpcKnot)
+        deallocate(scalPowerBcoef)
+        if (display) write(*,*) 'free_power_scal_spline: powerscalar spline freed'
+     else
+        write(*,*) 'free_power_scal_spline: not powerscalar spline data allocated'
+     endif
+ 
+   end subroutine free_power_scal_spline
+ 
+ 
+ 
+ 
+   function check_power_tens_spline()
+     implicit none
+     logical :: check_power_tens_spline
+ 
+     check_power_tens_spline = (allocated(tensLnkmpcKnot) &
+          .or. allocated(tensPowerBcoef))
+ 
+   end function check_power_tens_spline
+ 
+ 
+ 
+ 
+   subroutine free_power_tens_spline()
+     implicit none
+ 
+     if (check_power_tens_spline()) then
+        deallocate(tensLnkmpcKnot)
+        deallocate(tensPowerBcoef)
+        if (display) write(*,*) 'free_power_tens_spline: powertensor spline freed'
+     else
+        write(*,*) 'free_power_tens_spline: not powertensor spline data allocated'
+     endif
+ 
+   end subroutine free_power_tens_spline
+ 
+ 
+ 
+ 
+   subroutine set_power_scal_spline(infCosmo,lnkmpcVec)
+     use bspline, only : dbsnak, dbsint
+     use inftorad, only : inftoradcosmo
+     use infpert, only : scalNum, power_spectrum_scal   
+     implicit none
+ 
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp), dimension(:), intent(in) :: lnkmpcVec
+     
+     real(kp), dimension(:), allocatable :: lnPowerScalTemp
+     real(kp), dimension(:), allocatable :: scalPowerBcoefTemp
+     real(kp), dimension(:,:,:), allocatable :: lnPowerScal
+     real(kp), dimension(scalNum,scalNum) :: powerScal
+     real(kp) :: kmpc
+     
+     integer :: i,j,k,lnkmpcNum
+ 
+     lnkmpcNum = size(lnkmpcVec,1)
+ 
+     scalOrder = 3
+     scalBcoefNum = lnkmpcNum
+     scalModeNum = scalNum
+     
+ !spline allocation
+     if (check_power_scal_spline()) then
+        write(*,*) 'set_power_scal_spline: spline already allocated'
+        stop
+     endif
+ 
+     allocate(scalLnkmpcKnot(lnkmpcNum + scalOrder))
+     allocate(scalPowerBcoef(scalBcoefNum,scalNum,scalNum))
+ 
+ !local
+     allocate(lnPowerScal(lnkmpcNum,scalNum,scalNum))
+ 
+     if (display) then
+        write(*,*)'set_power_scal_spline: computing knots'
+     endif
+ 
+ !$omp parallel do &
+ !$omp default(shared) &
+ !$omp private(i,kmpc,powerScal,j,k) &
+ !$omp schedule(dynamic)    
+     do i=1,lnkmpcNum       
+        kmpc = exp(lnkmpcVec(i))
+        powerScal = power_spectrum_scal(infCosmo,kmpc)
+        do k=1,scalNum
+           do j=1,scalNum
+              if (powerScal(j,k).eq.0._kp) then
+                 powerScal(j,k) = tiny(1.0_kp)             
+              endif
+              lnPowerScal(i,j,k) = log(powerScal(j,k))   
+           enddo
+        enddo
+     enddo
+ !$omp end parallel do    
+ 
+     if (display) then
+        write(*,*)'set_power_scal_spline: end computing knots'
+     endif
+ 
+     call dbsnak(lnkmpcNum,lnkmpcVec,scalOrder,scalLnkmpcKnot)
+ 
+ !to avoid race conditions    
+     allocate(scalPowerBcoefTemp(scalBcoefNum))
+     allocate(lnPowerScalTemp(lnkmpcNum))
+ 
+     do j=1,scalNum
+        do i=1,scalNum
+           lnPowerScalTemp(:) = lnPowerScal(:,i,j)
+           call dbsint(lnkmpcNum,lnkmpcVec,lnPowerScalTemp,scalOrder,scalLnkmpcKnot &
+                ,scalPowerBcoefTemp)
+           scalPowerBcoef(:,i,j) = scalPowerBcoefTemp(:)
+        enddo
+     enddo
+ 
+     deallocate(scalPowerBcoefTemp)
+     deallocate(lnPowerScalTemp)
+     deallocate(lnPowerScal)
+     
+ 
+   end subroutine set_power_scal_spline
+ 
+ 
+ 
+ 
+ 
+   subroutine set_power_tens_spline(infCosmo,lnkmpcVec)
+     use bspline, only : dbsnak, dbsint
+     use infbgmodel, only : fieldNum
+     use inftorad, only : inftoradcosmo
+     use infpert, only : scalNum, power_spectrum_tens   
+     implicit none
+ 
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp), dimension(:), intent(in) :: lnkmpcVec
+     
+     real(kp), dimension(:), allocatable :: lnPowerTens
+     real(kp) :: kmpc, powerTens
+     integer :: i,lnkmpcNum
+ 
+   
+     lnkmpcNum = size(lnkmpcVec,1)
+     tensOrder = 3
+     tensBcoefNum = lnkmpcNum
+     tensModeNum = 1
+     
+ !spline allocation
+     if (check_power_tens_spline()) then       
+        write(*,*) 'set_power_tens_spline: spline already allocated'
+        stop
+     endif
+ 
+     allocate(tensLnkmpcKnot(lnkmpcNum + tensOrder))
+     allocate(tensPowerBcoef(tensBcoefNum))
+    
+ !local
+     allocate(lnPowerTens(lnkmpcNum))
+ 
+     if (display) then
+        write(*,*)'set_power_tens_spline: computing knots'
+     endif
+ 
+ 
+ !$omp parallel do &
+ !$omp default(shared) &
+ !$omp private(i,kmpc,powerTens) &   
+ !$omp schedule(dynamic)
+     do i=1,lnkmpcNum       
+        kmpc = exp(lnkmpcVec(i))
+        powerTens = power_spectrum_tens(infCosmo,kmpc)
+        if (powerTens.eq.0._kp) then
+           powerTens = tiny(1.0_kp)
+        endif
+        lnPowerTens(i) = log(powerTens)     
+     enddo
+ !$omp end parallel do    
+ 
+     if (display) then
+        write(*,*)'set_power_scal_spline: end computing knots'
+     endif
+ 
+     call dbsnak(lnkmpcNum,lnkmpcVec,tensOrder,tensLnkmpcKnot)
+     
+     call dbsint(lnkmpcNum,lnkmpcVec,lnPowerTens,tensOrder,tensLnkmpcKnot &
+          ,tensPowerBcoef)
+ 
+     deallocate(lnPowerTens)
+     
+   end subroutine  set_power_tens_spline
+ 
+ 
+ 
+ 
+ 
+   function splineval_power_scal(kmpc)
+     use bspline, only : dbsval
+     implicit none
+     real(kp), intent(in) :: kmpc
+     real(kp), dimension(scalModeNum,scalModeNum) :: splineval_power_scal    
+     real(kp) :: lnkmpc
+     real(kp), dimension(:), allocatable :: scalPowerBcoefTemp
+     integer :: i,j
+ 
+     lnkmpc = log(kmpc)  
+ 
+ !avoid race condition
+     allocate(scalPowerBcoefTemp(scalBcoefNum))
+ 
+     do j=1,scalModeNum
+        do i=1,scalModeNum
+           scalPowerBcoefTemp = scalPowerBcoef(:,i,j)
+           splineval_power_scal(i,j) = exp(dbsval(lnkmpc,scalOrder,scalLnkmpcKnot &
+                ,scalBcoefNum,scalPowerBcoefTemp))
+        enddo
+     enddo
+ 
+     deallocate(scalPowerBcoefTemp)
+ 
+   end function splineval_power_scal
+ 
+ 
+ 
+ 
+   function splineval_power_tens(kmpc)
+     use bspline, only : dbsval
+     implicit none
+     real(kp), intent(in) :: kmpc
+     real(kp) :: splineval_power_tens   
+     real(kp) :: lnkmpc
+ 
+     lnkmpc = log(kmpc)
+ 
+     splineval_power_tens = exp(dbsval(lnkmpc,tensOrder,tensLnkmpcKnot &
+          ,tensBcoefNum,tensPowerBcoef))
+     
+   end function splineval_power_tens
+ 
+ 
+ 
+ end module infpowspline
diff -r -c -b -B -N cosmomc/fieldinf/infprec.f90 cosmomc_fields/fieldinf/infprec.f90
*** cosmomc/fieldinf/infprec.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infprec.f90	2010-07-05 16:34:59.000000000 +0200
***************
*** 0 ****
--- 1,34 ----
+ module infprec
+   implicit none
+ 
+   public
+ 
+ !quad precision
+ !  integer, parameter :: kp = kind(1.0_16)
+ 
+ !double precision
+   integer, parameter :: kp = kind(1.0_8)
+ 
+ !home made precision: p number of digit
+ ! integer, parameter :: kp = selected_real_kind(p=32)
+ 
+ !default integration accuracy
+   real(kp), parameter :: tolkp = 1.d-12
+ 
+ !workaround for passing argument to old f77 functions. Only pointer
+ !can be deferred shape in derived data type.
+ !Allows to stop integration from conditions coming from called
+ !functions (find the end of inflation)
+   type transfert
+      logical :: yesno1,yesno2, yesno3, yesno4
+      integer :: int1, int2, int3
+      real(kp) :: real1, real2, real3, real4, real5
+      real(kp), dimension(:), pointer :: ptrvector1 => null()
+      real(kp), dimension(:), pointer :: ptrvector2 => null()
+ !reserved
+      logical :: check,update
+      real(kp) :: xend
+   end type transfert
+ 
+ 
+ end module infprec
diff -r -c -b -B -N cosmomc/fieldinf/infsrmodel.F90 cosmomc_fields/fieldinf/infsrmodel.F90
*** cosmomc/fieldinf/infsrmodel.F90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/infsrmodel.F90	2010-07-05 16:08:42.000000000 +0200
***************
*** 0 ****
--- 1,1212 ----
+ !provides the slow-roll initial field values such that N e-folds of
+ !inflation occurs.
+ 
+ module infsrmodel
+   use infprec, only : kp
+   use infbgmodel, only : matterNum
+   implicit none
+ 
+   private
+ 
+   logical, parameter :: display = .true.
+   
+   integer, parameter :: efoldBound = 110._kp
+ 
+ 
+   public field_stopinf, field_thbound
+   public slowroll_initial_matter_lf, slowroll_initial_matter_sf
+   public slowroll_initial_matter_hy, slowroll_initial_matter_rm
+   public slowroll_initial_matter_kksf, slowroll_initial_matter_kklt
+   public slowroll_initial_matter_mix
+ 
+   public sr_efold_sf, sr_endinf_sf, sr_iniinf_sf
+   public sr_efold_kklt, sr_endinf_kklt, sr_iniinf_kklt
+   public sr_efold_rm, sr_iniinf_rm
+   public sr_efold_mix, sr_endinf_mix, sr_iniinf_mix
+ 
+ 
+ 
+  
+ 
+ 
+ 
+   
+ contains
+ 
+   
+ 
+   function field_stopinf(infParam)
+ !return the field stop value in (1) and if it is a maximum (+1) or
+ !minimum (-1) in (2)
+     use infbgmodel, only : infbgparam, matterParamNum
+     implicit none
+     type(infbgparam), intent(in) :: infParam    
+     real(kp), dimension(2) :: field_stopinf
+ 
+     
+     select case (infParam%name)
+ 
+     case ('largef')
+        field_stopinf(1) = infParam%consts(matterParamNum)
+        field_stopinf(2) = -1._kp
+    
+     case ('smallf')
+        field_stopinf(1) = infParam%consts(matterParamNum)*infParam%consts(3)
+        field_stopinf(2) = 1._kp
+ 
+     case ('hybrid')
+        field_stopinf(1) = infParam%consts(matterParamNum) &
+             * slowroll_stopmax_matter_hy(infParam)
+        field_stopinf(2) = -1._kp
+        
+     case ('runmas')
+ 
+        field_stopinf(1) = infParam%consts(matterParamNum)
+ !for nu>0
+        if (infParam%consts(matterParamNum).lt.infParam%consts(3)) then
+           field_stopinf(2) = -1._kp
+        else
+           field_stopinf(2) = +1._kp
+        endif
+ !reverse if nu<0
+        if (infParam%consts(4).lt.0._kp) then
+           field_stopinf(2) = -field_stopinf(2)
+        endif
+ 
+     case ('kklmmt')
+        field_stopinf(1) = infParam%consts(matterParamNum)*infParam%consts(3)
+        field_stopinf(2) = -1._kp
+        print *, 'fieldStop = infParam(matterParamNum)'
+ 
+     case ('mixinf')
+        field_stopinf(1) = infParam%consts(matterParamNum)
+        field_stopinf(2) = -1._kp
+ 
+ 
+     end select
+ 
+     
+ 
+   end function field_stopinf
+ 
+ 
+ 
+   function field_thbound(infParam)
+ !returns a theoretical bound on the allowed field values if any. May be
+ !from the stochastic regime or uv limit in brane setup
+     use infbgmodel, only : infbgparam, matterParamNum
+     implicit none
+     type(infbgparam), intent(in) :: infParam    
+     real(kp), dimension(2) :: field_thbound
+ 
+     
+     select case (infParam%name)
+ 
+     case ('kklmmt')
+        field_thbound(1) = infParam%consts(matterParamNum-1)
+        field_thbound(2) = +1._kp
+        print *, 'fieldUv = infParam%consts(matterParamNum-1)'
+ 
+     case default
+        stop 'no theoretical field bound implemented for this model!'
+ 
+     end select
+ 
+   end function field_thbound
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !large field models
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function slowroll_initial_matter_lf(infParam,efoldWanted)   
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_lf
+     
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp) :: matterEnd, matterIni
+     real(kp) :: p,mu,efold
+ 
+ 
+     if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+   
+     mu = infParam%consts(3)
+     if (mu.ne.0._kp) stop 'slowroll_initial_matter_lf: improper parameters'
+        
+ 
+     p = infParam%consts(2)
+    
+     matterEnd = p/sqrt(2._kp)
+    
+     matterIni = sqrt(p**2/2._kp + 2._kp*p*efold)
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_lf: (*kappa)'
+        write(*,*)'matterEnd = ',matterEnd
+        write(*,*)'matterIni = ',matterIni
+        write(*,*)
+     endif
+ 
+     slowroll_initial_matter_lf = matterIni
+ 
+   end function slowroll_initial_matter_lf
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !small field models
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function slowroll_initial_matter_sf(infParam,efoldWanted)
+     use infprec, only : transfert,tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_sf
+ 
+     type(transfert) :: sfData
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp), parameter :: tolFind = tolkp
+     
+     
+     real(kp) :: matterOverMuEnd, matterOverMuIni
+     real(kp) :: mini,maxi
+     real(kp) :: p, mu, efold
+ 
+   
+     p = infParam%consts(2)    
+     mu = infParam%consts(3)
+ 
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_initial_matter_sf: improper parameters'
+     endif
+    
+ 
+     if (p.lt.2._kp) then
+        write(*,*) 'slowroll_initial_matter_sf: p = ',p
+        stop
+     endif
+ 
+      if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+ 
+ !find the end of inflation
+       
+     mini = epsilon(1._kp)
+     maxi = 1._kp + epsilon(1._kp)
+ 
+     sfData%real1 = p
+     sfData%real2 = mu
+ 
+     matterOverMuEnd = zbrent(sr_endinf_sf,mini,maxi,tolFind,sfData)
+    
+ 
+ 
+ !find the initial field values efolds before
+ 
+     mini = epsilon(1._kp)
+     maxi = matterOverMuEnd
+ 
+     sfData%real1 = p
+     sfData%real2 = 2._kp*p*efold/mu**2 + sr_efold_sf(matterOverMuEnd,p)
+     
+ 
+     matterOverMuIni = zbrent(sr_iniinf_sf,mini,maxi,tolFind,sfData)
+     
+     slowroll_initial_matter_sf = matterOverMuIni*mu
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_sf: (*kappa) (/mu)'
+        write(*,*)'matterEnd = ',matterOverMuEnd*mu,matterOverMuEnd
+        write(*,*)'matterIni = ',matterOverMuIni*mu,matterOverMuIni
+        write(*,*)
+     endif
+ 
+ 
+   end function slowroll_initial_matter_sf
+ 
+ 
+ 
+ 
+   function sr_endinf_sf(x,sfData)
+     use infprec, only : transfert    
+     implicit none
+     real(kp), intent(in) :: x    
+     type(transfert), optional, intent(inout) :: sfData
+     real(kp) :: sr_endinf_sf
+     real(kp) :: p,mu
+ 
+     p=sfData%real1
+     mu=sfData%real2
+ 
+     sr_endinf_sf = x**(p-1._kp) + sqrt(2._kp)*mu/abs(p) * (x**p - 1._kp)
+ 
+   end function sr_endinf_sf
+  
+ 
+ 
+ 
+   function sr_iniinf_sf(x,sfData)
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: x   
+     type(transfert), optional, intent(inout) :: sfData
+     real(kp) :: sr_iniinf_sf
+     real(kp) :: p
+ 
+     p=sfData%real1
+ 
+     sr_iniinf_sf = sr_efold_sf(x,p) - sfData%real2
+    
+   end function sr_iniinf_sf
+ 
+ 
+ 
+ 
+   function sr_efold_sf(x,p)
+     implicit none
+     real(kp), intent(in) :: x,p
+     real(kp) :: sr_efold_sf
+     
+     if (p == 2._kp) then
+        sr_efold_sf = x**2 - 2._kp * log(x)
+     else
+        sr_efold_sf = x**2 + 2._kp/(p-2._kp) * x**(2._kp-p)
+     endif
+     
+   end function sr_efold_sf
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !kklmmt
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ !some function call the small field ones since kklmmt potential looks
+ !like the small field ones with p->-p
+ 
+ 
+   function slowroll_initial_matter_kksf(infParam,efoldWanted)
+    use infprec, only : transfert,tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_kksf
+ 
+     type(transfert) :: sfData
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp), parameter :: tolFind = tolkp
+     
+     
+     real(kp) :: matterOverMuEnd, matterOverMuIni
+     real(kp) :: mini,maxi
+     real(kp) :: p, mu, efold
+ 
+   
+     p = infParam%consts(2)    
+     mu = infParam%consts(3)
+ 
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_initial_matter_kksf: improper parameters'
+     endif
+    
+ 
+     if (p.lt.0._kp) then
+        write(*,*) 'slowroll_initial_matter_kksf: p = ',p
+        stop
+     endif
+ 
+      if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+ 
+ !find the end of inflation
+       
+     mini = 1._kp + epsilon(1._kp)
+     maxi = 1._kp/epsilon(1._kp)
+ 
+     sfData%real1 = -p
+     sfData%real2 = mu
+ 
+     matterOverMuEnd = zbrent(sr_endinf_sf,mini,maxi,tolFind,sfData)
+    
+ 
+ 
+ !find the initial field values efolds before
+ 
+     mini = matterOverMuEnd
+     maxi = 1._kp/epsilon(1._kp)
+ 
+     sfData%real1 = -p
+     sfData%real2 = 2._kp*(-p)*efold/mu**2 + sr_efold_sf(matterOverMuEnd,-p)
+     
+ 
+     matterOverMuIni = zbrent(sr_iniinf_sf,mini,maxi,tolFind,sfData)
+     
+     slowroll_initial_matter_kksf = matterOverMuIni*mu
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_kksf: (*kappa) (/mu)'
+        write(*,*)'matterEnd = ',matterOverMuEnd*mu,matterOverMuEnd
+        write(*,*)'matterIni = ',matterOverMuIni*mu,matterOverMuIni
+        write(*,*)
+     endif
+ 
+ 
+   end function slowroll_initial_matter_kksf
+ 
+ 
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !hybrid models
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+ 
+   function slowroll_initial_matter_hy(infParam,efoldWanted)
+     use infprec, only : transfert, tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam, matterParamNum
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_hy
+ 
+     type(transfert) :: hyData
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp), parameter :: tolFind = tolkp
+     
+     real(kp), dimension(2) :: fieldStop
+     real(kp) :: matterOverMuMax, matterOverMuIni, matterOverMuStop
+     real(kp) :: mini,maxi
+     real(kp) :: p, mu
+     real(kp) :: muConnex, efold
+ 
+   
+     p = infParam%consts(2)
+     mu = infParam%consts(3)
+ 
+ !sanity checks
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_initial_matter_hy: improper consts(3)'
+     endif
+ 
+     if (p.lt.2._kp) then
+        write(*,*) 'slowroll_initial_matter_hy: p = ',p
+        stop
+     endif
+ 
+     if (infParam%consts(matterParamNum).gt.1._kp) then
+        stop 'slowroll_initial_matter_hy: improper consts(5)'
+     endif
+ 
+ 
+     if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+ 
+ 
+ !determines the maximum allowed field value to stop hybrid inflation
+ !(see the called function)
+ !    matterOverMuStopMax = slowroll_stopmax_matter_hy(infParam) / mu
+ 
+ !for hybrid inflation, it assumes that consts(matparamnum) is in unit of
+ !mattertopMax
+     fieldStop = field_stopinf(infParam)
+     matterOverMuStop = fieldStop(1) / mu
+   
+ 
+ !upper field value bound
+     matterOverMuMax = slowroll_startmax_matter_hy(infParam)
+ 
+ 
+ !find matterIni otherwise to get the right number of efolds
+ 
+     mini = matterOverMuStop
+     maxi = matterOverMuMax
+ 
+     hyData%real1 = p
+     hyData%real2 = 2._kp*p*(efold)/mu**2 + sr_efold_hy(matterOverMuStop,p)
+ 
+     matterOverMuIni =  zbrent(sr_iniinf_hy,mini,maxi,tolFind,hyData)
+ 
+     slowroll_initial_matter_hy = matterOverMuIni * mu
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_hy: (*kappa) (/mu)'       
+        write(*,*)'matterStop = ',matterOverMuStop*mu, matterOverMuStop  
+        write(*,*)'matterIni  = ',matterOverMuIni*mu, matterOverMuIni
+        write(*,*)
+     endif
+ 
+ 
+   end function slowroll_initial_matter_hy
+ 
+ 
+ 
+ 
+ 
+   function slowroll_stopmax_matter_hy(infParam)
+     use infprec, only : transfert,tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp) :: slowroll_stopmax_matter_hy
+     
+     real(kp), parameter :: efoldHybrid = efoldBound
+ 
+     real(kp), parameter :: tolFind = tolkp
+     type(transfert) :: hyData
+     real(kp) :: p,mu, mini,maxi
+     real(kp) :: matterOverMuMax, matterOverMuStopMax
+ 
+     p = infParam%consts(2)
+     mu = infParam%consts(3)
+ 
+ !sanity checks
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_stopmax_matter_hy: improper consts(3)'
+     endif
+ 
+     if (p.lt.2._kp) then
+        write(*,*) 'slowroll_stopmax_matter_hy: p = ',p
+        stop
+     endif
+ 
+     matterOverMuMax = slowroll_startmax_matter_hy(infParam)/mu
+ 
+ !MatterStopMax is the zero of the sr evolution equation with N --> -N
+ !and set to efoldHybrid.
+ 
+     mini = epsilon(1._kp)
+     maxi = matterOverMuMax
+ 
+     hyData%real1 = p
+     hyData%real2 = -2._kp*p*(efoldHybrid)/mu**2 + sr_efold_hy(matterOverMuMax,p) 
+    
+     matterOverMuStopMax = zbrent(sr_iniinf_hy,mini,maxi,tolFind,hyData)
+ 
+ !return the field value, in unit of kappa
+     slowroll_stopmax_matter_hy = matterOverMuStopMax * mu
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_matter_stopmax_hy: (*kappa) (/mu)'
+        write(*,*)'efold definition = ',efoldHybrid
+        write(*,*)'matterStopMax = ',matterOverMuStopMax*mu, matterOverMuStopMax      
+        write(*,*)
+     endif        
+ 
+   end function slowroll_stopmax_matter_hy
+ 
+ 
+ 
+ 
+ 
+ 
+   function slowroll_startmax_matter_hy(infParam)
+     use infprec, only : transfert,tolkp
+     use inftools, only : zbrent
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp) :: slowroll_startmax_matter_hy
+ 
+     real(kp), parameter :: tolFind = tolkp
+     type(transfert) :: hyData
+     real(kp) :: p,mu,mini,maxi, muConnex
+     real(kp) :: matterOverMuTrans, matterOverMuMax
+ 
+     p = infParam%consts(2)
+     mu = infParam%consts(3)
+ 
+ !sanity checks
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_startmax_matter_hy: improper consts(3)'
+     endif
+ 
+     if (p.lt.2._kp) then
+        write(*,*) 'slowroll_startmax_matter_hy: p = ',p
+        stop
+     endif
+ 
+ 
+ !this is the mu above which eps1 = 1 has no solution and for which
+ !inflationary domains in field space are simply connected
+     muConnex = p/sqrt(8._kp)
+ 
+ !this is the matter/mu for which eps1 is maximum. eps1(matter) is a
+ !increasing function wrt the field under this value, and decreasing
+ !above. So hybrid like behaviour only appears for matter <
+ !matterTrans.  Otherwise, this is a mixture between large field like
+ !and hybrid inflation during which the sign of eps2 changes
+     matterOverMuTrans = (p - 1._kp)**(1._kp/p)
+ 
+     
+ !We are looking to the maximum allowed value of the field to stop
+ !inflation and to get at least "efoldHybrid" efolds of inflation. Here
+ !we discard the case where inflation may start for matterIni >
+ !matterTrans since it would be large field like inflation. So the
+ !ultimate upper limit for matterIni, defined as matterMax, is the
+ !min(matterTrans,matterOne) where eps1(matterOne) = 1. MatterOne is
+ !seeked in [0,matterTrans]: this selects only the lower root, the
+ !other corresponding to the end of a large field like inflation)
+     mini = epsilon(1._kp)
+     maxi = matterOverMuTrans
+ 
+     hyData%real1 = p
+     hyData%real2 = mu
+ 
+     if (mu.le.muConnex) then
+        matterOverMuMax = zbrent(sr_endinf_hy,mini,maxi,tolFind,hyData)
+     else
+        matterOverMuMax = matterOverMuTrans
+     endif
+ 
+     slowroll_startmax_matter_hy = matterOverMuMax * mu
+     
+     if (display) then
+        write(*,*)'slowroll_startmax_matter_hy: (*kappa) (/mu)'
+        write(*,*)'matterMax = ',matterOverMuMax*mu,matterOverMuMax
+        if (mu.lt.muConnex) then
+           write(*,*) '<--- due to epsilon1 > 1 above'
+        else
+           write(*,*) '<--- due to epsilon2 > 0 above'
+        endif
+     endif
+ 
+   end function slowroll_startmax_matter_hy
+ 
+ 
+ 
+   function sr_endinf_hy(x,hyData)
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: x    
+     type(transfert), optional, intent(inout) :: hyData
+     real(kp) :: sr_endinf_hy
+     real(kp) :: p,mu
+ 
+     p=hyData%real1
+     mu=hyData%real2
+ 
+     sr_endinf_hy = x**(p-1._kp) - sqrt(2._kp)*mu/p * (x**p + 1._kp)
+ 
+   end function sr_endinf_hy
+ 
+ 
+ 
+ 
+   function sr_iniinf_hy(x,hyData)
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: x   
+     type(transfert), optional, intent(inout) :: hyData
+     real(kp) :: sr_iniinf_hy
+     real(kp) :: p
+ 
+     p=hyData%real1
+   
+     sr_iniinf_hy = sr_efold_hy(x,p) - hyData%real2
+    
+   end function sr_iniinf_hy
+ 
+ 
+ 
+ 
+   function sr_efold_hy(x,p)
+     implicit none
+     real(kp), intent(in) :: x,p
+     real(kp) :: sr_efold_hy
+ 
+     if (p == 2._kp) then
+        sr_efold_hy = x**2 + 2._kp * log(x)
+     else
+        sr_efold_hy = x**2 - 2._kp/(p-2._kp) * x**(2._kp-p)
+     endif
+ 
+ 
+   end function sr_efold_hy
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !running mass models
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+ 
+   function slowroll_initial_matter_rm(infParam,efoldWanted)
+     use infprec, only : transfert, tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_rm
+ 
+     type(transfert) :: rmData
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp), parameter :: tolFind = tolkp
+ 
+     real(kp) :: efold
+     real(kp) :: mini,maxi,randnum
+     real(kp) :: p,mu,nu,lambda
+     real(kp) :: matterOverMuStop,matterStop,matterEnd,matterIni
+     real(kp) :: matterZero
+     real(kp), dimension(2) :: fieldStop
+ 
+ !should match with the definition of consts!
+     p = infParam%consts(2)
+     mu = infParam%consts(3)
+     nu = infParam%consts(4)
+ 
+ !sanity checks
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_initial_matter_rm: improper consts(3)'
+     endif
+ 
+     if (p.lt.2._kp) then
+        write(*,*) 'slowroll_initial_matter_rm: p = ',p
+        stop
+     endif
+ 
+     if ((abs(infParam%consts(4)).gt.0.5_kp).or.(infParam%consts(4).eq.0._kp)) then
+        write(*,*)'slowroll_initial_matter_rm: improper consts(4) = ',infParam%consts(4)
+        read(*,*)
+     endif
+     
+     lambda = nu * mu**p
+ 
+     if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+ 
+ 
+ 
+ !the potential is
+ ! U = M^4 { 1 + nu*[1/p - ln(matter/mu)]*matter^p}
+ 
+ 
+ !matterstop required
+     fieldStop = field_stopinf(infParam)
+     matterStop = fieldStop(1)
+ 
+ 
+     
+ !for nu>0 there is matterEnd such as eps1(matterEnd) = 1. So the end
+ !of inflation in that case is either given by matterEnd or by
+ !matterStop. Note however that eps2 is usually big in that case which
+ !makes this calculation useless DAMNED!!. The eps1=1 eq has
+ !one solution only in [mu,matterZero] where U(matterZero) = 0
+     if ((nu.gt.0._kp).and.(matterStop.gt.mu)) then
+        mini = mu + epsilon(1._kp)
+        maxi = 1._kp/epsilon(1._kp)
+ 
+        rmData%real1 = p
+        rmData%real2 = mu
+        rmData%real3 = nu              
+ 
+        matterZero = zbrent(rm_potential,mini,maxi,tolFind,rmData)
+ 
+        mini = mu
+        maxi = matterZero
+ 
+        rmData%real1 = p
+        rmData%real2 = mu
+        rmData%real3 = nu
+ 
+        matterEnd = zbrent(sr_endinf_rm,mini,maxi,tolFind,rmData)
+     
+        if (display) then
+           if (matterEnd.lt.matterStop) then
+              write(*,*)'slowroll_initial_matter_rm: epsilon1 stops inflation in SR approx'
+           endif
+        endif
+ 
+ !useless       matterStop = min(matterStop,matterEnd)
+     endif
+ 
+ 
+ !find matterIni according to matterStop to get the right number of
+ !efolds. The choice between the 4 models is done according to the
+ !value of matterStop. matterIni>1 has been allowed for RM4, with still
+ !matterStop < 1
+    
+     if (matterStop.eq.mu) then       
+        write(*,*)'slowroll_initial_matter_rm: matterStop/mu = ',matterStop/mu
+        stop
+     endif
+ 
+     if (matterStop.lt.mu) then
+        mini = epsilon(1._kp)
+        maxi = mu - epsilon(1._kp)
+     elseif (matterStop.gt.mu) then
+        mini = mu + epsilon(1._kp)
+        if (nu.gt.0._kp) then
+           maxi = 1._kp
+        else
+           maxi = 1._kp/epsilon(1._kp)
+        endif
+     else
+        stop 'slowroll_initial_matter_rm: error'
+     endif
+ 
+      matterOverMuStop = matterStop/mu
+     
+ !    print *,'mini maxi',mini,maxi
+ 
+     rmData%real1 = p
+     rmData%real2 = mu
+     rmData%real3 = nu
+     rmData%xend = sr_efold_rm(matterOverMuStop,p,lambda) + 2._kp*p*efold/mu**2
+ 
+     matterIni =  zbrent(sr_iniinf_rm,mini,maxi,tolFind,rmData)
+ 
+     slowroll_initial_matter_rm = matterIni
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_rm: (*kappa)'       
+        write(*,*)'matterZero = ',matterZero
+        write(*,*)'matterEnd  = ',matterEnd
+        write(*,*)'matterStop = ',matterStop  
+        write(*,*)'matterIni  = ',matterIni
+        write(*,*)
+     endif
+ 
+ 
+   end function slowroll_initial_matter_rm
+ 
+ 
+ 
+ 
+   function sr_efold_rm(x,p,l)
+     use specialinf, only : dp, dei
+     implicit none
+     real(kp), intent(in) :: x,p,l
+     real(kp) :: sr_efold_rm
+     real(dp) :: argei1,argei2
+ 
+ !l=nu*mu^p
+     
+     if (p == 2._kp) then
+        argei1 = 2._dp*log(x)
+        sr_efold_rm = x**2 - (2._kp/l)*log(abs(log(x))) - dei(argei1)
+     else
+        argei1 = (2._dp-p)*log(x)
+        argei2 = 2._dp*log(x)
+        sr_efold_rm = x**2 - (2._kp/l)*dei(argei1) - (2._kp/p)*dei(argei2)       
+     endif
+     
+ !    print *,'arg ei',argei1,dei(argei1)
+ 
+   end function sr_efold_rm
+ 
+ 
+ 
+ 
+   function sr_endinf_rm(matter,rmData)
+ !vanishes for eps1=1 in the sr approx
+     use infprec, only : transfert    
+     implicit none
+     real(kp), intent(in) :: matter    
+     type(transfert), optional, intent(inout) :: rmData
+     real(kp) :: sr_endinf_rm
+     real(kp) :: p,mu,nu,x
+ 
+     p=rmData%real1
+     mu=rmData%real2
+     nu=rmData%real3
+ 
+     x = matter/mu
+    
+     sr_endinf_rm = 1._kp + nu*(1._kp/p - log(x))*matter**p &
+          - (nu*p/sqrt(2._kp))*log(x)*matter**(p-1._kp)
+ 
+   end function sr_endinf_rm
+  
+ 
+ 
+ 
+ 
+   function sr_iniinf_rm(matter,rmData)
+     use infprec, only : transfert    
+     implicit none
+     real(kp), intent(in) :: matter    
+     type(transfert), optional, intent(inout) :: rmData
+     real(kp) :: sr_iniinf_rm
+     real(kp) :: p,mu,nu,x,l
+ 
+     p=rmData%real1
+     mu=rmData%real2
+     nu=rmData%real3
+ 
+     x = matter/mu
+     l = nu * mu**p
+ 
+     sr_iniinf_rm = sr_efold_rm(x,p,l) - rmData%xend
+ 
+   end function sr_iniinf_rm
+  
+ 
+ 
+   function rm_potential(matter,rmData)
+     use infprec, only : transfert    
+     implicit none
+     real(kp), intent(in) :: matter    
+     type(transfert), optional, intent(inout) :: rmData
+     real(kp) :: rm_potential
+     real(kp) :: p,mu,nu,x
+ 
+     p=rmData%real1
+     mu=rmData%real2
+     nu=rmData%real3
+ 
+     x = matter/mu
+     
+     rm_potential = 1._kp + nu*(1._kp/p - log(x))*matter**p
+ 
+   end function rm_potential
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !kklmmt models with m2=0: V = M^4 / [1 + (mu/phi)^p]
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+   function slowroll_initial_matter_kklt(infParam,efoldWanted)
+     use infprec, only : transfert, tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam, matterParamNum
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_kklt
+ 
+     type(transfert) :: kkltData
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp), parameter :: tolFind = tolkp
+     
+     real(kp), dimension(2) :: fieldStop, fieldUv
+     real(kp) :: matterOverMuUv, matterOverMuString
+     real(kp) :: matterOverMuEps, matterOverMuIni, matterOverMuEnd
+     real(kp) :: mini,maxi
+     real(kp) :: p, mu
+     real(kp) :: efold
+ 
+   
+     p = infParam%consts(2)
+     mu = infParam%consts(3)
+ 
+ !sanity checks
+     if (infParam%consts(3).le.0._kp) then
+        stop 'slowroll_initial_matter_kklt: improper consts(3)'
+     endif
+ 
+     if (p.lt.2._kp) then
+        write(*,*) 'slowroll_initial_matter_kklt: p = ',p
+        stop
+     endif
+ 
+     if (infParam%consts(5).ne.-1._kp) then
+        stop 'slowroll_initial_matter_kklt: improper consts(5)'
+     endif
+ 
+ 
+     if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+ 
+ 
+ !upper field value bound
+     fieldUv = field_thbound(infParam)
+     matterOverMuUv = fieldUv(1)/mu
+ 
+ 
+ !inflation stops at matterOverMuEps1 (its determination is no accurate
+ !since eps2>1 in that region, but the number of efold in between is
+ !small. This condition could be replaced by matterOverMuEps2 as well
+ 
+     mini = 0._kp
+     maxi = 1._kp/epsilon(1._kp)
+ 
+     kkltData%real1 = p
+     kkltData%real2 = mu
+ 
+     matterOverMuEps = zbrent(sr_endinf_kklt,mini,maxi,tolFind,kkltData)
+ 
+ 
+ !the branes collide at matterString
+     fieldStop = field_stopinf(infParam)
+     matterOverMuString = fieldStop(1)/mu
+   
+     if (matterOverMuString.lt.1.) then
+        write(*,*)'slowroll_initial_matter_kklt: matterOverMuString < mu'
+     endif
+ 
+ 
+     matterOverMuEnd = max(matterOverMuString,MatterOverMuEps)
+ 
+ 
+     if (matterOverMuEnd.gt.matterOverMuUv) then
+        write(*,*)'slowroll_initial_matter_kklt: matterOverMuEnd > matterOverMuUv'
+     endif
+ 
+ !find matterIni that gives the wanted number of efolds
+ 
+     mini = 0._kp
+     maxi = 1._kp/epsilon(1._kp)
+ 
+     kkltData%real1 = p
+     kkltData%real2 = p*(efold)/mu**2 + sr_efold_kklt(matterOverMuEnd,p)
+ 
+     matterOverMuIni =  zbrent(sr_iniinf_kklt,mini,maxi,tolFind,kkltData)
+ 
+     slowroll_initial_matter_kklt = matterOverMuIni * mu
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_kklt: (*kappa) (/mu)'       
+        write(*,*)'matterEnd = ',matterOverMuEnd*mu, matterOverMuEnd
+        write(*,*)'matterString  = ',matterOverMuString*mu, matterOverMuString
+        write(*,*)'matterEps  = ',matterOverMuEps*mu, matterOverMuEps
+        write(*,*)'matterIni  = ',matterOverMuIni*mu, matterOverMuIni
+        write(*,*)'matterUv  = ',matterOverMuUv*mu, matterOverMuUv
+        write(*,*)
+     endif
+ 
+ 
+   end function slowroll_initial_matter_kklt
+ 
+ 
+ 
+ 
+   function sr_endinf_kklt(x,kkltData)
+     use infprec, only : transfert    
+     implicit none
+     real(kp), intent(in) :: x    
+     type(transfert), optional, intent(inout) :: kkltData
+     logical, parameter :: endinfIsEpsOne=.true.
+     real(kp) :: sr_endinf_kklt
+     real(kp) :: p,mu
+ 
+     p=kkltData%real1
+     mu=kkltData%real2
+ 
+     if (endinfIsEpsOne) then
+ !epsilon1=1
+        sr_endinf_kklt = x**(p+1._kp) + x - p/(mu*sqrt(2._kp))
+     else
+ !epsilon2=1
+        sr_endinf_kklt = (x**(p+1._kp) + x)**2 - (2._kp*p/mu/mu) &
+             *( (p+1._kp)*x**p + 1._kp)
+     endif
+ 
+   end function sr_endinf_kklt
+  
+ 
+ 
+ 
+   function sr_iniinf_kklt(x,kkltData)
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: x   
+     type(transfert), optional, intent(inout) :: kkltData
+     real(kp) :: sr_iniinf_kklt
+     real(kp) :: p
+ 
+     p=kkltData%real1
+ 
+     sr_iniinf_kklt =  sr_efold_kklt(x,p) - kkltData%real2
+    
+   end function sr_iniinf_kklt
+ 
+ 
+ 
+ 
+   function sr_efold_kklt(x,p)
+     implicit none
+     real(kp), intent(in) :: x,p
+     real(kp) :: sr_efold_kklt
+     
+     sr_efold_kklt = 0.5_kp*x**2 + x**(p+2._kp)/(p+2._kp)
+ 
+     
+   end function sr_efold_kklt
+ 
+ 
+ 
+ 
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !mixed inflation M^4( phi^p + alpha phi^q)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+ 
+   function slowroll_initial_matter_mix(infParam,efoldWanted)
+     use infprec, only : transfert,tolkp
+     use inftools, only : zbrent    
+     use infbgmodel, only : infbgparam
+     implicit none
+     type(infbgparam), intent(in) :: infParam
+     real(kp), optional, intent(in) :: efoldWanted
+     real(kp), dimension(matterNum) :: slowroll_initial_matter_mix
+ 
+     type(transfert) :: mixData
+     real(kp), parameter :: efoldDefault = efoldBound
+     real(kp), parameter :: tolFind = tolkp
+     
+     
+     real(kp) :: matterEnd, matterIni
+     real(kp) :: mini,maxi
+     real(kp) :: alpha, efold, p, q
+         
+ #ifndef PP5
+     p = infParam%consts(2)    
+     q = infParam%consts(12)
+     alpha = infParam%consts(6)
+ #else
+     stop 'slowroll_initial_matter_mix: check potParamNum value!'
+ #endif
+    
+           
+     if (alpha.lt.0._kp) then
+        stop 'mixed inflation: infParam%consts(6) < 0!'
+     endif
+ 
+     if (present(efoldWanted)) then
+        efold = efoldWanted
+     else
+        efold = efoldDefault
+     endif
+ 
+ !find the end of inflation
+       
+     mini = epsilon(1._kp)
+     maxi = 1._kp/epsilon(1._kp)
+ 
+     mixData%real1 = p
+     mixData%real2 = q
+     mixData%real3 = alpha
+ 
+     matterEnd = zbrent(sr_endinf_mix,mini,maxi,tolFind,mixData)
+    
+ 
+ 
+ !find the initial field values efolds before
+ 
+     mini = matterEnd - epsilon(1._kp)
+     maxi = 1._kp/epsilon(1._kp)
+ 
+     mixData%real1 = p
+     mixData%real2 = q
+     mixData%real3 = alpha
+     mixData%real4 = efold + sr_efold_mix(matterEnd,p,q,alpha)
+     
+     matterIni = zbrent(sr_iniinf_mix,mini,maxi,tolFind,mixData)
+     
+     slowroll_initial_matter_mix = matterIni
+ 
+     if (display) then
+        write(*,*)
+        write(*,*)'slowroll_initial_matter_mix: (*kappa)'
+        write(*,*)'matterEnd = ',matterEnd
+        write(*,*)'matterIni = ',matterIni
+        write(*,*)
+     endif
+ 
+ 
+   end function slowroll_initial_matter_mix
+ 
+ 
+ 
+ 
+   function sr_endinf_mix(x,mixData)
+     use infprec, only : transfert    
+     implicit none
+     real(kp), intent(in) :: x    
+     type(transfert), optional, intent(inout) :: mixData
+     real(kp) :: sr_endinf_mix
+     real(kp) :: p,q,alpha
+ 
+     p=mixData%real1
+     q=mixData%real2
+     alpha=mixData%real3
+ 
+     sr_endinf_mix = alpha*sqrt(2._kp)*x**(q-p+1._kp) - alpha*q*x**(q-p) &
+          + sqrt(2._kp)*x - p
+ 
+   end function sr_endinf_mix
+  
+ 
+ 
+ 
+   function sr_iniinf_mix(x,mixData)
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: x   
+     type(transfert), optional, intent(inout) :: mixData
+     real(kp) :: sr_iniinf_mix
+     real(kp) :: p,q,alpha
+ 
+     p=mixData%real1
+     q=mixData%real2
+     alpha=mixData%real3
+ 
+     sr_iniinf_mix = sr_efold_mix(x,p,q,alpha) - mixData%real4
+    
+   end function sr_iniinf_mix
+ 
+ 
+   function sr_efold_mix(x,p,q,alpha)
+     use specialinf, only : hypergeom_2F1
+     implicit none
+     real(kp), intent(in) :: x,p,q,alpha
+     real(kp) :: sr_efold_mix
+     
+     sr_efold_mix = 0.5_kp*x**2/(p*q)*(p + (q-p) &
+          *hypergeom_2F1(1._kp,2._kp/(q-p),1._kp + 2._kp/(q-p),-alpha*q*x**(q-p)/p))
+     
+   end function sr_efold_mix
+ 
+ 
+ end module infsrmodel
diff -r -c -b -B -N cosmomc/fieldinf/inftools.f90 cosmomc_fields/fieldinf/inftools.f90
*** cosmomc/fieldinf/inftools.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/inftools.f90	2010-08-25 14:32:42.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), intent(in) :: x
+            type(transfert), optional, intent(inout) :: otherdata
+          end function func
+       end interface
+ 
+       notbracketed = .true.
+       iex = 0
+ 
+       a=x1
+       b=x2      
+ 
+       do while (notbracketed.and.(iex.lt.iexmax))
+          fa=func(a,extradata)
+          fb=func(b,extradata)
+          if((fa.gt.0..and.fb.gt.0.).or.(fa.lt.0..and.fb.lt.0.)) then
+             write(*,*)'x1= fa= ',a,fa
+             write(*,*)'x2= fb= ',b,fb            
+             write(*,*)'zbrent: expanding interval!'
+             a = a - abs(a)*tolExpand
+             b = b + abs(b)*tolExpand
+             iex = iex + 1
+             notbracketed = .true.
+          else
+             notbracketed = .false.
+          endif
+       enddo
+ 
+       if (notbracketed) stop 'root must be bracketed for zbrent'
+ 
+       c=b
+       fc=fb
+       do iter=1,ITMAX
+         if((fb.gt.0..and.fc.gt.0.).or.(fb.lt.0..and.fc.lt.0.))then
+           c=a
+           fc=fa
+           d=b-a
+           e=d
+         endif
+         if(abs(fc).lt.abs(fb)) then
+           a=b
+           b=c
+           c=a
+           fa=fb
+           fb=fc
+           fc=fa
+         endif
+         tol1=2.*EPS*abs(b)+0.5*tol
+         xm=.5*(c-b)
+         if(abs(xm).le.tol1 .or. fb.eq.0.)then
+           zbrent=b
+           return
+         endif
+         if(abs(e).ge.tol1 .and. abs(fa).gt.abs(fb)) then
+           s=fb/fa
+           if(a.eq.c) then
+             p=2.*xm*s
+             q=1.-s
+           else
+             q=fa/fc
+             r=fb/fc
+             p=s*(2.*xm*q*(q-r)-(b-a)*(r-1.))
+             q=(q-1.)*(r-1.)*(s-1.)
+           endif
+           if(p.gt.0.) q=-q
+           p=abs(p)
+           if(2.*p .lt. min(3.*xm*q-abs(tol1*q),abs(e*q))) then
+             e=d
+             d=p/q
+           else
+             d=xm
+             e=d
+           endif
+         else
+           d=xm
+           e=d
+         endif
+         a=b
+         fa=fb
+         if(abs(d) .gt. tol1) then
+           b=b+d
+         else
+           b=b+sign(tol1,xm)
+         endif
+         fb=func(b,extradata)
+      enddo
+      stop 'zbrent exceeding maximum iterations'
+      zbrent=b
+      return
+    end function zbrent
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+  end module inftools
+ 
+ 
diff -r -c -b -B -N cosmomc/fieldinf/inftools.h cosmomc_fields/fieldinf/inftools.h
*** cosmomc/fieldinf/inftools.h	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/inftools.h	2006-04-14 19:40:52.000000000 +0200
***************
*** 0 ****
--- 1,11 ----
+   interface
+      subroutine fcn(n, x, y, yprime, otherdata)
+        use infprec, only : kp,transfert         
+        implicit none          
+        integer :: n
+        real(kp) :: x
+        real(kp), dimension(n) :: y, yprime
+        type(transfert), optional, intent(inout) :: otherdata
+      end subroutine fcn
+   end interface
+ 
diff -r -c -b -B -N cosmomc/fieldinf/inftorad.f90 cosmomc_fields/fieldinf/inftorad.f90
*** cosmomc/fieldinf/inftorad.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/inftorad.f90	2010-08-27 15:30:37.000000000 +0200
***************
*** 0 ****
--- 1,515 ----
+ module inftorad
+   use cosmopar
+   use infprec, only : kp
+   use infbgmodel, only : fieldNum
+   use infbg, only : infbgphys
+   implicit none
+ 
+   private
+ 
+ 
+ !we use this everywhere
+   type inftoradcosmo
+      real(kp) :: bfoldIni
+      real(kp) :: bfoldEnd 
+      real(kp) :: efoldEndToToday
+      real(kp) :: lnEnergyEnd
+      type(infbgphys) :: bgIni
+      type(infbgphys) :: bgEnd
+   end type inftoradcosmo
+ 
+ 
+ !for debugging, physical quantities at hubble exit
+   type infhubblexit
+      real(kp) :: kmpc
+      real(kp) :: bfold
+      real(kp) :: hubble
+      real(kp) :: epsilon1
+      real(kp) :: epsilon1JF
+   end type infhubblexit
+ 
+ 
+ !for debugging
+   logical, parameter :: display = .false.
+   logical, parameter :: dump_file = .false.
+ 
+ 
+ !some physical constants
+   real(kp), parameter :: scaleFactorToday = 1._kp  
+ 
+ ! ln[1Mpc/sqrt(8pi)/lPl] = 130.282
+ !  real(kp), parameter :: lnMpcToKappa = 130.282_kp
+ 
+ !enforce constant equation of state during reheating for large field models
+   logical, parameter :: LargeFieldWreh = .false.
+ 
+   public inftoradcosmo
+   public scaleFactorToday, lnMpcToKappa
+  
+   public set_inftorad_cosmo, bfold_hubble_fraction
+ 
+ 
+ !for test
+   public infhubblexit, hubble_splinexit
+   
+ contains
+ 
+ 
+ 
+ 
+ 
+   function set_inftorad_cosmo(bgParam,bgIni,bgEnd,lnReheat,inferror)
+     use infbgmodel, only : infbgparam
+     use infbg, only : infbgdata, infbgphys
+     use infbg, only :  matter_energy_density,  matter_energy_density_JF
+     use infbgspline, only : set_infbg_spline  
+     implicit none
+ 
+     type(inftoradcosmo) :: set_inftorad_cosmo
+ 
+     type(infbgparam), intent(in) :: bgParam
+     type(infbgphys), intent(in) :: bgIni
+     type(infbgphys), intent(in) :: bgEnd
+     
+ !ln(aend/areh) + (1/4)ln(rhoend/rhoreh) + (1/4)ln(rhoend). This is the
+ !deviations expected from either instantaneous reheating or radiation
+ !dominated like reheating
+     real(kp), intent(in) :: lnReheat
+ 
+ !useful for setting hard prior
+     integer, optional :: inferror
+ 
+ !rho at the end of inflation   
+     real(kp) :: lnEnergyEndInf
+ 
+ !bound on lnReheat
+     real(kp) :: lnReheatMin, lnReheatMax
+ 
+ !deviation from rad-like reheating: lnRrad = lnR - 1/4 ln(rhoend)
+     real(kp) :: lnRrad
+ 
+     real(kp) :: wreh, p, thirdminusw
+     real(kp) :: ThirdMinusWlnEnergyEndReh, lnEnergyEndReh
+ 
+ !kappaeff^4 x rhonuc with rhonuc~10MeV
+ !energyNuc = 2.9d-82
+ !    real(kp), parameter :: lnEnergyNuc = -187.747
+     real(kp), parameter :: lnEnergyNuc = lnRhoNuc
+ 
+     real(kp), dimension(fieldNum) :: velocityEnd, fieldEnd
+    
+     fieldEnd = bgEnd%field
+     velocityEnd = bgEnd%fieldDot*bgEnd%hubble
+ 
+ !if epsilon1=1 at the end of inflation, it should be Hend^2/3 (for one
+ !field models)
+ 
+     lnEnergyEndInf = log(matter_energy_density(fieldEnd,velocityEnd))
+ 
+ !comes from -1/3 <wreheat < 1 and rhorheat > rhonuc
+ 
+     lnReheatMax = (1._kp/12._kp)* (-lnEnergyNuc) &
+          - (1._kp/3._kp) * (-lnEnergyEndInf)
+ 
+     lnReheatMin = - (1._kp/4._kp)* (-lnEnergyNuc)
+     
+     
+     set_inftorad_cosmo%lnEnergyEnd = lnEnergyEndInf  
+     set_inftorad_cosmo%bfoldIni = bgIni%efold - bgEnd%efold
+     set_inftorad_cosmo%bfoldEnd = 0._kp
+ 
+     set_inftorad_cosmo%efoldEndToToday = - ln_scale_factor_scale_inv(lnEnergyEndInf) &
+          - lnReheat
+ 
+ !TODELETE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !    set_inftorad_cosmo%efoldEndToToday = 60._kp
+ !    write(*,*)'efoldEndToToday fixed to: ',set_inftorad_cosmo%efoldEndToToday
+ !    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+     set_inftorad_cosmo%bgIni = bgIni
+     set_inftorad_cosmo%bgEnd = bgEnd
+ 
+ 
+ !hard priors: inflation should occur at energy scale higher than bbn,
+ !as well as reheating
+     if (lnEnergyEndInf.le.lnEnergyNuc) then
+        write(*,*)'set_inftorad_cosmo: inflation till bbn (111)'
+        if (display) then
+           write(*,*)'lnEnergyEndInf = ',lnEnergyEndInf
+           write(*,*)'lnEnergyNucSynth = ',lnEnergyNuc
+        endif
+        if (present(inferror)) then          
+           inferror = 111
+           return
+        else          
+           stop
+        endif
+     endif
+ 
+     if (lnReheat.gt.lnReheatMax) then
+        write(*,*)'set_inftorad_cosmo: higher reheating limit reached (w=1 rho=bbn) (112)'
+        write(*,*)'lnReheat = ',lnReheat
+        write(*,*)'lnReheatMax= ',lnReheatMax       
+        if (present(inferror)) then
+           inferror = 112
+           return
+        else
+           stop
+        endif
+     endif
+ 
+     if (lnReheat.lt.lnReheatMin) then
+        write(*,*)'set_inftorad_cosmo: lower reheating limit reached (w=-1/3 rho=bbn) (113)'
+        write(*,*)'lnReheat = ',lnReheat
+        write(*,*)'lnReheatMin = ',lnReheatMin       
+        if (present(inferror)) then
+           inferror = 113
+           return
+        else
+           stop
+        endif
+     endif
+ 
+     if (LargeFieldWreh) then
+        
+        if (bgParam%name.ne.'largef') then
+           stop 'set_inftorad_cosmo: incompatible models in inftorad!'
+        endif
+ 
+        p = bgParam%consts(2)
+        if (p.gt.1) then
+           wreh = (p-2._kp)/(p+2._kp)
+           thirdminusw = 1._kp/3._kp - wreh                 
+        else
+           stop 'set_inftorad_cosmo: reheating cannot be parametric when p<1'
+        endif
+ 
+        write(*,*)'set_inftorad_cosmo: enforcing wreh = (p-2)/(p+2) =',wreh
+ 
+ !reheating is radiation
+        if (thirdminusw.eq.0._kp) then
+           write(*,*)'set_inftorad_cosmo: reheating is radiation: no constraint'
+           return
+        endif
+ 
+        lnRrad = lnReheat - 0.25_kp*lnEnergyEndInf
+ 
+        thirdMinusWlnEnergyEndReh = thirdminusw_ln_energy_endreh(lnRrad,lnEnergyEndInf,wreh)
+        lnEnergyEndReh = thirdMinusWlnEnergyEndReh/thirdminusw
+ 
+        if (lnEnergyEndReh.gt.lnEnergyEndInf) then
+           write(*,*)'set_inftorad_cosmo: higher cte reheating limit reached (rho=rhoinf) (114)'
+           write(*,*)'lnRhoEndReh = ',lnEnergyEndReh
+           write(*,*)'lnRhoEndInf = ',lnEnergyEndInf
+           if (present(inferror)) then
+              inferror = 114
+              return
+           else
+              stop
+           endif
+        endif
+ 
+        if (lnEnergyEndReh.lt.lnEnergyNuc) then
+           write(*,*)'set_inftorad_cosmo: lower cte reheating limit reached (rho=bbn) (115)'
+           write(*,*)'lnRhoEndReh = ',lnEnergyEndReh
+           write(*,*)'lnRhoNuc = ',lnEnergyNuc
+           if (present(inferror)) then
+              inferror = 115
+              return
+           else
+              stop
+           endif
+        endif
+        
+     endif
+ 
+ 
+          
+      
+     if (display) then
+        write(*,*)'--------------- set_inftorad_cosmo ---------------'
+        write(*,*)
+        write(*,*)'a0 = ',scaleFactorToday
+        write(*,*)'bfoldIni = ',set_inftorad_cosmo%bfoldIni
+        write(*,*)'bfoldEnd = ',set_inftorad_cosmo%bfoldEnd
+        write(*,*)'efoldIni = ',set_inftorad_cosmo%bgIni%efold
+        write(*,*)'efoldEnd = ',set_inftorad_cosmo%bgEnd%efold      
+        write(*,*)'lnReheatMin = ',lnReheatMin
+        write(*,*)'lnReheat = ',lnReheat
+        write(*,*)'lnReheatMax = ',lnReheatMax
+        write(*,*)       
+        if (largeFieldWreh) then
+           write(*,*)'wreh = ',wreh
+           write(*,*) 'ln(EnergyEndReh)',lnEnergyEndReh/4
+        endif
+        write(*,*)'ln(EnergyEndInf) = ',lnEnergyEndInf/4
+        write(*,*)'ln(EnergyNuc) = ',lnEnergyNuc/4
+        write(*,*)
+        write(*,*)'efoldEndToToday = ',set_inftorad_cosmo%efoldEndToToday
+        write(*,*)'ln[1Mpc/kappaeff] = ',lnMpcToKappa
+        write(*,*)       
+        write(*,*)'fieldEnd = ',set_inftorad_cosmo%bgEnd%field
+        write(*,*)
+        write(*,*)'energyEnd^1/2 = ',exp(0.5*set_inftorad_cosmo%lnEnergyEnd)
+        write(*,*)'hubbleEnd.3^1/2 = ',sqrt(3.)*set_inftorad_cosmo%bgEnd%hubble
+        write(*,*)
+        write(*,*)'-------------------------------------------------'
+     endif
+ 
+ 
+   end function set_inftorad_cosmo
+ 
+ 
+ 
+ 
+   function ln_scale_factor_eq()
+ !all in unit of kappa = sqrt(8pi)/Mpl. H0 et OmegaRad are fixed since
+ !the incertainties on their measured values is irrelevant compared to
+ !inflationary params. They can be added in the chains but this would
+ !render all prim parameters as "slow" in cosmocmc.
+ 
+     implicit none
+         
+     real(kp) :: ln_scale_factor_eq
+     
+ !    real(kp), parameter :: HubbleSquareRootOf2OmegaRad = 8.00d-63 !x kappaendinf(#kappatoday)
+ 
+ 
+ !this is: 1/4 ln(rhoeq) + ln(aeq/a0)
+ !             = (1/4) ln(rhoeq) - ln(1+zeq)
+ !             = -(1/4) ln(2/3) + (1/2) ln[Heq/(1+zeq)^2]
+ ! where used has been made of: rhoeq = (3/2) Heq^2 (in kappa unit)
+ !
+ ! Heq/(1+zeq)^2 = sqrt(2 Omega0) H0 / sqrt(1+zeq)
+ ! 1+zeq = Omega0/OmegaRadiation0 <---- photons + neutrinos
+ ! H0 = 100h km/s/Mpc = 1.74717d-61 Mpl
+ ! There is no dependency in h and Omega0 in Heq/(1+zeq)^2 = sqrt(2 OmegaRad0) H0 (x kappatoday)
+ 
+     ln_scale_factor_eq = log(scaleFactorToday) &
+          + 0.5_kp*log(HubbleSquareRootOf2OmegaRad) &
+          - 0.25_kp*log(2._kp/3._kp)
+ 
+   end function ln_scale_factor_eq
+ 
+ 
+ 
+ 
+ 
+   function ln_scale_factor_scale_inv(lnEnergyEndInf)
+ !this is ln(aend/a0) when R=1
+ !in that case we have:
+ !    ln(aend/a0) =
+ ! ln(aend/areh) - 1/4 ln(rhoreh) + 1/2 ln(rhoend) <--lnReheat
+ ! + ln(aeq/a0) + 1/4 ln(rhoeq) - 1/2 ln(rhoend) <-- ln_scale_inv
+ 
+     implicit none
+     real(kp), intent(in) :: lnEnergyEndInf
+     real(kp) :: ln_scale_factor_scale_inv
+     
+    
+     ln_scale_factor_scale_inv = ln_scale_factor_eq() - 0.5_kp*lnEnergyEndInf
+ 
+   end function ln_scale_factor_scale_inv
+   
+ 
+ 
+ 
+ 
+ 
+   function ln_scale_factor_radreheat(lnEnergyEndInf)
+ !This is ln(aend/a0) for Rrad=1. Rough approximation of the physical
+ !scale factor at the end of inflation. Assumes instantenous reheating
+ !and instantenous transitions, all in unit of kappa =
+ !sqrt(8pi)/Mpl. The input is supposed to be the energy transfered
+ !after inflation to the "matter sector", in our case this is the
+ !energy density of the matter field at the end of inflation. This
+ !assumes pure GR after the end of inflation.
+ 
+     implicit none
+     
+     real(kp), intent(in) :: lnEnergyEndInf
+     real(kp) :: ln_scale_factor_radreheat
+        
+ ! ln(aend/a0) = ln(aend/areh) + ln(areh/aeq) + ln(aeq/a0)
+ !             ~ (1/4) ln(rhoeq/rhoend) - ln(1+zeq)
+ !             = -(1/4) ln(2rhoend/3) + (1/2) ln[Heq/(1+zeq)^2]
+ ! where used has been made of: rhoeq = (3/2) Heq^2 (in kappa unit)
+ !
+ ! Heq/(1+zeq)^2 = sqrt(2 Omega0) H0 / sqrt(1+zeq)
+ ! 1+zeq = Omega0/OmegaRadiation0 <---- photons + neutrinos
+ ! H0 = 100h km/s/Mpc = 1.74717d-61 Mpl
+ ! There is no dependency in h and Omega0 in Heq/(1+zeq)^2 = sqrt(2 OmegaRad0) H0 (x kappatoday)
+ 
+     ln_scale_factor_radreheat = ln_scale_factor_eq() - 0.25_kp*lnEnergyEndInf
+ 
+   end function ln_scale_factor_radreheat
+ 
+ 
+ 
+   function ln_scale_factor_corr_radreheat(lnEnergyEndInf,lnEnergyEndReh,wreh)
+ !This is ln(Rrad): the correction from a rad-like reheating period
+ !when during reheating one has P=wre x rho, with wre a constant
+ 
+ !          ln(aend/areh) + (1/4) ln(rhoend/rhoreheat) = (1/4) x
+ !          (w-1/3)/(w+1) x ln(rhoend/rhoreheat)
+ 
+     implicit none
+     
+     real(kp), intent(in) :: lnEnergyEndInf, lnEnergyEndReh, wreh
+     real(kp) :: ln_scale_factor_corr_radreheat
+     
+     ln_scale_factor_corr_radreheat = 0.25_kp * (wreh - 1._kp/3._kp)/(wreh + 1._kp) &
+          * (lnEnergyEndInf - lnEnergyEndReh)
+ 
+   end function ln_scale_factor_corr_radreheat
+   
+ 
+ 
+ 
+ 
+   function thirdminusw_ln_energy_endreh(lnRrad,lnEnergyEndInf,wreh)
+ !This is the inverse function. It gives (1/3 -w) ln(rhoreh) as a function of ln(Rrad) and ln(rhoend)
+     implicit none
+     
+     real(kp), intent(in) :: lnRrad,lnEnergyEndinf,wreh
+     real(kp) :: thirdminusw_ln_energy_endreh
+ 
+     thirdminusw_ln_energy_endreh = 4._kp*(1._kp+wreh)*lnRrad + (1._kp/3._kp-wreh)*lnEnergyEndInf
+ 
+   end function thirdminusw_ln_energy_endreh
+ 
+ 
+ 
+ 
+ 
+ 
+    function bfold_plus_ln_hubble(bfold,cosmoData)
+ !returns N + ln[H(N)] - cosmoData%real1, required by zeros finder subroutine:
+ !zbrent
+     use infprec, only : transfert
+     use infbgspline, only : splineval_hubble_parameter
+     implicit none
+ 
+     type(transfert), optional, intent(inout) :: cosmoData
+     real(kp), intent(in) :: bfold
+     real(kp) :: bfold_plus_ln_hubble
+ 
+     real(kp) :: hubble
+ 
+     hubble = splineval_hubble_parameter(bfold)
+ 
+     bfold_plus_ln_hubble = bfold + log(hubble) - cosmoData%real1       
+     
+ !    print *,'bfold',bfold,bfold_plus_ln_hubble,cosmoData%real1
+ !    print *,'hubble^2',hubble**2
+ 
+   end function bfold_plus_ln_hubble
+ 
+ 
+ 
+ 
+ 
+ 
+   function bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubble,inferror)
+ !return the bfold at which k/aH = kphysOverHubble
+     use inftools, only : zbrent
+     use infprec, only : transfert
+     implicit none
+     real(kp), intent(in) :: kmpc
+     real(kp), intent(inout) :: kphysOverHubble
+     type(inftoradcosmo), intent(in) :: infCosmo
+     real(kp) :: bfold_hubble_fraction
+ 
+ !hard prior if quantum ic cannot be set
+     integer, optional :: inferror
+ 
+     type(transfert) :: cosmoData    
+     real(kp), parameter :: tolBfold = 1e-6
+     real(kp) :: bfoldSign
+ 
+ 
+     cosmoData%real1 = log(kmpc) + infCosmo%efoldEndToToday - lnMpcToKappa &
+          - log(kphysOverHubble)
+ 
+     bfoldSign = bfold_plus_ln_hubble(infCosmo%bfoldIni,cosmoData)
+  
+     if (bfoldSign.ge.0d0) then
+        write(*,*)'no crossing found (444) for mode k = ',kmpc, 'at k/aH = ' &
+             ,kphysOverHubble       
+        write(*,*)'bfoldIni = ',infCosmo%bfoldIni
+        if (present(inferror)) then
+           inferror = 222
+           return
+        else
+           if (bfoldSign.lt.log(kphysOverHubble)) then
+              write(*,*)'setting initial condition at bfoldIni'
+              write(*,*)'ln(k/aH) = ', -bfoldSign + log(kphysOverHubble)
+              kphysOverHubble = exp(-bfoldSign) * kphysOverHubble            
+              bfold_hubble_fraction = infCosmo%bfoldIni
+              return
+           else
+              stop
+           endif
+        endif
+     endif
+ 
+     bfold_hubble_fraction = zbrent(bfold_plus_ln_hubble,infCosmo%bfoldIni &
+          , infCosmo%bfoldEnd ,tolBfold, cosmoData)
+ 
+ 
+   end function bfold_hubble_fraction
+ 
+ 
+ 
+ 
+   function hubble_splinexit(infCosmo,kmpc)
+ !spline evaluation of physical quantities at hubble exit (k/aH=1) for the mode kmpc    
+     use infinout
+     use infbgspline, only : splineval_hubble_parameter
+     use infbgspline, only : splineval_epsilon1
+     use infbgspline, only : splineval_epsilon1JF
+     implicit none
+ 
+     real(kp), intent(in) :: kmpc
+     type(infhubblexit) :: hubble_splinexit
+     type(inftoradcosmo) :: infCosmo
+     real(kp) :: bfoldExit, hubbleExit
+     real(kp) :: epsilon1Exit, epsilon1JFExit
+     real(kp) :: kphysOverHubbleExit
+     real(kp) :: pi
+     
+     pi = acos(-1._kp)
+     kphysOverHubbleExit = 1._kp
+ 
+     bfoldExit = bfold_hubble_fraction(kmpc,infCosmo,kphysOverHubbleExit)
+     hubbleExit = splineval_hubble_parameter(bfoldExit)
+     epsilon1Exit = splineval_epsilon1(bfoldExit)
+     epsilon1JFExit = splineval_epsilon1JF(bfoldExit)
+ 
+     if (display) then
+ !this is the tensor spectrum, up to a negligeable relaxation after Hubble exit
+        write(*,*)
+        write(*,*)'kmpc = ',kmpc
+        write(*,*)'hubble crossing at bfold = ',bfoldExit
+        write(*,*)'2(Hk/pi)^2 = ',(2._kp/pi/pi)*hubbleExit**2 
+        write(*,*)'epsilon1 = ',epsilon1Exit
+        write(*,*)'epsilon1JF = ',epsilon1JFExit
+        write(*,*)
+     endif
+ 
+     if (dump_file) then
+        call livewrite('hubblexit.dat',kmpc,(2._kp/pi/pi)*hubbleExit**2)
+        call livewrite('epsilonexit.dat',kmpc,epsilon1Exit,epsilon1JFExit)
+        call livewrite('bfoldexit.dat',kmpc,bfoldExit)
+     endif
+ 
+     hubble_splinexit%kmpc = kmpc
+     hubble_splinexit%bfold = bfoldExit
+     hubble_splinexit%hubble = hubbleExit
+     hubble_splinexit%epsilon1 = epsilon1Exit
+     hubble_splinexit%epsilon1 = epsilon1JFExit
+ 
+   end function hubble_splinexit
+ 
+ 
+ end module inftorad
diff -r -c -b -B -N cosmomc/fieldinf/power_inf.f90 cosmomc_fields/fieldinf/power_inf.f90
*** cosmomc/fieldinf/power_inf.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/power_inf.f90	2010-08-26 13:57:10.000000000 +0200
***************
*** 0 ****
--- 1,948 ----
+ !This module provides the initial power spectra, computed from the inflationary module
+ 
+ module InitialPower   
+   use precision, only : dl
+   use infprec, only : kp 
+   use infbgmodel, only : infbgparam
+   use infbg, only : infbgphys, infbgdata
+   use inftorad, only : inftoradcosmo
+ 
+   implicit none   
+ 
+   private
+  
+   logical, parameter :: display=.false.
+    
+   character(LEN=*), parameter :: Power_Name = 'power_inf'
+   integer, parameter :: nnmax= 1 
+ 
+ !mind that for mcmc
+   logical, parameter :: checkStopDefault = .false.
+   logical, parameter :: checkBoundDefault = .false.
+   logical, parameter :: useSplineDefault = .true.
+ 
+ 
+   type InitialPowerParams
+      integer :: nn    
+      integer :: bgParamNum
+      logical :: checkStop     
+      logical :: checkBound
+      logical :: useSpline
+      integer :: lnkmpcNum
+      real(kp) :: lnkmpcMax, lnkmpcMin
+      real(kp) :: lnReheat
+      real(kp) :: kstar
+      type(infbgparam) :: infParam    
+   end type InitialPowerParams
+ 
+ 
+   type InitialPowerData
+      type(initialpowerparams) :: initP
+      type(infbgphys) :: infIni
+      type(infbgphys) :: infObs     
+      type(infbgphys) :: infEnd     
+      type(inftoradcosmo) :: infCosmo
+      type(infbgdata), pointer :: ptrBgdata => null()
+   end type InitialPowerData
+ 
+ 
+   type ExportInfProp
+      real(kp) :: lnEnergyEnd
+      real(kp) :: efoldEndToToday
+   end type ExportInfProp
+ 
+ 
+   real(dl) :: curv  !Curvature contant, set in InitializePowers     
+ 
+ 
+ 
+   type(InitialPowerData), save :: powerD
+ 
+   
+   
+ 
+   interface operator (==)     
+      module procedure inipowerparams_equal
+   end interface
+ 
+   interface operator (/=)
+      module procedure inipowerparams_unequal
+   end interface
+ 
+   private operator(==),operator(/=)
+ 
+   public nnmax
+   public SetInfBg, SetInfBgSpline, SetInfCosmo, SetInfScalPow
+   public InitializePowers, FreePowers, ScalarPower, TensorPower
+   public InitialPowerParams,Power_Descript, Power_Name, SetDefPowerParams
+ 
+   public exportinfprop, UpdateInfProp
+ 
+   public InitialPower_ReadParams
+ 
+ contains
+        
+ 
+ 
+ 
+ 
+   function inipowerparams_equal(PinA, PinB)
+     use infbgmodel, only : operator(==) 
+     implicit none
+     type(initialpowerparams), intent(in) :: PinA, PinB
+     logical :: inipowerparams_equal
+ 
+     inipowerparams_equal = ((PinA%infParam == PinB%infParam) &
+          .and. (PinA%lnReheat == PinB%lnReheat) &
+          .and. (PinA%nn == PinB%nn) &
+          .and. (PinA%bgParamNum == PinB%bgParamNum) &
+          .and. (PinA%checkStop .eqv. PinB%checkStop) &
+          .and. (PinA%checkBound .eqv. PinB%checkBound) &
+          .and. (PinA%useSpline .eqv. PinB%useSpline) &
+          .and. (PinA%lnkmpcNum == PinB%lnkmpcNum) &
+          .and. (PinA%lnkmpcMax == PinB%lnkmpcMax) &
+          .and. (PinA%lnkmpcMin == PinB%lnkmpcMin))
+ 
+   end function inipowerparams_equal
+ 
+ 
+ 
+ 
+   function inipowerparams_unequal(PinA, PinB)
+     implicit none
+     type(initialpowerparams), intent(in) :: PinA, PinB
+     logical :: inipowerparams_unequal
+ 
+     inipowerparams_unequal = .not.(inipowerparams_equal(PinA,PinB))
+     
+   end function inipowerparams_unequal
+ 
+ 
+ 
+ 
+   subroutine UpdateInfProp(export)
+     implicit none
+     type(exportinfprop), intent(out) :: export
+ 
+     export%lnEnergyEnd = powerD%infCosmo%lnEnergyEnd
+     export%efoldEndToToday = powerD%infCosmo%efoldEndToToday
+    
+   end subroutine UpdateInfProp
+ 
+   
+ 
+ 
+ 
+   subroutine SetDefPowerParams(Pin)
+     use infbgmodel, only : fieldNum, dilatonNum
+     use infbgmodel, only : matterParamNum, dilatonParamNum
+     use infbgmodel, only : infParamNum
+     implicit none
+     type (InitialPowerParams), intent(out) :: Pin
+ 
+     Pin%nn = 1
+    
+     Pin%bgParamNum = matterParamNum + dilatonParamNum
+ 
+ !stop inflation according to field values
+     Pin%checkStop = checkStopDefault
+ 
+ !impose hard prior from theoretical bounds on field values
+     Pin%checkBound = checkBoundDefault
+    
+ !range and sampling of the power spectra spline
+     Pin%useSpline = useSplineDefault 
+     Pin%lnkmpcMin = -14.
+     Pin%lnkmpcMax = 0.
+     Pin%lnkmpcNum = 12
+       
+     Pin%lnReheat = 0.
+     Pin%kstar = 0.05
+ 
+ !value for the parameters (see infbg.f90)
+     Pin%infParam%name = 'largef'
+     Pin%infParam%consts(1:infParamNum) = 0.
+     Pin%infParam%conforms(1:dilatonNum) = 1.
+ 
+     Pin%infParam%consts(1) = 1e-5
+     Pin%infParam%consts(2) = 2.   
+     Pin%infParam%consts(3:4) = 0.
+     Pin%infParam%consts(5) = 1.
+ 
+     if (infParamNum.gt.5) then
+        Pin%infParam%consts(6:infParamNum) = 0.
+     endif
+ 
+   end subroutine SetDefPowerParams
+ 
+ 
+ 
+ 
+   subroutine InitializePowers(Pin,acurv,wantScalars,wantTensors)
+     implicit none
+ 
+     type (initialpowerparams) :: Pin
+          !Called before computing final Cls in cmbmain.f90
+          !Could read spectra from disk here, do other processing, etc.
+     real(dl) :: acurv
+     logical, optional, intent(in) :: wantScalars, wantTensors
+     integer :: inferror
+     logical, parameter :: usePstar=.false.
+     real(kp), parameter :: Pstar = 1._kp
+ 
+     inferror = 0
+ 
+     if (Pin%nn > nnmax) then
+        stop 'can only used one initial power spectrum'
+     end if
+     curv=acurv         
+ 
+     if (curv.ne.0d0) stop 'flat universe only'
+ 
+ !one background for all k (that's why nnmax=1)
+ !    print *,'we are in initialize power',(Pin%infParam == powerD%initP%infParam) &
+ !         ,(Pin%infParam /= powerD%initP%infParam)   
+   
+     call SetInfBg(Pin,inferror)
+     if (inferror.ne.0) stop 'InitializePowers: unproper infbg'
+ 
+     if (usePstar) then
+ !this is only for playing with normalised power spectra to Pstar. 
+        write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+        write(*,*)'InitializePower: renormalising P(k*) to Pstar=',Pstar
+        write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+        read(*,*)
+        call SetInfScalPow(Pin,Pstar)
+     endif
+ 
+     call SetInfBgSpline(Pin)
+ 
+     call SetInfCosmo(Pin,inferror)
+     if (inferror.ne.0) stop 'InitializePowers: unproper inftorad'
+       
+   end subroutine InitializePowers
+ 
+ 
+ 
+ 
+   subroutine SetInfBg(Pin,inferror)
+     use infbgmodel, only : operator(==)
+     use infbgmodel, only : set_infbg_param, matterNum
+     use infsrmodel, only : field_stopinf
+     use infbg, only : operator(==)
+     use infbg, only : set_infbg_ini, bg_field_evol    
+     implicit none
+ 
+     type (initialpowerparams), intent(in) :: Pin    
+     integer, optional :: inferror
+ 
+     logical :: areTryParamsOk, areInfIniOk, isThBoundOk
+     logical :: areParamsSet
+     integer, parameter :: infbgPoints = 1000
+     type(initialpowerparams) :: Pstack
+     real(kp), dimension(2) :: fieldStop
+     logical :: stopAtMax
+    
+ !    print *,'Pin',Pin
+     if (associated(powerD%ptrBgdata)) then
+        if (Pin%infParam == powerD%initP%infParam) then
+           if (display) then
+              write(*,*)'SetInfBg: same infbg params'
+              write(*,*)'Pin%infParam= ',Pin%infParam
+           endif
+           return
+        else
+           if (display) then
+              write(*,*)'SetInfBg: new infbgparams'
+              write(*,*)'Pin%infParam= ',Pin%infParam
+           endif
+           Pstack = powerD%initP
+           call FreePowers(Pstack)
+        endif
+     endif
+ 
+ !hard prior tests on the parameters
+     areTryParamsOk = HardPriorAcceptParam(Pin%infParam,inferror)
+     if (.not.areTryParamsOk) then
+        if (present(inferror).and.display) write(*,*)'SetInfBg: inferror ',inferror
+        return
+     endif
+ 
+        
+ !update powerD%initP according to Pin (may be modified in)    
+     areParamsSet = set_infbg_param(Pin%infParam)
+     powerD%initP = Pin
+     if (.not.(areParamsSet)) then
+        stop 'SetInfBg: params initialisation failed!'
+     endif
+ 
+     powerD%infIni = set_infbg_ini(Pin%infParam)
+ 
+ 
+ 
+ !hard prior tests on the initial field values
+     areInfIniOk = HardPriorAcceptInfIni(powerD%infIni,inferror)
+     if (.not.areInfIniOk) then
+        if (present(inferror).and.display) write(*,*)'SetInfBg: inferror ',inferror
+        powerD%infEnd = powerD%infIni
+        return
+     endif
+ 
+ 
+ 
+ !hard prior tests for theoretical bound on initial field values 
+     if (powerD%initP%checkBound) then
+ 
+        isThBoundOk = HardPriorInThBound(powerD%initP%infParam &
+             ,powerD%infIni,inferror)
+ 
+        if (.not.isThBoundOk) then          
+           powerD%infEnd = powerD%infIni
+           if (present(inferror).and.display) write(*,*)'SetInfBg: inferror ',inferror
+           return
+        endif
+ 
+     endif
+ 
+ 
+     if (powerD%initP%checkStop) then
+        fieldStop = field_stopinf(powerD%initP%infParam)
+        if (fieldStop(2).gt.0._kp) then
+           stopAtMax = .true.
+        else
+           stopAtMax = .false.
+        endif
+ 
+        powerD%infEnd = bg_field_evol(powerD%infIni,infbgPoints &
+             ,powerD%infObs,powerD%ptrBgdata,fieldStop(1),stopAtMax)
+     else
+ 
+        powerD%infEnd = bg_field_evol(powerD%infIni,infbgPoints &
+             ,powerD%infObs,powerD%ptrBgdata)
+ 
+     endif
+ 
+ !last hard prior: the number of efolds is not enough
+     if (powerD%infEnd == powerD%infIni) then
+        if (display) write(*,*)'SetInfBg: infEnd = infIni (4444)'
+        if (present(inferror)) inferror = 4444
+        return
+     endif
+    
+ 
+   end subroutine SetInfBg
+ 
+ 
+ 
+   function HardPriorAcceptParam(infParam,inferror)
+     use infbgmodel, only : matterParamNum
+     implicit none
+     logical :: HardPriorAcceptParam
+     type(infbgparam), intent(in) :: infParam
+     integer, optional :: inferror
+ 
+     HardPriorAcceptParam = .true.
+ 
+ !if during mcmc, consts(4)=0 is unprobably tested (singular for this value)
+     if (infParam%name=='runmas') then
+        if (infParam%consts(4).eq.0._kp) then
+           if (display) then
+              write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+              write(*,*)'HardPriorAcceptParam: infParam%consts(4)=0 (1111)'
+              write(*,*)'for running mass model!'
+              write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+           endif
+           if (present(inferror)) inferror = 1111
+           HardPriorAcceptParam=.false.
+        endif
+     endif
+ 
+     if (infParam%name=='kklmmt') then
+        if (infParam%consts(matterParamNum).lt.infParam%consts(3)) then
+           if (display) write(*,*)'HardPriorAcceptParam: MatterString < mu (1112)'
+           if (present(inferror)) inferror = 1112
+           HardPriorAcceptParam=.false.
+        endif
+     endif
+ 
+ 
+   end function HardPriorAcceptParam
+ 
+ 
+ 
+   function HardPriorAcceptInfIni(infIni,inferror)
+     implicit none
+     logical :: HardPriorAcceptInfIni
+     type(infbgphys), intent(in) :: infIni
+     integer, optional :: inferror
+ 
+     HardPriorAcceptInfIni=.true.
+ 
+     if (infIni%epsilon1.gt.1._kp) then            
+        if (display) write(*,*) 'HardPriorAcceptInfIni: epsilon1 > 1 (2222) ' 
+        if (present(inferror)) inferror = 2222
+        HardPriorAcceptInfIni = .false.
+     endif
+ 
+   end function HardPriorAcceptInfIni
+ 
+ 
+ 
+ 
+   function HardPriorInThBound(infParam,infIni,inferror)
+     use infbgmodel, only : matterNum
+     use infsrmodel, only : field_thbound
+     implicit none
+     logical :: HardPriorInThBound
+     type(infbgparam), intent(in) :: infParam
+     type(infbgphys), intent(in) :: infIni
+     integer, optional :: inferror
+ 
+     real(kp), dimension(2) :: fieldBound
+ 
+     HardPriorInThBound = .true.
+ 
+     fieldBound = field_thbound(infParam)
+     if (fieldBound(2).gt.0._kp) then
+        HardPriorInThBound = (maxval(infIni%field(1:matterNum)) &
+             .lt.fieldBound(1))
+     else
+        HardPriorInThBound = (minval(infIni%field(1:matterNum)) &
+             .lt.fieldBound(1))
+     endif
+     
+     if (.not.HardPriorInthBound) then
+        if (display) write(*,*) 'HardPriorInThBound: bound violated (3333)'
+        if (present(inferror)) inferror = 3333
+     endif
+ 
+   end function HardPriorInThBound
+   
+ 
+ 
+ 
+   subroutine SetInfBgSpline(Pin)
+     use infbgmodel, only : operator(==)
+     use infbgspline, only : set_infbg_spline,check_infbg_spline
+     implicit none
+ 
+     type (initialpowerparams), intent(in) :: Pin    
+    
+     if (check_infbg_spline()) return
+ 
+ !sanity checks
+     if (Pin%infParam == powerD%initP%infParam) then
+        call set_infbg_spline(powerD%infEnd,powerD%ptrBgdata)
+     else
+        stop 'SetInfBgSpline: Pin%params >< Data params'
+     endif
+ 
+   end subroutine SetInfBgSpline
+ 
+ 
+ 
+ 
+ 
+   subroutine FreeInfBgSpline(Pin)
+     use infbgmodel, only : operator(==)
+     use infbgspline, only : free_infbg_spline, check_infbg_spline
+     implicit none
+ 
+     type (initialpowerparams), intent(in) :: Pin    
+    
+     if (.not. check_infbg_spline()) return
+ 
+ !sanity checks
+     if (Pin%infParam == powerD%initP%infParam) then
+        call free_infbg_spline()
+     else
+        stop 'FreeInfBgSpline: Pin%params >< Data params'
+     endif
+ 
+   end subroutine FreeInfBgSpline
+ 
+ 
+ 
+ 
+ 
+   subroutine FreeInfBgData(Pin)
+     use infbgmodel, only : operator(==)
+     use infbg, only : free_infbg_data
+     implicit none
+ 
+     type (initialpowerparams), intent(in) :: Pin    
+    
+     if (.not.associated(powerD%ptrBgdata)) stop 'FreeInfBgData: no bgdata found!'
+ 
+ !sanity checks
+     if (Pin%infParam == powerD%initP%infParam) then
+        call free_infbg_data(powerD%ptrBgdata)      
+     else
+        stop 'FreeInfBgData: Pin%params >< Data params'
+     endif
+ 
+   end subroutine FreeInfBgData
+   
+ 
+ 
+ 
+ 
+   subroutine SetInfCosmo(Pin,inferror)
+     use infbgmodel, only : operator(/=)   
+     use inftorad, only : set_inftorad_cosmo
+     use infpowspline, only : check_power_scal_spline, check_power_tens_spline
+     
+     implicit none
+ 
+     type (initialpowerparams), intent(in) :: Pin        
+     integer, optional :: inferror
+ 
+ !sanity checks
+     if (Pin%infParam /= powerD%initP%infParam) then
+        stop 'SetInfCosmo: Pin%params >< Data params'
+     endif
+ 
+     
+     if (Pin /= powerD%initP) then 
+        if (Pin%useSpline) call FreePowSpline(Pin)
+        if (display) then
+           write(*,*)'SetInfCosmo: new inftorad params'
+           write(*,*)'lnReheat = ',Pin%lnReheat
+        endif
+        powerD%initP = Pin
+     else
+        if (display) then
+           write(*,*)'SetInfCosmo: same inftorad params'
+           write(*,*)'lnReheat = ',Pin%lnReheat
+        endif
+     endif
+ 
+     powerD%infCosmo = set_inftorad_cosmo(powerD%initP%infParam &
+          ,powerD%infObs,powerD%infEnd,powerD%InitP%lnReheat,inferror)
+ 
+     if (present(inferror)) then
+        if (inferror.ne.0) return
+     endif
+ 
+     if (Pin%useSpline) then
+        call SetScalPowSpline(Pin,inferror)
+        call SetTensPowSpline(Pin,inferror)
+     endif
+ 
+   end subroutine SetInfCosmo
+ 
+ 
+ 
+ 
+ 
+   subroutine SetTensPowSpline(Pin,inferror)    
+     use inftorad, only : bfold_hubble_fraction
+     use infpowspline, only : set_power_tens_spline
+     use infpowspline, only : check_power_tens_spline
+     implicit none
+     type(initialpowerparams), intent(in) :: Pin   
+     integer, optional :: inferror
+ 
+     real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcKnots
+     
+     if (check_power_tens_spline()) return
+ 
+     call IniPowSpline(Pin,lnkmpcKnots,inferror)
+ 
+     if (present(inferror)) then
+        if (inferror.ne.0) return
+     endif
+ 
+     call set_power_tens_spline(powerD%infCosmo,lnkmpcKnots)
+     
+ !    if (present(inferror)) inferror = 0
+ 
+   end subroutine SetTensPowSpline
+ 
+ 
+ 
+ 
+ 
+   subroutine SetScalPowSpline(Pin,inferror)        
+     use infpowspline, only : set_power_scal_spline
+     use infpowspline, only : check_power_scal_spline
+     implicit none
+     type(initialpowerparams), intent(in) :: Pin   
+     integer, optional :: inferror
+ 
+     real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcKnots
+ 
+     if (check_power_scal_spline()) return
+     
+     call IniPowSpline(Pin,lnkmpcKnots,inferror)
+        
+     if (present(inferror)) then
+        if (inferror.ne.0) return
+     endif
+     
+     call set_power_scal_spline(powerD%infCosmo,lnkmpcKnots)       
+ 
+   end subroutine SetScalPowSpline
+ 
+   
+ 
+ 
+ 
+   
+   subroutine IniPowSpline(Pin,lnkmpcVec,inferror)
+     use inftorad, only : bfold_hubble_fraction
+     implicit none
+     type(initialpowerparams), intent(in) :: Pin   
+     real(kp), dimension(Pin%lnkmpcNum) :: lnkmpcVec
+     integer, optional :: inferror
+ 
+     integer :: i
+     real(kp) :: kmpcMin, bfoldSmallest
+     real(kp) :: kphysOverHubbleInit
+ 
+     kphysOverHubbleInit = 100._kp
+ 
+  !sanity checks
+     if (.not.associated(powerD%ptrBgdata)) then
+        stop 'SetInfPowSpline: no InfBg found, call SetInfBg before!'
+     else
+        if (Pin /= powerD%initP) then
+           write(*,*)'SetInfPowSpline: Pin >< Data'
+           stop      
+        endif
+     endif
+     if (.not.Pin%useSpline) stop 'SetInfPowSpline: useSpline is F'
+          
+     do i=1,powerD%initP%lnkmpcNum
+        lnkmpcVec(i) = powerD%initP%lnkmpcMin + real(i-1)*(powerD%initP%lnkmpcMax &
+             - powerD%initP%lnkmpcMin)/real(powerD%initP%lnkmpcNum-1)
+     enddo
+ 
+ !this test that initial conditions at kphysOverHubbleInit can be set,
+ !or in other words that there are enough efold to do it
+     if (present(inferror)) then
+        kmpcMin = exp(powerD%InitP%lnkmpcMin)      
+        bfoldSmallest = bfold_hubble_fraction(kmpcMin,powerD%infCosmo &
+             ,kphysOverHubbleInit,inferror)
+     endif
+ 
+   end subroutine IniPowSpline
+ 
+ 
+ 
+ 
+ 
+   subroutine FreePowSpline(Pin)
+     use infpowspline, only : check_power_scal_spline
+     use infpowspline, only : check_power_tens_spline
+     use infpowspline, only : free_power_scal_spline
+     use infpowspline, only : free_power_tens_spline
+     implicit none
+     type(initialpowerparams), intent(in) :: Pin
+ 
+     if (Pin%useSPline) then
+        if (check_power_scal_spline()) call free_power_scal_spline()
+        if (check_power_tens_spline()) call free_power_tens_spline()
+     else
+        stop 'FreePowSpline: useSpline is false!'
+     endif
+         
+   end subroutine FreePowSpline
+   
+ 
+ 
+ 
+ 
+   subroutine SetInfScalPow(Pin,Pwanted)
+ !to normalise the scalar spectrum to Pwanted at kpivot
+     use infbgmodel, only : operator(/=)
+     use infbg, only : rescale_potential   
+     use inftorad, only : set_inftorad_cosmo
+     use infpert, only : scalNum
+     use infpert, only : power_spectrum_scal
+     implicit none
+     
+     type (initialpowerparams), intent(inout) :: Pin 
+     real(kp), intent(in) :: Pwanted
+ 
+     real(kp) :: scale
+     real(kp) :: Pscal(scalNum,scalNum)
+    
+     integer :: ierror
+ 
+ !sanity checks
+     if (Pin%infParam /= powerD%initP%infParam) then
+        stop 'SetInfScalPow: Pin%params >< Data params'
+     endif
+ 
+     powerD%infCosmo = set_inftorad_cosmo(powerD%initP%infParam, &
+          powerD%infObs,powerD%infEnd,powerD%InitP%lnReheat,ierror)
+     
+ !the bg spline should be set to compute the power spectrum (if not
+ !already) TODO: not optimal at all
+     call SetInfBgSpline(Pin)
+ 
+     Pscal = power_spectrum_scal(powerD%infCosmo,Pin%kstar)
+     
+     if (Pscal(scalNum,scalNum).ne.0.) then
+        scale = Pwanted/Pscal(scalNum,scalNum)
+     else
+        stop 'SetInfScalPow: Pscal = 0'
+     endif
+ 
+ !rescale all the relevant quantities. After this call, everything
+ !should be as if the potential has been normalised according to Pwanted
+     call rescale_potential(scale,powerD%initP%infParam,powerD%infIni &
+          ,powerD%infEnd,powerD%infObs,powerD%ptrBgdata)
+ 
+ !update the external infParam
+     Pin%infParam = powerD%initP%infParam
+ 
+ !but the background spline is not longer up to date
+     call FreeInfBgSpline(Pin)
+     
+     
+ !for debugging only
+     if (display) then
+        write(*,*)
+        write(*,*)'SetInfScalPow:'
+        write(*,*)'Pwanted = ',Pwanted
+        write(*,*)'Pnow = ',Pscal(scalNum,scalNum)
+        call SetInfBgSpline(Pin)
+        powerD%infCosmo = set_inftorad_cosmo(powerD%InitP%infParam &
+             ,powerD%infObs,powerD%infEnd,powerD%InitP%lnReheat,ierror)
+        Pscal = power_spectrum_scal(powerD%infCosmo,Pin%kstar)
+        call FreeInfBgSpline(Pin)
+        write(*,*)'Pafter = ',Pscal(scalNum,scalNum)
+        write(*,*)
+     endif
+      
+ 
+   end subroutine SetInfScalPow
+ 
+ 
+ 
+ 
+ 
+   subroutine FreePowers(Pin)
+     use infbgmodel, only : operator(==)  
+     implicit none
+     type(initialpowerparams), intent(in) :: Pin
+ 
+     if (.not.associated(powerD%ptrBgdata)) then
+        write(*,*) 'FreePowers: powerD%ptrBgdata not associated!'
+        return
+     endif
+ 
+     if (Pin%infParam == powerD%initP%infParam) then       
+        if (display) write(*,*) 'FreePowers: freeing infbg spline'
+        call FreeInfBgSpline(Pin)
+ 
+        if (display) write(*,*) 'FreePowers: freeing infbg data'
+        call FreeInfBgData(Pin)
+ 
+        if (powerD%initP%useSpline) then
+           if (display) write(*,*) 'FreePowers: freeing powspline data'
+           call FreePowSpline(Pin)          
+        endif
+     else
+        write(*,*)
+        write(*,*) 'FreePowers: Pin <> Data'
+        write(*,*) 'FreePowers: Pin%Param = ',Pin%infParam
+        write(*,*) 'FreePowers: Data%Param = ',powerD%initP%infParam
+        write(*,*)
+        stop       
+     endif
+     
+   end subroutine FreePowers
+ 
+ 
+        
+ 
+ 
+ 
+   function ScalarPower(k,in)    
+ !"in" gives the index of the power to return for this k
+ !ScalarPower = const for scale invariant spectrum
+ !The normalization is defined so that for adiabatic perturbations the gradient of the 3-Ricci 
+ !scalar on co-moving hypersurfaces receives power
+ ! < |D_a R^{(3)}|^2 > = int dk/k 16 k^6/S^6 (1-3K/k^2)^2 ScalarPower(k) 
+ !In other words ScalarPower is the power spectrum of the conserved curvature perturbation given by
+ !-chi = \Phi + 2/3*\Omega^{-1} \frac{H^{-1}\Phi' - \Psi}{1+w}
+ !(w=p/\rho), so < |\chi(x)|^2 > = \int dk/k ScalarPower(k).
+ !Near the end of inflation chi is equal to 3/2 Psi.
+ !Here nu^2 = (k^2 + curv)/|curv| 
+ 
+ !This power spectrum is also used for isocurvature modes where 
+ !< |\Delta(x)|^2 > = \int dk/k ScalarPower(k)
+ !For the isocurvture velocity mode ScalarPower is the power in the neutrino heat flux.
+     use infpert, only : power_spectrum_scal
+     use infpert, only : scalNum
+     use infpowspline, only : splineval_power_scal
+     implicit none
+ 
+     real(kp), dimension(scalNum,scalNum) :: powerSpectrumScal
+     real(dl) :: ScalarPower,k
+     integer :: in
+    
+     if (in.ne.1) stop 'ScalarPower: only 1 Ps allowed'
+ 
+     if (powerD%initP%useSpline) then
+        powerSpectrumScal = splineval_power_scal(k*1._kp)
+     else
+        powerSpectrumScal = power_spectrum_scal(powerD%infCosmo,k*1._kp)
+     endif
+ 
+     ScalarPower = powerSpectrumScal(scalNum,scalNum)
+     
+   end function ScalarPower
+ 
+ 
+ 
+ 
+       
+   function TensorPower(k,in)
+ !TensorPower= const for scale invariant spectrum
+ !The normalization is defined so that
+ ! < h_{ij}(x) h^{ij}(x) > = \sum_nu nu /(nu^2-1) (nu^2-4)/nu^2 TensorPower(k)
+ !for a closed model
+ ! < h_{ij}(x) h^{ij}(x) > = int d nu /(nu^2+1) (nu^2+4)/nu^2 TensorPower(k)
+ !for an open model
+ !"in" gives the index of the power spectrum to return 
+ !Here nu^2 = (k^2 + 3*curv)/|curv| 
+     use infpert, only : power_spectrum_tens
+     use infpowspline, only : splineval_power_tens
+     implicit none
+ 
+     real(dl) :: TensorPower,k   
+     real(kp), parameter :: PiByTwo=3.14159265d0/2._kp
+    
+     integer :: in
+ 
+     if (in.ne.1) stop 'TensorPower: only 1 Pt allowed'
+ 
+      if (powerD%initP%useSpline) then
+        TensorPower = splineval_power_tens(k*1._kp)
+     else
+        TensorPower = power_spectrum_tens(powerD%infCosmo,k*1._kp)
+     endif
+   
+     if (curv < 0) TensorPower=TensorPower*tanh(PiByTwo*sqrt(-k**2/curv-3)) 
+ 
+   end function TensorPower
+ 
+ 
+ 
+ 
+ 
+ 
+   function Power_Descript(in, Scal, Tens, Keys, Vals)
+ !Get parameters describing parameterisation (for FITS file)
+     character(LEN=8), intent(out) :: Keys(*)
+     real(kp), intent(out) :: Vals(*)
+     integer, intent(IN) :: in
+     logical, intent(IN) :: Scal, Tens
+     integer num, Power_Descript
+     num=0
+     if ((Scal).or.(Tens)) then       
+        num=num+1    
+        Keys(num) = 'C1'
+        Vals(num) = powerD%initP%infParam%consts(1)
+        num=num+1
+        Keys(num) = 'C2'
+        Vals(num) = powerD%initP%infParam%consts(2)
+        num=num+1
+        Keys(num) = 'C3'
+        Vals(num) = powerD%initP%infParam%consts(3)
+        num=num+1
+        Keys(num) = 'C4'
+        Vals(num) = powerD%initP%infParam%consts(4)
+        num=num+1
+        Keys(num) = 'Conf'
+        Vals(num) = powerD%initP%infParam%conforms(1)
+        num=num+1             
+        Keys(num) = 'Field'
+        Vals(num) = powerD%initP%infParam%matters(1)    
+        num=num+1
+        Keys(num) = 'lnReheat'
+        Vals(num) = powerD%initP%lnReheat
+        num=num+1       
+        Keys(num) = 'HubbleEnd'
+        Vals(num) = powerD%infCosmo%bgEnd%hubble
+        num=num+1
+        Keys(num) = 'EnergyEndInf'
+        Vals(num) = powerD%infCosmo%lnEnergyEnd
+        num=num+1
+        Keys(num) = 'EfoldEndToToday'
+        Vals(num) = powerD%infCosmo%efoldEndToToday
+     end if
+     Power_Descript = num
+     
+   end function Power_Descript
+ 
+ 
+   subroutine InitialPower_ReadParams(InitPower, Ini, WantTensors)
+     use IniFile
+ !fields
+     use infbgmodel, only : dilatonNum, matterNum
+     real :: mu,nu
+ !end fields
+ 
+     Type(InitialPowerParams) :: InitPower
+     Type(TIniFile) :: Ini
+     logical, intent(in) :: WantTensors
+     integer i
+               
+ !fields
+ 
+     InitPower%nn = Ini_Read_Int('initial_power_num',1)
+     if (InitPower%nn>nnmax) stop 'Too many initial power spectra - increase nnmax in InitialPower'
+     InitPower%infParam%name = Ini_Read_String('inf_model_name')
+     InitPower%bgParamNum = Ini_Read_Int('inf_param_number',3)
+     
+     do i=1, InitPower%bgParamNum
+        InitPower%infParam%consts(i) &
+             = Ini_Read_Double_Array_File(Ini,'inf_param',i,0._dl)    		  
+     end do
+     
+     do i=1,dilatonNum
+        InitPower%infParam%conforms(i) &
+             = Ini_Read_Double_Array_File(Ini,'inf_conform',i,1d0)
+     enddo
+ 
+     do i=1,matterNum
+        InitPower%infParam%matters(i) &
+             = Ini_Read_Double_Array_File(Ini,'inf_matter',i,1d1)
+     enddo
+     
+     InitPower%checkBound = Ini_Read_Logical('inf_check_bound',.false.)
+     InitPower%checkStop = Ini_Read_Logical('inf_check_stop',.false.)
+     
+     InitPower%lnReheat = Ini_Read_Double('inf_ln_reheat',0d0)
+     
+     InitPower%useSpline = Ini_Read_Logical('power_spectra_spline',.false.)
+     if (InitPower%useSpline) then
+        InitPower%lnkmpcMin = Ini_Read_Double('spline_lnkmpc_min',-14d0)
+        InitPower%lnkmpcMax = Ini_Read_Double('spline_lnkmpc_max',0d0)
+        InitPower%lnkmpcNum = Ini_Read_Int('spline_lnkmpc_num',10)
+     endif
+     
+ 
+ !convenient rescalings    
+ !    InitPower%infParam%consts(1) = 10.**InitPower%infParam%consts(1)
+ !    InitPower%infParam%consts(4) = 10.**InitPower%infParam%consts(4)
+     mu = InitPower%infParam%consts(3)
+     nu = InitPower%infParam%consts(4)
+     if ((mu.ne.0.).and.(nu.eq.0.)) then
+        InitPower%infParam%matters = InitPower%infParam%matters &
+             *abs(mu)
+     endif
+     
+ !end fields
+ 
+ 
+   end  subroutine InitialPower_ReadParams
+ 
+ 
+ 
+ end module InitialPower
diff -r -c -b -B -N cosmomc/fieldinf/specialinf.f90 cosmomc_fields/fieldinf/specialinf.f90
*** cosmomc/fieldinf/specialinf.f90	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/fieldinf/specialinf.f90	2010-07-02 16:25:01.000000000 +0200
***************
*** 0 ****
--- 1,541 ----
+ module specialprec
+   use infprec, only : kp
+   implicit none
+   integer, parameter :: dp = selected_real_kind(12,60)
+ !  integer, parameter :: dp = kp
+ end module specialprec
+ 
+ 
+ module specialinf
+   use specialprec, only : dp,kp
+   implicit none
+ contains
+ 
+   function hypergeom_2F1(a,b,c,z)
+     implicit none
+     real(dp), intent(in) :: a,b,c,z
+     real(dp) :: hypergeom_2F1
+     complex(dp) :: ac,bc,cc,zc
+     complex(dp) :: HYP_2F1,res
+ 
+     ac = cmplx(a,0,dp)
+     bc = cmplx(b,0,dp)
+     cc = cmplx(c,0,dp)
+     zc = cmplx(z,0,dp)
+ 
+     res = HYP_2F1(ac,bc,cc,zc)
+ 
+     hypergeom_2F1  = real(res,dp)
+ 
+ 
+   end function hypergeom_2F1
+ 
+ 
+    function lambertw(x)
+     implicit none
+     real(kp) :: lambertw
+     real(kp), intent(in) :: x
+     real(kp) :: w,wTimesExpW,wPlusOneTimesExpW
+     real(kp), parameter :: tol=1d-15
+ 
+ !rough estimation
+ 
+     if ((x.le.500._kp).and.(x.ge.0._kp)) then
+        w = 0.665_kp * (1._kp + 0.0195*log(x+1._kp)) &
+             *log(x+1._kp) + 0.04_kp
+     elseif (x.gt.500._kp) then
+        w = log(x-4._kp) - (1._kp - 1._kp/log(x)) &
+             *log(log(x))
+     elseif (x.ge.-1._kp/exp(1._kp)) then
+        w=-0.5
+     else
+        stop 'x<-1/e'
+     endif
+ 
+ !recurrence
+        
+     do
+        wTimesExpW = w*exp(w)
+        wPlusOneTimesExpW = (w+1._kp)*exp(w)
+        if (tol.gt.(abs((x-wTimesExpW)/wPlusOneTimesExpW))) then
+           exit
+        else
+           w = w-(wTimesExpW-x) &
+                /(wPlusOneTimesExpW-(w+2._kp)*(wTimesExpW-x) &
+                /(2._kp*w+2._kp))
+        endif
+     enddo
+     
+     lambertw = w
+     
+   end function lambertw
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ !DECK DLI
+ ! Code converted using TO_F90 by Alan Miller
+ ! Date: 2002-02-26  Time: 16:43:57
+     FUNCTION dli(x) RESULT(fn_val)
+ !***BEGIN PROLOGUE  DLI
+ !***PURPOSE  Compute the logarithmic integral.
+ !***LIBRARY   SLATEC (FNLIB)
+ !***CATEGORY  C5
+ !***TYPE      REAL (dp) (ALI-S, DLI-D)
+ !***KEYWORDS  FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS
+ !***AUTHOR  Fullerton, W., (LANL)
+ !***DESCRIPTION
+ ! DLI(X) calculates the REAL (dp) logarithmic integral
+ ! for REAL (dp) argument X.
+ !***REFERENCES  (NONE)
+ !***ROUTINES CALLED  DEI, XERMSG
+ !***REVISION HISTORY  (YYMMDD)
+ !   770701  DATE WRITTEN
+ !   890531  Changed all specific intrinsics to generic.  (WRB)
+ !   890531  REVISION DATE from Version 3.2
+ !   891214  Prologue converted to Version 4.0 format.  (BAB)
+ !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+ !***END PROLOGUE  DLI
+       REAL (dp), INTENT(IN)  :: x
+       REAL (dp)              :: fn_val
+ !***FIRST EXECUTABLE STATEMENT  DLI
+       IF (x <= 0.d0) CALL xermsg('SLATEC', 'DLI', 'LOG INTEGRAL UNDEFINED FOR X <= 0')
+       IF (x == 1.d0) CALL xermsg('SLATEC', 'DLI', 'LOG INTEGRAL UNDEFINED FOR X = 0')
+       fn_val = dei(LOG(x))
+       RETURN
+     END FUNCTION dli
+ !DECK DCSEVL
+     FUNCTION dcsevl(x, cs, n) RESULT(fn_val)
+ !***BEGIN PROLOGUE  DCSEVL
+ !***PURPOSE  Evaluate a Chebyshev series.
+ !***LIBRARY   SLATEC (FNLIB)
+ !***CATEGORY  C3A2
+ !***TYPE      REAL (dp) (CSEVL-S, DCSEVL-D)
+ !***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
+ !***AUTHOR  Fullerton, W., (LANL)
+ !***DESCRIPTION
+ !  Evaluate the N-term Chebyshev series CS at X.  Adapted from
+ !  a method presented in the paper by Broucke referenced below.
+ !       Input Arguments --
+ !  X    value at which the series is to be evaluated.
+ !  CS   array of N terms of a Chebyshev series.  In evaluating
+ !       CS, only half the first coefficient is summed.
+ !  N    number of terms in array CS.
+ !***REFERENCES  R. Broucke, Ten subroutines for the manipulation of Chebyshev
+ !                 series, Algorithm 446, Communications of the A.C.M. 16,
+ !                 (1973) pp. 254-256.
+ !               L. Fox and I. B. Parker, Chebyshev Polynomials in Numerical
+ !                 Analysis, Oxford University Press, 1968, page 56.
+ !***ROUTINES CALLED  D1MACH, XERMSG
+ !***REVISION HISTORY  (YYMMDD)
+ !   770401  DATE WRITTEN
+ !   890831  Modified array declarations.  (WRB)
+ !   890831  REVISION DATE from Version 3.2
+ !   891214  Prologue converted to Version 4.0 format.  (BAB)
+ !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+ !   900329  Prologued revised extensively and code rewritten to allow
+ !           X to be slightly outside interval (-1,+1).  (WRB)
+ !   920501  Reformatted the REFERENCES section.  (WRB)
+ !***END PROLOGUE  DCSEVL
+ REAL (dp), INTENT(IN)  :: x
+ REAL (dp), INTENT(IN)  :: cs(:)
+ INTEGER, INTENT(IN)    :: n
+ REAL (dp)              :: fn_val
+ REAL (dp)        :: b0, b1, b2, twox
+ REAL (dp), SAVE  :: onepl
+ LOGICAL, SAVE    :: first = .TRUE.
+ INTEGER          :: i, ni
+ !***FIRST EXECUTABLE STATEMENT  DCSEVL
+ IF (first) onepl = 1.0_dp + 2*EPSILON(0.0_dp)
+ first = .false.
+ IF (n < 1) CALL xermsg('SLATEC','DCSEVL', 'NUMBER OF TERMS <= 0')
+ IF (n > 1000) CALL xermsg('SLATEC', 'DCSEVL', 'NUMBER OF TERMS > 1000')
+ IF (ABS(x) > onepl) CALL xermsg('SLATEC','DCSEVL', 'X OUTSIDE THE INTERVAL (-1,+1)')
+ b1 = 0.0_dp
+ b0 = 0.0_dp
+ twox = 2.0_dp * x
+ DO  i = 1, n
+   b2 = b1
+   b1 = b0
+   ni = n + 1 - i
+   b0 = twox * b1 - b2 + cs(ni)
+ END DO
+ fn_val = 0.5_dp * (b0-b2)
+ RETURN
+ END FUNCTION dcsevl
+ !DECK DE1
+ FUNCTION de1(x) RESULT(fn_val)
+ !***BEGIN PROLOGUE  DE1
+ !***PURPOSE  Compute the exponential integral E1(X).
+ !***LIBRARY   SLATEC (FNLIB)
+ !***CATEGORY  C5
+ !***TYPE      REAL (dp) (E1-S, DE1-D)
+ !***KEYWORDS  E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
+ !             SPECIAL FUNCTIONS
+ !***AUTHOR  Fullerton, W., (LANL)
+ !***DESCRIPTION
+ ! DE1 calculates the REAL (dp) exponential integral, E1(X), for positive
+ ! REAL (dp) argument X and the Cauchy principal value for negative X.
+ ! If principal values are used everywhere, then, for all X,
+ !    E1(X) = -Ei(-X)
+ ! or
+ !    Ei(X) = -E1(-X).
+ ! Series for AE10       on the interval -3.12500E-02 to  0.
+ !                                        with weighted error   4.62E-32
+ !                                         log weighted error  31.34
+ !                               significant figures required  29.70
+ !                                    decimal places required  32.18
+ ! Series for AE11       on the interval -1.25000E-01 to -3.12500E-02
+ !                                        with weighted error   2.22E-32
+ !                                         log weighted error  31.65
+ !                               significant figures required  30.75
+ !                                    decimal places required  32.54
+ ! Series for AE12       on the interval -2.50000E-01 to -1.25000E-01
+ !                                        with weighted error   5.19E-32
+ !                                         log weighted error  31.28
+ !                               significant figures required  30.82
+ !                                    decimal places required  32.09
+ ! Series for E11        on the interval -4.00000E+00 to -1.00000E+00
+ !                                        with weighted error   8.49E-34
+ !                                         log weighted error  33.07
+ !                               significant figures required  34.13
+ !                                    decimal places required  33.80
+ ! Series for E12        on the interval -1.00000E+00 to  1.00000E+00
+ !                                        with weighted error   8.08E-33
+ !                                         log weighted error  32.09
+ !                        approx significant figures required  30.4
+ !                                    decimal places required  32.79
+ ! Series for AE13       on the interval  2.50000E-01 to  1.00000E+00
+ !                                        with weighted error   6.65E-32
+ !                                         log weighted error  31.18
+ !                               significant figures required  30.69
+ !                                    decimal places required  32.03
+ ! Series for AE14       on the interval  0.          to  2.50000E-01
+ !                                        with weighted error   5.07E-32
+ !                                         log weighted error  31.30
+ !                               significant figures required  30.40
+ !                                    decimal places required  32.20
+ !***REFERENCES  (NONE)
+ !***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
+ !***REVISION HISTORY  (YYMMDD)
+ !   770701  DATE WRITTEN
+ !   890531  Changed all specific intrinsics to generic.  (WRB)
+ !   891115  Modified prologue description.  (WRB)
+ !   891115  REVISION DATE from Version 3.2
+ !   891214  Prologue converted to Version 4.0 format.  (BAB)
+ !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+ !   920618  Removed space from variable names.  (RWC, WRB)
+ !***END PROLOGUE  DE1
+ REAL (dp), INTENT(IN)  :: x
+ REAL (dp)              :: fn_val
+ REAL (dp)        :: eta, xmaxt
+ REAL (dp), SAVE  :: xmax
+ INTEGER, SAVE    :: ntae10, ntae11, ntae12, nte11, nte12, ntae13, ntae14
+ LOGICAL, SAVE    :: first = .TRUE.
+ REAL (dp), PARAMETER  :: ae10cs(50) = (/ +.3284394579616699087873844201881E-1_dp, &
+  -.1669920452031362851476184343387E-1_dp, +.2845284724361346807424899853252E-3_dp,   &
+  -.7563944358516206489487866938533E-5_dp, +.2798971289450859157504843180879E-6_dp,   &
+  -.1357901828534531069525563926255E-7_dp, +.8343596202040469255856102904906E-9_dp,   &
+  -.6370971727640248438275242988532E-10_dp, +.6007247608811861235760831561584E-11_dp, &
+  -.7022876174679773590750626150088E-12_dp, +.1018302673703687693096652346883E-12_dp, &
+  -.1761812903430880040406309966422E-13_dp, +.3250828614235360694244030353877E-14_dp, &
+  -.5071770025505818678824872259044E-15_dp, +.1665177387043294298172486084156E-16_dp, &
+  +.3166753890797514400677003536555E-16_dp, -.1588403763664141515133118343538E-16_dp, &
+  +.4175513256138018833003034618484E-17_dp, -.2892347749707141906710714478852E-18_dp, &
+  -.2800625903396608103506340589669E-18_dp, +.1322938639539270903707580023781E-18_dp, &
+  -.1804447444177301627283887833557E-19_dp, -.7905384086522616076291644817604E-20_dp, &
+  +.4435711366369570103946235838027E-20_dp, -.4264103994978120868865309206555E-21_dp, &
+  -.3920101766937117541553713162048E-21_dp, +.1527378051343994266343752326971E-21_dp, &
+  +.1024849527049372339310308783117E-22_dp, -.2134907874771433576262711405882E-22_dp, &
+  +.3239139475160028267061694700366E-23_dp, +.2142183762299889954762643168296E-23_dp, &
+  -.8234609419601018414700348082312E-24_dp, -.1524652829645809479613694401140E-24_dp, &
+  +.1378208282460639134668480364325E-24_dp, +.2131311202833947879523224999253E-26_dp, &
+  -.2012649651526484121817466763127E-25_dp, +.1995535662263358016106311782673E-26_dp, &
+  +.2798995808984003464948686520319E-26_dp, -.5534511845389626637640819277823E-27_dp, &
+  -.3884995396159968861682544026146E-27_dp, +.1121304434507359382850680354679E-27_dp, &
+  +.5566568152423740948256563833514E-28_dp, -.2045482929810499700448533938176E-28_dp, &
+  -.8453813992712336233411457493674E-29_dp, +.3565758433431291562816111116287E-29_dp, &
+  +.1383653872125634705539949098871E-29_dp, -.6062167864451372436584533764778E-30_dp, &
+  -.2447198043989313267437655119189E-30_dp, +.1006850640933998348011548180480E-30_dp, &
+  +.4623685555014869015664341461674E-31_dp /)
+ REAL (dp), PARAMETER  :: ae11cs(60) = (/ +.20263150647078889499401236517381_dp,  &
+  -.73655140991203130439536898728034E-1_dp, +.63909349118361915862753283840020E-2_dp,   &
+  -.60797252705247911780653153363999E-3_dp, -.73706498620176629330681411493484E-4_dp,   &
+  +.48732857449450183453464992488076E-4_dp, -.23837064840448290766588489460235E-5_dp,   &
+  -.30518612628561521027027332246121E-5_dp, +.17050331572564559009688032992907E-6_dp,   &
+  +.23834204527487747258601598136403E-6_dp, +.10781772556163166562596872364020E-7_dp,   &
+  -.17955692847399102653642691446599E-7_dp, -.41284072341950457727912394640436E-8_dp,   &
+  +.68622148588631968618346844526664E-9_dp, +.53130183120506356147602009675961E-9_dp,   &
+  +.78796880261490694831305022893515E-10_dp, -.26261762329356522290341675271232E-10_dp, &
+  -.15483687636308261963125756294100E-10_dp, -.25818962377261390492802405122591E-11_dp, &
+  +.59542879191591072658903529959352E-12_dp, +.46451400387681525833784919321405E-12_dp, &
+  +.11557855023255861496288006203731E-12_dp, -.10475236870835799012317547189670E-14_dp, &
+  -.11896653502709004368104489260929E-13_dp, -.47749077490261778752643019349950E-14_dp, &
+  -.81077649615772777976249734754135E-15_dp, +.13435569250031554199376987998178E-15_dp, &
+  +.14134530022913106260248873881287E-15_dp, +.49451592573953173115520663232883E-16_dp, &
+  +.79884048480080665648858587399367E-17_dp, -.14008632188089809829248711935393E-17_dp, &
+  -.14814246958417372107722804001680E-17_dp, -.55826173646025601904010693937113E-18_dp, &
+  -.11442074542191647264783072544598E-18_dp, +.25371823879566853500524018479923E-20_dp, &
+  +.13205328154805359813278863389097E-19_dp, +.62930261081586809166287426789485E-20_dp, &
+  +.17688270424882713734999261332548E-20_dp, +.23266187985146045209674296887432E-21_dp, &
+  -.67803060811125233043773831844113E-22_dp, -.59440876959676373802874150531891E-22_dp, &
+  -.23618214531184415968532592503466E-22_dp, -.60214499724601478214168478744576E-23_dp, &
+  -.65517906474348299071370444144639E-24_dp, +.29388755297497724587042038699349E-24_dp, &
+  +.22601606200642115173215728758510E-24_dp, +.89534369245958628745091206873087E-25_dp, &
+  +.24015923471098457555772067457706E-25_dp, +.34118376888907172955666423043413E-26_dp, &
+  -.71617071694630342052355013345279E-27_dp, -.75620390659281725157928651980799E-27_dp, &
+  -.33774612157467324637952920780800E-27_dp, -.10479325703300941711526430332245E-27_dp, &
+  -.21654550252170342240854880201386E-28_dp, -.75297125745288269994689298432000E-30_dp, &
+  +.19103179392798935768638084000426E-29_dp, +.11492104966530338547790728833706E-29_dp, &
+  +.43896970582661751514410359193600E-30_dp, +.12320883239205686471647157725866E-30_dp, &
+  +.22220174457553175317538581162666E-31_dp /)
+ REAL (dp), PARAMETER  :: ae12cs(41) = (/ +.63629589796747038767129887806803_dp,  &
+  -.13081168675067634385812671121135E+0_dp, -.84367410213053930014487662129752E-2_dp,   &
+  +.26568491531006685413029428068906E-2_dp, +.32822721781658133778792170142517E-3_dp,   &
+  -.23783447771430248269579807851050E-4_dp, -.11439804308100055514447076797047E-4_dp,   &
+  -.14405943433238338455239717699323E-5_dp, +.52415956651148829963772818061664E-8_dp,   &
+  +.38407306407844323480979203059716E-7_dp, +.85880244860267195879660515759344E-8_dp,   &
+  +.10219226625855003286339969553911E-8_dp, +.21749132323289724542821339805992E-10_dp,  &
+  -.22090238142623144809523503811741E-10_dp, -.63457533544928753294383622208801E-11_dp, &
+  -.10837746566857661115340539732919E-11_dp, -.11909822872222586730262200440277E-12_dp, &
+  -.28438682389265590299508766008661E-14_dp, +.25080327026686769668587195487546E-14_dp, &
+  +.78729641528559842431597726421265E-15_dp, +.15475066347785217148484334637329E-15_dp, &
+  +.22575322831665075055272608197290E-16_dp, +.22233352867266608760281380836693E-17_dp, &
+  +.16967819563544153513464194662399E-19_dp, -.57608316255947682105310087304533E-19_dp, &
+  -.17591235774646878055625369408853E-19_dp, -.36286056375103174394755328682666E-20_dp, &
+  -.59235569797328991652558143488000E-21_dp, -.76030380926310191114429136895999E-22_dp, &
+  -.62547843521711763842641428479999E-23_dp, +.25483360759307648606037606400000E-24_dp, &
+  +.25598615731739857020168874666666E-24_dp, +.71376239357899318800207052800000E-25_dp, &
+  +.14703759939567568181578956800000E-25_dp, +.25105524765386733555198634666666E-26_dp, &
+  +.35886666387790890886583637333333E-27_dp, +.39886035156771301763317759999999E-28_dp, &
+  +.21763676947356220478805333333333E-29_dp, -.46146998487618942367607466666666E-30_dp, &
+  -.20713517877481987707153066666666E-30_dp, -.51890378563534371596970666666666E-31_dp /)
+ REAL (dp), PARAMETER  :: e11cs(29) = (/ -.16113461655571494025720663927566180E+2_dp,      &
+  +.77940727787426802769272245891741497E+1_dp, -.19554058188631419507127283812814491E+1_dp,   &
+  +.37337293866277945611517190865690209E+0_dp, -.56925031910929019385263892220051166E-1_dp,   &
+  +.72110777696600918537847724812635813E-2_dp, -.78104901449841593997715184089064148E-3_dp,   &
+  +.73880933562621681878974881366177858E-4_dp, -.62028618758082045134358133607909712E-5_dp,   &
+  +.46816002303176735524405823868362657E-6_dp, -.32092888533298649524072553027228719E-7_dp,   &
+  +.20151997487404533394826262213019548E-8_dp, -.11673686816697793105356271695015419E-9_dp,   &
+  +.62762706672039943397788748379615573E-11_dp, -.31481541672275441045246781802393600E-12_dp, &
+  +.14799041744493474210894472251733333E-13_dp, -.65457091583979673774263401588053333E-15_dp, &
+  +.27336872223137291142508012748799999E-16_dp, -.10813524349754406876721727624533333E-17_dp, &
+  +.40628328040434303295300348586666666E-19_dp, -.14535539358960455858914372266666666E-20_dp, &
+  +.49632746181648636830198442666666666E-22_dp, -.16208612696636044604866560000000000E-23_dp, &
+  +.50721448038607422226431999999999999E-25_dp, -.15235811133372207813973333333333333E-26_dp, &
+  +.44001511256103618696533333333333333E-28_dp, -.12236141945416231594666666666666666E-29_dp, &
+  +.32809216661066001066666666666666666E-31_dp, -.84933452268306432000000000000000000E-33_dp /)
+ REAL (dp), PARAMETER  :: e12cs(25) = (/ -.3739021479220279511668698204827E-1_dp,      &
+  +.4272398606220957726049179176528E-1_dp, -.130318207984970054415392055219726_dp,     &
+  +.144191240246988907341095893982137E-1_dp, -.134617078051068022116121527983553E-2_dp,   &
+  +.107310292530637799976115850970073E-3_dp, -.742999951611943649610283062223163E-5_dp,   &
+  +.453773256907537139386383211511827E-6_dp, -.247641721139060131846547423802912E-7_dp,   &
+  +.122076581374590953700228167846102E-8_dp, -.548514148064092393821357398028261E-10_dp,  &
+  +.226362142130078799293688162377002E-11_dp, -.863589727169800979404172916282240E-13_dp, &
+  +.306291553669332997581032894881279E-14_dp, -.101485718855944147557128906734933E-15_dp, &
+  +.315482174034069877546855328426666E-17_dp, -.923604240769240954484015923200000E-19_dp, &
+  +.255504267970814002440435029333333E-20_dp, -.669912805684566847217882453333333E-22_dp, &
+  +.166925405435387319431987199999999E-23_dp, -.396254925184379641856000000000000E-25_dp, &
+  +.898135896598511332010666666666666E-27_dp, -.194763366993016433322666666666666E-28_dp, &
+  +.404836019024630033066666666666666E-30_dp, -.807981567699845120000000000000000E-32_dp /)
+ REAL (dp), PARAMETER  :: ae13cs(50) = (/ -.60577324664060345999319382737747_dp,  &
+  -.11253524348366090030649768852718E+0_dp, +.13432266247902779492487859329414E-1_dp,   &
+  -.19268451873811457249246838991303E-2_dp, +.30911833772060318335586737475368E-3_dp,   &
+  -.53564132129618418776393559795147E-4_dp, +.98278128802474923952491882717237E-5_dp,   &
+  -.18853689849165182826902891938910E-5_dp, +.37494319356894735406964042190531E-6_dp,   &
+  -.76823455870552639273733465680556E-7_dp, +.16143270567198777552956300060868E-7_dp,   &
+  -.34668022114907354566309060226027E-8_dp, +.75875420919036277572889747054114E-9_dp,   &
+  -.16886433329881412573514526636703E-9_dp, +.38145706749552265682804250927272E-10_dp,  &
+  -.87330266324446292706851718272334E-11_dp, +.20236728645867960961794311064330E-11_dp, &
+  -.47413283039555834655210340820160E-12_dp, +.11221172048389864324731799928920E-12_dp, &
+  -.26804225434840309912826809093395E-13_dp, +.64578514417716530343580369067212E-14_dp, &
+  -.15682760501666478830305702849194E-14_dp, +.38367865399315404861821516441408E-15_dp, &
+  -.94517173027579130478871048932556E-16_dp, +.23434812288949573293896666439133E-16_dp, &
+  -.58458661580214714576123194419882E-17_dp, +.14666229867947778605873617419195E-17_dp, &
+  -.36993923476444472706592538274474E-18_dp, +.93790159936721242136014291817813E-19_dp, &
+  -.23893673221937873136308224087381E-19_dp, +.61150624629497608051934223837866E-20_dp, &
+  -.15718585327554025507719853288106E-20_dp, +.40572387285585397769519294491306E-21_dp, &
+  -.10514026554738034990566367122773E-21_dp, +.27349664930638667785806003131733E-22_dp, &
+  -.71401604080205796099355574271999E-23_dp, +.18705552432235079986756924211199E-23_dp, &
+  -.49167468166870480520478020949333E-24_dp, +.12964988119684031730916087125333E-24_dp, &
+  -.34292515688362864461623940437333E-25_dp, +.90972241643887034329104820906666E-26_dp, &
+  -.24202112314316856489934847999999E-26_dp, +.64563612934639510757670475093333E-27_dp, &
+  -.17269132735340541122315987626666E-27_dp, +.46308611659151500715194231466666E-28_dp, &
+  -.12448703637214131241755170133333E-28_dp, +.33544574090520678532907007999999E-29_dp, &
+  -.90598868521070774437543935999999E-30_dp, +.24524147051474238587273216000000E-30_dp, &
+  -.66528178733552062817107967999999E-31_dp /)
+ REAL (dp), PARAMETER  :: ae14cs(64) = (/ -.1892918000753016825495679942820_dp, &
+  -.8648117855259871489968817056824E-1_dp, +.7224101543746594747021514839184E-2_dp,   &
+  -.8097559457557386197159655610181E-3_dp, +.1099913443266138867179251157002E-3_dp,   &
+  -.1717332998937767371495358814487E-4_dp, +.2985627514479283322825342495003E-5_dp,   &
+  -.5659649145771930056560167267155E-6_dp, +.1152680839714140019226583501663E-6_dp,   &
+  -.2495030440269338228842128765065E-7_dp, +.5692324201833754367039370368140E-8_dp,   &
+  -.1359957664805600338490030939176E-8_dp, +.3384662888760884590184512925859E-9_dp,   &
+  -.8737853904474681952350849316580E-10_dp, +.2331588663222659718612613400470E-10_dp, &
+  -.6411481049213785969753165196326E-11_dp, +.1812246980204816433384359484682E-11_dp, &
+  -.5253831761558460688819403840466E-12_dp, +.1559218272591925698855028609825E-12_dp, &
+  -.4729168297080398718476429369466E-13_dp, +.1463761864393243502076199493808E-13_dp, &
+  -.4617388988712924102232173623604E-14_dp, +.1482710348289369323789239660371E-14_dp, &
+  -.4841672496239229146973165734417E-15_dp, +.1606215575700290408116571966188E-15_dp, &
+  -.5408917538957170947895023784252E-16_dp, +.1847470159346897881370231402310E-16_dp, &
+  -.6395830792759094470500610425050E-17_dp, +.2242780721699759457250233276170E-17_dp, &
+  -.7961369173983947552744555308646E-18_dp, +.2859308111540197459808619929272E-18_dp, &
+  -.1038450244701137145900697137446E-18_dp, +.3812040607097975780866841008319E-19_dp, &
+  -.1413795417717200768717562723696E-19_dp, +.5295367865182740958305442594815E-20_dp, &
+  -.2002264245026825902137211131439E-20_dp, +.7640262751275196014736848610918E-21_dp, &
+  -.2941119006868787883311263523362E-21_dp, +.1141823539078927193037691483586E-21_dp, &
+  -.4469308475955298425247020718489E-22_dp, +.1763262410571750770630491408520E-22_dp, &
+  -.7009968187925902356351518262340E-23_dp, +.2807573556558378922287757507515E-23_dp, &
+  -.1132560944981086432141888891562E-23_dp, +.4600574684375017946156764233727E-24_dp, &
+  -.1881448598976133459864609148108E-24_dp, +.7744916111507730845444328478037E-25_dp, &
+  -.3208512760585368926702703826261E-25_dp, +.1337445542910839760619930421384E-25_dp, &
+  -.5608671881802217048894771735210E-26_dp, +.2365839716528537483710069473279E-26_dp, &
+  -.1003656195025305334065834526856E-26_dp, +.4281490878094161131286642556927E-27_dp, &
+  -.1836345261815318199691326958250E-27_dp, +.7917798231349540000097468678144E-28_dp, &
+  -.3431542358742220361025015775231E-28_dp, +.1494705493897103237475066008917E-28_dp, &
+  -.6542620279865705439739042420053E-29_dp, +.2877581395199171114340487353685E-29_dp, &
+  -.1271557211796024711027981200042E-29_dp, +.5644615555648722522388044622506E-30_dp, &
+  -.2516994994284095106080616830293E-30_dp, +.1127259818927510206370368804181E-30_dp, &
+  -.5069814875800460855562584719360E-31_dp /)
+ !***FIRST EXECUTABLE STATEMENT  DE1
+ IF (first) THEN
+   eta = 0.1 * EPSILON(0.0_dp)
+   ntae10 = initds(ae10cs, 50, eta)
+   ntae11 = initds(ae11cs, 60, eta)
+   ntae12 = initds(ae12cs, 41, eta)
+   nte11 = initds(e11cs, 29, eta)
+   nte12 = initds(e12cs, 25, eta)
+   ntae13 = initds(ae13cs, 50, eta)
+   ntae14 = initds(ae14cs, 64, eta)
+   xmaxt = -LOG( TINY(0.0_dp) )
+   xmax = xmaxt - LOG(xmaxt)
+ END IF
+ first = .false.
+ IF (x <= -1._dp) THEN
+   IF (x <= -32._dp) THEN
+     fn_val = EXP(-x) / x * (1._dp + dcsevl(64._dp/x+1._dp, ae10cs, ntae10))
+     RETURN
+   END IF
+   IF (x <= -8._dp) THEN
+     fn_val = EXP(-x) / x * (1._dp + dcsevl((64._dp/x+5._dp)/3._dp, ae11cs, ntae11))
+     RETURN
+   END IF
+   IF (x <= -4._dp) THEN
+     fn_val = EXP(-x) / x * (1._dp + dcsevl(16._dp/x+3._dp, ae12cs, ntae12))
+     RETURN
+   END IF
+   fn_val = -LOG(-x) + dcsevl((2._dp*x+5._dp)/3._dp, e11cs, nte11)
+   RETURN
+ END IF
+ IF (x <= 1.0_dp) THEN
+   IF (x == 0._dp) CALL xermsg('SLATEC', 'DE1', 'X IS 0')
+   fn_val = (-LOG(ABS(x)) - 0.6875_dp+x) + dcsevl(x, e12cs, nte12)
+   RETURN
+ END IF
+ IF (x <= 4.0_dp) THEN
+   fn_val = EXP(-x) / x * (1._dp + dcsevl((8._dp/x-5._dp)/3._dp, ae13cs, ntae13))
+   RETURN
+ END IF
+ IF (x <= xmax) THEN
+   fn_val = EXP(-x) / x * (1._dp + dcsevl(8._dp/x-1._dp, ae14cs, ntae14))
+   RETURN
+ END IF
+ CALL xermsg('SLATEC', 'DE1', 'X SO BIG E1 UNDERFLOWS')
+ fn_val = 0._dp
+ RETURN
+ END FUNCTION de1
+ !DECK DEI
+ FUNCTION dei(x) RESULT(fn_val)
+ !***BEGIN PROLOGUE  DEI
+ !***PURPOSE  Compute the exponential integral Ei(X).
+ !***LIBRARY   SLATEC (FNLIB)
+ !***CATEGORY  C5
+ !***TYPE      REAL (dp) (EI-S, DEI-D)
+ !***KEYWORDS  EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
+ !             SPECIAL FUNCTIONS
+ !***AUTHOR  Fullerton, W., (LANL)
+ !***DESCRIPTION
+ ! DEI calculates the REAL (dp) exponential integral, Ei(X), for
+ ! positive REAL (dp) argument X and the Cauchy principal value
+ ! for negative X.  If principal values are used everywhere, then, for
+ ! all X,
+ !    Ei(X) = -E1(-X)
+ ! or
+ !    E1(X) = -Ei(-X).
+ !***REFERENCES  (NONE)
+ !***ROUTINES CALLED  DE1
+ !***REVISION HISTORY  (YYMMDD)
+ !   770701  DATE WRITTEN
+ !   891115  Modified prologue description.  (WRB)
+ !   891115  REVISION DATE from Version 3.2
+ !   891214  Prologue converted to Version 4.0 format.  (BAB)
+ !***END PROLOGUE  DEI
+ REAL (dp), INTENT(IN)  :: x
+ REAL (dp)              :: fn_val
+ !***FIRST EXECUTABLE STATEMENT  DEI
+ fn_val = -de1(-x)
+ RETURN
+ END FUNCTION dei
+ !DECK INITDS
+ FUNCTION initds(os, nos, eta) RESULT(ival)
+ !***BEGIN PROLOGUE  INITDS
+ !***PURPOSE  Determine the number of terms needed in an orthogonal
+ !            polynomial series so that it meets a specified accuracy.
+ !***LIBRARY   SLATEC (FNLIB)
+ !***CATEGORY  C3A2
+ !***TYPE      REAL (dp) (INITS-S, INITDS-D)
+ !***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
+ !             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
+ !***AUTHOR  Fullerton, W., (LANL)
+ !***DESCRIPTION
+ !  Initialize the orthogonal series, represented by the array OS, so that
+ !  INITDS is the number of terms needed to insure the error is no larger than
+ !  ETA.  Ordinarily, ETA will be chosen to be one-tenth machine precision.
+ !             Input Arguments --
+ !   OS     REAL (dp) array of NOS coefficients in an orthogonal series.
+ !   NOS    number of coefficients in OS.
+ !   ETA    single precision scalar containing requested accuracy of series.
+ !***REFERENCES  (NONE)
+ !***ROUTINES CALLED  XERMSG
+ !***REVISION HISTORY  (YYMMDD)
+ !   770601  DATE WRITTEN
+ !   890531  Changed all specific intrinsics to generic.  (WRB)
+ !   890831  Modified array declarations.  (WRB)
+ !   891115  Modified error message.  (WRB)
+ !   891115  REVISION DATE from Version 3.2
+ !   891214  Prologue converted to Version 4.0 format.  (BAB)
+ !   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+ !***END PROLOGUE  INITDS
+ REAL (dp), INTENT(IN)  :: os(:)
+ INTEGER, INTENT(IN)    :: nos
+ REAL (dp), INTENT(IN)  :: eta
+ INTEGER                :: ival
+ INTEGER    :: i, ii
+ REAL (dp)  :: ERR
+ !***FIRST EXECUTABLE STATEMENT  INITDS
+ IF (nos < 1) CALL xermsg('SLATEC', 'INITDS', 'Number of coefficients < 1')
+ ERR = 0.0_dp
+ DO  ii = 1, nos
+   i = nos + 1 - ii
+   ERR = ERR + ABS(os(i))
+   IF (ERR > eta) GO TO 20
+ END DO
+ 20 IF (i == nos) CALL xermsg('SLATEC', 'INITDS',  &
+     'Chebyshev series too short for specified accuracy')
+ ival = i
+ RETURN
+ END FUNCTION initds
+ 
+ SUBROUTINE xermsg(text1, text2, text3)
+ CHARACTER (LEN= *), INTENT(IN)  :: text1
+ CHARACTER (LEN= *), INTENT(IN)  :: text2
+ CHARACTER (LEN= *), INTENT(IN)  :: text3
+ WRITE(*, '(6a)') ' Error in call to ', text1, ' routine: ', text2, ' Mesg: ', text3
+ return
+ END SUBROUTINE xermsg
+ 
+ 
+ end module specialinf
diff -r -c -b -B -N cosmomc/params_CMB.paramnames cosmomc_fields/params_CMB.paramnames
*** cosmomc/params_CMB.paramnames	2009-09-17 17:47:04.000000000 +0200
--- cosmomc_fields/params_CMB.paramnames	2011-08-02 17:06:29.551648962 +0200
***************
*** 5,14 ****
  omegak        \Omega_K
  fnu           f_\nu		#neutrino energy density as fraction of omegadmh2
  w             w			#constant equation of state parameter for scalar field dark energy 
! ns            n_s		#beware that pivot scale can change in .ini file
! nt            n_t
! nrun          n_{run}
! logA          log[10^{10} A_s]
  r             r			#ratio of tensor to scalar primordial amplitudes at pivot scale
  asz           A_{SZ}		#SZ template amplitude, as in WMAP
  omegal*       \Omega_\Lambda
--- 5,20 ----
  omegak        \Omega_K
  fnu           f_\nu			#neutrino energy density as fraction of omegadmh2
  w             w				#constant equation of state parameter for scalar field dark energy 
! Aini	      A_{ini}			#initial conformal factor in the Einstein frame
! Xini	      \kappa\chi_{ini}		#initiai field value
! p	      p	     			#potential parameter p
! mu	      \mu			#potential parameter mu
! nu	      \nu			#potential parameter nu
! q 	      q				#potential parameter q
! lnR	      ln(R)			#reheating parameter
! Xend	      \kappa\chi_{uv}		#bound on fields values
! Xstop	      \kappa\chi_{stop}		#force inflation to stop at this fied value
! lnA           ln[10^{10} P_*]		#scalar power spectrum amplitude
  r             r		 		#ratio of tensor to scalar primordial amplitudes at pivot scale
  asz           A_{SZ}			#SZ template amplitude, as in WMAP
  omegal*       \Omega_\Lambda
***************
*** 18,20 ****
--- 24,30 ----
  zrei*         z_{re}
  r10*          r_{10}			#tensor-scalar C_l amplitude at l=10
  H0*           H_0			#hubble parameter is H0 km/s/Mpc
+ logM*	      log(\kappa M)		#potential normalisation
+ lnRrad*	      ln(R_{rad})		#derived reheating parameter ln(a_{end}/a_{reh}) - 1/4 ln(\rho_{reh}/\rho_{end})
+ lnzinf*	      ln(a_0/a_{end})		#redshit of the end of inflation
+ lnrhoinf*     ln(\kappa^4 \rho_{end})	#energy at the end of inflation
diff -r -c -b -B -N cosmomc/params.ini cosmomc_fields/params.ini
*** cosmomc/params.ini	2011-07-07 15:30:25.000000000 +0200
--- cosmomc_fields/params.ini	2011-08-02 16:21:36.858287075 +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
***************
*** 67,84 ****
  
  #use fast-slow parameter distinctions to speed up 
  #(note for basic models WMAP3 code is only ~3x as fast as CAMB)
! use_fast_slow = F
  
  #Can use covariance matrix for proposal density, otherwise use settings below
  #Covariance matrix can be produced using "getdist" program.
! propose_matrix = params_CMB.covmat
  
  #If propose_matrix is blank (first run), can try to use numerical Hessian to 
  #estimate a good propose matrix. As a byproduct you also get an approx best fit point
  estimate_propose_matrix = F
  
  #Tolerance on log likelihood to use when estimating best fit point
! delta_loglike = 2
  
  #Scale of proposal relative to covariance; 2.4 is recommended by astro-ph/0405462 for Gaussians
  #If propose_matrix is much broader than the new distribution, make proportionately smaller
--- 67,84 ----
  
  #use fast-slow parameter distinctions to speed up 
  #(note for basic models WMAP3 code is only ~3x as fast as CAMB)
! use_fast_slow = T
  
  #Can use covariance matrix for proposal density, otherwise use settings below
  #Covariance matrix can be produced using "getdist" program.
! #propose_matrix = params_CMB.covmat
  
  #If propose_matrix is blank (first run), can try to use numerical Hessian to 
  #estimate a good propose matrix. As a byproduct you also get an approx best fit point
  estimate_propose_matrix = F
  
  #Tolerance on log likelihood to use when estimating best fit point
! delta_loglike = 0.1
  
  #Scale of proposal relative to covariance; 2.4 is recommended by astro-ph/0405462 for Gaussians
  #If propose_matrix is much broader than the new distribution, make proportionately smaller
***************
*** 142,148 ****
  
  #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)
--- 142,148 ----
  
  #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)
***************
*** 159,164 ****
--- 159,167 ----
  #accuracy_level can be increased to check stability/higher accuracy, but inefficient
  accuracy_level = 1
  
+ #select the inflationary model
+ inflation_model = largef
+ 
  #If action = 1
  redo_likelihoods = T
  redo_theory = F
***************
*** 183,194 ****
  param[fnu] = 0 0 0 0 0
  param[w] = -1 -1 -1 0 0
  
! param[ns] = 0.95 0.5 1.5 0.02 0.01
! param[nt] = 0 0 0 0 0
! param[nrun] = 0 0 0 0 0
  
  #log[10^10 A_s]
! param[logA] = 3 2.7 4 0.01 0.01
! param[r] = 0 0 0 0 0
  #SZ amplitude, as in WMAP analysis
  param[asz]= 1 0 2 0.4 0.4
--- 186,218 ----
  param[fnu] = 0 0 0 0 0
  param[w] = -1 -1 -1 0 0
  
! #initial field values
! #dilaton
! param[Aini] = 1 1 1 0 0
! #matter field X (0 to use guessed values)
! param[Xini] = 0 0 0 0 0
! #potential parameters: mu = nu = 0 for large fields
! #p
! param[p] = 2 2 2 0 0
! #mu
! param[mu] = 0 0 0 0 0
! #nu
! param[nu] = 0 0 0 0 0
! #q
! param[q] = 1 1 1 0 0
! 
! #reheating correction
! #ln(aend/areh) + 1/4 ln(1/rhoreh) - 1/2 ln(1/rhoend)
! param[lnR] = 0 -46 15 10 10
! 
! #bound on field values (need checkBound=T)
! param[Xend] = 0 0 0 0 0
! 
! #end field values (needs checkStop=T)
! param[Xstop] = 0 0 0 0 0
  
  #log[10^10 A_s]
! param[lnA] = 3 2.7 4 0.01 0.01
! param[r] = 1 1 1 0 0
  #SZ amplitude, as in WMAP analysis
  param[asz]= 1 0 2 0.4 0.4
diff -r -c -b -B -N cosmomc/source/CMB_Cls_simple.f90 cosmomc_fields/source/CMB_Cls_simple.f90
*** cosmomc/source/CMB_Cls_simple.f90	2011-07-11 18:00:59.000000000 +0200
--- cosmomc_fields/source/CMB_Cls_simple.f90	2011-08-02 16:22:01.787112716 +0200
***************
*** 133,140 ****
        !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
             
--- 133,145 ----
        !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
             
***************
*** 251,258 ****
     Threadnum =num_threads
     call CMBToCAMB(CMB, P)
     P%OnlyTransfers = .false.
!    call SetCAMBInitPower(P,CMB,1)   
!     
     MatterOnly = .false.
     if (DoPk) then
        P%WantTransfer = .true.
--- 256,268 ----
     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.
***************
*** 465,470 ****
--- 475,484 ----
          if (use_BAO) P%want_zdrag = .true. !JH
          P%want_zstar = .false. !set to true if you want CAMB to calculate exact z_star
  
+ !fields
+         P%InitPower%infParam%name = InfModelName
+ !end fields
+ 
          if (CMB_Lensing) then
              P%DoLensing = .true.
              P%Max_l = lmax +100 + 50 !+50 in case accuracyBoost>1 and so odd l spacing
diff -r -c -b -B -N cosmomc/source/driver.F90 cosmomc_fields/source/driver.F90
*** cosmomc/source/driver.F90	2011-07-07 15:26:52.000000000 +0200
--- cosmomc_fields/source/driver.F90	2011-08-02 16:25:08.738306057 +0200
***************
*** 56,67 ****
          end if
  
  #ifdef MPI 
! 
!         if (instance /= 0) call DoAbort('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 DoAbort('MPI fail')
  
--- 56,74 ----
          end if
  
  #ifdef MPI 
! !fields
! !        if (instance /= 0) call DoAbort('With MPI should not have second parameter')
!         instance_shift=instance
!         write(*,*)'MPI file names shifted by: ',instance_shift
! !end fields
          call mpi_comm_rank(mpi_comm_world,MPIrank,ierror)
  
          instance = MPIrank +1 !start at 1 for chains                                             
! !fields
!         !write (numstr,*) instance
!         instance_shift = MPIrank + instance_shift
!         write (numstr,*) instance_shift
! !end fields        
          rand_inst = instance
          if (ierror/=MPI_SUCCESS) call DoAbort('MPI fail')
  
***************
*** 102,108 ****
  
          HighAccuracyDefault = Ini_Read_Logical('high_accuracy_default',.false.)
          AccuracyLevel = Ini_Read_Real('accuracy_level',1.)
!         
          if (Ini_HasKey('highL_unlensed_cl_template')) &
            highL_unlensed_cl_template=  ReadIniFilename(DefIni,'highL_unlensed_cl_template')
  
--- 109,117 ----
  
          HighAccuracyDefault = Ini_Read_Logical('high_accuracy_default',.false.)
          AccuracyLevel = Ini_Read_Real('accuracy_level',1.)
! !fields
!         InfModelName = Ini_Read_String('inflation_model')
! !end fields
          if (Ini_HasKey('highL_unlensed_cl_template')) &
            highL_unlensed_cl_template=  ReadIniFilename(DefIni,'highL_unlensed_cl_template')
  
diff -r -c -b -B -N cosmomc/source/GetDist.f90 cosmomc_fields/source/GetDist.f90
*** cosmomc/source/GetDist.f90	2011-07-11 18:00:59.000000000 +0200
--- cosmomc_fields/source/GetDist.f90	2011-08-02 16:25:24.607558534 +0200
***************
*** 104,109 ****
--- 104,135 ----
          integer Num_ComparePlots
          logical ::   prob_label = .false.      
              
+ !addon
+ !exact field model
+         logical, parameter :: findMaxValues = .false.
+         logical, parameter :: mapRhoReh = .false.
+         logical, parameter :: mapLFPowerToWreh = .true.
+ 
+ !slow-roll analysis
+         logical, parameter :: adjEps1ToLog = .false.
+         logical, parameter :: extractHinf = .false.
+         logical, parameter :: mapnslogr = .true.
+         logical, parameter :: use2ndSR=.true.        
+         real, parameter :: ln10p5HinfCut=-10
+         real, parameter :: logrCut=-3.7
+ 
+ #ifdef SRREHEAT
+         logical, parameter :: doReheatFromSr = .false.
+         character(len=*), parameter :: reheatModel='smallf'
+ #endif
+ 
+         real, parameter :: wfix = -0.3
+         real, parameter :: pmax = 15, pmin = 0
+         real, parameter :: logmumax=10
+ !end addon
+ 
+ 
+     
  contains
  
    subroutine AdjustPriors
***************
*** 111,118 ****
     !Be careful as this code is parameterisation dependent
     integer i
     real ombh2, chisq 
   
!    stop 'You need to write the AdjustPriors subroutine in GetDist.f90 first!'
    
  !   write (*,*) 'Adjusting priors'
  !   do i=0, nrows-1
--- 137,156 ----
     !Be careful as this code is parameterisation dependent
     integer i
     real ombh2, chisq 
+ !addon
+    integer, parameter :: dp = kind(1._8)
+    real(dp) :: eps1,logeps1,eps2,eps3, lnR,lnRrad
+    real(dp) :: wreh,p,logmu,lnRhoReh,lnRhoEnd   
+ 
+    real :: ln10p5HinfMin=1e30
+    real :: ln10p5HinfMax=-1e30
+    
+    real :: lnRhoRehmax = -1e30, lnRhoEndMax=-1e30, lnRmax = -1e30, lnRradmax = -1e30
+ 
+    real, parameter :: lnRhoNuc = -187.747
   
! !   stop 'You need to write the AdjustPriors subroutine in GetDist.f90 first!'
! !end addon 
    
  !   write (*,*) 'Adjusting priors'
  !   do i=0, nrows-1
***************
*** 124,129 ****
--- 162,375 ----
  !    
  !   end do
  
+ !addon
+    wreh = wfix
+ 
+    
+    if (findMaxValues) then
+       print *,'-->computing maximum values in chains'
+ 
+       do i=0,nrows-1
+          lnR = coldata(14+2,i)
+          lnRhoEnd = coldata(2+30,i)
+          lnRrad = coldata(2+28,i)
+          lnRhoEndMax = max(lnRHoEndMax,lnRhoEnd)
+          lnRmax = max(lnRmax, lnR)
+          lnRradmax = max(lnRradmax, lnRrad)
+       enddo
+ 
+       print *,'lnRhoEndMax= ',lnRhoEndMax
+       print *,'lnRradMax= lnRmax= ',lnRradMax, lnRmax
+    endif
+ 
+    if (mapRhoReh) then
+       print *,'--> rejecting all p <',pmin
+       print *,'--> rejecting all logmu >',logmumax
+       print *,'--> rejecting all lnRhoNuc > lnRhoReh > lnRhoEnd'
+ 
+       do i=0,nrows-1
+          p = coldata(2+10,i)
+          logmu = coldata(11+2,i)
+ 
+          if (mapLFPowerToWreh) wreh = (p-2._dp)/(p+2._dp)
+ 
+          lnR = coldata(14+2,i)
+          lnRrad = coldata(2+28,i)
+          lnRhoReh = coldata(27+2,i)
+          lnRhoEnd = coldata(2+30,i)
+          
+          if ((wreh.lt.-1._dp/3._dp) &
+               .or.(p.lt.pmin).or.(logmu.gt.logmumax) &
+               .or.(lnRhoReh.gt.lnRhoEnd) &
+               .or.(lnRhoReh.lt.lnRhoNuc)) then
+             chisq = 1e30
+             coldata(1,i) = 0.
+             coldata(2,i) = coldata(2,i) + chisq/2
+          else
+             lnRhoRehMax = max(lnRHoRehMax,lnRhoReh)                          
+             lnRhoEndMax = max(lnRHoEndMax,lnRhoEnd)
+             lnRmax = max(lnRmax, lnR)
+             lnRradmax = max(lnRradmax, lnRrad)
+          endif
+ 
+       enddo
+       print *,'Max values after applying prior!'
+       print *,'lnRhoEndMax= ',lnRhoEndMax
+       print *,'lnRhoRehMax= ',lnRhoRehMax      
+       print *,'lnRradMax= lnRmax= ',lnRradMax, lnRmax
+    endif
+       
+    if (adjEps1ToLog) then
+       print *,'----> assumed mapped log(eps1) in col 8'
+       print *,'----> from flat eps1 to flat log(eps1)'
+       read(*,*)
+       do i=0, nrows-1
+          
+          logeps1 = coldata(8+2,i)
+          eps1 = 10.**logeps1
+          
+          coldata(1,i) = coldata(1,i)/(eps1*log(10.))
+          coldata(2,i) = coldata(2,i) 
+ 
+       end do
+    endif
+ 
+ 
+ 
+    if (extractHinf) then
+ 
+       write (*,*)'Computing and adjusting  bounds for ln(10^5 Hinf/mpl) in 17!'
+       
+       do i=0,nrows-1
+          ln10p5HinfMax = max(ln10p5HinfMax,coldata(2+17,i))
+          ln10p5HinfMin = min(ln10p5HinfMin,coldata(2+17,i))         
+ 
+          if (coldata(2+17,i).lt.ln10p5HinfCut) then
+             chisq = 1e30
+             coldata(1,i) = 0.
+             coldata(2,i) = coldata(2,i) + chisq/2
+          endif
+ 
+       enddo
+                
+       write(*,*)'----> ln(10^5 Hinf) Min= Max= ',ln10p5HinfMin,ln10p5HinfMax
+ 
+    endif
+ 
+    if (mapnslogr) then
+ 
+       write (*,*)'Adjusting  bounds for log(r) in 14!'
+ 
+       do i=0,nrows-1
+          
+          if (coldata(2+14,i).lt.logrCut) then
+             chisq = 1e30
+             coldata(1,i) = 0.
+             coldata(2,i) = coldata(2,i) + chisq/2
+          endif
+ 
+       enddo
+    endif
+ 
+ #ifdef SRREHEAT
+    if (doReheatFromSR) then
+       write(*,*)'Adjusting prior for reheat SR analysis'
+ 
+       select case (reheatModel)
+ 
+       case ('largef')
+         
+         
+          do i=0,nrows-1
+             
+             eps1 = 10**(coldata(2+8,i))
+             eps2 = coldata(2+9,i)
+             p = coldata(2+14,i)
+             wreh = (p-2.)/(p+2.)
+ 
+ !large field models cannot produce eps2<=0 (out of prior)
+             if ((eps2.le.0.).or.(p.gt.pmax).or.(p.lt.pmin)) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2
+             endif
+ 
+ !reheating is after end of inflation
+             lnRhoReh = coldata(11+2,i)
+             lnRhoEnd = coldata(12+2,i)
+ 
+ !            print *,'lnrhoreh end=',lnRhoReh,lnRhoEnd,eps1,eps2
+ 
+             if (wreh.lt.-1./3.) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2
+             endif
+             if (lnRhoReh.gt.lnRhoEnd) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2
+             endif
+             if (lnRhoReh.lt.lnRhoNuc) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2            
+             endif
+          enddo
+          
+       case ('smallf')
+ 
+          wreh = wfix
+                  
+          do i=0,nrows-1
+             
+             eps1 = 10**(coldata(2+8,i))
+             eps2 = coldata(2+9,i)
+             eps3 = coldata(2+10,i)
+ 
+             p = coldata(2+14,i)            
+ 
+ 
+ !small field models (out of prior)
+             if (.not.(sr_checkobs_sf(eps1,eps2,eps3)) &
+                  .or.(p.gt.pmax).or.(p.lt.pmin)) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2
+             endif
+ 
+ 
+ !reheating is after end of inflation
+             lnRhoReh = coldata(11+2,i)
+             lnRhoEnd = coldata(12+2,i)
+ 
+             if (wreh.lt.-1./3.) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2
+             endif
+             if (lnRhoReh.gt.lnRhoEnd) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2
+             endif
+             if (lnRhoReh.lt.lnRhoNuc) then
+                chisq = 1e30
+                coldata(1,i) = 0.
+                coldata(2,i) = coldata(2,i) + chisq/2            
+             endif
+          enddo
+          
+       end select
+ 
+       
+    endif
+ #endif
+ !end addon
+ 
+ 
+ 
+ 
    end subroutine AdjustPriors
  
    subroutine MapParameters(invars)
***************
*** 131,137 ****
  ! map parameters in invars: eg. invars(3)=invars(3)*invars(4) 
  
  !    invars(2+13)=invars(17+2)*exp(-invars(2+4)) 
!     stop 'Need to write MapParameters routine first'  
    
    end subroutine MapParameters
  
--- 377,570 ----
  ! map parameters in invars: eg. invars(3)=invars(3)*invars(4) 
  
  !    invars(2+13)=invars(17+2)*exp(-invars(2+4)) 
! 
! 
! !addon
!     integer, save :: counter = 0
!     real :: lnR, lnRhoReh,lnRhoEnd, ns,logr
!     real :: cseps1,eps1mdel1,eps2pdel1,del1
!     real :: as0,ln10p5Hinf
!     real, parameter :: C_const = -0.7296
! 
!     integer, parameter :: dp=kind(1._8)
!     real(dp) :: p, mu, wreh, Pstar,bfold,eps1,eps2,eps3
!     real(dp), dimension(2) :: buffer2D
!     real(dp), dimension(3) :: buffer3D
!         
! 
!     counter = counter + 1
! 
!     if (mapRhoReh) then
! 
!        if (mapLFPowerToWreh) then
!           
!           p = invars(2+10)
!           wreh = (p-2._dp)/(p+2._dp)
!           
!           if (counter.eq.1) print *,'reheat marginalisation on p in col10'
!        else
!           
!           wreh = wfix
!           if (counter.eq.1) print *,'marginalising at fixed wreh= ',wreh
!           
!        endif
!        
!        if (wreh.eq.1./3.) stop 'Treh inversion is singular!'
!        
!        if (counter.eq.1) print *,'mapping lnR -> lnRhoReh in col27'
! 
!        lnR = invars(2+14)
!        
!        lnRhoEnd = invars(2+30)
! 
!        lnRhoReh = 4._dp*((1._dp+wreh)/(1._dp/3._dp-wreh))*lnR &
!             - 4._dp*(1._dp/3._dp + wreh)/(1._dp/3._dp - wreh)*lnRhoEnd/2._dp
!        
!        invars(27+2)=lnRhoReh
! 
!     end if
!     
! 
!     if (extractHinf) then
!        del1 = 0.
! 
!        if (counter.eq.1) print *,'assumiing 10**(col10) is eps1'
! 
!        eps1mdel1 = 10**invars(2+8)
!        eps2pdel1 = invars(2+9)
!        eps1 = eps1mdel1
!        eps2 = eps2pdel1
!        eps3 = invars(2+10)
! 
! 
!        cseps1=eps1mdel1
! !       cseps1 = eps1/invars(2+15)
! !       cseps1= 10.**invars(2+15)
! 
! !       eps1 = 10.**invars(2+8)
! !       eps2 = invars(2+9)
! !       eps3 = invars(2+10)
! 
! 
! 
!        as0 = 1. + eps1mdel1*(-2.*(C_const+1.)) - eps2pdel1*C_const
! 
!        if (use2ndSR) then
!           if (counter.eq.1) print *,'using 2nd order slow-roll!'
!           as0 = as0 + eps1*eps1 * (2.*C_const**2 + 2.*C_const + pi**2/2. - 5.) &
!                + eps1*eps2 * (C_const**2 - C_const + 7.*pi**2/12. - 7.) &
!                + eps2*eps2 * (0.5*C_const**2 + pi**2/8. - 1.) &
!                + eps2*eps3 * (-0.5*C_const**2 + pi**2/24.)
!        endif
!        
!        ln10p5Hinf = + 0.5*invars(2+16) &
!             + 0.5*log(3.141592653589793238*cseps1) - 0.5*log(as0)
!        
! 
!        invars(2+17) = ln10p5Hinf
!     endif
! 
!     if (mapnslogr) then
!        
!        if (counter.eq.1) then          
!           print *,'assumiing 10**(col10) is eps1'
!           print *,'Mapping ns --> col15 & logr --> col14'
!        endif
! 
!        eps1 = 10**invars(2+8)
!        eps2 = invars(2+9)
!        eps3 = invars(2+10)
! 
!        ns = 1 - 2.*eps1 - eps2
!        logr = log10(16*eps1)
! 
!        if (use2ndSR) then
!           if (counter.eq.1) print *,'using 2nd order slow-roll!'
!           ns = ns - 2*eps1**2 - (2*C_const + 3)*eps1*eps2 - C_const*eps2*eps3
!           logr = logr + log10(1 + C_const*eps2)
!        endif
! 
!        invars(2+14) = logr
!        invars(2+15) = ns
!       
!     endif
!        
! 
! #ifdef SRREHEAT
!     if (doReheatFromSR) then
! 
!        if (counter.eq.1) then
!           write(*,*)'************************************************'
!           write(*,*)'Model is: ',reheatModel
!           write(*,*)'Doing Reheating analysis from SR:'
!           write(*,*)'Mapping lnRhoReh -> col11 & lnRhoEnd -> col12'
!           write(*,*)'& -N* -> col13 & p -> col14 & mu -> col15'
!           write(*,*)'************************************************'
!        endif
!           
!        Pstar = exp(invars(2+16))*1.e-10
!              
!        eps1 = 10**(invars(2+8))
!        eps2 = invars(2+9)
!        eps3 = invars(2+10)
!        
!        lnRhoReh = 0.
!        lnRhoEnd = 0.
!        bfold=0.
! 
!        select case(reheatModel)
!           
!        case ('largef')
!                                                    
! !large field models cannot produce eps2<=0 (out of prior)
!           if (eps2.le.0.) return
! 
!           buffer2d = sr_matter_obs_lf(eps1,eps2)
! 
!           p = buffer2d(1)
!           invars(15+2)=p
! 
!           if ((p.gt.pmax).or.(p.lt.pmin)) return
! 
!           lnRhoReh = sr_lnrhoreh_lf(wreh,eps1,eps2,Pstar,bfold)
!           lnRhoEnd = sr_lnrhoend_lf(p,Pstar)
! 
!           invars(11+2)=lnRhoReh
!           invars(12+2)=lnRhoEnd
!           invars(13+2)=bfold
!          
!        case ('smallf')
! 
! !small field models cannot produce any eps1,eps2,eps3<=0 (out of prior)
!           if (.not.sr_checkobs_sf(eps1,eps2,eps3)) return
!           
!           buffer3d = sr_matterovermu_obs_sf(eps1,eps2,eps3)
! 
!           p = buffer3d(1)
!           mu = buffer3d(2)
!           wreh = wfix
! 
!           invars(14+2)=p
!           invars(15+2)=mu
! 
!           if ((p.gt.pmax).or.(p.lt.pmin)) return
! 
!           lnRhoReh = sr_lnrhoreh_sf(wreh,eps1,eps2,eps3,Pstar,bfold)
!           lnRhoEnd = sr_lnrhoend_sf(p,mu,Pstar)
! 
!           invars(11+2) = lnRhoReh
!           invars(12+2) = lnRhoEnd
!           invars(13+2) = bfold
! 
!        case default
! 
!           stop 'model not implemented!'
! 
!        end select
! 
!     endif
! #endif
! !end addon
    
    end subroutine MapParameters
  
diff -r -c -b -B -N cosmomc/source/Makefile cosmomc_fields/source/Makefile
*** cosmomc/source/Makefile	2011-07-11 18:00:59.000000000 +0200
--- cosmomc_fields/source/Makefile	2011-08-02 16:28:13.819588030 +0200
***************
*** 1,119 ****
! #You may need to edit the library paths for MKL for Intel
! #Beware of using optmizations that lose accuracy - may give errors when running
  
- ##Uncomment the next line to include dr7 LRG
- EXTDATA =
- #EXTDATA = LRG
- 
- #set WMAP empty not to compile with WMAP
- WMAP = /home/aml1005/WMAP7/likelihood_v4
- 
- #Only needed for WMAP
- cfitsio = /usr/local/cfitsio/intel10/64/3.040
- 
- #GSL only needed for DR7 LRG
- GSLPATH = /home/aml1005/libs/gsl
- 
- IFLAG = -I
- INCLUDE=
- 
- #Intel MPI (assuming mpif77 set to point to ifort)
- #these settings for ifort 11.1 and higher; may need to add explicit link directory otherwise
- F90C     = mpif90
- FFLAGS = -O2 -ip -W0 -WB -openmp -fpp -DMPI -vec_report0 -mkl=parallel
- LAPACKL = -lmkl_lapack
- 
- #HPCF settings. Use Inteal 9 or 10.1+, not 10.0
- #F90C     = mpif90
- #FFLAGS = -O2 -Vaxlib -W0 -WB -openmp -fpp -DMPI -vec_report0
- #LAPACKL = -L/usr/local/Cluster-Apps/intel/mkl/10.2.2.025/lib/em64t -lmkl_lapack -lmkl -lguide -lpthread
- #GSLPATH = /usr/local/Cluster-Apps/gsl/1.9
- #cfitsio = /usr/local/Cluster-Users/cpac/cmb/2.1.0/cfitsio
- #INCLUDE=
- 
- #COSMOS: use "module load cosmolib latest"
- #use "runCosmomc" (globally installed) to run, defining required memory usage
- ifeq ($(COSMOHOST),cosmos)
- F90C = ifort
- FFLAGS = -openmp -O3 -w -fpp2 -DMPI
- LAPACKL = -mkl=sequential -lmkl_lapack -lmpi
- cfitsio = $(CFITSIO)
- WMAP = $(COSMOLIB)/WMAP7
- GSLPATH = $(GSL_ROOT)
- endif
- 
- #Intel fortran 8, check you have the latest update from the Intel web pages
- #See Makefile_intel for ifc 7.1 or lower (some versions have problems)
- #F90C     = ifort
- #FFLAGS = -O2 -Vaxlib -ip -W0 -WB -openmp -fpp
- #LAPACKL = -L/opt/intel/mkl61/lib/32 -lmkl_lapack -lmkl_ia32 -lguide -lpthread
- 
- #G95; make sure LAPACK and MPI libs also compiled with g95
- #F90C     = mpif90
- #FFLAGS = -O2 -cpp -DMPI
- #LAPACKL = /LAPACK/lapack_LINUX.a /LAPACK/blas_LINUX.a
- 
- #GFortran: if pre v4.3 add -D__GFORTRAN__
- #F90C     = gfortran
- #FFLAGS = -O2 -ffree-form -x f95-cpp-input
- #LAPACKL = -Wl,-framework -Wl,accelerate
- #may need to delete -Wl,accelerate, and/or add -shared
- 
- #SGI, -mp toggles multi-processor. Use -O2 if -Ofast gives problems.
- #Not various versions of the compiler are buggy giving erroneous seg faults with -mp.
- #Version 7.3 is OK, currently version 7.4 is bugged, as are some earlier versions.
- #F90C     = f90
- #LAPACKL = -lcomplib.sgimath
- #FFLAGS  = -Ofast -mp
- 
- #Digital/Compaq fortran, -omp toggles multi-processor
- #F90C    = f90
- #FFLAGS  = -omp -O4 -arch host -math_library fast -tune host -fpe1
- #LAPACKL  = -lcxml
- 
- #Absoft ProFortran, single processor, set -cpu:[type] for your local system
- #F90C     = f95
- #FFLAGS = -O2 -s -cpu:athlon -lU77 -w -YEXT_NAMES="LCS" -YEXT_SFX="_"
- #LAPACKL =  -llapack -lblas -lg2c
- #IFLAG = -p
- 
- #NAGF95, single processor:
- #F90C     = f95
- #FFLAGS = -DNAGF95 -O3
- #LAPACKL = -llapack -lblas -lg2c
- 
- #PGF90
- #F90C = pgf90
- #FFLAGS = -O2 -DESCAPEBACKSLASH
- #LAPACKL = -llapack -lblas
- 
- 
- #Sun, single processor:
- #F90C     = f90
- #FFLAGS = -fast -ftrap=%none
- #LAPACKL = -lsunperf -lfsu
- #LAPACKL = -lsunperf -lfsu -lsocket -lm
- #IFLAG = -M
- 
- #Sun MPI
- #F90C = mpf90
- #FFLAGS =  -O4 -openmp -ftrap=%none -dalign -DMPI
- #LAPACKL = -lsunperf -lfsu -lmpi_mt
- #IFLAG = -M
- 
- #Sun parallel enterprise:
- #F90C     = f95
- #FFLAGS =  -O4 -xarch=native64 -openmp -ftrap=%none
- #LAPACKL = -lsunperf -lfsu
- #IFLAG = -M
- 
- 
- #IBM XL Fortran, multi-processor (run "module load lapack" then run "gmake")
- # See also http://cosmocoffee.info/viewtopic.php?t=326
- #F90C     = xlf90_r $(LAPACK)
- #FFLAGS  = -WF,-DIBMXL -qsmp=omp -qsuffix=f=f90:cpp=F90 -O3 -qstrict -qarch=pwr3 -qtune=pwr3
- #INCLUDE = -lessl
- #LAPACKL =
  
  PROPOSE = propose.o
  CLSFILE = CMB_Cls_simple.o
--- 1,83 ----
! # >>> DESIGNED FOR GMAKE <<<
! 
! # Unified Systems makefile for COSMOMC
! # Add FLAGS -DMPI for using MPI
! 
! ext=$(shell uname | cut -c1-3)
! 
! CC=cc
! 
! ifeq ($(ext),IRI)
! F90C= f90
! FFLAGS= -Ofast -mp -n32 -LANG:recursive=ON -lmpi -DMPI
! WMAPFLAGS= $(FFLAGS)
! LAPACKL = -lcomplib.sgimath_mp
! INCLUDE = -I../camb
! CFITSIODIR = /people/ringeval/usr
! GSLDIR =
! endif
! 
! ifeq ($(ext),Lin)
! F90C=gfortran
! FFLAGS= -O -cpp -fopenmp
! WMAPFLAGS= -O
! LAPACKL = -llapack
! INCLUDE = -I../camb 
! CFITSIODIR = /opt/gnu/cfitsio
! GSLDIR = /usr
! endif 
! 
! ifeq ($(ext),OSF)
! F90C=f90
! FFLAGS= -omp -O -arch host -math_library fast -tune host -fpe1
! WMAPFLAGS= $(FFLAGS)
! LAPACKL  = -lcxml
! INCLUDE = -I../camb 
! CFITSIODIR = 
! GSLDIR =
! endif
! 
! ifeq ($(ext),Sun)
! F90C=f90
! FFLAGS= -O4 -xarch=native64 -openmp -ftrap=%none
! WMAPFLAGS= $(FFLAGS)
! LAPACKL = -lsunperf -lfsu
! INCLUDE = -I../camb -M../camb
! CFITSIODIR = 
! GSLDIR =
! endif
! 
! ifeq ($(ext),AIX)
! F90C    = mpxlf90_r
! FFLAGS  = -O4 -WF,-DIBMXL,-DMPI -qstrict -qsmp=omp -qmaxmem=-1 -qsuffix=f=f90:cpp=F90
! WMAPFLAGS= $(FFLAGS)
! LAPACKL = -lessl
! INCLUDE = -I../camb
! CFITSIODIR = 
! GSLDIR =
! endif
! 
! EXTDATA = LRG
! EXTINCLUDE = -I$(GSLDIR)/include
! EXTOBJS = bsplinepk.o
! 
! 
! WMAPDIR = ../WMAP
! WMAPINCLUDE = -I$(CFITSIODIR)/include
! WMAPOBJS = read_archive_map.o \
! 	read_fits.o \
! 	healpix_types.o \
! 	br_mod_dist.o \
! 	WMAP_7yr_options.o \
! 	WMAP_7yr_util.o \
! 	WMAP_7yr_gibbs.o \
! 	WMAP_7yr_tt_pixlike.o \
! 	WMAP_7yr_tt_beam_ptsrc_chisq.o \
! 	WMAP_7yr_teeebb_pixlike.o \
! 	WMAP_7yr_tetbeebbeb_pixlike.o \
! 	WMAP_7yr_likelihood.o
! 
  
  
  PROPOSE = propose.o
  CLSFILE = CMB_Cls_simple.o
***************
*** 121,133 ****
  #Can use params_H if you prefer more generic parameters
  PARAMETERIZATION = params_CMB.o
  
! F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(IFLAG)../camb $(INCLUDE)
! LINKFLAGS = -L../camb -lcamb $(LAPACKL)
  
! DISTFILES = ParamNames.o Matrix_utils.o settings.o IO.o GetDist.o
  
! OBJFILES=  ParamNames.o Matrix_utils.o settings.o IO.o cmbtypes.o Planck_like.o  \
! 	cmbdata.o WeakLen.o bbn.o bao.o lrggettheory.o mpk.o supernovae.o HST.o SDSSLy-a-v3.o \
  	$(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \
  	conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o
  
--- 85,100 ----
  #Can use params_H if you prefer more generic parameters
  PARAMETERIZATION = params_CMB.o
  
! LINKFLAGS =  -L../camb -lcamb -linf $(LAPACKL)
  
! F90FLAGS = -DMATRIX_SINGLE $(FFLAGS) $(INCLUDE)
  
! DISTFILES = ParamNames.o Matrix_utils.o settings.o GetDist.o
! 
! 
! 
! OBJFILES = ParamNames.o Matrix_utils.o settings.o IO.o cmbtypes.o Planck_like.o \
! 	cmbdata.o WeakLen.o bbn.o bao.o lrggettheory.o mpk.o supernovae.o HST.o SDSSLy-a-v3.o\
  	$(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \
  	conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o
  
***************
*** 131,166 ****
  	$(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \
  	conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o
  
- 
  ifeq ($(EXTDATA),LRG)
  F90FLAGS += -DDR71RG
! OBJFILES += bsplinepk.o
! GSLINC = -I$(GSLPATH)/include
! LINKFLAGS += -L$(GSLPATH)/lib -lgsl -lgslcblas
! endif
! 
! ifneq ($(WMAP),)
! F90FLAGS += $(IFLAG)$(cfitsio)/include $(IFLAG)$(WMAP)
! LINKFLAGS +=  -L$(cfitsio)/lib -L$(WMAP) -lcfitsio
! 
! OBJFILES += $(WMAP)/read_archive_map.o \
! 	$(WMAP)/read_fits.o \
! 	$(WMAP)/healpix_types.o \
! 	$(WMAP)/WMAP_7yr_options.o \
! 	$(WMAP)/WMAP_7yr_util.o \
! 	$(WMAP)/WMAP_7yr_tt_pixlike.o \
! 	$(WMAP)/WMAP_7yr_teeebb_pixlike.o \
! 	$(WMAP)/WMAP_7yr_likelihood.o \
! 	$(WMAP)/WMAP_7yr_gibbs.o \
! 	$(WMAP)/WMAP_7yr_tt_beam_ptsrc_chisq.o \
! 	$(WMAP)/br_mod_dist.o
  else
  F90FLAGS += -DNOWMAP
  endif
  
- default: cosmomc
  
! all : cosmomc getdist
  
  settings.o: ../camb/libcamb.a
  cmbtypes.o: settings.o
--- 98,124 ----
  	$(CLSFILE) paramdef.o $(PROPOSE) $(PARAMETERIZATION) calclike.o \
  	conjgrad_wrapper.o EstCovmat.o postprocess.o MCMC.o driver.o
  
  ifeq ($(EXTDATA),LRG)	
  F90FLAGS += -DDR71RG
! EXTINCLUDE = -I$(GSLDIR)/include
! LINKFLAGS += -lgsl -lgslcblas
! OBJFILES += $(EXTOBJS)
! endif	
! 
! ifneq ($(WMAPDIR),)
! F90FLAGS += $(WMAPINCLUDE)
! LINKFLAGS += -L$(CFITSIODIR)/lib -lcfitsio
! OBJFILES += $(WMAPOBJS)
  else
  F90FLAGS += -DNOWMAP
  endif
  
  
! 
! default: cosmomc.$(ext)
! 
! all : cosmomc.$(ext) getdist.$(ext)
! 
  
  settings.o: ../camb/libcamb.a
  cmbtypes.o: settings.o
***************
*** 184,197 ****
  MCMC.o: calclike.o
  driver.o: MCMC.o
  
- export FFLAGS
- export F90C
- 
  .f.o:
  	f77 $(F90FLAGS) -c $<
  
  %.o: %.c
! 	$(CC) $(GSLINC) -c $*.c
  
  %.o: %.f90
  	$(F90C) $(F90FLAGS) -c $*.f90
--- 142,159 ----
  MCMC.o: calclike.o
  driver.o: MCMC.o
  
  .f.o:
  	f77 $(F90FLAGS) -c $<
  
  %.o: %.c
! 	$(CC) $(EXTINCLUDE) -c $*.c
! 
! %.o: $(WMAPDIR)/%.f90
! 	$(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $<
! 
! %.o: $(WMAPDIR)/%.F90
! 	$(F90C) $(WMAPFLAGS) $(WMAPINCLUDE) -c $<
! 
  
  %.o: %.f90
  	$(F90C) $(F90FLAGS) -c $*.f90
***************
*** 200,218 ****
  	$(F90C) $(F90FLAGS) -c $*.F90
  
  
! cosmomc: camb $(OBJFILES)
! 	$(F90C) -o ../cosmomc $(OBJFILES) $(LINKFLAGS) $(F90FLAGS)
! 
  
- clean: cleancosmomc
- 	rm -f ../camb/*.o ../camb/*.obj ../camb/*.mod
  
! cleancosmomc:
  	rm -f *.o *.mod *.d *.pc *.obj ../core
  
  
- getdist: camb $(DISTFILES)
- 	$(F90C) -o ../getdist $(DISTFILES) $(LINKFLAGS) $(F90FLAGS)
  
- camb:
- 	cd ../camb && $(MAKE) --file=Makefile_main libcamb.a
--- 162,175 ----
  	$(F90C) $(F90FLAGS) -c $*.F90
  
  
! cosmomc.$(ext): $(OBJFILES) ../camb/libcamb.a ../camb/libinf.a
! 	$(F90C) -o ../$@ $(OBJFILES) $(LINKFLAGS) $(F90FLAGS)
  
  
! clean:
  	rm -f *.o *.mod *.d *.pc *.obj ../core
  
+ getdist.$(ext): $(DISTFILES)
+ 	$(F90C) -o ../$@ $(DISTFILES) $(LINKFLAGS) $(F90FLAGS) 
  
  
diff -r -c -b -B -N cosmomc/source/MCMC.f90 cosmomc_fields/source/MCMC.f90
*** cosmomc/source/MCMC.f90	2010-05-10 17:28:00.000000000 +0200
--- cosmomc_fields/source/MCMC.f90	2011-08-02 16:25:36.646991418 +0200
***************
*** 215,221 ****
    
      Like = GetLogLike(grid(r))
     
!     if (Feedback > 1) write (*,*) r, 'Likelihood: ', Like, 'Current Like:', CurLike
  
      if ((Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike)) then
      !Accept
--- 215,221 ----
    
      Like = GetLogLike(grid(r))
     
!     if (Feedback > 1) write (*,*) r, 'Likelihood: ', Like, 'Current Like:', CurLike, 'Rank', MPIRank
  
      if ((Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike)) then
      !Accept
***************
*** 501,507 ****
             output_lines = output_lines +1
             call WriteParams(CurParams, real(mult), CurLike)
            end if
!           if (Feedback > 1) write (*,*) instance, 'Slicing, Current Like:', CurLike
            mult = 1
            if (num_slow /=0) call SliceSampleSlowParam(CurParams, CurLike) 
            if (num_fast /=0) call SliceSampleFastParams(CurParams, CurLike) 
--- 501,507 ----
             output_lines = output_lines +1
             call WriteParams(CurParams, real(mult), CurLike)
            end if
!           if (Feedback > 1) write (*,*) instance, 'Slicing, Current Like:', CurLike, 'Rank', MPIRank
            mult = 1
            if (num_slow /=0) call SliceSampleSlowParam(CurParams, CurLike) 
            if (num_fast /=0) call SliceSampleFastParams(CurParams, CurLike) 
***************
*** 536,542 ****
  
      Like = GetLogLike(Trial) 
  
!     if (Feedback > 1) write (*,*) 'Likelihood: ', Like, 'Current Like:', CurLike
  
  !!!    accpt = (Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike) 
               !Include the min() so that compilers not doing optimal compilation don't complain
--- 536,542 ----
  
      Like = GetLogLike(Trial) 
  
!     if (Feedback > 1) write (*,*) 'Likelihood: ', Like, 'Current Like:', CurLike,  'Rank', MPIRank
  
  !!!    accpt = (Like /= logZero) .and. (CurLike > Like .or. randexp1() > Like - CurLike) 
               !Include the min() so that compilers not doing optimal compilation don't complain
diff -r -c -b -B -N cosmomc/source/params_CMB.f90 cosmomc_fields/source/params_CMB.f90
*** cosmomc/source/params_CMB.f90	2011-07-11 18:00:59.000000000 +0200
--- cosmomc_fields/source/params_CMB.f90	2011-08-02 16:37:05.034568607 +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, firsttime)
--- 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, firsttime)
***************
*** 141,147 ****
       real DA
       real  D_b,D_t,D_try,try_b,try_t, CMBToTheta, lasttry,tau
       external CMBToTheta
! 
       if (all(Params(1:num_hard) == Lastparams(1:num_hard))) then
         call SetForH(Params,CMB,LastH0, .true.)
         CMB%zre = Lastzre
--- 186,194 ----
       real DA
       real  D_b,D_t,D_try,try_b,try_t, CMBToTheta, lasttry,tau
       external CMBToTheta
! !fields
!      include 'params_CMB.h'
! !end fields
       if (all(Params(1:num_hard) == Lastparams(1:num_hard))) then
         call SetForH(Params,CMB,LastH0, .true.)
         CMB%zre = Lastzre
***************
*** 268,283 ****
       use settings
       use cmbtypes
       use ParamDef
       use IO
       use Lists
       implicit none
       Type(ParamSet) P
       real, intent(in) :: mult, like
       Type(CMBParams) CMB
       real, allocatable :: output_array(:)
       Type(real_pointer) :: derived
       integer numderived 
!      real CalcDerivedParams
       external CalcDerivedParams
    
      if (outfile_handle ==0) return
--- 315,336 ----
       use settings
       use cmbtypes
       use ParamDef
+ !fields
+      use initialpower, only : exportinfprop,updateinfprop
+ !end fields
       use IO
       use Lists
       implicit none
       Type(ParamSet) P
       real, intent(in) :: mult, like
       Type(CMBParams) CMB
+ !fields
+      type(exportinfprop) :: infExport
+ !end fields
       real, allocatable :: output_array(:)
       Type(real_pointer) :: derived
       integer numderived 
!      integer CalcDerivedParams
       external CalcDerivedParams
    
      if (outfile_handle ==0) return
***************
*** 289,296 ****
      else
      
        numderived = CalcDerivedParams(P, derived)
! 
!       allocate(output_array(num_real_params + numderived + nuisance_params_used ))
        output_array(1:num_real_params) =  P%P(1:num_real_params)
        output_array(num_real_params+1:num_real_params+numderived) =  derived%P
        deallocate(derived%P)
--- 342,352 ----
      else
      
        numderived = CalcDerivedParams(P, derived)
! !fields
!       call UpdateInfProp(infExport)
! !      allocate(output_array(num_real_params + numderived + nuisance_params_used ))
!       allocate(output_array(num_real_params + numderived + nuisance_params_used +4))
! !end fields
        output_array(1:num_real_params) =  P%P(1:num_real_params)
        output_array(num_real_params+1:num_real_params+numderived) =  derived%P
        deallocate(derived%P)
***************
*** 299,305 ****
         output_array(num_real_params+numderived+1:num_real_params+numderived+nuisance_params_used) = &
          P%P(num_real_params+1:num_real_params+nuisance_params_used) 
        end if
!  
        call IO_OutputChainRow(outfile_handle, mult, like, output_array)
        deallocate(output_array)           
      end if
--- 355,368 ----
         output_array(num_real_params+numderived+1:num_real_params+numderived+nuisance_params_used) = &
          P%P(num_real_params+1:num_real_params+nuisance_params_used) 
        end if
! !fields
!       output_array(num_real_params+nuisance_params_used+numderived+1) &
!            = log10(P%Info%Transfers%Params%InitPower%infParam%consts(1)) 
!       output_array(num_real_params+nuisance_params_used+numderived+2) &
!            = P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd
!       output_array(num_real_params+nuisance_params_used+numderived+3) = infExport%efoldEndToToday
!       output_array(num_real_params+nuisance_params_used+numderived+4) = infExport%lnEnergyEnd
! !end fields
        call IO_OutputChainRow(outfile_handle, mult, like, output_array)
        deallocate(output_array)           
      end if
***************
*** 313,318 ****
--- 376,384 ----
       use settings
       use cmbtypes
       use ParamDef
+ !fields
+      use initialpower, only : exportinfprop,updateinfprop
+ !end fields
       use IO
       use Lists
       implicit none
***************
*** 320,343 ****
       real, intent(in) :: mult, like
       character(LEN =30) fmt
       Type(CMBParams) CMB
       real,allocatable :: output_array(:)
       Type(real_pointer) :: derived
       integer numderived 
!      real CalcDerivedParams
       external CalcDerivedParams
           
      if (outfile_handle ==0) return
  
        numderived = CalcDerivedParams(P, derived)
! 
!       allocate(output_array(num_real_params + numderived + num_matter_power ))
        output_array(1:num_real_params) =  P%P(1:num_real_params)
        output_array(num_real_params+1:num_real_params+numderived) =  derived%P
        deallocate(derived%P)
  
        output_array(num_real_params+numderived+1:num_real_params+numderived+num_matter_power) = &
          P%Info%Theory%matter_power(:,1) 
! 
        call IO_OutputChainRow(outfile_handle, mult, like, output_array)
        deallocate(output_array)
  
--- 386,422 ----
       real, intent(in) :: mult, like
       character(LEN =30) fmt
       Type(CMBParams) CMB
+ !fields
+      type(exportinfprop) :: infExport
+ !end fields
       real,allocatable :: output_array(:)
       Type(real_pointer) :: derived
       integer numderived 
!      integer CalcDerivedParams
       external CalcDerivedParams
           
      if (outfile_handle ==0) return
  
        numderived = CalcDerivedParams(P, derived)
! !fields
!       call UpdateInfProp(infExport)
! !      allocate(output_array(num_real_params + numderived + num_matter_power ))
!       allocate(output_array(num_real_params + numderived + num_matter_power +4))
! !end fields
        output_array(1:num_real_params) =  P%P(1:num_real_params)
        output_array(num_real_params+1:num_real_params+numderived) =  derived%P
        deallocate(derived%P)
  
        output_array(num_real_params+numderived+1:num_real_params+numderived+num_matter_power) = &
          P%Info%Theory%matter_power(:,1) 
! !fields
!       output_array(num_real_params+num_matter_power+numderived+1) &
!            = log10(P%Info%Transfers%Params%InitPower%infParam%consts(1))
!       output_array(num_real_params+num_matter_power+numderived+2) &
!            = P%Info%Transfers%Params%InitPower%lnReheat - 0.25*infExport%lnEnergyEnd
!       output_array(num_real_params+num_matter_power+numderived+3) = infExport%efoldEndToToday
!       output_array(num_real_params+num_matter_power+numderived+4) = infExport%lnEnergyEnd
! !end fields
        call IO_OutputChainRow(outfile_handle, mult, like, output_array)
        deallocate(output_array)
  
diff -r -c -b -B -N cosmomc/source/params_CMB.h cosmomc_fields/source/params_CMB.h
*** cosmomc/source/params_CMB.h	1970-01-01 01:00:00.000000000 +0100
--- cosmomc_fields/source/params_CMB.h	2011-08-02 16:36:37.005888618 +0200
***************
*** 0 ****
--- 1,13 ----
+ interface
+      
+    subroutine SetForH(Params,CMB,LastH0,firsttime)
+      use cmbtypes
+      implicit none
+      real Params(num_Params)
+      logical, intent(in), optional :: firsttime
+      Type(CMBParams) CMB
+      real LastH0
+    end subroutine SetForH
+ 
+ end interface
+   
diff -r -c -b -B -N cosmomc/source/settings.f90 cosmomc_fields/source/settings.f90
*** cosmomc/source/settings.f90	2011-03-30 19:50:48.000000000 +0200
--- cosmomc_fields/source/settings.f90	2011-08-02 16:25:48.956411587 +0200
***************
*** 6,11 ****
--- 6,12 ----
    implicit none
  
    real :: AccuracyLevel = 1.
+   character (len=6) :: InfModelName
    !Set to >1 to use CAMB etc on higher accuracy settings. 
    !Does not affect MCMC (except making it all slower)
  
***************
*** 19,25 ****
  !                    (e.g. beam uncertainty modes, etc, specific to dataset)
  
    integer, parameter :: num_hard =7 
!   integer, parameter :: num_initpower = 3 
    integer, parameter :: num_freq_params = 1
    integer, parameter :: num_norm = 2 + num_freq_params 
    integer, parameter :: num_nuisance_params= 0
--- 20,29 ----
  !                    (e.g. beam uncertainty modes, etc, specific to dataset)
  
    integer, parameter :: num_hard =7 
! !fields
! !  integer, parameter :: num_initpower = 3 
!   integer, parameter :: num_initpower = 9
! !end fields 
    integer, parameter :: num_freq_params = 1
    integer, parameter :: num_norm = 2 + num_freq_params 
    integer, parameter :: num_nuisance_params= 0
***************
*** 64,69 ****
--- 68,76 ----
  
    integer :: num_threads = 0
    integer :: instance = 0
+ !addon
+   integer :: instance_shift = 0
+ !end addon
    integer :: MPIchains = 1, MPIrank = 0
  
    logical :: Use_LSS = .true.
