This program is on purpose modified - please use: http://lambda.gsfc.nasa.gov/toolbox/tb_camb_ov.cfm
 1 ** bessels.f90
 2 
 3 !CAMB spherical and hyperspherical Bessel function routines
 4 !This version May 2006 - minor changes to bjl (http://cosmocoffee.info/viewtopic.php?t = 530)
 5 !Feb 2007: fixed for high l, uses Ranges
 6 !Feb 2009: minor fix for non-flat compiled with non-smart IF evaluation
 7 !Dec 2011: minor tweak to DoRecurs for smoother errors across flat for L~O(30)
 8 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 9 !Flat bessel function module
 10 
 11         module SpherBessels
 12         use Precision
 13         use ModelParams
 14         use Ranges
 15         implicit none
 16         private
 17         
 18 !     Bessel functions and their second derivatives for interpolation
 19     
 20         real(dl), dimension(:,:), allocatable ::  ajl,ajlpr, ddajlpr
 21 
 22         integer  num_xx, kmaxfile, file_numl,  file_l(lmax_arr)
 23 !      parameters for working out where the flat Bessel functions are small
 24 !      Both should increase for higher accuracy
 25 !        real(dl), parameter :: xlimmin = 15  , xlimfrac = 0.05 
 26          real(dl), parameter :: xlimmin = 35  , xlimfrac = 0.05 
 27         
 28         Type(Regions):: BessRanges
 29 
 30         public ajl, ajlpr, ddajlpr, BessRanges, InitSpherBessels, xlimmin, xlimfrac
 31         public USpherBesselWithDeriv, phi_recurs,phi_langer, bjl, Bessels_Free
 32  
 33        contains
 34 
 35          
 36       subroutine InitSpherBessels
 37 !     This subroutine reads the jl files from disk (or generates them if not on disk)
 38       use lvalues
 39       implicit none
 40 
 41       !See if already loaded with enough (and correct) lSamp%l values and k*eta values
 42       if (allocated(ajl) .and. (lSamp%l0 < = file_numl) .and. all(file_l(1:lSamp%l0)-lSamp%l(1:lSamp%l0) = 0) &
 43                     .and. (int(min(max_bessels_etak,CP%Max_eta_k))+1 < = kmaxfile)) return
 44 
 45       !Haven't made them before, so make them now
 46       call GenerateBessels
 47     
 48       if (DebugMsgs .and. FeedbackLevel > 0) write(*,*) 'Calculated Bessels'
 49 
 50       end subroutine InitSpherBessels
 51 
 52      subroutine GenerateBessels
 53        use lvalues
 54        real(dl) x
 55        real(dl) xlim
 56        integer i,j
 57        integer max_ix
 58        real(dl), parameter :: bessel_boost = 1 
 59 
 60  
 61         if (DebugMsgs .and. FeedbackLevel > 0) write (*,*) 'Generating flat Bessels...'
 62       
 63 
 64         file_numl = lSamp%l0 
 65         file_l(1:lSamp%l0) = lSamp%l(1:lSamp%l0)
 66         kmaxfile = int(min(CP%Max_eta_k,max_bessels_etak))+1
 67         if (do_bispectrum) kmaxfile = kmaxfile*2
 68      
 69 
 70         call Ranges_Init(BessRanges)
 71 
 72         call Ranges_Add_delta(BessRanges,0, 1,0.01/bessel_boost)
 73         call Ranges_Add_delta(BessRanges,1, 5,0.1/bessel_boost)
 74         call Ranges_Add_delta(BessRanges,5, 25,0.2/bessel_boost)
 75         call Ranges_Add_delta(BessRanges,25, 150,0.5/bessel_boost/AccuracyBoost)
 76         call Ranges_Add_delta(BessRanges,150, real(kmaxfile,dl),0.8/bessel_boost/AccuracyBoost)
 77 
 78         call Ranges_GetArray(bessRanges, .false.)
 79         num_xx = BessRanges%npoints
 80 
 81 
 82        max_ix = min(max_bessels_l_index,lSamp%l0)
 83 
 84        if (allocated(ajl)) deallocate(ajl)
 85        if (allocated(ajlpr)) deallocate(ajlpr)
 86        if (allocated(ddajlpr)) deallocate(ddajlpr)
 87        Allocate(ajl(1:num_xx,1:max_ix))
 88        Allocate(ajlpr(1:num_xx,1:max_ix))
 89        Allocate(ddajlpr(1:num_xx,1:max_ix))
 90 
 91        !$OMP PARALLEL DO DEFAULT(SHARED),SCHEDULE(STATIC), PRIVATE(j,i,x,xlim)
 92        do j = 1,max_ix
 93        
 94          do  i = 1,num_xx
 95             x = BessRanges%points(i)
 96             xlim = xlimfrac*lSamp%l(j)
 97             xlim = max(xlim,xlimmin)
 98             xlim = lSamp%l(j)-xlim
 99             if (x > xlim) then
 100                if ((lSamp%l(j) = 3).and.(x < = 0.2) .or. (lSamp%l(j) > 3).and.(x < 0.5) .or. &
 101                             (lSamp%l(j)>5).and.(x < 1.0)) then
 102                    ajl(i,j) = 0
 103                  else
 104                   !if ( lSamp%l(j) > 40000) then
 105                   ! ajl(i,j) = phi_langer(lSamp%l(j),0,1,x)
 106                   !else
 107                    call bjl(lSamp%l(j),x,ajl(i,j))
 108                   !end if
 109                end if
 110             else
 111                   ajl(i,j) = 0
 112             end if
 113          end do
 114 
 115 !     get the interpolation matrix for bessel functions
 116         call spline(BessRanges%points,ajl(1,j),num_xx,spl_large,spl_large,ajlpr(1,j))
 117         call spline(BessRanges%points,ajlpr(1,j),num_xx,spl_large,spl_large,ddajlpr(1,j))
 118          
 119       end do
 120      !$OMP END PARALLEL DO
 121 
 122      end subroutine GenerateBessels
 123 
 124      subroutine Bessels_Free
 125 
 126        if (allocated(ajl)) deallocate(ajl)
 127        if (allocated(ajlpr)) deallocate(ajlpr)
 128        if (allocated(ddajlpr)) deallocate(ddajlpr)
 129        call Ranges_Free(BessRanges)
 130 
 131      end  subroutine Bessels_Free
 132 
 133  
 134          SUBROUTINE BJL(L,X,JL)
 135         !! = MODIFIED SUBROUTINE FOR SPHERICAL BESSEL FUNCTIONS.                       = !!
 136         !! = CORRECTED THE SMALL BUGS IN PACKAGE CMBFAST&CAMB(for l = 4,5, x~0.001-0.002) = !! 
 137         !! = CORRECTED THE SIGN OF J_L(X) FOR X<0 CASE                                 = !!
 138         !! = WORKS FASTER AND MORE ACCURATE FOR LOW L, X<> l ****************/
 241 
 242                 ELSEIF (AX  >  NU+1.48*L3) then
 243                     COSB = NU/AX
 244                     SX = DSQRT(AX2-NU2)
 245                     COTB = NU/SX
 246                     SECB = AX/NU
 247                     BETA = DACOS(COSB)
 248                     COT3B = COTB**3
 249                     COT6B = COT3B**2
 250                     SEC2B = SECB**2
 251                     TRIGARG = NU/COTB-NU*BETA-PID4 &
 252                            -((2.0+3.0*SEC2B)*COT3B/24  &
 253                            +(16-(1512+(3654+375*SEC2B)*SEC2B)*SEC2B)*COT3B*COT6B/5760/NU2)/NU
 254                     EXPTERM = ( (4+sec2b)*sec2b*cot6b/16 &
 255                            -(32+(288+(232+13*SEC2B)*SEC2B)*SEC2B)*SEC2B*COT6B**2/128/NU2)/NU2
 256                     JL = DSQRT(COTB*COSB)/NU*DEXP(-EXPTERM)*DCOS(TRIGARG)
 257 
 258                 !          /***************** Region 3: x near l ****************/
 259 
 260                 ELSE
 261                     BETA = AX-NU
 262                     BETA2 = BETA**2
 263                     SX = 6/AX
 264                     SX2 = SX**2
 265                     SECB = SX**0.3333333333333333
 266                     SEC2B = SECB**2
 267                     JL = ( GAMMA1*SECB + BETA*GAMMA2*SEC2B &
 268                           -(BETA2/18-1/45)*BETA*SX*SECB*GAMMA1 &
 269                           -((BETA2-1)*BETA2/36+1/420)*SX*SEC2B*GAMMA2   &
 270                           +(((BETA2/1620-7/3240)*BETA2+1/648)*BETA2-1/8100)*SX2*SECB*GAMMA1 &
 271                           +(((BETA2/4536-1/810)*BETA2+19/11340)*BETA2-13/28350)*BETA*SX2*SEC2B*GAMMA2 &
 272                           -((((BETA2/349920-1/29160)*BETA2+71/583200)*BETA2-121/874800)* &
 273                            BETA2+7939/224532000)*BETA*SX2*SX*SECB*GAMMA1)*DSQRT(SX)/ROOTPI12
 274                 ENDIF
 275             ENDIF
 276         ENDIF
 277         IF(X < 0.AND.MOD(L,2) <> 0)JL = -JL
 278         END SUBROUTINE BJL    
 279 
 280  !    end module SpherBessels
 281 
 282 
 283 
 284 
 285 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 286 !                                                                      c
 287 ! Calculation of ultraspherical Bessel functions.                      c
 288 ! Fortran version of the c program hyperjl.c by Arthur Kosowsky.       c
 289 ! WKB approx described in astro-ph/9805173                             c
 290 !                                                                      c
 291 ! Modifications by Anthony Challinor and Antony Lewis                  c
 292 ! Minor modifications to correct K = 1 case outside [0,pi],              c
 293 ! the small chi approximations for lSamp%l = 0 and lSamp%l = 1, and                    c
 294 ! the quadratic approximation to Q(x) around Q(x) = 0.                   c
 295 ! Bug fixed in downwards recursion (phi_recurs)                        c
 296 !                                                                      c
 297 ! The routine phi_recurs uses recursion relations to calculate         c
 298 ! the functions, which is accurate but relatively slow.                c  
 299 !   ***NOT STABLE FOR K = 1 or for all cases ***                         c
 300 !                                                                      c
 301 ! The routine phi_langer uses Langer's formula for a                   c
 302 ! uniform first-order asymptotic approximation in the open, closed     c
 303 ! and flat cases. This approximation is EXCELLENT for all lSamp%l > = 3.      c
 304 !                                                                      c
 305 ! The routine qintegral calculates the closed-form answer              c
 306 ! to the eikonal integral used in the WKB approximation.               c
 307 !                                                                      c
 308 ! The routine airy_ai returns the Airy function Ai(x) of the argument  c
 309 ! passed. It employs a Pade-type approximation away from zero and      c
 310 ! a Taylor expansion around zero. Highly accurate.                     c
 311 !                                                                      c
 312 ! The routines polevl and p1evl are auxiliary polynomial               c
 313 ! evaluation routines used in the airy function calculation.           c
 314 !                                                                      c
 315 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 316 
 317 
 318 
 319 ! module USpherBessels
 320 ! use Precision
 321 ! implicit none
 322 ! private 
 323  
 324  
 325  !public USpherBesselWithDeriv, phi_recurs,phi_langer
 326  
 327  
 328 ! contains
 329 
 330         subroutine USpherBesselWithDeriv(closed,Chi,l,beta,y1,y2)
 331           !returns y1 = ujl*sinhChi and y2 = diff(y1,Chi)
 332           !aim for accuracy > 1% for all inputs
 333         real(dl) Chi,beta,y1,y2,sinhChi,cothChi
 334         real(dl) sin_K, cot_K
 335         integer l,K
 336         logical, intent(IN) :: closed
 337         logical DoRecurs
 338         
 339         if (closed) then
 340             sin_K = sin(Chi) 
 341             cot_K = 1/tan(Chi)
 342             K = 1
 343          else 
 344             sin_K = sinh(Chi)
 345             cot_K = 1/tanh(Chi)
 346             K = -1
 347          end if
 348       
 349         sinhChi = sin_K
 350         cothChi = cot_K
 351    
 352        DoRecurs = ((l< = 45*AccuracyBoost).OR.((.not.closed.or.(abs(Chi-pi/2)>0.2)).and.(beta*l<750) &
 353             .or.closed.and.(beta*l<4000)))
 354 
 355 !Deep in the tails the closed recursion relation is not stable
 356 !Added July 2003 to prevent problems with very nearly flat models
 357        if (DoRecurs .and. closed) then
 358         if  (Chi < asin(sqrt(l*(l+1))/beta) - 2/beta) then
 359            if (phi_langer(l,K,beta,Chi) < 1e-7) then
 360              call phi_small_closed_int(l,beta,chi,y1,y2)
 361              return
 362            end if 
 363        end if    
 364      end if        
 365 
 366      if (DoRecurs) then 
 367              !use recursive evaluation where WKB is poor and recurs is fast anyway.
 368          y1 = phi_recurs(l,K,beta,Chi)*sinhChi
 369          y2 = y1*(l+1)*cothChi
 370          if (.not.closed.or.(l+1 1d10 .or. y2> 1d10) then
 461          
 462               y1 = y1/1d10
 463               y2 = y2/1d10
 464         
 465            end if
 466          end do
 467 
 468       end if     
 469    
 470        y1_x = y1; y2_x = y2 
 471 
 472        delchi = (x0 - chi)/nSteps
 473        h6 = delchi/6
 474        hh = delchi/2
 475 
 476           do i = 1,nSteps          
 477 ! One step in the ujl integration
 478 ! fourth-order Runge-Kutta method to integrate equation for ujl
 479 
 480             dydchi1 = y2         !deriv y1
 481             dydchi2 = tmp*y1     !deriv y2     
 482             xh = x+hh          !midpoint of step
 483             yt1 = y1+hh*dydchi1  !y1 at midpoint
 484             yt2 = y2+hh*dydchi2  !y2 at midpoint
 485             dyt1 = yt2           !deriv y1 at mid
 486             tmp = (ap1/sin(xh)**2 - nu2) 
 487             
 488             
 489             dyt2 = tmp*yt1       !deriv y2 at mid
 490        
 491             yt1 = y1+hh*dyt1     !y1 at mid
 492             yt2 = y2+hh*dyt2     !y2 at mid
 493            
 494             dym1 = yt2           !deriv y1 at mid
 495             dym2 = tmp*yt1       !deriv y2 at mid
 496             yt1 = y1+delchi*dym1 !y1 at end
 497             dym1 = dyt1+dym1     
 498             yt2 = y2+delchi*dym2 !y2 at end
 499             dym2 = dyt2+dym2
 500             
 501             x = x+delchi     !end point
 502             sh = sin(x)    
 503             dyt1 = yt2           !deriv y1 at end
 504             tmp = (ap1/sh**2 - nu2)
 505             dyt2 = tmp*yt1       !deriv y2 at end
 506             y1 = y1+h6*(dydchi1+dyt1+2*dym1) !add up
 507             y2 = y2+h6*(dydchi2+dyt2+2*dym2)       
 508             if (y1 > 1d10 .or. y2 > 1d10) then
 509               y1 = y1/1d10
 510               y2 = y2/1d10
 511               y1_x = y1_x/1d10
 512               y2_x = y2_x/1d10
 513         
 514             end if
 515          end do
 516 
 517 
 518          tmp = phi_recurs(l,1,beta,x0)*sin(x0) / y1
 519          y1 = y1_x * tmp
 520          y2 = y2_x * tmp
 521 
 522 
 523    end subroutine phi_small_closed_int
 524  
 525 !***********************************************************************
 526 !                                                                      *
 527 ! Calculates Phi(l,beta,chi) using recursion on l.                     *
 528 ! See Abbot and Schaefer, ApJ 308, 546 (1986) for needed               *
 529 ! recursion relations and closed-form expressions for l = 0,1.           *
 530 ! (Note: Their variable y is the same as chi here.)                    *
 531 !                                                                      *
 532 ! When the flag direction is negative, downwards recursion on l        *
 533 ! must be used because the upwards direction is unstable to roundoff   *
 534 ! errors. The downwards recursion begins with arbitrary values and     *
 535 ! continues downwards to l = 1, where the desired l value is normalized  *
 536 ! using the closed form solution for l = 1. (See, e.g., Numerical        *
 537 ! Recipes of Bessel functions for more detail)                         *
 538 !                                                                      *
 539 !***********************************************************************
 540 
 541   function phi_recurs(l, K, beta, chi)
 542   !doesn't like values which give exponentially small phi
 543   integer, intent(IN) :: l, K
 544   real(dl), intent(IN) :: beta, chi
 545   real(dl) phi_recurs
 546   integer j, direction, lstart,ibeta
 547   real(dl) ell, kay, arg, answer,beta2
 548   real(dl) root_K
 549   real(dl) phi0, phi1, phi_plus, phi_zero, phi_minus, b_zero, b_minus 
 550   real(dl), parameter :: ACC = 40, BIG = 1.d10
 551   real(dl) sin_K, cot_K
 552 
 553   ell = dble(l)
 554  
 555  
 556   ! Test input values
 557 
 558   if(l<0) then
 559      write(*,*) "Bessel function index ell < 0"
 560      stop
 561   endif
 562   if(beta<0) then
 563      write(*,*) "Wavenumber beta < 0"
 564      stop
 565   endif
 566   if ((abs(K)/= 1).and.(K/= 0)) then
 567      write(*,*) "K must be 1, 0 or -1"
 568      stop
 569   end if
 570   
 571   if(K = 1) then    
 572      ibeta = nint(beta)
 573      if(ibeta<3) then
 574         write(*,*) "Wavenumber beta < 3 for K = 1"
 575         stop
 576      endif
 577      if(ibeta< = l) then
 578         write(*,*) "Wavenumber beta < = l"
 579         stop
 580      endif
 581   endif
 582  
 583   if (chi<1/BIG) then
 584      phi_recurs = 0
 585      return
 586   end if
 587  
 588   kay = dble(K)
 589   arg = beta * chi
 590   beta2 = beta**2
 591 
 592   if(K = 0) then
 593      cot_K = 1/chi
 594      sin_K = chi
 595      root_K = beta
 596   else 
 597    root_K = sqrt(beta2 -kay*ell*ell)
 598   
 599     if(K = -1) then
 600     cot_K = 1/tanh(chi)
 601     sin_K = sinh(chi)   
 602     else
 603     cot_K = 1/tan(chi)
 604     sin_K = sin(chi)   
 605     end if
 606   
 607   endif
 608  
 609   
 610   ! Closed form solution for l = 0
 611  
 612   if (abs(chi) < 1.d-4) then
 613     if (abs(arg)<1.d-4) then
 614      phi0 = 1-chi**2*(beta*beta-kay)/6
 615     else
 616      phi0 = sin(arg)/arg
 617     end if
 618   else     
 619      phi0 = sin(arg) / (beta * sin_K)
 620   end if
 621 
 622   if (l = 0) then
 623        phi_recurs = phi0
 624        return 
 625    end if
 626 
 627 
 628      ! Closed form solution for l = 1
 629 
 630      if((abs(chi) < 1.d-4).and.(K/= 0)) then
 631         if(arg < 1.d-4) then
 632            phi1 = chi*sqrt(beta*beta-kay)/3
 633            !beta2 * chi / (3 * sqrt(1+ kay * beta2))
 634         else 
 635            phi1 = (sin(arg)/arg-cos(arg))/(sqrt(beta*beta-kay)*chi)
 636              !(sin(arg)/arg - cos(arg))/arg
 637         end if
 638      elseif ((abs(arg) < 1.d-4).and.(K = 0)) then
 639         phi1 = arg / 3
 640      else 
 641         if (K /= 0 ) then
 642            phi1 = sin(arg) * cot_K / (beta * sin_K) - cos(arg) / sin_K
 643            phi1 = phi1/sqrt(beta2 - kay)
 644         else
 645            phi1 = (sin(arg)/arg - cos(arg))/arg
 646         end if
 647      end if
 648      if(l = 1) then
 649         phi_recurs = phi1
 650         return
 651      end if
 652      ! Find recursion direction
 653      !  direction = +1 for upward recursion, -1 for downward
 654 
 655      if(abs(cot_K) < root_K / ell) then 
 656         direction = 1
 657      else 
 658         direction = -1
 659      end if
 660     
 661      ! For K = 1, must do upwards recursion:
 662      ! NOT STABLE for all values of chi
 663 
 664      if(K = 1) direction = 1
 665 
 666      ! Do upwards recursion on l
 667     
 668      
 669      if(direction = 1)then
 670         b_minus = sqrt(beta2 - kay)
 671         phi_minus = phi0
 672         phi_zero = phi1
 673       
 674         do j = 2,l 
 675            
 676            if(K = 0) then
 677               phi_plus = ((2*j-1) * cot_K * phi_zero - beta*phi_minus)/ beta
 678            else 
 679               b_zero = sqrt(beta2 - (K*j*j))  
 680               phi_plus = ((2*j-1) * cot_K * phi_zero - b_minus * phi_minus) / b_zero
 681               b_minus = b_zero
 682            end if
 683            phi_minus = phi_zero
 684            phi_zero = phi_plus
 685         end do
 686       
 687       
 688         phi_recurs = phi_plus
 689         
 690      
 691         return
 692 
 693         ! Do downwards recursion on l
 694 
 695      else 
 696         lstart = l + 2 * int(sqrt(ell*ACC))
 697       
 698         b_zero = sqrt(beta2 - dble(K*lstart*lstart))
 699         phi_plus = 0
 700         phi_zero = 1
 701         answer = 0
 702        
 703         do j = lstart - 2,1,-1
 704            
 705            if(K = 0) then
 706               phi_minus = ((2*j + 3) * cot_K * phi_zero - beta * phi_plus) / beta
 707            else
 708               b_minus = sqrt(beta2 - (K*(j+1)**2))  
 709               phi_minus = ((2*j + 3) * cot_K * phi_zero - b_zero * phi_plus) / b_minus
 710               b_zero = b_minus
 711            end if
 712            phi_plus = phi_zero
 713            phi_zero = phi_minus
 714 
 715            if(j = l) answer = phi_minus
 716            if((abs(phi_zero) > BIG).and.(j/= 1)) then
 717               phi_plus = phi_plus/BIG
 718               phi_zero = phi_zero/BIG            
 719               answer = answer/BIG
 720            end if
 721         end do
 722 
 723         ! Normalize answer to previously computed phi1
 724 
 725         answer = answer*phi1 / phi_minus
 726         phi_recurs = answer    
 727        
 728      end if
 729  
 730    end function phi_recurs
 731 
 732 
 733 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 734 !                                                                      c
 735 ! Calculates Phi(l,beta,chi) using the Langer uniform approximation    c
 736 ! to the first-order WKB approximation.                                c
 737 ! See C.M. Bender and S.A. Orszag,  Mathematical Methods for           c
 738 ! Scientists and Engineers (McGraw-Hill, 1978; LC QA371.B43),          c
 739 ! chapter 10.                                                          c
 740 !                                                                      c
 741 ! Differential equation for needed function can be cast into the       c
 742 ! Schrodinger form      \epsilon^2 y'' = Q(x) y                        c
 743 ! where \epsilon^2 = 1/l(l+1) and Q(x) depends on the parameter        c
 744 ! alpha \equiv beta * epsilon.                                         c
 745 !                                                                      c
 746 ! In the K = +1 case, the function is                                   c
 747 ! determined by its value on the interval [0, pi/2] and the symmetry   c
 748 ! conditions Phi(chi + pi) = (-1)^{beta - l - 1} Phi(chi),             c
 749 !            Phi(pi - chi) = (-1)^{beta - l - 1} Phi(chi).             c
 750 ! This interval contains one turning point, so the Langer formula      c
 751 ! can be used.                                                         c
 752 ! Note that the second condition at chi = pi/2 gives an eigenvalue     c
 753 ! condition on beta, which  must corrected. For the lowest             c
 754 ! eigenvalue(s), the region between the turning points is not large    c
 755 ! enough for the asymptotic solution to be valid, so the functions     c
 756 ! have a small discontinuity or discontinuous derivative at pi/2;      c
 757 ! this behavior is corrected by employing a 4-term asymptotic          c
 758 ! series around the regular point chi = pi/2.                            c
 759 ! The exact eigenvalue condition requires that beta must be an         c
 760 ! integer > = 3 with beta > l. Note this implies alpha > 1.             c
 761 !                                                                      c
 762 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 763       
 764 
 765 
 766       function phi_langer(l,K,beta,chi)
 767       integer l,K,ibeta,kay
 768       real(dl) phi_langer
 769       real(dl) ell,symm, anu, alpha2
 770       real(dl) beta,chi,eikonal, wkb, arg, arg2, tmp
 771       real(dl) epsilon, alpha, chi0, x, a, b,achi 
 772     
 773       real(dl) cot_K, sin_K
 774       real(dl), parameter :: PI = 3.1415926536,ROOTPI = 1.772453851,ROOT2PI = 2.506628275, &
 775                            PIOVER2 = 1.570796327
 776 
 777       ell = dble(l)
 778       achi = chi
 779    
 780       symm = 1
 781 !
 782 ! Test input values
 783 !
 784       if(l<0) then
 785          write(*,*) "Bessel function index ell < 0"
 786          stop
 787       endif
 788       if(beta<0) then
 789          write(*,*) "Wavenumber beta < 0"
 790          stop
 791       endif
 792       if ((abs(K)/= 1).and.(K/= 0)) then
 793         write(*,*) "K must be 1, 0 or -1"
 794         stop
 795       end if
 796 
 797       
 798       if(K = 1) then        
 799          ibeta = nint(beta)
 800          if(ibeta<3) then
 801             write(*,*) "Wavenumber beta < 3 for K = 1"
 802             stop
 803          endif
 804          if(ibeta< = l) then
 805             write(*,*) "Wavenumber beta < = l"
 806             stop
 807          endif
 808       endif
 809    
 810       kay = K
 811 
 812 
 813 ! For closed case, find equivalent chi in [0,pi/2]
 814 !
 815       if(K = 1) then
 816          achi = achi-2*Pi*int(achi/2/PI)
 817          if(achi>PI) then
 818             achi = 2*PI-achi
 819             if(2*(l/2) = l) then
 820                symm = symm
 821             else
 822                symm = -symm
 823             endif
 824          endif
 825          if(achi>PI/2) then
 826             achi = PI-achi
 827             if(2*((ibeta-l-1)/2) = (ibeta-l-1)) then
 828                symm = symm
 829             else
 830                symm = -symm
 831             endif
 832          endif
 833       endif
 834 
 835 ! Definitions
 836       if(K = 0) then
 837           sin_K = achi         
 838       else 
 839             if(K = -1) then
 840                sin_K = sinh(achi)   
 841              else
 842                sin_K = sin(achi)   
 843             end if           
 844       endif 
 845 
 846 ! Closed form solution for l = 0
 847 !
 848       if(l = 0) then
 849          arg = beta*achi
 850        
 851          if((abs(achi)<1.d-4).and.(K/= 0)) then
 852             if(abs(arg)<1.d-4) then
 853                wkb = 1-achi*achi*(beta*beta-kay)/6
 854             else
 855                wkb = sin(arg)/arg
 856             endif
 857          else if((abs(arg)<1.d-4).and.(K = 0)) then
 858             wkb = 1-arg*arg/6
 859          else
 860             wkb = sin(arg)/(beta*sin_K)
 861          endif
 862          phi_langer = symm*wkb
 863          return
 864       endif
 865 !
 866 ! Closed form solution for l = 1
 867 !
 868       if(l = 1) then
 869          arg = beta*achi
 870       
 871          if((abs(achi)<1.d-4).and.(K/= 0)) then
 872             if(abs(arg)<1.d-4) then
 873                wkb = achi*sqrt(beta*beta-kay)/3
 874             else
 875                wkb = (sin(arg)/arg-cos(arg))/(sqrt(beta*beta-kay)*achi)
 876             endif
 877          else if((abs(arg)<1.d-4).and.(K = 0)) then
 878             wkb = arg/3
 879          else 
 880           if(K/= 0) then
 881             if(K = 1) then
 882                cot_K = 1/tan(achi)
 883             else
 884                cot_K = 1/tanh(achi)
 885             endif
 886             wkb = sin(arg)*cot_K/(beta*sin_K)-cos(arg)/sin_K
 887             wkb = wkb/sqrt(beta*beta-kay)
 888          else
 889             wkb = (sin(arg)/arg-cos(arg))/arg
 890          endif
 891          end if
 892          phi_langer = symm*wkb
 893          return
 894       endif
 895 !
 896 ! Closed form solution for K = 1 and beta = l+1 (lowest eigenfunction)
 897 !
 898       if((K = 1).and.(ibeta = (l+1))) then
 899          wkb = (sin_K**ell)* &
 900               sqrt(sqrt(2*PI/(2*ell+1))*ell/((ell+1)*(2*ell+1)))
 901          wkb = wkb*(1+0.1875/ell-0.013671875/(ell*ell))
 902          phi_langer = symm*wkb
 903          return
 904       endif
 905 
 906 ! Very close to 0, return 0 (exponentially damped)
 907 !
 908       if(abs(achi)<1.d-8) then
 909          phi_langer = 0
 910          return
 911       endif
 912 
 913 
 914 ! For closed case, find corrected eigenvalue beta
 915 !
 916       if(K = 1) then
 917          anu = dble(ibeta)-1/(8*ell)+1/(16*ell*ell)
 918       else
 919          anu = beta
 920       endif
 921 !
 922 ! Evaluate epsilon using asymptotic form for large l
 923 !
 924       if(l<20) then
 925          epsilon = 1/sqrt(ell*(ell+1))
 926       else
 927          epsilon = 1/ell-0.5/(ell*ell)+0.375/(ell*ell*ell)
 928       endif
 929      
 930       alpha = epsilon*anu
 931 !
 932 ! Calculate the turning point where Q(x) = 0.
 933 ! Function in question has only a single simple turning point.
 934 !
 935       if(K = -1) chi0 = log((1+sqrt(1+alpha*alpha))/alpha)
 936       if(K = 0) chi0 = 1/alpha
 937       if(K = 1) chi0 = asin(1/alpha)
 938  
 939 
 940 ! Very close to chi0, use usual wkb form to avoid dividing by zero
 941 !
 942       if(abs(achi-chi0)<1.d-5) then
 943 
 944 ! Calculate coefficients of linear and quadratic terms in Q(x) expansion
 945 ! in the neighborhood of the turning point
 946 ! Q(chi) = a*(chi0-chi)+b*(chi0-chi)**2
 947          alpha2 = alpha*alpha
 948        
 949          if(K = -1) then
 950             a = 2*alpha2*sqrt(alpha2+1)
 951             b = 3*alpha2**2+2*alpha2
 952          endif
 953          if(K = 0) then
 954             a = 2*alpha2*alpha
 955             b = 3*alpha2**2
 956          endif
 957          if(K = 1) then
 958             a = 2*alpha2*sqrt(alpha2-1)
 959             b = 3*alpha2**2-2*alpha2
 960          endif
 961        
 962 ! Dependent variable x for which Q(x) = 0 at x=0
 963 ! x>0 is the evanescent region
 964 !
 965          x = chi0-achi
 966 !
 967 ! Argument of Airy function
 968 !
 969          arg = (x+b*x*x/(5*a))/(epsilon*epsilon/a)**(0.333333333)
 970 !
 971 ! Evaluate Airy function
 972 !
 973          wkb = airy_ai(arg)
 974 !
 975 ! Rest of functional dependence
 976 !
 977          wkb = wkb*(1-b*x/(5*a))/sin_K 
 978 !  Normalization factor:
 979 
 980          wkb = wkb*symm*ROOTPI*((a*epsilon)**(-0.1666667))*sqrt(epsilon/anu)
 981          phi_langer = wkb  
 982         
 983          return
 984       endif
 985 
 986 
 987 ! Langer approximation.
 988 !
 989 ! Transport factor:
 990 !
 991       tmp = sqrt(abs(1/(sin_K*sin_K)-alpha*alpha))
 992      
 993 ! Eikonal factor
 994 !
 995       eikonal = qintegral(sin_K,alpha,K)
 996 
 997     
 998      
 999       arg = (1.5*eikonal/epsilon)**(1/3)
 1000    
 1001       arg2 = arg*arg
 1002       if(achi>chi0) arg2 = -arg2
 1003       
 1004 ! Multiply factors together
 1005 
 1006       wkb = airy_ai(arg2)*symm*ROOTPI*sqrt(arg*epsilon/anu/tmp)/Sin_K
 1007       phi_langer = wkb
 1008 
 1009       end function phi_langer
 1010 
 1011 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 1012 !                                                                       c
 1013 ! Evaluates the exact solution to  the integral giving the WKB          c
 1014 ! eikonal solution,   \int^x sqrt(abs(Q(x))) dx                         c
 1015 !                                                                       c
 1016 ! In the open case, this integral costs 1 or 2 square roots, an atan    c
 1017 ! and a log; its evaluation will be roughly as expensive as the rest    c
 1018 ! of the Phi routine. An analytic fit cannot be substantially faster    c
 1019 ! because the dependence on alpha of the y-intercept of the linear      c
 1020 ! region of the integrand contains a log and an atan, so at best a fit  c
 1021 ! can only save the computation of the square roots.                    c
 1022 !                                                                       c
 1023 ! The integrals are very bland functions of chi and alpha and could     c
 1024 ! be precomputed and cached to save computation time; interpolation     c
 1025 ! on a relatively small number of points should be very accurate        c
 1026 !                                                                       c
 1027 ! Note that for the closed case, the variable arg must be between 0     c
 1028 ! and alpha; for arg > alpha, symmetry properties reduce the needed     c
 1029 ! integral to this case.                                                c
 1030 !                                                                       c
 1031 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 1032       function qintegral(sin_K,alpha, K)
 1033       implicit none
 1034       real(dl) qintegral, sin_K
 1035       integer K
 1036       real(dl) alpha,exact,arg, root1, root2, dummyarg
 1037      
 1038       real(dl), parameter :: PI = 3.1415926536,ROOTPI = 1.772453851,ROOT2PI = 2.506628275, &
 1039                            PIOVER2 = 1.570796327
 1040 
 1041       arg = alpha*sin_K
 1042 
 1043       if(K = 0) then
 1044          if(arg>1) then
 1045             exact = sqrt(arg*arg-1)-acos(1/arg)
 1046             qintegral = exact
 1047             return
 1048          else
 1049             root1 = sqrt(1-arg*arg)
 1050             exact = log((1+root1)/arg)-root1
 1051             qintegral = exact
 1052             return
 1053          endif
 1054       else if(K = -1) then
 1055          if(arg>1) then
 1056             root1 = sqrt(arg*arg-1)
 1057             root2 = sqrt(arg*arg+alpha*alpha)
 1058             exact = alpha/2*log((2*arg*arg+alpha*alpha-1+ &
 1059                   2*root1*root2)/(1+alpha*alpha))+atan(root2/ &
 1060                   (alpha*root1))-PIOVER2
 1061             qintegral = exact
 1062             return
 1063          else
 1064             root1 = sqrt((1-arg*arg)*(arg*arg+alpha*alpha))
 1065             exact = alpha/2*atan(-2*root1/(2*arg*arg+alpha*alpha- &
 1066                   1))+0.5*log((2*alpha*root1+2*alpha*alpha+ &
 1067                   arg*arg*(1-alpha*alpha))/(arg*arg*(1+ &
 1068                   alpha*alpha)))
 1069             if(2*arg*arg+alpha*alpha-1<0) then
 1070                exact = exact-alpha*PIOVER2
 1071             endif
 1072             qintegral = exact
 1073             return
 1074          endif
 1075       else
 1076          if(arg>1) then
 1077             root1 = sqrt(arg*arg-1)
 1078             root2 = sqrt(alpha*alpha-arg*arg)
 1079             exact = alpha/2*atan(-2*root1*root2/ &
 1080                (2*arg*arg-alpha*alpha-1))- &
 1081                atan(-root2/(root1*alpha))-PIOVER2
 1082             if(2*arg*arg-alpha*alpha-1>0) then
 1083                exact = exact+alpha*PIOVER2
 1084             endif
 1085          else
 1086             root1 = sqrt((1-arg*arg)*(alpha*alpha-arg*arg))
 1087             dummyarg = alpha*(1-arg*arg)/root1
 1088             exact = 0.5*log((1+dummyarg)/(1-dummyarg))- &
 1089              alpha/2*log((alpha*alpha-2*arg*arg+1+2*root1)/ &
 1090              (alpha*alpha-1))
 1091          endif
 1092          qintegral = exact
 1093          return
 1094       endif
 1095    
 1096       end function qintegral 
 1097 
 1098 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 1099 !                                                                      c
 1100 !       Airy function                                                  c
 1101 !                                                                      c
 1102 ! Modified from original routine by Stephen Moshier, available         c
 1103 ! as part of the Cephes library at www.netlib.com                      c
 1104 ! Modifications: eliminates calculation of Bi(x), Ai'(x), Bi'(x)       c
 1105 ! and translation to Fortran                                           c
 1106 !                                                                      c
 1107 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 1108 !
 1109 ! DESCRIPTION:
 1110 !
 1111 ! Solution of the differential equation
 1112 !
 1113 !       y"(x) = xy.
 1114 !
 1115 ! The function returns the two independent solutions Ai, Bi
 1116 ! and their first derivatives Ai'(x), Bi'(x).
 1117 !
 1118 ! Evaluation is by power series summation for small x,
 1119 ! by rational minimax approximations for large x.
 1120 !
 1121 !
 1122 !
 1123 ! ACCURACY:
 1124 ! Error criterion is absolute when function < = 1, relative
 1125 ! when function > 1, except * denotes relative error criterion.
 1126 ! For large negative x, the absolute error increases as x^1.5.
 1127 ! For large positive x, the relative error increases as x^1.5.
 1128 !
 1129 ! Arithmetic  domain   function  ! trials      peak         rms
 1130 ! IEEE        -10, 0     Ai        10000       1.6e-15     2.7e-16
 1131 ! IEEE          0, 10    Ai        10000       2.3e-14*    1.8e-15*
 1132 ! IEEE        -10, 0     Ai'       10000       4.6e-15     7.6e-16
 1133 ! IEEE          0, 10    Ai'       10000       1.8e-14*    1.5e-15*
 1134 ! IEEE        -10, 10    Bi        30000       4.2e-15     5.3e-16
 1135 ! IEEE        -10, 10    Bi'       30000       4.9e-15     7.3e-16
 1136 ! DEC         -10, 0     Ai         5000       1.7e-16     2.8e-17
 1137 ! DEC           0, 10    Ai         5000       2.1e-15*    1.7e-16*
 1138 ! DEC         -10, 0     Ai'        5000       4.7e-16     7.8e-17
 1139 ! DEC           0, 10    Ai'       12000       1.8e-15*    1.5e-16*
 1140 ! DEC         -10, 10    Bi        10000       5.5e-16     6.8e-17
 1141 ! DEC         -10, 10    Bi'        7000       5.3e-16     8.7e-17
 1142 !
 1143 !
 1144 ! Cephes Math Library Release 2.1:  January, 1989
 1145 ! Copyright 1984, 1987, 1989 by Stephen lSamp%l. Moshier
 1146 ! Direct inquiries to 30 Frost Street, Cambridge, MA 02140
 1147 !
 1148 
 1149       function airy_ai(x)
 1150       implicit none
 1151       real(dl) airy_ai
 1152       real(dl) x,z, zz, t, f, g, uf, ug, zeta, theta
 1153       real(dl) ak
 1154       real(dl) AN(8),AD(8),AFN(9),AFD(9),AGN(11),AGD(10)
 1155       real(dl), parameter :: AMAXAIRY = 25.77,ACC = 1.d-8,PI = 3.1415926536
 1156       real(dl), parameter :: c1 = 0.35502805388781723926, c2 = 0.258819403792806798405
 1157       real(dl), parameter :: sqrt3 = 1.732050807568877293527,sqpii = 5.64189583547756286948d-1
 1158      
 1159       
 1160       AN(1) = 3.46538101525629032477d-1
 1161       AN(2) = 1.20075952739645805542d1
 1162       AN(3) = 7.62796053615234516538d1
 1163       AN(4) = 1.68089224934630576269d2
 1164       AN(5) = 1.59756391350164413639d2
 1165       AN(6) = 7.05360906840444183113d1
 1166       AN(7) = 1.40264691163389668864d1
 1167       AN(8) = 9.99999999999999995305d-1
 1168 
 1169       AD(1) = 5.67594532638770212846d-1
 1170       AD(2) = 1.47562562584847203173d1
 1171       AD(3) = 8.45138970141474626562d1
 1172       AD(4) = 1.77318088145400459522d2
 1173       AD(5) = 1.64234692871529701831d2
 1174       AD(6) = 7.14778400825575695274d1
 1175       AD(7) = 1.40959135607834029598d1
 1176       AD(8) = 1.00000000000000000470
 1177 
 1178       AFN(1) = -1.31696323418331795333d-1
 1179       AFN(2) = -6.26456544431912369773d-1
 1180       AFN(3) = -6.93158036036933542233d-1
 1181       AFN(4) = -2.79779981545119124951d-1
 1182       AFN(5) = -4.91900132609500318020d-2
 1183       AFN(6) = -4.06265923594885404393d-3
 1184       AFN(7) = -1.59276496239262096340d-4
 1185       AFN(8) = -2.77649108155232920844d-6
 1186       AFN(9) = -1.67787698489114633780d-8
 1187 
 1188       AFD(1) = 1.33560420706553243746d1
 1189       AFD(2) = 3.26825032795224613948d1
 1190       AFD(3) = 2.67367040941499554804d1
 1191       AFD(4) = 9.18707402907259625840
 1192       AFD(5) = 1.47529146771666414581
 1193       AFD(6) = 1.15687173795188044134d-1
 1194       AFD(7) = 4.40291641615211203805d-3
 1195       AFD(8) = 7.54720348287414296618d-5
 1196       AFD(9) = 4.51850092970580378464d-7
 1197 
 1198       AGN(1) = 1.97339932091685679179d-2
 1199       AGN(2) = 3.91103029615688277255d-1
 1200       AGN(3) = 1.06579897599595591108
 1201       AGN(4) = 9.39169229816650230044d-1
 1202       AGN(5) = 3.51465656105547619242d-1
 1203       AGN(6) = 6.33888919628925490927d-2
 1204       AGN(7) = 5.85804113048388458567d-3
 1205       AGN(8) = 2.82851600836737019778d-4
 1206       AGN(9) = 6.98793669997260967291d-6
 1207       AGN(10) = 8.11789239554389293311d-8
 1208       AGN(11) = 3.41551784765923618484d-10
 1209 
 1210       AGD(1) = 9.30892908077441974853
 1211       AGD(2) = 1.98352928718312140417d1
 1212       AGD(3) = 1.55646628932864612953d1
 1213       AGD(4) = 5.47686069422975497931
 1214       AGD(5) = 9.54293611618961883998d-1
 1215       AGD(6) = 8.64580826352392193095d-2
 1216       AGD(7) = 4.12656523824222607191d-3
 1217       AGD(8) = 1.01259085116509135510d-4
 1218       AGD(9) = 1.17166733214413521882d-6
 1219       AGD(10) = 4.91834570062930015649d-9
 1220 !
 1221 ! Exponentially tiny for large enough argument
 1222 !
 1223       if(x>AMAXAIRY) then
 1224          airy_ai = 0
 1225          return
 1226       endif
 1227 !
 1228 ! Pade fit for large negative arguments
 1229 !
 1230       if(x<-2.09) then
 1231          t = sqrt(-x)
 1232          zeta = -2*x*t/3
 1233          t = sqrt(t)
 1234          ak = sqpii/t
 1235          z = 1/zeta
 1236          zz = z*z
 1237          uf = 1+zz*polevl(zz,AFN,8)/p1evl(zz,AFD,9)
 1238          ug = z*polevl(zz,AGN,10)/p1evl(zz,AGD,10)
 1239          theta = zeta+0.25*PI
 1240          f = sin(theta)
 1241          g = cos(theta)
 1242          airy_ai = ak*(f*uf-g*ug)
 1243          return
 1244       endif
 1245 !
 1246 ! Pade fit for large positive arguments
 1247 !
 1248       if(x> = 2.09) then
 1249          t = sqrt(x)
 1250          zeta = 2*x*t/3
 1251          g = exp(zeta)
 1252          t = sqrt(t)
 1253          ak = 2*t*g
 1254          z = 1/zeta
 1255          f = polevl(z,AN,7)/polevl(z,AD,7)
 1256          airy_ai = sqpii*f/ak
 1257          return
 1258       endif
 1259 !
 1260 ! Taylor series for region around x = 0
 1261 !
 1262 
 1263       f = 1
 1264       g = x
 1265       t = 1
 1266       uf = 1
 1267       ug = x
 1268       ak = 1
 1269       z = x*x*x
 1270      do while (t>ACC) 
 1271          uf = uf*z
 1272          ak = ak+1
 1273          uf = uf/ak
 1274          ug = ug*z
 1275          ak = ak+1
 1276          ug = ug/ak
 1277          uf = uf/ak
 1278          f = f+uf
 1279          ak = ak+1
 1280          ug = ug/ak
 1281          g = g+ug
 1282          t = abs(uf/f)
 1283       end do
 1284      
 1285 
 1286       airy_ai = c1*f-c2*g
 1287       
 1288       end function airy_ai
 1289 
 1290 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 1291 !  Evaluate polynomial                                          c
 1292 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 1293 ! DESCRIPTION:
 1294 !
 1295 ! Evaluates polynomial of degree N:
 1296 !
 1297 !                     2          N
 1298 ! y  =  C  + C x + C x  +...+ C x
 1299 !        0    1     2          N
 1300 !
 1301 ! Coefficients are stored in reverse order:
 1302 !
 1303 ! coef(1) = C  , ..., coef(N+1) = C  .
 1304 !            N                     0
 1305 !
 1306 ! The function p1evl() assumes that C = 1.0 and is
 1307 !                                    N
 1308 ! omitted from the array.  Its calling arguments are
 1309 ! otherwise the same as polevl().
 1310 !
 1311 !
 1312 ! SPEED:
 1313 !
 1314 ! In the interest of speed, there are no checks for out
 1315 ! of bounds arithmetic.  This routine is used by most of
 1316 ! the functions in the library.  Depending on available
 1317 ! equipment features, the user may wish to rewrite the
 1318 ! program in microcode or assembly language.
 1319 !
 1320 ! Cephes Math Library Release 2.1:  December, 1988
 1321 ! Copyright 1984, 1987, 1988 by Stephen lSamp%l. Moshier
 1322 ! Direct inquiries to 30 Frost Street, Cambridge, MA 02140
 1323 !
 1324       function polevl(x,coef,N)
 1325       implicit none
 1326       real(dl) polevl
 1327       real(dl) x,ans
 1328       real(dl) coef
 1329       integer N,i
 1330 
 1331       dimension coef(N+1)
 1332 
 1333       ans = coef(1)
 1334       do i = 2,N+1
 1335          ans = ans*x+coef(i)
 1336       end do
 1337       polevl = ans
 1338       
 1339       end function polevl
 1340 
 1341 !
 1342 !                                      
 1343 ! Evaluate polynomial when coefficient of x  is 1.0.
 1344 ! Otherwise same as polevl.
 1345 !
 1346       function p1evl(x,coef,N)
 1347       implicit none
 1348       real(dl) p1evl
 1349       real(dl) x,coef,ans
 1350       integer N,i
 1351       dimension coef(N)
 1352 
 1353       ans = x+coef(1)
 1354       do i = 2,N
 1355          ans = ans*x+coef(i)
 1356       end do
 1357       p1evl = ans
 1358      
 1359       end function p1evl
 1360 
 1361 
 1362 
 1363   end module SpherBessels !USpherBessels
 1364 
 1365 
 1366 
 1367         SUBROUTINE BJL_EXTERNAL(L,X,JL)
 1368         use SpherBessels
 1369         use Precision
 1370         !! = MODIFIED SUBROUTINE FOR SPHERICAL BESSEL FUNCTIONS.                       = !!
 1371         !! = CORRECTED THE SMALL BUGS IN PACKAGE CMBFAST&CAMB(for l = 4,5, x~0.001-0.002) = !! 
 1372         !! = CORRECTED THE SIGN OF J_L(X) FOR X<0 CASE                                 = !!
 1373         !! = WORKS FASTER AND MORE ACCURATE FOR LOW L, X<
 1386 ! Microsoft Developer Studio Generated Build File, Format Version 6.00
 1387 ! ** DO NOT EDIT **
 1388 
 1389 ! TARGTYPE "Win32 (x86) Console Application" 0x0103
 1390 
 1391 CFG = camb - Win32 Debug
 1392 !MESSAGE This is not a valid makefile. To build this project using NMAKE,
 1393 !MESSAGE use the Export Makefile command and run
 1394 !MESSAGE 
 1395 !MESSAGE NMAKE /f "camb.mak".
 1396 !MESSAGE 
 1397 !MESSAGE You can specify a configuration when running NMAKE
 1398 !MESSAGE by defining the macro CFG on the command line. For example:
 1399 !MESSAGE 
 1400 !MESSAGE NMAKE /f "camb.mak" CFG = "camb - Win32 Debug"
 1401 !MESSAGE 
 1402 !MESSAGE Possible choices for configuration are:
 1403 !MESSAGE 
 1404 !MESSAGE "camb - Win32 Release" (based on "Win32 (x86) Console Application")
 1405 !MESSAGE "camb - Win32 Debug" (based on "Win32 (x86) Console Application")
 1406 !MESSAGE 
 1407 
 1408 ! Begin Project
 1409 ! PROP AllowPerConfigDependencies 0
 1410 ! PROP Scc_ProjName ""
 1411 ! PROP Scc_LocalPath ""
 1412 CPP = cl.exe
 1413 F90 = df.exe
 1414 RSC = rc.exe
 1415 
 1416 !IF  "$(CFG)" = "camb - Win32 Release"
 1417 
 1418 ! PROP BASE Use_MFC 0
 1419 ! PROP BASE Use_Debug_Libraries 0
 1420 ! PROP BASE Output_Dir "Release"
 1421 ! PROP BASE Intermediate_Dir "Release"
 1422 ! PROP BASE Target_Dir ""
 1423 ! PROP Use_MFC 0
 1424 ! PROP Use_Debug_Libraries 0
 1425 ! PROP Output_Dir "Release"
 1426 ! PROP Intermediate_Dir "Release"
 1427 ! PROP Ignore_Export_Lib 0
 1428 ! PROP Target_Dir ""
 1429 ! ADD BASE F90 /compile_only /nologo /warn:nofileopt
 1430 ! ADD F90 /compile_only /fpp /nologo /warn:nofileopt
 1431 ! ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
 1432 ! ADD CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c
 1433 ! ADD BASE RSC /l 0x809 /d "NDEBUG"
 1434 ! ADD RSC /l 0x809 /d "NDEBUG"
 1435 BSC32 = bscmake.exe
 1436 ! ADD BASE BSC32 /nologo
 1437 ! ADD BSC32 /nologo
 1438 LINK32 = link.exe
 1439 ! ADD BASE LINK32 kernel32.lib /nologo /subsystem:console /machine:I386
 1440 ! ADD LINK32 kernel32.lib /nologo /subsystem:console /machine:I386
 1441 
 1442 !ELSEIF  "$(CFG)" = "camb - Win32 Debug"
 1443 
 1444 ! PROP BASE Use_MFC 0
 1445 ! PROP BASE Use_Debug_Libraries 1
 1446 ! PROP BASE Output_Dir "Debug"
 1447 ! PROP BASE Intermediate_Dir "Debug"
 1448 ! PROP BASE Target_Dir ""
 1449 ! PROP Use_MFC 0
 1450 ! PROP Use_Debug_Libraries 1
 1451 ! PROP Output_Dir "Debug"
 1452 ! PROP Intermediate_Dir "Debug"
 1453 ! PROP Ignore_Export_Lib 0
 1454 ! PROP Target_Dir ""
 1455 ! ADD BASE F90 /check:bounds /compile_only /dbglibs /debug:full /nologo /traceback /warn:argument_checking /warn:nofileopt
 1456 ! ADD F90 /check:bounds /compile_only /dbglibs /debug:full /fpp /nologo /traceback /warn:argument_checking /warn:nofileopt
 1457 ! ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
 1458 ! ADD CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /GZ /c
 1459 ! ADD BASE RSC /l 0x809 /d "_DEBUG"
 1460 ! ADD RSC /l 0x809 /d "_DEBUG"
 1461 BSC32 = bscmake.exe
 1462 ! ADD BASE BSC32 /nologo
 1463 ! ADD BSC32 /nologo
 1464 LINK32 = link.exe
 1465 ! ADD BASE LINK32 kernel32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept
 1466 ! ADD LINK32 kernel32.lib /nologo /subsystem:console /incremental:no /debug /machine:I386 /out:"camb.exe" /pdbtype:sept
 1467 
 1468 !ENDIF 
 1469 
 1470 ! Begin Target
 1471 
 1472 ! Name "camb - Win32 Release"
 1473 ! Name "camb - Win32 Debug"
 1474 ! Begin Group "Source Files"
 1475 
 1476 ! PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;f90;for;f;fpp"
 1477 ! Begin Source File
 1478 
 1479 SOURCE = .\bessels.f90
 1480 NODEP_F90_BESSE = \
 1481 	".\Debug\lvalues.mod"\
 1482 	".\Debug\ModelParams.mod"\
 1483 	".\Debug\Precision.mod"\
 1484 	
 1485 ! End Source File
 1486 ! Begin Source File
 1487 
 1488 SOURCE = .\camb.f90
 1489 NODEP_F90_CAMB_ = \
 1490 	".\Debug\CAMBmain.mod"\
 1491 	".\Debug\GaugeInterface.mod"\
 1492 	".\Debug\InitialPower.mod"\
 1493 	".\Debug\lensing.mod"\
 1494 	".\Debug\ModelData.mod"\
 1495 	".\Debug\ModelParams.mod"\
 1496 	".\Debug\Precision.mod"\
 1497 	".\Debug\Transfer.mod"\
 1498 	
 1499 ! End Source File
 1500 ! Begin Source File
 1501 
 1502 SOURCE = .\cmbmain.f90
 1503 NODEP_F90_CMBMA = \
 1504 	".\Debug\GaugeInterface.mod"\
 1505 	".\Debug\InitialPower.mod"\
 1506 	".\Debug\lvalues.mod"\
 1507 	".\Debug\MassiveNu.mod"\
 1508 	".\Debug\ModelData.mod"\
 1509 	".\Debug\ModelParams.mod"\
 1510 	".\Debug\NonLinear.mod"\
 1511 	".\Debug\Precision.mod"\
 1512 	".\Debug\SpherBessels.mod"\
 1513 	".\Debug\ThermoData.mod"\
 1514 	".\Debug\TimeSteps.mod"\
 1515 	".\Debug\Transfer.mod"\
 1516 	".\Debug\USpherBessels.mod"\
 1517 	
 1518 ! End Source File
 1519 ! Begin Source File
 1520 
 1521 SOURCE = .\constants.f90
 1522 ! End Source File
 1523 ! Begin Source File
 1524 
 1525 SOURCE = .\equations.f90
 1526 NODEP_F90_EQUAT = \
 1527 	".\Debug\lvalues.mod"\
 1528 	".\Debug\MassiveNu.mod"\
 1529 	".\Debug\ModelData.mod"\
 1530 	".\Debug\ModelParams.mod"\
 1531 	".\Debug\Precision.mod"\
 1532 	".\Debug\ThermoData.mod"\
 1533 	".\Debug\Transfer.mod"\
 1534 	
 1535 ! End Source File
 1536 ! Begin Source File
 1537 
 1538 SOURCE = .\halofit.f90
 1539 NODEP_F90_HALOF = \
 1540 	".\Debug\ModelParams.mod"\
 1541 	".\Debug\Transfer.mod"\
 1542 	
 1543 ! End Source File
 1544 ! Begin Source File
 1545 
 1546 SOURCE = .\inidriver.F90
 1547 NODEP_F90_INIDR = \
 1548 	".\Debug\AmlUtils.mod"\
 1549 	".\Debug\CAMB.mod"\
 1550 	".\Debug\F90_UNIX.mod"\
 1551 	".\Debug\IniFile.mod"\
 1552 	".\Debug\LambdaGeneral.mod"\
 1553 	".\Debug\lensing.mod"\
 1554 	".\Debug\RECFAST.MOD"\
 1555 	
 1556 ! End Source File
 1557 ! Begin Source File
 1558 
 1559 SOURCE = .\inifile.f90
 1560 ! End Source File
 1561 ! Begin Source File
 1562 
 1563 SOURCE = .\lensing.f90
 1564 NODEP_F90_LENSI = \
 1565 	".\Debug\InitialPower.mod"\
 1566 	".\Debug\lvalues.mod"\
 1567 	".\Debug\ModelData.mod"\
 1568 	".\Debug\ModelParams.mod"\
 1569 	".\Debug\Precision.mod"\
 1570 	
 1571 ! End Source File
 1572 ! Begin Source File
 1573 
 1574 SOURCE = .\modules.f90
 1575 NODEP_F90_MODUL = \
 1576 	".\Debug\AmlUtils.mod"\
 1577 	".\Debug\IniFile.mod"\
 1578 	".\Debug\InitialPower.mod"\
 1579 	".\Debug\Precision.mod"\
 1580 	".\Debug\RECFAST.MOD"\
 1581 	
 1582 ! End Source File
 1583 ! Begin Source File
 1584 
 1585 SOURCE = .\power_tilt.f90
 1586 NODEP_F90_POWER = \
 1587 	".\Debug\Precision.mod"\
 1588 	
 1589 ! End Source File
 1590 ! Begin Source File
 1591 
 1592 SOURCE = .\recfast.f90
 1593 NODEP_F90_RECFA = \
 1594 	".\Debug\Precision.mod"\
 1595 	
 1596 ! End Source File
 1597 ! Begin Source File
 1598 
 1599 SOURCE = .\reionization.f90
 1600 ! End Source File
 1601 ! Begin Source File
 1602 
 1603 SOURCE = .\subroutines.f90
 1604 ! End Source File
 1605 ! Begin Source File
 1606 
 1607 SOURCE = .\utils.F90
 1608 NODEP_F90_UTILS = \
 1609 	".\Debug\F90_UNIX.mod"\
 1610 	".\Debug\IFPORT.mod"\
 1611 	".\Debug\mpif.h"\
 1612 	".\xmll_use.mod"\
 1613 	".\XML_INCLUDE.F90"\
 1614 	".\xml_static_use.mod"\
 1615 	
 1616 ! End Source File
 1617 ! End Group
 1618 ! Begin Group "Header Files"
 1619 
 1620 ! PROP Default_Filter "h;hpp;hxx;hm;inl;fi;fd"
 1621 ! End Group
 1622 ! Begin Group "Resource Files"
 1623 
 1624 ! PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"
 1625 ! End Group
 1626 ! End Target
 1627 ! End Project
 1628 
 1629 
 1630 ** camb.f90
 1631 
 1632  !Interface module for CAMB. Call CAMB_GetResults to do the work.
 1633 
 1634      module CAMB
 1635          use Precision
 1636          use ModelParams
 1637          use ModelData
 1638          use Transfer
 1639          use GaugeInterface
 1640          use InitialPower
 1641          use Reionization
 1642          use Recombination
 1643          use lensing
 1644          implicit none
 1645          
 1646          Type CAMBdata
 1647             Type (ClTransferData) :: ClTransScal,ClTransTens,ClTransVec
 1648             Type (MatterTransferData) :: MTrans
 1649             Type (CAMBparams) :: Params
 1650          end Type CAMBdata
 1651 
 1652 !         public CAMB_GetTransfers, CAMB_GetResults, CAMB_GetCls, CAMB_SetDefParams, & 
 1653 !                CAMB_ValidateParams, CAMB_GetAge,CAMB_InitCAMBdata, 
 1654      contains
 1655 
 1656        subroutine CAMB_GetTransfers(Params, OutData, error)
 1657         use CAMBmain
 1658         use lensing
 1659         type(CAMBparams) :: Params
 1660         type (CAMBdata)  :: OutData
 1661         integer :: error !Zero if OK
 1662   
 1663       !Set internal types from OutData so it always 'owns' the memory, prevent leaks
 1664       
 1665         MT =  OutData%MTrans
 1666 
 1667         CTransScal = OutData%ClTransScal  
 1668         CTransVec  = OutData%ClTransVec  
 1669         CTransTens = OutData%ClTransTens
 1670   
 1671 
 1672         call CAMB_GetResults(Params, error)
 1673         OutData%Params = Params
 1674         OutData%MTrans = MT
 1675         OutData%ClTransScal = CTransScal
 1676         OutData%ClTransVec  = CTransVec
 1677         OutData%ClTransTens = CTransTens
 1678   
 1679        end subroutine CAMB_GetTransfers
 1680 
 1681        subroutine CAMB_InitCAMBdata(Dat)
 1682         type (CAMBdata) :: Dat
 1683  
 1684 !Comment these out to try to avoid intel bugs with status deallocating uninitialized pointers   
 1685         call Ranges_Nullify(Dat%ClTransScal%q)
 1686         call Ranges_Nullify(Dat%ClTransVec%q)
 1687         call Ranges_Nullify(Dat%ClTransTens%q)
 1688 
 1689         nullify(Dat%ClTransScal%Delta_p_l_k)
 1690         nullify(Dat%ClTransVec%Delta_p_l_k)
 1691         nullify(Dat%ClTransTens%Delta_p_l_k)
 1692         nullify(Dat%MTrans%sigma_8,Dat%MTrans%TransferData,Dat%MTrans%q_trans)
 1693              
 1694        end subroutine CAMB_InitCAMBdata
 1695 
 1696 
 1697        subroutine CAMB_FreeCAMBdata(Dat)
 1698             type (CAMBdata) :: Dat
 1699 
 1700             call Free_ClTransfer(Dat%ClTransScal)
 1701             call Free_ClTransfer(Dat%ClTransVec)
 1702             call Free_ClTransfer(Dat%ClTransTens)
 1703             call Transfer_Free(Dat%MTrans)
 1704 
 1705        end subroutine CAMB_FreeCAMBdata
 1706 
 1707 
 1708        subroutine CAMB_TransfersToPowers(CData)
 1709         use CAMBmain
 1710         use lensing
 1711         type (CAMBdata) :: CData
 1712 
 1713         CP = CData%Params
 1714         call InitializePowers(CP%InitPower,CP%curv)
 1715         if (global_error_flag/= 0) return
 1716         if (CData%Params%WantCls) then
 1717           call ClTransferToCl(CData%ClTransScal,CData%ClTransTens, CData%ClTransvec)  
 1718           if (CP%DoLensing .and. global_error_flag = 0) call lens_Cls
 1719           if (global_error_flag/= 0) return
 1720           if (CP%OutputNormalization = outCOBE) call COBEnormalize
 1721         end if
 1722         if (CData%Params%WantTransfer) call Transfer_Get_sigma8(Cdata%MTrans,8)
 1723      
 1724        end subroutine CAMB_TransfersToPowers
 1725   
 1726 
 1727 
 1728        !Call this routine with a set of parameters to generate the results you want.
 1729        subroutine CAMB_GetResults(Params, error)
 1730         use CAMBmain
 1731         use lensing
 1732         use Bispectrum
 1733         use Errors
 1734         type(CAMBparams) :: Params
 1735         integer, optional :: error !Zero if OK
 1736         type(CAMBparams) P
 1737         logical :: separate = .true. !whether to do P_k in separate call or not
 1738         logical :: InReionization
 1739         
 1740         if (Params%DoLensing .and. Params%NonLinear = NonLinear_Lens) separate = .false.
 1741         InReionization = Params%Reion%Reionization
 1742         global_error_flag = 0
 1743         
 1744          if (Params%WantCls .and. Params%WantScalars) then
 1745           P = Params
 1746           if (separate) then
 1747           P%WantTransfer = .false.
 1748           P%Transfer%high_precision = .false.
 1749           end if
 1750           P%WantTensors = .false.
 1751           P%WantVectors = .false.
 1752           call CAMBParams_Set(P)  
 1753           if (global_error_flag = 0) call cmbmain
 1754           if (global_error_flag/= 0) then
 1755             if (present(error)) error = global_error_flag
 1756             return 
 1757           end if
 1758           call_again = .true.
 1759           !Need to store CP%flat etc, but must keep original P_k settings
 1760           CP%Transfer%high_precision = Params%Transfer%high_precision
 1761           CP%WantTransfer = Params%WantTransfer
 1762           CP%WantTensors = Params%WantTensors
 1763           CP%WantVectors = Params%WantVectors
 1764           CP%Transfer%num_redshifts = Params%Transfer%num_redshifts
 1765           Params = CP            
 1766          end if
 1767  
 1768          if (Params%WantCls .and. Params%WantTensors) then
 1769           P = Params
 1770           P%WantTransfer = .false.
 1771           P%Transfer%high_precision = .false.
 1772           P%WantScalars = .false.
 1773           P%WantVectors = .false.
 1774           call CAMBParams_Set(P)  
 1775           if (global_error_flag = 0) call cmbmain
 1776           if (global_error_flag/= 0) then
 1777             if (present(error)) error = global_error_flag
 1778             return 
 1779           end if
 1780            call_again = .true.
 1781            CP%Transfer%high_precision = Params%Transfer%high_precision
 1782            CP%WantTransfer = Params%WantTransfer
 1783            CP%WantScalars = Params%WantScalars
 1784            CP%WantVectors = Params%WantVectors
 1785            CP%Transfer%num_redshifts = Params%Transfer%num_redshifts
 1786            Params = CP            
 1787    
 1788          end if
 1789  
 1790          if (Params%WantCls .and. Params%WantVectors) then
 1791           P = Params
 1792           P%WantTransfer = .false.
 1793           P%Transfer%high_precision = .false.
 1794           P%WantScalars = .false.
 1795           P%WantTensors = .false.
 1796           call CAMBParams_Set(P)  
 1797           if (global_error_flag = 0) call cmbmain
 1798           if (global_error_flag/= 0) then
 1799             if (present(error)) error = global_error_flag
 1800             return 
 1801           end if
 1802           call_again = .true.
 1803           CP%Transfer%high_precision = Params%Transfer%high_precision
 1804           CP%WantTransfer = Params%WantTransfer
 1805           CP%WantTensors = Params%WantTensors
 1806           CP%WantScalars = Params%WantScalars
 1807           CP%Transfer%num_redshifts = Params%Transfer%num_redshifts
 1808           Params = CP            
 1809    
 1810          end if
 1811 
 1812          if (Params%WantTransfer .and. &
 1813           .not. (Params%WantCls .and. Params%WantScalars .and. .not. separate)) then
 1814           P = Params
 1815           P%WantCls = .false.
 1816           P%WantScalars = .false.
 1817           P%WantTensors = .false.
 1818           P%WantVectors = .false.
 1819           call CAMBParams_Set(P)  
 1820           if (global_error_flag = 0) call cmbmain
 1821           if (global_error_flag/= 0) then
 1822             if (present(error)) error = global_error_flag
 1823             return 
 1824           end if
 1825           !Need to store num redshifts etc
 1826           CP%WantScalars = Params%WantScalars
 1827           CP%WantCls =  Params%WantCls
 1828           CP%WantTensors = Params%WantTensors
 1829           CP%WantVectors = Params%WantVectors
 1830           CP%Reion%Reionization = InReionization
 1831           Params = CP            
 1832 
 1833          end if
 1834 
 1835         call_again = .false.
 1836    
 1837 
 1838         if (.not. CP%OnlyTransfers) then
 1839 
 1840          if (CP%WantCls .and. CP%OutputNormalization = outCOBE) call COBEnormalize
 1841 
 1842          if (CP%DoLensing .and. global_error_flag = 0) then
 1843            call lens_Cls 
 1844          end if
 1845          
 1846          if (do_bispectrum .and. global_error_flag = 0) call GetBispectrum(CTransScal) 
 1847 
 1848         end if
 1849 
 1850         end subroutine CAMB_GetResults
 1851 
 1852 
 1853         !Return real (NOT double precision) arrays of the computed CMB  Cls
 1854         !Output is l(l+1)C_l/2pi
 1855         !If GC_Conventions = .false. use E-B conventions (as the rest of CAMB does)
 1856         subroutine CAMB_GetCls(Cls, lmax, in, GC_conventions)
 1857           integer, intent(IN) :: lmax, in
 1858           logical, intent(IN) :: GC_conventions
 1859           real, intent(OUT) :: Cls(2:lmax,1:4)
 1860           integer l
 1861       
 1862           Cls = 0
 1863           do l = 2, lmax
 1864              if (CP%WantScalars .and. l< = CP%Max_l) then
 1865              Cls(l,1:2) = Cl_scalar(l, in,  C_Temp:C_E)
 1866              Cls(l,4) = Cl_scalar(l, in,  C_Cross)
 1867              end if
 1868              if (CP%WantTensors .and. l < = CP%Max_l_tensor) then
 1869                 Cls(l,1:4) = Cls(l,1:4) + Cl_tensor(l, in,  CT_Temp:CT_Cross)
 1870              end if
 1871           end do
 1872           if (GC_conventions) then
 1873              Cls(:,2:3) = Cls(:,2:3)/2
 1874              Cls(:,4)   = Cls(:,4)/sqrt(2.0)             
 1875           end if
 1876  
 1877         end subroutine CAMB_GetCls
 1878 
 1879         function CAMB_GetAge(P)
 1880            !Return age in gigayears, returns -1 on error
 1881            use constants
 1882            type(CAMBparams), intent(in) :: P
 1883            real(dl) CAMB_GetAge
 1884            real(dl) atol,a1,a2, dtda, rombint
 1885 !           real(dl), parameter :: Mpc = 3.085678e22, &
 1886 !                 c = 2.99792458e8, Gyr = 3.1556926e16
 1887            integer error
 1888            external dtda,rombint
 1889 
 1890 
 1891            call  CAMBParams_Set(P, error, .false.)
 1892 
 1893            if (error/= 0) then
 1894             CAMB_GetAge = -1
 1895            else
 1896 
 1897            atol = 1d-4
 1898            a1 = 0
 1899            a2 = 1
 1900            CAMB_GetAge = rombint(dtda,a1,a2,atol)*Mpc/c/Gyr
 1901            end if
 1902     
 1903          end function CAMB_GetAge
 1904 
 1905 
 1906         function CAMB_GetZreFromTau(P, tau)
 1907            type(CAMBparams) :: P
 1908            real(dl) tau
 1909            real(dl) CAMB_GetZreFromTau
 1910            integer error
 1911 
 1912             P%Reion%use_optical_depth = .true.
 1913             P%Reion%optical_depth = tau
 1914             call CAMBParams_Set(P,error)
 1915             
 1916             CAMB_GetZreFromTau = CP%Reion%redshift
 1917 
 1918         end function CAMB_GetZreFromTau
 1919 
 1920       
 1921         subroutine CAMB_SetDefParams(P)
 1922             use Bispectrum
 1923             type(CAMBparams), intent(out) :: P
 1924 
 1925             P%WantTransfer = .false.
 1926             P%WantCls = .true.
 1927 
 1928             P%omegab  = .045
 1929             P%omegac  = 0.255
 1930             P%omegav  = 0.7
 1931             P%omegan  = 0
 1932             P%H0      = 65
 1933 
 1934             P%TCMB    = 2.726
 1935             P%YHe     = 0.24
 1936             P%Num_Nu_massless = 3.04
 1937             P%Num_Nu_massive  = 0
 1938             P%Nu_mass_splittings = .false.
 1939             P%Nu_mass_eigenstates = 0
 1940            
 1941             P%Scalar_initial_condition = initial_adiabatic
 1942             P%NonLinear = NonLinear_none
 1943             
 1944             call SetDefPowerParams(P%InitPower)
 1945 
 1946             call Recombination_SetDefParams(P%Recomb)
 1947           
 1948             call Reionization_SetDefParams(P%Reion)
 1949             
 1950             P%Transfer%high_precision = .false.
 1951     
 1952             P%OutputNormalization = outNone
 1953 
 1954             P%WantScalars = .true.
 1955             P%WantVectors = .false.
 1956             P%WantTensors = .false.
 1957             P%want_zstar = .false.  !!JH 
 1958             P%want_zdrag = .false.  !!JH  
 1959 
 1960             P%Max_l = 1500
 1961             P%Max_eta_k = 3000
 1962             P%Max_l_tensor = 400
 1963             P%Max_eta_k_tensor = 800
 1964             !Set up transfer just enough to get sigma_8 OK
 1965             P%Transfer%kmax = 0.9  
 1966             P%Transfer%k_per_logint = 0
 1967             P%Transfer%num_redshifts = 1
 1968             P%Transfer%redshifts = 0
 1969 
 1970             P%AccuratePolarization = .true.
 1971             P%AccurateReionization = .false.
 1972             P%AccurateBB = .false.
 1973 
 1974             P%DoLensing = .false.
 1975 
 1976             P%MassiveNuMethod = Nu_best
 1977             P%OnlyTransfers = .false.
 1978 
 1979          end subroutine CAMB_SetDefParams
 1980 
 1981 
 1982          !Stop with error is not good
 1983          function CAMB_ValidateParams(P) result(OK)
 1984             type(CAMBparams), intent(in) :: P
 1985             logical OK
 1986 
 1987              OK = .true.
 1988              if (.not. P%WantTransfer .and. .not. P%WantCls) then
 1989                 OK = .false.
 1990                 write(*,*) 'There is nothing to do! Do transfer functions or Cls.'
 1991              end if
 1992 
 1993              if (P%h0 < 20.or.P%h0 > 100) then
 1994                OK = .false.
 1995                write(*,*) '  Warning: H0 has units of km/s/Mpc. You have:', P%h0
 1996             end if
 1997              if (P%tcmb < 2.7.or.P%tcmb > 2.8) then
 1998                 write(*,*) '  Warning: Tcmb has units of K.  Your have:', P%tcmb
 1999              end if
 2000 
 2001              if (P%yhe < 0.2.or.P%yhe > 0.8) then
 2002                 OK = .false.
 2003                 write(*,*) &
 2004                      '  Warning: YHe is the Helium fraction of baryons.', &
 2005                      '  Your have:', P%yhe
 2006              end if
 2007              if (P%Num_Nu_massive < 0.or.P%Num_Nu_massive > 3.1) then
 2008                 OK = .false.
 2009                 write(*,*) &
 2010                      'Warning: Num_Nu_massive is strange:',P%Num_Nu_massive 
 2011               end if
 2012              if (P%Num_Nu_massless < 0.or.P%Num_Nu_massless > 3.1) then
 2013                 OK = .false.
 2014                 write(*,*) &
 2015                      'Warning: Num_nu_massless is strange:', P%Num_Nu_massless
 2016               end if
 2017              if (P%Num_Nu_massive < 1 .and. P%omegan > 0.0) then
 2018                 OK = .false.
 2019                 write(*,*) &
 2020                      'Warning: You have omega_neutrino > 0, but no massive species'
 2021               end if
 2022 
 2023 
 2024              if (P%omegab<0.001 .or. P%omegac<0 .or. P%omegab>1 .or. P%omegac>3) then
 2025                 OK = .false.
 2026                 write(*,*) 'Your matter densities are strange'
 2027              end if
 2028 
 2029              if (P%WantScalars .and. P%Max_eta_k < P%Max_l .or.  &
 2030                   P%WantTensors .and. P%Max_eta_k_tensor < P%Max_l_tensor) then
 2031                 OK = .false.
 2032                 write(*,*) 'You need Max_eta_k larger than Max_l to get good results'
 2033              end if
 2034              
 2035              call Reionization_Validate(P%Reion, OK)
 2036              call Recombination_Validate(P%Recomb, OK)
 2037 
 2038              if (P%WantTransfer) then
 2039               if (P%transfer%num_redshifts > max_transfer_redshifts .or. P%transfer%num_redshifts<1) then
 2040                 OK = .false.
 2041                 write(*,*) 'Maximum ',  max_transfer_redshifts, &
 2042                      'redshifts. You have: ', P%transfer%num_redshifts 
 2043               end if
 2044               if (P%transfer%kmax < 0.01 .or. P%transfer%kmax > 50000 .or. &
 2045                      P%transfer%k_per_logint>0 .and.  P%transfer%k_per_logint <1) then
 2046                  OK = .false.
 2047                  write(*,*) 'Strange transfer function settings.'
 2048               end if
 2049               if (P%transfer%num_redshifts > max_transfer_redshifts .or. P%transfer%num_redshifts<1) then
 2050                 OK = .false.
 2051                 write(*,*) 'Maximum ',  max_transfer_redshifts, &
 2052                      'redshifts. You have: ', P%transfer%num_redshifts 
 2053               end if
 2054 
 2055 
 2056              end if
 2057 
 2058          end function CAMB_ValidateParams
 2059 
 2060          subroutine CAMB_cleanup
 2061           use ThermoData
 2062           use SpherBessels
 2063           use ModelData
 2064           use Transfer
 2065 
 2066             !Free memory
 2067            call ThermoData_Free
 2068            call Bessels_Free
 2069            call ModelData_Free  
 2070            call Transfer_Free(MT)
 2071 
 2072          end subroutine CAMB_cleanup
 2073 
 2074 
 2075   end module CAMB
 2076 
 2077 
 2078   function dtda(a)
 2079           use Precision
 2080           implicit none
 2081           real(dl) dtda,dtauda,a
 2082           external dtauda
 2083           
 2084           dtda = dtauda(a)*a
 2085   end function
 2086 
 2087 ** cmbmain.f90
 2088 
 2089 !     This this is the main CAMB program module.
 2090 !
 2091 !     Code for Anisotropies in the Microwave Background
 2092 !     by Antony lewis (http://cosmologist.info) and Anthony Challinor
 2093 !     See readme.html for documentation. 
 2094 
 2095 !     Note that though the code is internally parallelised, it is not thread-safe
 2096 !     so you cannot generate more than one model at the same time in different threads.
 2097 !
 2098 !     Based on CMBFAST  by  Uros Seljak and Matias Zaldarriaga, itself based
 2099 !     on Boltzmann code written by Edmund Bertschinger, Chung-Pei Ma and Paul Bode.
 2100 !     Original CMBFAST copyright and disclaimer:
 2101 !
 2102 !     Copyright 1996 by Harvard-Smithsonian Center for Astrophysics and
 2103 !     the Massachusetts Institute of Technology.  All rights reserved.
 2104 !
 2105 !     THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. OR C.f.A. MAKE NO
 2106 !     REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPlIED.
 2107 !     By way of example, but not limitation,
 2108 !     M.I.T. AND C.f.A MAKE NO REPRESENTATIONS OR WARRANTIES OF
 2109 !     MERCHANTABIlITY OR FITNESS FOR ANY PARTICUlAR PURPOSE OR THAT
 2110 !     THE USE OF THE lICENSED SOFTWARE OR DOCUMENTATION WIll NOT INFRINGE
 2111 !     ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS.
 2112 !
 2113 !     portions of this software are based on the COSMICS package of
 2114 !     E. Bertschinger.  See the lICENSE file of the COSMICS distribution
 2115 !     for restrictions on the modification and distribution of this software.
 2116 
 2117   module CAMBmain
 2118 
 2119 !     This code evolves the linearized perturbation equations of general relativity,
 2120 !     the Boltzmann equations and the fluid equations for perturbations
 2121 !     of a Friedmann-Robertson-Walker universe with a supplied system of gauge-dependent equation
 2122 !     in a modules called GaugeInterface.  The sources for the line of sight integral are
 2123 !     computed at sampled times during the evolution for various of wavenumbers. The sources
 2124 !     are then interpolated to a denser wavenumber sampling for computing the line of
 2125 !     sight integrals of the form Integral d(conformal time) source_k * bessel_k_l. 
 2126 !     For CP%flat models the bessel functions are interpolated from a pre-computed table, for
 2127 !     non-CP%flat models the hyperspherical Bessel functions are computed by integrating their
 2128 !     differential equation. Both phases ('Evolution' and 'Integration') can do separate 
 2129 !     wavenumbers in parallel.
 2130 
 2131 !     The time variable is conformal  time dtau = dt/a(t) and the spatial dependence is Fourier transformed 
 2132 !     with q = sqrt(k**2 + (|m|+1)K), comoving distances are x = CP%r/a(t), with a(t) = 1 today.  
 2133 !     The units of both length and time are Mpc.
 2134 
 2135 !    Many elements are part of derived types (to make thread safe or to allow non-sequential code use
 2136 !    CP = CAMB parameters
 2137 !    EV = Time evolution variables
 2138 !    IV = Source integration variables
 2139 !    CT = Cl transfer data
 2140 !    MT = matter transfer data
 2141 
 2142 ! Modules are defined in modules.f90, except GaugeInterface which gives the background and gauge-dependent 
 2143 ! perturbation equations, and InitialPower which provides the initial power spectrum.
 2144 
 2145       use precision
 2146       use ModelParams
 2147       use ModelData
 2148       use GaugeInterface
 2149       use Transfer
 2150       use SpherBessels
 2151       use lvalues
 2152       use MassiveNu
 2153       use InitialPower
 2154       use Errors
 2155 
 2156       implicit none
 2157 
 2158       private
 2159 
 2160       logical ExactClosedSum  !do all nu values in sum for Cls for Omega_k>0.1
 2161   
 2162 
 2163       !Variables for integrating the sources with the bessel functions for each wavenumber
 2164        type IntegrationVars
 2165           integer q_ix
 2166           real(dl) q, dq    !q value we are doing and delta q
 2167   !        real(dl), dimension(:,:), pointer :: Delta_l_q
 2168             !Contribution to C_l integral from this k 
 2169           real(dl), dimension(:,:), pointer :: Source_q, ddSource_q
 2170             !Interpolated sources for this k
 2171     
 2172           integer SourceSteps !number of steps up to where source is zero
 2173 
 2174       end type IntegrationVars
 2175       
 2176       integer SourceNum
 2177       !SourceNum is total number sources (2 or 3 for scalars, 3 for tensors).
 2178 
 2179       real(dl) tautf(0:max_transfer_redshifts)  !Time of Trasfer%redshifts
 2180         
 2181 
 2182       real(dl), dimension(:,:,:), allocatable :: Src, ddSrc !Sources and second derivs
 2183         ! indices  Src( k_index, source_index, time_step_index )    
 2184   
 2185       real(dl), dimension(:,:,:), allocatable :: iCl_scalar, iCl_vector,iCl_tensor
 2186        ! Cls at the l values we actually compute,  iCl_xxx(l_index, Cl_type, initial_power_index)
 2187       
 2188       Type(Regions) :: Evolve_q
 2189 
 2190       real(dl),parameter :: qmin0 = 0.1
 2191 
 2192       real(dl) :: dtaurec_q
 2193     
 2194 !     qmax - CP%Max_eta_k/CP%tau0, qmin = qmin0/CP%tau0 for flat case
 2195 
 2196       real(dl) qmin, qmax 
 2197 
 2198       real(dl) max_etak_tensor , max_etak_vector, max_etak_scalar
 2199  !     Will only be calculated if k*tau < max_etak_xx
 2200 
 2201       integer maximum_l !Max value of l to compute
 2202       real(dl) :: maximum_qeta = 3000
 2203 
 2204       real(dl) :: fixq = 0 !Debug output of one q
 2205       
 2206       Type(ClTransferData), pointer :: ThisCT
 2207                     
 2208       public cmbmain, ClTransferToCl, InitVars !InitVars for BAO hack
 2209 
 2210 contains  
 2211 
 2212      
 2213       subroutine cmbmain
 2214       integer q_ix 
 2215       type(EvolutionVars) EV
 2216   
 2217 !     Timing variables for testing purposes. Used if DebugMsgs = .true. in ModelParams
 2218       real(sp) actual,timeprev,starttime
 2219 
 2220       if (CP%WantCls) then
 2221         
 2222          if (CP%WantTensors .and. CP%WantScalars) stop 'CMBMAIN cannot generate tensors and scalars'
 2223          !Use CAMB_GetResults instead
 2224 
 2225          if (CP%WantTensors) then
 2226             maximum_l = CP%Max_l_tensor 
 2227             maximum_qeta = CP%Max_eta_k_tensor
 2228          else
 2229             maximum_l = CP%Max_l
 2230             maximum_qeta = CP%Max_eta_k
 2231          end if
 2232 
 2233    
 2234          call initlval(lSamp, maximum_l)
 2235          
 2236          if (CP%flat)  call InitSpherBessels
 2237          !This is only slow if not called before with same (or higher) Max_l, Max_eta_k
 2238          !Preferably stick to Max_l being a multiple of 50
 2239       end if 
 2240 
 2241 
 2242       if (DebugMsgs .and. Feedbacklevel > 0) then
 2243          actual = GetTestTime()
 2244          starttime = actual !times don't include reading the Bessel file
 2245        end if
 2246     
 2247       call InitVars !Most of single thread time spent here (in InitRECFAST)
 2248       if (global_error_flag/= 0) return
 2249 
 2250       if (DebugMsgs .and. Feedbacklevel > 0) then
 2251          timeprev = actual
 2252          actual = GetTestTime()
 2253          write(*,*) actual-timeprev,' Timing for InitVars'
 2254          write (*,*) 'r = ',real(CP%r),' scale = ',real(scale), 'age = ', real(CP%tau0)  
 2255       end if 
 2256 
 2257        if (.not. CP%OnlyTransfers)  call InitializePowers(CP%InitPower,CP%curv)
 2258        if (global_error_flag/= 0) return
 2259 
 2260 !     Calculation of the CMB sources.
 2261 
 2262 
 2263       if (CP%WantCls) call SetkValuesForSources 
 2264 
 2265       if (CP%WantTransfer) call InitTransfer
 2266  
 2267 !      ***note that !$ is the prefix for conditional multi-processor compilation***
 2268       !$ if (ThreadNum /= 0) call OMP_SET_NUM_THREADS(ThreadNum)
 2269         
 2270    
 2271       if (CP%WantCls) then
 2272 
 2273          if (DebugMsgs .and. Feedbacklevel > 0) write(*,*) 'Set ',Evolve_q%npoints,' source k values'
 2274          
 2275          call GetSourceMem
 2276 
 2277          if (CP%WantScalars) then
 2278              ThisCT = > CTransScal
 2279          else if (CP%WantVectors) then
 2280              ThisCT = > CTransVec
 2281          else
 2282              ThisCT = > CTransTens
 2283          end if
 2284 
 2285          ThisCT%NumSources = SourceNum
 2286          ThisCT%ls = lSamp
 2287 
 2288          !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(DYNAMIC) &
 2289          !$OMP & PRIVATE(EV, q_ix)
 2290          do q_ix = 1,Evolve_q%npoints
 2291              if (global_error_flag = 0) call DoSourcek(EV,q_ix)
 2292          end do
 2293          !$OMP END PARAllEl DO
 2294         
 2295          if (DebugMsgs .and. Feedbacklevel > 0) then
 2296             timeprev = actual
 2297             actual = GetTestTime()
 2298             write(*,*) actual-timeprev,' Timing for source calculation'
 2299          end if
 2300 
 2301       endif !WantCls
 2302 
 2303    
 2304 !     If transfer functions are requested, set remaining k values and output
 2305       if (CP%WantTransfer .and. global_error_flag = 0) then
 2306         call TransferOut
 2307          if (DebugMsgs .and. Feedbacklevel > 0) then
 2308          timeprev = actual
 2309          actual = GetTestTime()
 2310          write(*,*) actual-timeprev,' Timing for transfer k values'
 2311          end if  
 2312       end if
 2313 
 2314        if (CP%WantTransfer .and. CP%WantCls .and. CP%DoLensing &
 2315             .and. CP%NonLinear = NonLinear_Lens .and. global_error_flag = 0) then
 2316           
 2317           call NonLinearLensing
 2318           if (DebugMsgs .and. Feedbacklevel > 0) then
 2319              timeprev = actual
 2320              actual = GetTestTime()
 2321              write(*,*) actual-timeprev,' Timing for NonLinear'
 2322           end if
 2323 
 2324        end if
 2325 
 2326        if (CP%WantTransfer .and. .not. CP%OnlyTransfers .and. global_error_flag = 0) &
 2327           call Transfer_Get_sigma8(MT,8) 
 2328            !Can call with other arguments if need different size
 2329  
 2330 !     if CMB calculations are requested, calculate the Cl by
 2331 !     integrating the sources over time and over k.
 2332 
 2333 
 2334       if (CP%WantCls) then
 2335          
 2336          if (global_error_flag = 0) then
 2337           
 2338          call InitSourceInterpolation   
 2339        
 2340          ExactClosedSum = CP%curv > 5e-9 .or. scale < 0.93
 2341      
 2342          call SetkValuesForInt
 2343 
 2344          if (DebugMsgs .and. Feedbacklevel > 0) write(*,*) 'Set ',ThisCT%q%npoints,' integration k values'
 2345    
 2346       !Begin k-loop and integrate Sources*Bessels over time
 2347 
 2348       
 2349       !$OMP PARAllEl DO DEFAUlT(SHARED),SHARED(TimeSteps), SCHEDUlE(STATIC,4) 
 2350           do q_ix = 1,ThisCT%q%npoints
 2351             call SourceToTransfers(q_ix)
 2352          end do !q loop
 2353        !$OMP END PARAllEl DO 
 2354   
 2355         if (DebugMsgs .and. Feedbacklevel > 0) then
 2356          timeprev = actual
 2357          actual = GetTestTime()
 2358          write(*,*)actual-timeprev,' Timing For Integration'
 2359         end if
 2360  
 2361         end if
 2362         
 2363         call FreeSourceMem
 2364 
 2365         !Final calculations for CMB output unless want the Cl transfer functions only.
 2366 
 2367         if (.not. CP%OnlyTransfers .and. global_error_flag = 0) &
 2368           call ClTransferToCl(CTransScal,CTransTens, CTransVec)
 2369 
 2370       end if
 2371 
 2372  
 2373       if (DebugMsgs .and. Feedbacklevel > 0) then
 2374          timeprev = actual
 2375          actual = GetTestTime()
 2376          write(*,*) actual - timeprev,' Timing for final output'
 2377          write(*,*) actual -starttime,' Timing for whole of cmbmain'
 2378       end if
 2379 
 2380       end subroutine cmbmain
 2381 
 2382      subroutine ClTransferToCl(CTransS,CTransT, CTransV)
 2383         Type(ClTransferData) :: CTransS,CTransT, CTransV
 2384 
 2385        if (CP%WantScalars .and. global_error_flag = 0) then
 2386            lSamp = CTransS%ls
 2387            allocate(iCl_Scalar(CTransS%ls%l0,C_Temp:C_last,CP%InitPower%nn))
 2388            iCl_scalar = 0
 2389            
 2390            call CalcScalCls(CTransS)
 2391            if (DebugMsgs .and. Feedbacklevel > 0) write (*,*) 'CalcScalCls'
 2392        end if    
 2393 
 2394        if (CP%WantVectors .and. global_error_flag = 0) then
 2395            allocate(iCl_vector(CTransV%ls%l0,C_Temp:CT_Cross,CP%InitPower%nn))
 2396            iCl_vector = 0
 2397            call CalcVecCls(CTransV,GetInitPowerArrayVec)
 2398            if (DebugMsgs .and. Feedbacklevel > 0) write (*,*) 'CalcVecCls'
 2399        end if    
 2400 
 2401 
 2402        if (CP%WantTensors .and. global_error_flag = 0) then
 2403            allocate(iCl_Tensor(CTransT%ls%l0,CT_Temp:CT_Cross,CP%InitPower%nn))
 2404            iCl_tensor = 0
 2405            call CalcTensCls(CTransT,GetInitPowerArrayTens)
 2406            if (DebugMsgs .and. Feedbacklevel > 0) write (*,*) 'CalcTensCls'
 2407        end if
 2408 
 2409        if (global_error_flag = 0) then
 2410         call Init_Cls
 2411  
 2412   !     Calculating Cls for every l.
 2413         call InterpolateCls(CTransS,CTransT, CTransV)
 2414    
 2415         if (DebugMsgs .and. Feedbacklevel > 0) write (*,*) 'InterplolateCls'
 2416 
 2417        end if
 2418 
 2419        if (CP%WantScalars .and. allocated(iCl_Scalar)) deallocate(iCl_scalar)
 2420        if (CP%WantVectors .and. allocated(iCl_Vector)) deallocate(iCl_vector)
 2421        if (CP%WantTensors .and. allocated(iCl_Tensor)) deallocate(iCl_tensor)
 2422        
 2423        if (global_error_flag/= 0) return
 2424  
 2425        if (CP%OutputNormalization > = 2) call NormalizeClsAtl(CP%OutputNormalization)
 2426        !Normalize to C_l = 1 at l = OutputNormalization 
 2427      
 2428      end subroutine ClTransferToCl
 2429     
 2430 
 2431      subroutine SourceToTransfers(q_ix)
 2432       integer q_ix
 2433       type(IntegrationVars) :: IV
 2434     
 2435           allocate(IV%Source_q(TimeSteps%npoints,SourceNum))
 2436           if (.not.CP%flat) allocate(IV%ddSource_q(TimeSteps%npoints,SourceNum))
 2437 
 2438             call IntegrationVars_init(IV)
 2439 
 2440             IV%q_ix = q_ix
 2441             IV%q = ThisCT%q%points(q_ix)
 2442             IV%dq = ThisCT%q%dpoints(q_ix)
 2443 
 2444             call InterpolateSources(IV)
 2445            
 2446             call DoSourceIntegration(IV)
 2447 
 2448           if (.not.CP%flat) deallocate(IV%ddSource_q) 
 2449           deallocate(IV%Source_q)
 2450          
 2451      end subroutine SourceToTransfers
 2452     
 2453 
 2454       subroutine InitTransfer
 2455         integer nu,lastnu, ntodo, nq, q_ix, first_i
 2456         real(dl) dlog_lowk1,dlog_lowk, d_osc,dlog_osc, dlog_highk, boost
 2457         real(dl) amin,q_switch_lowk,q_switch_lowk1,q_switch_osc,q_switch_highk
 2458         real(dl), dimension(:), allocatable :: q_transfer
 2459 
 2460        if (CP%Transfer%k_per_logint = 0) then
 2461         !Optimized spacing
 2462         !Large log spacing on superhorizon scales
 2463         !Linear spacing for horizon scales and first few baryon osciallations
 2464         !Log spacing for last few oscillations
 2465         !large log spacing for small scales
 2466 
 2467            boost = AccuracyBoost 
 2468            if (CP%Transfer%high_precision) boost = boost*1.5
 2469 
 2470            q_switch_lowk1 = 0.7/taurst
 2471            dlog_lowk1 = 2*boost
 2472 
 2473            q_switch_lowk = 8/taurst
 2474            dlog_lowk = 8*boost
 2475            if (HighAccuracyDefault) dlog_lowk = dlog_lowk*2.5
 2476 
 2477            q_switch_osc = min(CP%Transfer%kmax,30/taurst)
 2478            d_osc = 200*boost
 2479            if (HighAccuracyDefault) d_osc = d_osc*1.8
 2480     
 2481            q_switch_highk = min(CP%Transfer%kmax,60/taurst)
 2482            dlog_osc = 17*boost 
 2483            if (HighAccuracyDefault) q_switch_highk = min(CP%Transfer%kmax,90/taurst)
 2484 
 2485            !Then up to kmax
 2486            dlog_highk = 3*boost
 2487             
 2488            amin = 5e-5
 2489 
 2490            nq = int((log(CP%Transfer%kmax/amin))*d_osc)+1 
 2491            allocate(q_transfer(nq))
 2492      
 2493            nq = int((log(q_switch_lowk1/amin))*dlog_lowk1)+1 
 2494            do q_ix = 1, nq
 2495             q_transfer(q_ix) = amin*exp((q_ix-1)/dlog_lowk1)
 2496            end do
 2497            MT%num_q_trans = nq
 2498 
 2499            nq = int(log( q_switch_lowk/q_transfer(MT%num_q_trans))*dlog_lowk) +1
 2500            do q_ix = 1, nq
 2501             q_transfer(MT%num_q_trans+q_ix) = q_transfer(MT%num_q_trans)*exp(q_ix/dlog_lowk)
 2502            end do
 2503            MT%num_q_trans = MT%num_q_trans + nq
 2504 
 2505            nq = int((q_switch_osc-q_transfer(MT%num_q_trans))*d_osc)+1 
 2506            do q_ix = 1, nq
 2507             q_transfer(MT%num_q_trans+q_ix) = q_transfer(MT%num_q_trans)+ q_ix/d_osc
 2508            end do
 2509            MT%num_q_trans = MT%num_q_trans + nq
 2510 
 2511            if (CP%Transfer%kmax > q_transfer(MT%num_q_trans)) then
 2512             nq = int(log( q_switch_highk/q_transfer(MT%num_q_trans))*dlog_osc) +1
 2513             do q_ix = 1, nq
 2514              q_transfer(MT%num_q_trans+q_ix) = q_transfer(MT%num_q_trans)*exp(q_ix/dlog_osc)
 2515             end do
 2516             MT%num_q_trans = MT%num_q_trans + nq
 2517            end if
 2518 
 2519            if (CP%Transfer%kmax > q_transfer(MT%num_q_trans)) then
 2520             nq = int(log(CP%Transfer%kmax/q_transfer(MT%num_q_trans))*dlog_highk)+1 
 2521             do q_ix = 1, nq
 2522              q_transfer(MT%num_q_trans+q_ix) = q_transfer(MT%num_q_trans)*exp(q_ix/dlog_highk)
 2523             end do
 2524             MT%num_q_trans = MT%num_q_trans + nq
 2525            end if
 2526    
 2527         else
 2528          !Fixed spacing
 2529           MT%num_q_trans = int((log(CP%Transfer%kmax)-log(qmin))*CP%Transfer%k_per_logint)+1
 2530           allocate(q_transfer(MT%num_q_trans))
 2531           do q_ix = 1, MT%num_q_trans
 2532             q_transfer(q_ix) = qmin*exp(real(q_ix)/CP%Transfer%k_per_logint)
 2533           end do
 2534         end if
 2535 
 2536          if (CP%closed) then
 2537               lastnu = 0
 2538               ntodo = 0
 2539                do q_ix = 1,MT%num_q_trans
 2540                 nu = nint(CP%r*q_transfer(q_ix))
 2541                 if (.not. ((nu<3).or.(nu< = lastnu))) then
 2542                    ntodo = ntodo+1
 2543                    q_transfer(ntodo) = nu/CP%r
 2544                    lastnu = nu
 2545                 end if
 2546                end do
 2547               MT%num_q_trans = ntodo
 2548          end if
 2549 
 2550          if (CP%WantCls) then
 2551                ntodo = MT%num_q_trans
 2552                first_i = ntodo+1
 2553                do q_ix = 1,ntodo
 2554                 if (q_transfer(q_ix) > qmax) then
 2555                       first_i = q_ix 
 2556                       exit
 2557                 end if
 2558                end do            
 2559            
 2560                if (first_i > ntodo) then
 2561                MT%num_q_trans = Evolve_q%npoints 
 2562               else
 2563                MT%num_q_trans = Evolve_q%npoints + (ntodo - first_i+1) 
 2564               end if
 2565               call Transfer_Allocate(MT)
 2566 
 2567               MT%q_trans(1:Evolve_q%npoints) = Evolve_q%points(1:Evolve_q%npoints)
 2568               if (MT%num_q_trans > Evolve_q%npoints) then
 2569                MT%q_trans(Evolve_q%npoints+1:MT%num_q_trans) = q_transfer(first_i:ntodo)
 2570           end if
 2571 
 2572          else
 2573              Evolve_q%npoints = 0
 2574              call Transfer_Allocate(MT)
 2575              MT%q_trans = q_transfer(1:MT%num_q_trans)
 2576          end if
 2577           
 2578          deallocate(q_transfer)
 2579   
 2580       end  subroutine InitTransfer
 2581 
 2582       function GetTauStart(q)
 2583         real(dl), intent(IN) :: q
 2584         real(dl) taustart, GetTauStart
 2585 
 2586 !     Begin when wave is far outside horizon.
 2587 !     Conformal time (in Mpc) in the radiation era, for photons plus 3 species
 2588 !     of relativistic neutrinos.
 2589             if (CP%flat) then
 2590               taustart = 0.001/q
 2591             else
 2592               taustart = 0.001/sqrt(q**2-CP%curv)
 2593              end if
 2594 
 2595 !     Make sure to start early in the radiation era.
 2596            taustart = min(taustart,0.1)
 2597 
 2598 !     Start when massive neutrinos are strongly relativistic.
 2599             if (CP%Num_nu_massive>0) then
 2600                taustart = min(taustart,1.d-3/maxval(nu_masses(1:CP%Nu_mass_eigenstates))/adotrad)
 2601             end if
 2602 
 2603             GetTauStart = taustart
 2604       end function GetTauStart
 2605 
 2606 
 2607       subroutine DoSourcek(EV,q_ix)
 2608         integer q_ix
 2609         real(dl) taustart
 2610         type(EvolutionVars) EV
 2611 
 2612             EV%q = Evolve_q%points(q_ix) 
 2613  
 2614             if (fixq/= 0) then
 2615                 EV%q = fixq !for testing
 2616             end if
 2617             EV%q2 = EV%q**2
 2618 
 2619             EV%q_ix = q_ix
 2620             EV%TransferOnly = .false.
 2621       
 2622             taustart = GetTauStart(EV%q)
 2623    
 2624             call GetNumEqns(EV)
 2625 
 2626             if (CP%WantScalars .and. global_error_flag = 0) call CalcScalarSources(EV,taustart)
 2627             if (CP%WantVectors .and. global_error_flag = 0) call CalcVectorSources(EV,taustart)
 2628             if (CP%WantTensors .and. global_error_flag = 0) call CalcTensorSources(EV,taustart)
 2629 
 2630       end subroutine DoSourcek
 2631 
 2632        subroutine GetSourceMem
 2633      
 2634         if (CP%WantScalars) then
 2635            if (CP%Dolensing) then
 2636             SourceNum = 3
 2637             C_last = C_PhiE
 2638          else
 2639             SourceNum = 2
 2640             C_last = C_Cross
 2641            end if
 2642         else
 2643            SourceNum = 3 
 2644         end if
 2645        
 2646         allocate(Src(Evolve_q%npoints,SourceNum,TimeSteps%npoints))
 2647         Src = 0
 2648         allocate(ddSrc(Evolve_q%npoints,SourceNum,TimeSteps%npoints))
 2649     
 2650        end subroutine GetSourceMem
 2651 
 2652 
 2653        subroutine FreeSourceMem
 2654          
 2655         if (allocated(Src))deallocate(Src, ddSrc)
 2656         call Ranges_Free(Evolve_q)
 2657 
 2658        end subroutine FreeSourceMem
 2659 
 2660 
 2661 !  initial variables, number of steps, etc.
 2662       subroutine InitVars
 2663       use ThermoData
 2664       use precision
 2665       use ModelParams
 2666       
 2667       implicit none
 2668       real(dl) taumin, maxq, initAccuracyBoost
 2669       integer itf
 2670       
 2671       initAccuracyBoost = AccuracyBoost 
 2672 
 2673  ! Maximum and minimum k-values.      
 2674       if (CP%flat) then
 2675       qmax = maximum_qeta/CP%tau0
 2676       qmin = qmin0/CP%tau0/initAccuracyBoost 
 2677       else              
 2678         qmax = maximum_qeta/CP%r/CP%chi0
 2679         qmin = qmin0/CP%r/CP%chi0/initAccuracyBoost
 2680       end if
 2681 !     Timesteps during recombination (tentative, the actual
 2682 !     timestep is the minimum between this value and taurst/40,
 2683 !     where taurst is the time when recombination starts - see inithermo
 2684 
 2685       dtaurec_q = 4/qmax/initAccuracyBoost 
 2686       if (.not. CP%flat) dtaurec_q = dtaurec_q/6
 2687       !AL:Changed Dec 2003, dtaurec feeds back into the non-flat integration via the step size
 2688       dtaurec = dtaurec_q
 2689       !dtau rec may be changed by inithermo
 2690 
 2691       max_etak_tensor = initAccuracyBoost*maximum_qeta /10  
 2692       max_etak_scalar = initAccuracyBoost*max(1700,maximum_qeta) /20 
 2693       if (maximum_qeta <3500 .and. AccuracyBoost < 2) max_etak_scalar = max_etak_scalar * 1.5
 2694         !tweak to get large scales right
 2695       max_etak_vector = max_etak_scalar
 2696       
 2697       if (CP%WantCls) then     
 2698          maxq = qmax
 2699          if (CP%WantTransfer) maxq = max(qmax,CP%Transfer%kmax)
 2700       else
 2701          maxq = CP%Transfer%kmax
 2702       end if
 2703 
 2704 
 2705       taumin = GetTauStart(maxq)
 2706    
 2707 !     Initialize baryon temperature and ionization fractions vs. time.
 2708 !     This subroutine also fixes the timesteps where the sources are
 2709 !     saved in order to do the integration. So TimeSteps is set here.
 2710       !These routines in ThermoData (modules.f90)
 2711       call inithermo(taumin,CP%tau0)
 2712       if (global_error_flag/= 0) return
 2713    
 2714       if (DebugMsgs .and. Feedbacklevel > 0) write (*,*) 'inithermo'
 2715 
 2716 !Do any array initialization for propagation equations
 2717       call GaugeInterface_Init
 2718  
 2719       if (Feedbacklevel > 0)  &
 2720            write(*,'("tau_recomb/Mpc       = ",f7.2,"  tau_now/Mpc = ",f8.1)') tau_maxvis,CP%tau0
 2721 
 2722 !     Calculating the times for the outputs of the transfer functions.
 2723 !
 2724       if (CP%WantTransfer) then
 2725          do itf = 1,CP%Transfer%num_redshifts
 2726             tautf(itf) = min(TimeOfz(CP%Transfer%redshifts(itf)),CP%tau0)
 2727             if (itf>1) then
 2728              if (tautf(itf) < = tautf(itf-1)) then
 2729                stop 'Transfer redshifts not set or out of order'
 2730              end if
 2731             end if
 2732          end do
 2733       endif
 2734  
 2735       end subroutine InitVars
 2736 
 2737       subroutine SetkValuesForSources
 2738       implicit none
 2739       real(dl) dlnk0, dkn1, dkn2, q_switch
 2740       real(dl) qmax_log
 2741       real(dl) SourceAccuracyBoost
 2742 !     set k values for which the sources for the anisotropy and
 2743 !     polarization will be calculated. For low values of k we
 2744 !     use a logarithmic spacing. closed case dealt with by SetClosedkValues
 2745 
 2746          SourceAccuracyBoost = AccuracyBoost  
 2747          if (CP%WantScalars .and. CP%Reion%Reionization .and. CP%AccuratePolarization) then
 2748             dlnk0 = 2/10/SourceAccuracyBoost 
 2749             !Need this to get accurate low l polarization
 2750          else
 2751             dlnk0 = 5/10/SourceAccuracyBoost
 2752             if (CP%closed) dlnk0 = dlnk0/2
 2753          end if
 2754 
 2755          if (CP%AccurateReionization) dlnk0 = dlnk0/2
 2756 
 2757          dkn1 = 0.6/taurst/SourceAccuracyBoost   
 2758          dkn2 = 0.9/taurst/SourceAccuracyBoost 
 2759          if (HighAccuracyDefault) dkn2 = dkn2/1.2
 2760          if (CP%WantTensors .or. CP%WantVectors) then
 2761               dkn1 = dkn1  *0.8
 2762               dlnk0 = dlnk0/2 !*0.3
 2763               dkn2 = dkn2*0.85
 2764           end if
 2765 
 2766          qmax_log = dkn1/dlnk0
 2767          q_switch = 2*6.3/taurst 
 2768            !Want linear spacing for wavenumbers which come inside horizon
 2769            !Could use sound horizon, but for tensors that is not relevant
 2770 
 2771          call Ranges_Init(Evolve_q)
 2772          call Ranges_Add_delta(Evolve_q, qmin, qmax_log, dlnk0, IsLog = .true.)
 2773          call Ranges_Add_delta(Evolve_q, qmax_log, min(qmax,q_switch), dkn1)
 2774          if (qmax > q_switch) then
 2775            call Ranges_Add_delta(Evolve_q, q_switch, qmax, dkn2)
 2776          end if
 2777 
 2778          call Ranges_GetArray(Evolve_q, .false.)
 2779 
 2780          if (CP%closed) &
 2781            call SetClosedkValuesFromArr(Evolve_q, .false.) 
 2782  
 2783       end subroutine SetkValuesForSources
 2784 
 2785 
 2786       subroutine SetClosedkValuesFromArr(R, forInt)
 2787       Type(Regions) :: R
 2788       integer i,nu,lastnu,nmax
 2789        !nu = 3,4,5... in CP%closed case, so set nearest integers from arr array
 2790       logical, intent(in) :: forInt
 2791       integer ix
 2792       real(dl) dnu
 2793       integer, allocatable :: nu_array(:)
 2794              
 2795        if (forInt .and. nint(R%points(1)*CP%r)< = 3) then
 2796         
 2797          !quantization is important       
 2798        call Ranges_Getdpoints(R,half_ends = .false.)
 2799        R%dpoints = max(1,int(R%dpoints*CP%r+0.02))
 2800        lastnu = 2
 2801        ix = 1
 2802        dnu = R%dpoints(ix)
 2803        nmax = 0
 2804        lastnu = 2   
 2805        allocate(nu_array(R%npoints*2))    
 2806        do
 2807         
 2808        do while (R%dpoints(ix) = dnu .and. ix  nu_array(nmax)) then
 2820           nmax = nmax+1
 2821           nu_array(nmax) = nint(R%points(R%npoints)*CP%r)
 2822        end if 
 2823        deallocate(R%points)
 2824        allocate(R%points(nmax))
 2825        R%points = nu_array(1:nmax)/CP%r
 2826        deallocate(nu_array)
 2827        
 2828       else
 2829                 
 2830        lastnu = 3
 2831        nmax = 1
 2832       
 2833        do i = 2,R%npoints
 2834          nu = nint(R%points(i)*CP%r)
 2835          if (nu > lastnu) then
 2836           nmax = nmax+1 
 2837           lastnu = nu         
 2838           R%points(nmax) = nu/CP%r 
 2839          end if
 2840        
 2841        end do  
 2842        R%points(1) = 3/CP%r
 2843        
 2844        end if
 2845        
 2846        R%Lowest = R%points(1) 
 2847        R%Highest = R%points(nmax)
 2848        R%npoints = nmax
 2849 
 2850       end subroutine SetClosedkValuesFromArr
 2851 
 2852 
 2853 
 2854       subroutine CalcScalarSources(EV,taustart)
 2855       use Transfer
 2856       implicit none
 2857       type(EvolutionVars) EV
 2858       real(dl) tau,tol1,tauend, taustart
 2859       integer j,ind,itf
 2860       real(dl) c(24),w(EV%nvar,9), y(EV%nvar), sources(SourceNum)
 2861 
 2862         if (fixq/= 0) then
 2863             !evolution output
 2864             EV%q = fixq
 2865             EV%q2 = EV%q**2
 2866         endif
 2867 
 2868          w = 0
 2869          y = 0
 2870          call initial(EV,y, taustart)
 2871          if (global_error_flag/= 0) return
 2872        
 2873          tau = taustart
 2874          ind = 1
 2875 
 2876 !!Example code for plotting out variable evolution
 2877        if (fixq/= 0) then
 2878         tol1 = tol/exp(AccuracyBoost-1)
 2879     !   call CreateTxtFile('evolve.txt',1)
 2880     
 2881          do j = 1,1000      
 2882           tauend = taustart +(j-1)*CP%tau0/1000
 2883           call GaugeInterface_EvolveScal(EV,tau,y,tauend,tol1,ind,c,w)
 2884           write (1,'(2E15.5)') tau, y(EV%g_ix), y(EV%r_ix)
 2885          end do
 2886          close(1)
 2887          stop
 2888       end if
 2889 
 2890 !     Begin timestep loop.
 2891 
 2892            itf = 1
 2893            tol1 = tol/exp(AccuracyBoost-1) 
 2894            if (CP%WantTransfer .and. CP%Transfer%high_precision) tol1 = tol1/100
 2895 
 2896            do j = 2,TimeSteps%npoints               
 2897              tauend = TimeSteps%points(j)  
 2898 
 2899              if (.not. DebugEvolution .and. (EV%q*tauend > max_etak_scalar .and. tauend > taurend) &
 2900                   .and. .not. CP%Dolensing .and. &
 2901                   (.not.CP%WantTransfer.or.tau > tautf(CP%Transfer%num_redshifts))) then
 2902       
 2903               Src(EV%q_ix,1:SourceNum,j) = 0
 2904  
 2905              else
 2906              
 2907              !Integrate over time, calulate end point derivs and calc output
 2908              call GaugeInterface_EvolveScal(EV,tau,y,tauend,tol1,ind,c,w)
 2909              if (global_error_flag/= 0) return
 2910  
 2911              call output(EV,y,j,tau,sources)
 2912              Src(EV%q_ix,1:SourceNum,j) = sources
 2913             
 2914 !     Calculation of transfer functions.
 2915 101          if (CP%WantTransfer.and.itf < = CP%Transfer%num_redshifts) then
 2916                 if (j < TimeSteps%npoints) then
 2917                   if (tauend < tautf(itf) .and.TimeSteps%points(j+1)  > tautf(itf)) then
 2918                           
 2919                      call GaugeInterface_EvolveScal(EV,tau,y,tautf(itf),tol1,ind,c,w)
 2920                      if (global_error_flag/= 0) return
 2921 
 2922                   endif
 2923                 end if  
 2924 !     output transfer functions for this k-value.
 2925                       
 2926                   if (abs(tau-tautf(itf)) < 1.e-5) then
 2927                            call outtransf(EV,y, MT%TransferData(:,EV%q_ix,itf))
 2928                          
 2929                            itf = itf+1
 2930                            if (j < TimeSteps%npoints) then
 2931                             if (itf < = CP%Transfer%num_redshifts.and. &
 2932                                 TimeSteps%points(j+1) > tautf(itf)) goto 101
 2933                            end if    
 2934                   endif
 2935 
 2936                   end if
 2937              end if
 2938 
 2939             end do !time step loop
 2940 
 2941       end subroutine
 2942 
 2943 
 2944       subroutine CalcTensorSources(EV,taustart)
 2945 
 2946       implicit none
 2947       type(EvolutionVars) EV
 2948       real(dl) tau,tol1,tauend, taustart
 2949       integer j,ind
 2950       real(dl) c(24),wt(EV%nvart,9), yt(EV%nvart)
 2951 
 2952 
 2953            call initialt(EV,yt, taustart)
 2954      
 2955            tau = taustart
 2956            ind = 1 
 2957            tol1 = tol/exp(AccuracyBoost-1)
 2958 
 2959 !     Begin timestep loop.    
 2960            do j = 2,TimeSteps%npoints
 2961                   tauend = TimeSteps%points(j)        
 2962                   if (EV%q*tauend > max_etak_tensor) then
 2963                      Src(EV%q_ix,1:SourceNum,j) = 0
 2964                    else
 2965       
 2966                       call GaugeInterface_EvolveTens(EV,tau,yt,tauend,tol1,ind,c,wt)
 2967              
 2968                       call outputt(EV,yt,EV%nvart,j,tau,Src(EV%q_ix,CT_Temp,j),&
 2969                                   Src(EV%q_ix,CT_E,j),Src(EV%q_ix,CT_B,j))
 2970            
 2971                    end if
 2972               end do
 2973     
 2974       end subroutine CalcTensorSources
 2975 
 2976 
 2977       subroutine CalcVectorSources(EV,taustart)
 2978 
 2979       implicit none
 2980       type(EvolutionVars) EV
 2981       real(dl) tau,tol1,tauend, taustart
 2982       integer j,ind
 2983       real(dl) c(24),wt(EV%nvarv,9), yv(EV%nvarv)!,yvprime(EV%nvarv)
 2984         
 2985            
 2986 !EV%q = 0.2
 2987 !EV%q2 = EV%q**2
 2988 
 2989            call initialv(EV,yv, taustart)
 2990      
 2991            tau = taustart
 2992            ind = 1 
 2993            tol1 = tol*0.01/exp(AccuracyBoost-1)
 2994 
 2995 !!Example code for plotting out variable evolution
 2996 !if (.false.) then
 2997 !        do j = 1,6000      
 2998 !          tauend = taustart * exp(j/6000*log(CP%tau0/taustart))
 2999 !         call dverk(EV,EV%nvarv,fderivsv,tau,yv,tauend,tol1,ind,c,EV%nvarv,wt) !tauend
 3000 !          call fderivsv(EV,EV%nvarv,tau,yv,yvprime)
 3001 !
 3002 !          write (*,'(7E15.5)') yv(1), yv(2), yv(3),yv(4), &
 3003 !                   yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+1), &
 3004 !                yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+2),yv(5)                            
 3005 !         end do
 3006 !       stop
 3007 !nd if
 3008 
 3009 !     Begin timestep loop.            
 3010                do j = 2,TimeSteps%npoints
 3011                   tauend = TimeSteps%points(j)
 3012 
 3013                   if ( EV%q*tauend > max_etak_vector) then
 3014                      Src(EV%q_ix,1:SourceNum,j) = 0
 3015                    else
 3016       
 3017                       call dverk(EV,EV%nvarv,derivsv,tau,yv,tauend,tol1,ind,c,EV%nvarv,wt) !tauend
 3018                  
 3019                       call outputv(EV,yv,EV%nvarv,j,tau,Src(EV%q_ix,CT_Temp,j),&
 3020                                   Src(EV%q_ix,CT_E,j),Src(EV%q_ix,CT_B,j))
 3021            
 3022                    end if
 3023               end do
 3024 
 3025       end subroutine CalcVectorSources
 3026 
 3027 
 3028      subroutine TransferOut
 3029     !Output transfer functions for k larger than used for C_l computation
 3030       implicit none
 3031       integer q_ix
 3032       real(dl) tau
 3033       type(EvolutionVars) EV
 3034     
 3035 
 3036        if (DebugMsgs .and. Feedbacklevel > 0) & 
 3037          write(*,*) MT%num_q_trans-Evolve_q%npoints, 'transfer k values'
 3038 
 3039       !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(DYNAMIC) &
 3040       !$OMP & PRIVATE(EV, tau, q_ix) 
 3041 
 3042 !     loop over wavenumbers.
 3043          do q_ix = Evolve_q%npoints+1,MT%num_q_trans
 3044       
 3045             EV%TransferOnly = .true. !in case we want to do something to speed it up
 3046           
 3047             EV%q = MT%q_trans(q_ix)
 3048 
 3049             EV%q2 = EV%q**2
 3050             EV%q_ix = q_ix
 3051           
 3052             tau = GetTauStart(EV%q)
 3053 
 3054             call GetNumEqns(EV)
 3055 
 3056             call GetTransfer(EV, tau)
 3057 
 3058          end do
 3059      !$OMP END PARAllEl DO 
 3060 
 3061      end subroutine TransferOut
 3062       
 3063      subroutine GetTransfer(EV,tau)
 3064        type(EvolutionVars) EV
 3065        real(dl) tau
 3066        integer ind, i
 3067        real(dl) c(24),w(EV%nvar,9), y(EV%nvar)
 3068        real(dl) atol
 3069        
 3070        atol = tol/exp(AccuracyBoost-1)
 3071        if (CP%Transfer%high_precision) atol = atol/10000
 3072 
 3073        ind = 1
 3074        call initial(EV,y, tau) 
 3075        if (global_error_flag/= 0) return 
 3076          
 3077        do i = 1,CP%Transfer%num_redshifts
 3078           call GaugeInterface_EvolveScal(EV,tau,y,tautf(i),atol,ind,c,w)
 3079           if (global_error_flag/= 0) return
 3080           call outtransf(EV,y,MT%TransferData(:,EV%q_ix,i))
 3081        end do
 3082  
 3083      end subroutine GetTransfer
 3084 
 3085 
 3086      subroutine NonLinearLensing
 3087         !Scale lensing source terms by non-linear scaling at each redshift and wavenumber
 3088         use NonLinear
 3089         integer i,ik,first_step
 3090         real (dl) tau
 3091         real(dl) scaling(CP%Transfer%num_redshifts), ddScaling(CP%Transfer%num_redshifts)
 3092         real(dl) ho,a0,b0, ascale
 3093         integer tf_lo, tf_hi
 3094         type(MatterPowerData) :: CAMB_Pk
 3095 
 3096         call Transfer_GetMatterPowerData(MT, CAMB_PK, 1)
 3097 
 3098         call NonLinear_GetNonLinRatios(CAMB_PK)
 3099  
 3100          if (CP%InitPower%nn > 1) stop 'Non-linear lensing only does one initial power'
 3101 
 3102         first_step = 1
 3103         do while(TimeSteps%points(first_step) < tautf(1))
 3104            first_step = first_step + 1 
 3105         end do
 3106  
 3107         do ik = 1, Evolve_q%npoints
 3108           if (Evolve_q%points(ik)/(CP%H0/100) >  Min_kh_nonlinear) then
 3109 
 3110             !Interpolate non-linear scaling in conformal time
 3111             do i = 1, CP%Transfer%num_redshifts
 3112                 scaling(i) = CAMB_Pk%nonlin_ratio(ik,i)
 3113             end do
 3114             if (all(abs(scaling-1) < 5e-4)) cycle
 3115             call spline(tautf,scaling(1),CP%Transfer%num_redshifts,&
 3116                                  spl_large,spl_large,ddScaling(1))
 3117        
 3118             tf_lo = 1
 3119             tf_hi = tf_lo+1
 3120 
 3121             do i = first_step,TimeSteps%npoints-1
 3122   
 3123               tau = TimeSteps%points(i)
 3124             
 3125               do while (tau > tautf(tf_hi))
 3126                   tf_lo = tf_lo + 1
 3127                   tf_hi = tf_hi + 1
 3128               end do
 3129 
 3130               ho = tautf(tf_hi)-tautf(tf_lo) 
 3131               a0 = (tautf(tf_hi)-tau)/ho
 3132               b0 = 1-a0
 3133               
 3134               ascale = a0*scaling(tf_lo)+ b0*scaling(tf_hi)+&
 3135                   ((a0**3-a0)* ddscaling(tf_lo) &
 3136                        +(b0**3-b0)*ddscaling(tf_hi))*ho**2/6
 3137                         
 3138               Src(ik,3,i) = Src(ik,3,i) * ascale
 3139             end  do
 3140 
 3141           end if
 3142        end do
 3143        
 3144        call MatterPowerdata_Free(CAMB_pk)
 3145  
 3146       end subroutine NonLinearLensing
 3147 
 3148 
 3149       subroutine InitSourceInterpolation
 3150       integer i,j
 3151 !     get the interpolation matrix for the sources to interpolate them
 3152 !     for other k-values
 3153       !$OMP PARAllEl DO DEFAUlT(SHARED), SCHEDUlE(STATIC), PRIVATE(i,j) , SHARED(Evolve_q)
 3154         do  i = 1,TimeSteps%npoints
 3155            do j = 1, SourceNum
 3156                call spline(Evolve_q%points,Src(1,j,i),Evolve_q%npoints,spl_large,spl_large,ddSrc(1,j,i))
 3157           end do
 3158         end do
 3159        !$OMP END PARAllEl DO 
 3160        end subroutine InitSourceInterpolation
 3161 
 3162 
 3163      subroutine SetkValuesForInt
 3164       implicit none
 3165        
 3166       integer no
 3167       real(dl) dk,dk0,dlnk1, dk2, max_k_dk, k_max_log, k_max_0
 3168       integer lognum
 3169       real(dl)  qmax_int,IntSampleBoost
 3170       
 3171 
 3172        qmax_int = min(qmax,max_bessels_etak/CP%tau0)
 3173 
 3174        IntSampleBoost = AccuracyBoost 
 3175        if (do_bispectrum) then
 3176         IntSampleBoost = IntSampleBoost * 2  
 3177         if (hard_bispectrum) IntSampleBoost = IntSampleBoost * 2  
 3178        end if
 3179        
 3180 !     Fixing the ! of k for the integration. 
 3181       
 3182        call Ranges_Init(ThisCT%q)
 3183 
 3184       if (CP%closed.and.ExactClosedSum) then
 3185        
 3186         call Ranges_Add(ThisCT%q,3/CP%r, nint(qmax_int*CP%r)/CP%r, nint(qmax_int*CP%r)-3) !fix jun08
 3187         call Init_ClTransfer(ThisCT)
 3188         call Ranges_Getdpoints(ThisCT%q,half_ends = .false.) !Jun08
 3189       else
 3190 
 3191       !Split up into logarithmically spaced intervals from qmin up to k = lognum*dk0
 3192       !then no-lognum*dk0 linearly spaced at dk0 up to no*dk0
 3193       !then at dk up to max_k_dk, then dk2 up to qmax_int
 3194          lognum = nint(10*IntSampleBoost)
 3195          dlnk1 = 1/lognum  
 3196          no = nint(600*IntSampleBoost)
 3197          dk0 = 1.8/CP%r/CP%chi0/IntSampleBoost   
 3198          dk = 3/CP%r/CP%chi0/IntSampleBoost 
 3199          
 3200          if (HighAccuracyDefault) dk = dk/1.6 
 3201 
 3202          k_max_log = lognum*dk0
 3203          k_max_0  = no*dk0
 3204          
 3205          if (do_bispectrum) k_max_0 = max(10,k_max_0) 
 3206 
 3207          dk2 = 0.04/IntSampleBoost  !very small scales  
 3208 
 3209          call Ranges_Add_delta(ThisCT%q, qmin, k_max_log, dlnk1, IsLog = .true.)
 3210          call Ranges_Add_delta(ThisCT%q, k_max_log, min(qmax_int,k_max_0), dk0)     
 3211        
 3212          if (qmax_int > k_max_0) then
 3213 
 3214          max_k_dk = max(3000, 2*maximum_l)/CP%tau0
 3215        
 3216           call Ranges_Add_delta(ThisCT%q, k_max_0, min(qmax_int, max_k_dk), dk)
 3217           if (qmax_int > max_k_dk) then
 3218            !This allows inclusion of high k modes for computing BB lensed spectrum accurately
 3219            !without taking ages to compute.
 3220             call Ranges_Add_delta(ThisCT%q, max_k_dk, qmax_int, dk2)
 3221           end if    
 3222 
 3223          end if           
 3224 
 3225          call Init_ClTransfer(ThisCT)
 3226 
 3227        if (CP%closed) then
 3228         call SetClosedkValuesFromArr(ThisCT%q,.true.)
 3229         call Ranges_Getdpoints(ThisCT%q,half_ends = .false.)
 3230         ThisCT%q%dpoints(1) = 1/CP%r
 3231         !!!  
 3232         deallocate(ThisCT%Delta_p_l_k) !Re-do this from Init_ClTransfer because number of points changed
 3233         allocate(ThisCT%Delta_p_l_k(ThisCT%NumSources,min(max_bessels_l_index,ThisCT%ls%l0), ThisCT%q%npoints))
 3234         ThisCT%Delta_p_l_k = 0     
 3235        end if
 3236 
 3237        end if !ExactClosedSum
 3238 
 3239          
 3240       end subroutine setkValuesForInt
 3241 
 3242       subroutine InterpolateSources(IV)
 3243       implicit none
 3244       integer i,khi,klo, step
 3245       real(dl) xf,b0,ho,a0,ho2o6,a03,b03
 3246       type(IntegrationVars) IV
 3247 
 3248 
 3249 !     finding position of k in table Evolve_q to do the interpolation.
 3250 
 3251 !Can't use the following in closed case because regions are not set up (only points)  
 3252 !           klo = min(Evolve_q%npoints-1,Ranges_IndexOf(Evolve_q, IV%q))
 3253            !This is a bit inefficient, but thread safe
 3254             klo = 1
 3255             do while ((IV%q > Evolve_q%points(klo+1)).and.(klo < (Evolve_q%npoints-1))) 
 3256                klo = klo+1
 3257             end do
 3258 
 3259             khi = klo+1
 3260 
 3261 
 3262             ho = Evolve_q%points(khi)-Evolve_q%points(klo)
 3263             a0 = (Evolve_q%points(khi)-IV%q)/ho
 3264             b0 = (IV%q-Evolve_q%points(klo))/ho           
 3265             ho2o6 = ho**2/6
 3266             a03 = (a0**3-a0)
 3267             b03 = (b0**3-b0)
 3268             IV%SourceSteps = 0
 3269 
 3270 !     Interpolating the source as a function of time for the present
 3271 !     wavelength.
 3272              step = 2
 3273                do i = 2, TimeSteps%npoints
 3274                   xf = IV%q*(CP%tau0-TimeSteps%points(i))
 3275                   if (CP%WantTensors) then
 3276                    if (IV%q*TimeSteps%points(i) < max_etak_tensor.and. xf > 1.e-8) then
 3277                     step = i
 3278                      IV%Source_q(i,1:SourceNum) = a0*Src(klo,1:SourceNum,i)+&
 3279                           b0*Src(khi,1:SourceNum,i)+(a03 *ddSrc(klo,1:SourceNum,i)+ &
 3280                           b03*ddSrc(khi,1:SourceNum,i)) *ho2o6
 3281                     else
 3282                      IV%Source_q(i,1:SourceNum) = 0
 3283                    end if
 3284                   end if
 3285                   if (CP%WantVectors) then
 3286                    if (IV%q*TimeSteps%points(i) < max_etak_vector.and. xf > 1.e-8) then
 3287                      step = i
 3288                      IV%Source_q(i,1:SourceNum) = a0*Src(klo,1:SourceNum,i)+&
 3289                           b0*Src(khi,1:SourceNum,i)+(a03 *ddSrc(klo,1:SourceNum,i)+ &
 3290                           b03*ddSrc(khi,1:SourceNum,i)) *ho2o6
 3291                     else
 3292                      IV%Source_q(i,1:SourceNum) = 0
 3293                    end if
 3294                   end if
 3295 
 3296                   if (CP%WantScalars) then
 3297                      if ((DebugEvolution .or. CP%Dolensing .or. IV%q*TimeSteps%points(i) < max_etak_scalar) &
 3298                           .and. xf > 1.e-8) then
 3299                         step = i
 3300                         IV%Source_q(i,1:SourceNum) = a0*Src(klo,1:SourceNum,i)+ &
 3301                          b0*Src(khi,1:SourceNum,i) + (a03*ddSrc(klo,1:SourceNum,i) &
 3302                          +b03*ddSrc(khi,1:SourceNum,i))*ho2o6
 3303   
 3304                      else
 3305                        IV%Source_q(i,1:SourceNum) = 0 
 3306                      end if
 3307                   end if
 3308                end do
 3309                IV%SourceSteps = step
 3310   
 3311 
 3312           if (.not.CP%flat) then
 3313              do i = 1, SourceNum
 3314                 call spline(TimeSteps%points,IV%Source_q(1,i),TimeSteps%npoints,&
 3315                      spl_large,spl_large,IV%ddSource_q(1,i))
 3316              end do
 3317           end if
 3318            
 3319            IV%SourceSteps = IV%SourceSteps*1
 3320            !This is a fix for a compiler bug on Seaborg 
 3321 
 3322       end subroutine
 3323 
 3324       
 3325       subroutine IntegrationVars_Init(IV)
 3326       type(IntegrationVars), intent(INOUT) :: IV
 3327         
 3328         IV%Source_q(1,1:SourceNum) = 0
 3329         IV%Source_q(TimeSteps%npoints,1:SourceNum) = 0
 3330         IV%Source_q(TimeSteps%npoints-1,1:SourceNum) = 0
 3331  
 3332       end  subroutine IntegrationVars_Init
 3333 
 3334 
 3335 !cccccccccccccccccccccccccccccccccccc
 3336 
 3337 
 3338       subroutine DoSourceIntegration(IV) !for particular wave number q
 3339       integer j,ll,llmax
 3340       real(dl) nu
 3341       type(IntegrationVars) IV
 3342        
 3343          
 3344          nu = IV%q*CP%r
 3345         
 3346          if (CP%closed) then
 3347           
 3348           if (nu<20 .or. CP%tau0/CP%r+6*pi/nu > pi/2) then
 3349            llmax = nint(nu)-1
 3350           else
 3351            llmax = nint(nu*rofChi(CP%tau0/CP%r + 6*pi/nu))
 3352            llmax = min(llmax,nint(nu)-1)  !nu > = l+1
 3353           end if       
 3354 
 3355          else
 3356           llmax = nint(nu*CP%chi0)
 3357           
 3358           if (llmax<15) then
 3359            llmax = 17 !AL Sept2010 changed from 15 to get l = 16 smooth
 3360           else
 3361            llmax = nint(nu*rofChi(CP%tau0/CP%r + 6*pi/nu))
 3362           end if
 3363           
 3364       
 3365          end if 
 3366 
 3367          if (CP%flat) then
 3368             call DoFlatIntegration(IV,llmax)
 3369          else
 3370            do j = 1,lSamp%l0
 3371             ll = lSamp%l(j)
 3372             if (ll>llmax) exit  
 3373          
 3374             call IntegrateSourcesBessels(IV,j,ll,nu)      
 3375            end do !j loop
 3376          end if
 3377 
 3378        
 3379 
 3380       end subroutine DoSourceIntegration     
 3381 
 3382       function UseLimber(l,k)
 3383        !Calculate lensing potential power using Limber rather than j_l integration
 3384        !even when sources calculated as part of temperature calculation
 3385        !(Limber better on small scales unless step sizes made much smaller)
 3386        !This affects speed, esp. of non-flat case
 3387         logical :: UseLimber
 3388         integer l
 3389         real(dl) :: k
 3390  
 3391         if (CP%AccurateBB .or. CP%flat) then
 3392          UseLimber = l > 700*AccuracyBoost .and. k > 0.05    
 3393         else
 3394          !This is accurate at percent level only (good enough here)
 3395          UseLimber = l > 300*AccuracyBoost .or. k>0.05
 3396         end if
 3397 
 3398       end function UseLimber
 3399 
 3400 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 3401 !flat source integration
 3402         subroutine DoFlatIntegration(IV, llmax)
 3403         implicit none
 3404         type(IntegrationVars) IV
 3405         integer llmax
 3406         integer j
 3407         logical DoInt
 3408         real(dl) xlim,xlmax1 
 3409         real(dl) tmin, tmax
 3410         real(dl) a2, J_l, aa(IV%SourceSteps), fac(IV%SourceSteps)
 3411         real(dl) xf, sums(SourceNum)
 3412         real(dl) qmax_int
 3413         integer bes_ix,n, bes_index(IV%SourceSteps)
 3414      
 3415 !     Find the position in the xx table for the x correponding to each
 3416 !     timestep
 3417 
 3418          do j = 1,IV%SourceSteps !Precompute arrays for this k
 3419             xf = abs(IV%q*(CP%tau0-TimeSteps%points(j)))
 3420             bes_index(j) = Ranges_indexOf(BessRanges,xf)
 3421           !Precomputed values for the interpolation
 3422             bes_ix = bes_index(j)
 3423             fac(j) = BessRanges%points(bes_ix+1)-BessRanges%points(bes_ix)
 3424             aa(j) = (BessRanges%points(bes_ix+1)-xf)/fac(j)
 3425             fac(j) = fac(j)**2*aa(j)/6
 3426          end do
 3427 
 3428          do j = 1,lSamp%l0 
 3429              if (lSamp%l(j) > llmax) return
 3430              xlim = xlimfrac*lSamp%l(j)
 3431              xlim = max(xlim,xlimmin)
 3432              xlim = lSamp%l(j)-xlim
 3433              if (full_bessel_integration .or. do_bispectrum) then
 3434                  tmin = TimeSteps%points(2)
 3435              else
 3436                  xlmax1 = 80*lSamp%l(j)*AccuracyBoost 
 3437                  tmin = CP%tau0-xlmax1/IV%q
 3438                  tmin = max(TimeSteps%points(2),tmin)                 
 3439              end if 
 3440              tmax = CP%tau0-xlim/IV%q
 3441              tmax = min(CP%tau0,tmax)
 3442         
 3443              if (tmax < TimeSteps%points(2)) exit
 3444              sums(1:SourceNum) = 0
 3445  
 3446             !As long as we sample the source well enough, it is sufficient to
 3447             !interpolate the Bessel functions only
 3448 
 3449              if (SourceNum = 2) then
 3450               !This is the innermost loop, so we separate the no lensing scalar case to optimize it
 3451                  do n = Ranges_IndexOf(TimeSteps,tmin),min(IV%SourceSteps,Ranges_IndexOf(TimeSteps,tmax))
 3452 
 3453                  a2 = aa(n)
 3454                  bes_ix = bes_index(n) 
 3455 
 3456                  J_l = a2*ajl(bes_ix,j)+(1-a2)*(ajl(bes_ix+1,j) - ((a2+1) &
 3457                         *ajlpr(bes_ix,j)+(2-a2)*ajlpr(bes_ix+1,j))* fac(n)) !cubic spline
 3458  
 3459                  J_l = J_l*TimeSteps%dpoints(n)
 3460                  sums(1) = sums(1) + IV%Source_q(n,1)*J_l
 3461                  sums(2) = sums(2) + IV%Source_q(n,2)*J_l
 3462 
 3463                 end do
 3464               else 
 3465                  qmax_int = max(850,lSamp%l(j))*3*AccuracyBoost/CP%tau0
 3466                  if (HighAccuracyDefault) qmax_int = qmax_int*1.2
 3467                  DoInt = .not. CP%WantScalars .or. IV%q < qmax_int 
 3468                  if (DoInt) then
 3469                   do n = Ranges_IndexOf(TimeSteps,tmin),min(IV%SourceSteps,Ranges_IndexOf(TimeSteps,tmax))
 3470                   !Full Bessel integration
 3471                      a2 = aa(n)
 3472                      bes_ix = bes_index(n) 
 3473 
 3474                      J_l = a2*ajl(bes_ix,j)+(1-a2)*(ajl(bes_ix+1,j) - ((a2+1) &
 3475                             *ajlpr(bes_ix,j)+(2-a2)*ajlpr(bes_ix+1,j))* fac(n)) !cubic spline
 3476                      J_l = J_l*TimeSteps%dpoints(n)
 3477               
 3478                     !The unwrapped form is faster
 3479      
 3480                      sums(1) = sums(1) + IV%Source_q(n,1)*J_l
 3481                      sums(2) = sums(2) + IV%Source_q(n,2)*J_l
 3482                      sums(3) = sums(3) + IV%Source_q(n,3)*J_l
 3483                      
 3484                   end do
 3485                  end if
 3486                  if (.not. DoInt .or. UseLimber(lsamp%l(j),IV%q) .and. CP%WantScalars) then
 3487                   !Limber approximation for small scale lensing (better than poor version of above integral)
 3488                   xf = CP%tau0-lSamp%l(j)/IV%q
 3489                   if (xf < TimeSteps%Highest .and. xf > TimeSteps%Lowest) then
 3490                    n = Ranges_IndexOf(TimeSteps,xf)
 3491                    xf = (xf-TimeSteps%points(n))/(TimeSteps%points(n+1)-TimeSteps%points(n))                  
 3492                    sums(3) = (IV%Source_q(n,3)*(1-xf) + xf*IV%Source_q(n+1,3))*sqrt(pi/2/lSamp%l(j))/IV%q 
 3493                   else
 3494                    sums(3) = 0
 3495                   end if
 3496                  end if
 3497 
 3498               end if
 3499   
 3500               ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) = ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) + sums(1:SourceNum)
 3501  !             IV%Delta_l_q(1:SourceNum,j) = IV%Delta_l_q(1:SourceNum,j) + sums(1:SourceNum)
 3502          
 3503           end do
 3504 
 3505       
 3506         end subroutine DoFlatIntegration
 3507    
 3508 
 3509     
 3510 !non-flat source integration
 3511 
 3512       subroutine IntegrateSourcesBessels(IV,j,l,nu)  
 3513       use SpherBessels
 3514       type(IntegrationVars) IV
 3515       logical DoInt   
 3516       integer l,j, nstart,nDissipative,ntop,nbot,nrange,nnow
 3517       real(dl) nu,ChiDissipative,ChiStart,tDissipative,y1,y2,y1dis,y2dis     
 3518       real(dl) xf,x,chi, miny1
 3519       real(dl) sums(SourceNum),out_arr(SourceNum), qmax_int   
 3520     
 3521       !Calculate chi where for smaller chi it is dissipative
 3522       x = sqrt(real(l*(l+1),dl))/nu
 3523     
 3524       ChiDissipative = invsinfunc(x) 
 3525     
 3526       ChiStart = ChiDissipative
 3527       !Move down a bit to get smaller value (better accuracy integrating up from small values)
 3528       if (nu<300) ChiStart = max(ChiDissipative-1/nu,1d-6)   !max(ChiDissipative-1/nu,1d-6)
 3529  
 3530         !Then get nearest source point with lower Chi...
 3531       tDissipative = CP%tau0 - CP%r*ChiStart
 3532       if (tDissipative miny1)) then
 3561      
 3562             y1 = y1dis
 3563             y2 = y2dis
 3564             nnow = nstart
 3565             do nrange = 1,TimeSteps%Count
 3566                if (nrange = TimeSteps%count) then
 3567                 ntop = TimeSteps%npoints -1
 3568                else
 3569                 ntop = TimeSteps%R(nrange+1)%start_index
 3570                end if
 3571                if (nnow < ntop) then
 3572                   call DoRangeInt(IV,chi,ChiDissipative,nnow,ntop,TimeSteps%R(nrange)%delta, &
 3573                               nu,l,y1,y2,out_arr)        
 3574                  sums  = sums + out_arr
 3575                  nnow = ntop
 3576                  if (chi = 0) exit !small enough to cut off
 3577                end if
 3578              end do
 3579            
 3580            end if !integrate down chi
 3581              
 3582          !Integrate chi up in oscillatory region
 3583           if (nstart > 2) then
 3584            y1 = y1dis
 3585            y2 = y2dis
 3586            chi = ChiStart
 3587             nnow = nstart
 3588             do nrange = TimeSteps%Count,1,-1 
 3589                nbot = TimeSteps%R(nrange)%start_index          
 3590                if (nnow >  nbot) then
 3591                   call DoRangeInt(IV,chi,ChiDissipative,nnow,nbot,TimeSteps%R(nrange)%delta, &
 3592                               nu,l,y1,y2,out_arr)
 3593                  sums = sums+out_arr
 3594          
 3595                  if (chi = 0) exit !small for remaining region
 3596                  nnow = nbot
 3597                end if
 3598                
 3599             end do
 3600 
 3601            end if
 3602 
 3603            end if !DoInt
 3604          if (SourceNum = 3 .and. (.not. DoInt .or. UseLimber(l,IV%q))) then
 3605             !Limber approximation for small scale lensing (better than poor version of above integral)
 3606              xf = CP%tau0-invsinfunc(l/nu)*CP%r
 3607 
 3608 !Feb09 fix screw up introduced Feb 2008 version
 3609 !       if (xf > TimeSteps%Lowest .and. xf > TimeSteps%Highest) then
 3610              if (xf < TimeSteps%Highest .and. xf > TimeSteps%Lowest) then
 3611              nbot = Ranges_IndexOf(TimeSteps,xf)
 3612              xf = (xf-TimeSteps%points(nbot))/(TimeSteps%points(nbot+1)-TimeSteps%points(nbot))                  
 3613              sums(3) = (IV%Source_q(nbot,3)*(1-xf) + xf*IV%Source_q(nbot+1,3))*&
 3614                            sqrt(pi/2/l/sqrt(1-CP%Ksign*real(l**2)/nu**2))/IV%q
 3615              else
 3616               sums(3) = 0
 3617              end if                
 3618          end if
 3619 
 3620          ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) = ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix)+sums
 3621            
 3622       end if !Do Scalars
 3623            
 3624      if ((CP%WantTensors)) then !Do Tensors
 3625          chi = ChiStart
 3626         
 3627       !Integrate chi down in dissipative region
 3628       !DoRangeInt cuts off when ujl gets small
 3629          miny1 = 1.d-6/l/AccuracyBoost
 3630          if ((nstart < TimeSteps%npoints-1).and.(y1dis>miny1)) then
 3631             y1 = y1dis
 3632             y2 = y2dis
 3633             nnow = nstart
 3634             do nrange = 1,TimeSteps%Count
 3635                if (nrange = TimeSteps%count) then
 3636                 ntop = TimeSteps%npoints -1
 3637                else
 3638                 ntop = TimeSteps%R(nrange+1)%start_index
 3639                end if
 3640                if (nnow < ntop) then
 3641                  call DoRangeIntTensor(IV,chi,ChiDissipative,nnow,ntop,TimeSteps%R(nrange)%delta, &
 3642                               nu,l,y1,y2,out_arr)
 3643 
 3644                  ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) = ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) + out_arr
 3645                
 3646                  nnow = ntop
 3647                  if (chi = 0) exit
 3648                end if
 3649             end do
 3650                    
 3651          end if 
 3652         
 3653                  
 3654 !Integrate chi up in oscillatory region
 3655           if (nstart > 2) then
 3656            y1 = y1dis
 3657            y2 = y2dis
 3658            chi = ChiStart
 3659          
 3660            nnow = nstart
 3661             do nrange = TimeSteps%Count,1,-1 
 3662                nbot = TimeSteps%R(nrange)%start_index          
 3663                if (nnow >  nbot) then
 3664                  call DoRangeIntTensor(IV,chi,ChiDissipative,nnow,nbot,TimeSteps%R(nrange)%delta, &
 3665                               nu,l,y1,y2,out_arr)
 3666                  ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) = ThisCT%Delta_p_l_k(1:SourceNum,j,IV%q_ix) + out_arr
 3667                 
 3668                  nnow = nbot
 3669                  if (chi = 0) exit !small for remaining region
 3670                end if               
 3671             end do
 3672 
 3673           end if
 3674        
 3675         end if !Do Tensors
 3676      
 3677       end subroutine IntegrateSourcesBessels
 3678 
 3679    
 3680 
 3681  subroutine DoRangeInt(IV,chi,chiDisp,nstart,nend,dtau,nu,l,y1,y2,out)
 3682  !Non-flat version
 3683 
 3684 !returns chi at end of integral (where integral stops, not neccessarily end)
 3685 ! This subroutine integrates the source*ujl for steps nstart to nend
 3686 ! It calculates ujl by integrating a second order
 3687 ! differential equation from initial values.
 3688 ! dtau is the spacing of the timesteps (they must be equally spaced)
 3689 
 3690       use precision
 3691       use ModelParams
 3692       type(IntegrationVars) IV
 3693       integer l,nIntSteps,nstart,nend,nlowest,isgn,i,is,Startn
 3694       real(dl) nu,dtau,num1,num2,Deltachi,aux1,aux2
 3695       real(dl) a,b,tmpa,tmpb,hh,h6,xh,delchi,taui
 3696       real(dl) nu2,chi,chiDisp,dydchi1,dydchi2,yt1,yt2,dyt1,dyt2,dym1,dym2
 3697   
 3698       real(dl) tmp,dtau2o6,y1,y2,ap1,sh,ujl,chiDispTop
 3699       real(dl) dchimax,dchisource,sgn,sgndelchi,minujl
 3700       real(dl), parameter:: MINUJl1 = 0.5d-4  !cut-off point for small ujl l = 1
 3701       logical Interpolate
 3702       real(dl) scalel
 3703       real(dl) IntAccuracyBoost
 3704       real(dl) sources(SourceNum), out(SourceNum)
 3705    
 3706       IntAccuracyBoost = AccuracyBoost 
 3707 
 3708 ! atau0 is the array with the time where the sources are stored.
 3709       if (nend = nstart) then  
 3710             out = 0
 3711             return
 3712          end if
 3713       
 3714       dchisource = dtau/CP%r
 3715      
 3716       num1 = 1/nu     
 3717 
 3718       scalel = l/scale
 3719       if (scalel> = 2400) then
 3720          num2 = num1*2.5
 3721       else if (scalel< 50) then
 3722          num2 = num1*0.8
 3723       else 
 3724         num2 = num1*1.5 
 3725       end if    
 3726       !Dec 2003, since decrease dtaurec, can make this smaller
 3727       if (dtau = dtaurec_q) then
 3728        num2 = num2/4
 3729       end if
 3730 
 3731       if (HighAccuracyDefault .and. scalel<1500 .and. scalel > 150) &
 3732           IntAccuracyBoost = IntAccuracyBoost*(1+(2000-scalel)*0.6/2000 ) 
 3733 
 3734       if (num2*IntAccuracyBoost < dchisource .and. (.not. CP%DoLensing .or. UseLimber(l,IV%q)) & 
 3735 !       if ((num2*IntAccuracyBoost < dchisource ) & !Oscillating fast 
 3736         .or. (nstart>IV%SourceSteps.and.nend>IV%SourceSteps)) then  
 3737          out = 0
 3738          y1 = 0 !So we know to calculate starting y1,y2 if there is next range
 3739          y2 = 0
 3740          chi = (CP%tau0-TimeSteps%points(nend))/CP%r
 3741          return
 3742         end if
 3743      
 3744       Startn = nstart
 3745       if (nstart>IV%SourceSteps .and. nend < IV%SourceSteps) then
 3746          chi = (CP%tau0-TimeSteps%points(IV%SourceSteps))/CP%r
 3747          Startn = IV%SourceSteps
 3748          call USpherBesselWithDeriv(CP%closed,chi,l,nu,y1,y2)
 3749       else if ((y2 = 0).and.(y1 = 0)) then 
 3750          call USpherBesselWithDeriv(CP%closed,chi,l,nu,y1,y2)
 3751       end if
 3752     
 3753       if (CP%closed) then
 3754         !Need to cut off when ujl gets exponentially small as it approaches Pi
 3755          chiDispTop = pi - chiDisp
 3756       else
 3757          chiDispTop = 1d20
 3758       end if
 3759 
 3760       minujl = MINUJl1/l/IntAccuracyBoost 
 3761       isgn = sign(1,Startn-nend)!direction of chi integration 
 3762         !higher n, later time, smaller chi
 3763     
 3764       sgn = isgn
 3765 
 3766       nlowest = min(Startn,nend)
 3767       aux1 = 1*CP%r/dtau  !used to calculate nearest timestep quickly
 3768       aux2 = (CP%tau0-TimeSteps%points(nlowest))/dtau + nlowest
 3769           
 3770       nu2 = nu*nu
 3771       ap1 = l*(l+1)
 3772       sh = rofChi(chi)
 3773            
 3774       if (scalel < 1100) then
 3775          dchimax = 0.3*num1 
 3776       else if (scalel < 1400) then
 3777          dchimax = 0.25*num1 *1.5
 3778       else
 3779          dchimax = 0.35*num1 *1.5
 3780       end if
 3781 
 3782       dchimax = dchimax/IntAccuracyBoost 
 3783     
 3784       ujl = y1/sh
 3785       sources = IV%Source_q(Startn,1:SourceNum)
 3786 
 3787       out = 0.5*ujl*sources
 3788 
 3789       Interpolate = dchisource > dchimax
 3790       if (Interpolate) then !split up smaller than source step size
 3791          delchi = dchimax
 3792          Deltachi = sgn*(TimeSteps%points(Startn)-TimeSteps%points(nend))/CP%r
 3793          nIntSteps = int(Deltachi/delchi+0.99)        
 3794          delchi = Deltachi/nIntSteps 
 3795          dtau2o6 = (CP%r*delchi)**2/6
 3796        else !step size is that of source
 3797          delchi = dchisource
 3798          nIntSteps = isgn*(Startn-nend)      
 3799        end if
 3800         
 3801          sgndelchi = delchi*sgn
 3802          tmp = (ap1/sh**2 - nu2) 
 3803          hh = 0.5*sgndelchi  
 3804          h6 = sgndelchi/6
 3805 
 3806       
 3807           do i = 1,nIntSteps          
 3808 ! One step in the ujl integration
 3809 ! fourth-order Runge-Kutta method to integrate equation for ujl
 3810 
 3811             dydchi1 = y2         !deriv y1
 3812             dydchi2 = tmp*y1     !deriv y2     
 3813             xh = chi+hh          !midpoint of step
 3814             yt1 = y1+hh*dydchi1  !y1 at midpoint
 3815             yt2 = y2+hh*dydchi2  !y2 at midpoint
 3816             dyt1 = yt2           !deriv y1 at mid
 3817             tmp = (ap1/rofChi(xh)**2 - nu2) 
 3818             
 3819             
 3820             dyt2 = tmp*yt1       !deriv y2 at mid
 3821        
 3822             yt1 = y1+hh*dyt1     !y1 at mid
 3823             yt2 = y2+hh*dyt2     !y2 at mid
 3824            
 3825             dym1 = yt2           !deriv y1 at mid
 3826             dym2 = tmp*yt1       !deriv y2 at mid
 3827             yt1 = y1+sgndelchi*dym1 !y1 at end
 3828             dym1 = dyt1+dym1     
 3829             yt2 = y2+sgndelchi*dym2 !y2 at end
 3830             dym2 = dyt2+dym2
 3831             
 3832             chi = chi+sgndelchi     !end point
 3833             sh = rofChi(chi)    
 3834             dyt1 = yt2           !deriv y1 at end
 3835             tmp = (ap1/sh**2 - nu2)
 3836             dyt2 = tmp*yt1       !deriv y2 at end
 3837             y1 = y1+h6*(dydchi1+dyt1+2*dym1) !add up
 3838             y2 = y2+h6*(dydchi2+dyt2+2*dym2)       
 3839 
 3840             ujl = y1/sh
 3841             if ((isgn<0).and.(y1*y2<0).or.((chi>chiDispTop).and.((chi>3.14).or.(y1*y2>0)))) then
 3842                 chi = 0 
 3843                 exit   !If this happens we are small, so stop integration
 3844             end if
 3845 
 3846      
 3847             if (Interpolate) then
 3848 ! Interpolate the source
 3849             taui = aux2-aux1*chi
 3850             is = int(taui)
 3851              b = taui-is
 3852     
 3853             if (b > 0.998) then 
 3854                !may save time, and prevents numerical error leading to access violation of IV%Source_q(0)
 3855              sources = IV%Source_q(is+1,1:SourceNum)
 3856              else
 3857 
 3858              a = 1-b          
 3859              tmpa = (a**3-a)
 3860              tmpb = (b**3-b)
 3861              sources = a*IV%Source_q(is,1:SourceNum)+b*IV%Source_q(is+1,1:SourceNum)+ &
 3862                   (tmpa*IV%ddSource_q(is,1:SourceNum)+ &
 3863                    tmpb*IV%ddSource_q(is+1,1:SourceNum))*dtau2o6
 3864              end if
 3865 
 3866             else
 3867              sources = IV%Source_q(Startn - i*isgn,1:SourceNum)
 3868       
 3869             end if
 3870 
 3871             out = out + ujl*sources
 3872                 
 3873             if (((isgn<0).or.(chi>chiDispTop)).and.(abs(ujl) < minujl)) then
 3874            
 3875              chi = 0
 3876             exit !break when getting  exponentially small in dissipative region
 3877 
 3878             end if
 3879             
 3880          end do
 3881 
 3882          out = (out - sources*ujl/2)*delchi*CP%r
 3883          
 3884          end subroutine DoRangeInt
 3885 
 3886  
 3887 
 3888 
 3889       subroutine DoRangeIntTensor(IV,chi,chiDisp,nstart,nend,dtau,nu,l,y1,y2,out)
 3890 ! It calculates ujl by integrating a second order
 3891 ! differential equation from initial values for calculating ujl.
 3892 ! nstart and nend are the starting and finishing values of the
 3893 ! integration.
 3894 ! dtau is the spacing of the timesteps (they must be equally spaced)
 3895 
 3896       use precision
 3897       use ModelParams
 3898       type(IntegrationVars), target :: IV
 3899       integer l,nIntSteps,nstart,nend,nlowest,isgn,i,is
 3900       real(dl) nu,dtau,num1,num2,Deltachi,aux1,aux2
 3901       real(dl) a,b,tmpa,tmpb,hh,h6,xh,delchi,taui,scalel
 3902       real(dl) nu2,chi,chiDisp,chiDispTop
 3903       real(dl) dydchi1,dydchi2,yt1,yt2,dyt1,dyt2,dym1,dym2
 3904   
 3905       real(dl) tmp,dtau2o6,y1,y2,ap1,sh,ujl
 3906       real(dl) dchimax,dchisource,sgn,sgndelchi,minujl
 3907       real(dl), parameter:: MINUJl1 = 1.D-6  !cut-off point for smal ujl l = 1
 3908       logical Interpolate
 3909       real(dl) out(SourceNum), source(SourceNum)
 3910       real(dl), dimension(:,:), pointer :: sourcep, ddsourcep
 3911 
 3912       sourcep = > IV%Source_q(:,1:)
 3913       ddsourcep = > IV%ddSource_q(:,1:)
 3914       
 3915      
 3916       if (nend = nstart) then  
 3917             out = 0
 3918             return
 3919          end if    
 3920       minujl = MINUJL1*AccuracyBoost/l
 3921       isgn = sign(1,nstart-nend)!direction of chi integration 
 3922         !higher n, later time, smaller chi
 3923 
 3924       if (CP%closed) then
 3925         !Need to cut off when ujl gets exponentially small as it approaches Pi
 3926          chiDispTop = pi - chiDisp
 3927       else
 3928          chiDispTop = 1d20
 3929       end if
 3930       
 3931      
 3932       num1 = 1/nu
 3933       dchisource = dtau/CP%r
 3934 
 3935       scalel = l/scale
 3936       if (scalel> = 2000) then
 3937          num2 = num1*4
 3938       else if (scalel> = 1000) then
 3939          num2 = num1*2.5 
 3940       else if (scalel< 75) then
 3941          num2 = num1*0.1
 3942       else if (scalel<180) then
 3943          num2 = num1*0.3
 3944       else if (scalel < 600) then
 3945          num2 = num1*0.8
 3946       else
 3947          num2 = num1
 3948       end if
 3949   
 3950       if ((isgn = 1).and.(num2*AccuracyBoost < dchisource)) then  !Oscillating fast
 3951          out = 0
 3952          y1 = 0 !!So we know to calculate starting y1,y2 if there is next range
 3953          y2 = 0
 3954          chi = (CP%tau0-TimeSteps%points(nend))/CP%r
 3955          return
 3956         end if
 3957       if ((y2 = 0).and.(y1 = 0)) call USpherBesselWithDeriv(CP%closed,chi,l,nu,y1,y2)
 3958    
 3959       sgn = isgn
 3960 
 3961       nlowest = min(nstart,nend)
 3962       aux1 = 1*CP%r/dtau  !used to calculate nearest timestep quickly
 3963       aux2 = (CP%tau0-TimeSteps%points(nlowest))/dtau + nlowest
 3964           
 3965      
 3966       nu2 = nu*nu
 3967       ap1 = l*(l+1)
 3968 
 3969       sh = rofChi(chi)
 3970       
 3971       if (scalel < 120) then
 3972          dchimax = 0.6*num1
 3973       else if (scalel < 1400) then
 3974          dchimax = 0.25*num1
 3975       else
 3976          dchimax = 0.35*num1 
 3977       end if
 3978 
 3979       dchimax = dchimax/AccuracyBoost
 3980      
 3981       ujl = y1/sh
 3982       out = ujl * sourcep(nstart,1:SourceNum)/2
 3983    
 3984       Interpolate = dchisource > dchimax
 3985       if (Interpolate) then !split up smaller than source step size
 3986          delchi = dchimax
 3987          Deltachi = sgn*(TimeSteps%points(nstart)-TimeSteps%points(nend))/CP%r
 3988          nIntSteps = int(Deltachi/delchi+0.99)
 3989          delchi = Deltachi/nIntSteps 
 3990          dtau2o6 = (CP%r*delchi)**2/6
 3991        else !step size is that of source
 3992          delchi = dchisource
 3993          nIntSteps = isgn*(nstart-nend)      
 3994        end if
 3995     
 3996        
 3997          sgndelchi = delchi*sgn
 3998          tmp = (ap1/sh**2 - nu2) 
 3999          hh = 0.5*sgndelchi  
 4000          h6 = sgndelchi/6
 4001     
 4002                 
 4003          do i = 1,nIntSteps
 4004             
 4005 
 4006 ! One step in the ujl integration
 4007 ! fourth-order Runge-Kutta method to integrate equation for ujl
 4008 
 4009             dydchi1 = y2         !deriv y1
 4010             dydchi2 = tmp*y1     !deriv y2     
 4011             xh = chi+hh          !midpoint of step
 4012             yt1 = y1+hh*dydchi1  !y1 at midpoint
 4013             yt2 = y2+hh*dydchi2  !y2 at midpoint
 4014             dyt1 = yt2           !deriv y1 at mid
 4015             tmp = (ap1/rofChi(xh)**2 - nu2) 
 4016           
 4017             
 4018             dyt2 = tmp*yt1       !deriv y2 at mid        
 4019             yt1 = y1+hh*dyt1     !y1 at mid
 4020             yt2 = y2+hh*dyt2     !y2 at mid
 4021            
 4022             dym1 = yt2           !deriv y1 at mid
 4023             dym2 = tmp*yt1       !deriv y2 at mid
 4024             yt1 = y1+sgndelchi*dym1 !y1 at end
 4025             dym1 = dyt1+dym1     
 4026             yt2 = y2+sgndelchi*dym2 !y2 at end
 4027             dym2 = dyt2+dym2
 4028          
 4029             chi = chi+sgndelchi     !end point
 4030             sh = rofChi(chi)    
 4031             dyt1 = yt2           !deriv y1 at end
 4032             tmp = (ap1/sh**2 - nu2)
 4033             dyt2 = tmp*yt1       !deriv y2 at end
 4034             y1 = y1+h6*(dydchi1+dyt1+2*dym1) !add up
 4035             y2 = y2+h6*(dydchi2+dyt2+2*dym2)
 4036 
 4037             ujl = y1/sh 
 4038             if ((isgn<0).and.(y1*y2<0).or.((chi>chiDispTop).and.((chi>3.14).or.(y1*y2>0)))) then
 4039                 chi = 0
 4040                 exit   !exit because ujl now small
 4041                 end if
 4042             
 4043             if (Interpolate) then
 4044 ! Interpolate the source
 4045             taui = aux2-aux1*chi
 4046             is = int(taui)
 4047             b = taui-is
 4048             if (b > 0.995) then 
 4049                !may save time, and prevents numerical error leading to access violation of zero index
 4050              is = is+1
 4051              source = sourcep(is,1:SourceNum)
 4052             
 4053              else
 4054              a = 1-b            
 4055              tmpa = (a**3-a)
 4056              tmpb = (b**3-b)
 4057              source = a*sourcep(is,1:SourceNum)+b*sourcep(is+1,1:SourceNum)+ &
 4058                    (tmpa*ddsourcep(is,1:SourceNum) +  tmpb*ddsourcep(is+1,1:SourceNum))*dtau2o6
 4059 
 4060              end if           
 4061 
 4062             else
 4063              source = sourcep(nstart - i*isgn,1:SourceNum)
 4064           
 4065             end if
 4066             out = out + source * ujl
 4067                   
 4068             if (((isgn<0).or.(chi>chiDispTop)).and.(abs(ujl) < minujl)) then
 4069             chi = 0
 4070             exit  !break when getting  exponentially small in dissipative region
 4071             end if
 4072          end do
 4073 
 4074          out = (out - source * ujl /2)*delchi*CP%r
 4075        
 4076          end subroutine DoRangeIntTensor
 4077 
 4078         subroutine GetInitPowerArrayVec(pows,ks, numks,pix)
 4079          integer, intent(in) :: numks, pix
 4080          real(dl) pows(numks), ks(numks)
 4081          integer i
 4082       
 4083          do i = 1, numks
 4084          !!change to vec...
 4085             pows(i) =  ScalarPower(ks(i) ,pix)
 4086             if (global_error_flag/= 0) exit
 4087          end do
 4088 
 4089         end subroutine GetInitPowerArrayVec
 4090 
 4091 
 4092         subroutine GetInitPowerArrayTens(pows,ks, numks,pix)
 4093          integer, intent(in) :: numks, pix
 4094          real(dl) pows(numks), ks(numks)
 4095          integer i
 4096       
 4097          do i = 1, numks
 4098             pows(i) =  TensorPower(ks(i) ,pix)
 4099             if (global_error_flag/= 0) exit
 4100          end do
 4101 
 4102         end subroutine GetInitPowerArrayTens
 4103 
 4104 
 4105         subroutine CalcScalCls(CTrans)
 4106         use Bispectrum
 4107         implicit none
 4108         Type(ClTransferData) :: CTrans
 4109         integer pix,j
 4110         real(dl) apowers, pows(CTrans%q%npoints)
 4111         integer q_ix
 4112         real(dl)  ks(CTrans%q%npoints),dlnks(CTrans%q%npoints),dlnk
 4113         real(dl) ctnorm,dbletmp
 4114 
 4115 
 4116          do pix = 1,CP%InitPower%nn
 4117 
 4118           do q_ix = 1, CTrans%q%npoints 
 4119 
 4120              if (CP%flat) then
 4121                      ks(q_ix) = CTrans%q%points(q_ix)
 4122                      dlnks(q_ix) = CTrans%q%dpoints(q_ix)/CTrans%q%points(q_ix)
 4123              else
 4124                      ks(q_ix) = sqrt(CTrans%q%points(q_ix)**2 - CP%curv)
 4125                      dlnks(q_ix) = CTrans%q%dpoints(q_ix)*CTrans%q%points(q_ix)/ks(q_ix)**2
 4126              end if
 4127 
 4128              pows(q_ix) =  ScalarPower(ks(q_ix) ,pix)
 4129              if (global_error_flag/= 0) return
 4130       
 4131           end do
 4132 
 4133 
 4134         !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) &
 4135         !$OMP & PRIVATE(j,q_ix,dlnk,apowers,ctnorm,dbletmp)
 4136 
 4137          do j = 1,CTrans%ls%l0
 4138 
 4139         !Integrate dk/k Delta_l_q**2 * Power(k)
 4140           do q_ix = 1, CTrans%q%npoints 
 4141 
 4142              if (.not.(CP%closed.and.nint(CTrans%q%points(q_ix)*CP%r)< = CTrans%ls%l(j))) then 
 4143                !cut off at nu = l + 1
 4144              dlnk = dlnks(q_ix)
 4145              apowers = pows(q_ix)
 4146 
 4147              iCl_scalar(j,C_Temp:C_E,pix) = iCl_scalar(j,C_Temp:C_E,pix) +  &
 4148                           apowers*CTrans%Delta_p_l_k(1:2,j,q_ix)**2*dlnk
 4149              iCl_scalar(j,C_Cross,pix) = iCl_scalar(j,C_Cross,pix) + &
 4150                           apowers*CTrans%Delta_p_l_k(1,j,q_ix)*CTrans%Delta_p_l_k(2,j,q_ix)*dlnk
 4151              if (CTrans%NumSources>2) then
 4152                         iCl_scalar(j,C_Phi,pix) = iCl_scalar(j,C_Phi,pix) +  &
 4153                                                        apowers*CTrans%Delta_p_l_k(3,j,q_ix)**2*dlnk
 4154                         iCl_scalar(j,C_PhiTemp,pix) = iCl_scalar(j,C_PhiTemp,pix) +  &
 4155                                           apowers*CTrans%Delta_p_l_k(3,j,q_ix)*CTrans%Delta_p_l_k(1,j,q_ix)*dlnk
 4156                         iCl_scalar(j,C_PhiE,pix) = iCl_scalar(j,C_PhiE,pix) +  &
 4157                                           apowers*CTrans%Delta_p_l_k(3,j,q_ix)*CTrans%Delta_p_l_k(2,j,q_ix)*dlnk
 4158              end if
 4159 
 4160              end if
 4161              
 4162            end do
 4163 
 4164 !Output l(l+1)C_l/OutputDenominator
 4165 
 4166            !ctnorm = (CTrans%ls%l+2)!/(CTrans%ls%l-2)! - beware of int overflow
 4167             ctnorm = (CTrans%ls%l(j)*CTrans%ls%l(j)-1)*real((CTrans%ls%l(j)+2)*CTrans%ls%l(j),dl)
 4168             dbletmp = (CTrans%ls%l(j)*(CTrans%ls%l(j)+1))/OutputDenominator*fourpi  
 4169                  
 4170             iCl_scalar(j,C_Temp,pix)  =  iCl_scalar(j,C_Temp,pix)*dbletmp
 4171             iCl_scalar(j,C_E,pix)     =  iCl_scalar(j,C_E,pix)*dbletmp*ctnorm
 4172             iCl_scalar(j,C_Cross,pix) =  iCl_scalar(j,C_Cross,pix)*dbletmp*sqrt(ctnorm)
 4173             if (CTrans%NumSources>2) then
 4174                      iCl_scalar(j,C_Phi,pix)   =  &
 4175                             iCl_scalar(j,C_Phi,pix)*fourpi*real(CTrans%ls%l(j)**2,dl)**2    
 4176                      !The lensing power spectrum computed is l^4 C_l^{\phi\phi}
 4177                      !We put pix extra factors of l here to improve interpolation in CTrans%ls%l
 4178                      iCl_scalar(j,C_PhiTemp,pix)   =  &
 4179                             iCl_scalar(j,C_PhiTemp,pix)*fourpi*real(CTrans%ls%l(j)**2,dl)*CTrans%ls%l(j)
 4180                       !Cross-correlation is CTrans%ls%l^3 C_l^{\phi T}
 4181                      iCl_scalar(j,C_PhiE,pix)   =  &
 4182                             iCl_scalar(j,C_PhiE,pix)*fourpi*real(CTrans%ls%l(j)**2,dl)*CTrans%ls%l(j)*sqrt(ctnorm)
 4183                       !Cross-correlation is CTrans%ls%l^3 C_l^{\phi E}
 4184              end if
 4185 
 4186            end do
 4187          !$OMP END PARAllEl DO
 4188 
 4189           end do
 4190 
 4191         end subroutine CalcScalCls
 4192 
 4193         subroutine CalcScalCls2(CTrans)
 4194         !Calculate C_ll' for non-isotropic models
 4195         !Run with l_sample_boost = 50 to get every l
 4196         !not used in normal CAMB
 4197         implicit none
 4198         Type(ClTransferData) :: CTrans
 4199         integer j,j2,in
 4200         real(dl) apowers, pows(CTrans%q%npoints)
 4201         integer q_ix
 4202         real(dl)  ks(CTrans%q%npoints),dlnks(CTrans%q%npoints),dlnk
 4203         real(dl) ctnorm,dbletmp
 4204         real(dl), allocatable :: iCl_Scalar2(:,:,:,:) 
 4205 
 4206          allocate(iCl_Scalar2(CTranS%ls%l0,CTrans%ls%l0,C_Temp:C_last,CP%InitPower%nn))
 4207          iCl_scalar2 = 0
 4208     
 4209          do in = 1,CP%InitPower%nn
 4210           do q_ix = 1, CTrans%q%npoints 
 4211 
 4212              if (CP%flat) then
 4213                      ks(q_ix) = CTrans%q%points(q_ix)
 4214                      dlnks(q_ix) = CTrans%q%dpoints(q_ix)/CTrans%q%points(q_ix)
 4215              else
 4216                      ks(q_ix) = sqrt(CTrans%q%points(q_ix)**2 - CP%curv)
 4217                      dlnks(q_ix) = CTrans%q%dpoints(q_ix)*CTrans%q%points(q_ix)/ks(q_ix)**2
 4218              end if
 4219 
 4220              pows(q_ix) =  ScalarPower(ks(q_ix) ,in)
 4221              if (global_error_flag/= 0) return
 4222 
 4223           end do
 4224 
 4225          do j = 1,CTrans%ls%l0
 4226           do j2 = 1,CTrans%ls%l0
 4227 
 4228         !Integrate dk/k Delta_l_q**2 * Power(k)
 4229 
 4230           do q_ix = 1, CTrans%q%npoints 
 4231 
 4232              if (.not.(CP%closed.and.nint(CTrans%q%points(q_ix)*CP%r)< = CTrans%ls%l(j))) then 
 4233                !cut off at nu = l + 1
 4234              dlnk = dlnks(q_ix)
 4235              apowers = pows(q_ix)
 4236 
 4237              iCl_scalar2(j,j2,C_Temp:C_E,in) = iCl_scalar2(j,j2,C_Temp:C_E,in) +  &
 4238                           apowers*CTrans%Delta_p_l_k(1:2,j,q_ix)*CTrans%Delta_p_l_k(1:2,j2,q_ix)*dlnk
 4239              iCl_scalar2(j,j2,C_Cross,in) = iCl_scalar2(j,j2,C_Cross,in) + &
 4240                           apowers*CTrans%Delta_p_l_k(1,j,q_ix)*CTrans%Delta_p_l_k(2,j2,q_ix)*dlnk
 4241     
 4242              end if
 4243 
 4244            end do
 4245 
 4246 !Output l(l+1)C_l/OutputDenominator
 4247 
 4248            !ctnorm = (CTrans%ls%l+2)!/(CTrans%ls%l-2)! - beware of int overflow
 4249             ctnorm = (CTrans%ls%l(j)*CTrans%ls%l(j)-1)*real((CTrans%ls%l(j)+2)*CTrans%ls%l(j),dl)
 4250             ctnorm = sqrt(ctnorm*(CTrans%ls%l(j2)*CTrans%ls%l(j2)-1)*real((CTrans%ls%l(j2)+2)*CTrans%ls%l(j2),dl))
 4251             
 4252             dbletmp = (CTrans%ls%l(j)*(CTrans%ls%l(j)+1))/OutputDenominator*fourpi  
 4253             dbletmp = sqrt(dbletmp*(CTrans%ls%l(j2)*(CTrans%ls%l(j2)+1))/OutputDenominator*fourpi  )
 4254                  
 4255             iCl_scalar2(j,j2,C_Temp,in)  =  iCl_scalar2(j,j2,C_Temp,in)*dbletmp
 4256             iCl_scalar2(j,j2,C_E,in)     =  iCl_scalar2(j,j2,C_E,in)*dbletmp*ctnorm
 4257             iCl_scalar2(j,j2,C_Cross,in) =  iCl_scalar2(j,j2,C_Cross,in)*dbletmp*sqrt(ctnorm)
 4258     
 4259            end do
 4260 
 4261           end do
 4262 
 4263         end do
 4264         
 4265         call CreateTxtFile('z:\cl2.dat',1)
 4266         do j = 1,CTrans%ls%l0
 4267         do j2 = 1,CTrans%ls%l0
 4268          write (1,*) CTrans%ls%l(j),CTrans%ls%l(j2),iCl_scalar2(j,j2,1,1)*7.4311e12
 4269         end do
 4270         end do  
 4271         close(1)
 4272         call CreateTxtFile('cl1l2.dat',1)
 4273         do j = 1,999
 4274          write (1,'(999E15.5)') iCl_scalar2(j,1:999,1,1)*7.4311e12
 4275         end do          
 4276         stop
 4277 
 4278         end subroutine CalcScalCls2
 4279 
 4280      
 4281         subroutine CalcTensCls(CTrans, GetInitPowers)
 4282         implicit none
 4283         Type(ClTransferData) :: CTrans
 4284         external GetInitPowers       
 4285         integer in,j, q_ix
 4286         real(dl) nu
 4287         real(dl) apowert,  measure
 4288         real(dl) ctnorm,dbletmp
 4289         real(dl) pows(CTrans%q%npoints)
 4290         real(dl)  ks(CTrans%q%npoints),measures(CTrans%q%npoints)
 4291 
 4292         !For tensors we want Integral dnu/nu (nu^2-3)/(nu^2-1) Delta_l_k^2 P(k) for CP%closed
 4293 
 4294         do in = 1,CP%InitPower%nn
 4295         
 4296          do q_ix = 1, CTrans%q%npoints 
 4297 
 4298              if (CP%flat) then
 4299                      ks(q_ix) = CTrans%q%points(q_ix)
 4300                      measures(q_ix) = CTrans%q%dpoints(q_ix)/CTrans%q%points(q_ix)
 4301              else
 4302                      nu = CTrans%q%points(q_ix)*CP%r
 4303                      ks(q_ix) = sqrt(CTrans%q%points(q_ix)**2 - 3*CP%curv)
 4304                      measures(q_ix) = CTrans%q%dpoints(q_ix)/CTrans%q%points(q_ix)*(nu**2-3*CP%Ksign)/(nu**2-CP%Ksign)
 4305              end if
 4306 
 4307           end do
 4308 
 4309          call GetInitPowers(pows,ks,CTrans%q%npoints,in)
 4310 
 4311         !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) &
 4312         !$OMP & PRIVATE(j,q_ix,measure,apowert,ctnorm,dbletmp)
 4313          do j = 1,CTrans%ls%l0
 4314 
 4315           do q_ix = 1, CTrans%q%npoints 
 4316 
 4317                  if (.not.(CP%closed.and. nint(CTrans%q%points(q_ix)*CP%r)< = CTrans%ls%l(j))) then
 4318                      !cut off at nu = l+1
 4319 
 4320                  apowert = pows(q_ix)
 4321                  measure = measures(q_ix)
 4322                
 4323                  iCl_tensor(j,CT_Temp:CT_B,in) = iCl_tensor(j,CT_Temp:CT_B,in) + &
 4324                       apowert*CTrans%Delta_p_l_k(CT_Temp:CT_B,j,q_ix)**2*measure
 4325                  
 4326                  iCl_tensor(j,CT_cross, in ) = iCl_tensor(j,CT_cross, in ) &
 4327                       +apowert*CTrans%Delta_p_l_k(CT_Temp,j,q_ix)*CTrans%Delta_p_l_k(CT_E,j,q_ix)*measure
 4328                  end if 
 4329            end do
 4330 
 4331             ctnorm = (CTrans%ls%l(j)*CTrans%ls%l(j)-1)*real((CTrans%ls%l(j)+2)*CTrans%ls%l(j),dl)
 4332             dbletmp = (CTrans%ls%l(j)*(CTrans%ls%l(j)+1))/OutputDenominator*pi/4
 4333             iCl_tensor(j, CT_Temp, in)   = iCl_tensor(j, CT_Temp, in)*dbletmp*ctnorm
 4334             if (CTrans%ls%l(j) = 1) dbletmp =0
 4335             iCl_tensor(j, CT_E:CT_B, in) = iCl_tensor(j, CT_E:CT_B, in)*dbletmp
 4336             iCl_tensor(j, CT_Cross, in)  = iCl_tensor(j, CT_Cross, in)*dbletmp*sqrt(ctnorm)
 4337 
 4338          end do
 4339 
 4340          end do
 4341     
 4342         end subroutine CalcTensCls
 4343 
 4344 
 4345         subroutine CalcVecCls(CTrans, GetInitPowers)
 4346         implicit none
 4347         Type(ClTransferData) :: CTrans
 4348         external GetInitPowers       
 4349         integer in,j, q_ix
 4350         real(dl) power,  measure
 4351         real(dl) ctnorm,lfac,dbletmp
 4352         real(dl) pows(CTrans%q%npoints)
 4353         real(dl)  ks(CTrans%q%npoints),measures(CTrans%q%npoints)
 4354 
 4355         do in = 1,CP%InitPower%nn
 4356         
 4357          do q_ix = 1, CTrans%q%npoints 
 4358 
 4359                ks(q_ix) = CTrans%q%points(q_ix)
 4360                measures(q_ix) = CTrans%q%dpoints(q_ix)/CTrans%q%points(q_ix)
 4361 
 4362           end do
 4363 
 4364          call GetInitPowers(pows,ks,CTrans%q%npoints,in)
 4365 
 4366         !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDUlE(STATIC,4) &
 4367         !$OMP & PRIVATE(j,q_ix,measure,power,ctnorm,dbletmp)
 4368          do j = 1,CTrans%ls%l0
 4369 
 4370           do q_ix = 1, CTrans%q%npoints 
 4371 
 4372              if (.not.(CP%closed.and. nint(CTrans%q%points(q_ix)*CP%r)< = CTrans%ls%l(j))) then
 4373                      !cut off at nu = l+1
 4374 
 4375                  power = pows(q_ix)
 4376                  measure = measures(q_ix)
 4377                
 4378                  iCl_vector(j,CT_Temp:CT_B,in) = iCl_vector(j,CT_Temp:CT_B,in) + &
 4379                       power*CTrans%Delta_p_l_k(CT_Temp:CT_B,j,q_ix)**2*measure
 4380                  
 4381                  iCl_vector(j,CT_cross, in ) = iCl_vector(j,CT_cross, in ) &
 4382                       +power*CTrans%Delta_p_l_k(CT_Temp,j,q_ix)*CTrans%Delta_p_l_k(CT_E,j,q_ix)*measure
 4383              end if 
 4384           end do
 4385 
 4386             ctnorm = CTrans%ls%l(j)*(CTrans%ls%l(j)+1)
 4387             dbletmp = (CTrans%ls%l(j)*(CTrans%ls%l(j)+1))/OutputDenominator*pi/8
 4388             iCl_vector(j, CT_Temp, in)   = iCl_vector(j, CT_Temp, in)*dbletmp*ctnorm
 4389             lfac = (CTrans%ls%l(j) + 2)*(CTrans%ls%l(j) - 1)
 4390             iCl_vector(j, CT_E:CT_B, in) = iCl_vector(j, CT_E:CT_B, in)*dbletmp*lfac
 4391             iCl_vector(j, CT_Cross, in)  = iCl_vector(j, CT_Cross, in)*dbletmp*sqrt(lfac*ctnorm)
 4392 
 4393          end do
 4394 
 4395          end do
 4396     
 4397         end subroutine CalcVecCls
 4398 
 4399 
 4400     subroutine InterpolateCls(CTransS,CTransT,CTransV)
 4401       implicit none
 4402        Type(ClTransferData) :: CTransS, CTransT, CTransV
 4403       integer in,i
 4404   
 4405 !Note using log interpolation is worse]
 4406 
 4407       !$OMP PARALLEL DO DEFAULT(SHARED), PRIVATE(i,in), SHARED(CTransS,CTransT),IF(CP%InitPower%nn > 1)
 4408       do in = 1,CP%InitPower%nn
 4409          if (CP%WantScalars) then
 4410            do i = C_Temp, C_last
 4411               call InterpolateClArrTemplated(CTransS%ls,iCl_scalar(1,i,in),Cl_scalar(lmin, in, i), &
 4412                  CTransS%ls%l0,i)
 4413            end do
 4414          end if
 4415       
 4416          if (CP%WantVectors) then
 4417            do i = C_Temp, CT_cross
 4418             call InterpolateClArr(CTransV%ls,iCl_vector(1,i,in),Cl_vector(lmin, in, i),CTransV%ls%l0)
 4419            end do
 4420          end if
 4421          
 4422          if (CP%WantTensors) then
 4423            do i = CT_Temp, CT_Cross
 4424              call InterpolateClArr(CTransT%ls,iCl_tensor(1,i,in),Cl_tensor(lmin, in, i), &
 4425                CTransT%ls%l0)
 4426            end do
 4427          end if
 4428       end do
 4429       !$OMP END PARALLEL DO
 4430     end subroutine InterpolateCls
 4431 
 4432 
 4433 end module CAMBmain
 4434 
 4435     
 4436 ** constants.f90     
 4437 
 4438 
 4439 
 4440    module Precision
 4441       implicit none
 4442 
 4443       integer, parameter :: dl = KIND(1)
 4444       integer, parameter :: sp = KIND(1.0)
 4445    end module Precision
 4446 
 4447   
 4448    module constants
 4449        use precision
 4450        implicit none
 4451       
 4452        real(dl), parameter :: const_pi = 3.1415926535897932384626433832795
 4453        real(dl), parameter :: const_twopi = 2*const_pi, const_fourpi = 4*const_pi
 4454        real(dl), parameter :: const_sqrt6 = 2.4494897427831780981972840747059
 4455 
 4456        real(dl), parameter :: c = 2.99792458e8
 4457        real(dl), parameter :: h_P = 6.62606896e-34
 4458         
 4459        real(dl), parameter :: G = 6.67428e-11
 4460        real(dl), parameter :: sigma_thomson = 6.6524616e-29
 4461        real(dl), parameter :: sigma_boltz = 5.6704e-8  
 4462        real(dl), parameter :: k_B = 1.3806504e-23 
 4463 
 4464 
 4465        real(dl), parameter :: m_p = 1.672621637e-27  ! 1.672623e-27
 4466        real(dl), parameter :: m_H = 1.673575e-27 !av. H atom
 4467        real(dl), parameter :: m_e = 9.10938215e-31
 4468        real(dl), parameter :: mass_ratio_He_H = 3.9715
 4469  
 4470 
 4471        real(dl), parameter :: Gyr = 3.1556926e16
 4472        real(dl), parameter :: Mpc = 3.085678e22 !seem to be different definitions of this?
 4473        real(dl), parameter :: MPC_in_sec = Mpc/c ! Mpc/c = 1.029272d14 in SI units      
 4474 
 4475        real(dl), parameter :: barssc0 = k_B / m_p / c**2
 4476        real(dl), parameter :: kappa = 8*const_pi*G
 4477        real(dl), parameter :: a_rad = 8*const_pi**5*k_B**4/15/c**3/h_p**3  
 4478                 !7.565914e-16 !radiation constant for u = aT^4
 4479 
 4480 
 4481        real(dl), parameter :: Compton_CT = MPC_in_sec*(8/3)*(sigma_thomson/(m_e*c))*a_rad
 4482         !Compton_CT is CT in Mpc units, (8./3.)*(sigma_T/(m_e*C))*a_R in Mpc
 4483         !Used to get evolution of matter temperature 
 4484         
 4485        !For 21cm
 4486        real(dl), parameter :: f_21cm = 1420.40575e6, l_21cm = c/f_21cm, T_21cm = h_P*f_21cm/k_B
 4487        real(dl), parameter :: A10 = 2.869e-15, B10 = l_21cm**3/2/h_P/c*A10
 4488 
 4489        real(dl), parameter :: line21_const = 3*l_21cm**2*C*h_P/32/const_pi/k_B*A10 * Mpc_in_sec * 1000
 4490         !1000 to get in MiliKelvin
 4491        real(dl), parameter :: COBE_CMBTemp = 2.726 !(Fixsen 2009)
 4492 
 4493    end module constants
 4494 
 4495 
 4496     module Errors
 4497      implicit none
 4498      
 4499      integer :: global_error_flag = 0
 4500      character(LEN = 1024) :: global_error_message = ''
 4501      integer, parameter :: error_reionization = 1
 4502      integer, parameter :: error_recombination = 2
 4503      integer, parameter :: error_inital_power = 3
 4504      integer, parameter :: error_evolution = 4
 4505      integer, parameter :: error_unsupported_params = 5
 4506      
 4507     contains
 4508       
 4509       subroutine GlobalError(message, id)
 4510        character(LEN = *), intent(IN), optional :: message
 4511        integer, intent(in), optional :: id
 4512        
 4513        if (present(message)) then       
 4514         global_error_message = message
 4515        else
 4516         global_error_message = ''
 4517        end if
 4518        if (present(id)) then
 4519          if (id = 0) stop 'Error id must be non-zero'
 4520          global_error_flag = id
 4521        else
 4522          global_error_flag = -1
 4523        end if        
 4524       
 4525       end subroutine GlobalError
 4526   
 4527     end module Errors  
 4528     
 4529 
 4530 ** equations.f90
 4531     
 4532 ! Equations module for dark energy with constant equation of state parameter w
 4533 ! allowing for perturbations based on a quintessence model
 4534 ! by Antony Lewis (http://cosmologist.info/)
 4535 
 4536 ! Dec 2003, fixed (fatal) bug in tensor neutrino setup
 4537 ! Changes to tight coupling approximation
 4538 ! June 2004, fixed problem with large scale polarized tensors; support for vector modes
 4539 ! Generate vector modes on their own. The power spectrum is taken from the scalar parameters.
 4540 ! August 2004, fixed reionization term in lensing potential
 4541 ! Nov 2004, change massive neutrino l_max to be consistent with massless if light
 4542 ! Apr 2005, added DoLateRadTruncation option
 4543 ! June 2006, added support for arbitary neutrino mass splittings
 4544 ! Nov 2006, tweak to high_precision transfer function accuracy at lowish k
 4545 ! June 2011, improved radiation approximations from arXiv: 1104.2933; Some 2nd order tight coupling terms
 4546 !            merged fderivs and derivs so flat and non-flat use same equations; more precomputed arrays
 4547 !            optimized neutrino sampling, and reorganised neutrino integration functions
 4548 
 4549        module LambdaGeneral
 4550          use precision
 4551          implicit none
 4552           
 4553          real(dl)  :: w_lam = -1 !p/rho for the dark energy (assumed constant) 
 4554          real(dl) :: cs2_lam = 1 
 4555           !comoving sound speed. Always exactly 1 for quintessence 
 4556           !(otherwise assumed constant, though this is almost certainly unrealistic)
 4557 
 4558          logical :: w_perturb = .true.
 4559 
 4560        end module LambdaGeneral
 4561 
 4562 
 4563     
 4564 !Return OmegaK - modify this if you add extra fluid components
 4565         function GetOmegak()
 4566         use precision
 4567         use ModelParams
 4568         real(dl)  GetOmegak
 4569          GetOmegak = 1 - (CP%omegab+CP%omegac+CP%omegav+CP%omegan) 
 4570           
 4571         end function GetOmegak
 4572   
 4573   
 4574        subroutine init_background
 4575          !This is only called once per model, and is a good point to do any extra initialization.
 4576          !It is called before first call to dtauda, but after
 4577          !massive neutrinos are initialized and after GetOmegak
 4578        end  subroutine init_background
 4579 
 4580 
 4581 !Background evolution
 4582         function dtauda(a)
 4583          !get d tau / d a
 4584         use precision
 4585         use ModelParams
 4586         use MassiveNu
 4587         use LambdaGeneral
 4588         implicit none
 4589         real(dl) dtauda
 4590         real(dl), intent(IN) :: a
 4591         real(dl) rhonu,grhoa2, a2
 4592         integer nu_i
 4593 
 4594         a2 = a**2
 4595 
 4596 !  8*pi*G*rho*a**4.
 4597         grhoa2 = grhok*a2+(grhoc+grhob)*a+grhog+grhornomass
 4598          if (w_lam = -1) then
 4599            grhoa2 = grhoa2+grhov*a2**2
 4600          else
 4601            grhoa2 = grhoa2+grhov*a**(1-3*w_lam)
 4602          end if
 4603         if (CP%Num_Nu_massive /= 0) then
 4604 !Get massive neutrino density relative to massless
 4605            do nu_i = 1, CP%nu_mass_eigenstates
 4606             call Nu_rho(a*nu_masses(nu_i),rhonu)
 4607             grhoa2 = grhoa2+rhonu*grhormass(nu_i)
 4608            end do
 4609         end if
 4610 
 4611         dtauda = sqrt(3/grhoa2)
 4612      
 4613         end function dtauda
 4614 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 4615 
 4616 !Gauge-dependent perturbation equations
 4617 
 4618         module GaugeInterface
 4619         use precision
 4620         use ModelParams
 4621         use MassiveNu
 4622         use LambdaGeneral
 4623         use Errors
 4624         implicit none
 4625         public
 4626 
 4627         !Description of this file. Change if you make modifications.
 4628         character(LEN = *), parameter :: Eqns_name = 'gauge_inv'
 4629 
 4630         integer, parameter :: basic_num_eqns = 5
 4631           
 4632         logical :: DoTensorNeutrinos = .false.
 4633         
 4634         logical :: DoLateRadTruncation = .true.
 4635             !if true, use smooth approx to radition perturbations after decoupling on 
 4636             !small scales, saving evolution of irrelevant osciallatory multipole equations
 4637 
 4638         logical, parameter :: second_order_tightcoupling = .true.
 4639 
 4640         real(dl) :: Magnetic = 0
 4641             !Vector mode anisotropic stress in units of rho_gamma
 4642         real(dl) :: vec_sig0 = 1
 4643             !Vector mode shear      
 4644         integer, parameter :: max_l_evolve = 1024 !Maximum l we are ever likely to propagate
 4645 
 4646         !Supported scalar initial condition flags
 4647          integer, parameter :: initial_adiabatic = 1, initial_iso_CDM = 2, &
 4648          initial_iso_baryon = 3,  initial_iso_neutrino = 4, initial_iso_neutrino_vel = 5, initial_vector = 0
 4649          integer, parameter :: initial_nummodes =  initial_iso_neutrino_vel
 4650 
 4651         type EvolutionVars
 4652             real(dl) q, q2
 4653             real(dl) k_buf,k2_buf ! set in initial
 4654 
 4655             integer w_ix !Index of two quintessence equations
 4656             integer r_ix !Index of the massless neutrino hierarchy
 4657             integer g_ix !Index of the photon neutrino hierarchy
 4658             
 4659             integer q_ix !index into q_evolve array that gives the value q
 4660             logical TransferOnly
 4661 
 4662     !       nvar  - number of scalar (tensor) equations for this k       
 4663             integer nvar,nvart, nvarv
 4664 
 4665            !Max_l for the various hierarchies
 4666             integer lmaxg,lmaxnr,lmaxnu,lmaxgpol,MaxlNeeded
 4667             integer lmaxnrt, lmaxnut, lmaxt, lmaxpolt, MaxlNeededt
 4668             logical EvolveTensorMassiveNu(max_nu)
 4669             integer lmaxnrv, lmaxv, lmaxpolv
 4670 
 4671             integer polind  !index into scalar array of polarization hierarchy
 4672 
 4673     !array indices for massive neutrino equations
 4674             integer nu_ix(max_nu), nu_pert_ix
 4675             integer nq(max_nu), lmaxnu_pert
 4676             logical has_nu_relativistic
 4677 
 4678     !Initial values for massive neutrino v*3 variables calculated when switching 
 4679     !to non-relativistic approx
 4680             real(dl) G11(max_nu),G30(max_nu)
 4681     !True when using non-relativistic approximation
 4682             logical MassiveNuApprox(max_nu)
 4683             real(dl) MassiveNuApproxTime(max_nu)
 4684 
 4685     !True when truncating at l = 2,3 when k*tau>>1 (see arXiv:1104.2933)       
 4686             logical high_ktau_neutrino_approx
 4687 
 4688     !Massive neutrino scheme being used at the moment        
 4689             integer NuMethod
 4690 
 4691     !True when using tight-coupling approximation (required for stability at early times)
 4692             logical TightCoupling, TensTightCoupling
 4693             real(dl) TightSwitchoffTime
 4694   
 4695     !Numer of scalar equations we are propagating
 4696             integer ScalEqsToPropagate
 4697             integer TensEqsToPropagate
 4698     !beta > l for closed models 
 4699             integer FirstZerolForBeta
 4700     !Tensor vars
 4701             real(dl) aux_buf
 4702 
 4703             real(dl) pig, pigdot !For tight coupling
 4704             real(dl) poltruncfac
 4705             
 4706             logical no_nu_multpoles, no_phot_multpoles 
 4707             integer lmaxnu_tau(max_nu)  !lmax for massive neutinos at time being integrated
 4708             logical nu_nonrelativistic(max_nu)
 4709              
 4710             real(dl) denlk(max_l_evolve),denlk2(max_l_evolve), polfack(max_l_evolve)
 4711             real(dl) Kf(max_l_evolve)  
 4712 
 4713             integer E_ix, B_ix !tensor polarization indices
 4714             real(dl) denlkt(4,max_l_evolve),Kft(max_l_evolve) 
 4715               
 4716                
 4717         end type EvolutionVars
 4718 
 4719 !precalculated arrays
 4720         real(dl) polfac(max_l_evolve),denl(max_l_evolve),vecfac(max_l_evolve),vecfacpol(max_l_evolve) 
 4721         
 4722        real(dl), parameter :: ep0 = 1.0d-2 
 4723        integer, parameter :: lmaxnu_high_ktau = 3
 4724 
 4725        real(dl) epsw
 4726        real(dl) nu_tau_notmassless(nqmax0+1,max_nu), nu_tau_nonrelativistic(max_nu),nu_tau_massive(max_nu)  
 4727        contains
 4728 
 4729 
 4730         subroutine GaugeInterface_ScalEv(EV,y,tau,tauend,tol1,ind,c,w)
 4731          type(EvolutionVars) EV
 4732          real(dl) c(24),w(EV%nvar,9), y(EV%nvar), tol1, tau, tauend
 4733          integer ind
 4734             
 4735             call dverk(EV,EV%ScalEqsToPropagate,derivs,tau,y,tauend,tol1,ind,c,EV%nvar,w)
 4736             if (ind = -3) then
 4737              call GlobalError('Dverk error -3: the subroutine was unable  to  satisfy  the  error ' &
 4738                            //'requirement  with a particular step-size that is less than or * ' &
 4739                            //'equal to hmin, which may mean that tol is too small' &
 4740                            //'--- but most likely you''ve messed up the y array indexing; ' &
 4741                       //'compiling with bounds checking may (or may not) help find the problem.',error_evolution)     
 4742             end if
 4743         end subroutine GaugeInterface_ScalEv
 4744         
 4745         function next_nu_nq(nq) result (next_nq)
 4746          integer, intent(in) :: nq
 4747          integer q, next_nq
 4748         
 4749          if (nq = 0) then
 4750          next_nq = 1
 4751          else
 4752          q = nu_q(nq)         
 4753          if (q> = 10) then
 4754            next_nq = nqmax
 4755          else
 4756            next_nq = nq+1
 4757          end if
 4758          end if
 4759         
 4760         end function next_nu_nq
 4761 
 4762          recursive subroutine GaugeInterface_EvolveScal(EV,tau,y,tauend,tol1,ind,c,w)
 4763          use ThermoData
 4764          type(EvolutionVars) EV, EVout
 4765          real(dl) c(24),w(EV%nvar,9), y(EV%nvar), yout(EV%nvar), tol1, tau, tauend
 4766          integer ind, nu_i
 4767          real(dl) cs2, opacity, dopacity
 4768          real(dl) tau_switch_ktau, tau_switch_nu_massless, tau_switch_nu_massive, next_switch
 4769          real(dl) tau_switch_no_nu_multpoles, tau_switch_no_phot_multpoles,tau_switch_nu_nonrel
 4770          real(dl) noSwitch, smallTime
 4771 
 4772          noSwitch = CP%tau0+1
 4773          smallTime =  min(tau, 1/EV%k_buf)/100
 4774 
 4775          tau_switch_ktau = noSwitch
 4776          tau_switch_no_nu_multpoles = noSwitch
 4777          tau_switch_no_phot_multpoles = noSwitch
 4778          
 4779          !Massive neutrino switches
 4780          tau_switch_nu_massless = noSwitch
 4781          tau_switch_nu_nonrel = noSwitch
 4782          tau_switch_nu_massive = noSwitch
 4783 
 4784          !Evolve equations from tau to tauend, performing switches in equations if necessary.
 4785           
 4786           if (.not. EV%high_ktau_neutrino_approx .and. .not. EV%no_nu_multpoles ) then
 4787             tau_switch_ktau =  max(20, EV%lmaxnr-4)/EV%k_buf
 4788           end if          
 4789 
 4790          if (CP%Num_Nu_massive /= 0) then
 4791           do nu_i = 1, CP%Nu_mass_eigenstates       
 4792             if (EV%nq(nu_i) /= nqmax) then
 4793               tau_switch_nu_massless = min(tau_switch_nu_massless,nu_tau_notmassless(next_nu_nq(EV%nq(nu_i)),nu_i))
 4794             else if (.not. EV%nu_nonrelativistic(nu_i)) then
 4795               tau_switch_nu_nonrel = min(nu_tau_nonrelativistic(nu_i),tau_switch_nu_nonrel)            
 4796             else if (EV%NuMethod = Nu_trunc .and..not. EV%MassiveNuApprox(nu_i)) then
 4797               tau_switch_nu_massive = min(tau_switch_nu_massive,EV%MassiveNuApproxTime(nu_i)) 
 4798             end if   
 4799           end do        
 4800          end if
 4801          
 4802          if (DoLateRadTruncation) then
 4803           
 4804           if (.not. EV%no_nu_multpoles) & !!.and. .not. EV%has_nu_relativistic .and. tau_switch_nu_massless = noSwitch)  &
 4805                tau_switch_no_nu_multpoles = max(15/EV%k_buf*AccuracyBoost,min(taurend,matter_verydom_tau)) 
 4806           
 4807           if (.not. EV%no_phot_multpoles .and. (.not.CP%WantCls .or. EV%k_buf>0.03*AccuracyBoost)) &
 4808                tau_switch_no_phot_multpoles = max(15/EV%k_buf,taurend)*AccuracyBoost 
 4809          end if          
 4810          
 4811          next_switch = min(tau_switch_ktau, tau_switch_nu_massless,EV%TightSwitchoffTime, tau_switch_nu_massive, &
 4812                tau_switch_no_nu_multpoles, tau_switch_no_phot_multpoles, tau_switch_nu_nonrel,noSwitch)
 4813          
 4814          if (next_switch < tauend) then
 4815              if (next_switch > tau+smallTime) then
 4816                 call GaugeInterface_ScalEv(EV, y, tau,next_switch,tol1,ind,c,w)
 4817                 if (global_error_flag/= 0) return
 4818              end if
 4819    
 4820              EVout = EV
 4821           
 4822             if (next_switch = EV%TightSwitchoffTime) then 
 4823               !TightCoupling           
 4824                  EVout%TightCoupling = .false.
 4825                  EVout%TightSwitchoffTime = noSwitch
 4826                  call SetupScalarArrayIndices(EVout)
 4827                  call CopyScalarVariableArray(y,yout, EV, EVout)
 4828                  EV = EVout
 4829                  y = yout
 4830                  ind = 1
 4831                !Set up variables with their tight coupling values
 4832                  y(EV%g_ix+2) = EV%pig
 4833                  call thermo(tau,cs2,opacity,dopacity)
 4834 
 4835                  if (second_order_tightcoupling) then
 4836                  ! Francis-Yan Cyr-Racine November 2010
 4837                  
 4838                  y(EV%g_ix+3) = (3/7)*y(EV%g_ix+2)*(EV%k_buf/opacity)*(1+dopacity/opacity**2) + &
 4839                       (3/7)*EV%pigdot*(EV%k_buf/opacity**2)*(-1)
 4840                 
 4841                  y(EV%polind+2) = EV%pig/4 + EV%pigdot*(1/opacity)*(-5/8- &
 4842                       (25/16)*dopacity/opacity**2) + &
 4843                       EV%pig*(EV%k_buf/opacity)**2*(-5/56)  
 4844                  y(EV%polind+3) = (3/7)*(EV%k_buf/opacity)*y(EV%polind+2)*(1 + &
 4845                      dopacity/opacity**2) + (3/7)*(EV%k_buf/opacity**2)*((EV%pigdot/4)* &
 4846                       (1+(5/2)*dopacity/opacity**2))*(-1)
 4847 
 4848                  else  
 4849                 
 4850                  y(EV%g_ix+3) = 3./7*y(EV%g_ix+2)*EV%k_buf/opacity
 4851                  y(EV%polind+2) = EV%pig/4   
 4852                  y(EV%polind+3) = y(EV%g_ix+3)/4 
 4853                  
 4854                  end if
 4855                  
 4856            else if (next_switch = tau_switch_ktau) then
 4857             !k tau >> 1, evolve massless neutrino effective fluid up to l = 2
 4858                 EVout%high_ktau_neutrino_approx = .true.
 4859                 EV%nq(1:CP%Nu_mass_eigenstates) = nqmax               
 4860                 call SetupScalarArrayIndices(EVout)
 4861                 call CopyScalarVariableArray(y,yout, EV, EVout)
 4862                 y = yout
 4863                 EV = EVout
 4864            else if (next_switch = tau_switch_nu_massless) then
 4865              !Mass starts to become important, start evolving next momentum mode
 4866               do nu_i = 1, CP%Nu_mass_eigenstates       
 4867                  if (EV%nq(nu_i) /= nqmax .and. &
 4868                    next_switch = nu_tau_notmassless(next_nu_nq(EV%nq(nu_i)),nu_i)) then
 4869                      EVOut%nq(nu_i) = next_nu_nq(EV%nq(nu_i))
 4870                      call SetupScalarArrayIndices(EVout)
 4871                      call CopyScalarVariableArray(y,yout, EV, EVout)
 4872                      EV = EVout
 4873                      y = yout
 4874                      exit 
 4875                 end if
 4876               end do
 4877            else if (next_switch = tau_switch_nu_nonrel) then
 4878               !Neutrino becomes non-relativistic, don't need high L              
 4879               do nu_i = 1, CP%Nu_mass_eigenstates       
 4880                 if (.not. EV%nu_nonrelativistic(nu_i) .and.  next_switch = nu_tau_nonrelativistic(nu_i) ) then
 4881                      EVout%nu_nonrelativistic(nu_i) = .true.
 4882                      call SetupScalarArrayIndices(EVout)
 4883                      call CopyScalarVariableArray(y,yout, EV, EVout)
 4884                      EV = EVout
 4885                      y = yout
 4886                      exit 
 4887                 end if
 4888               end do
 4889            else if (next_switch = tau_switch_nu_massive) then
 4890             !Very non-relativistic neutrinos, switch to truncated velocity-weight hierarchy
 4891               do nu_i = 1, CP%Nu_mass_eigenstates       
 4892                 if (.not. EV%MassiveNuApprox(nu_i) .and.  next_switch = EV%MassiveNuApproxTime(nu_i) ) then
 4893                      call SwitchToMassiveNuApprox(EV,y, nu_i)
 4894                      exit
 4895                 end if
 4896               end do
 4897            else if (next_switch = tau_switch_no_nu_multpoles) then
 4898            !Turn off neutrino hierarchies at late time where slow and not needed.
 4899                  ind = 1
 4900                  EVout%no_nu_multpoles = .true.
 4901                  EVOut%nq(1:CP%Nu_mass_eigenstates ) = nqmax                 
 4902                  call SetupScalarArrayIndices(EVout)
 4903                  call CopyScalarVariableArray(y,yout, EV, EVout)
 4904                  y = yout
 4905                  EV = EVout 
 4906            else if (next_switch = tau_switch_no_phot_multpoles) then
 4907            !Turn off photon hierarchies at late time where slow and not needed.
 4908                  ind = 1
 4909                  EVout%no_phot_multpoles = .true.
 4910                  call SetupScalarArrayIndices(EVout)
 4911                  call CopyScalarVariableArray(y,yout, EV, EVout)
 4912                  y = yout
 4913                  EV = EVout      
 4914            end if       
 4915     
 4916            call GaugeInterface_EvolveScal(EV,tau,y,tauend,tol1,ind,c,w)
 4917            return           
 4918          
 4919          end if
 4920          
 4921          call GaugeInterface_ScalEv(EV,y,tau,tauend,tol1,ind,c,w)
 4922         
 4923         end subroutine GaugeInterface_EvolveScal
 4924 
 4925          subroutine GaugeInterface_EvolveTens(EV,tau,y,tauend,tol1,ind,c,w)
 4926          use ThermoData
 4927          type(EvolutionVars) EV, EVOut
 4928          real(dl) c(24),w(EV%nvart,9), y(EV%nvart),yout(EV%nvart), tol1, tau, tauend
 4929          integer ind
 4930          real(dl) opacity, cs2
 4931          
 4932            if (EV%TensTightCoupling .and. tauend > EV%TightSwitchoffTime) then
 4933             if (EV%TightSwitchoffTime > tau) then
 4934              call dverk(EV,EV%TensEqsToPropagate, derivst,tau,y,EV%TightSwitchoffTime,tol1,ind,c,EV%nvart,w)
 4935             end if
 4936             EVOut = EV
 4937             EVOut%TensTightCoupling = .false.
 4938             call SetupTensorArrayIndices(EVout)
 4939             call CopyTensorVariableArray(y,yout,Ev, Evout)
 4940             Ev = EvOut
 4941             y = yout
 4942             call thermo(tau,cs2,opacity)
 4943             y(EV%g_ix+2) = 32/45*EV%k_buf/opacity*y(3)
 4944             y(EV%E_ix+2) = y(EV%g_ix+2)/4
 4945            end if
 4946  
 4947            call dverk(EV,EV%TensEqsToPropagate, derivst,tau,y,tauend,tol1,ind,c,EV%nvart,w)
 4948  
 4949          
 4950          end subroutine GaugeInterface_EvolveTens
 4951 
 4952  
 4953         subroutine GaugeInterface_Init
 4954           !Precompute various arrays and other things independent of wavenumber
 4955           integer j, nu_i
 4956           real(dl) a_nonrel, a_mass,a_massive, time
 4957 
 4958           epsw = 100/CP%tau0
 4959          
 4960           if (CP%WantScalars) then
 4961             do j = 2,max_l_evolve
 4962               polfac(j) = real((j+3)*(j-1),dl)/(j+1)
 4963             end do               
 4964           end if
 4965       
 4966           if (CP%WantVectors) then
 4967             do j = 2,max_l_evolve
 4968              vecfac(j) = real((j+2),dl)/(j+1)
 4969              vecfacpol(j) = real((j+3)*j,dl)*(j-1)*vecfac(j)/(j+1)**2
 4970            end do
 4971    
 4972           end if
 4973     
 4974          do j = 1,max_l_evolve
 4975            denl(j) = 1/(2*j+1)
 4976          end do     
 4977     
 4978          do nu_i = 1, CP%Nu_Mass_eigenstates
 4979             a_mass =  1.e-1/nu_masses(nu_i)/lAccuracyBoost 
 4980             !if (HighAccuracyDefault) a_mass = a_mass/4
 4981             time = DeltaTime(0,nu_q(1)*a_mass)
 4982             nu_tau_notmassless(1, nu_i) = time
 4983             do j = 2,nqmax
 4984              !times when each momentum mode becomes signficantly nonrelativistic
 4985              time = time + DeltaTime(nu_q(j-1)*a_mass,nu_q(j)*a_mass, 0.01)
 4986              nu_tau_notmassless(j, nu_i) = time
 4987             end do
 4988             
 4989             a_nonrel =  2/nu_masses(nu_i)*AccuracyBoost
 4990             nu_tau_nonrelativistic(nu_i) = DeltaTime(0,a_nonrel) 
 4991             a_massive =  17/nu_masses(nu_i)*AccuracyBoost 
 4992             nu_tau_massive(nu_i) = nu_tau_nonrelativistic(nu_i) + DeltaTime(a_nonrel,a_massive) 
 4993             
 4994          end do 
 4995        
 4996         end subroutine GaugeInterface_Init
 4997 
 4998 
 4999         subroutine SetupScalarArrayIndices(EV, max_num_eqns)
 5000           !Set up array indices after the lmax have been decided
 5001           use MassiveNu
 5002           !Set the numer of equations in each hierarchy, and get total number of equations for this k
 5003           type(EvolutionVars) EV
 5004           integer, intent(out), optional :: max_num_eqns
 5005           integer neq, maxeq, nu_i
 5006           
 5007           neq = basic_num_eqns
 5008           maxeq = neq 
 5009           if (.not. EV%no_phot_multpoles) then
 5010            !Photon multipoles
 5011            EV%g_ix = basic_num_eqns+1
 5012            if (EV%TightCoupling) then
 5013              neq = neq+2
 5014             else 
 5015              neq = neq+ (EV%lmaxg+1)
 5016             !Polarization multipoles
 5017              EV%polind = neq -1 !polind+2 is L = 2, for polarizationthe first calculated         
 5018              neq = neq + EV%lmaxgpol-1
 5019            end if
 5020           end if
 5021           if (.not. EV%no_nu_multpoles) then
 5022            !Massless neutrino multipoles
 5023            EV%r_ix = neq+1   
 5024            if (EV%high_ktau_neutrino_approx) then
 5025             neq = neq + 3
 5026            else
 5027             neq = neq + (EV%lmaxnr+1)
 5028            end if 
 5029           end if          
 5030           maxeq = maxeq +  (EV%lmaxg+1)+(EV%lmaxnr+1)+EV%lmaxgpol-1
 5031 
 5032           !Dark energy
 5033           if (w_lam /= -1 .and. w_Perturb) then
 5034             EV%w_ix = neq+1
 5035             neq = neq+2 
 5036             maxeq = maxeq+2
 5037           else
 5038             EV%w_ix = 0
 5039           end if
 5040 
 5041          !Massive neutrinos 
 5042          if (CP%Num_Nu_massive /= 0) then
 5043 
 5044            EV%has_nu_relativistic = any(EV%nq(1:CP%Nu_Mass_eigenstates)/= nqmax)
 5045            if (EV%has_nu_relativistic) then
 5046             EV%lmaxnu_pert = EV%lmaxnu 
 5047             EV%nu_pert_ix = neq+1
 5048             neq = neq+ EV%lmaxnu_pert+1
 5049             maxeq = maxeq+ EV%lmaxnu_pert+1
 5050            else
 5051             EV%lmaxnu_pert = 0
 5052            end if
 5053            
 5054            do nu_i = 1, CP%Nu_Mass_eigenstates
 5055            
 5056             if (EV%high_ktau_neutrino_approx) then
 5057               if (HighAccuracyDefault .and. CP%WantTransfer .and. EV%q < 1) then
 5058                EV%lmaxnu_tau(nu_i) = max(4,lmaxnu_high_ktau)
 5059                else
 5060                EV%lmaxnu_tau(nu_i) = lmaxnu_high_ktau
 5061               end if
 5062             else
 5063               EV%lmaxnu_tau(nu_i) = max(min(nint(0.5*EV%q*nu_tau_nonrelativistic(nu_i)*lAccuracyBoost),EV%lmaxnu),3) 
 5064               if (EV%nu_nonrelativistic(nu_i)) EV%lmaxnu_tau(nu_i) = min(EV%lmaxnu_tau(nu_i),nint(4*lAccuracyBoost))
 5065             end if
 5066             EV%lmaxnu_tau(nu_i) = min(EV%lmaxnu,EV%lmaxnu_tau(nu_i))
 5067         
 5068             EV%nu_ix(nu_i) = neq+1 
 5069             if (EV%MassiveNuApprox(nu_i)) then
 5070                 neq = neq+4
 5071             else
 5072                 neq = neq+ EV%nq(nu_i)*(EV%lmaxnu_tau(nu_i)+1)
 5073             endif
 5074             maxeq = maxeq + nqmax*(EV%lmaxnu+1)
 5075           end do
 5076            
 5077          else
 5078           EV%has_nu_relativistic = .false.
 5079          end if
 5080 
 5081          EV%ScalEqsToPropagate = neq
 5082          if (present(max_num_eqns)) then
 5083           max_num_eqns = maxeq
 5084          end if
 5085  
 5086         end subroutine SetupScalarArrayIndices
 5087 
 5088         subroutine CopyScalarVariableArray(y,yout, EV, EVout)
 5089           type(EvolutionVars) EV, EVOut
 5090           real(dl), intent(in) :: y(EV%nvar)
 5091           real(dl), intent(out) :: yout(EVout%nvar)
 5092           integer lmax,i, nq
 5093           integer nnueq,nu_i, ix_off, ix_off2, ind, ind2
 5094           real(dl) q, pert_scale
 5095           
 5096           yout = 0 
 5097           yout(1:basic_num_eqns) = y(1:basic_num_eqns)
 5098           if (w_lam /= -1 .and. w_Perturb) then
 5099                yout(EVout%w_ix) = y(EV%w_ix)
 5100                yout(EVout%w_ix+1) = y(EV%w_ix+1)
 5101           end if  
 5102           
 5103           if (.not. EV%no_phot_multpoles .and. .not. EVout%no_phot_multpoles) then
 5104           
 5105             if (EV%TightCoupling .or. EVOut%TightCoupling) then
 5106              lmax = 1
 5107             else 
 5108              lmax = min(EV%lmaxg,EVout%lmaxg)
 5109             end if
 5110             yout(EVout%g_ix:EVout%g_ix+lmax) = y(EV%g_ix:EV%g_ix+lmax)          
 5111             if (.not. EV%TightCoupling .and. .not. EVOut%TightCoupling) then  
 5112               lmax = min(EV%lmaxgpol,EVout%lmaxgpol)
 5113               yout(EVout%polind+2:EVout%polind+lmax) = y(EV%polind+2:EV%polind+lmax)
 5114             end if
 5115             
 5116           end if  
 5117 
 5118           if (.not. EV%no_nu_multpoles .and. .not. EVout%no_nu_multpoles) then
 5119          
 5120             if (EV%high_ktau_neutrino_approx .or. EVout%high_ktau_neutrino_approx) then
 5121              lmax = 2
 5122             else
 5123              lmax = min(EV%lmaxnr,EVout%lmaxnr)            
 5124             end if
 5125             yout(EVout%r_ix:EVout%r_ix+lmax) = y(EV%r_ix:EV%r_ix+lmax)  
 5126           
 5127           end if
 5128           
 5129          if (CP%Num_Nu_massive /= 0) then
 5130            
 5131            do nu_i = 1,CP%Nu_mass_eigenstates
 5132             ix_off = EV%nu_ix(nu_i)
 5133             ix_off2 = EVOut%nu_ix(nu_i)
 5134             if (EV%MassiveNuApprox(nu_i) .and. EVout%MassiveNuApprox(nu_i)) then
 5135                  nnueq = 4
 5136                  yout(ix_off2:ix_off2+nnueq-1) = y(ix_off:ix_off+nnueq-1)
 5137             else if (.not. EV%MassiveNuApprox(nu_i) .and. .not. EVout%MassiveNuApprox(nu_i)) then
 5138                  lmax = min(EV%lmaxnu_tau(nu_i),EVOut%lmaxnu_tau(nu_i))
 5139                  nq = min(EV%nq(nu_i), EVOut%nq(nu_i))
 5140                  do i = 1,nq
 5141                      ind = ix_off + (i-1)*(EV%lmaxnu_tau(nu_i)+1)
 5142                      ind2 = ix_off2+ (i-1)*(EVOut%lmaxnu_tau(nu_i)+1)
 5143                      yout(ind2:ind2+lmax) = y(ind:ind+lmax) 
 5144                  end do
 5145                  do i = nq+1, EVOut%nq(nu_i)
 5146                    lmax = min(EVOut%lmaxnu_tau(nu_i), EV%lmaxnr)
 5147                    ind2 = ix_off2+ (i-1)*(EVOut%lmaxnu_tau(nu_i)+1)
 5148                    yout(ind2:ind2+lmax) = y(EV%r_ix:EV%r_ix+lmax)            
 5149   
 5150                   !Add leading correction for the mass
 5151                    q = nu_q(i)
 5152                    pert_scale = (nu_masses(nu_i)/q)**2/2
 5153                    lmax = min(lmax,EV%lmaxnu_pert)
 5154                    yout(ind2:ind2+lmax) = yout(ind2:ind2+lmax) &
 5155                                    + y(EV%nu_pert_ix:EV%nu_pert_ix+lmax)*pert_scale           
 5156                   
 5157                  end do
 5158             end if
 5159            end do
 5160            
 5161            if (EVOut%has_nu_relativistic .and. EV%has_nu_relativistic) then   
 5162             lmax = min(EVOut%lmaxnu_pert, EV%lmaxnu_pert)
 5163             yout(EVout%nu_pert_ix:EVout%nu_pert_ix+lmax) =  y(EV%nu_pert_ix:EV%nu_pert_ix+lmax)
 5164           end if
 5165     
 5166          end if         
 5167           
 5168         end subroutine CopyScalarVariableArray
 5169 
 5170 
 5171         subroutine SetupTensorArrayIndices(EV, maxeq)
 5172          type(EvolutionVars) EV          
 5173          integer nu_i, neq
 5174          integer, optional, intent(out) :: maxeq
 5175           neq = 3
 5176           EV%g_ix = neq-1 !EV%g_ix+2 is quadrupole
 5177           if (.not. EV%TensTightCoupling) then
 5178            EV%E_ix = EV%g_ix + (EV%lmaxt-1)
 5179            EV%B_ix = EV%E_ix + (EV%lmaxpolt-1)
 5180            neq = neq+ (EV%lmaxt-1)+(EV%lmaxpolt-1)*2
 5181           end if
 5182           if (present(maxeq)) then
 5183            maxeq = 3 + (EV%lmaxt-1)+(EV%lmaxpolt-1)*2
 5184           end if
 5185           EV%r_ix = neq -1
 5186           if (DoTensorNeutrinos) then           
 5187              neq = neq + EV%lmaxnrt-1
 5188              if (present(maxeq)) maxeq = maxeq+EV%lmaxnrt-1
 5189              if (CP%Num_Nu_massive /= 0 ) then
 5190                do nu_i = 1, CP%nu_mass_eigenstates
 5191                    EV%EvolveTensorMassiveNu(nu_i) = nu_tau_nonrelativistic(nu_i) < 0.8*tau_maxvis*AccuracyBoost
 5192                    if (EV%EvolveTensorMassiveNu(nu_i)) then
 5193                     EV%nu_ix(nu_i) = neq-1 
 5194                     neq = neq+ nqmax*(EV%lmaxnut-1)
 5195                     if (present(maxeq)) maxeq = maxeq + nqmax*(EV%lmaxnut-1)
 5196                    end if
 5197                end do
 5198               end if 
 5199           end if
 5200          
 5201          EV%TensEqsToPropagate = neq 
 5202          
 5203         end  subroutine SetupTensorArrayIndices
 5204 
 5205         subroutine CopyTensorVariableArray(y,yout, EV, EVout)
 5206           type(EvolutionVars) EV, EVOut
 5207           real(dl), intent(in) :: y(EV%nvart)
 5208           real(dl), intent(out) :: yout(EVout%nvart)
 5209           integer lmaxpolt, lmaxt, nu_i, ind, ind2, i
 5210           
 5211           yout = 0 
 5212           yout(1:3) = y(1:3)          
 5213           if (.not. EVOut%TensTightCoupling .and. .not.EV%TensTightCoupling) then
 5214            lmaxt = min(EVOut%lmaxt,EV%lmaxt)
 5215            yout(EVout%g_ix+2:EVout%g_ix+lmaxt) = y(EV%g_ix+2:EV%g_ix+lmaxt)     
 5216            lmaxpolt = min(EV%lmaxpolt, EVOut%lmaxpolt)    
 5217            yout(EVout%E_ix+2:EVout%E_ix+lmaxpolt) = y(EV%E_ix+2:EV%E_ix+lmaxpolt)         
 5218            yout(EVout%B_ix+2:EVout%B_ix+lmaxpolt) = y(EV%B_ix+2:EV%B_ix+lmaxpolt)         
 5219           end if
 5220           if (DoTensorNeutrinos) then       
 5221              lmaxt = min(EV%lmaxnrt,EVOut%lmaxnrt)    
 5222              yout(EVout%r_ix+2:EVout%r_ix+lmaxt) = y(EV%r_ix+2:EV%r_ix+lmaxt)     
 5223              do nu_i = 1, CP%nu_mass_eigenstates
 5224                 if (EV%EvolveTensorMassiveNu(nu_i)) then
 5225                  lmaxt = min(EV%lmaxnut,EVOut%lmaxnut)
 5226                  do i = 1,nqmax
 5227                      ind = EV%nu_ix(nu_i) + (i-1)*(EV%lmaxnut-1)
 5228                      ind2 = EVOut%nu_ix(nu_i)+ (i-1)*(EVOut%lmaxnut-1)
 5229                      yout(ind2+2:ind2+lmaxt) = y(ind+2:ind+lmaxt) 
 5230                  end do
 5231                 end if 
 5232              end do
 5233           end if           
 5234           
 5235         end subroutine CopyTensorVariableArray
 5236 
 5237         subroutine GetNumEqns(EV)
 5238           use MassiveNu
 5239           !Set the numer of equations in each hierarchy, and get total number of equations for this k
 5240           type(EvolutionVars) EV
 5241           real(dl) scal
 5242           integer nu_i,q_rel,j
 5243 
 5244          if (CP%Num_Nu_massive = 0) then
 5245             EV%lmaxnu = 0
 5246          else 
 5247             do nu_i = 1, CP%Nu_mass_eigenstates       
 5248                !Start with momentum modes for which t_k ~ time at which mode becomes non-relativistic
 5249                q_rel = 0
 5250                do j = 1, nqmax
 5251                  !two different q's here EV%q ~k
 5252                 if (nu_q(j) > nu_masses(nu_i)*adotrad/EV%q) exit
 5253                 q_rel = q_rel + 1 
 5254                end do
 5255 
 5256                if (q_rel> = nqmax-2) then
 5257                 EV%nq(nu_i) = nqmax
 5258                else
 5259                 EV%nq(nu_i) = q_rel
 5260                end if
 5261                !q_rel = nint(nu_masses(nu_i)*adotrad/EV%q) !two dffierent q's here EV%q ~k
 5262                !EV%nq(nu_i) = max(0,min(nqmax0,q_rel)) !number of momentum modes to evolve intitially 
 5263                EV%nu_nonrelativistic(nu_i) = .false.
 5264             end do
 5265 
 5266             EV%NuMethod = CP%MassiveNuMethod
 5267             if (EV%NuMethod = Nu_Best) EV%NuMethod = Nu_Trunc
 5268             !l_max for massive neutrinos
 5269             if (CP%Transfer%high_precision) then
 5270              EV%lmaxnu = nint(25*lAccuracyBoost) 
 5271             else
 5272              EV%lmaxnu = max(3,nint(10*lAccuracyBoost))   
 5273             endif 
 5274             
 5275          end if
 5276 
 5277         if (CP%closed) then
 5278            EV%FirstZerolForBeta = nint(EV%q*CP%r) 
 5279         else 
 5280            EV%FirstZerolForBeta = l0max !a large number
 5281         end if
 5282 
 5283         EV%high_ktau_neutrino_approx = .false.
 5284         if (CP%WantScalars) then
 5285          EV%TightCoupling = .true.
 5286          EV%no_phot_multpoles = .false.
 5287          EV%no_nu_multpoles = .false.
 5288          EV%MassiveNuApprox = .false.
 5289 
 5290          if (HighAccuracyDefault .and. CP%AccuratePolarization) then
 5291           EV%lmaxg  = max(nint(11*lAccuracyBoost),3) 
 5292          else
 5293           EV%lmaxg  = max(nint(8*lAccuracyBoost),3)          
 5294          end if
 5295          EV%lmaxnr = max(nint(14*lAccuracyBoost),3)
 5296 
 5297          EV%lmaxgpol = EV%lmaxg  
 5298          if (.not.CP%AccuratePolarization) EV%lmaxgpol = max(nint(4*lAccuracyBoost),3)
 5299      
 5300          if (EV%q < 0.05) then  
 5301             !Large scales need fewer equations
 5302             scal  = 1
 5303             if (CP%AccuratePolarization) scal = 4  !But need more to get polarization right
 5304             EV%lmaxgpol = max(3,nint(min(8,nint(scal* 150* EV%q))*lAccuracyBoost)) 
 5305             EV%lmaxnr = max(3,nint(min(7,nint(sqrt(scal)* 150 * EV%q))*lAccuracyBoost)) 
 5306             EV%lmaxg = max(3,nint(min(8,nint(sqrt(scal) *300 * EV%q))*lAccuracyBoost)) 
 5307             if (CP%AccurateReionization) then
 5308              EV%lmaxg = EV%lmaxg*4
 5309              EV%lmaxgpol = EV%lmaxgpol*2
 5310             end if
 5311          end if                  
 5312          if (EV%TransferOnly) then
 5313             EV%lmaxgpol = min(EV%lmaxgpol,nint(5*lAccuracyBoost)) 
 5314             EV%lmaxg = min(EV%lmaxg,nint(6*lAccuracyBoost))     
 5315          end if
 5316          if (CP%Transfer%high_precision) then
 5317            if (HighAccuracyDefault) then
 5318              EV%lmaxnr = max(nint(45*lAccuracyBoost),3) 
 5319            else
 5320              EV%lmaxnr = max(nint(30*lAccuracyBoost),3) 
 5321            endif   
 5322            if (EV%q > 0.04 .and. EV%q < 0.5) then !baryon oscillation scales
 5323               EV%lmaxg = max(EV%lmaxg,10) 
 5324            end if   
 5325          end if
 5326       
 5327          if (CP%closed) then         
 5328           EV%lmaxnu = min(EV%lmaxnu, EV%FirstZerolForBeta-1)         
 5329           EV%lmaxnr = min(EV%lmaxnr, EV%FirstZerolForBeta-1)         
 5330           EV%lmaxg = min(EV%lmaxg, EV%FirstZerolForBeta-1)         
 5331           EV%lmaxgpol = min(EV%lmaxgpol, EV%FirstZerolForBeta-1)         
 5332          end if
 5333          
 5334          EV%poltruncfac = real(EV%lmaxgpol,dl)/max(1,(EV%lmaxgpol-2))
 5335          EV%MaxlNeeded = max(EV%lmaxg,EV%lmaxnr,EV%lmaxgpol,EV%lmaxnu) 
 5336          if (EV%MaxlNeeded > max_l_evolve) stop 'Need to increase max_l_evolve'
 5337          call SetupScalarArrayIndices(EV,EV%nvar)
 5338          if (CP%closed) EV%nvar = EV%nvar+1 !so can reference lmax+1 with zero coefficient
 5339          EV%lmaxt = 0
 5340          
 5341         else
 5342           EV%nvar = 0
 5343         end if
 5344     
 5345        if (CP%WantTensors) then
 5346           EV%TensTightCoupling = .true.
 5347           EV%lmaxt = max(3,nint(8*lAccuracyBoost)) 
 5348           EV%lmaxpolt = max(3,nint(4*lAccuracyBoost)) 
 5349          ! if (EV%q < 1e-3) EV%lmaxpolt = EV%lmaxpolt+1 
 5350           if (DoTensorNeutrinos) then           
 5351             EV%lmaxnrt = nint(6*lAccuracyBoost)
 5352             EV%lmaxnut = EV%lmaxnrt
 5353           else
 5354            EV%lmaxnut = 0
 5355            EV%lmaxnrt = 0
 5356           end if
 5357           if (CP%closed) then
 5358             EV%lmaxt = min(EV%FirstZerolForBeta-1,EV%lmaxt)
 5359             EV%lmaxpolt = min(EV%FirstZerolForBeta-1,EV%lmaxpolt)
 5360             EV%lmaxnrt = min(EV%FirstZerolForBeta-1,EV%lmaxnrt)
 5361             EV%lmaxnut = min(EV%FirstZerolForBeta-1,EV%lmaxnut)            
 5362           end if
 5363           EV%MaxlNeededt = max(EV%lmaxpolt,EV%lmaxt, EV%lmaxnrt, EV%lmaxnut)
 5364           if (EV%MaxlNeededt > max_l_evolve) stop 'Need to increase max_l_evolve'
 5365           call SetupTensorArrayIndices(EV, EV%nvart)
 5366         else
 5367           EV%nvart = 0
 5368         end if       
 5369 
 5370 
 5371        if (CP%WantVectors) then
 5372            EV%lmaxv = max(10,nint(8*lAccuracyBoost))
 5373            EV%lmaxpolv = max(5,nint(5*lAccuracyBoost)) 
 5374           
 5375            EV%nvarv = (EV%lmaxv)+(EV%lmaxpolv-1)*2+3
 5376           
 5377            EV%lmaxnrv = nint(30*lAccuracyBoost)
 5378   
 5379            EV%nvarv = EV%nvarv+EV%lmaxnrv
 5380            if (CP%Num_Nu_massive /= 0 ) then
 5381                   stop 'massive neutrinos not supported for vector modes'
 5382            end if 
 5383         else
 5384           EV%nvarv = 0
 5385         end if       
 5386         
 5387         end subroutine GetNumEqns
 5388 
 5389 !cccccccccccccccccccccccccccccccccc
 5390         subroutine SwitchToMassiveNuApprox(EV,y, nu_i)
 5391 !When the neutrinos are no longer highly relativistic we use a truncated
 5392 !energy-integrated hierarchy going up to third order in velocity dispersion
 5393         type(EvolutionVars) EV, EVout
 5394         integer, intent(in) :: nu_i
 5395 
 5396         real(dl) a,a2,pnu,clxnu,dpnu,pinu,rhonu
 5397         real(dl) qnu
 5398         real(dl) y(EV%nvar), yout(EV%nvar)
 5399      
 5400         a = y(1)
 5401         a2 = a*a
 5402         EVout = EV
 5403         EVout%MassiveNuApprox(nu_i) = .true.
 5404         call SetupScalarArrayIndices(EVout)
 5405         call CopyScalarVariableArray(y,yout, EV, EVout)
 5406         
 5407        !Get density and pressure as ratio to massles by interpolation from table
 5408         call Nu_background(a*nu_masses(nu_i),rhonu,pnu)
 5409 
 5410        !Integrate over q
 5411         call Nu_Integrate_L012(EV, y, a, nu_i, clxnu,qnu,dpnu,pinu)
 5412         !clxnu_here  = rhonu*clxnu, qnu_here = qnu*rhonu
 5413         dpnu = dpnu/rhonu
 5414         qnu = qnu/rhonu
 5415         clxnu = clxnu/rhonu
 5416         pinu = pinu/rhonu                     
 5417 
 5418         yout(EVout%nu_ix(nu_i)) = clxnu
 5419         yout(EVout%nu_ix(nu_i)+1) = dpnu
 5420         yout(EVout%nu_ix(nu_i)+2) = qnu
 5421         yout(EVout%nu_ix(nu_i)+3) = pinu
 5422 
 5423         call Nu_Intvsq(EV,y, a, nu_i, EVout%G11(nu_i),EVout%G30(nu_i))
 5424 !Analytic solution for higher moments, proportional to a^{-3}
 5425         EVout%G11(nu_i) = EVout%G11(nu_i)*a2*a/rhonu  
 5426         EVout%G30(nu_i) = EVout%G30(nu_i)*a2*a/rhonu   
 5427 
 5428         EV = EVout
 5429         y = yout
 5430          
 5431         end subroutine SwitchToMassiveNuApprox
 5432 
 5433        subroutine MassiveNuVarsOut(EV,y,yprime,a,grho,gpres,dgrho,dgq,dgpi, gdpi_diff,pidot_sum)
 5434         implicit none
 5435         type(EvolutionVars) EV
 5436         real(dl) :: y(EV%nvar), yprime(EV%nvar),a, grho,gpres,dgrho,dgq,dgpi, gdpi_diff,pidot_sum
 5437           !grho = a^2 kappa rho
 5438           !gpres = a^2 kappa p
 5439           !dgrho = a^2 kappa \delta\rho
 5440           !dgp =  a^2 kappa \delta p
 5441           !dgq = a^2 kappa q (heat flux)
 5442           !dgpi = a^2 kappa pi (anisotropic stress) 
 5443           !dgpi_diff = a^2 kappa (3*p -rho)*pi
 5444 
 5445         integer nu_i
 5446         real(dl) pinudot,grhormass_t, rhonu, pnu,  rhonudot
 5447         real(dl) adotoa, grhonu_t,gpnu_t
 5448         real(dl) clxnu, qnu, pinu, dpnu
 5449         real(dl) dtauda
 5450 
 5451          do nu_i = 1, CP%Nu_mass_eigenstates
 5452 
 5453            grhormass_t = grhormass(nu_i)/a**2
 5454 
 5455            !Get density and pressure as ratio to massless by interpolation from table
 5456            call Nu_background(a*nu_masses(nu_i),rhonu,pnu)
 5457 
 5458            if (EV%MassiveNuApprox(nu_i)) then    
 5459               clxnu = y(EV%nu_ix(nu_i))
 5460               !dpnu = y(EV%iq0+1+off_ix)
 5461               qnu = y(EV%nu_ix(nu_i)+2)
 5462               pinu = y(EV%nu_ix(nu_i)+3)
 5463               pinudot = yprime(EV%nu_ix(nu_i)+3)
 5464         
 5465            else
 5466             !Integrate over q
 5467             call Nu_Integrate_L012(EV, y, a, nu_i, clxnu,qnu,dpnu,pinu)
 5468             !clxnu_here  = rhonu*clxnu, qnu_here = qnu*rhonu
 5469             !dpnu = dpnu/rhonu
 5470             qnu = qnu/rhonu
 5471             clxnu = clxnu/rhonu
 5472             pinu = pinu/rhonu       
 5473             adotoa = 1/(a*dtauda(a))
 5474             rhonudot = Nu_drho(a*nu_masses(nu_i),adotoa,rhonu)
 5475             
 5476             call Nu_pinudot(EV,y, yprime, a,adotoa, nu_i,pinudot)
 5477             pinudot = pinudot/rhonu - rhonudot/rhonu*pinu    
 5478           endif
 5479 
 5480           grhonu_t = grhormass_t*rhonu
 5481           gpnu_t = grhormass_t*pnu
 5482           
 5483           grho = grho  + grhonu_t
 5484           gpres = gpres + gpnu_t
 5485 
 5486           dgrho = dgrho + grhonu_t*clxnu  
 5487           dgq  = dgq   + grhonu_t*qnu 
 5488           dgpi = dgpi  + grhonu_t*pinu 
 5489           gdpi_diff = gdpi_diff + pinu*(3*gpnu_t-grhonu_t) 
 5490           pidot_sum = pidot_sum + grhonu_t*pinudot 
 5491 
 5492         end do
 5493 
 5494      end subroutine MassiveNuVarsOut
 5495 
 5496        subroutine Nu_Integrate_L012(EV,y,a,nu_i,drhonu,fnu,dpnu,pinu)
 5497         type(EvolutionVars) EV
 5498 !  Compute the perturbations of density and energy flux
 5499 !  of one eigenstate of massive neutrinos, in units of the mean
 5500 !  density of one eigenstate of massless neutrinos, by integrating over
 5501 !  momentum.
 5502         integer, intent(in) :: nu_i
 5503         real(dl), intent(in) :: a, y(EV%nvar)
 5504         real(dl), intent(OUT) ::  drhonu,fnu
 5505         real(dl), optional, intent(OUT) :: dpnu,pinu
 5506         real(dl) tmp, am, aq,v, pert_scale
 5507         integer iq, ind
 5508    
 5509 !  q is the comoving momentum in units of k_B*T_nu0/c.
 5510 
 5511         drhonu = 0
 5512         fnu = 0
 5513         if (present(dpnu)) then
 5514          dpnu = 0
 5515          pinu = 0
 5516         end if
 5517         am = a*nu_masses(nu_i)
 5518         ind = EV%nu_ix(nu_i)
 5519         do iq = 1,EV%nq(nu_i)
 5520             aq = am/nu_q(iq)
 5521             v = 1/sqrt(1+aq*aq)          
 5522             drhonu = drhonu+ nu_int_kernel(iq)* y(ind)/v           
 5523             fnu = fnu+nu_int_kernel(iq)* y(ind+1)
 5524             if (present(dpnu)) then
 5525              dpnu = dpnu+  nu_int_kernel(iq)* y(ind)*v 
 5526              pinu = pinu+ nu_int_kernel(iq)*y(ind+2)*v
 5527             end if  
 5528             ind = ind+EV%lmaxnu_tau(nu_i)+1           
 5529         end do
 5530         ind = EV%nu_pert_ix
 5531         do iq = EV%nq(nu_i)+1,nqmax
 5532          !Get the rest from perturbatively relativistic expansion
 5533             aq = am/nu_q(iq)
 5534             v = 1/sqrt(1+aq*aq)          
 5535             pert_scale = (nu_masses(nu_i)/nu_q(iq))**2/2
 5536             tmp = nu_int_kernel(iq)*(y(EV%r_ix)  + pert_scale*y(ind)  )
 5537             drhonu = drhonu+ tmp/v           
 5538             fnu = fnu+nu_int_kernel(iq)*(y(EV%r_ix+1)+ pert_scale*y(ind+1))
 5539             if (present(dpnu)) then
 5540               dpnu = dpnu+ tmp*v
 5541               pinu = pinu+ nu_int_kernel(iq)*(y(EV%r_ix+2)+ pert_scale*y(ind+2))*v
 5542             end if
 5543         end do
 5544 
 5545         if (present(dpnu)) then
 5546          dpnu = dpnu/3
 5547         end if
 5548      
 5549         end subroutine Nu_Integrate_L012
 5550 
 5551        subroutine Nu_pinudot(EV,y, ydot, a,adotoa, nu_i,pinudot)
 5552         type(EvolutionVars) EV
 5553         integer, intent(in) :: nu_i
 5554         real(dl), intent(in) :: a,adotoa, y(EV%nvar), ydot(EV%nvar)
 5555            
 5556 !  Compute the time derivative of the mean density in massive neutrinos
 5557 !  and the shear perturbation.
 5558         real(dl) pinudot
 5559         real(dl) aq,q,v,aqdot,vdot
 5560         real(dl) psi2,psi2dot
 5561         real(dl) am, pert_scale
 5562         integer iq,ind
 5563 
 5564 !  q is the comoving momentum in units of k_B*T_nu0/c.
 5565         pinudot = 0
 5566         ind = EV%nu_ix(nu_i)+2
 5567         am = a*nu_masses(nu_i)
 5568         do iq = 1,EV%nq(nu_i)
 5569             q = nu_q(iq)
 5570             aq = am/q
 5571             aqdot = aq*adotoa
 5572             v = 1/sqrt(1+aq*aq)
 5573             vdot = -aq*aqdot/(1+aq*aq)**1.5
 5574             pinudot = pinudot+nu_int_kernel(iq)*(ydot(ind)*v+y(ind)*vdot)
 5575             ind = ind+EV%lmaxnu_tau(nu_i)+1           
 5576         end do
 5577         ind = EV%nu_pert_ix+2
 5578         do iq = EV%nq(nu_i)+1,nqmax
 5579             q = nu_q(iq)
 5580             aq = am/q
 5581             aqdot = aq*adotoa
 5582             pert_scale = (nu_masses(nu_i)/q)**2/2
 5583             v = 1/sqrt(1+aq*aq)
 5584             vdot = -aq*aqdot/(1+aq*aq)**1.5
 5585             psi2dot = ydot(EV%r_ix+2)  + pert_scale*ydot(ind)
 5586             psi2 = y(EV%r_ix+2)  + pert_scale*y(ind)
 5587             pinudot = pinudot+nu_int_kernel(iq)*(psi2dot*v+psi2*vdot)
 5588         end do
 5589 
 5590        end subroutine Nu_pinudot
 5591 
 5592 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 5593         function Nu_pi(EV,y, a, nu_i) result(pinu)
 5594         type(EvolutionVars) EV
 5595         integer, intent(in) :: nu_i
 5596         real(dl), intent(in) :: a, y(EV%nvar)
 5597         real(dl) :: am      
 5598         real(dl) pinu,q,aq,v
 5599         integer iq, ind
 5600 
 5601         if (EV%nq(nu_i)/= nqmax) stop 'Nu_pi nq/= nqmax0'
 5602         pinu = 0
 5603         ind = EV%nu_ix(nu_i)+2
 5604         am = a*nu_masses(nu_i)
 5605         do iq = 1, EV%nq(nu_i)
 5606             q = nu_q(iq)
 5607             aq = am/q
 5608             v = 1/sqrt(1+aq*aq)          
 5609             pinu = pinu+nu_int_kernel(iq)*y(ind)*v
 5610             ind = ind+EV%lmaxnut+1  
 5611         end do
 5612 
 5613         end function Nu_pi
 5614 
 5615 !cccccccccccccccccccccccccccccccccccccccccccccc
 5616       subroutine Nu_Intvsq(EV,y, a, nu_i, G11,G30)
 5617         type(EvolutionVars) EV
 5618         integer, intent(in) :: nu_i
 5619         real(dl), intent(in) :: a, y(EV%nvar)
 5620         real(dl), intent(OUT) ::  G11,G30
 5621 
 5622 !  Compute the third order variables (in velocity dispersion) 
 5623 !by integrating over momentum.
 5624         real(dl) aq,q,v, am
 5625         integer iq, ind
 5626 
 5627 !  q is the comoving momentum in units of k_B*T_nu0/c.
 5628         am = a*nu_masses(nu_i)
 5629         ind = EV%nu_ix(nu_i)
 5630         G11 = 0
 5631         G30 = 0
 5632         if (EV%nq(nu_i)/= nqmax) stop 'Nu_Intvsq nq/= nqmax0'
 5633         do iq = 1, EV%nq(nu_i)
 5634             q = nu_q(iq)
 5635             aq = am/q
 5636             v = 1/sqrt(1+aq*aq)          
 5637             G11 = G11+nu_int_kernel(iq)*y(ind+1)*v**2
 5638             if (EV%lmaxnu_tau(nu_i)>2) then
 5639             G30 = G30+nu_int_kernel(iq)*y(ind+3)*v**2
 5640             end if
 5641             ind = ind+EV%lmaxnu_tau(nu_i)+1     
 5642         end do
 5643            
 5644         end subroutine Nu_Intvsq
 5645 
 5646 
 5647      subroutine MassiveNuVars(EV,y,a,grho,gpres,dgrho,dgq, wnu_arr)
 5648         implicit none
 5649         type(EvolutionVars) EV
 5650         real(dl) :: y(EV%nvar), a, grho,gpres,dgrho,dgq
 5651         real(dl), intent(out), optional :: wnu_arr(max_nu)
 5652           !grho = a^2 kappa rho
 5653           !gpres = a^2 kappa p
 5654           !dgrho = a^2 kappa \delta\rho
 5655           !dgp =  a^2 kappa \delta p
 5656           !dgq = a^2 kappa q (heat flux)
 5657         integer nu_i
 5658         real(dl) grhormass_t, rhonu, qnu, clxnu, grhonu_t, gpnu_t, pnu
 5659 
 5660          do nu_i = 1, CP%Nu_mass_eigenstates
 5661 
 5662           grhormass_t = grhormass(nu_i)/a**2
 5663 
 5664           !Get density and pressure as ratio to massless by interpolation from table
 5665           call Nu_background(a*nu_masses(nu_i),rhonu,pnu)
 5666  
 5667           if (EV%MassiveNuApprox(nu_i)) then    
 5668               clxnu = y(EV%nu_ix(nu_i))
 5669               qnu = y(EV%nu_ix(nu_i)+2)
 5670            else
 5671             !Integrate over q
 5672              call Nu_Integrate_L012(EV, y, a, nu_i, clxnu,qnu)
 5673              !clxnu_here  = rhonu*clxnu, qnu_here = qnu*rhonu
 5674              qnu = qnu/rhonu
 5675              clxnu = clxnu/rhonu
 5676            endif
 5677  
 5678           grhonu_t = grhormass_t*rhonu
 5679           gpnu_t = grhormass_t*pnu
 5680                     
 5681           grho = grho  + grhonu_t
 5682           gpres = gpres + gpnu_t
 5683           dgrho = dgrho + grhonu_t*clxnu
 5684           dgq  = dgq   + grhonu_t*qnu
 5685 
 5686           if (present(wnu_arr)) then
 5687            wnu_arr(nu_i) = pnu/rhonu
 5688           end if
 5689 
 5690         end do
 5691 
 5692      end subroutine MassiveNuVars
 5693 
 5694 
 5695 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 5696         subroutine output(EV,y, j,tau,sources)
 5697         use ThermoData
 5698         use lvalues
 5699         use ModelData 
 5700         implicit none
 5701         integer j
 5702         type(EvolutionVars) EV
 5703         real(dl), target :: y(EV%nvar),yprime(EV%nvar)
 5704         real(dl), dimension(:),pointer :: ypol,ypolprime
 5705         
 5706         real(dl) dgq,grhob_t,grhor_t,grhoc_t,grhog_t,grhov_t,sigma,polter
 5707         real(dl) qgdot,pigdot,pirdot,vbdot,dgrho
 5708         real(dl) a,a2,dz,z,clxc,clxb,vb,clxg,qg,pig,clxr,qr,pir
 5709 
 5710         real(dl) tau,x,divfac
 5711         real(dl) dgpi_diff, pidot_sum
 5712         real(dl), target :: pol(3),polprime(3) 
 5713           !dgpi_diff = sum (3*p_nu -rho_nu)*pi_nu
 5714 
 5715         real(dl) k,k2  ,adotoa, grho, gpres,etak,phi,dgpi
 5716         real(dl) clxq, vq, diff_rhopi, octg, octgprime
 5717         real(dl) sources(CTransScal%NumSources)
 5718         real(dl) ISW
 5719         
 5720         yprime = 0
 5721         call derivs(EV,EV%ScalEqsToPropagate,tau,y,yprime)        
 5722         
 5723         if (EV%TightCoupling .or. EV%no_phot_multpoles) then
 5724          pol = 0
 5725          polprime = 0
 5726          ypolprime = > polprime
 5727          ypol = > pol         
 5728         else
 5729          ypolprime = > yprime(EV%polind+1:)
 5730          ypol = > y(EV%polind+1:)
 5731         end if
 5732         
 5733         k = EV%k_buf
 5734         k2 = EV%k2_buf
 5735      
 5736         a   = y(1)
 5737         a2  = a*a
 5738         etak = y(2)
 5739         clxc = y(3)
 5740         clxb = y(4)
 5741         vb  = y(5)
 5742         vbdot = yprime(5)
 5743 
 5744 !  Compute expansion rate from: grho 8*pi*rho*a**2
 5745 
 5746         grhob_t = grhob/a
 5747         grhoc_t = grhoc/a
 5748         grhor_t = grhornomass/a2
 5749         grhog_t = grhog/a2
 5750         grhov_t = grhov*a**(-1-3*w_lam)
 5751         grho = grhob_t+grhoc_t+grhor_t+grhog_t+grhov_t
 5752         gpres = (grhog_t+grhor_t)/3+grhov_t*w_lam
 5753 
 5754 !  8*pi*a*a*SUM[rho_i*clx_i] add radiation later
 5755         dgrho = grhob_t*clxb+grhoc_t*clxc
 5756 
 5757 !  8*pi*a*a*SUM[(rho_i+p_i)*v_i]
 5758         dgq = grhob_t*vb
 5759 
 5760         dgpi = 0   
 5761         dgpi_diff = 0
 5762         pidot_sum = 0
 5763 
 5764         if (CP%Num_Nu_Massive /= 0) then
 5765          call MassiveNuVarsOut(EV,y,yprime,a,grho,gpres,dgrho,dgq,dgpi, dgpi_diff,pidot_sum)
 5766         end if
 5767 
 5768         if (w_lam /= -1 .and. w_Perturb) then
 5769           
 5770            clxq = y(EV%w_ix)
 5771            vq = y(EV%w_ix+1) 
 5772            dgrho = dgrho + clxq*grhov_t
 5773            dgq = dgq + vq*grhov_t*(1+w_lam)
 5774          
 5775         end if
 5776         
 5777         adotoa = sqrt((grho+grhok)/3)
 5778 
 5779         if (EV%no_nu_multpoles) then
 5780              z = (0.5*dgrho/k + etak)/adotoa 
 5781              dz = -adotoa*z - 0.5*dgrho/k
 5782              clxr = -4*dz/k
 5783              qr = -4/3*z
 5784              pir = 0
 5785              pirdot = 0
 5786         else
 5787             clxr = y(EV%r_ix)
 5788             qr  = y(EV%r_ix+1)
 5789             pir = y(EV%r_ix+2)
 5790             pirdot = yprime(EV%r_ix+2)
 5791         end if
 5792 
 5793         if (EV%no_phot_multpoles) then
 5794              z = (0.5*dgrho/k + etak)/adotoa 
 5795              dz = -adotoa*z - 0.5*dgrho/k
 5796              clxg = -4*dz/k -4/k*opac(j)*(vb+z)
 5797              qg = -4/3*z
 5798              pig = 0
 5799              pigdot = 0
 5800              octg = 0
 5801              octgprime = 0
 5802              qgdot = -4*dz/k
 5803         else
 5804             if (EV%TightCoupling) then
 5805              pig = EV%pig
 5806              !pigdot = EV%pigdot
 5807              if (second_order_tightcoupling) then
 5808                octg = (3/7)*pig*(EV%k_buf/opac(j)) 
 5809                ypol(2) = EV%pig/4 + EV%pigdot*(1/opac(j))*(-5/8)
 5810                ypol(3) = (3/7)*(EV%k_buf/opac(j))*ypol(2)
 5811              else
 5812                ypol(2) = EV%pig/4
 5813                octg = 0
 5814              end if
 5815              octgprime = 0
 5816             else
 5817              pig = y(EV%g_ix+2)
 5818              pigdot = yprime(EV%g_ix+2)
 5819              octg = y(EV%g_ix+3)
 5820              octgprime = yprime(EV%g_ix+3)
 5821             end if 
 5822             clxg = y(EV%g_ix)
 5823             qg  = y(EV%g_ix+1)
 5824             qgdot = yprime(EV%g_ix+1)
 5825        end if
 5826 
 5827        dgrho = dgrho + grhog_t*clxg+grhor_t*clxr
 5828        dgq   = dgq   + grhog_t*qg+grhor_t*qr
 5829        dgpi  = dgpi  + grhor_t*pir + grhog_t*pig
 5830 
 5831 
 5832 !  Get sigma (shear) and z from the constraints
 5833 !  have to get z from eta for numerical stability       
 5834         z = (0.5*dgrho/k + etak)/adotoa 
 5835         sigma = (z+1.5*dgq/k2)/EV%Kf(1)
 5836          
 5837         polter = 0.1*pig+9/15*ypol(2)
 5838 
 5839         if (CP%flat) then
 5840         x = k*(CP%tau0-tau)
 5841         divfac = x*x    
 5842         else   
 5843         x = (CP%tau0-tau)/CP%r
 5844         divfac = (CP%r*rofChi(x))**2*k2 
 5845         end if
 5846 
 5847 
 5848         if (EV%TightCoupling) then
 5849           if (second_order_tightcoupling) then
 5850             pigdot = EV%pigdot  
 5851             ypolprime(2) = (pigdot/4)*(1+(5/2)*(dopac(j)/opac(j)**2))
 5852           else
 5853            pigdot = -dopac(j)/opac(j)*pig + 32/45*k/opac(j)*(-2*adotoa*sigma  &
 5854                  +etak/EV%Kf(1)-  dgpi/k +vbdot )
 5855            ypolprime(2) = pigdot/4
 5856           end if
 5857         end if
 5858 
 5859         pidot_sum =  pidot_sum + grhog_t*pigdot + grhor_t*pirdot
 5860         diff_rhopi = pidot_sum - (4*dgpi+ dgpi_diff )*adotoa
 5861 
 5862 !Maple's fortran output - see scal_eqs.map
 5863 !2phi' term (\phi' + \psi' in Newtonian gauge)
 5864         ISW = (4/3*k*EV%Kf(1)*sigma+(-2/3*sigma-2/3*etak/adotoa)*k &
 5865               -diff_rhopi/k**2-1/adotoa*dgrho/3+(3*gpres+5*grho)*sigma/k/3 &
 5866               -2/k*adotoa/EV%Kf(1)*etak)*expmmu(j)
 5867 
 5868 !e.g. to get only late-time ISW
 5869 !  if (1/a-1 < 30) ISW = 0
 5870 
 5871 !The rest, note y(9)->octg, yprime(9)->octgprime (octopoles)
 5872     sources(1) = ISW +  ((-9/160*pig-27/80*ypol(2))/k**2*opac(j)+(11/10*sigma- &
 5873     3/8*EV%Kf(2)*ypol(3)+vb-9/80*EV%Kf(2)*octg+3/40*qg)/k-(- &
 5874     180*ypolprime(2)-30*pigdot)/k**2/160)*dvis(j)+(-(9*pigdot+ &
 5875     54*ypolprime(2))/k**2*opac(j)/160+pig/16+clxg/4+3/8*ypol(2)+(- &
 5876     21/5*adotoa*sigma-3/8*EV%Kf(2)*ypolprime(3)+vbdot+3/40*qgdot- &
 5877     9/80*EV%Kf(2)*octgprime)/k+(-9/160*dopac(j)*pig-21/10*dgpi-27/ &
 5878     80*dopac(j)*ypol(2))/k**2)*vis(j)+(3/16*ddvis(j)*pig+9/ &
 5879     8*ddvis(j)*ypol(2))/k**2+21/10/k/EV%Kf(1)*vis(j)*etak   
 5880 
 5881 
 5882 ! Doppler term
 5883 !   sources(1) =  (sigma+vb)/k*dvis(j)+((-2*adotoa*sigma+vbdot)/k-1/k**2*dgpi)*vis(j) &
 5884 !         +1/k/EV%Kf(1)*vis(j)*etak
 5885 
 5886 !Equivalent full result
 5887 !    t4 = 1/adotoa
 5888 !    t92 = k**2
 5889 !   sources(1) = (4/3*EV%Kf(1)*expmmu(j)*sigma+2/3*(-sigma-t4*etak)*expmmu(j))*k+ &
 5890 !       (3/8*ypol(2)+pig/16+clxg/4)*vis(j)
 5891 !    sources(1) = sources(1)-t4*expmmu(j)*dgrho/3+((11/10*sigma- &
 5892 !         3/8*EV%Kf(2)*ypol(3)+vb+ 3/40*qg-9/80*EV%Kf(2)*y(9))*dvis(j)+(5/3*grho+ &
 5893 !        gpres)*sigma*expmmu(j)+(-2*adotoa*etak*expmmu(j)+21/10*etak*vis(j))/ &
 5894 !        EV%Kf(1)+(vbdot-3/8*EV%Kf(2)*ypolprime(3)+3/40*qgdot-21/ &
 5895 !        5*sigma*adotoa-9/80*EV%Kf(2)*yprime(9))*vis(j))/k+(((-9/160*pigdot- &
 5896 !        27/80*ypolprime(2))*opac(j)-21/10*dgpi -27/80*dopac(j)*ypol(2) &
 5897 !        -9/160*dopac(j)*pig)*vis(j) - diff_rhopi*expmmu(j)+((-27/80*ypol(2)-9/ &
 5898 !        160*pig)*opac(j)+3/16*pigdot+9/8*ypolprime(2))*dvis(j)+9/ &
 5899 !        8*ddvis(j)*ypol(2)+3/16*ddvis(j)*pig)/t92
 5900 
 5901 
 5902       if (x > 0) then
 5903          !E polarization source
 5904            sources(2) = vis(j)*polter*(15/8)/divfac 
 5905                !factor of four because no 1/16 later
 5906         else
 5907            sources(2) = 0
 5908         end if
 5909  
 5910       if (CTransScal%NumSources > 2) then
 5911          !Get lensing sources
 5912          !Can modify this here if you want to get power spectra for other tracer
 5913        if (tau>taurend .and. CP%tau0-tau > 0.1) then
 5914          
 5915          !phi_lens = Phi - 1/2 kappa (a/k)^2 sum_i rho_i pi_i
 5916          !Neglect pi contributions because not accurate at late time anyway
 5917          phi = -(dgrho +3*dgq*adotoa/k)/(k2*EV%Kf(1)*2) 
 5918             ! - (grhor_t*pir + grhog_t*pig+ pinu*gpnu_t)/k2
 5919          
 5920          sources(3) = -2*phi*f_K(tau-tau_maxvis)/(f_K(CP%tau0-tau_maxvis)*f_K(CP%tau0-tau))
 5921 !         sources(3) = -2*phi*(tau-tau_maxvis)/((CP%tau0-tau_maxvis)*(CP%tau0-tau))
 5922           !We include the lensing factor of two here
 5923        else
 5924          sources(3) = 0
 5925        end if
 5926       end if
 5927       
 5928      end subroutine output
 5929 
 5930 
 5931 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 5932         subroutine outputt(EV,yt,n,j,tau,dt,dte,dtb)
 5933 !calculate the tensor sources for open and closed case
 5934         use ThermoData
 5935 
 5936         implicit none
 5937         integer j,n
 5938         type(EvolutionVars) :: EV
 5939         real(dl), target :: yt(n), ytprime(n)
 5940         real(dl) tau,dt,dte,dtb,x,polterdot,polterddot,prefac
 5941         real(dl) pig, pigdot, octg, aux, polter, shear, adotoa,a
 5942         real(dl) sinhxr,cothxor
 5943         real(dl) k,k2
 5944         real(dl), dimension(:),pointer :: E,Bprime,Eprime
 5945         real(dl), target :: pol(3),polEprime(3), polBprime(3) 
 5946         real(dl) dtauda
 5947 
 5948         call derivst(EV,EV%nvart,tau,yt,ytprime)
 5949       
 5950         k2 = EV%k2_buf
 5951         k = EV%k_buf 
 5952         aux = EV%aux_buf  
 5953         shear = yt(3)
 5954 
 5955         x = (CP%tau0-tau)/CP%r
 5956 
 5957         !  And the electric part of the Weyl.
 5958         if (.not. EV%TensTightCoupling) then
 5959 !  Use the full expression for pigdt
 5960            pig = yt(EV%g_ix+2)
 5961            pigdot = ytprime(EV%g_ix+2)
 5962            E = > yt(EV%E_ix+1:)   
 5963            Eprime = > ytprime(EV%E_ix+1:) 
 5964            Bprime = > ytprime(EV%B_ix+1:)
 5965            octg = ytprime(EV%g_ix+3)
 5966         else
 5967 !  Use the tight-coupling approximation
 5968            a = yt(1)
 5969            adotoa = 1/(a*dtauda(a))
 5970            pigdot = 32/45*k/opac(j)*(2*adotoa*shear+ytprime(3))
 5971            pig = 32/45*k/opac(j)*shear
 5972            pol = 0
 5973            polEprime = 0
 5974            polBprime = 0
 5975            E = >pol
 5976            EPrime = >polEPrime
 5977            BPrime = >polBPrime
 5978            E(2) = pig/4    
 5979            EPrime(2) = pigdot/4   
 5980            octg = 0
 5981         endif
 5982        
 5983         sinhxr = rofChi(x)*CP%r
 5984     
 5985         if (EV%q*sinhxr > 1.e-8) then  
 5986 
 5987         prefac = sqrt(EV%q2*CP%r*CP%r-CP%Ksign)
 5988         cothxor = cosfunc(x)/sinhxr
 5989 
 5990         polter = 0.1*pig + 9/15*E(2)
 5991         polterdot = 9/15*Eprime(2) + 0.1*pigdot
 5992         polterddot = 9/15*(-dopac(j)*(E(2)-polter)-opac(j)*(  &
 5993                    Eprime(2)-polterdot) + k*(2/3*Bprime(2)*aux - &
 5994                    5/27*Eprime(3)*EV%Kft(2))) &
 5995                    +0.1*(k*(-octg*EV%Kft(2)/3 + 8/15*ytprime(3)) - &
 5996                    dopac(j)*(pig - polter) - opac(j)*(pigdot-polterdot))
 5997 
 5998         dt = (shear*expmmu(j) + (15/8)*polter*vis(j)/k)*CP%r/sinhxr**2/prefac 
 5999    
 6000         dte = CP%r*15/8/k/prefac* &
 6001             ((ddvis(j)*polter + 2*dvis(j)*polterdot + vis(j)*polterddot)  &
 6002               + 4*cothxor*(dvis(j)*polter + vis(j)*polterdot) - &
 6003                    vis(j)*polter*(k2 -6*cothxor**2))
 6004       
 6005         dtb = 15/4*EV%q*CP%r/k/prefac*(vis(j)*(2*cothxor*polter + polterdot) + dvis(j)*polter)
 6006    
 6007         else
 6008         dt = 0
 6009         dte = 0
 6010         dtb = 0
 6011         end if
 6012 
 6013         end subroutine outputt
 6014 
 6015 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 6016         subroutine outputv(EV,yv,n,j,tau,dt,dte,dtb)
 6017 !calculate the vector sources 
 6018         use ThermoData
 6019 
 6020         implicit none
 6021         integer j,n
 6022         type(EvolutionVars) :: EV
 6023         real(dl), target :: yv(n), yvprime(n)
 6024         real(dl) tau,dt,dte,dtb,x,polterdot
 6025         real(dl) vb,qg, pig, polter, sigma
 6026         real(dl) k,k2
 6027         real(dl), dimension(:),pointer :: E,Eprime
 6028 
 6029         call derivsv(EV,EV%nvarv,tau,yv,yvprime)
 6030       
 6031         k2 = EV%k2_buf
 6032         k = EV%k_buf 
 6033         sigma = yv(2)
 6034         vb  = yv(3)
 6035         qg  = yv(4)
 6036         pig = yv(5)
 6037 
 6038   
 6039         x = (CP%tau0-tau)*k
 6040               
 6041         if (x > 1.e-8) then  
 6042 
 6043         E = > yv(EV%lmaxv+3:)
 6044         Eprime = > yvprime(EV%lmaxv+3:) 
 6045       
 6046         polter = 0.1*pig + 9/15*E(2)
 6047         polterdot = 9/15*Eprime(2) + 0.1*yvprime(5)
 6048  
 6049         if (yv(1) < 1e-3) then
 6050          dt = 1
 6051         else
 6052          dt = 0
 6053         end if   
 6054         dt = (4*(vb+sigma)*vis(j) + 15/2/k*( vis(j)*polterdot + dvis(j)*polter) &
 6055                + 4*(expmmu(j)*yvprime(2)) )/x 
 6056    
 6057         dte = 15/2*2*polter/x**2*vis(j) + 15/2/k*(dvis(j)*polter + vis(j)*polterdot)/x 
 6058       
 6059         dtb = -15/2*polter/x*vis(j)
 6060 
 6061         else
 6062          dt = 0
 6063          dte = 0
 6064          dtb = 0
 6065         end if
 6066 
 6067         end subroutine outputv
 6068 
 6069 
 6070 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 6071         subroutine initial(EV,y, tau)
 6072 !  Initial conditions.
 6073         use ThermoData
 6074         implicit none
 6075    
 6076         type(EvolutionVars) EV
 6077         real(dl) y(EV%nvar)
 6078         real(dl) Rp15,tau,x,x2,x3,om,omtau, &
 6079              Rc,Rb,Rv,Rg,grhonu,chi
 6080         real(dl) k,k2 
 6081         real(dl) a,a2, iqg, rhomass,a_massive, ep
 6082         integer l,i, nu_i, j, ind
 6083         integer, parameter :: i_clxg = 1,i_clxr = 2,i_clxc = 3, i_clxb=4, &
 6084                 i_qg = 5,i_qr = 6,i_vb = 7,i_pir = 8, i_eta = 9, i_aj3r = 10,i_clxq=11,i_vq=12
 6085         integer, parameter :: i_max = i_vq
 6086         real(dl) initv(6,1:i_max), initvec(1:i_max)
 6087        
 6088         if (CP%flat) then
 6089          EV%k_buf = EV%q
 6090          EV%k2_buf = EV%q2     
 6091          EV%Kf(1:EV%MaxlNeeded) = 1
 6092         else
 6093          EV%k2_buf = EV%q2-CP%curv
 6094          EV%k_buf = sqrt(EV%k2_buf)
 6095                     
 6096          do l = 1,EV%MaxlNeeded
 6097            EV%Kf(l) = 1-CP%curv*(l*(l+2))/EV%k2_buf           
 6098          end do
 6099         end if
 6100  
 6101         k = EV%k_buf
 6102         k2 = EV%k2_buf
 6103  
 6104          do j = 1,EV%MaxlNeeded
 6105            EV%denlk(j) = denl(j)*k*j
 6106            EV%denlk2(j) = denl(j)*k*EV%Kf(j)*(j+1)
 6107            EV%polfack(j) = polfac(j)*k*EV%Kf(j)*denl(j)
 6108          end do     
 6109       
 6110         !Get time to switch off tight coupling 
 6111         !The numbers here are a bit of guesswork
 6112         !The high k increase saves time for very small loss of accuracy
 6113         !The lower k ones are more delicate. Nead to avoid instabilities at same time
 6114         !as ensuring tight coupling is accurate enough
 6115          if (EV%k_buf > epsw) then
 6116            if (EV%k_buf > epsw*5) then
 6117             ep = ep0*5/AccuracyBoost  
 6118             if (HighAccuracyDefault) ep = ep*0.65  
 6119            else
 6120             ep = ep0
 6121            end if
 6122          else
 6123            ep = ep0 
 6124          end if
 6125          if (second_order_tightcoupling) ep = ep*2 
 6126          EV%TightSwitchoffTime = min(tight_tau,Thermo_OpacityToTime(EV%k_buf/ep)) 
 6127 
 6128       
 6129         y = 0   
 6130    
 6131 !  k*tau, (k*tau)**2, (k*tau)**3
 6132         x = k*tau
 6133         x2 = x*x
 6134         x3 = x2*x
 6135         rhomass =  sum(grhormass(1:CP%Nu_mass_eigenstates)) 
 6136         grhonu = rhomass+grhornomass
 6137                                                         
 6138         om = (grhob+grhoc)/sqrt(3*(grhog+grhonu))       
 6139         omtau = om*tau
 6140         Rv = grhonu/(grhonu+grhog)
 6141         
 6142         Rg = 1-Rv
 6143         Rc = CP%omegac/(CP%omegac+CP%omegab)
 6144         Rb = 1-Rc
 6145         Rp15 = 4*Rv+15
 6146 
 6147         if (CP%Scalar_initial_condition > initial_nummodes) &
 6148           stop 'Invalid initial condition for scalar modes'
 6149 
 6150         a = tau*adotrad*(1+omtau/4)
 6151         a2 = a*a
 6152         
 6153         initv = 0
 6154 
 6155 !  Set adiabatic initial conditions
 6156 
 6157         chi = 1  !Get transfer function for chi
 6158         initv(1,i_clxg) = -chi*EV%Kf(1)/3*x2*(1-omtau/5)
 6159         initv(1,i_clxr) = initv(1,i_clxg)
 6160         initv(1,i_clxb) = 0.75*initv(1,i_clxg)
 6161         initv(1,i_clxc) = initv(1,i_clxb)
 6162         initv(1,i_qg) = initv(1,i_clxg)*x/9
 6163         initv(1,i_qr) = -chi*EV%Kf(1)*(4*Rv+23)/Rp15*x3/27
 6164         initv(1,i_vb) = 0.75*initv(1,i_qg)
 6165         initv(1,i_pir) = chi*4/3*x2/Rp15*(1+omtau/4*(4*Rv-5)/(2*Rv+15))
 6166         initv(1,i_aj3r) = chi*4/21/Rp15*x3
 6167         initv(1,i_eta) = -chi*2*EV%Kf(1)*(1 - x2/12*(-10/Rp15 + EV%Kf(1)))
 6168       
 6169         if (CP%Scalar_initial_condition/= initial_adiabatic) then
 6170 !CDM isocurvature   
 6171        
 6172          initv(2,i_clxg) = Rc*omtau*(-2/3 + omtau/4)
 6173          initv(2,i_clxr) = initv(2,i_clxg)
 6174          initv(2,i_clxb) = initv(2,i_clxg)*0.75
 6175          initv(2,i_clxc) = 1+initv(2,i_clxb)
 6176          initv(2,i_qg) = -Rc/9*omtau*x
 6177          initv(2,i_qr) = initv(2,i_qg)
 6178          initv(2,i_vb) = 0.75*initv(2,i_qg)
 6179          initv(2,i_pir) = -Rc*omtau*x2/3/(2*Rv+15)
 6180          initv(2,i_eta) = Rc*omtau*(1/3 - omtau/8)*EV%Kf(1)
 6181          initv(2,i_aj3r) = 0
 6182 !Baryon isocurvature
 6183          if (Rc = 0) stop 'Isocurvature initial conditions assume non-zero dark matter'
 6184 
 6185          initv(3,:) = initv(2,:)*(Rb/Rc)
 6186          initv(3,i_clxc) = initv(3,i_clxb)
 6187          initv(3,i_clxb) = initv(3,i_clxb)+1
 6188       
 6189 !neutrino isocurvature density mode
 6190        
 6191          initv(4,i_clxg) = Rv/Rg*(-1 + x2/6)
 6192          initv(4,i_clxr) = 1-x2/6
 6193          initv(4,i_clxc) = -omtau*x2/80*Rv*Rb/Rg
 6194          initv(4,i_clxb) = Rv/Rg/8*x2
 6195          iqg = - Rv/Rg*(x/3 - Rb/4/Rg*omtau*x)
 6196          initv(4,i_qg) = iqg
 6197          initv(4,i_qr) = x/3
 6198          initv(4,i_vb) = 0.75*iqg
 6199          initv(4,i_pir) = x2/Rp15
 6200          initv(4,i_eta) = EV%Kf(1)*Rv/Rp15/3*x2
 6201      
 6202 !neutrino isocurvature velocity mode
 6203 
 6204          initv(5,i_clxg) = Rv/Rg*x - 2*x*omtau/16*Rb*(2+Rg)/Rg**2
 6205          initv(5,i_clxr) = -x -3*x*omtau*Rb/16/Rg
 6206          initv(5,i_clxc) = -9*omtau*x/64*Rv*Rb/Rg
 6207          initv(5,i_clxb) = 3*Rv/4/Rg*x - 9*omtau*x/64*Rb*(2+Rg)/Rg**2
 6208          iqg = Rv/Rg*(-1 + 3*Rb/4/Rg*omtau+x2/6 +3*omtau**2/16*Rb/Rg**2*(Rg-3*Rb))
 6209          initv(5,i_qg) = iqg
 6210          initv(5,i_qr) = 1 - x2/6*(1+4*EV%Kf(1)/(4*Rv+5))
 6211          initv(5,i_vb) = 0.75*iqg
 6212          initv(5,i_pir) = 2*x/(4*Rv+5)+omtau*x*6/Rp15/(4*Rv+5)
 6213          initv(5,i_eta) = 2*EV%Kf(1)*x*Rv/(4*Rv+5) + omtau*x*3*EV%Kf(1)*Rv/32*(Rb/Rg - 80/Rp15/(4*Rv+5))
 6214          initv(5,i_aj3r) = 3/7*x2/(4*Rv+5)
 6215 
 6216 !quintessence isocurvature mode
 6217 
 6218 
 6219          end if
 6220 
 6221        if (CP%Scalar_initial_condition = initial_vector) then
 6222           InitVec = 0
 6223           do i = 1,initial_nummodes
 6224           InitVec = InitVec+ initv(i,:)*CP%InitialConditionVector(i)
 6225           end do
 6226        else
 6227           InitVec = initv(CP%Scalar_initial_condition,:)
 6228           if (CP%Scalar_initial_condition = initial_adiabatic) InitVec = -InitVec
 6229             !So we start with chi = -1 as before
 6230        end if
 6231 
 6232         y(1) = a
 6233         y(2) = -InitVec(i_eta)*k/2
 6234         !get eta_s*k, where eta_s is synchronous gauge variable
 6235 
 6236 !  CDM
 6237         y(3) = InitVec(i_clxc)
 6238   
 6239 !  Baryons
 6240         y(4) = InitVec(i_clxb)
 6241         y(5) = InitVec(i_vb)
 6242 
 6243 !  Photons
 6244         y(EV%g_ix) = InitVec(i_clxg)
 6245         y(EV%g_ix+1) = InitVec(i_qg) 
 6246               
 6247         if (w_lam /= -1 .and. w_Perturb) then
 6248          y(EV%w_ix) = InitVec(i_clxq)
 6249          y(EV%w_ix+1) = InitVec(i_vq)
 6250         end if
 6251 
 6252 !  Neutrinos
 6253         y(EV%r_ix) = InitVec(i_clxr)
 6254         y(EV%r_ix+1) = InitVec(i_qr)
 6255         y(EV%r_ix+2) = InitVec(i_pir)
 6256 
 6257         if (EV%lmaxnr>2) then
 6258          y(EV%r_ix+3) = InitVec(i_aj3r)
 6259         endif
 6260 
 6261         if (CP%Num_Nu_massive = 0) return 
 6262 
 6263         do nu_i = 1, CP%Nu_mass_eigenstates       
 6264           
 6265           EV%MassiveNuApproxTime(nu_i) = Nu_tau_massive(nu_i)
 6266           a_massive =  20000*k/nu_masses(nu_i)*AccuracyBoost*lAccuracyBoost  
 6267           if (a_massive > = 0.99) then
 6268             EV%MassiveNuApproxTime(nu_i) = CP%tau0+1
 6269           else if (a_massive > 17/nu_masses(nu_i)*AccuracyBoost) then
 6270             EV%MassiveNuApproxTime(nu_i) = max(EV%MassiveNuApproxTime(nu_i),DeltaTime(0,a_massive, 0.01))  
 6271           end if
 6272           ind = EV%nu_ix(nu_i)    
 6273           do  i = 1,EV%nq(nu_i)
 6274            y(ind:ind+2) = y(EV%r_ix:EV%r_ix+2) 
 6275            if (EV%lmaxnu_tau(nu_i)>2) y(ind+3) = InitVec(i_aj3r)           
 6276            ind = ind + EV%lmaxnu_tau(nu_i)+1
 6277           end do
 6278 
 6279         end do       
 6280 
 6281         end subroutine initial
 6282 
 6283 
 6284 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 6285         subroutine initialt(EV,yt,tau)
 6286 !  Initial conditions for tensors
 6287         use ThermoData
 6288         implicit none
 6289         real(dl) bigR,tau,x,aj3r,elec, pir, rhomass
 6290         integer l
 6291          type(EvolutionVars) EV
 6292         real(dl) k,k2 ,a, omtau
 6293         real(dl) yt(EV%nvart)
 6294         real(dl) tens0, ep, tensfac
 6295         
 6296         if (CP%flat) then
 6297          EV%aux_buf = 1
 6298          EV%k2_buf = EV%q2
 6299          EV%k_buf = EV%q       
 6300          EV%Kft(1:EV%MaxlNeededt) = 1 !initialize for flat case
 6301         else
 6302       
 6303          EV%k2_buf = EV%q2-3*CP%curv
 6304          EV%k_buf = sqrt(EV%k2_buf) 
 6305          EV%aux_buf = sqrt(1+3*CP%curv/EV%k2_buf)  
 6306         
 6307         endif
 6308       
 6309         k = EV%k_buf
 6310         k2 = EV%k2_buf
 6311 
 6312         do l = 1,EV%MaxlNeededt
 6313            if (.not. CP%flat) EV%Kft(l) = 1-CP%curv*((l+1)**2-3)/k2
 6314            EV%denlkt(1,l) = k*denl(l)*l !term for L-1
 6315            tensfac = real((l+3)*(l-1),dl)/(l+1)
 6316            EV%denlkt(2,l) = k*denl(l)*tensfac*EV%Kft(l) !term for L+1
 6317            EV%denlkt(3,l) = k*denl(l)*tensfac**2/(l+1)*EV%Kft(l) !term for polarization 
 6318            EV%denlkt(4,l) = k*4/(l*(l+1))*EV%aux_buf !other for polarization
 6319         end do
 6320 
 6321         if (k > 0.06*epsw) then
 6322            ep = ep0
 6323         else
 6324            ep = 0.2*ep0
 6325         end if
 6326 
 6327     !    finished_tightcoupling = ((k/opacity > ep).or.(1/(opacity*tau) > ep)) 
 6328         EV%TightSwitchoffTime = min(tight_tau,Thermo_OpacityToTime(EV%k_buf/ep)) 
 6329          
 6330         a = tau*adotrad
 6331         rhomass =  sum(grhormass(1:CP%Nu_mass_eigenstates)) 
 6332         omtau = tau*(grhob+grhoc)/sqrt(3*(grhog+rhomass+grhornomass))       
 6333             
 6334         if (DoTensorNeutrinos) then
 6335          bigR = (rhomass+grhornomass)/(rhomass+grhornomass+grhog)
 6336         else
 6337          bigR = 0
 6338         end if
 6339 
 6340         x = k*tau
 6341  
 6342         yt(1) = a
 6343         tens0 = 1
 6344 
 6345         yt(2) = tens0 
 6346 !commented things are for the compensated mode with magnetic fields; can be neglected
 6347 !-15/28*x**2*(bigR-1)/(15+4*bigR)*Magnetic*(1-5./2*omtau/(2*bigR+15))
 6348     
 6349         elec = -tens0*(1+2*CP%curv/k2)*(2*bigR+10)/(4*bigR+15) !elec, with H=1
 6350        
 6351         !shear
 6352         yt(3) = -5/2/(bigR+5)*x*elec 
 6353 !          + 15/14*x*(bigR-1)/(4*bigR+15)*Magnetic*(1 - 15./2*omtau/(2*bigR+15))
 6354         
 6355         yt(4:EV%nvart) = 0
 6356      
 6357 !  Neutrinos 
 6358         if (DoTensorNeutrinos) then
 6359          pir = -2/3/(bigR+5)*x**2*elec 
 6360 !           + (bigR-1)/bigR*Magnetic*(1-15./14*x**2/(15+4*bigR))
 6361          aj3r =  -2/21/(bigR+5)*x**3*elec !&
 6362 !           + 3/7*x*(bigR-1)/bigR*Magnetic
 6363          yt(EV%r_ix+2) = pir
 6364          yt(EV%r_ix+3) = aj3r
 6365          !Should set up massive too, but small anyway..
 6366         end if
 6367     
 6368         end subroutine initialt
 6369 
 6370 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 6371         subroutine initialv(EV,yv,tau)
 6372 !  Initial conditions for vectors
 6373 
 6374         implicit none
 6375         real(dl) bigR,Rc,tau,x,pir
 6376         type(EvolutionVars) EV
 6377         real(dl) k,k2 ,a, omtau
 6378         real(dl) yv(EV%nvarv)
 6379         
 6380         if (CP%flat) then
 6381          EV%k2_buf = EV%q2
 6382          EV%k_buf = EV%q       
 6383         else
 6384          stop 'Vectors not supported in non-flat models'
 6385         endif
 6386         
 6387         k = EV%k_buf
 6388         k2 = EV%k2_buf
 6389 
 6390         omtau = tau*(grhob+grhoc)/sqrt(3*(grhog+grhornomass))       
 6391 
 6392         a = tau*adotrad*(1+omtau/4)
 6393         
 6394         x = k*tau
 6395        
 6396         bigR = (grhornomass)/(grhornomass+grhog)
 6397         Rc = CP%omegac/(CP%omegac+CP%omegab)
 6398 
 6399         yv(1) = a
 6400 
 6401         
 6402         yv(2) = vec_sig0*(1- 15/2*omtau/(4*bigR+15)) + 45/14*x*Magnetic*(BigR-1)/(4*BigR+15)
 6403         !qg
 6404         yv(4) = vec_sig0/3* (4*bigR + 5)/(1-BigR)*(1  -0.75*omtau*(Rc-1)/(bigR-1)* &
 6405                (1 - 0.25*omtau*(3*Rc-2-bigR)/(BigR-1))) &
 6406                  -x/2*Magnetic
 6407         yv(3) = 3/4*yv(4)
 6408         
 6409         yv(5:EV%nvarv) = 0
 6410 
 6411 !        if (.false.) then
 6412 !         yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+1) = vec_sig0/6/bigR*x**2*(1+2*bigR*omtau/(4*bigR+15))
 6413 !         yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+2) = -2/3*vec_sig0/bigR*x*(1 +3*omtau*bigR/(4*bigR+15))
 6414 !         yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+3) = 1/4*vec_sig0/bigR*(5+4*BigR) 
 6415 !         yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+4) = 1/9.*x*vec_sig0*(5+4*bigR)/bigR
 6416 !         yv(4) = 0
 6417 !         yv(3) = 3/4*yv(4)
 6418 !          return 
 6419 !        end if
 6420 
 6421 !  Neutrinos
 6422 !q_r
 6423          yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+1) = -1/3*vec_sig0*(4*BigR+5)/bigR &
 6424              + x**2*vec_sig0/6/BigR +0.5*x*(1/bigR-1)*Magnetic 
 6425 !pi_r
 6426          pir = -2/3*x*vec_sig0/BigR - (1/bigR-1)*Magnetic
 6427          yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+1 +1) = pir
 6428          yv((EV%lmaxv-1+1)+(EV%lmaxpolv-1)*2+3+1 +2) = 3/7*x*Magnetic*(1-1/BigR)
 6429   
 6430         end subroutine initialv
 6431 
 6432 
 6433       subroutine outtransf(EV, y, Arr)
 6434  !write out clxc, clxb, clxg, clxn
 6435         use Transfer
 6436         implicit none
 6437         type(EvolutionVars) EV
 6438    
 6439         real(dl) clxc, clxb, clxg, clxr, k,k2
 6440         real(dl) grho,gpres,dgrho,dgq,a
 6441         real Arr(Transfer_max)
 6442         real(dl) y(EV%nvar)
 6443 
 6444         a    = y(1)
 6445         clxc = y(3)
 6446         clxb = y(4)
 6447         if (EV%no_nu_multpoles) then
 6448          clxr = 0
 6449         else
 6450          clxr = y(EV%r_ix)
 6451         end if
 6452         
 6453         if (EV%no_phot_multpoles) then
 6454          clxg = 0
 6455         else
 6456          clxg = y(EV%g_ix)
 6457         end if
 6458         
 6459         k    = EV%k_buf
 6460         k2   = EV%k2_buf
 6461  
 6462         Arr(Transfer_kh) = k/(CP%h0/100)
 6463         Arr(Transfer_cdm) = clxc/k2
 6464         Arr(Transfer_b) = clxb/k2
 6465         Arr(Transfer_g) = clxg/k2
 6466         Arr(Transfer_r) = clxr/k2
 6467   
 6468         dgrho = 0 
 6469         grho =  0
 6470         
 6471         if (CP%Num_Nu_Massive > 0) then
 6472           call MassiveNuVars(EV,y,a,grho,gpres,dgrho,dgq)
 6473            Arr(Transfer_nu) = dgrho/grho/k2
 6474         else
 6475            Arr(Transfer_nu) = 0
 6476         end if
 6477 
 6478 !!!If we want DE perturbations to get \delta\rho/\rho_m    
 6479 !       dgrho = dgrho+y(EV%w_ix)*grhov*a**(-1-3*w_lam)
 6480 !        Arr(Transfer_r) = y(EV%w_ix)/k2
 6481 !
 6482 !        dgrho = dgrho+(clxc*grhoc + clxb*grhob)/a 
 6483 !        grho =  grho+(grhoc+grhob)/a + grhov*a**(-1-3*w_lam)
 6484 
 6485          dgrho = dgrho+(clxc*grhoc + clxb*grhob)/a 
 6486          grho =  grho+(grhoc+grhob)/a
 6487         
 6488         Arr(Transfer_tot) = dgrho/grho/k2 
 6489              
 6490     
 6491      end subroutine outtransf
 6492 
 6493 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 6494         subroutine derivs(EV,n,tau,ay,ayprime)
 6495 !  Evaluate the time derivatives of the perturbations, flat case
 6496 !  ayprime is not necessarily GaugeInterface.yprime, so keep them distinct
 6497         use ThermoData
 6498         use MassiveNu
 6499         implicit none      
 6500         type(EvolutionVars) EV
 6501 
 6502         integer n,nu_i
 6503         real(dl) ay(n),ayprime(n)
 6504         real(dl) tau,w
 6505         real(dl) k,k2 
 6506 
 6507 !  Internal variables.
 6508 
 6509         real(dl) opacity
 6510         real(dl) photbar,cs2,pb43,grho,slip,clxgdot, &
 6511                       clxcdot,clxbdot,adotdota,gpres,clxrdot,etak
 6512         real(dl) q,aq,v
 6513         real(dl) G11_t,G30_t, wnu_arr(max_nu)
 6514 
 6515         real(dl) dgq,grhob_t,grhor_t,grhoc_t,grhog_t,grhov_t,sigma,polter
 6516         real(dl) qgdot,qrdot,pigdot,pirdot,vbdot,dgrho,adotoa
 6517         real(dl) a,a2,z,clxc,clxb,vb,clxg,qg,pig,clxr,qr,pir
 6518         real(dl) clxq, vq,  E2, dopacity
 6519         integer l,i,ind, ind2, off_ix, ix
 6520         real(dl) dgs,sigmadot,dz !, ddz
 6521         !non-flat vars
 6522         real(dl) cothxor !1/tau in flat case
 6523         
 6524        
 6525         k = EV%k_buf
 6526         k2 = EV%k2_buf     
 6527   
 6528         a = ay(1)
 6529         a2 = a*a
 6530 
 6531         etak = ay(2)
 6532 
 6533 !  CDM variables
 6534         clxc = ay(3)
 6535 
 6536 !  Baryon variables
 6537         clxb = ay(4)
 6538         vb = ay(5)
 6539 
 6540 !  Compute expansion rate from: grho 8*pi*rho*a**2
 6541 
 6542         grhob_t = grhob/a
 6543         grhoc_t = grhoc/a
 6544         grhor_t = grhornomass/a2
 6545         grhog_t = grhog/a2
 6546         if (w_lam = -1) then
 6547          grhov_t = grhov*a2
 6548          else
 6549          grhov_t = grhov*a**(-1-3*w_lam)
 6550         end if
 6551 
 6552 !  Get sound speed and ionisation fraction.
 6553         if (EV%TightCoupling) then
 6554           call thermo(tau,cs2,opacity,dopacity)
 6555          else
 6556           call thermo(tau,cs2,opacity)        
 6557         end if
 6558 
 6559         gpres = 0
 6560         grho = grhob_t+grhoc_t+grhor_t+grhog_t+grhov_t
 6561 
 6562 !total perturbations: matter terms first, then add massive nu, de and radiation 
 6563 !  8*pi*a*a*SUM[rho_i*clx_i]
 6564         dgrho = grhob_t*clxb+grhoc_t*clxc 
 6565 !  8*pi*a*a*SUM[(rho_i+p_i)*v_i]
 6566         dgq = grhob_t*vb
 6567                 
 6568         if (CP%Num_Nu_Massive > 0) then
 6569            call MassiveNuVars(EV,ay,a,grho,gpres,dgrho,dgq, wnu_arr)
 6570         end if
 6571         
 6572         if (CP%flat) then
 6573          adotoa = sqrt(grho/3)
 6574          cothxor = 1/tau
 6575         else
 6576          adotoa = sqrt((grho+grhok)/3)
 6577          cothxor = 1/tanfunc(tau/CP%r)/CP%r
 6578         end if
 6579          
 6580         if (w_lam /= -1 .and. w_Perturb) then
 6581            clxq = ay(EV%w_ix) 
 6582            vq = ay(EV%w_ix+1) 
 6583            dgrho = dgrho + clxq*grhov_t
 6584            dgq = dgq + vq*grhov_t*(1+w_lam)
 6585        end if
 6586 
 6587        if (EV%no_nu_multpoles) then
 6588         !RSA approximation of arXiv:1104.2933, dropping opactity terms in the velocity
 6589         !Approximate total density variables with just matter terms
 6590         z = (0.5*dgrho/k + etak)/adotoa 
 6591         dz = -adotoa*z - 0.5*dgrho/k
 6592         clxr = -4*dz/k
 6593         qr = -4/3*z
 6594         pir = 0
 6595        else
 6596 !  Massless neutrinos
 6597         clxr = ay(EV%r_ix)
 6598         qr  = ay(EV%r_ix+1)
 6599         pir = ay(EV%r_ix+2)
 6600        endif
 6601         
 6602        if (EV%no_phot_multpoles) then
 6603          if (.not. EV%no_nu_multpoles) then
 6604           z = (0.5*dgrho/k + etak)/adotoa 
 6605           dz = -adotoa*z - 0.5*dgrho/k
 6606           clxg = -4*dz/k-4/k*opacity*(vb+z)
 6607           qg = -4/3*z
 6608          else
 6609           clxg = clxr-4/k*opacity*(vb+z)
 6610           qg = qr          
 6611          end if
 6612          pig = 0    
 6613        else
 6614 !  Photons
 6615         clxg = ay(EV%g_ix)
 6616         qg = ay(EV%g_ix+1)
 6617         if (.not. EV%TightCoupling) pig = ay(EV%g_ix+2)
 6618        end if
 6619 
 6620 !  8*pi*a*a*SUM[rho_i*clx_i] - radiation terms
 6621         dgrho = dgrho + grhog_t*clxg+grhor_t*clxr 
 6622        
 6623 !  8*pi*a*a*SUM[(rho_i+p_i)*v_i]
 6624         dgq = dgq + grhog_t*qg+grhor_t*qr
 6625 
 6626 
 6627 !  Photon mass density over baryon mass density
 6628         photbar = grhog_t/grhob_t
 6629         pb43 = 4/3*photbar
 6630         
 6631         ayprime(1) = adotoa*a
 6632 
 6633 
 6634 !  Get sigma (shear) and z from the constraints
 6635 ! have to get z from eta for numerical stability
 6636         z = (0.5*dgrho/k + etak)/adotoa 
 6637         if (CP%flat) then
 6638  !eta*k equation
 6639          sigma = (z+1.5*dgq/k2)
 6640          ayprime(2) = 0.5*dgq
 6641         else
 6642          sigma = (z+1.5*dgq/k2)/EV%Kf(1)
 6643          ayprime(2) = 0.5*dgq + CP%curv*z
 6644         end if
 6645         
 6646         if (w_lam /= -1 .and. w_Perturb) then
 6647 
 6648            ayprime(EV%w_ix) = -3*adotoa*(cs2_lam-w_lam)*(clxq+3*adotoa*(1+w_lam)*vq/k) &
 6649                -(1+w_lam)*k*vq -(1+w_lam)*k*z
 6650 
 6651            ayprime(EV%w_ix+1) = -adotoa*(1-3*cs2_lam)*vq + k*cs2_lam*clxq/(1+w_lam)
 6652 
 6653         end if
 6654 
 6655 !  CDM equation of motion
 6656         clxcdot = -k*z
 6657         ayprime(3) = clxcdot
 6658 
 6659 !  Baryon equation of motion.
 6660         clxbdot = -k*(z+vb)
 6661         ayprime(4) = clxbdot
 6662 !  Photon equation of motion
 6663         clxgdot = -k*(4/3*z+qg)
 6664 
 6665 ! old comment:Small k: potential problem with stability, using full equations earlier is NOT more accurate in general
 6666 ! Easy to see instability in k \sim 1e-3 by tracking evolution of vb
 6667 
 6668 !  Use explicit equation for vb if appropriate
 6669 
 6670          if (EV%TightCoupling) then
 6671    
 6672            !  ddota/a
 6673             gpres = gpres+ (grhog_t+grhor_t)/3 +grhov_t*w_lam
 6674             adotdota = (adotoa*adotoa-gpres)/2
 6675 
 6676             pig = 32/45/opacity*k*(sigma+vb)
 6677 
 6678     !  First-order approximation to baryon-photon splip
 6679              slip = - (2*adotoa/(1+pb43) + dopacity/opacity)* (vb-3/4*qg) &
 6680              +(-adotdota*vb-k/2*adotoa*clxg +k*(cs2*clxbdot-clxgdot/4))/(opacity*(1+pb43))
 6681             
 6682             if (second_order_tightcoupling) then
 6683             ! by Francis-Yan Cyr-Racine simplified (inconsistently) by AL assuming flat
 6684             !AL: First order slip seems to be fine here to 2e-4
 6685 
 6686              !  8*pi*G*a*a*SUM[rho_i*sigma_i]
 6687              dgs = grhog_t*pig+grhor_t*pir
 6688 
 6689              ! Define shear derivative to first order
 6690              sigmadot = -2*adotoa*sigma-dgs/k+etak
 6691 
 6692              !Once know slip, recompute qgdot, pig, pigdot
 6693              qgdot = k*(clxg/4-pig/2) +opacity*slip 
 6694 
 6695              pig = 32/45/opacity*k*(sigma+3*qg/4)*(1+(dopacity*11/6/opacity**2)) &
 6696                  + (32/45/opacity**2)*k*(sigmadot+3*qgdot/4)*(-11/6)
 6697 
 6698              pigdot = -(32/45)*(dopacity/opacity**2)*k*(sigma+3*qg/4)*(1 + &
 6699                  dopacity*11/6/opacity**2 ) &
 6700                  + (32/45/opacity)*k*(sigmadot+3*qgdot/4)*(1+(11/6) &
 6701                  *(dopacity/opacity**2))
 6702 
 6703              EV%pigdot = pigdot
 6704    
 6705             end if
 6706 
 6707     !  Use tight-coupling approximation for vb
 6708     !  zeroth order approximation to vbdot + the pig term
 6709             vbdot = (-adotoa*vb+cs2*k*clxb  &
 6710                  +k/4*pb43*(clxg-2*EV%Kf(1)*pig))/(1+pb43)
 6711 
 6712             vbdot = vbdot+pb43/(1+pb43)*slip
 6713 
 6714             EV%pig = pig
 6715 
 6716         else
 6717             vbdot = -adotoa*vb+cs2*k*clxb-photbar*opacity*(4/3*vb-qg)
 6718         end if
 6719 
 6720         ayprime(5) = vbdot
 6721     
 6722      if (.not. EV%no_phot_multpoles) then
 6723 
 6724  !  Photon equations of motion
 6725         ayprime(EV%g_ix) = clxgdot
 6726         qgdot = 4/3*(-vbdot-adotoa*vb+cs2*k*clxb)/pb43 &
 6727              +EV%denlk(1)*clxg-EV%denlk2(1)*pig  
 6728         ayprime(EV%g_ix+1) = qgdot
 6729         
 6730 !  Use explicit equations for photon moments if appropriate       
 6731         if (.not. EV%tightcoupling) then
 6732 
 6733             E2 = ay(EV%polind+2)
 6734             polter = pig/10+9/15*E2 !2/15*(3/4 pig + 9/2 E2)
 6735             ix = EV%g_ix+2
 6736             if (EV%lmaxg>2) then 
 6737               pigdot = EV%denlk(2)*qg-EV%denlk2(2)*ay(ix+1)-opacity*(pig - polter) &
 6738                    +8/15*k*sigma
 6739               ayprime(ix) = pigdot
 6740               do  l = 3,EV%lmaxg-1
 6741                 ix = ix+1
 6742                 ayprime(ix) = (EV%denlk(l)*ay(ix-1)-EV%denlk2(l)*ay(ix+1))-opacity*ay(ix)
 6743               end do
 6744              ix = ix+1
 6745           !  Truncate the photon moment expansion
 6746              ayprime(ix) = k*ay(ix-1)-(EV%lmaxg+1)*cothxor*ay(ix) -opacity*ay(ix)
 6747             else !closed case
 6748               pigdot = EV%denlk(2)*qg-opacity*(pig - polter) +8/15*k*sigma
 6749               ayprime(ix) = pigdot
 6750             endif 
 6751 !  Polarization
 6752             !l = 2 
 6753             ix = EV%polind+2
 6754             if (EV%lmaxgpol>2) then
 6755               ayprime(ix) = -opacity*(ay(ix) - polter) - k/3*ay(ix+1)
 6756               do l = 3,EV%lmaxgpol-1
 6757                ix = ix+1
 6758                ayprime(ix) = -opacity*ay(ix) + (EV%denlk(l)*ay(ix-1)-EV%polfack(l)*ay(ix+1))
 6759               end do  
 6760               ix = ix+1
 6761               !truncate
 6762               ayprime(ix) = -opacity*ay(ix) + &
 6763                 k*EV%poltruncfac*ay(ix-1)-(EV%lmaxgpol+3)*cothxor*ay(ix)
 6764            else !closed case
 6765               ayprime(ix) = -opacity*(ay(ix) - polter) 
 6766            endif
 6767          end if
 6768         end if
 6769 
 6770         if (.not. EV%no_nu_multpoles) then
 6771    
 6772 !  Massless neutrino equations of motion.
 6773         clxrdot = -k*(4/3*z+qr)
 6774         ayprime(EV%r_ix) = clxrdot
 6775         qrdot = EV%denlk(1)*clxr-EV%denlk2(1)*pir
 6776         ayprime(EV%r_ix+1) = qrdot              
 6777         if (EV%high_ktau_neutrino_approx) then
 6778         
 6779           !ufa approximation for k*tau>>1, more accurate when there are reflections from lmax
 6780           !Method from arXiv:1104.2933
 6781 !                if (.not. EV%TightCoupling) then
 6782 !                 gpres = gpres+ (grhog_t+grhor_t)/3 +grhov_t*w_lam
 6783 !                 adotdota = (adotoa*adotoa-gpres)/2
 6784 !                end if
 6785 !                ddz = (2*adotoa**2 - adotdota)*z  & 
 6786 !                  + adotoa/(2*k)*( 6*(grhog_t*clxg+grhor_t*clxr) + 2*(grhoc_t*clxc+grhob_t*clxb) ) &
 6787 !                   - 1/(2*k)*( 2*(grhog_t*clxgdot+grhor_t*clxrdot) + grhoc_t*clxcdot + grhob_t*clxbdot ) 
 6788 !                dz = -adotoa*z - 0.5*dgrho/k
 6789 !                pirdot = -3*pir*cothxor + k*(qr+4/3*z) 
 6790                  pirdot = -3*pir*cothxor - clxrdot 
 6791                  ayprime(EV%r_ix+2) = pirdot
 6792             
 6793 !                pirdot = k*(0.4*qr-0.6*ay(EV%lmaxg+10)+8/15*sigma)
 6794 !                ayprime(EV%lmaxg+9) = pirdot
 6795 !                ayprime(3+EV%lmaxg+7) = k*ay(3+EV%lmaxg+6)- &
 6796 !                                      (3+1)*cothxor*ay(3+EV%lmaxg+7)
 6797 !               ayprime(3+EV%lmaxg+7+1:EV%lmaxnr+EV%lmaxg+7) = 0
 6798            else
 6799                 ix = EV%r_ix+2
 6800                 if (EV%lmaxnr>2) then
 6801                  pirdot = EV%denlk(2)*qr- EV%denlk2(2)*ay(ix+1)+8/15*k*sigma
 6802                  ayprime(ix) = pirdot
 6803                  do l = 3,EV%lmaxnr-1
 6804                    ix = ix+1
 6805                    ayprime(ix) = (EV%denlk(l)*ay(ix-1) - EV%denlk2(l)*ay(ix+1)) 
 6806                  end do   
 6807             !  Truncate the neutrino expansion
 6808                  ix = ix+1
 6809                  ayprime(ix) = k*ay(ix-1)- (EV%lmaxnr+1)*cothxor*ay(ix)
 6810                 else
 6811                  pirdot = EV%denlk(2)*qr +8/15*k*sigma
 6812                  ayprime(ix) = pirdot
 6813                 end if
 6814          end if     
 6815         end if ! no_nu_multpoles
 6816 
 6817 !  Massive neutrino equations of motion.
 6818          if (CP%Num_Nu_massive = 0) return
 6819           
 6820           do nu_i = 1, CP%Nu_mass_eigenstates
 6821           if (EV%MassiveNuApprox(nu_i)) then
 6822              !Now EV%iq0 = clx, EV%iq0+1 = clxp, EV%iq0+2 = G_1, EV%iq0+3 = G_2 = pinu
 6823              !see astro-ph/0203507
 6824              G11_t = EV%G11(nu_i)/a/a2 
 6825              G30_t = EV%G30(nu_i)/a/a2
 6826              off_ix = EV%nu_ix(nu_i)
 6827              w = wnu_arr(nu_i)
 6828              ayprime(off_ix) = -k*z*(w+1) + 3*adotoa*(w*ay(off_ix) - ay(off_ix+1))-k*ay(off_ix+2)
 6829              ayprime(off_ix+1) = (3*w-2)*adotoa*ay(off_ix+1) - 5/3*k*z*w - k/3*G11_t
 6830              ayprime(off_ix+2) = (3*w-1)*adotoa*ay(off_ix+2) - k*(2/3*EV%Kf(1)*ay(off_ix+3)-ay(off_ix+1))
 6831              ayprime(off_ix+3) = (3*w-2)*adotoa*ay(off_ix+3) + 2*w*k*sigma - k/5*(3*EV%Kf(2)*G30_t-2*G11_t)
 6832      
 6833           else
 6834    
 6835               ind = EV%nu_ix(nu_i)
 6836               do i = 1,EV%nq(nu_i)
 6837                q = nu_q(i)
 6838                aq = a*nu_masses(nu_i)/q
 6839                v = 1/sqrt(1+aq*aq)
 6840 
 6841                ayprime(ind) = -k*(4/3*z + v*ay(ind+1))
 6842                ind = ind+1
 6843                ayprime(ind) = v*(EV%denlk(1)*ay(ind-1)-EV%denlk2(1)*ay(ind+1))
 6844                ind = ind+1
 6845                if (EV%lmaxnu_tau(nu_i) = 2) then
 6846                  ayprime(ind) = -ayprime(ind-2) -3*cothxor*ay(ind)
 6847                else
 6848                  ayprime(ind) = v*(EV%denlk(2)*ay(ind-1)-EV%denlk2(2)*ay(ind+1)) &
 6849                       +k*8/15*sigma
 6850                  do l = 3,EV%lmaxnu_tau(nu_i)-1
 6851                    ind = ind+1
 6852                    ayprime(ind) = v*(EV%denlk(l)*ay(ind-1)-EV%denlk2(l)*ay(ind+1))
 6853                  end do
 6854                !  Truncate moment expansion.
 6855                  ind = ind+1
 6856                  ayprime(ind) = k*v*ay(ind-1)-(EV%lmaxnu_tau(nu_i)+1)*cothxor*ay(ind)
 6857                end if
 6858                ind = ind+1                 
 6859               end do
 6860  
 6861           end if
 6862           end do
 6863 
 6864           if (EV%has_nu_relativistic) then
 6865            ind = EV%nu_pert_ix
 6866            ayprime(ind) = +k*a2*qr -k*ay(ind+1)  
 6867            ind2 = EV%r_ix
 6868            do l = 1,EV%lmaxnu_pert-1
 6869             ind = ind+1
 6870             ind2 = ind2+1
 6871             ayprime(ind) = -a2*(EV%denlk(l)*ay(ind2-1)-EV%denlk2(l)*ay(ind2+1)) &
 6872                           +   (EV%denlk(l)*ay(ind-1)-EV%denlk2(l)*ay(ind+1))
 6873            end do
 6874             ind = ind+1
 6875             ind2 = ind2+1
 6876             ayprime(ind) = k*(ay(ind-1) -a2*ay(ind2-1)) -(EV%lmaxnu_pert+1)*cothxor*ay(ind)
 6877           end if
 6878           
 6879         end subroutine derivs
 6880 
 6881      
 6882 
 6883         subroutine derivsv(EV,n,tau,yv,yvprime)
 6884 !  Evaluate the time derivatives of the vector perturbations, flat case
 6885         use ThermoData
 6886         use MassiveNu
 6887         implicit none      
 6888         type(EvolutionVars) EV
 6889         integer n,l
 6890         real(dl), target ::  yv(n),yvprime(n)
 6891         real(dl) ep,tau,grho,rhopi,cs2,opacity,gpres
 6892         logical finished_tightcoupling
 6893         real(dl), dimension(:),pointer :: neut,neutprime,E,B,Eprime,Bprime
 6894         real(dl)  grhob_t,grhor_t,grhoc_t,grhog_t,grhov_t,polter
 6895         real(dl) sigma, qg,pig, qr, vb, rhoq, vbdot, photbar, pb43
 6896         real(dl) k,k2,a,a2, adotdota
 6897         real(dl) pir,adotoa  
 6898    
 6899          k2 = EV%k2_buf
 6900          k = EV%k_buf       
 6901 
 6902         !E and B start at l = 2. Set up pointers accordingly to fill in y arrays
 6903         E = > yv(EV%lmaxv+3:)
 6904         Eprime = > yvprime(EV%lmaxv+3:) 
 6905         B = > E(EV%lmaxpolv:)
 6906         Bprime = > Eprime(EV%lmaxpolv:)
 6907         neutprime = > Bprime(EV%lmaxpolv+1:)
 6908         neut = > B(EV%lmaxpolv+1:)
 6909             
 6910         a = yv(1)        
 6911 
 6912         sigma = yv(2)
 6913 
 6914         a2 = a*a
 6915 
 6916 !  Get sound speed and opacity, and see if should use tight-coupling
 6917              
 6918         call thermo(tau,cs2,opacity)
 6919         if (k > 0.06*epsw) then
 6920            ep = ep0
 6921         else
 6922            ep = 0.2*ep0
 6923         end if
 6924    
 6925         finished_tightcoupling = &
 6926          ((k/opacity > ep).or.(1/(opacity*tau) > ep .and. k/opacity > 1d-4)) 
 6927 
 6928 
 6929 ! Compute expansion rate from: grho = 8*pi*rho*a**2
 6930 ! Also calculate gpres: 8*pi*p*a**2
 6931         grhob_t = grhob/a
 6932         grhoc_t = grhoc/a
 6933         grhor_t = grhornomass/a2
 6934         grhog_t = grhog/a2
 6935         grhov_t = grhov*a**(-1-3*w_lam)
 6936 
 6937         grho = grhob_t+grhoc_t+grhor_t+grhog_t+grhov_t
 6938         gpres = (grhog_t+grhor_t)/3+grhov_t*w_lam 
 6939 
 6940         adotoa = sqrt(grho/3)
 6941         adotdota = (adotoa*adotoa-gpres)/2
 6942 
 6943         photbar = grhog_t/grhob_t
 6944         pb43 = 4/3*photbar
 6945        
 6946         yvprime(1) = adotoa*a
 6947      
 6948         vb = yv(3)
 6949         qg = yv(4)         
 6950         qr = neut(1)
 6951 
 6952 !  8*pi*a*a*SUM[(rho_i+p_i)*v_i]
 6953         rhoq = grhob_t*vb+grhog_t*qg+grhor_t*qr
 6954      !  sigma = 2*rhoq/k**2
 6955         !for non-large k this expression for sigma is unstable at early times
 6956         !so propagate sigma equation separately (near total cancellation in rhoq)
 6957         ! print *,yv(2),2*rhoq/k**2
 6958 
 6959         if (finished_tightcoupling) then
 6960 !  Use explicit equations:
 6961 
 6962         pig = yv(5) 
 6963 
 6964         polter = 0.1*pig + 9/15*E(2)
 6965 
 6966         vbdot = -adotoa*vb-photbar*opacity*(4/3*vb-qg) - 0.5*k*photbar*Magnetic
 6967 
 6968 !  Equation for the photon heat flux stress
 6969   
 6970          yvprime(4) = -0.5*k*pig + opacity*(4/3*vb-qg) 
 6971       
 6972 !  Equation for the photon anisotropic stress
 6973         yvprime(5) = k*(2/5*qg -8/15*yv(6))+8/15*k*sigma  &
 6974                   -opacity*(pig - polter)
 6975 ! And for the moments            
 6976         do  l = 3,EV%lmaxv-1
 6977            yvprime(l+3) = k*denl(l)*l*(yv(l+2)-   &
 6978                   vecfac(l)*yv(l+4))-opacity*yv(l+3)
 6979         end do
 6980 !  Truncate the hierarchy
 6981         yvprime(EV%lmaxv+3) = k*EV%lmaxv/(EV%lmaxv-1)*yv(EV%lmaxv+2)- &
 6982                        (EV%lmaxv+2)*yv(EV%lmaxv+3)/tau-opacity*yv(EV%lmaxv+3)
 6983      
 6984 !E equations
 6985    
 6986         Eprime(2) = - opacity*(E(2) - polter) + k*(1/3*B(2) - &
 6987                         8/27*E(3))
 6988         do l = 3,EV%lmaxpolv-1
 6989         Eprime(l) = -opacity*E(l) + k*(denl(l)*(l*E(l-1) - &
 6990                         vecfacpol(l)*E(l+1)) + 2/(l*(l+1))*B(l))
 6991         end do
 6992 !truncate
 6993         Eprime(EV%lmaxpolv) = 0
 6994                 
 6995 !B-bar equations
 6996         
 6997         do l = 2,EV%lmaxpolv-1
 6998         Bprime(l) = -opacity*B(l) + k*(denl(l)*(l*B(l-1) - &
 6999                         vecfacpol(l)*B(l+1)) - 2/(l*(l+1))*E(l))
 7000         end do
 7001 !truncate
 7002         Bprime(EV%lmaxpolv) = 0
 7003 
 7004        else
 7005 
 7006 !Tight coupling expansion results
 7007 
 7008         pig = 32/45*k/opacity*(vb + sigma)
 7009 
 7010         EV%pig = pig
 7011 
 7012         vbdot = (-adotoa*vb  -3/8*pb43*k*Magnetic  -3/8*k*pb43*pig &
 7013                 - pb43/(1+pb43)/opacity*(0.75*k*adotoa*pb43**2/(pb43+1)*Magnetic + vb*&
 7014               ( 2*pb43*adotoa**2/(1+pb43) + adotdota)) &
 7015                   )/(1+pb43) 
 7016 
 7017 !  Equation for the photon heat flux
 7018 ! Get drag from vbdot expression 
 7019         yvprime(4) = -0.5*k*pig - &
 7020            (vbdot+adotoa*vb)/photbar - 0.5*k*Magnetic
 7021 
 7022 !  Set the derivatives to zero
 7023         yvprime(5:n) = 0
 7024         yv(5) = pig
 7025         E(2) =  pig/4 
 7026         
 7027         endif
 7028  
 7029         yvprime(3) = vbdot
 7030 
 7031 !  Neutrino equations: 
 7032                
 7033 !  Massless neutrino anisotropic stress
 7034         pir = neut(2)
 7035         neutprime(1) = -0.5*k*pir
 7036         neutprime(2) = 2/5*k*qr -8/15*k*neut(3)+ 8/15*k*sigma
 7037 !  And for the moments
 7038         do  l = 3,EV%lmaxnrv-1
 7039            neutprime(l) = k*denl(l)*l*(neut(l-1)- vecfac(l)*neut(l+1))
 7040         end do
 7041         
 7042 !  Truncate the hierarchy
 7043         neutprime(EV%lmaxnrv) = k*EV%lmaxnrv/(EV%lmaxnrv-1)*neut(EV%lmaxnrv-1)-  &
 7044                        (EV%lmaxnrv+2)*neut(EV%lmaxnrv)/tau
 7045 
 7046     
 7047 !  Get the propagation equation for the shear
 7048             
 7049         rhopi = grhog_t*pig+grhor_t*pir+ grhog_t*Magnetic
 7050                       
 7051         yvprime(2) = -2*adotoa*sigma -rhopi/k
 7052 
 7053        end subroutine derivsv
 7054 
 7055 
 7056 
 7057 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
 7058         subroutine derivst(EV,n,tau,ayt,aytprime)
 7059 !  Evaluate the time derivatives of the tensor perturbations.
 7060         use ThermoData
 7061         use MassiveNu
 7062         implicit none      
 7063         type(EvolutionVars) EV
 7064         integer n,l,i,ind, nu_i
 7065         real(dl), target ::  ayt(n),aytprime(n)
 7066         real(dl) tau,grho,rhopi,cs2,opacity,pirdt
 7067         real(dl), dimension(:),pointer :: neut,neutprime,E,B,Eprime,Bprime
 7068         real(dl) q,aq,v
 7069         real(dl)  grhob_t,grhor_t,grhoc_t,grhog_t,grhov_t,polter
 7070         real(dl) Hchi,pinu, pig
 7071         real(dl) k,k2,a,a2
 7072         real(dl) pir, adotoa, rhonu, shear
 7073 
 7074         real(dl) cothxor
 7075       
 7076         k2 = EV%k2_buf
 7077         k = EV%k_buf   
 7078 
 7079         a = ayt(1)        
 7080 
 7081         Hchi = ayt(2)  
 7082 
 7083         shear = ayt(3)
 7084 
 7085         a2 = a*a
 7086   
 7087 ! Compute expansion rate from: grho = 8*pi*rho*a**2
 7088 ! Also calculate gpres: 8*pi*p*a**2
 7089         grhob_t = grhob/a
 7090         grhoc_t = grhoc/a
 7091         grhor_t = grhornomass/a2
 7092         grhog_t = grhog/a2
 7093         if (w_lam = -1) then
 7094          grhov_t = grhov*a2       
 7095         else
 7096          grhov_t = grhov*a**(-1-3*w_lam)
 7097         end if
 7098         
 7099         grho = grhob_t+grhoc_t+grhor_t+grhog_t+grhov_t
 7100      
 7101 !Do massive neutrinos
 7102         if (CP%Num_Nu_Massive >0) then
 7103          do nu_i = 1,CP%Nu_mass_eigenstates
 7104            call Nu_rho(a*nu_masses(nu_i),rhonu)
 7105            grho = grho+grhormass(nu_i)*rhonu/a2
 7106          end do
 7107         end if
 7108 
 7109         if (CP%flat) then
 7110          cothxor = 1/tau  
 7111          adotoa = sqrt(grho/3)
 7112         else
 7113          cothxor = 1/tanfunc(tau/CP%r)/CP%r  
 7114          adotoa = sqrt((grho+grhok)/3)
 7115         end if
 7116 
 7117         aytprime(1) = adotoa*a
 7118 
 7119         call thermo(tau,cs2,opacity)
 7120 
 7121         if (.not. EV%TensTightCoupling) then
 7122 !  Don't use tight coupling approx - use explicit equations:
 7123 !  Equation for the photon anisotropic stress
 7124 
 7125 
 7126         !E and B start at l = 2. Set up pointers accordingly to fill in ayt arrays
 7127         E = > ayt(EV%E_ix+1:)   
 7128         B = > ayt(EV%B_ix+1:)  
 7129         Eprime = > aytprime(EV%E_ix+1:) 
 7130         Bprime = > aytprime(EV%B_ix+1:)
 7131 
 7132         ind = EV%g_ix+2
 7133 
 7134         !  Photon anisotropic stress
 7135         pig = ayt(ind)
 7136         polter = 0.1*pig + 9/15*E(2)
 7137 
 7138         if (EV%lmaxt > 2) then
 7139          
 7140         aytprime(ind) = -EV%denlkt(2,2)*ayt(ind+1)+k*8/15*shear  &
 7141                   -opacity*(pig - polter)
 7142 
 7143         do l = 3, EV%lmaxt -1
 7144          ind = ind+1
 7145          aytprime(ind) = EV%denlkt(1,L)*ayt(ind-1)-EV%denlkt(2,L)*ayt(ind+1)-opacity*ayt(ind)
 7146         end do
 7147 
 7148         !Truncate the hierarchy 
 7149         ind = ind+1
 7150         aytprime(ind) = k*EV%lmaxt/(EV%lmaxt-2)*ayt(ind-1)- &
 7151                        (EV%lmaxt+3)*cothxor*ayt(ind)-opacity*ayt(ind)
 7152 
 7153 !E and B-bar equations
 7154      
 7155         Eprime(2) = - opacity*(E(2) - polter) + EV%denlkt(4,2)*B(2) - &
 7156                         EV%denlkt(3,2)*E(3)
 7157         
 7158         do l = 3, EV%lmaxpolt-1
 7159                        
 7160            Eprime(l) = (EV%denlkt(1,L)*E(l-1)-EV%denlkt(3,L)*E(l+1) + EV%denlkt(4,L)*B(l)) &
 7161                           -opacity*E(l) 
 7162    
 7163         end do
 7164         l = EV%lmaxpolt
 7165 !truncate: difficult, but setting l+1 to zero seems to work OK
 7166         Eprime(l) = (EV%denlkt(1,L)*E(l-1) + EV%denlkt(4,L)*B(l)) -opacity*E(l) 
 7167                     
 7168         Bprime(2) = -EV%denlkt(3,2)*B(3) - EV%denlkt(4,2)*E(2)  -opacity*B(2)
 7169         do l = 3, EV%lmaxpolt-1
 7170         Bprime(l) = (EV%denlkt(1,L)*B(l-1) -EV%denlkt(3,L)*B(l+1) - EV%denlkt(4,L)*E(l)) &
 7171                          -opacity*B(l)
 7172         end do
 7173         l = EV%lmaxpolt 
 7174 !truncate
 7175         Bprime(l) = (EV%denlkt(1,L)*B(l-1) - EV%denlkt(4,L)*E(l))  -opacity*B(l)
 7176 
 7177         else !lmax = 2
 7178         
 7179          aytprime(ind) = k*8/15*shear-opacity*(pig - polter) 
 7180          Eprime(2) = - opacity*(E(2) - polter) + EV%denlkt(4,2)*B(2)
 7181          Bprime(2) = - EV%denlkt(4,2)*E(2)  -opacity*B(2)
 7182         
 7183         end if     
 7184 
 7185         else  !Tight coupling
 7186          pig = 32/45*k/opacity*shear
 7187         
 7188         endif
 7189       
 7190       rhopi = grhog_t*pig 
 7191 
 7192 
 7193 !  Neutrino equations: 
 7194 !  Anisotropic stress
 7195         if (DoTensorNeutrinos) then
 7196         
 7197         neutprime = > aytprime(EV%r_ix+1:)
 7198         neut = > ayt(EV%r_ix+1:)
 7199        
 7200 !  Massless neutrino anisotropic stress
 7201         pir = neut(2)
 7202 
 7203         rhopi = rhopi+grhor_t*pir
 7204  
 7205         if (EV%lmaxnrt>2) then   
 7206         pirdt = -EV%denlkt(2,2)*neut(3) + 8/15*k*shear
 7207         neutprime(2) = pirdt
 7208 !  And for the moments
 7209         do  l = 3, EV%lmaxnrt-1
 7210            neutprime(l) = EV%denlkt(1,L)*neut(l-1) -EV%denlkt(2,L)*neut(l+1)
 7211         end do
 7212         
 7213 !  Truncate the hierarchy
 7214         neutprime(EV%lmaxnrt) = k*EV%lmaxnrt/(EV%lmaxnrt-2)*neut(EV%lmaxnrt-1)-  &
 7215                        (EV%lmaxnrt+3)*cothxor*neut(EV%lmaxnrt)
 7216 
 7217         else
 7218          pirdt = 8/15*k*shear
 7219          neutprime(2) = pirdt
 7220         end if
 7221 
 7222          !  Massive neutrino equations of motion and contributions to anisotropic stress.
 7223          if (CP%Num_Nu_massive > 0) then
 7224           
 7225           do nu_i = 1,CP%Nu_mass_eigenstates
 7226             if (.not. EV%EvolveTensorMassiveNu(nu_i)) then
 7227               rhopi = rhopi+ grhormass(nu_i)/a2*pir !- good approx, note no rhonu weighting  
 7228             else
 7229               ind = EV%nu_ix(nu_i)+2
 7230               
 7231               pinu = Nu_pi(EV, ayt(ind),a, nu_i)                 
 7232               rhopi = rhopi+ grhormass(nu_i)/a2*pinu   
 7233          
 7234               do i = 1,nqmax
 7235                 q = nu_q(i)
 7236                 aq = a*nu_masses(nu_i)/q
 7237                 v = 1/sqrt(1+aq*aq)
 7238                 if (EV%lmaxnut>2) then
 7239                  aytprime(ind) = -v*EV%denlkt(2,2)*ayt(ind+1)+8/15*k*shear
 7240                  do l = 3,EV%lmaxnut-1
 7241                   ind = ind+1
 7242                   aytprime(ind) = v*(EV%denlkt(1,L)*ayt(ind-1)-EV%denlkt(2,L)*ayt(ind+1))     
 7243                  end do
 7244                  ind = ind+1
 7245                 !Truncate moment expansion.
 7246                  aytprime(ind) = k*v*EV%lmaxnut/(EV%lmaxnut-2)*ayt(ind-1)-(EV%lmaxnut+3)*cothxor*ayt(ind)
 7247                 else
 7248                  aytprime(ind) = 8/15*k*shear
 7249                 end if
 7250                 ind = ind+1
 7251               end do
 7252             end if          
 7253           end do
 7254                       
 7255          end if
 7256         end if
 7257              
 7258 !  Get the propagation equation for the shear
 7259         
 7260         if (CP%flat) then
 7261         aytprime(3) = -2*adotoa*shear+k*Hchi-rhopi/k   
 7262         else
 7263         aytprime(3) = -2*adotoa*shear+k*Hchi*(1+2*CP%curv/k2)-rhopi/k   
 7264         endif  
 7265 
 7266         aytprime(2) = -k*shear
 7267 
 7268         end subroutine derivst
 7269 
 7270 
 7271 
 7272 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 7273 
 7274         end module GaugeInterface
 7275 
 7276 ** halofit.f90
 7277 
 7278 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 7279 ! The `halofit' code models the nonlinear evolution of cold matter 
 7280 ! cosmological power spectra. The full details of the way in which 
 7281 ! this is done are presented in Smith et al. (2002), MNRAS, ?, ?. 
 7282 !
 7283 ! The code `halofit' was written by R. E. Smith & J. A. Peacock. 
 7284 ! See http://www.astro.upenn.edu/~res, 
 7285 ! Last edited 8/5/2002.
 7286 
 7287 ! Only tested for plain LCDM models with power law initial power spectra
 7288 
 7289 ! Adapted for F90 and CAMB, AL March 2005
 7290 !!BR09 Oct 09: generalized expressions for om(z) and ol(z) to include w
 7291 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 7292 
 7293       module NonLinear
 7294       use ModelParams
 7295       use transfer
 7296       use LambdaGeneral
 7297       implicit none 
 7298       private
 7299        
 7300        real, parameter :: Min_kh_nonlinear = 0.005
 7301        real(dl):: om_m,om_v,fnu,omm0
 7302 
 7303       public Min_kh_nonlinear,NonLinear_GetNonLinRatios
 7304       
 7305       contains
 7306 
 7307      subroutine NonLinear_GetNonLinRatios(CAMB_Pk)
 7308      !Fill the CAMB_Pk%nonlin_scaling array with sqrt(non-linear power/linear power)
 7309      !for each redshift and wavenumber
 7310      !This implementation uses Halofit
 7311       type(MatterPowerData) :: CAMB_Pk
 7312       integer itf
 7313       real(dl) a,plin,pq,ph,pnl,rk
 7314       real(dl) sig,rknl,rneff,rncur,d1,d2
 7315       real(dl) diff,xlogr1,xlogr2,rmid
 7316       integer i
 7317 
 7318        !!BR09 putting neutrinos into the matter as well, not sure if this is correct, but at least one will get a consisent omk.
 7319        omm0 = CP%omegac+CP%omegab+CP%omegan
 7320        fnu = CP%omegan/(CP%omegab+CP%omegac)
 7321 
 7322        CAMB_Pk%nonlin_ratio = 1
 7323 
 7324        do itf = 1, CAMB_Pk%num_z
 7325 
 7326 
 7327 ! calculate nonlinear wavenumber (rknl), effective spectral index (rneff) and 
 7328 ! curvature (rncur) of the power spectrum at the desired redshift, using method 
 7329 ! described in Smith et al (2002).
 7330        a = 1/real(1+CAMB_Pk%Redshifts(itf),dl)
 7331        om_m = omega_m(a, omm0, CP%omegav, w_lam)  
 7332        om_v = omega_v(a, omm0, CP%omegav, w_lam)
 7333 
 7334       xlogr1 = -2.0
 7335       xlogr2 = 3.5
 7336       do
 7337           rmid = (xlogr2+xlogr1)/2.0
 7338           rmid = 10**rmid
 7339           call wint(CAMB_Pk,itf,rmid,sig,d1,d2)
 7340           diff = sig-1.0
 7341           if (abs(diff)< = 0.001) then
 7342              rknl = 1./rmid
 7343              rneff = -3-d1
 7344              rncur = -d2                  
 7345              exit
 7346           elseif (diff > 0.001) then
 7347              xlogr1 = log10(rmid)
 7348           elseif (diff < -0.001) then
 7349              xlogr2 = log10(rmid)
 7350           endif
 7351           if (xlogr2 < -1.9999) then
 7352                !is still linear, exit
 7353                goto 101
 7354          end if
 7355       end do
 7356 
 7357 ! now calculate power spectra for a logarithmic range of wavenumbers (rk)
 7358 
 7359       do i = 1, CAMB_PK%num_k
 7360          rk = exp(CAMB_Pk%log_kh(i))
 7361 
 7362          if (rk > Min_kh_nonlinear) then
 7363 
 7364     ! linear power spectrum !! Remeber = > plin = k^3 * P(k) * constant
 7365     ! constant = 4*pi*V/(2*pi)^3 
 7366 
 7367              plin = MatterPowerData_k(CAMB_PK, rk, itf)*(rk**3/(2*pi**2)) 
 7368 
 7369     ! calculate nonlinear power according to halofit: pnl = pq + ph,
 7370     ! where pq represents the quasi-linear (halo-halo) power and 
 7371     ! where ph is represents the self-correlation halo term. 
 7372  
 7373              call halofit(rk,rneff,rncur,rknl,plin,pnl,pq,ph)   ! halo fitting formula 
 7374              CAMB_Pk%nonlin_ratio(i,itf) = sqrt(pnl/plin)
 7375 
 7376          end if
 7377 
 7378       enddo
 7379 
 7380 101   continue
 7381       end do
 7382             
 7383       end subroutine NonLinear_GetNonLinRatios
 7384        
 7385 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 7386 
 7387 ! halo model nonlinear fitting formula as described in 
 7388 ! Appendix C of Smith et al. (2002)
 7389 
 7390       subroutine halofit(rk,rn,rncur,rknl,plin,pnl,pq,ph)
 7391       implicit none
 7392 
 7393       real(dl) extragam,gam,a,b,c,xmu,xnu,alpha,beta,f1,f2,f3
 7394       real(dl) rk,rn,plin,pnl,pq,ph,plinaa
 7395       real(dl) rknl,y,rncur
 7396       real(dl) f1a,f2a,f3a,f1b,f2b,f3b,frac
 7397 
 7398 !SPB11: Standard halofit underestimates the power on the smallest scales by a
 7399 !factor of two. Add an extra correction from the simulations in Bird, Viel,
 7400 !Haehnelt 2011 which partially accounts for this.
 7401       extragam = 0.3159 -0.0765*rn -0.8350*rncur
 7402       gam = extragam+0.86485+0.2989*rn+0.1631*rncur
 7403       a = 1.4861+1.83693*rn+1.67618*rn*rn+0.7940*rn*rn*rn+ &
 7404            0.1670756*rn*rn*rn*rn-0.620695*rncur
 7405       a = 10**a      
 7406       b = 10**(0.9463+0.9466*rn+0.3084*rn*rn-0.940*rncur)
 7407       c = 10**(-0.2807+0.6669*rn+0.3214*rn*rn-0.0793*rncur)
 7408       xmu = 10**(-3.54419+0.19086*rn)
 7409       xnu = 10**(0.95897+1.2857*rn)
 7410       alpha = 1.38848+0.3701*rn-0.1452*rn*rn
 7411       beta = 0.8291+0.9854*rn+0.3400*rn**2+fnu*(-6.4868+1.4373*rn**2)
 7412 
 7413       if(abs(1-om_m) > 0.01) then ! omega evolution 
 7414          f1a = om_m**(-0.0732)
 7415          f2a = om_m**(-0.1423)
 7416          f3a = om_m**(0.0725)
 7417          f1b = om_m**(-0.0307)
 7418          f2b = om_m**(-0.0585)
 7419          f3b = om_m**(0.0743)       
 7420          frac = om_v/(1.-om_m) 
 7421          f1 = frac*f1b + (1-frac)*f1a
 7422          f2 = frac*f2b + (1-frac)*f2a
 7423          f3 = frac*f3b + (1-frac)*f3a
 7424       else         
 7425          f1 = 1.0
 7426          f2 = 1.
 7427          f3 = 1.
 7428       endif
 7429 
 7430       y = (rk/rknl)
 7431 
 7432       ph = a*y**(f1*3)/(1+b*y**(f2)+(f3*c*y)**(3-gam))
 7433       ph = ph/(1+xmu*y**(-1)+xnu*y**(-2))*(1+fnu*(2.080-12.39*(omm0-0.3))/(1+1.201e-03*y**3))
 7434       plinaa = plin*(1+fnu*26.29*rk**2/(1+1.5*rk**2))
 7435       pq = plin*(1+plinaa)**beta/(1+plinaa*alpha)*exp(-y/4.0-y**2/8.0)
 7436 
 7437       pnl = pq+ph
 7438 
 7439       end subroutine halofit       
 7440 
 7441 
 7442 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 7443 
 7444 ! The subroutine wint, finds the effective spectral quantities
 7445 ! rknl, rneff & rncur. This it does by calculating the radius of 
 7446 ! the Gaussian filter at which the variance is unity = rknl.
 7447 ! rneff is defined as the first derivative of the variance, calculated 
 7448 ! at the nonlinear wavenumber and similarly the rncur is the second
 7449 ! derivative at the nonlinear wavenumber. 
 7450 
 7451       subroutine wint(CAMB_Pk,itf,r,sig,d1,d2)
 7452       implicit none
 7453       integer, intent(in) :: itf
 7454       type(MatterPowerData) :: CAMB_Pk
 7455       real(dl) sum1,sum2,sum3,t,y,x,w1,w2,w3
 7456       real(dl) x2,rk, fac,r, sig, d1,d2, anorm
 7457       integer i,nint
 7458 
 7459       nint = 3000
 7460       sum1 = 0
 7461       sum2 = 0
 7462       sum3 = 0
 7463       anorm = 1/(2*pi**2)
 7464       do i = 1,nint
 7465          t = (i-0.5)/nint
 7466          y = -1+1/t
 7467          rk = y
 7468          d2 = MatterPowerData_k(CAMB_PK, rk, itf)*(rk**3*anorm) 
 7469          x = y*r
 7470          x2 = x*x
 7471          w1 = exp(-x2)
 7472          w2 = 2*x2*w1
 7473          w3 = 4*x2*(1-x2)*w1
 7474          fac = d2/y/t/t
 7475          sum1 = sum1+w1*fac
 7476          sum2 = sum2+w2*fac
 7477          sum3 = sum3+w3*fac
 7478       enddo
 7479       sum1 = sum1/nint
 7480       sum2 = sum2/nint
 7481       sum3 = sum3/nint
 7482       sig = sqrt(sum1)
 7483       d1 = -sum2/sum1
 7484       d2 = -sum2*sum2/sum1/sum1 - sum3/sum1
 7485       
 7486       end subroutine wint
 7487       
 7488 !!BR09 generalize to constant w
 7489 
 7490       function omega_m(aa,om_m0,om_v0,wval)
 7491       implicit none
 7492       real(dl) omega_m,omega_t,om_m0,om_v0,aa,wval
 7493       omega_t = 1.0+(om_m0+om_v0-1.0)/(1-om_m0-om_v0+om_v0*((aa)**(-1.0-3.0*wval))+om_m0/aa)
 7494       omega_m = omega_t*om_m0/(om_m0+om_v0*((aa)**(-3.0*wval)))
 7495       end function omega_m
 7496 
 7497 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 7498 
 7499 ! evolution of omega lambda with expansion factor
 7500 
 7501       function omega_v(aa,om_m0,om_v0,wval)      
 7502       implicit none
 7503       real(dl) aa,omega_v,om_m0,om_v0,omega_t,wval
 7504       omega_t = 1.0+(om_m0+om_v0-1.0)/(1-om_m0-om_v0+om_v0*((aa)**(-1.0-3.0*wval))+om_m0/aa)
 7505       omega_v = omega_t*om_v0*((aa)**(-3.0-3.0*wval))/(om_v0*((aa)**(-3.0-3.0*wval))+om_m0/aa/aa/aa)
 7506       end function omega_v
 7507 
 7508 !!BR09 end generalize to constant w
 7509 
 7510 end module NonLinear
 7511 
 7512 
 7513 !workaround for f90 circular-module reference
 7514      subroutine NonLinear_GetRatios(CAMB_Pk)
 7515       use Transfer
 7516       use NonLinear
 7517       type(MatterPowerData) :: CAMB_Pk
 7518 
 7519       call NonLinear_GetNonLinRatios(CAMB_Pk)      
 7520 
 7521      end subroutine NonLinear_GetRatios
 7522      
 7523 
 7524 
 7525      subroutine NonLinear_GetRatios_all(CAMB_Pk)
 7526       use Transfer
 7527       use NonLinear
 7528       type(MatterPowerData) :: CAMB_Pk
 7529 
 7530        stop 'Halofit module doesn''t support non-linear velocities'
 7531 
 7532      end subroutine NonLinear_GetRatios_All
 7533 
 7534 ** inidriver.f90
 7535 
 7536 !     Code for Anisotropies in the Microwave Background
 7537 !     by Antony Lewis (http://cosmologist.info/) and Anthony Challinor
 7538 !     See readme.html for documentation. This is a sample driver routine that reads
 7539 !     in one set of parameters and produdes the corresponding output. 
 7540 
 7541     program driver
 7542         use IniFile
 7543         use CAMB
 7544         use LambdaGeneral
 7545         use Lensing
 7546         use AMLUtils
 7547         use Transfer
 7548         use constants
 7549         use Bispectrum
 7550 !ifdef NAGF95 
 7551         use F90_UNIX
 7552 !endif
 7553         implicit none
 7554       
 7555         Type(CAMBparams) P
 7556         
 7557         character(LEN = Ini_max_string_len) numstr, VectorFileName, &
 7558             InputFile, ScalarFileName, TensorFileName, TotalFileName, LensedFileName,&
 7559             LensedTotFileName, LensPotentialFileName
 7560         integer i
 7561         character(LEN = Ini_max_string_len) TransferFileNames(max_transfer_redshifts), &
 7562                MatterPowerFileNames(max_transfer_redshifts), outroot, version_check
 7563         real(dl) output_factor, Age, nmassive
 7564 
 7565 !ifdef WRITE_FITS
 7566        character(LEN = Ini_max_string_len) FITSfilename
 7567 !endif
 7568 
 7569         logical bad
 7570 
 7571         InputFile = GetParam(1)
 7572         if (InputFile = '') stop 'No parameter input file'
 7573 
 7574         call Ini_Open(InputFile, 1, bad, .false.)
 7575         if (bad) stop 'Error opening parameter file'
 7576 
 7577         Ini_fail_on_not_found = .false.
 7578     
 7579         outroot = Ini_Read_String('output_root')
 7580         if (outroot /= '') outroot = trim(outroot) // '_'
 7581         
 7582         call CAMB_SetDefParams(P)
 7583 
 7584         P%WantScalars = Ini_Read_Logical('get_scalar_cls')
 7585         P%WantVectors = Ini_Read_Logical('get_vector_cls',.false.)
 7586         P%WantTensors = Ini_Read_Logical('get_tensor_cls',.false.)
 7587         
 7588         P%OutputNormalization = outNone
 7589         if (Ini_Read_Logical('COBE_normalize',.false.))  P%OutputNormalization = outCOBE
 7590         output_factor = Ini_Read_Double('CMB_outputscale',1)
 7591 
 7592         P%WantCls = P%WantScalars .or. P%WantTensors .or. P%WantVectors
 7593 
 7594         P%WantTransfer = Ini_Read_Logical('get_transfer')
 7595         
 7596         P%NonLinear = Ini_Read_Int('do_nonlinear',NonLinear_none)
 7597    
 7598         P%DoLensing = .false.
 7599         if (P%WantCls) then
 7600           if (P%WantScalars  .or. P%WantVectors) then
 7601            P%Max_l = Ini_Read_Int('l_max_scalar')
 7602            P%Max_eta_k = Ini_Read_Double('k_eta_max_scalar',P%Max_l*2)
 7603            if (P%WantScalars) then
 7604              P%DoLensing = Ini_Read_Logical('do_lensing',.false.)
 7605              if (P%DoLensing) lensing_method = Ini_Read_Int('lensing_method',1)
 7606            end if
 7607            if (P%WantVectors) then
 7608             if (P%WantScalars .or. P%WantTensors) stop 'Must generate vector modes on their own'
 7609             i = Ini_Read_Int('vector_mode')
 7610             if (i = 0) then 
 7611               vec_sig0 = 1
 7612               Magnetic = 0
 7613             else if (i = 1) then
 7614               Magnetic = -1
 7615               vec_sig0 = 0
 7616             else
 7617               stop 'vector_mode must be 0 (regular) or 1 (magnetic)'
 7618             end if 
 7619            end if
 7620           end if
 7621 
 7622           if (P%WantTensors) then
 7623            P%Max_l_tensor = Ini_Read_Int('l_max_tensor')
 7624            P%Max_eta_k_tensor =  Ini_Read_Double('k_eta_max_tensor',Max(500,P%Max_l_tensor*2))
 7625           end if
 7626         endif
 7627 
 7628                 
 7629 !  Read initial parameters.
 7630        
 7631        w_lam = Ini_Read_Double('w', -1)   
 7632        cs2_lam = Ini_Read_Double('cs2_lam',1)
 7633 
 7634        P%h0     = Ini_Read_Double('hubble')
 7635  
 7636        if (Ini_Read_Logical('use_physical',.false.)) then 
 7637 
 7638         P%omegab = Ini_Read_Double('ombh2')/(P%H0/100)**2
 7639         P%omegac = Ini_Read_Double('omch2')/(P%H0/100)**2
 7640         P%omegan = Ini_Read_Double('omnuh2')/(P%H0/100)**2
 7641         P%omegav = 1- Ini_Read_Double('omk') - P%omegab-P%omegac - P%omegan
 7642   
 7643        else
 7644        
 7645         P%omegab = Ini_Read_Double('omega_baryon')
 7646         P%omegac = Ini_Read_Double('omega_cdm')
 7647         P%omegav = Ini_Read_Double('omega_lambda')
 7648         P%omegan = Ini_Read_Double('omega_neutrino')
 7649 
 7650        end if
 7651 
 7652        P%tcmb   = Ini_Read_Double('temp_cmb',COBE_CMBTemp)
 7653        P%yhe    = Ini_Read_Double('helium_fraction',0.24)
 7654        P%Num_Nu_massless  = Ini_Read_Double('massless_neutrinos')
 7655        nmassive = Ini_Read_Double('massive_neutrinos')
 7656        !Store fractional numbers in the massless total
 7657        P%Num_Nu_massive   = int(nmassive+1e-6)
 7658        P%Num_Nu_massless  = P%Num_Nu_massless + nmassive-P%Num_Nu_massive
 7659    
 7660        P%nu_mass_splittings = .true.
 7661        P%Nu_mass_eigenstates = Ini_Read_Int('nu_mass_eigenstates',1)
 7662        if (P%Nu_mass_eigenstates > max_nu) stop 'too many mass eigenstates'
 7663        numstr = Ini_Read_String('nu_mass_degeneracies')
 7664        if (numstr = '') then
 7665          P%Nu_mass_degeneracies(1) = P%Num_nu_massive
 7666        else
 7667         read(numstr,*) P%Nu_mass_degeneracies(1:P%Nu_mass_eigenstates)
 7668        end if
 7669        numstr = Ini_read_String('nu_mass_fractions')
 7670        if (numstr = '') then
 7671         P%Nu_mass_fractions(1) = 1  
 7672         if (P%Nu_mass_eigenstates >1) stop 'must give nu_mass_fractions for the eigenstates'
 7673        else
 7674         read(numstr,*) P%Nu_mass_fractions(1:P%Nu_mass_eigenstates)
 7675        end if
 7676 
 7677        if (P%NonLinear = NonLinear_lens .and. P%DoLensing) then
 7678           if (P%WantTransfer) &
 7679              write (*,*) 'overriding transfer settings to get non-linear lensing'
 7680           P%WantTransfer  = .true.
 7681           call Transfer_SetForNonlinearLensing(P%Transfer)
 7682           P%Transfer%high_precision =  Ini_Read_Logical('transfer_high_precision',.false.)
 7683        
 7684        else if (P%WantTransfer)  then
 7685         P%Transfer%high_precision =  Ini_Read_Logical('transfer_high_precision',.false.)
 7686         P%transfer%kmax          =  Ini_Read_Double('transfer_kmax')
 7687         P%transfer%k_per_logint  =  Ini_Read_Int('transfer_k_per_logint')
 7688         P%transfer%num_redshifts =  Ini_Read_Int('transfer_num_redshifts')
 7689         
 7690         transfer_interp_matterpower = Ini_Read_Logical('transfer_interp_matterpower ', transfer_interp_matterpower)
 7691         transfer_power_var = Ini_read_int('transfer_power_var',transfer_power_var)
 7692         if (P%transfer%num_redshifts > max_transfer_redshifts) stop 'Too many redshifts'
 7693         do i = 1, P%transfer%num_redshifts
 7694              P%transfer%redshifts(i)  = Ini_Read_Double_Array('transfer_redshift',i,0)
 7695              transferFileNames(i)     = Ini_Read_String_Array('transfer_filename',i)
 7696              MatterPowerFilenames(i)  = Ini_Read_String_Array('transfer_matterpower',i)
 7697              
 7698              if (TransferFileNames(i) = '') then
 7699                  TransferFileNames(i) =  trim(numcat('transfer_',i))//'.dat' 
 7700              end if
 7701              if (MatterPowerFilenames(i) = '') then
 7702                  MatterPowerFilenames(i) =  trim(numcat('matterpower_',i))//'.dat' 
 7703              end if
 7704              if (TransferFileNames(i)/= '') &
 7705                    TransferFileNames(i) = trim(outroot)//TransferFileNames(i)
 7706              if (MatterPowerFilenames(i) /= '') &
 7707                  MatterPowerFilenames(i) = trim(outroot)//MatterPowerFilenames(i)
 7708         end do
 7709 
 7710 
 7711         P%transfer%kmax = P%transfer%kmax*(P%h0/100)
 7712                 
 7713        else
 7714          P%transfer%high_precision = .false.
 7715        endif
 7716   
 7717         Ini_fail_on_not_found = .false. 
 7718   
 7719         call Reionization_ReadParams(P%Reion, DefIni)
 7720         call InitialPower_ReadParams(P%InitPower, DefIni, P%WantTensors) 
 7721         call Recombination_ReadParams(P%Recomb, DefIni)
 7722         if (Ini_HasKey('recombination')) then
 7723          i = Ini_Read_Int('recombination',1)
 7724          if (i/= 1) stop 'recombination option deprecated'
 7725         end if
 7726         
 7727         call Bispectrum_ReadParams(BispectrumParams, DefIni, outroot)
 7728         
 7729         if (P%WantScalars .or. P%WantTransfer) then
 7730             P%Scalar_initial_condition = Ini_Read_Int('initial_condition',initial_adiabatic)
 7731             if (P%Scalar_initial_condition = initial_vector) then
 7732                 P%InitialConditionVector = 0
 7733               numstr = Ini_Read_String('initial_vector',.true.)
 7734               read (numstr,*) P%InitialConditionVector(1:initial_iso_neutrino_vel)
 7735             end if
 7736 
 7737         end if
 7738         
 7739        if (P%WantScalars) then
 7740           ScalarFileName = trim(outroot)//Ini_Read_String('scalar_output_file')
 7741           LensedFileName =  trim(outroot) //Ini_Read_String('lensed_output_file')
 7742           LensPotentialFileName =  Ini_Read_String('lens_potential_output_file')
 7743           if (LensPotentialFileName/= '') LensPotentialFileName = concat(outroot,LensPotentialFileName)
 7744         end if
 7745         if (P%WantTensors) then
 7746           TensorFileName =  trim(outroot) //Ini_Read_String('tensor_output_file')
 7747          if (P%WantScalars)  then
 7748           TotalFileName =  trim(outroot) //Ini_Read_String('total_output_file')
 7749           LensedTotFileName = Ini_Read_String('lensed_total_output_file')
 7750           if (LensedTotFileName/= '') LensedTotFileName = trim(outroot) //trim(LensedTotFileName)
 7751          end if
 7752         end if
 7753         if (P%WantVectors) then
 7754           VectorFileName =  trim(outroot) //Ini_Read_String('vector_output_file')
 7755         end if
 7756          
 7757 !ifdef WRITE_FITS
 7758         if (P%WantCls) then
 7759         FITSfilename =  trim(outroot) //Ini_Read_String('FITS_filename',.true.)
 7760         if (FITSfilename /= '') then
 7761         inquire(file = FITSfilename, exist = bad)
 7762         if (bad) then
 7763          open(unit = 18,file = FITSfilename,status = 'old')
 7764          close(18,status = 'delete')
 7765         end if
 7766        end if
 7767         end if
 7768 !endif        
 7769        
 7770 
 7771        Ini_fail_on_not_found = .false. 
 7772 
 7773 !optional parameters controlling the computation
 7774 
 7775        P%AccuratePolarization = Ini_Read_Logical('accurate_polarization',.true.)
 7776        P%AccurateReionization = Ini_Read_Logical('accurate_reionization',.false.)
 7777        P%AccurateBB = Ini_Read_Logical('accurate_BB',.false.)
 7778  
 7779        version_check = Ini_Read_String('version_check')
 7780        if (version_check = '') then
 7781           !tag the output used parameters .ini file with the version of CAMB being used now
 7782            call TNameValueList_Add(DefIni%ReadValues, 'version_check', version)
 7783        else if (version_check /= version) then
 7784            write(*,*) 'WARNING: version_check does not match this CAMB version'
 7785         end if
 7786        !Mess here to fix typo with backwards compatibility
 7787        if (Ini_HasKey('do_late_rad_trunction')) then
 7788          DoLateRadTruncation = Ini_Read_Logical('do_late_rad_trunction',.true.)
 7789          if (Ini_HasKey('do_late_rad_truncation')) stop 'check do_late_rad_xxxx'
 7790        else
 7791         DoLateRadTruncation = Ini_Read_Logical('do_late_rad_truncation',.true.)
 7792        end if
 7793        DoTensorNeutrinos = Ini_Read_Logical('do_tensor_neutrinos',DoTensorNeutrinos )
 7794        FeedbackLevel = Ini_Read_Int('feedback_level',FeedbackLevel)
 7795        
 7796        P%MassiveNuMethod  = Ini_Read_Int('massive_nu_approx',Nu_best)
 7797 
 7798        ThreadNum      = Ini_Read_Int('number_of_threads',ThreadNum)
 7799        AccuracyBoost  = Ini_Read_Double('accuracy_boost',AccuracyBoost)
 7800        lAccuracyBoost = Ini_Read_Real('l_accuracy_boost',lAccuracyBoost)
 7801        HighAccuracyDefault = Ini_Read_Logical('high_accuracy_default',HighAccuracyDefault)
 7802        use_spline_template = Ini_Read_Logical('use_spline_template',use_spline_template)
 7803        if (HighAccuracyDefault) then
 7804          P%Max_eta_k = max(min(P%max_l,3000)*2.5,P%Max_eta_k)
 7805        end if
 7806        DoTensorNeutrinos = DoTensorNeutrinos .or. HighAccuracyDefault
 7807        if (do_bispectrum) then
 7808         lSampleBoost   = 50
 7809        else
 7810         lSampleBoost   = Ini_Read_Double('l_sample_boost',lSampleBoost)
 7811        end if
 7812        if (outroot /= '') then
 7813          if (InputFile /= trim(outroot) //'params.ini') then   
 7814           call Ini_SaveReadValues(trim(outroot) //'params.ini',1)
 7815          else
 7816           write(*,*) 'Output _params.ini not created as would overwrite input'    
 7817          end if
 7818        end if
 7819 
 7820        call Ini_Close
 7821 
 7822        if (.not. CAMB_ValidateParams(P)) stop 'Stopped due to parameter error'
 7823 
 7824 !ifdef RUNIDLE
 7825        call SetIdle
 7826 !endif 
 7827 
 7828        if (FeedbackLevel > 0) then
 7829          Age = CAMB_GetAge(P) 
 7830          write (*,'("Age of universe/GYr  = ",f7.3)') Age  
 7831        end if 
 7832 
 7833        if (global_error_flag = 0) call CAMB_GetResults(P)
 7834        if (global_error_flag/= 0) then
 7835         write (*,*) 'Error result '//trim(global_error_message)
 7836         stop
 7837        endif
 7838     
 7839         if (P%WantTransfer .and. .not. (P%NonLinear = NonLinear_lens .and. P%DoLensing)) then
 7840          call Transfer_SaveToFiles(MT,TransferFileNames)
 7841          call Transfer_SaveMatterPower(MT,MatterPowerFileNames)
 7842          if ((P%OutputNormalization /= outCOBE) .or. .not. P%WantCls)  call Transfer_output_sig8(MT)
 7843         end if
 7844 
 7845         if (P%WantCls) then
 7846   
 7847          if (P%OutputNormalization = outCOBE) then
 7848 
 7849             if (P%WantTransfer) call Transfer_output_Sig8AndNorm(MT)
 7850            
 7851           end if
 7852 
 7853          call output_cl_files(ScalarFileName, TensorFileName, TotalFileName, &
 7854               LensedFileName, LensedTotFilename, output_factor)
 7855               
 7856          call output_lens_pot_files(LensPotentialFileName, output_factor)
 7857 
 7858          if (P%WantVectors) then
 7859            call output_veccl_files(VectorFileName, output_factor)
 7860          end if
 7861 
 7862 
 7863 !ifdef WRITE_FITS
 7864          if (FITSfilename /= '') call WriteFitsCls(FITSfilename, CP%Max_l)
 7865 !endif
 7866         end if
 7867 
 7868         call CAMB_cleanup             
 7869   
 7870         end program driver
 7871 
 7872 
 7873 !ifdef RUNIDLE
 7874  !If in Windows and want to run with low priorty so can multitask
 7875    subroutine SetIdle
 7876     USE DFWIN
 7877     Integer dwPriority 
 7878     Integer CheckPriority
 7879 
 7880     dwPriority = 64 ! idle priority
 7881     CheckPriority = SetPriorityClass(GetCurrentProcess(), dwPriority)
 7882 
 7883    end subroutine SetIdle
 7884 !endif
 7885 
 7886 ** inifile.txt
 7887 
 7888 !Module to read in name/value pairs from a file, with each line of the form line 'name = value'
 7889 !Should correctly interpret FITS headers
 7890 !Antony Lewis (http://cosmologist.info/). Released to the public domain.
 7891 !This version Apr 11, added support for INCLUDE(file); check for duplicate keys
 7892 
 7893 module IniFile
 7894  implicit none
 7895  public
 7896 
 7897   integer, parameter :: Ini_max_name_len = 128
 7898 
 7899   integer, parameter :: Ini_max_string_len = 1024
 7900   logical :: Ini_fail_on_not_found = .false.
 7901 
 7902   logical :: Ini_Echo_Read = .false.
 7903 
 7904   logical :: Ini_AllowDuplicateKeys = .false.
 7905 
 7906   type TNameValue
 7907    !no known way to make character string pointers..
 7908     character(Ini_max_name_len)  :: Name
 7909     character(Ini_max_string_len):: Value
 7910   end type TNameValue
 7911 
 7912   type TNameValue_pointer
 7913      Type(TNameValue), pointer :: P
 7914   end type TNameValue_pointer
 7915 
 7916   Type TNameValueList
 7917     integer Count
 7918     integer Delta
 7919     integer Capacity
 7920     logical ignoreDuplicates
 7921     type(TNameValue_pointer), dimension(:), pointer :: Items
 7922   end Type TNameValueList
 7923 
 7924   Type TIniFile
 7925    logical SlashComments
 7926    Type (TNameValueList) :: L, ReadValues
 7927   end Type TIniFile
 7928  
 7929   Type(TIniFile) :: DefIni
 7930 
 7931 contains
 7932 
 7933    subroutine TNameValueList_Init(L, ignoreDuplicates)
 7934     Type (TNameValueList) :: L
 7935     logical, intent(in), optional :: ignoreDuplicates
 7936     
 7937      L%Count = 0
 7938      L%Capacity = 0
 7939      L%Delta = 128
 7940      L%ignoreDuplicates = .false.
 7941      if (present(ignoreDuplicates)) L%ignoreDuplicates = ignoreDuplicates
 7942      nullify(L%Items)
 7943 
 7944    end subroutine TNameValueList_Init
 7945 
 7946    subroutine TNameValueList_Clear(L)
 7947     Type (TNameValueList) :: L
 7948     integer i, status
 7949      
 7950     do i = L%count,1,-1
 7951      deallocate (L%Items(i)%P, stat = status)
 7952     end do
 7953     deallocate (L%Items, stat = status)
 7954     call TNameValueList_Init(L)
 7955 
 7956    end subroutine TNameValueList_Clear
 7957 
 7958    subroutine TNameValueList_ValueOf(L, AName, AValue)
 7959      Type (TNameValueList), intent(in) :: L
 7960      character(LEN = *), intent(in) :: AName
 7961      CHARACTER(LEN = *), intent(out) :: AValue
 7962      integer i
 7963 
 7964      do i = 1, L%Count
 7965        if (L%Items(i)%P%Name = AName) then
 7966           AValue = L%Items(i)%P%Value 
 7967           return
 7968        end if
 7969      end do
 7970      AValue = ''
 7971 
 7972    end subroutine TNameValueList_ValueOf
 7973 
 7974    function TNameValueList_HasKey(L, AName) result (AValue)
 7975      Type (TNameValueList), intent(in) :: L
 7976      character(LEN = *), intent(in) :: AName
 7977      logical :: AValue
 7978      integer i
 7979 
 7980      do i = 1, L%Count
 7981        if (L%Items(i)%P%Name = AName) then
 7982           AValue = .true.
 7983           return
 7984        end if
 7985      end do
 7986      AValue = .false.
 7987      
 7988    end function TNameValueList_HasKey
 7989     
 7990    subroutine TNameValueList_Add(L, AName, AValue)
 7991     Type (TNameValueList) :: L
 7992     character(LEN = *), intent(in) :: AName, AValue
 7993 
 7994     if (.not. Ini_AllowDuplicateKeys .and. TNameValueList_HasKey(L,AName)) then
 7995       if (L%ignoreDuplicates) return
 7996       write (*,*) 'IniFile,TNameValueList_Add: duplicate key name in file: '//trim(AName)
 7997       stop 
 7998      end if 
 7999     if (L%Count = L%Capacity) call TNameValueList_SetCapacity(L, L%Capacity + L%Delta)
 8000     L%Count = L%Count + 1
 8001     allocate(L%Items(L%Count)%P)
 8002     L%Items(L%Count)%P%Name = AName
 8003     L%Items(L%Count)%P%Value = AValue
 8004 
 8005    end subroutine TNameValueList_Add
 8006 
 8007    subroutine TNameValueList_SetCapacity(L, C)
 8008     Type (TNameValueList) :: L
 8009     integer C
 8010     type(TNameValue_pointer), dimension(:), pointer :: TmpItems
 8011     
 8012     if (L%Count > 0) then
 8013       if (C < L%Count) stop 'TNameValueList_SetCapacity: smaller than Count'
 8014       allocate(TmpItems(L%Count))
 8015       TmpItems = L%Items(1:L%Count)
 8016       deallocate(L%Items)
 8017       allocate(L%Items(C))
 8018       L%Items(1:L%Count) = TmpItems
 8019       deallocate(TmpItems)
 8020     else
 8021      allocate(L%Items(C))
 8022     end if  
 8023     L%Capacity = C
 8024   
 8025    end subroutine TNameValueList_SetCapacity
 8026 
 8027    subroutine TNameValueList_Delete(L, i)
 8028     Type (TNameValueList) :: L
 8029     integer, intent(in) :: i
 8030      
 8031      deallocate(L%Items(i)%P)
 8032      if (L%Count > 1) L%Items(i:L%Count-1) = L%Items(i+1:L%Count)
 8033      L%Count = L%Count -1
 8034      
 8035    end subroutine TNameValueList_Delete
 8036 
 8037   subroutine Ini_NameValue_Add(Ini,AInLine)
 8038     Type(TIniFile) :: Ini
 8039     character (LEN = *), intent(IN) :: AInLine
 8040     integer EqPos, slashpos, lastpos
 8041     character (LEN = len(AInLine)) :: AName, S, InLine
 8042 
 8043       InLine = trim(adjustl(AInLine))
 8044       EqPos = scan(InLine,' = ')
 8045       if (EqPos/= 0 .and. InLine(1:1)/= '!' .and. InLine(1:7) /= 'COMMENT' ) then
 8046    
 8047          AName = trim(InLine(1:EqPos-1))
 8048          
 8049          S = adjustl(InLine(EqPos+1:)) 
 8050            if (Ini%SlashComments) then
 8051            slashpos = scan(S,'/')
 8052            if (slashpos /= 0) then
 8053               S  = S(1:slashpos-1)
 8054            end if
 8055          end if
 8056          lastpos = len_trim(S)
 8057          if (lastpos>1) then
 8058           if (S(1:1) = '''' .and. S(lastpos:lastpos) = '''') then
 8059            S = S(2:lastpos-1)
 8060           end if
 8061          end if
 8062          call TNameValueList_Add(Ini%L, AName, S)
 8063 
 8064       end if
 8065 
 8066   end subroutine Ini_NameValue_Add
 8067 
 8068   subroutine Ini_Open(filename, unit_id,  error, slash_comments)
 8069      character (LEN = *), intent(IN) :: filename
 8070      integer, intent(IN) :: unit_id
 8071      logical, optional, intent(OUT) :: error
 8072      logical, optional, intent(IN) :: slash_comments
 8073      logical aerror
 8074 
 8075      call TNameValueList_Init(DefIni%L)
 8076      call TNameValueList_Init(DefIni%ReadValues, .true.)
 8077           
 8078      if (present(slash_comments)) then
 8079       call Ini_Open_File(DefIni,filename,unit_id,aerror,slash_comments)
 8080      else
 8081       call Ini_Open_File(DefIni,filename,unit_id,aerror)
 8082      end if
 8083 
 8084      if (present(error)) then
 8085        error = aerror
 8086      else
 8087       if (aerror) then
 8088         write (*,*) 'Ini_Open: Error opening file ' // trim(filename)
 8089         stop
 8090       end if
 8091      end if
 8092 
 8093   end subroutine Ini_Open
 8094 
 8095   function Ini_ExtractFilePath(aname)
 8096     character(LEN = *), intent(IN) :: aname
 8097     character(LEN = Ini_max_string_len) Ini_ExtractFilePath
 8098     integer len, i
 8099 
 8100     len = len_trim(aname)
 8101     do i = len, 1, -1
 8102        if (aname(i:i) = '/') then
 8103           Ini_ExtractFilePath = aname(1:i)
 8104           return
 8105        end if
 8106     end do
 8107     Ini_ExtractFilePath = ''
 8108 
 8109   end function Ini_ExtractFilePath
 8110 
 8111   recursive subroutine Ini_Open_File(Ini, filename, unit_id,  &
 8112                                     error, slash_comments, append)
 8113      Type(TIniFile) :: Ini
 8114 
 8115      character (LEN = *), intent(IN) :: filename
 8116      integer, intent(IN) :: unit_id
 8117      logical, intent(OUT) :: error
 8118      logical, optional, intent(IN) :: slash_comments
 8119      logical, optional, intent(in) :: append
 8120      character (LEN = Ini_max_string_len) :: InLine, IncludeFile
 8121      integer lastpos, i
 8122      Type (TNameValueList) IncudeFiles
 8123      logical doappend, FileExists
 8124      
 8125      if (present(append)) then
 8126       doappend = append
 8127      else
 8128       doappend = .false.
 8129      end if  
 8130      
 8131      if (.not. doappend) then
 8132        call TNameValueList_Init(Ini%L)
 8133        call TNameValueList_Init(Ini%ReadValues, .true.)
 8134      end if
 8135  
 8136     call TNameValueList_Init(IncudeFiles) 
 8137      
 8138     if (present(slash_comments)) then
 8139      Ini%SlashComments = slash_comments
 8140     else
 8141      Ini%SlashComments = .false.
 8142     end if
 8143          
 8144     open(unit = unit_id,file = filename,form = 'formatted',status = 'old', err=500)
 8145    
 8146     do 
 8147       read (unit_id,'(a)',end = 400) InLine
 8148       if (InLine = 'END') exit;
 8149       if (InLine(1:8) = 'INCLUDE(') then
 8150            lastpos = scan(InLine,')')
 8151            if (lastpos/= 0) then
 8152             call TNameValueList_Add(IncudeFiles, trim(adjustl(InLine(9:lastpos-1))),'')            
 8153            else
 8154             stop 'Ini_Open_File: error in INCLUDE line'
 8155            end if 
 8156       elseif (InLine /= '') then
 8157        call Ini_NameValue_Add(Ini,InLine) 
 8158       end if
 8159     end do
 8160 
 8161 400 close(unit_id)
 8162     error = .false.
 8163 
 8164     do i = 1, IncudeFiles%Count
 8165        if (error) exit
 8166        IncludeFile = IncudeFiles%Items(i)%P%Name
 8167        inquire(file = IncludeFile, exist = FileExists)
 8168        if (.not. FileExists) then
 8169          IncludeFile = trim(Ini_ExtractFilePath(filename))//trim(IncludeFile)
 8170          inquire(file = IncludeFile, exist = FileExists)
 8171          if (.not. FileExists) stop 'Ini_Open_File: INCLUDE file not found'
 8172        end if
 8173        call Ini_Open_File(Ini, IncludeFile, unit_id,  &
 8174                           error, slash_comments, append = .true.)      
 8175     end do
 8176     call TNameValueList_Clear(IncudeFiles)
 8177     
 8178     return
 8179 
 8180 500 error = .true.
 8181     call TNameValueList_Clear(IncudeFiles)
 8182 
 8183   end subroutine Ini_Open_File
 8184 
 8185   subroutine Ini_Open_Fromlines(Ini, Lines, NumLines, slash_comments)
 8186     Type(TIniFile) :: Ini
 8187 
 8188     integer, intent(IN) :: NumLines
 8189     character (LEN = *), dimension(NumLines), intent(IN) :: Lines
 8190     logical, intent(IN) :: slash_comments
 8191     integer i
 8192 
 8193     call TNameValueList_Init(Ini%L)
 8194     call TNameValueList_Init(Ini%ReadValues, .true.)
 8195 
 8196     Ini%SlashComments = slash_comments
 8197 
 8198     do i = 1,NumLines
 8199        call Ini_NameValue_Add(Ini,Lines(i))
 8200     end do
 8201 
 8202   end  subroutine Ini_Open_Fromlines
 8203 
 8204   subroutine Ini_Close
 8205 
 8206     call Ini_close_File(DefIni)
 8207 
 8208   end subroutine Ini_Close
 8209 
 8210 
 8211   subroutine Ini_Close_File(Ini)
 8212     Type(TIniFile) :: Ini
 8213    
 8214     call TNameValueList_Clear(Ini%L)
 8215     call TNameValueList_Clear(Ini%ReadValues)
 8216 
 8217   end  subroutine Ini_Close_File
 8218   
 8219 
 8220 
 8221   function Ini_Read_String(Key, NotFoundFail) result(AValue)
 8222    character (LEN = *), intent(IN) :: Key
 8223    logical, optional, intent(IN) :: NotFoundFail
 8224    character(LEN = Ini_max_string_len) :: AValue
 8225 
 8226      if (present(NotFoundFail)) then
 8227       AValue = Ini_Read_String_File(DefIni, Key, NotFoundFail)
 8228      else
 8229       AValue = Ini_Read_String_File(DefIni, Key)
 8230      end if
 8231 
 8232   end function Ini_Read_String
 8233 
 8234 
 8235   function Ini_Read_String_File(Ini, Key, NotFoundFail) result(AValue)
 8236    Type(TIniFile) :: Ini
 8237    character (LEN = *), intent(IN) :: Key
 8238    logical, optional, intent(IN) :: NotFoundFail
 8239    character(LEN = Ini_max_string_len) :: AValue
 8240 
 8241    call TNameValueList_ValueOf(Ini%L, Key, AValue)
 8242 
 8243    if (AValue/= '') then
 8244 
 8245     call  TNameValueList_Add(Ini%ReadValues, Key, AValue)
 8246     if (Ini_Echo_Read) write (*,*) trim(Key)//' = ',trim(AValue)
 8247     return
 8248 
 8249    end if
 8250    if (present(NotFoundFail)) then
 8251       if (NotFoundFail) then
 8252          write(*,*) 'key not found : '//trim(Key)
 8253          stop
 8254       end if
 8255    else if (Ini_fail_on_not_found) then
 8256       write(*,*) 'key not found : '//trim(Key)
 8257       stop
 8258    end if
 8259 
 8260   end function Ini_Read_String_File
 8261   
 8262   
 8263   function Ini_HasKey(Key) result(AValue)
 8264    character (LEN = *), intent(IN) :: Key
 8265    logical AValue
 8266 
 8267    AValue = Ini_HasKey_File(DefIni, Key)
 8268 
 8269   end function Ini_HasKey
 8270 
 8271   function Ini_HasKey_File(Ini, Key) result(AValue)
 8272    type(TIniFile), intent(in) :: Ini
 8273    character (LEN = *), intent(IN) :: Key
 8274    logical AValue
 8275 
 8276       Avalue = TNameValueList_HasKey(Ini%L, Key)
 8277       
 8278   end function Ini_HasKey_File
 8279 
 8280  function Ini_Key_To_Arraykey(Key, index)  result(AValue)
 8281     character (LEN = *), intent(IN) :: Key
 8282     integer, intent(in) :: index
 8283     character(LEN = Ini_max_string_len) :: AValue
 8284     
 8285     character(LEN = 32) :: numstr
 8286     write (numstr,*) index 
 8287     numstr = adjustl(numstr)
 8288     AValue = trim(Key) // '(' // trim(numStr) // ')' 
 8289  
 8290  end function Ini_Key_To_Arraykey
 8291 
 8292   function Ini_Read_String_Array(Key, index, NotFoundFail) result(AValue)
 8293    character (LEN = *), intent(IN) :: Key
 8294    integer, intent(in) :: index
 8295    logical, optional, intent(IN) :: NotFoundFail
 8296    character(LEN = Ini_max_string_len) :: AValue
 8297 
 8298      if (present(NotFoundFail)) then
 8299       AValue = Ini_Read_String_Array_File(DefIni, Key, index, NotFoundFail)
 8300      else
 8301       AValue = Ini_Read_String_Array_File(DefIni, Key, index)
 8302      end if
 8303 
 8304   end function Ini_Read_String_Array
 8305 
 8306   function Ini_Read_String_Array_File(Ini, Key, index, NotFoundFail) result(AValue)
 8307    Type(TIniFile) :: Ini
 8308    integer, intent(in) :: index
 8309    character (LEN = *), intent(IN) :: Key
 8310    logical, optional, intent(IN) :: NotFoundFail
 8311    character(LEN = Ini_max_string_len) :: AValue
 8312    character(LEN = Ini_max_string_len) :: ArrayKey
 8313    
 8314      ArrayKey = Ini_Key_To_Arraykey(Key,index)
 8315      if (present(NotFoundFail)) then
 8316       AValue = Ini_Read_String_File(Ini, ArrayKey, NotFoundFail)
 8317      else
 8318       AValue = Ini_Read_String_File(Ini, ArrayKey)
 8319      end if
 8320    
 8321   end function Ini_Read_String_Array_File
 8322 
 8323   function Ini_Read_Int_Array(Key, index, Default)
 8324      integer, optional, intent(IN) :: Default
 8325      integer, intent(in) :: index
 8326      character (LEN = *), intent(IN) :: Key
 8327      integer Ini_Read_Int_Array
 8328 
 8329      if (present(Default)) then
 8330       Ini_Read_Int_Array = Ini_Read_Int_Array_File(DefIni, Key, index, Default)
 8331      else
 8332       Ini_Read_Int_Array = Ini_Read_Int_Array_File(DefIni, Key, index)
 8333      end if
 8334      
 8335    end function Ini_Read_Int_Array
 8336 
 8337   function Ini_Read_Int_Array_File(Ini,Key, index, Default)
 8338   !Reads Key(1), Key(2), etc.
 8339    Type(TIniFile) :: Ini
 8340    integer Ini_Read_Int_Array_File 
 8341    integer, optional, intent(IN) :: Default
 8342    integer, intent(in) :: index
 8343    character (LEN = *), intent(IN) :: Key
 8344    character(LEN = Ini_max_string_len) :: ArrrayKey
 8345      ArrrayKey = Ini_Key_To_Arraykey(Key,index)
 8346      if (present(Default)) then
 8347       Ini_Read_Int_Array_File = Ini_Read_Int_File(Ini, ArrrayKey, Default)
 8348      else
 8349       Ini_Read_Int_Array_File = Ini_Read_Int_File(Ini, ArrrayKey)
 8350      end if
 8351   end function Ini_Read_Int_Array_File
 8352 
 8353 
 8354   function Ini_Read_Int(Key, Default)
 8355      integer, optional, intent(IN) :: Default
 8356      character (LEN = *), intent(IN) :: Key
 8357      integer Ini_Read_Int
 8358 
 8359      if (present(Default)) then
 8360       Ini_Read_Int = Ini_Read_Int_File(DefIni, Key, Default)
 8361      else
 8362       Ini_Read_Int = Ini_Read_Int_File(DefIni, Key)
 8363      end if
 8364   end function Ini_Read_Int
 8365 
 8366   function Ini_Read_Int_File(Ini, Key, Default)
 8367    Type(TIniFile) :: Ini
 8368    integer Ini_Read_Int_File
 8369    integer, optional, intent(IN) :: Default
 8370    character  (LEN = *), intent(IN) :: Key
 8371    character(LEN = Ini_max_string_len) :: S
 8372    
 8373    S = Ini_Read_String_File(Ini, Key,.not. present(Default))
 8374    if (S = '') then
 8375       if (.not. present(Default)) then
 8376         write(*,*) 'no value for key: '//Key
 8377         stop
 8378       end if
 8379       Ini_Read_Int_File = Default
 8380       write (S,*) Default
 8381       call  TNameValueList_Add(Ini%ReadValues, Key, S)
 8382    else
 8383     if (verify(trim(S),'-+0123456789') /= 0) goto 10
 8384     read (S,*, err = 10) Ini_Read_Int_File
 8385    end if
 8386   return
 8387 10 write (*,*) 'error reading integer for key: '//Key
 8388    stop
 8389   
 8390   end function Ini_Read_Int_File
 8391 
 8392   function Ini_Read_Double(Key, Default)
 8393      double precision, optional, intent(IN) :: Default
 8394      character (LEN = *), intent(IN) :: Key
 8395      double precision Ini_Read_Double
 8396 
 8397      if (present(Default)) then
 8398       Ini_Read_Double = Ini_Read_Double_File(DefIni, Key, Default)
 8399      else
 8400       Ini_Read_Double = Ini_Read_Double_File(DefIni, Key)
 8401      end if
 8402   
 8403   end function Ini_Read_Double
 8404 
 8405   function Ini_Read_Double_File(Ini,Key, Default)
 8406    Type(TIniFile) :: Ini
 8407    double precision Ini_Read_Double_File 
 8408    double precision, optional, intent(IN) :: Default
 8409    character (LEN = *), intent(IN) :: Key
 8410    character(LEN = Ini_max_string_len) :: S
 8411    
 8412    S = Ini_Read_String_File(Ini,Key,.not. present(Default))
 8413    if (S = '') then
 8414       if (.not. present(Default)) then
 8415         write(*,*) 'no value for key: '//Key
 8416         stop
 8417       end if
 8418       Ini_Read_Double_File = Default
 8419       write (S,*) Default
 8420 
 8421       call  TNameValueList_Add(Ini%ReadValues, Key, S)
 8422 
 8423    else
 8424     read (S,*, err = 10) Ini_Read_Double_File
 8425    end if
 8426 
 8427   return
 8428 
 8429 10 write (*,*) 'error reading double for key: '//Key
 8430    stop
 8431 
 8432   end function Ini_Read_Double_File
 8433 
 8434 
 8435 
 8436     function Ini_Read_Double_Array(Key, index, Default)
 8437      double precision, optional, intent(IN) :: Default
 8438      integer, intent(in) :: index
 8439      character (LEN = *), intent(IN) :: Key
 8440      double precision Ini_Read_Double_Array
 8441 
 8442      if (present(Default)) then
 8443       Ini_Read_Double_Array = Ini_Read_Double_Array_File(DefIni, Key, index, Default)
 8444      else
 8445       Ini_Read_Double_Array = Ini_Read_Double_Array_File(DefIni, Key, index)
 8446      end if
 8447      
 8448     end function Ini_Read_Double_Array
 8449 
 8450 
 8451   function Ini_Read_Double_Array_File(Ini,Key, index, Default)
 8452 
 8453   !Reads Key(1), Key(2), etc.
 8454 
 8455    Type(TIniFile) :: Ini
 8456 
 8457    double precision Ini_Read_Double_Array_File 
 8458    double precision, optional, intent(IN) :: Default
 8459    integer, intent(in) :: index
 8460    character (LEN = *), intent(IN) :: Key
 8461    character(LEN = Ini_max_string_len) ::  ArrrayKey
 8462 
 8463      ArrrayKey = Ini_Key_To_Arraykey(Key,index)
 8464      if (present(Default)) then
 8465 
 8466       Ini_Read_Double_Array_File = Ini_Read_Double_File(Ini, ArrrayKey, Default)
 8467      else
 8468       Ini_Read_Double_Array_File = Ini_Read_Double_File(Ini, ArrrayKey)
 8469      end if
 8470   end function Ini_Read_Double_Array_File
 8471 
 8472     function Ini_Read_Real(Key, Default)
 8473      real, optional, intent(IN) :: Default
 8474      character (LEN = *), intent(IN) :: Key
 8475      real Ini_Read_Real
 8476 
 8477      if (present(Default)) then
 8478       Ini_Read_Real = Ini_Read_Real_File(DefIni, Key, Default)
 8479      else
 8480       Ini_Read_Real = Ini_Read_Real_File(DefIni, Key)
 8481      end if
 8482 
 8483     end function Ini_Read_Real
 8484 
 8485     function Ini_Read_Real_File(Ini,Key, Default)
 8486     Type(TIniFile) :: Ini
 8487     real Ini_Read_Real_File 
 8488     real, optional, intent(IN) :: Default
 8489     character (LEN = *), intent(IN) :: Key
 8490     character(LEN = Ini_max_string_len) :: S
 8491    
 8492     S = Ini_Read_String_File(Ini,Key,.not. present(Default))
 8493     if (S = '') then
 8494       if (.not. present(Default)) then
 8495         write(*,*) 'no value for key: '//Key
 8496         stop
 8497       end if
 8498       Ini_Read_Real_File = Default
 8499       write (S,*) Default
 8500       call  TNameValueList_Add(Ini%ReadValues, Key, S)
 8501 
 8502    else
 8503     read (S,*, err = 10) Ini_Read_Real_File
 8504    end if
 8505 
 8506   return
 8507 
 8508 10 write (*,*) 'error reading double for key: '//Key
 8509    stop
 8510 
 8511   end function Ini_Read_Real_File
 8512 
 8513 
 8514 
 8515    function Ini_Read_Real_Array(Key, index, Default)
 8516      real, optional, intent(IN) :: Default
 8517      integer, intent(in) :: index
 8518      character (LEN = *), intent(IN) :: Key
 8519      real Ini_Read_Real_Array
 8520 
 8521      if (present(Default)) then
 8522       Ini_Read_Real_Array = Ini_Read_Real_Array_File(DefIni, Key, index, Default)
 8523      else
 8524       Ini_Read_Real_Array = Ini_Read_Real_Array_File(DefIni, Key, index)
 8525      end if
 8526    end function Ini_Read_Real_Array
 8527 
 8528   function Ini_Read_Real_Array_File(Ini,Key, index, Default)
 8529   !Reads Key(1), Key(2), etc.
 8530    Type(TIniFile) :: Ini
 8531    real Ini_Read_Real_Array_File 
 8532    real, optional, intent(IN) :: Default
 8533    integer, intent(in) :: index
 8534    character (LEN = *), intent(IN) :: Key
 8535    character(LEN = Ini_max_string_len) :: ArrrayKey
 8536    
 8537      ArrrayKey = Ini_Key_To_Arraykey(Key,index)
 8538      if (present(Default)) then
 8539       Ini_Read_Real_Array_File = Ini_Read_Real_File(Ini, ArrrayKey, Default)
 8540      else
 8541       Ini_Read_Real_Array_File = Ini_Read_Real_File(Ini, ArrrayKey)
 8542      end if
 8543   end function Ini_Read_Real_Array_File
 8544 
 8545   function Ini_Read_Logical(Key, Default)
 8546      Logical, optional, intent(IN) :: Default
 8547      character (LEN = *), intent(IN) :: Key
 8548     logical Ini_Read_Logical
 8549 
 8550      if (present(Default)) then
 8551       Ini_Read_Logical = Ini_Read_Logical_File(DefIni, Key, Default)
 8552      else
 8553       Ini_Read_Logical = Ini_Read_Logical_File(DefIni, Key)
 8554      end if
 8555   end function Ini_Read_Logical
 8556 
 8557   function Ini_Read_Logical_File(Ini, Key, Default)
 8558    Type(TIniFile) :: Ini
 8559 
 8560    logical Ini_Read_Logical_File
 8561    logical, optional, intent(IN) :: Default
 8562    character  (LEN = *), intent(IN) :: Key
 8563   
 8564    character(LEN = Ini_max_string_len) :: S
 8565    
 8566    S = Ini_Read_String_File(Ini,Key,.not. present(Default))
 8567    if (S = '') then
 8568       if (.not. present(Default)) then
 8569         write(*,*) 'no value for key: '//Key
 8570         stop
 8571       end if
 8572       Ini_Read_Logical_File = Default
 8573       write (S,*) Default
 8574 
 8575       call  TNameValueList_Add(Ini%ReadValues, Key, S)
 8576 
 8577    else
 8578 
 8579     if (verify(trim(S),'10TF') /= 0) goto 10  
 8580     read (S,*, err = 10) Ini_Read_Logical_File
 8581    end if
 8582 
 8583   return
 8584 
 8585 10 write (*,*) 'error reading logical for key: '//Key
 8586    stop
 8587   end function Ini_Read_Logical_File
 8588 
 8589 
 8590 
 8591   subroutine Ini_SaveReadValues(afile,unit_id)
 8592    character(LEN = *)  :: afile
 8593    integer, intent(in) :: unit_id
 8594 
 8595    call Ini_SaveReadValues_File(DefIni, afile, unit_id)
 8596 
 8597   end subroutine Ini_SaveReadValues
 8598 
 8599 
 8600 
 8601   subroutine Ini_SaveReadValues_File(Ini, afile, unit_id)
 8602    Type(TIniFile) :: Ini
 8603    character(LEN = *), intent(in) :: afile
 8604    integer, intent(in) :: unit_id
 8605    integer i
 8606 
 8607    open(unit = unit_id,file = afile,form = 'formatted',status = 'replace', err=500)
 8608 
 8609    do i = 1, Ini%ReadValues%Count
 8610 
 8611     write (unit_id,'(a)') trim(Ini%ReadValues%Items(i)%P%Name) // ' = ' &
 8612                         //trim(Ini%ReadValues%Items(i)%P%Value)
 8613 
 8614    end do
 8615 
 8616    close(unit_id)
 8617    return
 8618 
 8619 500 write(*,*) 'Ini_SaveReadValues_File: Error creating '//trim(afile)
 8620 
 8621   end subroutine Ini_SaveReadValues_File
 8622 
 8623 end module IniFile
 8624 
 8625 ** lensing.f90
 8626 
 8627 !Lensing the C_l using the deflection angle from the computed lensing potential
 8628 !power spectrum. 
 8629 !lensing_method = 1: using an accurate curved-sky correlation function method
 8630 !lensing_method = 2: using the flat-sky lower order result of astro-ph/9505109 
 8631 !                  and astro-ph/9803150 as in CMBFAST 
 8632 !lensing_method = 3: using inaccurate full sky harmonic method of astro-ph/0001303
 8633 
 8634 !The flat sky result is accurate to about 0.1% in TT, and 0.4% in EE and is
 8635 !about a factor of two faster than lensing_method = 1.
 8636 !lensing_method = 3 is only present for comparison and is not recommended in any regime
 8637 
 8638 !Set accurate_BB = T if you want BB accurately by integrating the full angular range
 8639 !otherwise it saves a large amount of time by only integrating the small scales
 8640 !accute_BB only does *not* include any non-linear corrections or ensure you have
 8641 !chosen sufficiently high l_max and k_max, so does not neccessarily give an accurate
 8642 !result
 8643 
 8644 !Uses the un-lensed Cls and the computed lensing potential power spectrum.
 8645 !Usual values of k_max are fine for all but the lensed BB Cls
 8646 !To get the lensed BB accurate around l = 1000 you need to go to l_max >2000, and
 8647 !higher for higher l. Since this probes small scales in the lensing power spectrum you
 8648 !also need to go to higher k_max - for concordance models something like 
 8649 !k_eta_max_scalar = 10000. At l>1000 you can expect to need higher k_max, and for 
 8650 !non-linear evolution to cause a significant error.
 8651 
 8652 !Correlation function routines by AL+AC Nov 2004 with flat-sky borrowings from CMBFAST
 8653 !Curved sky results use the method of astro-ph/xxx.
 8654 
 8655 !Full sky harmonic lensing routines by Gayoung Chon and AC.
 8656 !Ref: astro-ph/0001303 by W. Hu. 
 8657 !For better derivations see also astro-ph/0301064 and astro-ph/0301031
 8658 !Adapted for CAMB and optimized by AL.
 8659 !Uses f90 version of "J1-RECURSION OF 3J-COEFFICIENTS" by K. Schulten and R.G. Gordon 
 8660 !obtainable from the CPC program library (www.cpc.cs.qub.ac.uk).
 8661 
 8662 !March 2006: fixed problem with l_max when generating with tensors (thanks Chad Fendt)
 8663 
 8664 module lensing
 8665 use Precision
 8666 use ModelParams
 8667 use AmlUtils
 8668 implicit none
 8669  integer, parameter :: lensing_method_curv_corr = 1,lensing_method_flat_corr = 2, &
 8670                        lensing_method_harmonic = 3
 8671  
 8672  integer :: lensing_method = lensing_method_curv_corr
 8673 
 8674 private
 8675 
 8676  logical  :: lensing_includes_tensors = .false.
 8677 
 8678 !flat method stores
 8679  real(dl), parameter :: dbessel = 0.05 
 8680  real(dl), dimension(:), allocatable :: Bess0, ddBess0
 8681  real(dl), dimension(:), allocatable :: Bess2, ddBess2
 8682  real(dl), dimension(:), allocatable :: Bess4, ddBess4
 8683  real(dl), dimension(:), allocatable :: Bess6, ddBess6
 8684 
 8685  integer, parameter :: lensed_convolution_margin = 100
 8686    !Number of L less than L max at which the lensed power spectrum is calculated 
 8687 
 8688 !Harmonic method stores
 8689  integer :: lmax_donelnfa = 0
 8690  real(dl), dimension(:), allocatable  :: lnfa
 8691 
 8692 public lens_Cls, lensing_includes_tensors, lensing_method, lensing_method_flat_corr,&
 8693       lensing_method_curv_corr,lensing_method_harmonic, BessI, bessj0
 8694 contains
 8695 
 8696 
 8697 subroutine lens_Cls
 8698  use lvalues
 8699 
 8700  !Must set l again in case computed tessors (thanks to Chad)
 8701  call initlval(lSamp,CP%Max_l)
 8702  if (lensing_method = lensing_method_curv_corr) then
 8703     call CorrFuncFullSky()
 8704   elseif (lensing_method = lensing_method_flat_corr) then 
 8705     call CorrFuncFlatSky()
 8706   elseif (lensing_method = lensing_method_harmonic) then 
 8707     call BadHarmonic
 8708   else
 8709     stop 'Unknown lensing method'
 8710  end if
 8711 end subroutine lens_Cls
 8712 
 8713 
 8714 subroutine CorrFuncFullSky
 8715 
 8716   integer :: lmax_extrap 
 8717   
 8718   lmax_extrap = CP%Max_l - lensed_convolution_margin + 450  
 8719   if (HighAccuracyDefault) lmax_extrap = lmax_extrap+300
 8720   lmax_extrap = min(lmax_extrap_highl,lmax_extrap)
 8721   call CorrFuncFullSkyImpl(max(lmax_extrap,CP%max_l))
 8722 
 8723 end subroutine CorrFuncFullSky
 8724 
 8725 
 8726 subroutine CorrFuncFullSkyImpl(lmax)
 8727  !Accurate curved sky correlation function method
 8728  !Uses non-perturbative isotropic term with 2nd order expansion in C_{gl,2}
 8729  !Neglects C_{gl}(theta) terms (very good approx)
 8730   use ModelParams
 8731   use ModelData
 8732   use lvalues
 8733   implicit none
 8734   integer, intent(in) :: lmax
 8735   integer l, i, in
 8736   integer :: npoints 
 8737   real(dl) corr(4), Cg2, sigmasq, theta
 8738   real(dl) dtheta
 8739   real(dl) llp1,fac, fac1,fac2,fac3, rootllp1, rootfac1, rootfac2, rootfac3
 8740   integer max_lensed_ix
 8741   real(dl) P(lmax),dP(lmax)
 8742   real(dl) sinth,halfsinth, x, T2,T4
 8743   real(dl) roots(-1:lmax+4), lfacs(lmax), lfacs2(lmax), lrootfacs(lmax)
 8744   real(dl) d_11(lmax),d_m11(lmax)
 8745   real(dl) d_22(lmax),d_2m2(lmax),d_20(lmax)
 8746   real(dl) Cphil3(lmin:lmax), CTT(lmin:lmax), CTE(lmin:lmax),CEE(lmin:lmax)
 8747   real(dl) ls(lmax)
 8748   real(dl) xl(lmax),ddcontribs(lmax,4),corrcontribs(lmax,4)
 8749   real(dl), allocatable, dimension(:,:,:) :: lens_contrib(:,:,:)
 8750   integer thread_ix
 8751   real(dl) pmm, pmmp1
 8752   real(dl) d4m4,d11,dm11,d2m2,d22,d20,d23,d2m3,d33,d3m3,dd4,d1m2,d12,d13,d1m3,d2m4
 8753   real(dl) sinfac, Cg2sq
 8754   real(dl) X000,X022,X220,X121,X132,X242
 8755   real(dl) dX000,dX022
 8756   real(sp) timeprev
 8757   integer  interp_fac
 8758   integer j,jmax
 8759   integer llo, lhi
 8760   real(dl) a0,b0,ho, sc
 8761   logical :: short_integral_range
 8762   integer, parameter :: slow_highL = 5000 !Lmax at which to do full range to prevent ringing etc
 8763 
 8764   logical, parameter :: approx = .false.
 8765 
 8766 !$ integer  OMP_GET_THREAD_NUM, OMP_GET_MAX_THREADS
 8767 !$ external OMP_GET_THREAD_NUM, OMP_GET_MAX_THREADS
 8768 
 8769     if (lensing_includes_tensors) stop 'Haven''t implemented tensor lensing'
 8770 
 8771     max_lensed_ix = lSamp%l0-1
 8772 !    do while(lSamp%l(max_lensed_ix) > CP%Max_l -250)
 8773     do while(lSamp%l(max_lensed_ix) > CP%Max_l - lensed_convolution_margin) 
 8774       max_lensed_ix = max_lensed_ix -1
 8775     end do
 8776     lmax_lensed = lSamp%l(max_lensed_ix)
 8777     if (allocated(Cl_lensed)) deallocate(Cl_lensed)
 8778     allocate(Cl_lensed(lmin:lmax_lensed,CP%InitPower%nn,1:4))
 8779     
 8780     Cl_Lensed = 0
 8781    
 8782     npoints = CP%Max_l  * 2    
 8783     short_integral_range = .not. CP%AccurateBB .and. CP%Max_l< = slow_highL
 8784     if (.not. short_integral_range ) npoints = npoints * 2 
 8785 
 8786     dtheta = pi / npoints
 8787     if (short_integral_range) then
 8788       npoints = int(npoints /32 *min(32,AccuracyBoost)) 
 8789       !OK for TT, EE, TE but inaccurate for low l BB
 8790       !this induces high frequency ringing on very small scales
 8791     end if
 8792 
 8793     if (DebugMsgs) timeprev = GetTestTime()
 8794 
 8795     if (.not. short_integral_range) then
 8796      !There is an odd serious problem with interpolating if you do a large
 8797      !angular range.
 8798       
 8799      interp_fac = 1
 8800     else
 8801      interp_fac = max(1,nint(10/AccuracyBoost))
 8802     end if
 8803 
 8804     jmax = 0
 8805     do l = lmin,lmax
 8806        if (l< = 15 .or. mod(l-15,interp_fac) = interp_fac/2) then
 8807          jmax = jmax+1
 8808          ls(jmax) = l
 8809          xl(jmax) = l
 8810        end if
 8811        lfacs(l) = real(l*(l+1),dl)
 8812        lfacs2(l) = real((l+2)*(l-1),dl)
 8813        lrootfacs(l) = sqrt(lfacs(l)*lfacs2(l))
 8814     end do
 8815 
 8816     roots(-1) = 0 !just so dipole doesn't screw up
 8817     do l = 0,lmax+4
 8818      roots(l) = sqrt(real(l,dl))
 8819     end do
 8820 
 8821 
 8822     thread_ix = 1
 8823     !$ thread_ix = OMP_GET_MAX_THREADS()  
 8824     allocate(lens_contrib(4,lmax_lensed,thread_ix))
 8825 
 8826     do in = 1, CP%InitPower%nn
 8827 
 8828     do l = lmin,CP%Max_l
 8829      ! (2*l+1)l(l+1)/4pi C_phi_phi: Cl_scalar(l,1,C_Phi) is l^4 C_phi_phi
 8830        Cphil3(l) = Cl_scalar(l,in,C_Phi)*(2*l+1)*(l+1)/real(l,dl)**3/(4*pi) 
 8831        fac = (2*l+1)/(4*pi) * 2*pi/(l*(l+1))
 8832        CTT(l) =  Cl_scalar(l,in,C_Temp)*fac
 8833        CEE(l) =  Cl_scalar(l,in,C_E)*fac
 8834        CTE(l) =  Cl_scalar(l,in,C_Cross)*fac
 8835     end do
 8836     if (Cphil3(10) > 1e-7) then
 8837      write (*,*) 'You need to normalize realistically to use lensing.'
 8838      write (*,*) 'see http://cosmocoffee.info/viewtopic.php?t = 94'
 8839      stop
 8840     end if
 8841     if (lmax > CP%Max_l) then
 8842      l = CP%Max_l
 8843      sc = (2*l+1)/(4*pi) * 2*pi/(l*(l+1))     
 8844      fac2 = CTT(CP%Max_l)/(sc*highL_CL_template(CP%Max_l, C_Temp))
 8845      fac = Cphil3(CP%Max_l)/(sc*highL_CL_template(CP%Max_l, C_Phi))  
 8846      do l = CP%Max_l+1, lmax
 8847        !Fill in tail from template
 8848        sc = (2*l+1)/(4*pi) * 2*pi/(l*(l+1))  
 8849        Cphil3(l) = highL_CL_template(l, C_Phi)*fac*sc
 8850        
 8851        CTT(l) =  highL_CL_template(l, C_Temp)*fac2*sc
 8852        CEE(l) =  highL_CL_template(l, C_E)*fac2 *sc
 8853        CTE(l) =  highL_CL_template(l, C_Cross)*fac2*sc 
 8854       if (Cphil3(CP%Max_l+1) > 1e-7) then
 8855        write (*,*) 'You need to normalize the high-L template so it is dimensionless'
 8856        stop
 8857       end if
 8858      end do
 8859    end if
 8860   lens_contrib = 0
 8861 
 8862   !uncomment second line for PGF90 workaround
 8863   !$OMP PARALLEL DO DEFAULT(PRIVATE),  &
 8864   !OMP PRIVATE(P,dP,d11,dm11,d22,d2m2,d20,corrcontribs,ddcontribs),& 
 8865   !$OMP SHARED(lfacs,lfacs2,lrootfacs,Cphil3,CTT,CTE,CEE,lens_contrib, lmax), &
 8866   !$OMP SHARED(dtheta,CP,lmax_lensed,roots, npoints,interp_fac,jmax,ls,xl,short_integral_range) 
 8867       do i = 1,npoints-1
 8868 
 8869       theta = i * dtheta 
 8870       x = cos(theta)
 8871       sinth = sin(theta)
 8872       halfsinth = sinth/2
 8873 
 8874       pmm = 1
 8875       pmmp1 = x
 8876 
 8877       Cg2 = 0
 8878       sigmasq = 0
 8879       if (lmin = 1) then
 8880         d_11(1) = cos(theta/2)**2
 8881         d_m11(1) = sin(theta/2)**2
 8882         sigmasq = sigmasq  +  (1-d_11(1))*Cphil3(lmin) 
 8883         Cg2 = Cg2  + d_m11(1)*Cphil3(lmin)
 8884         P(1) = x
 8885         d_22(1) = 0
 8886         d_2m2(1) = 0
 8887         d_20(1) = 0
 8888       end if
 8889       do l = 2,lmax
 8890 
 8891         P(l) = ((2*l-1)* x *pmmp1 - (l-1)*Pmm)/ l
 8892         dP(l) = l*(pmmp1-x*P(l))/sinth**2
 8893         Pmm = pmmp1
 8894         pmmp1 = P(l)
 8895         llp1 = lfacs(l)
 8896   
 8897         fac1 = (1-x)
 8898         fac2 = (1+x)
 8899         fac = fac1/fac2
 8900 
 8901         d_11(l) =  fac1*dP(l)/llp1 + P(l)
 8902         d_m11(l) = fac2*dP(l)/llp1 - P(l)
 8903 
 8904         sigmasq = sigmasq  +  (1-d_11(l))*Cphil3(l) 
 8905         Cg2 = Cg2  + d_m11(l)*Cphil3(l)
 8906         
 8907         d_22(l) = ( ((4*x-8)/fac2 + llp1)*P(l) &
 8908             + 4*fac*( fac2 + (x - 2)/llp1)*dP(l) )/ lfacs2(l)
 8909                   
 8910         d_2m2(l) = ( (llp1- (4*x+8)/fac1) *P(l) &
 8911             +4/fac*( -fac1 + (x+2)/llp1) *dP(l) )/lfacs2(l)              
 8912 
 8913         d_20(l) = (2*x*dP(l) - llp1*P(l) ) / lrootfacs(l)
 8914 
 8915       end do
 8916     
 8917        do j = 1,jmax
 8918         l = ls(j)
 8919  
 8920         fac1 = (1-x)
 8921         fac2 = (1+x)
 8922         llp1 = lfacs(l)
 8923   
 8924         rootllp1 = roots(l)*roots(l+1) 
 8925         rootfac1 = roots(l+2)*roots(l-1)
 8926         rootfac2 = roots(l+3)*roots(l-2)
 8927 
 8928         llp1 = lfacs(l)
 8929         dm11 = d_m11(l)
 8930         d11 = d_11(l)
 8931         if (l<2) then
 8932          d2m2 = 0
 8933          d22 = 0
 8934          d20 = 0
 8935          d1m2 = 0
 8936          d12 =  0     
 8937         else
 8938          d2m2 = d_2m2(l)
 8939          d22 = d_22(l)
 8940          d20 = d_20(l)
 8941          d1m2 = sinth/rootfac1*(dP(l) -2/fac1*dm11)
 8942          d12 =  sinth/rootfac1*(dP(l) -2/fac2*d11)
 8943         end if
 8944         if (l<3) then
 8945          d1m3 = 0
 8946          d2m3 = 0
 8947          d3m3 = 0
 8948          d13 = 0 
 8949          d23 = 0
 8950          d33 = 0 
 8951         else
 8952          sinfac = 4/sinth
 8953          d1m3 = (-(x+0.5)*d1m2*sinfac - lfacs2(l)*dm11/rootfac1 )/rootfac2
 8954          d2m3 = (-fac2*d2m2*sinfac - rootfac1*d1m2)/rootfac2
 8955          d3m3 = (-(x+1.5)*d2m3*sinfac - rootfac1*d1m3)/rootfac2
 8956          d13  =  ((x-0.5)*d12*sinfac - lfacs2(l)*d11/rootfac1 ) /rootfac2
 8957          d23  = (-fac1*d22*sinfac + rootfac1*d12 ) / rootfac2
 8958          d33  = (-(x-1.5)*d23*sinfac - rootfac1*d13)/rootfac2
 8959         end if 
 8960         if (l<4) then
 8961          dd4 = 0
 8962          d2m4 = 0
 8963          d4m4 = 0
 8964          rootfac3 = 0
 8965         else
 8966          rootfac3 = roots(l-3)*roots(l+4)
 8967          dd4 = ( (-llp1 + (18*x**2 + 6)/sinth**2 )*d20  -&
 8968              6*x*lfacs2(l)*dP(l)/lrootfacs(l) ) / (rootfac2*rootfac3)
 8969          d2m4 = (-(6*x+4)*d2m3/sinth - rootfac2*d2m2 ) / rootfac3
 8970          d4m4 = (-7/5*(llp1-6)*d2m2 + &
 8971                 12/5*( -llp1+(9*x+26)/fac1)*d3m3 ) / (llp1-12)
 8972         end if
 8973 
 8974        !Non perturbative isotropic integrals
 8975        !these are approx, but extremely good approximations
 8976          X000 = exp(-llp1*sigmasq/4)
 8977          if (approx) then
 8978 
 8979          X022 = X000  
 8980          X220 = rootllp1**2/4*X000
 8981          X121 = -0.5*rootllp1*X000
 8982          X132 = -0.5*rootllp1*X000
 8983          X242 = 0.25*rootllp1**2*X022 
 8984          
 8985          dX000 = -llp1/4*X000
 8986          dX022 = -llp1/4*X022
 8987         
 8988 
 8989          else
 8990          X022 = X000*(1+sigmasq)   !exp(-(llp1-4)*sigmasq/4)
 8991          X220 = lrootfacs(l)/4*X000
 8992          X121 = -0.5*rootfac1*X000
 8993          X132 = -0.5*rootfac2*X000
 8994          X242 = 0.25*rootfac2*rootfac3*X022 
 8995          
 8996          dX000 = -llp1/4*X000
 8997          dX022 = (1-llp1/4)*X022
 8998          end if  
 8999 !second order
 9000          !TT
 9001          fac1 = dX000**2
 9002          fac3 = X220**2
 9003          Cg2sq = Cg2**2
 9004 
 9005 !Here we drop terms in Cgt which are down by powers of l
 9006 !Approx good to 1e-4 level
 9007          fac = ( (X000**2-1) + Cg2sq*fac1)*P(l)+ Cg2sq*fac3*d2m2 &
 9008                     + 8/llp1* fac1*Cg2*dm11 
 9009      
 9010          corrcontribs(j,1) =  CTT(l) * fac 
 9011 
 9012          fac2 = (Cg2*dX022)**2+(X022**2-1)
 9013 !Q+U
 9014          fac = 2*Cg2*X121*X132*d13 + fac2*d22 +Cg2sq*X242*X220*dd4 
 9015 
 9016          corrcontribs(j,2) = CEE(l) * fac 
 9017 
 9018 !Q-U 
 9019          fac = ( fac3*P(l) + X242**2*d4m4)*Cg2sq/2 &
 9020               + Cg2*(X121**2*dm11+ X132**2*d3m3) + fac2*d2m2 
 9021 
 9022          corrcontribs(j,3) = CEE(l) * fac 
 9023 
 9024 !TE
 9025         fac = (X000*X022-1)*d20+ &
 9026           2*dX000*Cg2*(X121*d11 + X132*d1m3)/rootllp1 &
 9027              + Cg2sq*(X220/2*d2m4*X242 +( fac3/2 + dX022*dX000)*d20) 
 9028 
 9029         corrcontribs(j,4) = CTE(l) * fac 
 9030 
 9031       end do
 9032 
 9033 do j = 1,4
 9034   corr(j) = sum(corrcontribs(1:14,j))+interp_fac*sum(corrcontribs(15:jmax,j))
 9035 end do
 9036 
 9037 if (short_integral_range .and. i>npoints-20) &
 9038         corr = corr*exp(-(i-npoints+20)**2/150.0) !taper the end to help prevent ringing
 9039 
 9040 !Interpolate contributions
 9041 !Increasing interp_fac and using this seems to be slower than above
 9042 if (.false.) then
 9043       if (abs(sum(corrcontribs(1:jmax,1)))>1e-11) print *,i,sum(corrcontribs(1:jmax,1))
 9044       do j = 1,4
 9045        call spline(xl,corrcontribs(1,j),jmax,1d30,1d30,ddcontribs(1,j))
 9046       end do 
 9047       corr = 0
 9048       llo = 1
 9049       do l = lmin,lmax
 9050            if ((l > ls(llo+1)).and.(llo < jmax)) then
 9051               llo = llo+1
 9052            end if
 9053            lhi = llo+1
 9054            ho = ls(lhi)-ls(llo)
 9055            a0 = (ls(lhi)-l)/ho
 9056            b0 = (l-ls(llo))/ho
 9057            fac1 = ho**2/6
 9058            fac2 = (b0**3-b0)*fac1
 9059            fac1 = (a0**3-a0)*fac1 
 9060   
 9061            corr(1) = Corr(1)+ a0*corrcontribs(llo,1)+ b0*corrcontribs(lhi,1)+ &
 9062             fac1* ddcontribs(llo,1) +fac2*ddcontribs(lhi,1)
 9063            corr(2) = Corr(2)+ a0*corrcontribs(llo,2)+ b0*corrcontribs(lhi,2)+ &
 9064             fac1* ddcontribs(llo,2) +fac2*ddcontribs(lhi,2)
 9065            corr(3) = Corr(3)+ a0*corrcontribs(llo,3)+ b0*corrcontribs(lhi,3)+ &
 9066             fac1* ddcontribs(llo,3) +fac2*ddcontribs(lhi,3)
 9067            corr(4) = Corr(4)+ a0*corrcontribs(llo,4)+ b0*corrcontribs(lhi,4)+ &
 9068             fac1* ddcontribs(llo,4) +fac2*ddcontribs(lhi,4)
 9069          
 9070       end do
 9071 end if 
 9072       
 9073  !$   thread_ix = OMP_GET_THREAD_NUM()+1
 9074 
 9075       do l = lmin, lmax_lensed
 9076        !theta factors were put in earlier (already in corr)
 9077 
 9078 
 9079        lens_contrib(C_Temp, l, thread_ix) = lens_contrib(C_Temp,l, thread_ix) + &
 9080                                           corr(1)*P(l)*sinth 
 9081 
 9082        T2 = corr(2)* d_22(l)
 9083        T4 = corr(3)* d_2m2(l)
 9084 
 9085 
 9086        lens_contrib(CT_E, l, thread_ix) = lens_contrib(CT_E,l, thread_ix) + &
 9087                                           (T2+T4)*halfsinth 
 9088        lens_contrib(CT_B, l, thread_ix) = lens_contrib(CT_B,l, thread_ix) + &
 9089                                           (T2-T4)*halfsinth 
 9090  
 9091        lens_contrib(CT_Cross, l, thread_ix) = lens_contrib(CT_Cross,l, thread_ix) + &
 9092                                           corr(4)*d_20(l)*sinth 
 9093  
 9094       end do
 9095 
 9096      end do
 9097   !$OMP END PARALLEL DO
 9098      
 9099       do l = lmin, lmax_lensed
 9100          !sign from d(cos theta) = -sin theta dtheta
 9101        fac = l*(l+1)/OutputDenominator*dtheta *2*pi
 9102        Cl_lensed(l,in,CT_Temp) = sum(lens_contrib(CT_Temp,l,:))*fac &
 9103                  + Cl_scalar(l,in,C_Temp) 
 9104        Cl_lensed(l,in,CT_E) = sum(lens_contrib(CT_E,l,:))*fac &
 9105                  + Cl_scalar(l,in,C_E) 
 9106        Cl_lensed(l,in,CT_B) = sum(lens_contrib(CT_B,l,:))*fac
 9107        Cl_lensed(l,in,CT_Cross) = sum(lens_contrib(CT_Cross,l,:))*fac &
 9108                  + Cl_scalar(l,in,C_Cross) 
 9109 
 9110       end do
 9111 
 9112       end do !loop over different initial power spectra
 9113      deallocate(lens_contrib)
 9114 
 9115      if (DebugMsgs) write(*,*) GetTestTime()-timeprev, 'Time for corr lensing'
 9116 
 9117 end subroutine CorrFuncFullSkyImpl
 9118 
 9119 
 9120 
 9121 subroutine CorrFuncFlatSky
 9122  !Do flat sky approx partially non-perturbative lensing, lensing_method = 2
 9123    use ModelParams
 9124   use ModelData
 9125   use lvalues
 9126   integer l, i
 9127   integer :: npoints 
 9128   real(dl) Cgl2,  sigmasq, theta
 9129   real(dl) dtheta
 9130   real(dl) dbessfac, fac, fac1,fac2,  C2term, expsig, corr(4)
 9131   real(sp) timeprev
 9132   real(dl) Bessel0(lmin:CP%Max_l),Bessel2(lmin:CP%Max_l)
 9133   real(dl) Bessel4(lmin:CP%Max_l),Bessel6(lmin:CP%Max_l)
 9134   real(dl) Cphil3(lmin:CP%Max_l), CTT(lmin:CP%Max_l), CTE(lmin:CP%Max_l),CEE(lmin:CP%Max_l)
 9135   integer max_lensed_ix
 9136   integer b_lo
 9137   integer in
 9138   real(dl) T2,T4,a0, b0
 9139   real(dl) lfacs(CP%Max_l)
 9140   real(dl), allocatable, dimension(:,:,:) :: lens_contrib(:,:,:)
 9141   integer thread_ix
 9142 !$ integer OMP_GET_THREAD_NUM, OMP_GET_MAX_THREADS
 9143 !$ external OMP_GET_THREAD_NUM, OMP_GET_MAX_THREADS
 9144 
 9145     if (lensing_includes_tensors) stop 'Haven''t implemented tensor lensing'
 9146 
 9147     max_lensed_ix = lSamp%l0-1
 9148     do while(lSamp%l(max_lensed_ix) > CP%Max_l -250)
 9149       max_lensed_ix = max_lensed_ix -1
 9150     end do
 9151     lmax_lensed = lSamp%l(max_lensed_ix)
 9152     if (allocated(Cl_lensed)) deallocate(Cl_lensed)
 9153     allocate(Cl_lensed(lmin:lmax_lensed,CP%InitPower%nn,1:4))
 9154     
 9155     Cl_Lensed = 0
 9156    
 9157     npoints = CP%Max_l  * 2   
 9158     if (CP%AccurateBB) npoints = npoints * 2
 9159 
 9160     dtheta = pi / npoints
 9161     if (.not. CP%AccurateBB) then
 9162      npoints = int(npoints /32 *min(32,AccuracyBoost)) 
 9163       !OK for TT, EE, TE but inaccurate for low l BB
 9164       !this induces high frequency ringing on very small scales
 9165     end if
 9166 
 9167     call GetBessels(npoints*dtheta*CP%Max_l)
 9168 
 9169     if (DebugMsgs) timeprev = GetTestTime()
 9170 
 9171     dbessfac = dbessel**2/6
 9172 
 9173     thread_ix = 1
 9174     !$ thread_ix = OMP_GET_MAX_THREADS()  
 9175     allocate(lens_contrib(4,lmax_lensed,thread_ix))
 9176 
 9177     do in = 1, CP%InitPower%nn
 9178 
 9179     do l = lmin,CP%Max_l
 9180      ! l^3 C_phi_phi/2/pi: Cl_scalar(l,1,C_Phi) is l^4 C_phi_phi
 9181        Cphil3(l) = Cl_scalar(l,in,C_Phi)/l /(2*pi)
 9182        fac = l/(2*pi)*2*pi/(l*(l+1))
 9183        CTT(l) =  Cl_scalar(l,in,C_Temp)*fac
 9184        CEE(l) =  Cl_scalar(l,in,C_E)*fac
 9185        CTE(l) =  Cl_scalar(l,in,C_Cross)*fac
 9186        lfacs(l) = l**2*0.5
 9187     end do
 9188 
 9189     if (Cphil3(10) > 1e-7) then
 9190      write (*,*) 'You need to normalize realistically to use lensing.'
 9191      write (*,*) 'see http://cosmocoffee.info/viewtopic.php?t = 94'
 9192      stop
 9193     end if
 9194 
 9195   lens_contrib = 0
 9196 
 9197   !$OMP PARALLEL DO DEFAULT(SHARED),  &
 9198   !$OMP PRIVATE(theta, sigmasq,cgl2,b_lo,a0,b0,fac,fac1,fac2), &
 9199   !$OMP PRIVATE(Bessel0,Bessel2,Bessel4,Bessel6), &
 9200   !$OMP PRIVATE(corr,expsig,C2term,T2,T4,i,l, thread_ix)     
 9201 
 9202     do i = 1,npoints-1
 9203 
 9204       theta = i * dtheta 
 9205       sigmasq = 0
 9206       Cgl2 = 0
 9207       fac = theta /dbessel
 9208      
 9209       do l = lmin,CP%Max_l
 9210 
 9211 !Interpolate the Bessel functions, and compute sigma^2 and C_{gl,2} 
 9212         b0 = l*fac
 9213         b_lo = int(b0) +1 
 9214         a0 =  b_lo - b0                
 9215         b0 =  1 - a0 
 9216         fac1 = a0*b0*dbessfac
 9217         fac2 = fac1*(a0-2)
 9218         fac1 = fac1*(b0-2)
 9219 
 9220         Bessel0(l) = a0*Bess0(b_lo)+ b0*Bess0(b_lo+1) +fac1*ddBess0(b_lo) &
 9221                        +fac2*ddBess0(b_lo+1)
 9222         sigmasq = sigmasq + (1-Bessel0(l))*Cphil3(l) 
 9223 
 9224 
 9225         Bessel2(l) = a0*Bess2(b_lo)+ b0*Bess2(b_lo+1) +fac1*ddBess2(b_lo) &
 9226                       +fac2*ddBess2(b_lo+1)
 9227         Cgl2 =  Cgl2 + Bessel2(l)*Cphil3(l)
 9228 
 9229         Bessel4(l) = a0*Bess4(b_lo)+ b0*Bess4(b_lo+1) +fac1*ddBess4(b_lo) &
 9230                       +fac2*ddBess4(b_lo+1)
 9231         Bessel6(l) = a0*Bess6(b_lo)+ b0*Bess6(b_lo+1) +fac1*ddBess6(b_lo) &
 9232                       +fac2*ddBess6(b_lo+1)
 9233 
 9234       end do
 9235 
 9236 !Get difference between lensed and unlensed correlation function
 9237      corr = 0
 9238       do l = lmin,CP%Max_l
 9239 !For 2nd order perturbative result use 
 9240 !         expsig = 1 -sigmasq*l**2/2
 9241 !         C2term = l**2*Cgl2/2
 9242           fac = sigmasq*lfacs(l)
 9243           expsig = exp(-fac) 
 9244           C2term = Cgl2*lfacs(l)
 9245 !Put theta factor later  in here
 9246           fac1 = expsig*theta
 9247           fac2 = C2term*fac1
 9248           fac1 = fac1 - theta  !we want expsig-1 to get lensing difference
 9249 
 9250           fac = fac1*Bessel0(l) + fac2*Bessel2(l) 
 9251 
 9252           !TT
 9253           corr(1) = corr(1) + CTT(l) * fac                              
 9254 
 9255           !Q + U
 9256           corr(2) = corr(2) + CEE(l) * fac                              
 9257           fac2 = fac2*0.5
 9258           !Q-U
 9259           corr(3) = corr(3) + CEE(l) * &
 9260               (fac1*Bessel4(l) + fac2*(Bessel2(l)+Bessel6(l)))                               
 9261           !Cross
 9262           corr(4) = corr(4) + CTE(l) * &
 9263               (fac1*Bessel2(l) + fac2*(Bessel0(l)+Bessel4(l)))                               
 9264  
 9265 
 9266       end do
 9267 
 9268       
 9269  !$   thread_ix = OMP_GET_THREAD_NUM()+1
 9270 
 9271       do l = lmin, lmax_lensed
 9272        !theta factors were put in earlier (already in corr)
 9273        lens_contrib(C_Temp, l, thread_ix) = lens_contrib(C_Temp,l, thread_ix) + &
 9274                                           corr(1)*Bessel0(l) 
 9275        T2 = corr(2)*Bessel0(l)
 9276        T4 = corr(3)*Bessel4(l)
 9277        lens_contrib(CT_E,l,thread_ix)  = lens_contrib(CT_E,l, thread_ix) + T2+T4
 9278        lens_contrib(CT_B,l,thread_ix)  = lens_contrib(CT_B,l, thread_ix) + T2-T4
 9279        lens_contrib(CT_Cross,l, thread_ix) = lens_contrib(CT_Cross,l, thread_ix) + &
 9280                                               corr(4)*Bessel2(l)
 9281       end do
 9282 
 9283      end do
 9284   !$OMP END PARALLEL DO
 9285      
 9286       do l = lmin, lmax_lensed
 9287        fac = l*(l+1)* 2*pi/OutputDenominator*dtheta
 9288        Cl_lensed(l,in,CT_Temp) = sum(lens_contrib(CT_Temp,l,:))*fac &
 9289                  + Cl_scalar(l,in,CT_Temp) 
 9290        Cl_lensed(l,in,CT_Cross) = sum(lens_contrib(CT_Cross,l,:))*fac &
 9291                  +Cl_scalar(l,in,C_Cross)
 9292        fac = fac /2 !(factor of 1/2 should have been in T2+/-T4 above           
 9293        Cl_lensed(l,in,CT_E) = sum(lens_contrib(CT_E,l,:))*fac &
 9294                  + Cl_scalar(l,in,CT_E) 
 9295        Cl_lensed(l,in,CT_B) = sum(lens_contrib(CT_B,l,:))*fac
 9296       end do
 9297 
 9298       end do !loop over different initial power spectra
 9299      deallocate(lens_contrib)
 9300 
 9301      if (DebugMsgs) write(*,*) GetTestTime()-timeprev, 'Time for corr lensing'
 9302 
 9303 end subroutine CorrFuncFlatSky
 9304 
 9305 subroutine BadHarmonic
 9306   use ModelParams
 9307   use ModelData
 9308   use lvalues
 9309   use InitialPower
 9310   integer maxl, i, in, almin, max_lensed_ix, maxl_phi
 9311   real(dl) , dimension (:,:,:), allocatable :: bare_cls
 9312   real(dl) pp(CP%InitPower%nn,CP%Max_l)
 9313   real(dl) asum(CP%InitPower%nn), RR(CP%InitPower%nn), roots(CP%Max_l)
 9314   real(dl) asum_TE(CP%InitPower%nn), asum_EE(CP%InitPower%nn), asum_BB(CP%InitPower%nn)
 9315   integer l1,l2,al,j, j1, k, hk, llp_1, llp_al, g1
 9316   real(dl)  F, fct
 9317   real(dl) g2l,g2l1, norm
 9318   real(dl) a3j(CP%Max_l*2+1), tF, expF
 9319   logical DoPol
 9320   real(dl) iContribs(lSamp%l0,CP%InitPower%nn, 1:4), intcontrib(lmin:lSamp%l(lSamp%l0))
 9321   real(dl) , dimension (:,:,:), allocatable :: iCl_lensed
 9322   integer max_j_contribs
 9323 
 9324   real(sp) timeprev
 9325     
 9326 !Otherwise use second order perturbative harmonic method
 9327 
 9328   if (DebugMsgs) timeprev = GetTestTime()
 9329 
 9330   DoPol = CP%AccuratePolarization
 9331 
 9332   maxl = CP%Max_l
 9333  
 9334   if (allocated(Cl_lensed)) deallocate(Cl_lensed)
 9335 
 9336 
 9337   allocate(bare_cls(CP%InitPower%nn,maxl,1:4))
 9338   
 9339   RR = 0
 9340   do j = lmin,maxl
 9341      norm = OutputDenominator/(j*(j+1))
 9342      if (lensing_includes_tensors .and. CP%WantTensors .and. j< = CP%Max_l_tensor) then !Use total Cls
 9343       bare_cls(:,j,CT_Temp:CT_E) = (Cl_scalar(j,:,C_Temp:C_E) + &
 9344            Cl_tensor(j,:,CT_Temp:CT_E))*norm
 9345       bare_cls(:,j,CT_B) = Cl_tensor(j,:,CT_B)*norm
 9346       bare_cls(:,j,CT_Cross) =  (Cl_scalar(j,:,C_Cross) + &
 9347           Cl_tensor(j,:,CT_Cross))*norm
 9348      else
 9349       bare_cls(:,j,CT_Temp:CT_E) = Cl_scalar(j,:,C_Temp:C_E)*norm
 9350       bare_cls(:,j,CT_B) = 0
 9351       bare_cls(:,j,CT_Cross) =  Cl_scalar(j,:,C_Cross)*norm
 9352      end if
 9353      pp(:,j) = Cl_scalar(j,:,C_Phi)/real(j**2,dl)**2
 9354      RR = RR + j*(j+1)*real(2*j+1,dl)*pp(:,j)
 9355      roots(j) = sqrt(real(2*j+1,dl))
 9356   end do
 9357 
 9358   RR = RR/2/fourpi
 9359   if (RR(1) > 1e-5) then
 9360      write (*,*) 'You need to normalize realistically to use lensing.'
 9361      write (*,*) 'see http://cosmocoffee.info/viewtopic.php?t = 94'
 9362    stop
 9363   end if
 9364   if (maxl > lmax_donelnfa) then 
 9365    !Get ln factorials
 9366    if (allocated(lnfa)) deallocate(lnfa)
 9367    allocate(lnfa(0:maxl*3+1))
 9368    lmax_donelnfa = maxl 
 9369    lnfa(0) = 0
 9370    do i = 1,CP%Max_l*3+1 
 9371      lnfa(i) = lnfa(i-1) + log(real(i,dl))
 9372    end do
 9373   end if
 9374    
 9375   max_lensed_ix = lSamp%l0-1
 9376   do while(lSamp%l(max_lensed_ix) > maxl -250)
 9377      max_lensed_ix = max_lensed_ix -1
 9378   end do
 9379   lmax_lensed = lSamp%l(max_lensed_ix)
 9380 
 9381   allocate(iCl_lensed(max_lensed_ix, CP%InitPower%nn, 1:4))
 9382 
 9383   max_j_contribs = lSamp%l0-1
 9384   if (.not. DoPol) then
 9385            maxl_phi = min(maxl,nint(max(600,(maxl*2)/5)*scale*AccuracyBoost))
 9386            do while (lSamp%l(max_j_contribs) > maxl_phi)
 9387               max_j_contribs = max_j_contribs-1
 9388            end do
 9389   end if
 9390 
 9391   !$OMP PARALLEL DO DEFAULT(SHARED), SCHEDULE(DYNAMIC), SHARED(max_j_contribs) &
 9392   !$OMP PRIVATE(al,g1,llp_al,llp_1,g2l,asum,l1,g2l1,l2,k,hk,F,fct,almin), &
 9393   !$OMP PRIVATE(asum_EE,asum_BB,asum_TE,expF,tF, a3j, iContribs,in,intcontrib)
 9394   do j = max_lensed_ix,1,-1  
 9395      !Only compute lensed spectra at lSamp%l(j). Start with slow ones.
 9396      
 9397      al = lSamp%l(j)
 9398 
 9399      llp_al = al*(al+1)
 9400      g2l = sqrt((2*al+1)/fourpi)
 9401 
 9402      asum = 0
 9403      asum_EE = 0
 9404      asum_BB = 0
 9405      asum_TE = 0
 9406 
 9407    
 9408      do j1 = 1, max_j_contribs
 9409         !  Contributions to C_al are a smooth function of l_1 - so interpolate
 9410         l1 = lSamp%l(j1)
 9411 
 9412         llp_1 = l1*(l1+1)
 9413         g2l1 = roots(l1)
 9414 
 9415         almin = max(abs(al-l1),2)
 9416 
 9417         if (DoPol) then
 9418           call GetThreeJs(a3j(almin),l1,al,0,2)
 9419           do l2 = almin, min(maxl,al+l1)
 9420               g1 = llp_1+l2*(l2+1)-llp_al
 9421               if (g1 = 0 ) cycle
 9422 
 9423               k = al+l1+l2
 9424               fct = g1*g2l*g2l1*roots(l2)/2
 9425               tF = fct*a3j(l2)
 9426 
 9427               if (mod(k,2) = 0) then
 9428 
 9429                  hk = k/2
 9430                  F = lnfa(hk)-lnfa(hk-al)-lnfa(hk-l1)-lnfa(hk-l2)+(lnfa(k-2*al)+lnfa(k-2*l1)&
 9431                   & +lnfa(k-2*l2)-lnfa(k+1))/2
 9432                  
 9433                  expF = exp(F)
 9434 
 9435                  asum = asum + bare_cls(:,l2,C_Temp)*(expF*fct)**2
 9436         
 9437                  asum_EE = asum_EE + bare_cls(:,l2,CT_E)*tF**2
 9438                  asum_BB = asum_BB + bare_cls(:,l2,CT_B)*tF**2
 9439                  if (mod(hk,2)/= 0) tF = -tF
 9440                  asum_TE = asum_TE + bare_cls(:,l2,CT_Cross)*expF*fct*tF
 9441 
 9442               else
 9443                 
 9444                  asum_BB = asum_BB + bare_cls(:,l2,CT_E)*tF**2
 9445                  asum_EE = asum_EE +bare_cls(:,l2,CT_B)*tF**2 
 9446 
 9447               end if
 9448               
 9449           end do
 9450 
 9451         else !No polarization
 9452           do l2 = almin +mod(al+l1+almin,2),min(maxl,al+l1), 2 
 9453              !Only do lSamp%l's where al + l1 + l2 is even
 9454              
 9455               g1 = llp_1+l2*(l2+1)-llp_al
 9456             
 9457               if (g1 = 0 ) cycle  !Contribution is zero
 9458 
 9459               k = al+l1+l2
 9460               hk = k/2
 9461            
 9462               fct = g1*g2l*g2l1*roots(l2)/2
 9463               expF = exp(2*(lnfa(hk)-lnfa(hk-al)-lnfa(hk-l1)-lnfa(hk-l2))+lnfa(k-2*al)+lnfa(k-2*l1)&
 9464                   & +lnfa(k-2*l2)-lnfa(k+1))
 9465               asum = asum + bare_cls(:,l2,CT_Temp)*expF *fct**2
 9466           
 9467           end do
 9468           end if !No polarization
 9469 
 9470 
 9471              iContribs(j1,:,CT_Temp) = asum*pp(:,l1)
 9472              if (DoPol) then
 9473                 iContribs(j1,:,CT_E) = asum_EE*pp(:,l1)
 9474                 iContribs(j1,:,CT_B) = asum_BB*pp(:,l1)
 9475                 iContribs(j1,:,CT_Cross) = asum_TE*pp(:,l1)
 9476              end if
 9477              asum = 0
 9478              asum_EE = 0
 9479              asum_BB = 0
 9480              asum_TE = 0
 9481 
 9482         
 9483        end do
 9484 
 9485           
 9486        !Interpolate contributions to sum and add up
 9487          do in = 1, CP%InitPower%nn
 9488           
 9489             call InterpolateClArr(lSamp,iContribs(1,in,CT_Temp),intcontrib,max_j_contribs)
 9490             asum(in) = sum(intcontrib(lmin:lSamp%l(max_j_contribs)))
 9491             if (DoPol) then
 9492                call InterpolateClArr(lSamp,iContribs(1,in,CT_E),intcontrib,max_j_contribs)
 9493                asum_EE(in) = sum(intcontrib(lmin:lSamp%l(max_j_contribs)))
 9494                call InterpolateClArr(lSamp,iContribs(1,in,CT_B),intcontrib,max_j_contribs)
 9495                asum_BB(in) = sum(intcontrib(lmin:lSamp%l(max_j_contribs)))
 9496                call InterpolateClArr(lSamp,iContribs(1,in,CT_Cross),intcontrib,max_j_contribs)
 9497                asum_TE(in) = sum(intcontrib(lmin:lSamp%l(max_j_contribs)))
 9498             end if
 9499          end do
 9500 
 9501      iCl_lensed(j,:,CT_Temp) =  ((1-al*(al+1)*RR)*bare_cls(:,al,CT_Temp)  & !Linear part
 9502               + asum/(2*al+1))*llp_al/OutputDenominator !add quadratic part and *l(l+1)/2pi
 9503      if (DoPol) then
 9504         iCl_lensed(j,:,CT_E) = ((1-(al**2+al-4)*RR)*bare_cls(:,al,CT_E)  & 
 9505               + asum_EE/(2*al+1))*llp_al/OutputDenominator
 9506         iCl_lensed(j,:,CT_B) = ((1-(al**2+al-4)*RR)*bare_cls(:,al,CT_B)  & 
 9507               + asum_BB/(2*al+1))*llp_al/OutputDenominator
 9508         iCl_lensed(j,:,CT_Cross) =  ((1-(al**2+al-2)*RR)*bare_cls(:,al,CT_Cross) &
 9509                 + asum_TE/(2*al+1))*llp_al/OutputDenominator
 9510 
 9511      else
 9512         iCl_lensed(j,:,CT_E:CT_Cross) = bare_cls(:,al,CT_E:CT_Cross)
 9513      end if
 9514 
 9515   end do
 9516   !$OMP END PARALLEL DO
 9517 
 9518   deallocate(bare_cls)
 9519 
 9520   allocate(Cl_lensed(lmin:lmax_lensed,CP%InitPower%nn,1:4))
 9521 
 9522   !Interpolate to get final spectrum
 9523   do in = 1, CP%InitPower%nn
 9524      do j = CT_Temp, CT_Cross
 9525       call InterpolateClArr(lSamp,iCl_lensed(1,in,j),Cl_lensed(lmin, in, j),max_lensed_ix)
 9526      end do
 9527   end do
 9528 
 9529   deallocate(iCl_lensed)
 9530 
 9531   if (DebugMsgs) then
 9532         if (FeedbackLevel>0) write(*,*) GetTestTime()-timeprev,' Timing for lensing'
 9533    end if
 9534 
 9535 end subroutine BadHarmonic
 9536 
 9537       subroutine GetBessels(MaxArg)
 9538        real(dl), intent(in):: MaxArg
 9539        integer i
 9540        real(dl), allocatable, dimension(:) :: x
 9541        integer max_bes_ix
 9542        integer, save :: last_max = 0
 9543 
 9544        max_bes_ix = nint(MaxArg / dbessel) + 3
 9545        if (max_bes_ix > last_max) then
 9546            last_max = max_bes_ix
 9547            if (allocated(Bess0)) then
 9548              deallocate(Bess0,ddBess0)
 9549              deallocate(Bess2,ddBess2)
 9550              deallocate(Bess4,ddBess4)
 9551              deallocate(Bess6,ddBess6)
 9552            end if
 9553            allocate(Bess0(max_bes_ix),ddBess0(max_bes_ix))
 9554            allocate(Bess2(max_bes_ix),ddBess2(max_bes_ix))
 9555            allocate(Bess4(max_bes_ix),ddBess4(max_bes_ix))
 9556            allocate(Bess6(max_bes_ix),ddBess6(max_bes_ix))
 9557 
 9558            allocate(x(max_bes_ix))
 9559            Bess0(1) = 1
 9560            Bess2(1) = 0; Bess4(1) = 0; Bess6(1)=0
 9561            x(1) = 0
 9562            do i = 2, max_bes_ix
 9563              x(i) = (i-1)*dbessel
 9564              Bess0(i) = Bessj0(x(i)) 
 9565              Bess2(i) = Bessj(2,x(i)) 
 9566              Bess4(i) = Bessj(4,x(i)) 
 9567              Bess6(i) = Bessj(6,x(i)) 
 9568            end do 
 9569            call spline(x,Bess0,max_bes_ix,spl_large,spl_large,ddBess0)
 9570            call spline(x,Bess2,max_bes_ix,spl_large,spl_large,ddBess2)
 9571            call spline(x,Bess4,max_bes_ix,spl_large,spl_large,ddBess4)
 9572            call spline(x,Bess6,max_bes_ix,spl_large,spl_large,ddBess6)
 9573 
 9574            deallocate(x)
 9575        end if
 9576 
 9577       end subroutine GetBessels
 9578 
 9579 
 9580 
 9581       FUNCTION bessj0(x)
 9582       real(dl) bessj0,x
 9583       real(dl) ax,xx,z
 9584       real(dl) p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6, &
 9585         s1,s2,s3,s4,s5,s6,y
 9586       SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4, &
 9587        s5,s6
 9588       DATA p1,p2,p3,p4,p5/1,-.1098628627d-2,.2734510407d-4, &
 9589       -.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1, &
 9590       .1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
 9591       DATA r1,r2,r3,r4,r5,r6/57568490574,-13362590354, &
 9592        651619640.7,-11214424.18,77392.33017,-184.9052456/,s1,s2, &
 9593        s3,s4,s5,s6/57568490411,1029532985,9494680.718, &
 9594        59272.64853,267.8532712,1/
 9595 
 9596       if(abs(x) < 8)then
 9597         y = x**2
 9598         bessj0 = (r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y* &
 9599           (s4+y*(s5+y*s6)))))
 9600       else
 9601         ax = abs(x)
 9602         z = 8/ax
 9603         y = z**2
 9604         xx = ax-.785398164
 9605         bessj0 = sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y* &
 9606            p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
 9607       endif
 9608 !  (C) Copr. 1986-92 Numerical Recipes Software
 9609 
 9610       END FUNCTION bessj0
 9611 
 9612 
 9613 
 9614       FUNCTION BESSJ1(X)
 9615       real(dl), intent(in) :: x
 9616       real(dl) bessj1,ax,z,xx
 9617       real(dl) Y,P1,P2,P3,P4,P5,Q1,Q2,Q3,Q4,Q5,R1,R2,R3,R4,R5, &
 9618          R6,S1,S2,S3,S4,S5,S6
 9619       DATA R1,R2,R3,R4,R5,R6/72362614232,-7895059235,242396853.1,&
 9620          -2972611.439,15704.48260,-30.16036606/, &
 9621          S1,S2,S3,S4,S5,S6/144725228442,2300535178, &
 9622          18583304.74,99447.43394,376.9991397,1/
 9623       DATA P1,P2,P3,P4,P5/1,.183105D-2,-.3516396496D-4,.2457520174D-5, & 
 9624          -.240337019D-6/, Q1,Q2,Q3,Q4,Q5/.04687499995,-.2002690873D-3, &     
 9625          .8449199096D-5,-.88228987D-6,.105787412D-6/
 9626       IF(ABS(X) < 8.)THEN
 9627         Y = X**2
 9628         BESSJ1 = X*(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))) &
 9629            /(S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))))
 9630       ELSE
 9631         AX = ABS(X)
 9632         Z = 8.0/AX
 9633         Y = Z**2
 9634         XX = AX-2.356194491
 9635         BESSJ1 = SQRT(.636619772/AX)*(COS(XX)*(P1+Y*(P2+Y*(P3+Y*(P4+Y &
 9636            *P5))))-Z*SIN(XX)*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5))))) &
 9637            *SIGN(1,x)
 9638       ENDIF
 9639 
 9640       END FUNCTION BESSJ1
 9641 
 9642 
 9643       FUNCTION BESSJ(N,X)
 9644       real(dl) bessj
 9645       real(dl), intent(in) :: x
 9646       integer, intent(in) :: n
 9647       integer, parameter :: IACC = 40
 9648       real(dl), parameter :: BIGNO = 1.d10,BIGNI = 1.d-10
 9649       integer jsum,j,m
 9650       real(dl) bj,bjm, bjp, tox, sum
 9651       
 9652       IF(N < 2)STOP 'bad argument N in BESSJ'
 9653 
 9654       TOX = 2/X
 9655       IF(X > FLOAT(N))THEN
 9656         BJM = BESSJ0(X)
 9657         BJ = BESSJ1(X)
 9658         DO J = 1,N-1
 9659           BJP = J*TOX*BJ-BJM
 9660           BJM = BJ
 9661           BJ = BJP
 9662         END DO
 9663         BESSJ = BJ
 9664       ELSE
 9665         M = 2*((N+INT(SQRT(FLOAT(IACC*N))))/2)
 9666         BESSJ = 0.0
 9667         JSUM = 0
 9668         SUM = 0
 9669         BJP = 0
 9670         BJ = 1
 9671         DO J = M,1,-1
 9672           BJM = J*TOX*BJ-BJP
 9673           BJP = BJ
 9674           BJ = BJM
 9675           IF(ABS(BJ) > BIGNO)THEN
 9676             BJ = BJ*BIGNI
 9677             BJP = BJP*BIGNI
 9678             BESSJ = BESSJ*BIGNI
 9679             SUM = SUM*BIGNI
 9680           ENDIF
 9681           IF(JSUM <> 0)SUM = SUM+BJ
 9682           JSUM = 1-JSUM
 9683           IF(J = N)BESSJ = BJP
 9684         end do
 9685         SUM = 2.*SUM-BJ
 9686         BESSJ = BESSJ/SUM
 9687       ENDIF
 9688       END FUNCTION BESSJ
 9689 
 9690 ! ----------------------------------------------------------------------
 9691 ! Auxiliary Bessel functions for N = 0, N=1
 9692       FUNCTION BESSI0(X)
 9693       double precision X,BESSI0,Y,P1,P2,P3,P4,P5,P6,P7,  &
 9694       Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
 9695       DATA P1,P2,P3,P4,P5,P6,P7/1,3.5156229,3.0899424,1.2067429,  &
 9696       0.2659732,0.360768D-1,0.45813D-2/
 9697       DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228,0.1328592D-1, &
 9698       0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,  &
 9699       0.2635537D-1,-0.1647633D-1,0.392377D-2/
 9700       IF(ABS(X) < 3.75) THEN
 9701       Y = (X/3.75)**2
 9702       BESSI0 = P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
 9703       ELSE
 9704       AX = ABS(X)
 9705       Y = 3.75/AX
 9706       BX = EXP(AX)/SQRT(AX)
 9707       AX = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
 9708       BESSI0 = AX*BX
 9709       ENDIF
 9710       RETURN
 9711       END FUNCTION BESSI0
 9712 ! ----------------------------------------------------------------------
 9713       FUNCTION BESSI1(X)
 9714       double precision X,BESSI1,Y,P1,P2,P3,P4,P5,P6,P7,  &
 9715       Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
 9716       DATA P1,P2,P3,P4,P5,P6,P7/0.5,0.87890594,0.51498869,  &
 9717       0.15084934,0.2658733D-1,0.301532D-2,0.32411D-3/
 9718       DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228,-0.3988024D-1, &
 9719       -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, &
 9720       -0.2895312D-1,0.1787654D-1,-0.420059D-2/
 9721       IF(ABS(X) < 3.75) THEN
 9722       Y = (X/3.75)**2
 9723       BESSI1 = X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
 9724       ELSE
 9725       AX = ABS(X)
 9726       Y = 3.75/AX
 9727       BX = EXP(AX)/SQRT(AX)
 9728       AX = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
 9729       BESSI1 = AX*BX
 9730       ENDIF
 9731       RETURN
 9732       END FUNCTION BESSI1
 9733 
 9734 
 9735       FUNCTION BESSI(N,X)
 9736       !from http://perso.orange.fr/jean-pierre.moreau/Fortran/tbessi_f90.txt
 9737 !
 9738 !     This subroutine calculates the first kind modified Bessel function
 9739 !     of integer order N, for any REAL X. We use here the classical
 9740 !     recursion formula, when X > N. For X < N, the Miller's algorithm
 9741 !     is used to avoid overflows. 
 9742 !     REFERENCE:
 9743 !     C.W.CLENSHAW, CHEBYSHEV SERIES FOR MATHEMATICAL FUNCTIONS,
 9744 !     MATHEMATICAL TABLES, VOL.5, 1962.
 9745       integer, intent(in) :: N
 9746       integer, PARAMETER :: IACC = 40
 9747       integer m,j
 9748       double precision, parameter ::  BIGNO = 1.D10, BIGNI = 1.D-10
 9749       double precision X,BESSI,TOX,BIM,BI,BIP
 9750       IF (N = 0) THEN
 9751       BESSI = BESSI0(X)
 9752       RETURN
 9753       ENDIF
 9754       IF (N = 1) THEN
 9755       BESSI = BESSI1(X)
 9756       RETURN
 9757       ENDIF
 9758       IF(X = 0) THEN
 9759       BESSI = 0
 9760       RETURN
 9761       ENDIF
 9762       TOX = 2/X
 9763       BIP = 0
 9764       BI  = 1
 9765       BESSI = 0
 9766       M = 2*((N+INT(SQRT(FLOAT(IACC*N)))))
 9767       DO J = M,1,-1
 9768       BIM = BIP+ J*TOX*BI
 9769       BIP = BI
 9770       BI  = BIM
 9771       IF (ABS(BI) > BIGNO) THEN
 9772       BI  = BI*BIGNI
 9773       BIP = BIP*BIGNI
 9774       BESSI = BESSI*BIGNI
 9775       ENDIF
 9776       IF (J = N) BESSI = BIP
 9777       END DO
 9778       BESSI = BESSI*BESSI0(X)/BI
 9779       RETURN
 9780       END FUNCTION BESSI
 9781 
 9782 
 9783 end module lensing
 9784 
 9785 ** Matrix_utils.f90
 9786 
 9787 !Matrix utility routines. Uses BLAS/LAPACK. Mostly wrapper routines.
 9788 !Generally (but not always) assumes that all matrix arrays are defined at exactly correct size
 9789 !Not complete
 9790 !Antony Lewis May 2003-2007
 9791 !http://cosmologist.info/utils/
 9792 
 9793 
 9794 module MatrixUtils
 9795  use AMLutils
 9796  implicit none
 9797 
 9798  logical, parameter :: Matrix_runmsgs = .false.
 9799 !ifdef MATRIX_SINGLE 
 9800  integer, parameter :: dm = KIND(1.0)
 9801 !else
 9802  integer, parameter :: dm = KIND(1)
 9803 !endif
 9804   !Precision of matrix operators
 9805   !If changing also need to change prefix on LAPACK routine names
 9806  integer, parameter :: Mat_F90 = 1, Mat_Norm = 2, Mat_DC = 3 !Normal, basic BLAS/LAPACK or divide and conquer
 9807  integer, parameter :: matrix_method = mat_DC
 9808 
 9809  real Matrix_StartTime
 9810 
 9811  Type TMatrixType
 9812   real(dm), dimension(:,:), pointer :: M
 9813  end Type TMatrixType
 9814 
 9815  complex(dm), parameter :: COne = (1._dm,0._dm), CZero = (0._dm,0._dm)
 9816  real(dm), parameter :: ROne = 1._dm, RZero = 0._dm
 9817  real, parameter :: SOne = 1., SZero = 0.
 9818 
 9819 contains
 9820 
 9821 
 9822  function GetMatrixTime()
 9823       real GetMatrixTime
 9824       real atime
 9825        
 9826       call cpu_time(atime)
 9827 
 9828       GetMatrixTime = atime  
 9829        
 9830 
 9831  end function GetMatrixTime
 9832 
 9833  subroutine  Matrix_start(Name)
 9834   character(LEN = *), intent(in) :: Name
 9835 
 9836      if (Matrix_runmsgs) then
 9837       Matrix_StartTime = GetMatrixTime()
 9838       Write(*,*) 'Matrix_'//trim(Name) //' start'
 9839      end if
 9840  end subroutine  Matrix_start
 9841 
 9842  subroutine  Matrix_end(Name)
 9843   character(LEN = *), intent(in) :: Name
 9844 
 9845      if (Matrix_runmsgs) then
 9846       Write(*,*) 'Matrix_'//trim(Name) //' end: ', GetMatrixTime() - Matrix_StartTime
 9847      end if
 9848  end subroutine  Matrix_end
 9849 
 9850  subroutine Matrix_WriteFileRow(aunit, vec,n)
 9851   integer, intent(in) :: aunit
 9852   integer, intent(in) :: n
 9853   real(dm) :: vec(n)
 9854   character(LEN = 50) fmt
 9855   
 9856    fmt = trim(numcat('(',n))//'E17.7)'
 9857    write (aunit, fmt) vec(1:n)
 9858 
 9859  end subroutine Matrix_WriteFileRow
 9860 
 9861  subroutine Matrix_Write(aname, mat, forcetable, commentline)
 9862    character(LEN = *), intent(in) :: aname
 9863    character(LEN = *), intent(in), optional :: commentline   
 9864    real(dm), intent(in) :: mat(:,:)
 9865    logical, intent(in), optional :: forcetable
 9866    integer i,k
 9867    character(LEN = 50) fmt
 9868    integer shp(2)
 9869    logical WriteTab
 9870    integer file_unit
 9871 
 9872    shp = shape(mat)
 9873    WriteTab = shp(2)< = 50
 9874    if (present(forcetable)) then
 9875      if (forcetable) WriteTab = .true.
 9876     end if
 9877    file_unit = new_file_unit()
 9878    call CreateTxtFile(aname, file_unit)
 9879    if (present(commentline)) then
 9880     write(file_unit,'(a)') '!'//trim(commentline)
 9881    end if
 9882    fmt = trim(numcat('(',shp(2)))//'E15.5)'
 9883    do i = 1, shp(1)
 9884      if (.not. WriteTab) then
 9885       do k = 1, shp(2)
 9886        write (file_unit, '(1E17.7)') mat(i,k)
 9887       end do
 9888      else
 9889       write (file_unit, fmt) mat(i,1:shp(2))
 9890      end if
 9891    end do
 9892 
 9893    call CloseFile(file_unit)
 9894 
 9895  end subroutine Matrix_Write
 9896 
 9897 subroutine Matrix_Write_double(aname, mat, forcetable)
 9898    character(LEN = *), intent(in) :: aname
 9899    double precision, intent(in) :: mat(:,:)
 9900    logical, intent(in), optional :: forcetable
 9901    integer i,k
 9902    character(LEN = 50) fmt
 9903    integer shp(2)
 9904    logical WriteTab
 9905    integer file_unit
 9906 
 9907    shp = shape(mat)
 9908    WriteTab = shp(2)< = 50
 9909    if (present(forcetable)) then
 9910      if (forcetable) WriteTab = .true.
 9911     end if
 9912    file_unit = new_file_unit()
 9913    call CreateTxtFile(aname, file_unit)
 9914    fmt = trim(numcat('(',shp(2)))//'E15.5)'
 9915    do i = 1, shp(1)
 9916      if (.not. WriteTab) then
 9917       do k = 1, shp(2)
 9918        write (file_unit, '(1E17.7)') mat(i,k)
 9919       end do
 9920      else
 9921       write (file_unit, fmt) mat(i,1:shp(2))
 9922      end if
 9923    end do
 9924 
 9925    call CloseFile(file_unit)
 9926 
 9927  end subroutine Matrix_Write_double
 9928 
 9929 
 9930  subroutine Matrix_Write_Binary(aname, mat)
 9931    character(LEN = *), intent(in) :: aname
 9932    real(dm), intent(in) :: mat(:,:)
 9933    integer file_unit
 9934      
 9935    file_unit = new_file_unit()
 9936    call CreateFile(aname, file_unit,'unformatted')
 9937    write (file_unit) mat
 9938    call CloseFile(file_unit)
 9939 
 9940  end subroutine Matrix_Write_Binary
 9941 
 9942 
 9943  subroutine MatrixSym_Write_Binary(aname, mat)
 9944    character(LEN = *), intent(in) :: aname
 9945    real(dm), intent(in) :: mat(:,:)
 9946    integer i
 9947    integer shp(2)
 9948    integer file_unit
 9949    
 9950    shp = shape(mat)
 9951    if (shp(1) /= shp(2)) call MpiStop('MatrixSym_Write_Binary: Not square matrix')
 9952    if (shp(1) = 0) return
 9953    
 9954    file_unit = new_file_unit()
 9955    call CreateFile(aname, file_unit,'unformatted')
 9956    do i = 1,shp(1) 
 9957     write (file_unit) mat(i:shp(2),i)
 9958    end do 
 9959    call CloseFile(file_unit)
 9960 
 9961  end subroutine MatrixSym_Write_Binary
 9962 
 9963  subroutine MatrixSym_Write_Binary_Single(aname, mat)
 9964    character(LEN = *), intent(in) :: aname
 9965    real(dm), intent(in) :: mat(:,:)
 9966    integer i,    file_unit 
 9967    integer shp(2)
 9968   
 9969    shp = shape(mat)
 9970    if (shp(1) /= shp(2)) call MpiStop('MatrixSym_Write_Binary_Single: Not square matrix')
 9971    if (shp(1) = 0) return
 9972    
 9973    file_unit = new_file_unit()
 9974    call CreateFile(aname, file_unit,'unformatted')
 9975    do i = 1,shp(1) 
 9976     write (file_unit) real(mat(i:shp(2),i), kind(1.0))
 9977    end do 
 9978    call CloseFile(file_unit)
 9979 
 9980  end subroutine MatrixSym_Write_Binary_Single
 9981 
 9982 
 9983 
 9984  subroutine Matrix_WriteVec(aname, vec)
 9985    character(LEN = *), intent(in) :: aname
 9986    real(dm), intent(in) :: vec(:)
 9987    integer i,   file_unit 
 9988  
 9989    file_unit = new_file_unit()
 9990    call CreateTxtFile(aname, file_unit)
 9991    do i = 1, size(vec)
 9992       write (file_unit, '(1E17.7)') vec(i)
 9993    end do
 9994    call CloseFile(file_unit)
 9995 
 9996  end subroutine Matrix_WriteVec
 9997 
 9998 
 9999  subroutine Matrix_Read_Binary(aname, mat)
 10000    character(LEN = *), intent(in) :: aname
 10001    real(dm), intent(out) :: mat(:,:)
 10002    integer  file_unit
 10003      
 10004    file_unit = new_file_unit()
 10005    call OpenFile(aname, file_unit,'unformatted')
 10006    read (file_unit) mat
 10007    call CloseFile(file_unit)
 10008 
 10009  end subroutine Matrix_Read_Binary
 10010 
 10011 
 10012   subroutine MatrixSym_Read_Binary(aname, mat)
 10013    character(LEN = *), intent(in) :: aname
 10014    real(dm), intent(out) :: mat(:,:)
 10015    integer i,    file_unit
 10016    integer shp(2)
 10017 
 10018    shp = shape(mat)
 10019    if (shp(1) /= shp(2)) call MpiStop( 'MatrixSym_Read_Binary: Not square matrix')
 10020    if (shp(1) = 0) return
 10021  
 10022    file_unit = new_file_unit()
 10023    call OpenFile(aname, file_unit,'unformatted')
 10024    do i = 1,shp(1)
 10025     read (file_unit) mat(i:shp(1),i)
 10026     mat(i,i:shp(1)) = mat(i:shp(1),i)
 10027    end do
 10028    call CloseFile(file_unit)
 10029 
 10030  end subroutine MatrixSym_Read_Binary
 10031 
 10032   subroutine MatrixSym_Read_Binary_Single(aname, mat)
 10033    character(LEN = *), intent(in) :: aname
 10034    real, intent(out) :: mat(:,:)
 10035    integer i,    file_unit
 10036    integer shp(2)
 10037 
 10038    shp = shape(mat)
 10039    if (shp(1) /= shp(2)) call MpiStop( 'MatrixSym_Read_Binary: Not square matrix')
 10040    if (shp(1) = 0) return
 10041  
 10042    file_unit = new_file_unit()
 10043    call OpenFile(aname, file_unit,'unformatted')
 10044    do i = 1,shp(1)
 10045     read (file_unit) mat(i:shp(1),i)
 10046     mat(i,i:shp(1)) = mat(i:shp(1),i)
 10047    end do
 10048    call CloseFile(file_unit)
 10049 
 10050  end subroutine MatrixSym_Read_Binary_Single
 10051 
 10052 
 10053 
 10054 
 10055 
 10056   subroutine Matrix_Read(aname, mat)
 10057    character(LEN = *), intent(IN) :: aname
 10058    real(dm), intent(out) :: mat(:,:)
 10059    integer j,k,    file_unit
 10060    integer shp(2)
 10061    real(dm) tmp
 10062 
 10063    shp = shape(mat)
 10064  
 10065    file_unit = new_file_unit()
 10066    call OpenTxtFile(aname, file_unit)
 10067 
 10068    do j = 1,shp(1)
 10069       read (file_unit,*, end = 200, err = 100) mat(j,1:shp(2))
 10070    end do
 10071    goto 120
 10072 
 10073 100 rewind(file_unit)  !Try other possible format
 10074    do j = 1,shp(1) 
 10075     do k = 1,shp(2)
 10076       read (file_unit,*, end = 200) mat(j,k)
 10077     end do
 10078    end do
 10079 
 10080 120 read (file_unit,*, err = 150, end = 150) tmp
 10081    goto 200
 10082 
 10083 150 call CloseFile(file_unit)
 10084     return
 10085 
 10086  200 call MpiStop('Matrix_Read: file '//trim(aname)//' is the wrong size')
 10087      
 10088 
 10089  end subroutine Matrix_Read
 10090 
 10091   subroutine Matrix_ReadSingle(aname, mat)
 10092    character(LEN = *), intent(IN) :: aname
 10093    real, intent(out) :: mat(:,:)
 10094    integer j,k,    file_unit 
 10095    integer shp(2)
 10096    real tmp
 10097 
 10098    shp = shape(mat)
 10099 
 10100    file_unit = new_file_unit()
 10101    call OpenTxtFile(aname, file_unit)
 10102 
 10103    do j = 1,shp(1)
 10104       read (file_unit,*, end = 200, err = 100) mat(j,1:shp(2))
 10105    end do
 10106    goto 120
 10107 
 10108 100 rewind(file_unit)  !Try other possible format
 10109    do j = 1,shp(1) 
 10110     do k = 1,shp(2)
 10111       read (file_unit,*, end = 200) mat(j,k)
 10112     end do
 10113    end do
 10114 
 10115 120 read (file_unit,*, err = 150, end = 150) tmp
 10116    goto 200
 10117 
 10118 150 call CloseFile(file_unit)
 10119     return
 10120 
 10121  200 call MpiStop('Matrix_Read:Single file '//trim(aname)//' is the wrong size')
 10122      
 10123 
 10124  end subroutine Matrix_ReadSingle
 10125 
 10126 
 10127   function Matrix_Diag(M, n)
 10128     integer, intent(in) :: n
 10129     real(dm), intent(in) :: M(:,:)
 10130     real(dm) Matrix_Diag(n)
 10131     integer i
 10132 
 10133     do i = 1,n
 10134     
 10135      Matrix_Diag(i) = M(i,i)
 10136 
 10137     end do
 10138 
 10139   end function Matrix_Diag
 10140 
 10141   function ILAENV_wrap(i,S1,S2,a,b,c,d)
 10142    integer ILAENV_wrap
 10143    integer, intent(in) :: i,a,b,c,d
 10144    character(LEN = *), intent(in) :: S1, S2
 10145    integer, external :: ILAENV
 10146 
 10147   !If you don't have ILAENV in math library, change routine to return some positive integer
 10148   !that is a guess at the blocksize
 10149 !ifdef MATRIX_SINGLE
 10150     ILAENV_wrap = 16
 10151 !else 
 10152     ILAENV_wrap =  ILAENV(i,S1,S2,a,b,c,d)
 10153 !endif
 10154 !!!IFC 
 10155   end  function ILAENV_wrap
 10156 
 10157 
 10158   subroutine Matrix_Diagonalize(M, diag, n)
 10159   !Does m = U diag U^T, returning U in M
 10160       integer, intent(in) :: n
 10161       real(dm), intent(inout):: m(n,n)
 10162       real(dm), intent(out) :: diag(n)
 10163       integer ierr, tmpsize
 10164       real(dm), allocatable, dimension(:) :: tmp
 10165  
 10166       call Matrix_Start('Diagonalize')      
 10167 !ifdef MATRIX_SINGLE 
 10168       tmpsize =  max( (ILAENV_wrap(1,'SSYTRD','U',n,n,n,n)+2)*N,max(1,3*n-1))  !3*n**2
 10169       allocate(tmp(tmpsize));
 10170       call SSYEV('V','U',n,m,n,diag,tmp,tmpsize,ierr) !evalues and vectors of symmetric matrix
 10171 !else
 10172       tmpsize =  max( (ILAENV_wrap(1,'DSYTRD','U',n,n,n,n)+2)*N,max(1,3*n-1))  !3*n**2
 10173       allocate(tmp(tmpsize));
 10174       call DSYEV('V','U',n,m,n,diag,tmp,tmpsize,ierr) !evalues and vectors of symmetric matrix
 10175 !endif
 10176       if (ierr /= 0) call MpiStop('Error in Matrix_Diagonalize')
 10177       deallocate(tmp)
 10178       call Matrix_End('Diagonalize')
 10179 
 10180   end subroutine Matrix_Diagonalize
 10181 
 10182   subroutine Matrix_Diagonalize_DC(M, diag, n)
 10183   !Complex version. Does m = U diag U^dag, returning U in M
 10184       integer, intent(in) :: n
 10185       real(dm), intent(inout):: m(n,n)
 10186       real(dm), intent(out) :: diag(n)
 10187       integer ierr, tmpsize ,isize
 10188       real(dm), allocatable, dimension(:) :: tmp
 10189       integer, allocatable,dimension(:):: iwork
 10190       
 10191       call Matrix_Start('Diagonalize')
 10192 
 10193       if (matrix_method = Mat_DC) then
 10194         !Divide and conquer
 10195           tmpsize = 1 + 6*N + 2*N**2 
 10196           isize = 3+5*N
 10197           allocate(tmp(tmpsize))
 10198           allocate(iwork(isize))
 10199 !ifdef MATRIX_SINGLE 
 10200           call SSYEVD('V','U',n,M,n,diag,tmp,tmpsize,iwork,isize,ierr) !evalues and vectors of hermitian matrix
 10201 !else
 10202           call DSYEVD('V','U',n,M,n,diag,tmp,tmpsize,iwork,isize,ierr) !evalues and vectors of hermitian matrix
 10203 !endif
 10204           deallocate(iwork)
 10205           deallocate(tmp)
 10206       else
 10207         call Matrix_Diagonalize(M, diag, n)
 10208       end if
 10209     
 10210       if (ierr /= 0) call MpiStop('Error in Matrix_Diagonalize')
 10211       
 10212    call Matrix_End('Diagonalize')
 10213   
 10214   end subroutine Matrix_Diagonalize_DC
 10215 
 10216 
 10217 
 10218   subroutine Matrix_Root(M, n, pow)
 10219   !Does M**pow for symmetric M using U D**pow U^T
 10220   !Not optimized for large matrices
 10221       integer, intent(in) :: n
 10222       real(dm), intent(inout):: M(n,n)
 10223       real(dm) :: Tmp(n,n)
 10224       real(dm), intent(in) :: pow
 10225 
 10226       real(dm) :: diag(n)
 10227       integer i
 10228       
 10229       call Matrix_Diagonalize(M, diag, n)
 10230       Tmp = M
 10231       diag = diag**pow
 10232       do i = 1, n
 10233         M(:,i) = M(:,i)*diag(i)
 10234       end do
 10235       M = matmul(M,transpose(Tmp))
 10236 
 10237   end subroutine Matrix_Root
 10238 
 10239 
 10240    subroutine Matrix_Diagonalize_Partial(M, diag, n, emin,emax, nfound)
 10241   !Real version. Does m = U diag U^dag, returning U in M
 10242   !Assumes up to nfound values will be found. nfound set to true value on exit
 10243       integer, intent(in) :: n
 10244       real(dm), intent(inout):: m(:,:)
 10245       real(dm), intent(out) :: diag(:)
 10246       real(dm), intent(in) :: emin,emax
 10247       integer, intent(inout) :: nfound
 10248       integer ierr, worksize, LIWork
 10249       real(dm), allocatable, dimension(:) :: work
 10250       real(dm), allocatable, dimension(:,:) :: tmp
 10251       integer, allocatable,dimension(:):: supp,iwork
 10252       real(dm) wsize(1)
 10253       real(dm)  atol
 10254       integer ISize(1)
 10255 
 10256       atol = 1d-9
 10257       call Matrix_Start('Matrix_Diagonalize_Partial')
 10258       allocate(tmp(n,nfound))
 10259       allocate(Supp(n))
 10260 !Query
 10261       WorkSize = -1
 10262       LIWork = -1
 10263 !ifdef MATRIX_SINGLE 
 10264       call SSYEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10265                Supp,WSize,WorkSize,ISize,LIWork,ierr  )
 10266 !else     
 10267       call DSYEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10268                Supp,WSize,WorkSize,ISize,LIWork,ierr  )
 10269 !endif
 10270       WorkSize = Real(WSize(1))
 10271       LIWork = ISize(1)
 10272       allocate(Work(WorkSize),IWork(LIWork))
 10273 !ifdef MATRIX_SINGLE 
 10274       call SSYEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10275                Supp,Work,WorkSize,IWork,LIWork,ierr )
 10276 !else
 10277       call DSYEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10278                Supp,Work,WorkSize,IWork,LIWork,ierr )
 10279 !endif
 10280       deallocate(Supp,Work,IWork)
 10281       if (ierr /= 0) call MpiStop('Matrix_Diagonalize_Partial: Error') 
 10282       M(1:n,1:nfound) = tmp(1:n,1:nfound)  !nfound now different
 10283       deallocate(tmp)
 10284       call Matrix_End('Matrix_Diagonalize_Partial')
 10285 
 10286   end subroutine Matrix_Diagonalize_Partial
 10287 
 10288 
 10289    subroutine Matrix_CDiagonalize_Partial(M, diag, n, emin,emax, nfound)
 10290   !Complex version. Does m = U diag U^dag, returning U in M
 10291   !Assumes up to nfound values will be found. nfound set to true value on exit
 10292       integer, intent(in) :: n
 10293       complex(dm), intent(inout):: m(:,:)
 10294       real(dm), intent(out) :: diag(:)
 10295       real(dm), intent(in) :: emin,emax
 10296       integer, intent(inout) :: nfound
 10297       integer ierr, worksize, LRWork, LIWork
 10298       real(dm), allocatable, dimension(:) :: Rwork
 10299       complex(dm), allocatable, dimension(:) :: work
 10300       complex(dm), allocatable, dimension(:,:) :: tmp
 10301       integer, allocatable,dimension(:):: supp,iwork
 10302       complex(dm) wsize(1)
 10303       real(dm) Rsize(1), atol
 10304       integer ISize(1)
 10305 
 10306       atol = 1d-9
 10307       call Matrix_Start('Matrix_CDiagonalize_Partial')
 10308       allocate(tmp(n,nfound))
 10309       allocate(Supp(n))
 10310 !Query
 10311       WorkSize = -1
 10312       LRWork = -1
 10313       LIWork = -1
 10314 !ifdef MATRIX_SINGLE 
 10315       call CHEEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10316                Supp,WSize,WorkSize,RSize,LRWork,ISize,LIWork,ierr  )
 10317 !else     
 10318       call ZHEEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10319                Supp,WSize,WorkSize,RSize,LRWork,ISize,LIWork,ierr  )
 10320 !endif
 10321       WorkSize = Real(WSize(1))
 10322       LRWork = RSize(1)
 10323       LIWork = ISize(1)
 10324       allocate(Work(WorkSize),RWork(LRWork),IWork(LIWork))
 10325 !ifdef MATRIX_SINGLE 
 10326       call CHEEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10327                Supp,Work,WorkSize,RWork,LRWork,IWork,LIWork,ierr )
 10328 !else
 10329       call ZHEEVR('V','V','U',n,M,Size(M,DIM = 1),emin,emax,0,0,atol,nfound,diag,tmp,Size(TMP,DIM = 1),&
 10330                Supp,Work,WorkSize,RWork,LRWork,IWork,LIWork,ierr )
 10331 !endif
 10332       deallocate(Supp,Work,RWork,IWork)
 10333       if (ierr /= 0) call MpiStop('Matrix_CDiagonalize_Partial: Error') 
 10334       M(1:n,1:nfound) = tmp(1:n,1:nfound)  !nfound now different
 10335       deallocate(tmp)
 10336       call Matrix_End('Matrix_CDiagonalize_Partial')
 10337 
 10338 
 10339   end subroutine
 10340 
 10341 
 10342   subroutine Matrix_CDiagonalize(M, diag, n)
 10343   !Complex version. Does m = U diag U^dag, returning U in M
 10344       integer, intent(in) :: n
 10345       complex(dm), intent(inout):: m(n,n)
 10346       real(dm), intent(out) :: diag(n)
 10347       integer ierr, tmpsize ,isize, rworksize
 10348       real(dm), allocatable, dimension(:) :: Rwork
 10349       complex(dm), allocatable, dimension(:) :: tmp
 10350       integer, allocatable,dimension(:):: iwork
 10351       
 10352       call Matrix_Start('CDiagonalize')
 10353 
 10354       if (matrix_method = Mat_DC) then
 10355         !Divide and conquer
 10356           tmpsize = 2*N + N**2 
 10357           rworksize =  1 + 4*N + 2*N*int(log(real(N))/log(2.)+1) + 3*N**2
 10358           isize =  (2 + 5*N)*4
 10359           allocate(tmp(tmpsize),rwork(rworksize))
 10360           allocate(iwork(isize))
 10361 !ifdef MATRIX_SINGLE 
 10362           call CHEEVD('V','U',n,M,n,diag,tmp,tmpsize,Rwork,rworksize,iwork,isize,ierr) !evalues and vectors of hermitian matrix
 10363 !else
 10364           call ZHEEVD('V','U',n,M,n,diag,tmp,tmpsize,Rwork,rworksize,iwork,isize,ierr) !evalues and vectors of hermitian matrix
 10365 !endif
 10366           deallocate(iwork)
 10367       
 10368       else
 10369       
 10370           rworksize =  max(1, 3*n-2)
 10371 !ifdef MATRIX_SINGLE 
 10372           tmpsize = max( (ILAENV_wrap(1,'CHETRD','U',n,n,n,n)+1)*N,max(1,2*n-1)) !   3*n**2
 10373           allocate(tmp(tmpsize),rwork(rworksize));
 10374           call CHEEV('V','U',n,m,n,diag,tmp,tmpsize,Rwork,ierr) !evalues and vectors of hermitian matrix
 10375 !else
 10376           tmpsize = max( (ILAENV_wrap(1,'ZHETRD','U',n,n,n,n)+1)*N,max(1,2*n-1)) !   3*n**2
 10377           allocate(tmp(tmpsize),rwork(rworksize));
 10378           call ZHEEV('V','U',n,m,n,diag,tmp,tmpsize,Rwork,ierr) !evalues and vectors of hermitian matrix
 10379 !endif
 10380       end if
 10381     
 10382       if (ierr /= 0) call MpiStop('Error in Matrix_CDiagonalize')
 10383       deallocate(tmp,rwork)
 10384       
 10385    call Matrix_End('CDiagonalize')
 10386   
 10387   end subroutine Matrix_CDiagonalize
 10388 
 10389   function Matrix_CTrace(M)
 10390     complex(dm), intent(in) :: M(:,:)
 10391     complex(dm) tmp,Matrix_CTrace
 10392     integer i
 10393 
 10394     if (size(M,dim = 1) /= size(M,dim = 2)) call MpiStop('Matrix_CTrace: non-square matrix')
 10395     tmp = 0
 10396     do i = 1,size(M,dim =1)
 10397      tmp = tmp + M(i,i)  
 10398     end do
 10399     Matrix_CTrace = tmp
 10400 
 10401   end function Matrix_CTrace
 10402   
 10403   function Matrix_Trace(M)
 10404     real(dm), intent(in) :: M(:,:)
 10405     real(dm) tmp,Matrix_Trace
 10406     integer i
 10407 
 10408     if (size(M,dim = 1) /= size(M,dim = 2)) call mpiStop('Matrix_Trace: non-square matrix')
 10409     tmp = 0
 10410     do i = 1,size(M,dim =1)
 10411      tmp = tmp + M(i,i)  
 10412     end do
 10413     Matrix_Trace = tmp
 10414 
 10415   end function Matrix_Trace
 10416 
 10417 
 10418  function MatrixSym_LogDet(mat) result (logDet)
 10419   real(dm), intent(in) :: mat(:,:)
 10420   real(dm) logDet
 10421   real(dm) Tmp(size(mat,dim = 1),size(mat,dim = 1))
 10422   integer i
 10423   
 10424   if (size(mat,dim = 1) /= size(mat,dim = 2)) call mpiStop('MatrixSym_LogDet: non-square matrix')
 10425   Tmp = mat
 10426   call Matrix_Cholesky(tmp)
 10427   logDet = 0
 10428   do i = 1, size(mat,dim =1)
 10429    logDet = logDet  + log(tmp(i,i))
 10430   end do
 10431   logDet = 2._dm*logDet
 10432   
 10433  end function MatrixSym_LogDet
 10434 
 10435   
 10436    subroutine Matrix_CRotateSymm(Mat,U,m,Out,triangular)
 10437     !Gets U^dag Mat U
 10438      integer, intent(in) ::m
 10439      complex(dm), intent(in) :: Mat(:,:),U(:,:)
 10440      complex(dm) Out(:,:) 
 10441      complex(dm), dimension(:,:), allocatable :: C
 10442      integer n
 10443      logical, intent(in), optional :: triangular
 10444      logical :: triang
 10445 
 10446       call Matrix_Start('CRotateSymm')
 10447       
 10448       if (present(triangular)) then
 10449        triang = triangular
 10450       else
 10451        triang = .false.
 10452       end if
 10453       
 10454      n = Size(Mat,DIM = 1)
 10455      if (n /= Size(Mat,DIM = 2)) call mpiStop('Matrix_CRotateSymm: Need square matrix')
 10456      if (n /= Size(U,DIM = 1)) call MpiStop('Matrix_CRotateSymm: Matrix size mismatch')
 10457      if (Size(Out,DIM = 1) < m .or. Size(Out,DIM = 2) < m) &
 10458                 call MpiStop('Matrix_CRotateSymm: Wrong output size')
 10459 
 10460       if (matrix_method = Mat_F90) then
 10461           Out = matmul(matmul(transpose(conjg(U(1:n,1:m))),Mat),U(1:n,1:m))
 10462       else
 10463 !ifdef MATRIX_SINGLE   
 10464           if (triang) then
 10465             if (m/= n) call MpiStop('Matrix_CRotateSymm: Matrices must be same size')
 10466             call CHEMM('L','U',n,n,COne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),CZero,Out,Size(Out,Dim=1))
 10467             call CTRMM('Left','Upper','Complex-Transpose','Not-unit',n,n,COne,U,Size(U,DIM = 1),Out,Size(Out,Dim = 1))
 10468           else       
 10469            allocate(C(n,m))
 10470            call CHEMM('L','U',n,m,COne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),CZero,C,n)
 10471            call CGEMM('C','N',m,m,n,COne,U,Size(U,DIM = 1),C,n,CZero,Out,Size(Out,Dim = 1))
 10472            deallocate(C)
 10473           end if
 10474 !else
 10475           if (triang) then
 10476             if (m/= n) call MpiStop('Matrix_CRotateSymm: Matrices must be same size')
 10477             call ZHEMM('L','U',n,n,COne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),CZero,Out,Size(Out,Dim=1))
 10478             call ZTRMM('Left','Upper','Complex-Transpose','Not-unit',n,n,COne,U,Size(U,DIM = 1),Out,Size(Out,Dim = 1))
 10479           else 
 10480            allocate(C(n,m))
 10481            call ZHEMM('L','U',n,m,COne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),CZero,C,n)
 10482            call ZGEMM('C','N',m,m,n,COne,U,Size(U,DIM = 1),C,n,CZero,Out,Size(Out,Dim = 1))
 10483            deallocate(C)
 10484           end if
 10485 !endif
 10486       end if
 10487    call Matrix_End('CRotateSymm')
 10488 
 10489             
 10490    end subroutine Matrix_CRotateSymm
 10491 
 10492    subroutine Matrix_RotateSymm(Mat,U,m,Out, triangular)
 10493     !Gets U^T Mat U
 10494     !If triangular U = Upper triangular (U^T lower triangular)
 10495      integer, intent(in) ::m
 10496      real(dm), intent(in) :: Mat(:,:),U(:,:)
 10497      real(dm) Out(:,:) 
 10498      real(dm), dimension(:,:), allocatable :: C
 10499      logical, intent(in), optional :: triangular
 10500      logical triang
 10501      integer n
 10502 
 10503       call Matrix_Start('RotateSymm')
 10504       
 10505       if (present(triangular)) then
 10506        triang = triangular
 10507       else
 10508        triang = .false.
 10509       end if
 10510 
 10511      n = Size(Mat,DIM = 1)
 10512      if (n /= Size(Mat,DIM = 2)) call MpiStop('Matrix_RotateSymm: Need square matrix')
 10513      if (n /= Size(U,DIM = 1)) call MpiStop('Matrix_RotateSymm: Matrix size mismatch')
 10514      if (Size(Out,DIM = 1) < m .or. Size(Out,DIM = 2) < m) &
 10515                 call MpiStop('Matrix_RotateSymm: Wrong output size')
 10516 
 10517       if (matrix_method = Mat_F90) then
 10518           Out = matmul(matmul(transpose(U(1:n,1:m)),Mat),U(1:n,1:m))
 10519       else
 10520 !ifdef MATRIX_SINGLE             
 10521           if (triang) then
 10522             if (m/= n) call MpiStop('Matrix_RotateSymm: Matrices must be same size')
 10523             call SSYMM('L','U',n,n,ROne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),RZero,Out,Size(Out,Dim=1))
 10524             call STRMM('Left','Upper','Transpose','Not-unit',n,n,ROne,U,Size(U,DIM = 1),Out,Size(Out,Dim = 1))
 10525           else
 10526            allocate(C(n,m))
 10527            call SSYMM('L','U',n,m,ROne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),RZero,C,n)
 10528            call SGEMM('T','N',m,m,n,ROne,U,Size(U,DIM = 1),C,n,RZero,Out,Size(Out,Dim = 1))
 10529            deallocate(C)
 10530           end if
 10531 !else
 10532           if (triang) then
 10533             if (m/= n) call MpiStop('Matrix_RotateSymm: Matrices must be same size')
 10534             call DSYMM('L','U',n,n,ROne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),RZero,Out,Size(Out,Dim=1))
 10535             call DTRMM('Left','Upper','Transpose','Not-unit',n,n,ROne,U,Size(U,DIM = 1),Out,Size(Out,Dim = 1))
 10536           else
 10537             allocate(C(n,m))
 10538             call DSYMM('L','U',n,m,ROne,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),RZero,C,n)
 10539             call DGEMM('T','N',m,m,n,ROne,U,Size(U,DIM = 1),C,n,RZero,Out,Size(Out,Dim = 1))
 10540             deallocate(C)
 10541           end if
 10542 !endif
 10543       end if
 10544    call Matrix_End('RotateSymm')
 10545 
 10546             
 10547    end subroutine Matrix_RotateSymm
 10548 
 10549 
 10550    subroutine Matrix_RotateAntiSymm(Mat,U,m,Out)
 10551     !Gets U^T Mat U
 10552     !Where Mat = -Mat^T
 10553      integer, intent(in) ::m
 10554      real(dm), intent(in) :: Mat(:,:),U(:,:)
 10555      real(dm) Out(:,:) 
 10556      real(dm), dimension(:,:), allocatable :: C
 10557      integer i,j,n
 10558 
 10559      call Matrix_Start('RotateAntiSymm')
 10560       
 10561      n = Size(Mat,DIM = 1)
 10562      if (n /= Size(Mat,DIM = 2)) call MpiStop('Matrix_RotateAntiSymm: Need square matrix')
 10563      if (n /= Size(U,DIM = 1)) call MpiStop('Matrix_RotateAntiSymm: Matrix size mismatch')
 10564      if (Size(Out,DIM = 1) < m .or. Size(Out,DIM = 2) < m) &
 10565                 call MpiStop('Matrix_RotateAntiSymm: Wrong output size')
 10566 
 10567      if (matrix_method = Mat_F90) then
 10568           Out = matmul(matmul(transpose(U(1:n,1:m)),Mat),U(1:n,1:m))
 10569       else
 10570            allocate(C(n,m))
 10571            C = U(1:n,1:m)
 10572 !ifdef MATRIX_SINGLE             
 10573            call STRMM('Left','Lower','Not-Transpose','Not-unit',n,m,ROne,Mat,Size(Mat,DIM = 1),C,Size(C,Dim = 1))
 10574            call SGEMM('T','N',m,m,n,ROne,U,Size(U,DIM = 1),C,n,RZero,Out,Size(Out,Dim = 1))
 10575 !else
 10576            call DTRMM('Left','Lower','Not-Transpose','Not-unit',n,m,ROne,Mat,Size(Mat,DIM = 1),C,Size(C,Dim = 1))
 10577            call DGEMM('T','N',m,m,n,ROne,U,Size(U,DIM = 1),C,n,RZero,Out,Size(Out,Dim = 1))
 10578 !endif
 10579            deallocate(C)
 10580       end if
 10581            
 10582     do i = 1, m
 10583      do j = 1,i
 10584       Out(j,i) = Out(j,i) - Out(i,j)
 10585       out(i,j) = -Out(j,i)
 10586      end do
 10587     end do  
 10588            
 10589    call Matrix_End('RotateAntiSymm')
 10590             
 10591    end subroutine Matrix_RotateAntiSymm
 10592 
 10593   subroutine Matrix_CMult_SymmRight(Mat,U,Out,a,b)
 10594    complex(dm), intent(in) :: Mat(:,:),U(:,:)
 10595    complex(dm) Out(:,:) 
 10596    complex(dm), intent(in), optional :: a,b
 10597    complex(dm)  mult, beta 
 10598    integer n,m
 10599 
 10600     call Matrix_Start('CMult_SymmRight')
 10601 
 10602      m = Size(Mat,DIM = 1)
 10603      n = Size(U,DIM = 2)
 10604      if (n /= Size(Mat,DIM = 2) .or. n/= Size(U,DIM = 1)) &
 10605               call MpiStop('Matrix_CMult_SymmRight: Size mismatch')
 10606      if (present(a)) then
 10607        mult = a
 10608      else
 10609        mult = COne
 10610      end if
 10611      if (present(b)) then
 10612        beta = b    
 10613      else
 10614        beta = CZero
 10615      end if
 10616      if (matrix_method = Mat_F90) then
 10617       if (beta /= CZero) then
 10618        out = a*MatMul(Mat,U) + beta*Out
 10619       else
 10620        out = MatMul(Mat,U)
 10621        if (mult /= COne) Out = Out*mult
 10622       end if     
 10623      else 
 10624 !ifdef MATRIX_SINGLE 
 10625       call CHEMM('R','U',m,n,mult,U,Size(U,DIM = 1),Mat,Size(Mat,DIM = 1),beta,Out,Size(Out,DIM=1))
 10626 !else     
 10627       call ZHEMM('R','U',m,n,mult,U,Size(U,DIM = 1),Mat,Size(Mat,DIM = 1),beta,Out,Size(Out,DIM=1))
 10628 !endif
 10629      end if
 10630 
 10631     call Matrix_End('CMult_SymmRight')
 10632 
 10633   end subroutine Matrix_CMult_SymmRight
 10634 
 10635  
 10636   subroutine Matrix_CMult_SymmLeft(Mat,U,Out,a,b)
 10637    complex(dm), intent(in) :: Mat(:,:),U(:,:)
 10638    complex(dm) Out(:,:) 
 10639    complex(dm), intent(in), optional :: a,b
 10640    complex(dm)  mult, beta 
 10641    integer n,m
 10642 
 10643     call Matrix_Start('CMult_SymmLeft')
 10644 
 10645      m = Size(Mat,DIM = 1)
 10646      n = Size(U,DIM = 2)
 10647      if (m /= Size(U,DIM = 1) .or. m/= Size(Mat,DIM = 2)) &
 10648               call MpiStop('Matrix_CMult_SymmLeft: Size mismatch')
 10649      if (present(a)) then
 10650        mult = a
 10651      else
 10652        mult = COne
 10653      end if
 10654      if (present(b)) then
 10655        beta = b    
 10656      else
 10657        beta = CZero
 10658      end if
 10659      if (matrix_method = Mat_F90) then
 10660       if (beta /= CZero) then
 10661        out = a*MatMul(Mat,U) + beta*Out
 10662       else
 10663        out = MatMul(Mat,U)
 10664        if (mult /= COne) Out = Out*mult
 10665       end if     
 10666      else 
 10667 !ifdef MATRIX_SINGLE
 10668       call CHEMM('L','U',m,n,mult,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),beta,Out,Size(Out,DIM=1))
 10669 !else     
 10670       call ZHEMM('L','U',m,n,mult,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),beta,Out,Size(Out,DIM=1))
 10671 !endif
 10672      end if
 10673 
 10674     call Matrix_End('CMult_SymmLeft')
 10675 
 10676   end subroutine Matrix_CMult_SymmLeft
 10677 
 10678 
 10679   subroutine Matrix_CMult(Mat,U,Out,a,b)
 10680    ! Out = a*Mat U + b*out
 10681    complex(dm), intent(in) :: Mat(:,:),U(:,:)
 10682    complex(dm) Out(:,:) 
 10683    complex(dm), intent(in), optional :: a,b
 10684    complex(dm)  mult, beta 
 10685    integer m,n,k
 10686 
 10687      call Matrix_Start('CMult')
 10688 
 10689      m = Size(Mat,DIM = 1)
 10690      n = Size(U,DIM = 2)
 10691      k = Size(Mat,DIM = 2)
 10692      if (k /= Size(U,DIM = 1)) call MpiStop('Matrix_Mult: Matrix size mismatch')
 10693      if (present(a)) then
 10694        mult = a
 10695      else
 10696        mult = COne
 10697      end if
 10698      if (present(b)) then
 10699        beta = b    
 10700      else
 10701        beta = CZero
 10702      end if
 10703   
 10704      if (matrix_method = Mat_F90) then
 10705       if (beta /= CZero) then
 10706        out = a*MatMul(Mat,U) + beta*Out
 10707       else
 10708        out = MatMul(Mat,U)
 10709        if (mult /= COne) Out = Out*mult
 10710       end if     
 10711      else
 10712 !ifdef MATRIX_SINGLE
 10713        call CGEMM('N','N',m,n,k,mult,Mat,m,U,k,beta,Out,Size(Out,Dim = 1))
 10714 !else
 10715        call ZGEMM('N','N',m,n,k,mult,Mat,m,U,k,beta,Out,Size(Out,Dim = 1))
 10716 !endif
 10717      end if
 10718      call Matrix_End('CMult')
 10719 
 10720 
 10721  end subroutine Matrix_CMult
 10722 
 10723 
 10724   subroutine Matrix_MultSq_RepRight(Mat,U,a)
 10725    !U = a*Mat*U
 10726    real(dm), intent(in) :: Mat(:,:)
 10727    real(dm), intent(inout) ::U(:,:)
 10728    real(dm), intent(in), optional :: a
 10729    real(dm) aa
 10730    integer m,n
 10731    real(dm), dimension(:,:), allocatable :: tmp
 10732 
 10733 
 10734    m = Size(Mat,DIM = 1)
 10735    n = Size(Mat,DIM = 2)
 10736    if (m /= n) call MpiStop('Matrix_MultSq: Matrix size mismatch')
 10737    m = Size(U,DIM = 1)
 10738    n = Size(U,DIM = 2)
 10739    if (m /= n) call MpiStop('Matrix_MultSq: Matrix size mismatch')
 10740    
 10741    allocate(tmp(n,n))
 10742    if (present(a)) then
 10743     aa = a
 10744    else
 10745     aa = ROne
 10746    end if 
 10747    
 10748    call Matrix_Mult(Mat,U,tmp,aa)
 10749    U = tmp
 10750    deallocate(tmp)
 10751 
 10752    end  subroutine Matrix_MultSq_RepRight
 10753 
 10754   subroutine Matrix_MultTri(Mat,L, side)
 10755    ! Mat -> L Mat or Mat L where L is lower triangular
 10756    real(dm), intent(inout) :: Mat(:,:)
 10757    real(dm), intent(in) :: L(:,:) 
 10758    character(LEN = *), intent(in) :: side
 10759    integer m,n
 10760 
 10761      call Matrix_Start('Matrix_MultTri')
 10762     
 10763      m = Size(Mat,DIM = 1)
 10764      n = Size(Mat,DIM = 2)
 10765      
 10766      if (side(1:1) = 'L') then
 10767       if (Size(L,DIM = 2) /= m) call MpiStop('Matrix_MultTri: Matrix size mismatch')
 10768      else
 10769       if (Size(L,DIM = 1) /= n) call MpiStop('Matrix_MultTri: Matrix size mismatch')
 10770      end if
 10771 !ifdef MATRIX_SINGLE
 10772      call STRMM(side,'Lower','Not-Transpose','Not-unit',m,n,ROne,L,Size(L,DIM = 1),Mat,Size(Mat,Dim = 1))
 10773 !else
 10774      call DTRMM(side,'Lower','Not-Transpose','Not-unit',m,n,ROne,L,Size(L,DIM = 1),Mat,Size(Mat,Dim = 1))
 10775 !endif
 10776      call Matrix_End('Matrix_MultTri')
 10777 
 10778    end subroutine Matrix_MultTri
 10779 
 10780      
 10781 
 10782   subroutine Matrix_Mult(Mat,U,Out,a,b)
 10783    ! Out = a*Mat U + b*out
 10784    real(dm), intent(in) :: Mat(:,:),U(:,:)
 10785    real(dm) :: Out(:,:) 
 10786    real(dm), intent(in), optional :: a,b
 10787    real(dm)  mult, beta 
 10788    integer m,n,k
 10789 
 10790      call Matrix_Start('Mult')
 10791     
 10792 
 10793      m = Size(Mat,DIM = 1)
 10794      n = Size(U,DIM = 2)
 10795      k = Size(Mat,DIM = 2)
 10796      if (k /= Size(U,DIM = 1)) call MpiStop('Matrix_Mult: Matrix size mismatch')
 10797 
 10798 
 10799      if (present(a)) then
 10800        mult = a
 10801      else
 10802        mult = ROne
 10803      end if
 10804      if (present(b)) then
 10805        beta = b    
 10806      else
 10807        beta = RZero
 10808      end if
 10809   
 10810      if (matrix_method = Mat_F90) then
 10811       if (beta /= RZero) then
 10812        out = a*MatMul(Mat,U) + beta*Out
 10813       else
 10814        out = MatMul(Mat,U)
 10815        if (mult /= ROne) Out = Out*mult
 10816       end if     
 10817      else
 10818 !ifdef MATRIX_SINGLE
 10819        call SGEMM('N','N',m,n,k,mult,Mat,m,U,k,beta,Out,Size(Out,Dim = 1))
 10820 !else     
 10821        call DGEMM('N','N',m,n,k,mult,Mat,m,U,k,beta,Out,Size(Out,Dim = 1))
 10822 !endif
 10823      end if
 10824      call Matrix_End('Mult')
 10825 
 10826 
 10827  end subroutine Matrix_Mult
 10828 
 10829   subroutine Matrix_Mult_SymmLeft(Mat,U,Out,a,b)
 10830    real(dm), intent(in) :: Mat(:,:),U(:,:)
 10831    real(dm) Out(:,:) 
 10832    real(dm), intent(in), optional :: a,b
 10833    real(dm)  mult, beta 
 10834    integer n,m
 10835 
 10836     call Matrix_Start('Mult_SymmLeft')
 10837 
 10838      m = Size(Mat,DIM = 1)
 10839      n = Size(U,DIM = 2)
 10840      if (m /= Size(U,DIM = 1) .or. m/= Size(Mat,DIM = 2)) &
 10841               call MpiStop('Matrix_Mult_SymmLeft: Size mismatch')
 10842      if (present(a)) then
 10843        mult = a
 10844      else
 10845        mult = ROne
 10846      end if
 10847      if (present(b)) then
 10848        beta = b    
 10849      else
 10850        beta = RZero
 10851      end if
 10852      if (matrix_method = Mat_F90) then
 10853       if (beta /= RZero) then
 10854        out = a*MatMul(Mat,U) + beta*Out
 10855       else
 10856        out = MatMul(Mat,U)
 10857        if (mult /= COne) Out = Out*mult
 10858       end if     
 10859      else 
 10860 !ifdef MATRIX_SINGLE
 10861       call SSYMM('L','U',m,n,mult,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),beta,Out,Size(Out,DIM=1))
 10862 !else     
 10863       call DSYMM('L','U',m,n,mult,Mat,Size(Mat,DIM = 1),U,Size(U,DIM = 1),beta,Out,Size(Out,DIM=1))
 10864 !endif
 10865      end if
 10866 
 10867     call Matrix_End('Mult_SymmLeft')
 10868 
 10869   end subroutine Matrix_Mult_SymmLeft
 10870 
 10871 
 10872   subroutine Matrix_Mult_SymmRight(Mat,U,Out,a,b)
 10873    ! Out = a*Mat U + b*out
 10874     real(dm), intent(in) :: Mat(:,:),U(:,:)
 10875    real(dm) Out(:,:) 
 10876    real(dm), intent(in), optional :: a,b
 10877    real(dm)  mult, beta 
 10878    integer n,m
 10879 
 10880     call Matrix_Start('Mult_SymmRight')
 10881 
 10882      m = Size(Mat,DIM = 1)
 10883      n = Size(U,DIM = 2)
 10884      if (n /= Size(Mat,DIM = 2) .or. n/= Size(U,DIM = 1)) &
 10885               call MpiStop('Matrix_Mult_SymmRight: Size mismatch')
 10886      if (present(a)) then
 10887        mult = a
 10888      else
 10889        mult = ROne
 10890      end if
 10891      if (present(b)) then
 10892        beta = b    
 10893      else
 10894        beta = RZero
 10895      end if
 10896      if (matrix_method = Mat_F90) then
 10897       if (beta /= RZero) then
 10898        out = a*MatMul(Mat,U) + beta*Out
 10899       else
 10900        out = MatMul(Mat,U)
 10901        if (mult /= ROne) Out = Out*mult
 10902       end if     
 10903      else 
 10904 !ifdef MATRIX_SINGLE
 10905       call SSYMM('R','U',m,n,mult,U,Size(U,DIM = 1),Mat,Size(Mat,DIM = 1),beta,Out,Size(Out,DIM=1))
 10906 !else     
 10907       call DSYMM('R','U',m,n,mult,U,Size(U,DIM = 1),Mat,Size(Mat,DIM = 1),beta,Out,Size(Out,DIM=1))
 10908 !endif
 10909      end if
 10910 
 10911     call Matrix_End('Mult_SymmRight')
 10912 
 10913   end subroutine Matrix_Mult_SymmRight
 10914 
 10915 
 10916   subroutine Matrix_CMultGen(Mat,m,k,U,n,Out)
 10917    !     out(1:m,1:n) = MatMul(Mat(1:m,1:k),U(1:k,1:n))
 10918    integer, intent(in) :: m,k,n
 10919    complex(dm), intent(in) :: Mat(:,:),U(:,:)
 10920    complex(dm) Out(:,:) 
 10921  
 10922      call Matrix_Start('CMultGen')
 10923 
 10924      if (SIZE(Out,DIM = 1) m. ')
 11510   
 11511    call Matrix_Start('SVD_VT')
 11512  
 11513     if (present(U) .and. Matrix_method = Mat_DC) then
 11514     !Use divide and conquer
 11515      allocate(IWork(8*MIN(M,N))) 
 11516      WorkSize = -1 !3*min(M,N)*min(M,N) +max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N))
 11517 !ifdef MATRIX_SINGLE
 11518      call SGESDD('O',m,n, Mat, m ,D,U,m,Mat,n,OptWk,WorkSize,IWork,ierr) 
 11519 !else     
 11520      call DGESDD('O',m,n, Mat, m ,D,U,m,Mat,n,OptWk,WorkSize,IWork,ierr) 
 11521 !endif
 11522      WorkSize = nint(OptWk)
 11523      allocate(rv1(WorkSize))   
 11524 !ifdef MATRIX_SINGLE
 11525      call SGESDD('O',m,n, Mat, m ,D,U,m,Mat,n,rv1,WorkSize,IWork,ierr) 
 11526 !else     
 11527      call DGESDD('O',m,n, Mat, m ,D,U,m,Mat,n,rv1,WorkSize,IWork,ierr) 
 11528 !endif
 11529      deallocate(IWOrk)
 11530     else
 11531        call MpiStop('Matrix_SVD_VT Not no-U non-DC case')
 11532     end if
 11533    
 11534    if (ierr/= 0) call MpiStop('error in Matrix_SVD_VT')
 11535    deallocate(rv1)
 11536 
 11537    call Matrix_End('SVD_VT')
 11538 
 11539   end subroutine Matrix_SVD_VT
 11540 
 11541  
 11542   subroutine Matrix_CSVD_VT(Mat,m, n, D, U)
 11543    !Do singular value decomposition of m x n matrix Mat
 11544    !Mat =  U D V^dag
 11545    !returns V^dag in Mat, vector D of diagonal elements of, unitary matrix U  
 11546    integer, intent(in) :: m,n
 11547    complex(dm), intent(inout) :: Mat(m,n)
 11548    complex(dm), intent(out),optional :: U(m,m)
 11549    real(dm), intent(out) :: D(*)
 11550 
 11551    integer WorkSize, ierr
 11552    integer,allocatable, dimension (:) :: IWork
 11553    complex(dm), allocatable, dimension (:) :: rv1 
 11554    real(dm), allocatable, dimension (:) :: rwork
 11555 
 11556    if (n< = m) call MpiStop('Matrix_CSVD_VT assumed n>m. If equal use SVD_U.')
 11557   
 11558    call Matrix_Start('CSVD_VT')
 11559   
 11560  
 11561     if (present(U) .and. Matrix_method = Mat_DC) then
 11562     !Use divide and conquer
 11563      WorkSize = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N) + 5*N !Add on 5N.. 
 11564      allocate(rv1(WorkSize))   
 11565      allocate(rwork(5*min(M,N)*min(M,N) + 5*min(M,N) ))
 11566      allocate(IWork(8*MIN(M,N))) 
 11567 !ifdef MATRIX_SINGLE
 11568      call CGESDD('O',m,n, Mat, m ,D,U,m,Mat,n,rv1,WorkSize,rwork,IWork,ierr) 
 11569 !else     
 11570      call ZGESDD('O',m,n, Mat, m ,D,U,m,Mat,n,rv1,WorkSize,rwork,IWork,ierr) 
 11571 !endif
 11572      deallocate(IWOrk)
 11573     else
 11574  
 11575        allocate(rwork((max(3*min(m,n),5*min(m,n)-4))))
 11576        WorkSize = 3*max(m,n)**2
 11577        allocate(rv1(WorkSize), STAT = ierr)
 11578        if (ierr /= 0) then
 11579         WorkSize = MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N))
 11580         allocate(rv1(WorkSize))
 11581        end if
 11582 !ifdef MATRIX_SINGLE
 11583        if (present(U)) then
 11584         call CGESVD('S','O',m,n, Mat, m , D,U,m,Mat,n,rv1,WorkSize,rwork,ierr) 
 11585        else
 11586         call CGESVD('N','O',m,n, Mat, m , D,Mat,m,Mat,n,rv1,WorkSize,rwork,ierr) 
 11587        end if
 11588 !else
 11589        if (present(U)) then
 11590         call ZGESVD('S','O',m,n, Mat, m , D,U,m,Mat,n,rv1,WorkSize,rwork,ierr) 
 11591        else
 11592         call ZGESVD('N','O',m,n, Mat, m , D,Mat,m,Mat,n,rv1,WorkSize,rwork,ierr) 
 11593        end if
 11594 !endif       
 11595     end if
 11596   
 11597    if (ierr/= 0) call MpiStop('error in Matrix_SVD_VT')
 11598    deallocate(rv1)
 11599 
 11600    call Matrix_End('SVD_VT')
 11601 
 11602   end subroutine Matrix_CSVD_VT
 11603 
 11604     subroutine Matrix_CSVD_U(Mat,m, n, D, VT)
 11605    !Do singular value decomposition of m x n matrix Mat
 11606    !Mat =  U D VT
 11607    !returns U in Mat, vector D of diagonal elements of, unitary matrix V  
 11608    integer, intent(in) :: m,n
 11609    complex(dm), intent(inout) :: Mat(m,n)
 11610    complex(dm), intent(out),optional :: VT(n,n)
 11611    real(dm), intent(out) :: D(*)
 11612    integer WorkSize, ierr
 11613    integer,allocatable, dimension (:) :: IWork
 11614    complex(dm), allocatable, dimension (:) :: rv1 
 11615    real(dm), allocatable, dimension (:) :: rwork
 11616 
 11617    call Matrix_Start('CSVD_U')
 11618 
 11619    if (m = n')
 11620  
 11621     if (present(VT) .and. Matrix_method = Mat_DC) then
 11622      WorkSize = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N) + 5*N !Add on 5N.. 
 11623      allocate(rv1(WorkSize))   
 11624      allocate(rwork(5*min(M,N)*min(M,N) + 5*min(M,N) ))
 11625      allocate(IWork(8*MIN(M,N))) 
 11626 !ifdef MATRIX_SINGLE
 11627      call CGESDD('O',m,n, Mat, m ,D,Mat,m,VT,n,rv1,WorkSize,rwork,IWork,ierr) 
 11628 !else
 11629      call ZGESDD('O',m,n, Mat, m ,D,Mat,m,VT,n,rv1,WorkSize,rwork,IWork,ierr) 
 11630 !endif
 11631      deallocate(IWOrk)
 11632     else
 11633       allocate(rwork((max(3*min(m,n),5*min(m,n)-4))))
 11634 
 11635       WorkSize = 3*max(m,n)**2
 11636       allocate(rv1(WorkSize), STAT = ierr)
 11637       if (ierr /= 0) then
 11638         WorkSize = MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N))
 11639         allocate(rv1(WorkSize))
 11640       end if
 11641 !ifdef MATRIX_SINGLE
 11642      if (present(VT)) then
 11643       call CGESVD('O','S',m,n, Mat, m , D,Mat,m,VT,n,rv1,WorkSize,rwork,ierr) 
 11644      else
 11645       call CGESVD('O','N',m,n, Mat, m , D,Mat,m,Mat,n,rv1,WorkSize,rwork,ierr) 
 11646      end if
 11647 !else
 11648      if (present(VT)) then
 11649       call ZGESVD('O','S',m,n, Mat, m , D,Mat,m,VT,n,rv1,WorkSize,rwork,ierr) 
 11650      else
 11651       call ZGESVD('O','N',m,n, Mat, m , D,Mat,m,Mat,n,rv1,WorkSize,rwork,ierr) 
 11652      end if
 11653 !endif  
 11654     end if
 11655     if (ierr/= 0) call MpiStop('error in Matrix_SVD_U')
 11656     call Matrix_End('CSVD_U')
 11657 
 11658    deallocate(rv1,rwork)
 11659 
 11660   end subroutine Matrix_CSVD_U
 11661 
 11662 
 11663   subroutine Matrix_CSVD_AllVT(Mat,m, n, D, VT)
 11664    !n>m
 11665    !Do singular value decomposition of m x n matrix Mat
 11666    !Mat =  U D V^dag
 11667    !returns all nxn V^dag in VT, vector D of diagonal elements of
 11668    integer, intent(in) :: m,n
 11669    complex(dm), intent(inout) :: Mat(m,n)
 11670    complex(dm), intent(out):: VT(n,n)
 11671    real(dm), intent(out) :: D(m)
 11672    
 11673    integer WorkSize, ierr
 11674    complex(dm), allocatable, dimension (:) :: rv1 
 11675    complex(dm), allocatable, dimension (:,:) :: U
 11676    integer, allocatable, dimension(:) :: IWork
 11677    real(dm), allocatable, dimension (:) :: rwork
 11678 
 11679   
 11680    call Matrix_Start('CSVD_AllVT')
 11681    
 11682    if (Matrix_method = Mat_DC) then
 11683    !Divide and conquer doesn't seem to provide outputs we want here
 11684      WorkSize = 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N) + 5*N !Add on 5N.. 
 11685      allocate(rv1(WorkSize))   
 11686      allocate(rwork(5*min(M,N)*min(M,N) + 5*min(M,N) ))
 11687      allocate(IWork(8*MIN(M,N))) 
 11688      allocate(U(m,m))
 11689 !ifdef MATRIX_SINGLE
 11690      call CGESDD('A',m,n, Mat, m ,D,U,m,VT,n,rv1,WorkSize,rwork,IWork,ierr) 
 11691 !else     
 11692      call ZGESDD('A',m,n, Mat, m ,D,U,m,VT,n,rv1,WorkSize,rwork,IWork,ierr) 
 11693 !endif
 11694      deallocate(U)
 11695      deallocate(IWork)
 11696 
 11697    else
 11698     WorkSize =  2*m*n + 2*max(n,m)
 11699     allocate(rwork(5*max(m,n)))
 11700     allocate(rv1(WorkSize), STAT = ierr)
 11701     if (ierr /= 0) then
 11702      WorkSize = MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N))
 11703      allocate(rv1(WorkSize))
 11704     end if
 11705 !ifdef MATRIX_SINGLE
 11706     call CGESVD('N','A',m,n, Mat, m , D,Mat,m,VT,n,rv1,WorkSize,rwork,ierr) 
 11707 !else    
 11708     call ZGESVD('N','A',m,n, Mat, m , D,Mat,m,VT,n,rv1,WorkSize,rwork,ierr) 
 11709 !endif    
 11710     end if
 11711   
 11712    if (ierr/= 0) call MpiStop('error in Matrix_SVD_AllVT')
 11713    deallocate(rv1,rwork)
 11714 
 11715    call Matrix_End('CSVD_AllVT')
 11716 
 11717 
 11718   end subroutine Matrix_CSVD_allVT
 11719 
 11720 
 11721   subroutine Matrix_DiagPreMul(D,M)
 11722    ! M -> matmul(diag(D),M)
 11723    real(dm), intent(inout) :: M(:,:)
 11724    real(dm), intent(in) :: D(:)
 11725    integer i
 11726 
 11727    if (Size(D) /= SiZE(M,DIM = 1)) call MpiStop('Matrix_DiagPreMul: Wrong size')
 11728    do i = 1, size(D)
 11729      M(i,:) = M(i,:)*D(i)
 11730    end do
 11731 
 11732   end subroutine Matrix_DiagPreMul
 11733 
 11734 
 11735   subroutine Matrix_SolveSymm(M,a,soln)
 11736      real(dm), intent(out) :: soln(:)
 11737      real(dm), intent(in):: M(:,:),a(:)
 11738      integer IPIV(size(a)),info
 11739      real(dm), dimension(:,:), allocatable :: tmp
 11740      real(dm), dimension(:), allocatable :: work
 11741      integer n, WorkSize
 11742 
 11743      n = Size(M,DIM =1)
 11744      if (n< = 1) return
 11745      if (Size(M,DIM = 2)/= n) call MpiStop('Matrix_SolveSq: non-square matrix')
 11746      call Matrix_Start('SolveSymm')
 11747 
 11748 
 11749      WorkSize = n**2
 11750      allocate(work(WorkSize))
 11751      allocate(tmp(n,n))
 11752      tmp = M
 11753 !ifdef MATRIX_SINGLE
 11754      call SSYTRF('U',n,tmp,n,IPIV, work,WorkSize,info)
 11755 !else     
 11756      call DSYTRF('U',n,tmp,n,IPIV, work,WorkSize,info)
 11757 !endif
 11758      deallocate(work)
 11759      if (info/= 0) call MpiStop('error in SolveSymm')
 11760      soln(1:n) = a(1:n)
 11761 !ifdef MATRIX_SINGLE
 11762      call SSYTRS('U',n,1,tmp,n,IPIV,soln,n,info)
 11763 !else
 11764      call DSYTRS('U',n,1,tmp,n,IPIV,soln,n,info)
 11765 !endif
 11766      if (info/= 0) call MpiStop('error (2) in SolveSymm')
 11767      deallocate(tmp)
 11768       
 11769      call Matrix_End('SolveSymm')
 11770 
 11771 
 11772   end subroutine Matrix_SolveSymm
 11773 
 11774   
 11775   subroutine Matrix_SolveASymm(M,a,soln)
 11776      real(dm), intent(out) :: soln(:)
 11777      real(dm), intent(in):: M(:,:),a(:)
 11778      integer IPIV(size(a)),info
 11779      real(dm), dimension(:,:), allocatable :: tmp
 11780      integer n
 11781 
 11782      n = Size(M,DIM =1)
 11783      if (n< = 1) return
 11784      if (Size(M,DIM = 2)/= n) call MpiStop('Matrix_SolveSq: non-square matrix')
 11785 
 11786      call Matrix_Start('SolveASymm')
 11787 
 11788      allocate(tmp(n,n))
 11789      tmp = M
 11790 !ifdef MATRIX_SINGLE
 11791      call SGETRF(n,n,tmp,n,IPIV, info)
 11792 !else
 11793      call DGETRF(n,n,tmp,n,IPIV, info)
 11794 !endif
 11795      if (info/= 0) call MpiStop('error in SolveASymm')
 11796      soln(1:n) = a(1:n)
 11797 !ifdef MATRIX_SINGLE
 11798      call SGETRS('N',n,1,tmp,n,IPIV,Soln,n,info)
 11799 !else
 11800      call DGETRS('N',n,1,tmp,n,IPIV,Soln,n,info)
 11801 !endif
 11802      if (info/= 0) call MpiStop('error (2) in SolveASymm')
 11803      deallocate(tmp) 
 11804 
 11805      call Matrix_End('SolveASymm')
 11806 
 11807   end subroutine Matrix_SolveASymm
 11808 
 11809  function Matrix_vecdot(vec1,vec2)
 11810   real(dm) vec1(:),vec2(:)
 11811   real(dm) Matrix_vecdot
 11812   integer n
 11813 !ifdef MATRIX_SINGLE
 11814   real(dm) sdot
 11815   external sdot
 11816 !else  
 11817   real(dm) ddot
 11818   external ddot
 11819 !endif
 11820   n = size(vec1)
 11821   if (n/= size(vec2)) call MpiStop('Matrix_vecdot: size mismatch')
 11822 !ifdef MATRIX_SINGLE
 11823   Matrix_vecdot = sdot(n, vec1, 1, vec2, 1)
 11824 !else
 11825   Matrix_vecdot = ddot(n, vec1, 1, vec2, 1)
 11826 !endif
 11827  end function Matrix_vecdot
 11828 
 11829  function Matrix_QuadForm(Mat,vec)
 11830    !Get vec^T*Mat*vec where Mat is symmetric
 11831    real(dm) Matrix_QuadForm
 11832    real(dm) vec(:)
 11833    real(dm) Mat(:,:)
 11834    real(dm), dimension(:), allocatable :: out
 11835    integer n
 11836 
 11837    n = size(vec)
 11838    allocate(out(n))
 11839    call Matrix_MulVecSymm(Mat,vec,out)
 11840    Matrix_QuadForm = Matrix_vecdot(vec, out)
 11841    deallocate(out)
 11842 
 11843  end function Matrix_QuadForm
 11844 
 11845   subroutine Matrix_MulVec(Mat,vec,Out,a,b)
 11846    ! Out = a*Mat*vec + b*out
 11847    real(dm), intent(in) :: Mat(:,:)
 11848    real(dm) vec(:)
 11849    real(dm) Out(:) 
 11850    real(dm), intent(in), optional :: a,b
 11851    real(dm)  mult, beta 
 11852    integer m,n
 11853 
 11854     call Matrix_Start('MulVec')
 11855 
 11856      m = Size(Mat,DIM = 1)
 11857      n = Size(Vec)
 11858      if (Size(Mat,DIM = 2) /= n) call MpiStop('Matrix_MulVec: size mismatch')
 11859      if (present(a)) then
 11860        mult = a
 11861      else
 11862        mult = ROne
 11863      end if
 11864      if (present(b)) then
 11865        beta = b    
 11866      else
 11867        beta = RZero
 11868      end if
 11869   
 11870      if (matrix_method = Mat_F90) then
 11871       if (beta /= RZero) then
 11872        out = a*MatMul(Mat,Vec) + beta*Out
 11873       else
 11874        out = MatMul(Mat,Vec)
 11875        if (mult /= ROne) Out = Out*mult
 11876       end if     
 11877      else
 11878 !ifdef MATRIX_SINGLE
 11879        call SGEMV('N',m,n,mult,Mat,m,vec, 1,beta, Out,1)
 11880 !else     
 11881        call DGEMV('N',m,n,mult,Mat,m,vec, 1,beta, Out,1)
 11882 !endif
 11883      end if
 11884      call Matrix_End('MulVec')
 11885 
 11886   end subroutine Matrix_MulVec
 11887 
 11888   subroutine Matrix_MulVecSingle(Mat,vec,Out,a,b)
 11889    ! Out = a*Mat*vec + b*out
 11890    real, intent(in) :: Mat(:,:)
 11891    real vec(:)
 11892    real Out(:) 
 11893    real, intent(in), optional :: a,b
 11894    real  mult, beta 
 11895    integer m,n
 11896 
 11897     call Matrix_Start('MulVecSingle')
 11898 
 11899      m = Size(Mat,DIM = 1)
 11900      n = Size(Vec)
 11901      if (Size(Mat,DIM = 2) /= n) call MpiStop('Matrix_MulVecSingle: size mismatch')
 11902      if (present(a)) then
 11903        mult = a
 11904      else
 11905        mult = SOne
 11906      end if
 11907      if (present(b)) then
 11908        beta = b    
 11909      else
 11910        beta = SZero
 11911      end if
 11912   
 11913      if (matrix_method = Mat_F90) then
 11914       if (beta /= SZero) then
 11915        out = a*MatMul(Mat,Vec) + beta*Out
 11916       else
 11917        out = MatMul(Mat,Vec)
 11918        if (mult /= SOne) Out = Out*mult
 11919       end if     
 11920      else
 11921        call SGEMV('N',m,n,mult,Mat,m,vec, 1,beta, Out,1)
 11922      end if
 11923      call Matrix_End('MulVecSingle')
 11924 
 11925   end subroutine Matrix_MulVecSingle
 11926 
 11927 
 11928 
 11929 
 11930   subroutine Matrix_MulVecSymm(Mat,vec,Out,a,b)
 11931    ! Out = a*Mat*vec + b*out
 11932    real(dm), intent(in) :: Mat(:,:)
 11933    real(dm) vec(:)
 11934    real(dm) Out(:) 
 11935    real(dm), intent(in), optional :: a,b
 11936    real(dm)  mult, beta 
 11937    integer m,n
 11938 
 11939     call Matrix_Start('MulVecSymm')
 11940 
 11941      m = Size(Mat,DIM = 1)
 11942      n = Size(Vec)
 11943      if (m /= n) call MpiStop('Matrix_MulVecSymm: size mismatch')
 11944      if (present(a)) then
 11945        mult = a
 11946      else
 11947        mult = ROne
 11948      end if
 11949      if (present(b)) then
 11950        beta = b    
 11951      else
 11952        beta = RZero
 11953      end if
 11954   
 11955      if (matrix_method = Mat_F90) then
 11956       if (beta /= RZero) then
 11957        out = a*MatMul(Mat,Vec) + beta*Out
 11958       else
 11959        out = MatMul(Mat,Vec)
 11960        if (mult /= ROne) Out = Out*mult
 11961       end if     
 11962      else
 11963 !ifdef MATRIX_SINGLE
 11964        call SSYMV('U',m,mult,Mat,m,vec, 1,beta, Out,1)
 11965 !else     
 11966        call DSYMV('U',m,mult,Mat,m,vec, 1,beta, Out,1)
 11967 !endif
 11968      end if
 11969      call Matrix_End('MulVecSymm')
 11970 
 11971   end subroutine Matrix_MulVecSymm
 11972 
 11973   subroutine Matrix_MulVecSymmSingle(Mat,vec,Out,a,b)
 11974    ! Out = a*Mat*vec + b*out
 11975    real, intent(in) :: Mat(:,:)
 11976    real vec(:)
 11977    real Out(:) 
 11978    real, intent(in), optional :: a,b
 11979    real  mult, beta 
 11980    integer m,n
 11981 
 11982     call Matrix_Start('MulVecSymm')
 11983 
 11984      m = Size(Mat,DIM = 1)
 11985      n = Size(Vec)
 11986      if (m /= n) call MpiStop('Matrix_MulVecSymm: size mismatch')
 11987      if (present(a)) then
 11988        mult = a
 11989      else
 11990        mult = SOne
 11991      end if
 11992      if (present(b)) then
 11993        beta = b    
 11994      else
 11995        beta = SZero
 11996      end if
 11997   
 11998      if (matrix_method = Mat_F90) then
 11999       if (beta /= RZero) then
 12000        out = a*MatMul(Mat,Vec) + beta*Out
 12001       else
 12002        out = MatMul(Mat,Vec)
 12003        if (mult /= ROne) Out = Out*mult
 12004       end if     
 12005      else
 12006        call SSYMV('U',m,mult,Mat,m,vec, 1,beta, Out,1)
 12007      end if
 12008      call Matrix_End('MulVecSymmSingle')
 12009 
 12010   end subroutine Matrix_MulVecSymmSingle
 12011 
 12012  function Matrix_vecdotSingle(vec1,vec2)
 12013   real vec1(:),vec2(:)
 12014   real Matrix_vecdotSingle
 12015   integer n
 12016   real sdot
 12017   external sdot
 12018 
 12019   n = size(vec1)
 12020   if (n/= size(vec2)) call MpiStop('Matrix_vecdotSingle: size mismatch')
 12021   Matrix_vecdotSingle = sdot(n, vec1, 1, vec2, 1)
 12022 
 12023  end function Matrix_vecdotSingle
 12024 
 12025 
 12026  subroutine Matrix_InverseArrayMPI(Arr,nmat)
 12027    !Invert array of matrices by sending each to separate CPU
 12028     integer, intent(in) :: nmat
 12029 !ifdef __GFORTRAN__    
 12030     Type(TMatrixType), target :: Arr(:)
 12031 !else
 12032     Type(TMatrixType), target :: Arr(*)
 12033 !endif
 12034     Type(TMatrixType), pointer :: AM
 12035     integer n
 12036     integer i,MpiID, MpiSize
 12037     integer sz
 12038 !ifdef MPI        
 12039     integer j, ierr, sid
 12040     Type(TMatrixType), target :: tmp
 12041 !endif     
 12042 
 12043     call MpiStat(MpiID, MpiSize)
 12044     if (MpiId = 0) then
 12045      n = nmat
 12046      sz = Size(Arr(1)%M,DIM = 1)
 12047     end if 
 12048 !    if (MpiID = 0) then
 12049 !     do i = 1,nmat
 12050 !      print *,'inverting',i
 12051 !      call Matrix_inverse(Arr(i)%M)
 12052 !     end do
 12053 !    end if
 12054 !    return
 12055 !ifdef MPI        
 12056     if (MpiID = 0) print *, 'MatrixInverseArray: starting'
 12057     call MPI_BCAST(n,1,MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) 
 12058     call MPI_BCAST(sz,1,MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) 
 12059     if (MpiID/= 0) then
 12060       allocate(tmp%M(sz,sz))           
 12061       AM = > tmp
 12062     end if
 12063 !endif
 12064       
 12065      do i = 1,n
 12066          if (MpiID = 0) AM = > Arr(i)
 12067 !ifdef MPI       
 12068          if (mod(i,MpiSize)/= MpiID) then
 12069           !Do nothing
 12070           if (MpiId = 0) then
 12071            j = mod(i,MpiSize)
 12072            call MPI_SEND(AM%M,size(AM%M),MPI_DOUBLE_PRECISION, j, 1, MPI_COMM_WORLD, ierr) 
 12073           end if
 12074          else
 12075           if (MpiId/= 0) then
 12076             !Get from main thread
 12077             call MPI_RECV(AM%M,size(AM%M),MPI_DOUBLE_PRECISION, 0, 1, MPI_COMM_WORLD,MPI_STATUS_IGNORE, ierr) 
 12078 
 12079           end if
 12080 !endif         
 12081           call Matrix_Inverse(AM%M)
 12082       
 12083 !ifdef MPI
 12084            if (MpiID = 0) then
 12085             do j = max(1,i-MpiSize+1),i-1 
 12086              sid = mod(j,MpiSize)
 12087              call MPI_RECV(Arr(j)%M,size(Arr(j)%M),MPI_DOUBLE_PRECISION, sid, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) 
 12088             end do
 12089            else
 12090             call MPI_SEND(AM%M,size(AM%M),MPI_DOUBLE_PRECISION, 0, 1, MPI_COMM_WORLD, ierr) 
 12091            end if
 12092 
 12093          end if 
 12094 !endif
 12095      end do
 12096    
 12097       
 12098 !ifdef MPI
 12099       if (MpiID = 0) then
 12100        do j = n - mod(n,MpiSize) +1 ,n
 12101            sid = mod(j,MpiSize)
 12102            call MPI_RECV(ARr(j)%M,Size(ARr(j)%M),MPI_DOUBLE_PRECISION, sid, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) 
 12103        end do
 12104       else
 12105         deallocate(tmp%M)           
 12106       end if
 12107 !endif   
 12108     if (MpiID = 0) print *, 'MatrixInverseArray: Done'
 12109     
 12110 
 12111  end subroutine Matrix_InverseArrayMPI
 12112 
 12113 
 12114 
 12115 end module MatrixUtils
 12116 
 12117 ** modules.f90
 12118 
 12119 !     Modules used by cmbmain and other routines.
 12120 
 12121 !     Code for Anisotropies in the Microwave Background
 12122 !     by Antony Lewis (http://cosmologist.info) and Anthony Challinor
 12123 !     See readme.html for documentation. 
 12124 !
 12125 !     Based on CMBFAST  by  Uros Seljak and Matias Zaldarriaga, itself based
 12126 !     on Boltzmann code written by Edmund Bertschinger, Chung-Pei Ma and Paul Bode.
 12127 !     Original CMBFAST copyright and disclaimer:
 12128 !
 12129 !     Copyright 1996 by Harvard-Smithsonian Center for Astrophysics and
 12130 !     the Massachusetts Institute of Technology.  All rights reserved.
 12131 !
 12132 !     THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. OR C.f.A. MAKE NO
 12133 !     REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.
 12134 !     By way of example, but not limitation,
 12135 !     M.I.T. AND C.f.A MAKE NO REPRESENTATIONS OR WARRANTIES OF
 12136 !     MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT
 12137 !     THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT INFRINGE
 12138 !     ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS.
 12139 !
 12140 !     portions of this software are based on the COSMICS package of
 12141 !     E. Bertschinger.  See the LICENSE file of the COSMICS distribution
 12142 !     for restrictions on the modification and distribution of this software.
 12143 
 12144 
 12145         module ModelParams
 12146         use precision
 12147         use Ranges
 12148         use InitialPower
 12149         use Reionization
 12150         use Recombination
 12151         use Errors
 12152         
 12153         implicit none    
 12154         public
 12155 
 12156         character(LEN = *), parameter :: version = 'Jan_12'
 12157         
 12158         integer :: FeedbackLevel = 0 !if >0 print out useful information about the model
 12159 
 12160         logical, parameter :: DebugMsgs = .false. !Set to true to view progress and timing
 12161 
 12162         logical, parameter :: DebugEvolution = .false. !Set to true to do all the evolution for all k
 12163  
 12164         logical ::  do_bispectrum  = .false. 
 12165         logical, parameter :: hard_bispectrum = .false. ! e.g. warm inflation where delicate cancellations
 12166         
 12167         logical, parameter :: full_bessel_integration = .false. !(go into the tails when calculating the sources)
 12168 
 12169         integer, parameter :: Nu_int = 0, Nu_trunc = 1, Nu_approx = 2, Nu_best = 3
 12170          !For CAMBparams%MassiveNuMethod
 12171          !Nu_int: always integrate distribution function
 12172          !Nu_trunc: switch to expansion in velocity once non-relativistic
 12173          !Nu_approx: approximate scheme - good for CMB, but not formally correct and no good for matter power
 12174          !Nu_best: automatically use mixture which is fastest and most accurate
 12175 
 12176         integer, parameter :: max_Nu = 5 !Maximum number of neutrino species    
 12177         integer, parameter :: max_transfer_redshifts = 50    
 12178         integer, parameter :: fileio_unit = 13 !Any number not used elsewhere will do       
 12179         integer, parameter :: outCOBE = 0, outNone=1
 12180     
 12181         integer :: max_bessels_l_index  = 1000000
 12182         real(dl) :: max_bessels_etak = 1000000*2
 12183 
 12184 
 12185         real(dl), parameter ::  OutputDenominator = twopi
 12186        !When using outNone the output is l(l+1)Cl/OutputDenominator
 12187 
 12188 
 12189         Type(Regions) :: TimeSteps
 12190 
 12191 
 12192         type TransferParams
 12193             logical     ::  high_precision
 12194             integer     ::  num_redshifts
 12195             real(dl)    ::  kmax         !these are acutally q values, but same as k for CP%flat
 12196             integer     ::  k_per_logint ! ..
 12197             real(dl)    ::  redshifts(max_transfer_redshifts)         
 12198         end type TransferParams
 12199 
 12200 !other variables, options, derived variables, etc.
 12201 
 12202          integer, parameter :: NonLinear_none = 0, NonLinear_Pk = 1, NonLinear_Lens=2
 12203 
 12204 ! Main parameters type
 12205         type CAMBparams
 12206     
 12207          logical   :: WantCls, WantTransfer
 12208          logical   :: WantScalars, WantTensors, WantVectors
 12209          logical   :: DoLensing
 12210          logical   :: want_zstar, want_zdrag     !!JH for updated BAO likelihood.
 12211          integer   :: NonLinear
 12212 
 12213          integer   :: Max_l, Max_l_tensor
 12214          real(dl)  :: Max_eta_k, Max_eta_k_tensor
 12215           ! _tensor settings only used in initialization, 
 12216           !Max_l and Max_eta_k are set to the tensor variables if only tensors requested
 12217 
 12218          real(dl)  :: omegab, omegac, omegav, omegan
 12219          !Omega baryon, CDM, Lambda and massive neutrino
 12220          real(dl)  :: H0,TCMB,yhe,Num_Nu_massless
 12221          integer   :: Num_Nu_massive
 12222 
 12223          logical :: Nu_mass_splittings
 12224          integer   :: Nu_mass_eigenstates  !1 for degenerate masses
 12225          real(dl)  :: Nu_mass_degeneracies(max_nu)
 12226          real(dl)  :: Nu_mass_fractions(max_nu)
 12227              !The ratios of the masses
 12228 
 12229          integer   :: Scalar_initial_condition 
 12230          !must be one of the initial_xxx values defined in GaugeInterface
 12231          
 12232          integer   :: OutputNormalization  
 12233          !outNone, outCOBE, or C_OutputNormalization = 1 if > 1
 12234 
 12235          logical   :: AccuratePolarization
 12236            !Do you care about the accuracy of the polarization Cls?
 12237   
 12238          logical   :: AccurateBB
 12239            !Do you care about BB accuracy (e.g. in lensing)
 12240 
 12241 !Reionization settings - used if Reion%Reionization = .true.
 12242          logical   :: AccurateReionization
 12243            !Do you care about pecent level accuracy on EE signal from reionization?
 12244 
 12245          integer   :: MassiveNuMethod
 12246         
 12247          type(InitialPowerParams) :: InitPower  !see power_tilt.f90 - you can change this
 12248          type(ReionizationParams) :: Reion
 12249          type(RecombinationParams):: Recomb
 12250          type(TransferParams)     :: Transfer 
 12251          
 12252          real(dl) ::  InitialConditionVector(1:10) !Allow up to 10 for future extensions
 12253           !ignored unless Scalar_initial_condition = initial_vector
 12254 
 12255          logical OnlyTransfers !Don't use initial power spectrum data, instead get Delta_q_l array
 12256            !If trye, sigma_8 is not calculated either
 12257 
 12258 !Derived parameters, not set initially
 12259          type(ReionizationHistory) :: ReionHist
 12260          
 12261          logical flat,closed,open
 12262          real(dl) omegak
 12263          real(dl) curv,r, Ksign !CP%r = 1/sqrt(|CP%curv|), CP%Ksign = 1,0 or -1
 12264          real(dl) tau0,chi0 !time today and rofChi(CP%tau0/CP%r) 
 12265     
 12266                       
 12267          end type CAMBparams
 12268 
 12269         type(CAMBparams) CP  !Global collection of parameters
 12270 
 12271 
 12272        real(dl) scale !relative to CP%flat. e.g. for scaling lSamp%l sampling.
 12273 
 12274        logical ::call_again = .false.
 12275           !if being called again with same parameters to get different thing
 12276 
 12277  
 12278 !     grhom = kappa*a^2*rho_m0
 12279 !     grhornomass = grhor*number of massless neutrino species
 12280 !     taurst,taurend - time at start/end of recombination
 12281 !     dtaurec - dtau during recombination
 12282 !     adotrad - a(tau) in radiation era
 12283 
 12284         real(dl) grhom,grhog,grhor,grhob,grhoc,grhov,grhornomass,grhok
 12285         real(dl) taurst,dtaurec,taurend, tau_maxvis,adotrad
 12286 
 12287 !Neutrinos
 12288         real(dl) grhormass(max_nu)
 12289      
 12290 !     nu_masses = m_nu*c**2/(k_B*T_nu0)      
 12291        real(dl) :: nu_masses(max_nu) 
 12292         
 12293        real(dl) akthom !sigma_T * (number density of protons now)
 12294        real(dl) fHe !n_He_tot / n_H_tot
 12295        real(dl) Nnow
 12296 
 12297 
 12298       integer :: ThreadNum = 0 
 12299        !If zero assigned automatically, obviously only used if parallelised
 12300    
 12301 !Parameters for checking/changing overall accuracy
 12302 !If HighAccuracyDefault = .false., the other parameters equal to 1 corresponds to ~0.3% scalar C_l accuracy
 12303 !If HighAccuracyDefault = .true., the other parameters equal to 1 corresponds to ~0.1% scalar C_l accuracy (at L>600)
 12304       logical :: HighAccuracyDefault = .false.
 12305 
 12306       real(dl) :: lSampleBoost = 1
 12307           !Increase lSampleBoost to increase sampling in lSamp%l for Cl interpolation
 12308           
 12309       real(dl) :: AccuracyBoost = 1  
 12310 
 12311           !Decrease step sizes, etc. by this parameter. Useful for checking accuracy.
 12312           !Can also be used to improve speed significantly if less accuracy is required.              
 12313           !or improving accuracy for extreme models. 
 12314           !Note this does not increase lSamp%l sampling or massive neutrino q-sampling
 12315 
 12316       real(sp) :: lAccuracyBoost = 1. 
 12317           !Boost number of multipoles integrated in Boltzman heirarchy
 12318 
 12319       integer, parameter :: lmin = 2  
 12320           !must be either 1 or 2       
 12321 
 12322       real(dl), parameter :: OmegaKFlat = 5e-7 !Value at which to use flat code
 12323 
 12324       real(dl),parameter :: tol = 1.0d-4 !Base tolerance for integrations
 12325 
 12326 !     used as parameter for spline - tells it to use 'natural' end values
 12327       real(dl), parameter :: spl_large = 1.e40
 12328 
 12329       integer, parameter:: l0max = 4000
 12330 
 12331 !     lmax is max possible number of l's evaluated
 12332       integer, parameter :: lmax_arr = l0max 
 12333  
 12334       character(LEN = 1024) :: highL_unlensed_cl_template = 'HighLExtrapTemplate_lenspotentialCls.dat'
 12335            !fiducial high-accuracy high-L C_L used for making small cosmology-independent numerical corrections
 12336            !to lensing and C_L interpolation. Ideally close to models of interest, but dependence is weak.
 12337       logical :: use_spline_template = .true.  
 12338       integer, parameter :: lmax_extrap_highl = 6000
 12339       real(dl), allocatable :: highL_CL_template(:,:)
 12340            
 12341         contains
 12342       
 12343 
 12344          subroutine CAMBParams_Set(P, error, DoReion)
 12345            use constants
 12346            type(CAMBparams), intent(in) :: P
 12347            real(dl) GetOmegak, fractional_number
 12348            integer, optional :: error !Zero if OK
 12349            logical, optional :: DoReion
 12350            logical WantReion
 12351            integer nu_i,actual_massless
 12352            external GetOmegak
 12353            real(dl), save :: last_tau0
 12354            !Constants in SI units
 12355 
 12356             global_error_flag = 0
 12357 
 12358             if ((P%WantTensors .or. P%WantVectors).and. P%WantTransfer .and. .not. P%WantScalars) then
 12359               call GlobalError( 'Cannot generate tensor C_l and transfer without scalar C_l',error_unsupported_params)
 12360             end if
 12361  
 12362             if (present(error)) error = global_error_flag
 12363             if (global_error_flag/= 0) return
 12364           
 12365            if (present(DoReion)) then
 12366             WantReion = DoReion
 12367            else
 12368             WantReion = .true.
 12369            end if
 12370         
 12371            CP = P
 12372           
 12373            CP%Max_eta_k = max(CP%Max_eta_k,CP%Max_eta_k_tensor)
 12374            
 12375            if (CP%WantTransfer) then
 12376               CP%WantScalars = .true.
 12377               if (.not. CP%WantCls) then
 12378                  CP%AccuratePolarization = .false.
 12379                  CP%Reion%Reionization = .false.
 12380               end if
 12381            else
 12382               CP%transfer%num_redshifts = 0
 12383            end if
 12384 
 12385            if (CP%Omegan = 0 .and. CP%Num_Nu_Massive /= 0) then
 12386               CP%Num_Nu_Massless = CP%Num_Nu_Massless + CP%Num_Nu_Massive
 12387               CP%Num_Nu_Massive  = 0
 12388            end if
 12389 
 12390            if (CP%Num_nu_massive > 0) then
 12391                if (.not. CP%Nu_mass_splittings) then
 12392                  !Default totally degenerate masses
 12393                  CP%Nu_mass_eigenstates = 1
 12394                  CP%Nu_mass_degeneracies(1) = CP%Num_Nu_Massive 
 12395                  CP%Nu_mass_fractions(1) = 1
 12396                else
 12397                  if (CP%Nu_mass_degeneracies(1) = 0) CP%Nu_mass_degeneracies(1) = CP%Num_Nu_Massive 
 12398                  if (abs(sum(CP%Nu_mass_fractions(1:CP%Nu_mass_eigenstates))-1) > 1e-4) &
 12399                    stop 'Nu_mass_fractions do not add up to 1'
 12400 
 12401                  if (abs(sum(CP%Nu_mass_degeneracies(1:CP%Nu_mass_eigenstates))-CP%Num_nu_massive) >1e-4 ) &
 12402                     stop 'nu_mass_eigenstates do not add up to num_nu_massive'
 12403                  if (CP%Nu_mass_eigenstates = 0) stop 'Have Num_nu_massive>0 but no nu_mass_eigenstates'
 12404 
 12405                end if
 12406            else
 12407             CP%Nu_mass_eigenstates = 0
 12408            end if
 12409            
 12410            if ((CP%WantTransfer).and. CP%MassiveNuMethod = Nu_approx) then
 12411               CP%MassiveNuMethod = Nu_trunc
 12412            end if
 12413 
 12414            CP%omegak = GetOmegak()
 12415           
 12416            CP%flat = (abs(CP%omegak) < = OmegaKFlat)
 12417            CP%closed = CP%omegak < -OmegaKFlat
 12418         
 12419            CP%open = .not.CP%flat.and..not.CP%closed
 12420            if (CP%flat) then
 12421               CP%curv = 0
 12422               CP%Ksign = 0
 12423               CP%r = 1 !so we can use tau/CP%r, etc, where CP%r's cancel
 12424            else   
 12425            CP%curv = -CP%omegak/((c/1000)/CP%h0)**2
 12426            CP%Ksign = sign(1,CP%curv)
 12427            CP%r = 1/sqrt(abs(CP%curv))
 12428            end if
 12429 !  grho gives the contribution to the expansion rate from: (g) photons,
 12430 !  (r) one flavor of relativistic neutrino (2 degrees of freedom),
 12431 !  (m) nonrelativistic matter (for Omega = 1).  grho is actually
 12432 !  8*pi*G*rho/c^2 at a = 1, with units of Mpc**(-2).
 12433 !  a = tau(Mpc)*adotrad, with a = 1 today, assuming 3 neutrinos.
 12434 !  (Used only to set the initial conformal time.)
 12435 
 12436            !H0 is in km/s/Mpc
 12437 
 12438            grhom = 3*CP%h0**2/c**2*1000**2 !3*h0^2/c^2 ( = 8*pi*G*rho_crit/c^2)
 12439         
 12440           !grhom = 3.3379d-11*h0*h0 
 12441            grhog = kappa/c**2*4*sigma_boltz/c**3*CP%tcmb**4*Mpc**2 !8*pi*G/c^2*4*sigma_B/c^3 T^4
 12442           ! grhog = 1.4952d-13*tcmb**4
 12443            grhor = 7/8*(4/11)**(4/3)*grhog !7/8*(4/11)^(4/3)*grhog (per neutrino species)
 12444           !grhor = 3.3957d-14*tcmb**4
 12445            !correction for fractional number of neutrinos, e.g. 3.04 to give slightly higher T_nu hence rhor
 12446            !Num_Nu_massive is already integer, Num_Nu_massless can contain fraction
 12447            !We assume all eigenstates affected the same way
 12448            fractional_number  = CP%Num_Nu_massless + CP%Num_Nu_massive
 12449            actual_massless = int(CP%Num_Nu_massless + 1e-6)
 12450            grhor = grhor * fractional_number/(actual_massless + CP%Num_Nu_massive)
 12451           
 12452            grhornomass = grhor*actual_massless
 12453            grhormass = 0
 12454            do nu_i = 1, CP%Nu_mass_eigenstates
 12455             grhormass(nu_i) = grhor*CP%Nu_mass_degeneracies(nu_i)
 12456            end do
 12457            grhoc = grhom*CP%omegac
 12458            grhob = grhom*CP%omegab
 12459            grhov = grhom*CP%omegav
 12460            grhok = grhom*CP%omegak
 12461 !  adotrad gives the relation a(tau) in the radiation era:
 12462            adotrad = sqrt((grhog+grhornomass+sum(grhormass(1:CP%Nu_mass_eigenstates)))/3)
 12463        
 12464           
 12465            Nnow = CP%omegab*(1-CP%yhe)*grhom*c**2/kappa/m_H/Mpc**2
 12466 
 12467            akthom = sigma_thomson*Nnow*Mpc
 12468               !sigma_T * (number density of protons now)
 12469     
 12470            fHe = CP%YHe/(mass_ratio_He_H*(1-CP%YHe))  !n_He_tot / n_H_tot
 12471       
 12472            if (CP%omegan = 0) then
 12473               CP%Num_nu_massless = CP%Num_nu_massless + CP%Num_nu_massive
 12474               CP%Num_nu_massive = 0
 12475            end if
 12476 
 12477            if (.not.call_again) then
 12478       
 12479             call init_massive_nu(CP%omegan /= 0)
 12480             call init_background
 12481             if (global_error_flag = 0) then
 12482              CP%tau0 = TimeOfz(0)
 12483          ! print *, 'chi = ',  (CP%tau0 - TimeOfz(0.15)) * CP%h0/100   
 12484              last_tau0 = CP%tau0
 12485              if (WantReion) call Reionization_Init(CP%Reion,CP%ReionHist, CP%YHe, akthom, CP%tau0, FeedbackLevel)
 12486             end if
 12487            else
 12488               CP%tau0 = last_tau0
 12489            end if  
 12490            
 12491            if ( CP%NonLinear = NonLinear_Lens) then
 12492              CP%Transfer%kmax = max(CP%Transfer%kmax, CP%Max_eta_k/CP%tau0) 
 12493              if (FeedbackLevel > 0 .and. CP%Transfer%kmax = CP%Max_eta_k/CP%tau0) &
 12494                   write (*,*) 'max_eta_k changed to ', CP%Max_eta_k
 12495            end if
 12496 
 12497            if (CP%closed .and. CP%tau0/CP%r >3.14) then
 12498              call GlobalError('chi > = pi in closed model not supported',error_unsupported_params)
 12499            end if
 12500 
 12501            if (global_error_flag/= 0) then
 12502              if (present(error)) error = global_error_flag            
 12503              return
 12504            end if       
 12505            
 12506            if (present(error)) then
 12507               error = 0
 12508            else if (FeedbackLevel > 0 .and. .not. call_again) then
 12509               write(*,'("Om_b h^2             = ",f9.6)') CP%omegab*(CP%H0/100)**2
 12510               write(*,'("Om_c h^2             = ",f9.6)') CP%omegac*(CP%H0/100)**2
 12511               write(*,'("Om_nu h^2            = ",f9.6)') CP%omegan*(CP%H0/100)**2
 12512               write(*,'("Om_Lambda            = ",f9.6)') CP%omegav
 12513               write(*,'("Om_K                 = ",f9.6)') CP%omegak
 12514               write(*,'("Om_m (1-Om_K-Om_L)   = ",f9.6)') 1-CP%omegak-CP%omegav
 12515               write(*,'("100 theta (CosmoMC)  = ",f9.6)') 100*CosmomcTheta()
 12516               if (CP%Num_Nu_Massive > 0) then
 12517                 do nu_i = 1, CP%Nu_mass_eigenstates 
 12518                  write(*,'(f5.2, " nu, m_nu*c^2/k_B/T_nu0   = ",f8.2," (m_nu = ",f6.3," eV)")') &
 12519                      CP%nu_mass_degeneracies(nu_i), nu_masses(nu_i),1.68e-4*nu_masses(nu_i)
 12520                 end do
 12521               end if
 12522            end if
 12523            CP%chi0 = rofChi(CP%tau0/CP%r)
 12524            scale = CP%chi0*CP%r/CP%tau0  !e.g. changel sampling depending on approx peak spacing      
 12525            
 12526          end subroutine CAMBParams_Set
 12527 
 12528     
 12529          function GetTestTime()
 12530            real(sp) GetTestTime
 12531            real(sp) atime
 12532 
 12533 !           GetTestTime = etime(tarray)
 12534          !Can replace this if etime gives problems
 12535          !Or just comment out - only used if DebugMsgs = .true.
 12536            call cpu_time(atime)
 12537            GetTestTime = atime
 12538             
 12539          end function GetTestTime
 12540 
 12541         
 12542          function rofChi(Chi) !sinh(chi) for open, sin(chi) for closed.
 12543          real(dl) Chi,rofChi
 12544 
 12545          if (CP%closed) then
 12546             rofChi = sin(chi)
 12547          else if (CP%open) then
 12548             rofChi = sinh(chi)
 12549          else
 12550             rofChi = chi
 12551          endif
 12552          end function rofChi  
 12553          
 12554 
 12555          function cosfunc (Chi)
 12556          real(dl) Chi,cosfunc
 12557 
 12558          if (CP%closed) then
 12559             cosfunc = cos(chi)
 12560          else if (CP%open) then
 12561             cosfunc = cosh(chi)
 12562          else
 12563             cosfunc = 1
 12564          endif
 12565          end function cosfunc  
 12566 
 12567          function tanfunc(Chi)
 12568          real(dl) Chi,tanfunc
 12569          if (CP%closed) then
 12570             tanfunc = tan(Chi)
 12571          else if (CP%open) then
 12572             tanfunc = tanh(Chi)
 12573          else
 12574             tanfunc = Chi
 12575          end if
 12576 
 12577          end  function tanfunc
 12578 
 12579          function invsinfunc(x)
 12580          real(dl) invsinfunc,x
 12581 
 12582          if (CP%closed) then
 12583           invsinfunc = asin(x)
 12584           else if (CP%open) then
 12585           invsinfunc = log((x+sqrt(1+x**2)))  
 12586           else
 12587           invsinfunc = x
 12588          endif
 12589          end function invsinfunc    
 12590 
 12591         function f_K(x)
 12592          real(dl) :: f_K
 12593          real(dl), intent(in) :: x
 12594          f_K = CP%r*rofChi(x/CP%r)
 12595           
 12596         end function f_K
 12597 
 12598 
 12599         function DeltaTime(a1,a2, in_tol)
 12600         implicit none
 12601         real(dl) DeltaTime, atol
 12602         real(dl), intent(IN) :: a1,a2
 12603         real(dl), optional, intent(in) :: in_tol
 12604         real(dl) dtauda, rombint !diff of tau w.CP%r.t a and integration
 12605         external dtauda, rombint
 12606 
 12607         if (present(in_tol)) then
 12608          atol = in_tol
 12609         else
 12610          atol = tol/1000/exp(AccuracyBoost-1)
 12611         end if
 12612         DeltaTime = rombint(dtauda,a1,a2,atol)
 12613       
 12614         end function DeltaTime
 12615 
 12616         function TimeOfz(z)
 12617         implicit none
 12618         real(dl) TimeOfz
 12619         real(dl), intent(IN) :: z
 12620         
 12621         TimeOfz = DeltaTime(0,1/(z+1))
 12622         end function TimeOfz
 12623 
 12624         function AngularDiameterDistance(z)
 12625           real(dl) AngularDiameterDistance
 12626           real(dl), intent(in) :: z
 12627 
 12628           AngularDiameterDistance = CP%r/(1+z)*rofchi(DeltaTime(1/(1+z),1)/CP%r)
 12629 
 12630         end function AngularDiameterDistance
 12631 
 12632        function dsound_da(a)
 12633           implicit none
 12634           real(dl) dsound_da,dtauda,a,R,cs
 12635           external dtauda
 12636 
 12637            R = 3.0d4*a*CP%omegab*(CP%h0/100.0)**2
 12638 !          R = 3*grhob*a / (4*grhog) //above is mostly within 0.2% and used for previous consistency
 12639            cs = 1.0/sqrt(3*(1+R))
 12640            dsound_da = dtauda(a)*cs
 12641         
 12642        end function dsound_da
 12643 
 12644 
 12645        function CosmomcTheta()
 12646          real(dl) zstar, astar, atol, rs, DA
 12647          real(dl) CosmomcTheta
 12648          real(dl) ombh2, omdmh2
 12649          real(dl) rombint
 12650          external rombint
 12651 
 12652          ombh2 = CP%omegab*(CP%h0/100.0)**2
 12653          omdmh2 = (CP%omegac+CP%omegan)*(CP%h0/100.0)**2
 12654 
 12655     !!From Hu & Sugiyama
 12656            zstar =  1048*(1+0.00124*ombh2**(-0.738))*(1+ &
 12657             (0.0783*ombh2**(-0.238)/(1+39.5*ombh2**0.763)) * &
 12658                (omdmh2+ombh2)**(0.560/(1+21.1*ombh2**1.81)))
 12659      
 12660            astar = 1/(1+zstar)
 12661            atol = 1e-6
 12662            rs = rombint(dsound_da,1d-8,astar,atol)
 12663            DA = AngularDiameterDistance(zstar)/astar
 12664            CosmomcTheta = rs/DA
 12665     !       print *,'z* = ',zstar, 'r_s = ',rs, 'DA = ',DA, rs/DA
 12666 
 12667        end function CosmomcTheta
 12668 
 12669    end module ModelParams
 12670 
 12671 
 12672 
 12673 !ccccccccccccccccccccccccccccccccccccccccccccccccccc
 12674 
 12675         module lvalues
 12676         use precision
 12677         use ModelParams
 12678         implicit none
 12679         public
 12680 
 12681         Type lSamples
 12682             integer l0
 12683             integer l(lmax_arr)
 12684         end Type lSamples
 12685 
 12686         Type(lSamples) :: lSamp
 12687 
 12688        contains
 12689 
 12690 
 12691         subroutine initlval(lSet,max_l)
 12692 
 12693 ! This subroutines initializes lSet%l arrays. Other values will be interpolated.
 12694   
 12695         implicit none
 12696         type(lSamples) :: lSet
 12697          
 12698         integer, intent(IN) :: max_l
 12699         integer lind, lvar, step,top,bot,ls(lmax_arr)
 12700         real(dl) AScale
 12701     
 12702         Ascale = scale/lSampleBoost       
 12703        
 12704         if (lSampleBoost > = 50) then
 12705          !just do all of them
 12706          lind = 0
 12707          do lvar = lmin, max_l
 12708            lind = lind+1
 12709            ls(lind) = lvar 
 12710          end do
 12711          lSet%l0 = lind
 12712          lSet%l(1:lind) = ls(1:lind)
 12713          return       
 12714         end if
 12715       
 12716         lind = 0
 12717         do lvar = lmin, 10
 12718            lind = lind+1
 12719            ls(lind) = lvar 
 12720         end do
 12721 
 12722         if (CP%AccurateReionization) then
 12723             if (lSampleBoost > 1) then
 12724              do lvar = 11, 37,1
 12725                lind = lind+1
 12726                ls(lind) = lvar 
 12727              end do       
 12728             else
 12729              do lvar = 11, 37,2
 12730                lind = lind+1
 12731                ls(lind) = lvar 
 12732              end do       
 12733             end if 
 12734 
 12735             step = max(nint(5*Ascale),2)           
 12736             bot = 40
 12737             top = bot + step*10
 12738         else
 12739 
 12740             if (lSampleBoost >1) then
 12741              do lvar = 11, 15
 12742                lind = lind+1
 12743                ls(lind) = lvar 
 12744              end do           
 12745             else
 12746              lind = lind+1
 12747              ls(lind) = 12
 12748              lind = lind+1
 12749              ls(lind) = 15
 12750             end if
 12751             step = max(nint(10*Ascale),3)           
 12752             bot = 15+max(step/2,2)
 12753             top = bot + step*7
 12754         end if
 12755 
 12756         do lvar = bot, top, step
 12757            lind = lind+1
 12758            ls(lind) = lvar          
 12759         end do
 12760 
 12761         step = max(nint(20*Ascale),4)
 12762         bot = ls(lind)+step
 12763         top = bot+step*2
 12764 
 12765         do lvar = bot,top,step 
 12766           lind = lind+1
 12767           ls(lind) = lvar
 12768         end do
 12769 
 12770         if (ls(lind)> = max_l) then
 12771            do lvar = lind,1,-1
 12772             if (ls(lvar)< = max_l) exit  
 12773            end do
 12774            lind = lvar
 12775            if (ls(lind) = max_l) then
 12793            do lvar = lind,1,-1
 12794             if (ls(lvar)< = max_l) exit  
 12795            end do
 12796            lind = lvar
 12797            if (ls(lind) 5000) then
 12817              !Should be pretty smooth or tiny out here   
 12818              step = max(nint(400*Ascale),50)
 12819              lvar = ls(lind)
 12820             
 12821              do
 12822               lvar = lvar + step
 12823               if (lvar > max_l) exit
 12824               lind = lind+1
 12825               ls(lind) = lvar
 12826               step = nint(step*1.5) !log spacing
 12827              end do
 12828 
 12829          end if
 12830 
 12831          if (ls(lind) /= max_l) then          
 12832            lind = lind+1
 12833            ls(lind) = max_l
 12834          end if
 12835         if (.not. CP%flat) ls(lind-1) = int(max_l+ls(lind-2))/2
 12836         !Not in CP%flat case so interpolation table is the same when using lower l_max
 12837         end if
 12838         end if
 12839         lSet%l0 = lind
 12840         lSet%l(1:lind) = ls(1:lind)
 12841         
 12842       end subroutine initlval
 12843 
 12844       subroutine InterpolateClArr(lSet,iCl, all_Cl, max_ind)
 12845       type (lSamples), intent(in) :: lSet        
 12846       real(dl), intent(in) :: iCl(*)
 12847       real(dl), intent(out):: all_Cl(lmin:*)
 12848       integer, intent(in) :: max_ind      
 12849       integer il,llo,lhi, xi
 12850       real(dl) ddCl(lSet%l0)
 12851       real(dl) xl(lSet%l0)
 12852 
 12853       real(dl) a0,b0,ho
 12854       real(dl), parameter :: cllo = 1.e30,clhi = 1.e30
 12855 
 12856       if (max_ind > lSet%l0) stop 'Wrong max_ind in InterpolateClArr'
 12857 
 12858       xl = real(lSet%l(1:lSet%l0),dl)
 12859       call spline(xl,iCL(1),max_ind,cllo,clhi,ddCl(1))
 12860          
 12861             llo = 1
 12862             do il = lmin,lSet%l(max_ind)
 12863                xi = il
 12864                if ((xi > lSet%l(llo+1)).and.(llo < max_ind)) then
 12865                   llo = llo+1
 12866                end if
 12867                lhi = llo+1
 12868                ho = lSet%l(lhi)-lSet%l(llo)
 12869                a0 = (lSet%l(lhi)-xi)/ho
 12870                b0 = (xi-lSet%l(llo))/ho
 12871       
 12872                all_Cl(il) = a0*iCl(llo)+ b0*iCl(lhi)+((a0**3-a0)* ddCl(llo) &
 12873                        +(b0**3-b0)*ddCl(lhi))*ho**2/6
 12874               
 12875             end do
 12876            
 12877       end subroutine InterpolateClArr
 12878       
 12879        subroutine InterpolateClArrTemplated(lSet,iCl, all_Cl, max_ind, template_index)
 12880       type (lSamples), intent(in) :: lSet        
 12881       real(dl), intent(in) :: iCl(*)
 12882       real(dl), intent(out):: all_Cl(lmin:*)
 12883       integer, intent(in) :: max_ind
 12884       integer, intent(in), optional :: template_index
 12885       integer maxdelta, il
 12886       real(dl) DeltaCL(lSet%l0)
 12887       real(dl), allocatable :: tmpall(:)
 12888 
 12889       if (max_ind > lSet%l0) stop 'Wrong max_ind in InterpolateClArrTemplated'
 12890 
 12891       if (use_spline_template .and. present(template_index)) then
 12892         if (template_index< = 3) then
 12893           !interpolate only the difference between the C_l and an accurately interpolated template. Temp only for the mo.
 12894           !Using unlensed for template, seems to be good enough 
 12895            maxdelta = max_ind
 12896            do while (lSet%l(maxdelta) > lmax_extrap_highl) 
 12897             maxdelta = maxdelta-1
 12898            end do
 12899            DeltaCL(1:maxdelta) = iCL(1:maxdelta)- highL_CL_template(lSet%l(1:maxdelta), template_index)
 12900         
 12901            call InterpolateClArr(lSet,DeltaCl, all_Cl, maxdelta)
 12902       
 12903            do il = lmin,lSet%l(maxdelta)
 12904                 all_Cl(il) = all_Cl(il) +  highL_CL_template(il,template_index)
 12905            end do
 12906        
 12907            if (maxdelta < max_ind) then
 12908            !directly interpolate high L where no template (doesn't effect lensing spectrum much anyway)
 12909             allocate(tmpall(lmin:lSet%l(max_ind)))
 12910             call InterpolateClArr(lSet,iCl, tmpall, max_ind)
 12911             !overlap to reduce interpolation artefacts
 12912             all_cl(lSet%l(maxdelta-2):lSet%l(max_ind) ) = tmpall(lSet%l(maxdelta-2):lSet%l(max_ind))
 12913             deallocate(tmpall)
 12914            end if
 12915           return
 12916         end if        
 12917        end if 
 12918                     
 12919        call InterpolateClArr(lSet,iCl, all_Cl, max_ind)
 12920        
 12921            
 12922       end subroutine InterpolateClArrTemplated
 12923       
 12924 
 12925  
 12926     
 12927 
 12928 !ccccccccccccccccccccccccccc
 12929 
 12930         end module lvalues
 12931         
 12932 
 12933 
 12934 !ccccccccccccccccccccccccccccccccccccccccccccccccccc
 12935 
 12936         module ModelData
 12937         use precision
 12938         use ModelParams
 12939         use InitialPower
 12940         use lValues
 12941         use Ranges
 12942         use AMlUtils
 12943         implicit none
 12944         public
 12945 
 12946          Type ClTransferData
 12947       !Cl transfer function variables
 12948        !values of q for integration over q to get C_ls
 12949           Type (lSamples) :: ls ! scalar and tensor l that are computed
 12950           integer :: NumSources 
 12951           !Changes -scalars:  2 for just CMB, 3 for lensing
 12952           !- tensors: T and E and phi (for lensing), and T, E, B respectively
 12953         
 12954           Type (Regions) :: q
 12955 
 12956           real(dl), dimension(:,:,:), pointer :: Delta_p_l_k = > NULL() 
 12957       
 12958          end Type ClTransferData
 12959 
 12960          Type(ClTransferData), save, target :: CTransScal, CTransTens, CTransVec
 12961 
 12962         !Computed output power spectra data
 12963                          
 12964         integer, parameter :: C_Temp = 1, C_E = 2, C_Cross = 3, C_Phi = 4, C_PhiTemp = 5, C_PhiE =6
 12965         integer :: C_last = C_PhiE
 12966         integer, parameter :: CT_Temp = 1, CT_E = 2, CT_B = 3, CT_Cross =  4
 12967   
 12968 
 12969         real(dl), dimension (:,:,:), allocatable :: Cl_scalar, Cl_tensor, Cl_vector
 12970         !Indices are Cl_xxx( l , intial_power_index, Cl_type)
 12971         !where Cl_type is one of the above constants
 12972 
 12973         !The following are set only if doing lensing
 12974         integer lmax_lensed !Only accurate to rather less than this 
 12975         real(dl) , dimension (:,:,:), allocatable :: Cl_lensed
 12976           !Cl_lensed(l, power_index, Cl_type) are the interpolated Cls
 12977     
 12978         real(dl), dimension (:), allocatable ::  COBElikelihoods,COBE_scales
 12979         !Set by COBEnormalize if using outCOBE
 12980         contains
 12981 
 12982 
 12983         subroutine Init_ClTransfer(CTrans)
 12984         !Need to set the Ranges array q before calling this
 12985           Type(ClTransferData) :: CTrans
 12986           integer st
 12987 
 12988           deallocate(CTrans%Delta_p_l_k, STAT = st)
 12989           call Ranges_getArray(CTrans%q, .true.)
 12990 
 12991           allocate(CTrans%Delta_p_l_k(CTrans%NumSources,min(max_bessels_l_index,CTrans%ls%l0), CTrans%q%npoints))
 12992           CTrans%Delta_p_l_k = 0
 12993 
 12994   
 12995          end subroutine Init_ClTransfer
 12996 
 12997 
 12998         subroutine Free_ClTransfer(CTrans)
 12999           Type(ClTransferData) :: CTrans
 13000           integer st
 13001 
 13002            deallocate(CTrans%Delta_p_l_k, STAT = st)
 13003            nullify(CTrans%Delta_p_l_k)
 13004            call Ranges_Free(CTrans%q)
 13005 
 13006         end subroutine Free_ClTransfer
 13007         
 13008         subroutine CheckLoadedHighLTemplate
 13009           integer L
 13010           real(dl) array(7)
 13011 
 13012          if (.not. allocated(highL_CL_template)) then
 13013              allocate(highL_CL_template(lmin:lmax_extrap_highl, C_Temp:C_Phi))
 13014              call OpenTxtFile(highL_unlensed_cl_template,fileio_unit)
 13015              if (lmin = 1) highL_CL_template(lmin,:) =0
 13016              do
 13017               read(fileio_unit,*, end = 500) L , array 
 13018               if (L>lmax_extrap_highl) exit
 13019             !  array = array * (2*l+1)/(4*pi) * 2*pi/(l*(l+1)) 
 13020               highL_CL_template(L, C_Temp:C_E) = array(1:2)
 13021               highL_CL_template(L, C_Cross) = array(4)
 13022               highL_CL_template(L, C_Phi) = array(5)    
 13023              end do
 13024      
 13025          500  close(fileio_unit)
 13026          end if
 13027 
 13028         end subroutine CheckLoadedHighLTemplate
 13029 
 13030 
 13031 
 13032         subroutine Init_Cls
 13033       
 13034         call CheckLoadedHighLTemplate 
 13035         if (CP%WantScalars) then
 13036          if (allocated(Cl_scalar)) deallocate(Cl_scalar)
 13037          allocate(Cl_scalar(lmin:CP%Max_l, CP%InitPower%nn, C_Temp:C_last))
 13038          Cl_scalar = 0
 13039         end if
 13040 
 13041         if (CP%WantVectors) then
 13042          if (allocated(Cl_vector)) deallocate(Cl_vector)
 13043          allocate(Cl_vector(lmin:CP%Max_l, CP%InitPower%nn, CT_Temp:CT_Cross))
 13044          Cl_vector = 0
 13045         end if
 13046 
 13047 
 13048         if (CP%WantTensors) then
 13049           if (allocated(Cl_tensor)) deallocate(Cl_tensor)
 13050           allocate(Cl_tensor(lmin:CP%Max_l_tensor, CP%InitPower%nn, CT_Temp:CT_Cross))
 13051           Cl_tensor = 0
 13052         end if
 13053 
 13054         end subroutine Init_Cls
 13055        
 13056         subroutine output_cl_files(ScalFile,TensFile, TotFile, LensFile, LensTotFile, factor)
 13057         implicit none
 13058         integer in,il
 13059         character(LEN = *) ScalFile, TensFile, TotFile, LensFile, LensTotFile
 13060         real(dl), intent(in), optional :: factor
 13061         real(dl) fact
 13062         integer last_C
 13063 
 13064         if (present(factor)) then
 13065           fact = factor
 13066         else
 13067           fact = 1
 13068         end if
 13069 
 13070          if (CP%WantScalars .and. ScalFile /= '') then
 13071            last_C = min(C_PhiTemp,C_last)
 13072            open(unit = fileio_unit,file = ScalFile,form = 'formatted',status = 'replace')
 13073            do in = 1,CP%InitPower%nn
 13074              do il = lmin,min(10000,CP%Max_l)
 13075                write(fileio_unit,trim(numcat('(1I6,',last_C))//'E15.5)')il ,fact*Cl_scalar(il,in,C_Temp:last_C)
 13076              end do
 13077              do il = 10100,CP%Max_l, 100
 13078                write(fileio_unit,trim(numcat('(1E15.5,',last_C))//'E15.5)') real(il),&
 13079                        fact*Cl_scalar(il,in,C_Temp:last_C)
 13080              end do
 13081             end do
 13082             close(fileio_unit)
 13083          end if
 13084   
 13085        if (CP%WantTensors .and. TensFile /= '') then
 13086            open(unit = fileio_unit,file = TensFile,form = 'formatted',status = 'replace')
 13087             do in = 1,CP%InitPower%nn
 13088              do il = lmin,CP%Max_l_tensor
 13089                write(fileio_unit,'(1I6,4E15.5)')il, fact*Cl_tensor(il, in, CT_Temp:CT_Cross)
 13090              end do
 13091             end do
 13092            close(fileio_unit)
 13093         end if
 13094  
 13095         if (CP%WantTensors .and. CP%WantScalars .and. TotFile /= '') then
 13096            open(unit = fileio_unit,file = TotFile,form = 'formatted',status = 'replace')
 13097            do in = 1,CP%InitPower%nn
 13098              do il = lmin,CP%Max_l_tensor
 13099 
 13100                 write(fileio_unit,'(1I6,4E15.5)')il, fact*(Cl_scalar(il, in, C_Temp:C_E)+ Cl_tensor(il,in, C_Temp:C_E)), &
 13101                    fact*Cl_tensor(il,in, CT_B), fact*(Cl_scalar(il, in, C_Cross) + Cl_tensor(il, in, CT_Cross))
 13102              end do
 13103              do il = CP%Max_l_tensor+1,CP%Max_l
 13104                   write(fileio_unit,'(1I6,4E15.5)')il ,fact*Cl_scalar(il,in,C_Temp:C_E), 0, fact*Cl_scalar(il,in,C_Cross)
 13105              end do
 13106            end do
 13107            close(fileio_unit)
 13108         end if
 13109  
 13110         if (CP%WantScalars .and. CP%DoLensing .and. LensFile /= '') then
 13111            open(unit = fileio_unit,file = LensFile,form = 'formatted',status = 'replace')
 13112             do in = 1,CP%InitPower%nn
 13113              do il = lmin, lmax_lensed
 13114                write(fileio_unit,'(1I6,4E15.5)')il, fact*Cl_lensed(il, in, CT_Temp:CT_Cross)
 13115              end do
 13116             end do
 13117            close(fileio_unit)      
 13118         end if
 13119 
 13120 
 13121        if (CP%WantScalars .and. CP%WantTensors .and. CP%DoLensing .and. LensTotFile /= '') then
 13122            open(unit = fileio_unit,file = LensTotFile,form = 'formatted',status = 'replace')
 13123            do in = 1,CP%InitPower%nn
 13124              do il = lmin,min(CP%Max_l_tensor,lmax_lensed)
 13125                 write(fileio_unit,'(1I6,4E15.5)')il, fact*(Cl_lensed(il, in, CT_Temp:CT_Cross)+ Cl_tensor(il,in, CT_Temp:CT_Cross))
 13126              end do
 13127              do il = min(CP%Max_l_tensor,lmax_lensed)+1,lmax_lensed
 13128                 write(fileio_unit,'(1I6,4E15.5)')il, fact*Cl_lensed(il, in, CT_Temp:CT_Cross)
 13129              end do
 13130            end do
 13131      
 13132         end if
 13133         end subroutine output_cl_files
 13134 
 13135         subroutine output_lens_pot_files(LensPotFile, factor)
 13136       !Write out L TT EE BB TE PP PT PE where P is the lensing potential, all unlensed  
 13137       !This input supported by LensPix from 2010
 13138         implicit none
 13139         integer in,il
 13140         real(dl), intent(in), optional :: factor
 13141         real(dl) fact, scale, BB, TT, TE, EE
 13142         character(LEN = *) LensPotFile
 13143          !output file of dimensionless [l(l+1)]^2 C_phi_phi/2pi and [l(l+1)]^(3/2) C_phi_T/2pi 
 13144          !This is the format used by Planck_like but original LensPix uses scalar_output_file.
 13145          
 13146          !(Cl_scalar and scalar_output_file numbers are instead l^4 C_phi and l^3 C_phi 
 13147          ! - for historical reasons) 
 13148 
 13149         if (present(factor)) then
 13150           fact = factor
 13151         else
 13152           fact = 1
 13153         end if
 13154 
 13155         if (CP%WantScalars .and. CP%DoLensing .and. LensPotFile/= '') then
 13156   
 13157            open(unit = fileio_unit,file = LensPotFile,form = 'formatted',status = 'replace')
 13158            do in = 1,CP%InitPower%nn
 13159              do il = lmin,min(10000,CP%Max_l)
 13160              
 13161                TT = Cl_scalar(il, in, C_Temp)
 13162                EE = Cl_scalar(il, in, C_E)
 13163                TE = Cl_scalar(il, in, C_Cross)              
 13164                if (CP%WantTensors .and. il < = CP%Max_l_tensor) then
 13165                 TT = TT+Cl_tensor(il,in, CT_Temp)
 13166                 EE = EE+Cl_tensor(il,in, CT_E)
 13167                 TE = TE+Cl_tensor(il,in, CT_Cross)
 13168                 BB = Cl_tensor(il,in, CT_B)               
 13169                else
 13170                 BB = 0
 13171                end if
 13172                scale = (real(il+1)/il)**2/OutputDenominator !Factor to go from old l^4 factor to new
 13173                
 13174                write(fileio_unit,'(1I6,7E15.5)') il , fact*TT, fact*EE, fact*BB, fact*TE, scale*Cl_scalar(il,in,C_Phi),&
 13175                    (real(il+1)/il)**1.5/OutputDenominator*sqrt(fact)*Cl_scalar(il,in,C_PhiTemp:C_PhiE)
 13176                    
 13177              end do
 13178              do il = 10100,CP%Max_l, 100
 13179                scale = (real(il+1)/il)**2/OutputDenominator
 13180                write(fileio_unit,'(1E15.5,7E15.5)') real(il), fact*Cl_scalar(il,in,C_Temp:C_E),0.,fact*Cl_scalar(il,in,C_Cross), &
 13181                     scale*Cl_scalar(il,in,C_Phi),&
 13182                    (real(il+1)/il)**1.5/OutputDenominator*sqrt(fact)*Cl_scalar(il,in,C_PhiTemp:C_PhiE)
 13183              end do
 13184             end do
 13185             close(fileio_unit)
 13186          end if
 13187         end subroutine output_lens_pot_files
 13188 
 13189 
 13190         subroutine output_veccl_files(VecFile, factor)
 13191         implicit none
 13192         integer in,il
 13193         character(LEN = *) VecFile
 13194         real(dl), intent(in), optional :: factor
 13195         real(dl) fact
 13196 
 13197 
 13198         if (present(factor)) then
 13199           fact = factor
 13200         else
 13201           fact = 1
 13202         end if
 13203 
 13204   
 13205        if (CP%WantVectors .and. VecFile /= '') then
 13206            open(unit = fileio_unit,file = VecFile,form = 'formatted',status = 'replace')
 13207             do in = 1,CP%InitPower%nn
 13208              do il = lmin,CP%Max_l
 13209                write(fileio_unit,'(1I5,4E15.5)')il, fact*Cl_vector(il, in, CT_Temp:CT_Cross)
 13210              end do
 13211             end do
 13212 
 13213            close(fileio_unit)
 13214         end if
 13215  
 13216         end subroutine output_veccl_files
 13217 
 13218 
 13219         subroutine output_COBElikelihood
 13220           integer in
 13221           do in = 1, CP%InitPower%nn
 13222              write(*,*)'COBE Likelihood relative to CP%flat = ',COBElikelihoods(in)
 13223           end do
 13224         end  subroutine output_COBElikelihood
 13225 
 13226         
 13227       subroutine NormalizeClsAtL(lnorm)
 13228         implicit none
 13229         integer, intent(IN) :: lnorm
 13230         integer in
 13231         real(dl) Norm
 13232 
 13233          do in = 1,CP%InitPower%nn
 13234              
 13235              if (CP%WantScalars) then
 13236                 Norm = 1/Cl_scalar(lnorm,in, C_Temp)
 13237                 Cl_scalar(lmin:CP%Max_l, in, C_Temp:C_Cross) = Cl_scalar(lmin:CP%Max_l, in, C_Temp:C_Cross) * Norm
 13238              end if
 13239 
 13240              if (CP%WantTensors) then
 13241                   if (.not.CP%WantScalars) Norm = 1/Cl_tensor(lnorm,in, C_Temp)
 13242                   !Otherwise Norm already set correctly
 13243                   Cl_tensor(lmin:CP%Max_l_tensor, in, CT_Temp:CT_Cross) =  &
 13244                     Cl_tensor(lmin:CP%Max_l_tensor, in, CT_Temp:CT_Cross) * Norm
 13245              end if
 13246        end do
 13247 
 13248       end  subroutine NormalizeClsAtL
 13249 
 13250 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 13251 
 13252         subroutine COBEnormalize
 13253         use precision
 13254         use ModelParams
 13255         
 13256 
 13257         integer in
 13258         real(dl) xlog10
 13259         real(dl) c10, d1,d2,d3,d4,d5,d6,d7, xlogl, COBE_scale
 13260         real(dl) x1, x2,x3,x4,x5,x6,x7,sy,s,sx,sxy,sxx,delt,d1pr,d1ppr
 13261         real(dl) Ctot(lmin:20)
 13262 
 13263     
 13264            if (allocated(COBElikelihoods)) deallocate(COBElikelihoods)
 13265            if (allocated(COBE_scales)) deallocate(COBE_scales)
 13266            allocate(COBElikelihoods(CP%InitPower%nn))
 13267            allocate(COBE_scales(CP%InitPower%nn))
 13268     
 13269 
 13270           
 13271         xlog10 = log(10)
 13272   
 13273 
 13274 ! COBE normalization
 13275 ! fit the spectrum to a quadratic around C_10 with equal weights in logl
 13276 
 13277         do in = 1,CP%InitPower%nn
 13278 
 13279            if (CP%WantTensors) then
 13280               Ctot =  Cl_tensor(lmin:20, in, C_Temp)
 13281            else
 13282               Ctot = 0
 13283            end if
 13284            if (CP%WantScalars) then
 13285               Ctot = Ctot + Cl_scalar(lmin:20, in, C_Temp)
 13286      
 13287            end if
 13288            c10 = Ctot(10)
 13289       
 13290            d1 = (Ctot(3))/c10-1
 13291            d2 = (Ctot(4))/c10-1
 13292            d3 = (Ctot(6))/c10-1
 13293            d4 = (Ctot(8))/c10-1
 13294            d5 = (Ctot(12))/c10-1
 13295            d6 = (Ctot(15))/c10-1
 13296            d7 = (Ctot(20))/c10-1
 13297 
 13298      
 13299            x1 = log(3)/xlog10-1
 13300            x2 = log(4)/xlog10-1
 13301            x3 = log(6)/xlog10-1
 13302            x4 = log(8)/xlog10-1
 13303            x5 = log(12)/xlog10-1
 13304            x6 = log(15)/xlog10-1
 13305            x7 = log(20)/xlog10-1
 13306            sy = x1*d1+x2*d2+x3*d3+x4*d4+x5*d5+x6*d6+x7*d7
 13307            s = x1*x1+x2*x2+x3*x3+x4*x4+x5*x5+x6*x6+x7*x7
 13308            sx = x1**3+x2**3+x3**3+x4**3+x5**3+x6**3+x7**3
 13309            sxy = x1**2*d1+x2**2*d2+x3**2*d3+x4**2*d4+ &
 13310               x5**2*d5+x6**2*d6+x7**2*d7
 13311            sxx = x1**4+x2**4+x3**4+x4**4+x5**4+x6**4+x7**4
 13312            delt = s*sxx-sx*sx
 13313            d1pr = (sxx*sy-sx*sxy)/delt
 13314            d1ppr = 2*(s*sxy-sx*sy)/delt
 13315 
 13316 ! Bunn and White fitting formula
 13317            c10 = (0.64575+0.02282*d1pr+0.01391*d1pr*d1pr &
 13318            -0.01819*d1ppr-0.00646*d1pr*d1ppr &
 13319            +0.00103*d1ppr*d1ppr)/c10
 13320 ! logl
 13321            xlogl = -0.01669+1.19895*d1pr-0.83527*d1pr*d1pr &
 13322                  -0.43541*d1ppr-0.03421*d1pr*d1ppr &
 13323                  +0.01049*d1ppr*d1ppr
 13324           ! write(*,*)'COBE Likelihood relative to CP%flat = ',exp(xlogl)
 13325            COBElikelihoods(in) = exp(xlogl)
 13326 
 13327 ! density power spectrum normalization;
 13328 
 13329            COBE_scale = c10/OutputDenominator*1.1d-9
 13330            COBE_scales(in) = COBE_scale
 13331 
 13332 !!$!delta^2 = k^4*(tf)^2*ScalarPower(k,in)*COBE_scale where (tf) is output in the transfer function file
 13333 !!$!delta^2 = 4*pi*k^3 P(k)
 13334 
 13335 
 13336 ! C_l normalization; output l(l+1)C_l/twopi
 13337            c10 = c10*2.2d-9/fourpi
 13338 
 13339            if (CP%WantScalars) Cl_scalar(lmin:CP%Max_l, in, C_Temp:C_last) = &
 13340                         Cl_scalar(lmin:CP%Max_l, in, C_Temp:C_last)*c10
 13341            if (CP%WantTensors) Cl_tensor(lmin:CP%Max_l_tensor, in, CT_Temp:CT_Cross) = &
 13342                                     Cl_tensor(lmin:CP%Max_l_tensor, in, CT_Temp:CT_Cross)*c10
 13343            
 13344           end do !in
 13345          end subroutine COBEnormalize
 13346         
 13347          subroutine ModelData_Free
 13348 
 13349              call Free_ClTransfer(CTransScal)
 13350              call Free_ClTransfer(CTransVec)
 13351              call Free_ClTransfer(CTransTens)
 13352              if (allocated(Cl_vector)) deallocate(Cl_vector)
 13353              if (allocated(Cl_tensor)) deallocate(Cl_tensor)
 13354              if (allocated(Cl_scalar)) deallocate(Cl_scalar)
 13355              if (allocated(Cl_lensed)) deallocate(Cl_lensed)
 13356              if (allocated(COBElikelihoods)) deallocate(COBElikelihoods)
 13357              if (allocated(COBE_scales)) deallocate(COBE_scales) 
 13358  
 13359          end subroutine ModelData_Free
 13360 
 13361         end module ModelData
 13362 
 13363 
 13364 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 13365     module MassiveNu
 13366       use precision
 13367       use ModelParams
 13368       implicit none
 13369         private 
 13370         
 13371           real(dl), parameter  :: const  = 7/120*pi**4 ! 5.68219698
 13372              !const = int q^3 F(q) dq = 7/120*pi^4
 13373           real(dl), parameter  :: const2 = 5/7/pi**2   !0.072372274
 13374           real(dl), parameter  :: zeta3  = 1.2020569031595942853997
 13375           real(dl), parameter  :: zeta5  = 1.0369277551433699263313
 13376           real(dl), parameter  :: zeta7  = 1.0083492773819228268397
 13377 
 13378           integer, parameter  :: nrhopn = 2000  
 13379           real(dl), parameter :: am_min = 0.01  !0.02
 13380             !smallest a*m_nu to integrate distribution function rather than using series
 13381           real(dl), parameter :: am_max = 600 
 13382             !max a*m_nu to integrate
 13383           
 13384           real(dl),parameter  :: am_minp = am_min*1.1
 13385           real(dl), parameter :: am_maxp = am_max*0.9
 13386    
 13387           real(dl) dlnam
 13388 
 13389           real(dl), dimension(:), allocatable ::  r1,p1,dr1,dp1,ddr1
 13390 
 13391           !Sample for massive neutrino momentum
 13392           !These settings appear to be OK for P_k accuate at 1e-3 level
 13393           integer, parameter :: nqmax0 = 80 !maximum array size of q momentum samples 
 13394           real(dl) :: nu_q(nqmax0), nu_int_kernel(nqmax0)
 13395  
 13396           integer nqmax !actual number of q modes evolves
 13397  
 13398        public const,Nu_Init,Nu_background, Nu_rho, Nu_drho,  nqmax0, nqmax, &
 13399            nu_int_kernel, nu_q
 13400        contains
 13401   !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 13402 
 13403         subroutine Nu_init
 13404       
 13405 !  Initialize interpolation tables for massive neutrinos.
 13406 !  Use cubic splines interpolation of log rhonu and pnu vs. log a*m.
 13407  
 13408          integer i
 13409          real(dl) dq,dlfdlq, q, am, rhonu,pnu
 13410          real(dl) spline_data(nrhopn)
 13411      
 13412 !  nu_masses = m_nu(i)*c**2/(k_B*T_nu0).
 13413 !  Get number density n of neutrinos from
 13414 !  rho_massless/n = int q^3/(1+e^q) / int q^2/(1+e^q) = 7/180 pi^4/Zeta(3)
 13415 !  then m = Omega_nu/N_nu rho_crit /n
 13416 !  Error due to velocity < 1e-5
 13417         
 13418         do i = 1, CP%Nu_mass_eigenstates 
 13419          nu_masses(i) = const/(1.5*zeta3)*grhom/grhor*CP%omegan*CP%Nu_mass_fractions(i) &
 13420                /CP%Nu_mass_degeneracies(i)
 13421         end do
 13422 
 13423         if (allocated(r1)) return
 13424         allocate(r1(nrhopn),p1(nrhopn),dr1(nrhopn),dp1(nrhopn),ddr1(nrhopn))
 13425 
 13426         
 13427         nqmax = 3
 13428         if (AccuracyBoost >1) nqmax = 4
 13429         if (AccuracyBoost >2) nqmax = 5
 13430         if (AccuracyBoost >3) nqmax = nint(AccuracyBoost*10) 
 13431           !note this may well be worse than the 5 optimized points
 13432 
 13433         if (nqmax > nqmax0) call MpiStop('Nu_Init: qmax > nqmax0')
 13434 
 13435         !We evolve evolve 4F_l/dlfdlq(i), so kernel includes dlfdlnq factor
 13436         !Integration scheme gets (Fermi-Dirac thing)*q^n exact,for n = -4, -2..2
 13437         !see CAMB notes
 13438         if (nqmax = 3) then
 13439           !Accurate at 2e-4 level
 13440           nu_q(1:3) = (/0.913201, 3.37517, 7.79184/)
 13441           nu_int_kernel(1:3) = (/0.0687359, 3.31435, 2.29911/)
 13442           
 13443         else if (nqmax = 4) then
 13444           !This seems to be very accurate (limited by other numerics)
 13445            nu_q(1:4) = (/0.7, 2.62814, 5.90428, 12.0/)
 13446            nu_int_kernel(1:4) = (/0.0200251, 1.84539, 3.52736, 0.289427/)
 13447       
 13448         else if (nqmax = 5) then
 13449         !exact for n = -4,-2..3 
 13450         !This seems to be very accurate (limited by other numerics)
 13451          nu_q(1:5) = (/0.583165, 2.0, 4.0, 7.26582, 13.0/)  
 13452          nu_int_kernel(1:5) = (/0.0081201, 0.689407, 2.8063, 2.05156, 0.126817/) 
 13453   
 13454         else
 13455          dq = (12 + nqmax/5)/real(nqmax)
 13456          do i = 1,nqmax
 13457             q = (i-0.5)*dq
 13458             nu_q(i) = q 
 13459             dlfdlq = -q/(1+exp(-q))
 13460             nu_int_kernel(i) = dq*q**3/(exp(q)+1) * (-0.25*dlfdlq) !now evolve 4F_l/dlfdlq(i)
 13461             
 13462          end do
 13463         end if
 13464         nu_int_kernel = nu_int_kernel/const
 13465         
 13466         dlnam = -(log(am_min/am_max))/(nrhopn-1)
 13467  
 13468 
 13469         !$OMP PARALLEL DO DEFAULT(SHARED),SCHEDULE(STATIC) &
 13470         !$OMP & PRIVATE(am, rhonu,pnu) 
 13471         do i = 1,nrhopn
 13472           am = am_min*exp((i-1)*dlnam)
 13473           call nuRhoPres(am,rhonu,pnu)
 13474           r1(i) = log(rhonu)
 13475           p1(i) = log(pnu)
 13476         end do
 13477         !$OMP END PARALLEL DO
 13478 
 13479 
 13480         call splini(spline_data,nrhopn)
 13481         call splder(r1,dr1,nrhopn,spline_data)
 13482         call splder(p1,dp1,nrhopn,spline_data)
 13483         call splder(dr1,ddr1,nrhopn,spline_data)       
 13484 
 13485        
 13486         end subroutine Nu_init
 13487 
 13488 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 13489         subroutine nuRhoPres(am,rhonu,pnu)
 13490 !  Compute the density and pressure of one eigenstate of massive neutrinos,
 13491 !  in units of the mean density of one flavor of massless neutrinos.
 13492 
 13493         real(dl),  parameter :: qmax = 30
 13494         integer, parameter :: nq = 100
 13495         real(dl) dum1(nq+1),dum2(nq+1)
 13496         real(dl), intent(in) :: am
 13497         real(dl), intent(out) ::  rhonu,pnu
 13498         integer i
 13499         real(dl) q,aq,v,aqdn,adq
 13500       
 13501 
 13502 !  q is the comoving momentum in units of k_B*T_nu0/c.
 13503 !  Integrate up to qmax and then use asymptotic expansion for remainder.
 13504         adq = qmax/nq
 13505         dum1(1) = 0
 13506         dum2(1) = 0
 13507         do  i = 1,nq
 13508           q = i*adq
 13509           aq = am/q
 13510           v = 1/sqrt(1+aq*aq)
 13511           aqdn = adq*q*q*q/(exp(q)+1)
 13512           dum1(i+1) = aqdn/v
 13513           dum2(i+1) = aqdn*v
 13514         end do
 13515         call splint(dum1,rhonu,nq+1)
 13516         call splint(dum2,pnu,nq+1)
 13517 !  Apply asymptotic corrrection for q>qmax and normalize by relativistic
 13518 !  energy density.
 13519         rhonu = (rhonu+dum1(nq+1)/adq)/const
 13520         pnu = (pnu+dum2(nq+1)/adq)/const/3
 13521        
 13522         end subroutine nuRhoPres
 13523 
 13524 !cccccccccccccccccccccccccccccccccccccccccc
 13525        subroutine Nu_background(am,rhonu,pnu)
 13526         use precision
 13527         use ModelParams
 13528         real(dl), intent(in) :: am
 13529         real(dl), intent(out) :: rhonu, pnu
 13530 
 13531 !  Compute massive neutrino density and pressure in units of the mean
 13532 !  density of one eigenstate of massless neutrinos.  Use cubic splines to
 13533 !  interpolate from a table.
 13534 
 13535         real(dl) d
 13536         integer i
 13537       
 13538         if (am < = am_minp) then
 13539           rhonu = 1 + const2*am**2  
 13540           pnu = (2-rhonu)/3
 13541           return
 13542         else if (am > = am_maxp) then
 13543           rhonu = 3/(2*const)*(zeta3*am + (15*zeta5)/2/am)
 13544           pnu = 900/120/const*(zeta5-63/4*Zeta7/am**2)/am
 13545           return
 13546         end if
 13547 
 13548         
 13549         d = log(am/am_min)/dlnam+1
 13550         i = int(d)
 13551         d = d-i
 13552        
 13553 !  Cubic spline interpolation.
 13554           rhonu = r1(i)+d*(dr1(i)+d*(3*(r1(i+1)-r1(i))-2*dr1(i) &
 13555                -dr1(i+1)+d*(dr1(i)+dr1(i+1)+2*(r1(i)-r1(i+1)))))
 13556           pnu = p1(i)+d*(dp1(i)+d*(3*(p1(i+1)-p1(i))-2*dp1(i) &
 13557                -dp1(i+1)+d*(dp1(i)+dp1(i+1)+2*(p1(i)-p1(i+1)))))
 13558           rhonu = exp(rhonu)
 13559           pnu = exp(pnu)
 13560 
 13561         end subroutine Nu_background
 13562 
 13563 !cccccccccccccccccccccccccccccccccccccccccc
 13564        subroutine Nu_rho(am,rhonu)
 13565         use precision
 13566         use ModelParams
 13567         real(dl), intent(in) :: am
 13568         real(dl), intent(out) :: rhonu
 13569 
 13570 !  Compute massive neutrino density in units of the mean
 13571 !  density of one eigenstate of massless neutrinos.  Use cubic splines to
 13572 !  interpolate from a table.
 13573 
 13574         real(dl) d
 13575         integer i
 13576       
 13577         if (am < = am_minp) then
 13578           rhonu = 1 + const2*am**2  
 13579           return
 13580         else if (am > = am_maxp) then
 13581           rhonu = 3/(2*const)*(zeta3*am + (15*zeta5)/2/am)
 13582           return
 13583         end if
 13584         
 13585         d = log(am/am_min)/dlnam+1
 13586         i = int(d)
 13587         d = d-i
 13588        
 13589 !  Cubic spline interpolation.
 13590         rhonu = r1(i)+d*(dr1(i)+d*(3*(r1(i+1)-r1(i))-2*dr1(i) &
 13591                -dr1(i+1)+d*(dr1(i)+dr1(i+1)+2*(r1(i)-r1(i+1)))))
 13592         rhonu = exp(rhonu)
 13593        end subroutine Nu_rho
 13594 
 13595 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 13596 
 13597         function Nu_drho(am,adotoa,rhonu) result (rhonudot)
 13598         use precision
 13599         use ModelParams
 13600 
 13601 !  Compute the time derivative of the mean density in massive neutrinos
 13602 !  and the shear perturbation.
 13603         real(dl) adotoa,rhonu,rhonudot
 13604         real(dl) d
 13605         real(dl), intent(IN) :: am
 13606         integer i
 13607 
 13608         if (am< am_minp) then
 13609 
 13610            rhonudot = 2*const2*am**2*adotoa
 13611 
 13612         else if (am>am_maxp) then
 13613 
 13614            rhonudot = 3/(2*const)*(zeta3*am - (15*zeta5)/2/am)*adotoa
 13615 
 13616         else
 13617            
 13618            d = log(am/am_min)/dlnam+1
 13619            i = int(d)
 13620            d = d-i
 13621            !  Cubic spline interpolation for rhonudot.
 13622            rhonudot = dr1(i)+d*(ddr1(i)+d*(3*(dr1(i+1)-dr1(i)) &
 13623                 -2*ddr1(i)-ddr1(i+1)+d*(ddr1(i)+ddr1(i+1) &
 13624                 +2*(dr1(i)-dr1(i+1)))))
 13625      
 13626            rhonudot = rhonu*adotoa*rhonudot/dlnam
 13627         end if
 13628       
 13629         end function Nu_drho
 13630 
 13631       end module MassiveNu
 13632 
 13633 ! wrapper function to avoid cirular module references
 13634       subroutine init_massive_nu(has_massive_nu)
 13635         use MassiveNu
 13636         use ModelParams
 13637         implicit none
 13638         logical, intent(IN) :: has_massive_nu
 13639 
 13640         if (has_massive_nu) then
 13641              call Nu_Init  
 13642         else
 13643              nu_masses = 0
 13644         end if
 13645       end subroutine init_massive_nu
 13646 
 13647 
 13648 !ccccccccccccccccccccccccccccccccccccccccccccccccccc
 13649 
 13650         module Transfer
 13651         use ModelData
 13652         use Errors
 13653         implicit none
 13654         public
 13655         integer, parameter :: Transfer_kh = 1, Transfer_cdm = 2,Transfer_b = 3,Transfer_g=4, &
 13656                               Transfer_r = 5, Transfer_nu = 6,  & !massless and massive neutrino
 13657                               Transfer_tot = 7
 13658        
 13659         integer, parameter :: Transfer_max = Transfer_tot
 13660 
 13661         logical :: transfer_interp_matterpower  = .true. !output regular grid in log k
 13662          !set to false to output calculated values for later interpolation
 13663 
 13664         integer :: transfer_power_var = Transfer_tot 
 13665          !What to use to calulcate the output matter power spectrum and sigma_8
 13666          !Transfer_tot uses total matter perturbation
 13667 
 13668         Type MatterTransferData
 13669          !Computed data
 13670          integer   ::  num_q_trans   !    number of steps in k for transfer calculation
 13671          real(dl), dimension (:), pointer :: q_trans = > NULL() 
 13672          real(dl), dimension (:,:), pointer ::  sigma_8 = > NULL() 
 13673          real, dimension(:,:,:), pointer :: TransferData = > NULL() 
 13674          !TransferData(entry,k_index,z_index) for entry = Tranfer_kh.. Transfer_tot
 13675         end Type MatterTransferData
 13676 
 13677         Type MatterPowerData
 13678          !everything is a function of k/h
 13679           integer   ::  num_k, num_z          
 13680           real(dl), dimension(:), pointer :: log_kh, redshifts = > NULL() 
 13681           !matpower is log(P_k)
 13682           real(dl), dimension(:,:), pointer :: matpower, ddmat = > NULL() 
 13683           !if NonLinear, nonlin_ratio =  sqrt(P_nonlinear/P_linear)
 13684           !function of k and redshift NonLinearScaling(k_index,z_index)         
 13685           real(dl), dimension(:,:), pointer :: nonlin_ratio = > NULL() 
 13686         end Type MatterPowerData
 13687 
 13688         Type (MatterTransferData), save :: MT        
 13689 
 13690       contains
 13691 
 13692         subroutine Transfer_GetMatterPowerData(MTrans, PK_data, in, itf_only)
 13693          !Does *NOT* include non-linear corrections
 13694           !Get total matter power spectrum in units of (h Mpc^{-1})^3 ready for interpolation.
 13695           !Here there definition is < Delta^2(x) > = 1/(2 pi)^3 int d^3k P_k(k)
 13696           !We are assuming that Cls are generated so any baryonic wiggles are well sampled and that matter power
 13697           !sepctrum is generated to beyond the CMB k_max
 13698           Type(MatterTransferData), intent(in) :: MTrans
 13699           Type(MatterPowerData) :: PK_data
 13700           integer, intent(in) :: in
 13701           integer, intent(in), optional :: itf_only
 13702           real(dl) h, kh, k, power
 13703           integer ik
 13704           integer nz,itf, itf_start, itf_end
 13705           
 13706           if (present(itf_only)) then
 13707               itf_start = itf_only
 13708               itf_end = itf_only
 13709               nz = 1
 13710           else
 13711               itf_start = 1
 13712               nz = size(MTrans%TransferData,3)
 13713               itf_end = nz
 13714           end if
 13715           PK_data%num_k = MTrans%num_q_trans
 13716           PK_Data%num_z = nz
 13717 
 13718           allocate(PK_data%matpower(PK_data%num_k,nz))
 13719           allocate(PK_data%ddmat(PK_data%num_k,nz))
 13720           allocate(PK_data%nonlin_ratio(PK_data%num_k,nz))
 13721           allocate(PK_data%log_kh(PK_data%num_k))
 13722           allocate(PK_data%redshifts(nz))
 13723           PK_data%redshifts = CP%Transfer%Redshifts(itf_start:itf_end)
 13724        
 13725           h = CP%H0/100
 13726 
 13727           do ik = 1,MTrans%num_q_trans
 13728                  kh = MTrans%TransferData(Transfer_kh,ik,1)
 13729                  k = kh*h
 13730                  PK_data%log_kh(ik) = log(kh)
 13731                  power = ScalarPower(k,in)
 13732                  if (global_error_flag/= 0) then
 13733                      call MatterPowerdata_Free(PK_data) 
 13734                      return
 13735                  end if      
 13736                  do itf = 1, nz
 13737                    PK_data%matpower(ik,itf) = &
 13738                     log(MTrans%TransferData(transfer_power_var,ik,itf_start+itf-1)**2*k & 
 13739                                    *pi*twopi*h**3*power)
 13740                  end do
 13741           end do
 13742      
 13743           call MatterPowerdata_getsplines(PK_data)
 13744 
 13745         end subroutine Transfer_GetMatterPowerData
 13746 
 13747         subroutine MatterPowerData_Load(PK_data,fname)
 13748           !Loads in kh, P_k from file for one redshiftr and one initial power spectrum
 13749           !Not redshift is not stored in file, so not set correctly
 13750           !Also note that output _matterpower file is already interpolated, so re-interpolating is probs not a good idea
 13751 
 13752           !Get total matter power spectrum in units of (h Mpc^{-1})^3 ready for interpolation.
 13753           !Here there definition is < Delta^2(x) > = 1/(2 pi)^3 int d^3k P_k(k)
 13754           use AmlUtils
 13755           character(LEN = *) :: fname
 13756           Type(MatterPowerData) :: PK_data
 13757           real(dl)kh, Pk
 13758           integer ik
 13759           integer nz
 13760           
 13761 
 13762           nz = 1
 13763           call openTxtFile(fname, fileio_unit)
 13764          
 13765           PK_data%num_k = FileLines(fileio_unit)
 13766           PK_Data%num_z = 1
 13767 
 13768           allocate(PK_data%matpower(PK_data%num_k,nz))
 13769           allocate(PK_data%ddmat(PK_data%num_k,nz))
 13770           allocate(PK_data%nonlin_ratio(PK_data%num_k,nz))
 13771           allocate(PK_data%log_kh(PK_data%num_k))
 13772        
 13773           allocate(PK_data%redshifts(nz))
 13774           PK_data%redshifts = 0
 13775 
 13776           do ik = 1,PK_data%num_k
 13777               read (fileio_unit,*) kh, Pk
 13778               PK_data%matpower(ik,1) = log(Pk) 
 13779               PK_data%log_kh(ik) = log(kh)
 13780           end do
 13781      
 13782           call MatterPowerdata_getsplines(PK_data)
 13783 
 13784         end subroutine MatterPowerData_Load
 13785 
 13786 
 13787         subroutine MatterPowerdata_getsplines(PK_data)
 13788           Type(MatterPowerData) :: PK_data
 13789           integer i
 13790           real(dl), parameter :: cllo = 1.e30,clhi = 1.e30
 13791 
 13792           do i = 1,PK_Data%num_z
 13793           
 13794            call spline(PK_data%log_kh,PK_data%matpower(1,i),PK_data%num_k,&
 13795                                cllo,clhi,PK_data%ddmat(1,i))
 13796           end do
 13797 
 13798         end subroutine MatterPowerdata_getsplines
 13799         
 13800         subroutine MatterPowerdata_MakeNonlinear(PK_data)
 13801           Type(MatterPowerData) :: PK_data
 13802 
 13803           call NonLinear_GetRatios(PK_data)
 13804           PK_data%matpower = PK_data%matpower +  2*log(PK_data%nonlin_ratio)
 13805           call MatterPowerdata_getsplines(PK_data)
 13806 
 13807         end subroutine MatterPowerdata_MakeNonlinear
 13808 
 13809         subroutine MatterPowerdata_Free(PK_data)
 13810           Type(MatterPowerData) :: PK_data
 13811           integer i
 13812 
 13813           deallocate(PK_data%log_kh,stat = i)
 13814           deallocate(PK_data%matpower,stat = i)
 13815           deallocate(PK_data%ddmat,stat = i)
 13816           deallocate(PK_data%nonlin_ratio,stat = i)
 13817           deallocate(PK_data%redshifts,stat = i)
 13818           nullify(PK_data%log_kh,PK_data%matpower,PK_data%ddmat, &
 13819              PK_data%nonlin_ratio,PK_data%redshifts)
 13820 
 13821         end subroutine MatterPowerdata_Free
 13822 
 13823         function MatterPowerData_k(PK,  kh, itf) result(outpower)
 13824          !Get matter power spectrum at particular k/h by interpolation
 13825           Type(MatterPowerData) :: PK
 13826           integer, intent(in) :: itf
 13827           real (dl), intent(in) :: kh
 13828           real(dl) :: logk
 13829           integer llo,lhi
 13830           real(dl) outpower, dp
 13831           real(dl) ho,a0,b0
 13832           integer, save :: i_last = 1          
 13833           
 13834            logk = log(kh)
 13835            if (logk < PK%log_kh(1)) then
 13836               dp = (PK%matpower(2,itf) -  PK%matpower(1,itf)) / &
 13837                  ( PK%log_kh(2)-PK%log_kh(1) )
 13838               outpower = PK%matpower(1,itf) + dp*(logk - PK%log_kh(1))
 13839            else if (logk > PK%log_kh(PK%num_k)) then
 13840             !Do dodgy linear extrapolation on assumption accuracy of result won't matter
 13841            
 13842              dp = (PK%matpower(PK%num_k,itf) -  PK%matpower(PK%num_k-1,itf)) / &
 13843                  ( PK%log_kh(PK%num_k)-PK%log_kh(PK%num_k-1) )
 13844              outpower = PK%matpower(PK%num_k,itf) + dp*(logk - PK%log_kh(PK%num_k))
 13845            else 
 13846 
 13847             llo = min(i_last,PK%num_k)
 13848             do while (PK%log_kh(llo) > logk)
 13849                llo = llo-1
 13850             end do
 13851             do while (PK%log_kh(llo+1)< logk)
 13852                llo = llo+1
 13853             end do
 13854             i_last = llo  
 13855             lhi = llo+1
 13856             ho = PK%log_kh(lhi)-PK%log_kh(llo) 
 13857             a0 = (PK%log_kh(lhi)-logk)/ho
 13858             b0 = 1-a0
 13859               
 13860             outpower = a0*PK%matpower(llo,itf)+ b0*PK%matpower(lhi,itf)+&
 13861                   ((a0**3-a0)* PK%ddmat(llo,itf) &
 13862                        +(b0**3-b0)*PK%ddmat(lhi,itf))*ho**2/6
 13863               
 13864           end if
 13865 
 13866           outpower = exp(max(-30,outpower))
 13867 
 13868         end function MatterPowerData_k
 13869 
 13870 
 13871         subroutine Transfer_GetMatterPower(MTrans,outpower, itf, in, minkh, dlnkh, npoints)
 13872           !Allows for non-smooth priordial spectra
 13873           !if CP%Nonlinear/= NonLinear_none includes non-linear evolution
 13874           !Get total matter power spectrum at logarithmically equal intervals dlnkh of k/h starting at minkh
 13875           !in units of (h Mpc^{-1})^3.   
 13876           !Here there definition is < Delta^2(x) > = 1/(2 pi)^3 int d^3k P_k(k)
 13877           !We are assuming that Cls are generated so any baryonic wiggles are well sampled and that matter power
 13878           !sepctrum is generated to beyond the CMB k_max
 13879           Type(MatterTransferData), intent(in) :: MTrans
 13880           Type(MatterPowerData) :: PK
 13881         
 13882           integer, intent(in) :: itf, in, npoints
 13883           real, intent(out) :: outpower(npoints)
 13884           real, intent(in) :: minkh, dlnkh
 13885           real(dl), parameter :: cllo = 1.e30,clhi = 1.e30
 13886           integer ik, llo,il,lhi,lastix
 13887           real(dl) matpower(MTrans%num_q_trans), kh, kvals(MTrans%num_q_trans), ddmat(MTrans%num_q_trans)
 13888           real(dl) atransfer,xi, a0, b0, ho, logmink,k, h
 13889           
 13890 
 13891           if (npoints < 2) stop 'Need at least 2 points in Transfer_GetMatterPower'
 13892 
 13893 !         if (minkh < MTrans%TransferData(Transfer_kh,1,itf)) then
 13894 !            stop 'Transfer_GetMatterPower: kh out of computed region'
 13895 !          end if
 13896           if (minkh*exp((npoints-1)*dlnkh) > MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf) &
 13897                 .and. FeedbackLevel > 0 ) &
 13898                     write(*,*) 'Warning: extrapolating matter power in Transfer_GetMatterPower'
 13899 
 13900           
 13901           if (CP%NonLinear/= NonLinear_None) then
 13902            call Transfer_GetMatterPowerData(MTrans, PK, in, itf)
 13903            call NonLinear_GetRatios(PK)
 13904           end if
 13905            
 13906           h = CP%H0/100
 13907           logmink = log(minkh)
 13908           do ik = 1,MTrans%num_q_trans
 13909              kh = MTrans%TransferData(Transfer_kh,ik,itf)
 13910              k = kh*h
 13911              kvals(ik) = log(kh)
 13912              atransfer = MTrans%TransferData(transfer_power_var,ik,itf)
 13913              if (CP%NonLinear/= NonLinear_None) &
 13914                  atransfer = atransfer* PK%nonlin_ratio(ik,1) !only one element, this itf
 13915              matpower(ik) = log(atransfer**2*k*pi*twopi*h**3)
 13916                  !Put in power spectrum later: transfer functions should be smooth, initial power may not be                
 13917           end do
 13918              
 13919           call spline(kvals,matpower,MTrans%num_q_trans,cllo,clhi,ddmat)
 13920 
 13921             llo = 1
 13922             lastix = npoints + 1
 13923             do il = 1, npoints
 13924                xi = logmink + dlnkh*(il-1)
 13925                if (xi < kvals(1)) then
 13926                  outpower(il) = -30.
 13927                  cycle
 13928                end if
 13929                do while ((xi > kvals(llo+1)).and.(llo < MTrans%num_q_trans))
 13930                   llo = llo+1
 13931                   if (llo > = MTrans%num_q_trans) exit
 13932                end do
 13933                if (llo = MTrans%num_q_trans) then
 13934                    lastix = il
 13935                    exit
 13936                end if
 13937                lhi = llo+1
 13938                ho = kvals(lhi)-kvals(llo) 
 13939                a0 = (kvals(lhi)-xi)/ho
 13940                b0 = (xi-kvals(llo))/ho
 13941               
 13942                outpower(il) = a0*matpower(llo)+ b0*matpower(lhi)+((a0**3-a0)* ddmat(llo) &
 13943                        +(b0**3-b0)*ddmat(lhi))*ho**2/6
 13944               
 13945             end do
 13946 
 13947             do while (lastix < = npoints)
 13948                !Do linear extrapolation in the log
 13949                !Obviouly inaccurate, non-linear etc, but OK if only using in tails of window functions
 13950                outpower(lastix) = 2*outpower(lastix-1) - outpower(lastix-2)
 13951                lastix = lastix+1
 13952             end do
 13953 
 13954             outpower = exp(max(-30.,outpower))
 13955 
 13956             do il = 1, npoints
 13957                k = exp(logmink + dlnkh*(il-1))*h
 13958                outpower(il) = outpower(il) * ScalarPower(k,in) 
 13959                if (global_error_flag /= 0) exit
 13960             end do
 13961 
 13962           if (CP%NonLinear/= NonLinear_None) call MatterPowerdata_Free(PK)
 13963 
 13964         end subroutine Transfer_GetMatterPower
 13965      
 13966         subroutine Transfer_Get_sigma8(MTrans, sigr8)
 13967           use MassiveNu
 13968           Type(MatterTransferData) :: MTrans
 13969           integer ik, itf, in
 13970           real(dl) kh, k, h, x, win, delta
 13971           real(dl) lnk, dlnk, lnko
 13972           real(dl) dsig8, dsig8o, sig8, sig8o, powers
 13973           real(dl), intent(IN) :: sigr8
 13974          
 13975           !Calculate MTrans%sigma_8^2 = int dk/k win**2 T_k**2 P(k), where win is the FT of a spherical top hat
 13976           !of radius sigr8 h^{-1} Mpc
 13977           
 13978            if (global_error_flag /= 0) return
 13979           
 13980          H = CP%h0/100
 13981          do in = 1, CP%InitPower%nn
 13982           do itf = 1,CP%Transfer%num_redshifts
 13983             lnko = 0
 13984             dsig8o = 0
 13985             sig8 = 0
 13986             sig8o = 0
 13987           do ik = 1, MTrans%num_q_trans
 13988                kh = MTrans%TransferData(Transfer_kh,ik,itf)
 13989                if (kh = 0) cycle
 13990                k = kh*H
 13991                
 13992                delta = k**2*MTrans%TransferData(transfer_power_var,ik,itf)
 13993                !if (CP%NonLinear/= NonLinear_None) delta = delta* MTrans%NonLinearScaling(ik,itf)
 13994                !sigma_8 defined "as though it were linear"
 13995 
 13996                x = kh *sigr8
 13997                win = 3*(sin(x)-x*cos(x))/x**3
 13998                lnk = log(k)
 13999                if (ik = 1) then
 14000                   dlnk = 0.5 
 14001                  !Approx for 2/(CP%InitPower%an(in)+3)  [From int_0^k_1 dk/k k^4 P(k)]
 14002                  !Contribution should be very small in any case 
 14003                else
 14004                   dlnk = lnk-lnko
 14005                end if
 14006                powers = ScalarPower(k,in)
 14007                dsig8 = (win*delta)**2*powers
 14008                sig8 = sig8+(dsig8+dsig8o)*dlnk/2
 14009                dsig8o = dsig8
 14010                lnko = lnk
 14011 
 14012 
 14013           end do
 14014     
 14015           MTrans%sigma_8(itf,in) = sqrt(sig8)
 14016           end do
 14017          end do
 14018 
 14019         end subroutine Transfer_Get_sigma8
 14020 
 14021         subroutine Transfer_output_Sig8(MTrans)
 14022            Type(MatterTransferData), intent(in) :: MTrans
 14023            
 14024            integer in, j
 14025        
 14026            do in = 1, CP%InitPower%nn
 14027             if (CP%InitPower%nn>1)  write(*,*) 'Power spectrum : ', in
 14028             do j = 1, CP%Transfer%num_redshifts
 14029                write(*,*) 'at z = ',real(CP%Transfer%redshifts(j)), ' sigma8 (all matter) = ', real(MTrans%sigma_8(j,in))
 14030             end do
 14031            end do
 14032 
 14033          end subroutine Transfer_output_Sig8
 14034 
 14035 
 14036         subroutine Transfer_output_Sig8AndNorm(MTrans)
 14037            Type(MatterTransferData), intent(in) :: MTrans
 14038            integer in, j
 14039 
 14040            do in = 1, CP%InitPower%nn
 14041              write(*,*) 'Power spectrum ',in, ' COBE_scale = ',real(COBE_scales(in))
 14042             do j = 1, CP%Transfer%num_redshifts
 14043                write(*,*) 'at z = ',real(CP%Transfer%redshifts(j)), ' sigma8(all matter) = ', &
 14044                     real(MTrans%sigma_8(j,in)*sqrt(COBE_scales(in)))
 14045             end do
 14046            end do
 14047                 
 14048          end subroutine Transfer_output_Sig8AndNorm
 14049 
 14050 
 14051         subroutine Transfer_Allocate(MTrans)
 14052          Type(MatterTransferData) :: MTrans
 14053          integer st
 14054 
 14055           deallocate(MTrans%q_trans, STAT = st)
 14056           deallocate(MTrans%TransferData, STAT = st)
 14057           deallocate(MTrans%sigma_8, STAT = st)
 14058           allocate(MTrans%q_trans(MTrans%num_q_trans))            
 14059           allocate(MTrans%TransferData(Transfer_max,MTrans%num_q_trans,CP%Transfer%num_redshifts))  
 14060           allocate(MTrans%sigma_8(CP%Transfer%num_redshifts, CP%InitPower%nn))
 14061            
 14062         end  subroutine Transfer_Allocate
 14063 
 14064         subroutine Transfer_Free(MTrans)
 14065           Type(MatterTransferData):: MTrans
 14066           integer st
 14067 
 14068           deallocate(MTrans%q_trans, STAT = st)
 14069           deallocate(MTrans%TransferData, STAT = st)
 14070           deallocate(MTrans%sigma_8, STAT = st)
 14071           nullify(MTrans%q_trans)
 14072           nullify(MTrans%TransferData)
 14073           nullify(MTrans%sigma_8)
 14074           
 14075         end subroutine Transfer_Free
 14076 
 14077        subroutine Transfer_SetForNonlinearLensing(P)
 14078           Type(TransferParams) :: P
 14079           integer i
 14080 
 14081           P%kmax = 5*AccuracyBoost
 14082           P%k_per_logint  = 0
 14083           P%num_redshifts =  nint(10*AccuracyBoost)
 14084           if (P%num_redshifts > max_transfer_redshifts) &
 14085                 stop 'Transfer_SetForNonlinearLensing: Too many redshifts'
 14086           do i = 1,P%num_redshifts
 14087            P%redshifts(i) = real(P%num_redshifts-i)/(P%num_redshifts/10)
 14088           end do
 14089 
 14090        end subroutine Transfer_SetForNonlinearLensing
 14091 
 14092 
 14093 
 14094         subroutine Transfer_SaveToFiles(MTrans,FileNames)
 14095           use IniFile
 14096           Type(MatterTransferData), intent(in) :: MTrans
 14097           integer i,ik
 14098           character(LEN = Ini_max_string_len), intent(IN) :: FileNames(*)
 14099 
 14100           do i = 1, CP%Transfer%num_redshifts
 14101             if (FileNames(i) /= '') then
 14102             open(unit = fileio_unit,file = FileNames(i),form = 'formatted',status = 'replace')
 14103              do ik = 1,MTrans%num_q_trans
 14104                 if (MTrans%TransferData(Transfer_kh,ik,i)/= 0) then
 14105                  write(fileio_unit,'(7E14.6)') MTrans%TransferData(Transfer_kh:Transfer_max,ik,i)
 14106                 end if
 14107              end do
 14108             close(fileio_unit)
 14109             end if
 14110           end do
 14111 
 14112           
 14113         end subroutine Transfer_SaveToFiles
 14114 
 14115         subroutine Transfer_SaveMatterPower(MTrans, FileNames)
 14116           use IniFile
 14117           !Export files of total  matter power spectra in h^{-1} Mpc units, against k/h.
 14118           Type(MatterTransferData), intent(in) :: MTrans
 14119           character(LEN = Ini_max_string_len), intent(IN) :: FileNames(*)
 14120           integer itf,in,i
 14121           integer points
 14122           real, dimension(:,:), allocatable :: outpower
 14123           character(LEN = 80) fmt
 14124           real minkh,dlnkh
 14125           Type(MatterPowerData) :: PK_data
 14126 
 14127 
 14128           write (fmt,*) CP%InitPower%nn+1
 14129           fmt = '('//trim(adjustl(fmt))//'E15.5)'
 14130           do itf = 1, CP%Transfer%num_redshifts
 14131             if (FileNames(itf) /= '') then
 14132 
 14133             
 14134              if (.not. transfer_interp_matterpower ) then
 14135              
 14136              points = MTrans%num_q_trans
 14137              allocate(outpower(points,CP%InitPower%nn))
 14138        
 14139                  do in = 1, CP%InitPower%nn
 14140 
 14141                    call Transfer_GetMatterPowerData(MTrans, PK_data, in, itf)
 14142 
 14143                   if (CP%NonLinear/= NonLinear_None) call MatterPowerdata_MakeNonlinear(PK_Data)
 14144 
 14145                    outpower(:,in) = exp(PK_data%matpower(:,1))
 14146                    call MatterPowerdata_Free(PK_Data)
 14147                  end do
 14148 
 14149                  open(unit = fileio_unit,file = FileNames(itf),form = 'formatted',status = 'replace')
 14150                  do i = 1,points
 14151                   write (fileio_unit, fmt) MTrans%TransferData(Transfer_kh,i,1),outpower(i,1:CP%InitPower%nn)
 14152                  end do
 14153                  close(fileio_unit)
 14154 
 14155              else
 14156 
 14157 
 14158              minkh = 1e-4
 14159              dlnkh = 0.02
 14160              points = log(MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf)/minkh)/dlnkh+1
 14161 !             dlnkh = log(MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf)/minkh)/(points-0.999)
 14162              allocate(outpower(points,CP%InitPower%nn))
 14163              do in = 1, CP%InitPower%nn
 14164               call Transfer_GetMatterPower(MTrans,outpower(1,in), itf, in, minkh,dlnkh, points)
 14165               if (CP%OutputNormalization = outCOBE) then
 14166                  if (allocated(COBE_scales)) then
 14167                   outpower(:,in) = outpower(:,in)*COBE_scales(in)
 14168                  else
 14169                   if (FeedbackLevel>0) write (*,*) 'Cannot COBE normalize - no Cls generated'
 14170                  end if
 14171              end if
 14172              end do
 14173      
 14174              open(unit = fileio_unit,file = FileNames(itf),form = 'formatted',status = 'replace')
 14175              do i = 1,points
 14176               write (fileio_unit, fmt) minkh*exp((i-1)*dlnkh),outpower(i,1:CP%InitPower%nn)
 14177              end do
 14178              close(fileio_unit)
 14179              
 14180              end if
 14181 
 14182              deallocate(outpower) 
 14183              
 14184             end if
 14185           end do
 14186 
 14187         end subroutine Transfer_SaveMatterPower
 14188 
 14189         end module Transfer
 14190 
 14191 
 14192 !ccccccccccccccccccccccccccccccccccccccccccccccccccc
 14193 
 14194         module ThermoData
 14195         use ModelData
 14196         implicit none
 14197         private
 14198         integer,parameter :: nthermo = 20000
 14199         
 14200         real(dl) tb(nthermo),cs2(nthermo),xe(nthermo)
 14201         real(dl) dcs2(nthermo)
 14202         real(dl) dotmu(nthermo), ddotmu(nthermo)
 14203         real(dl) sdotmu(nthermo),emmu(nthermo)
 14204         real(dl) demmu(nthermo)
 14205         real(dl) dddotmu(nthermo),ddddotmu(nthermo)
 14206         real(dl) tauminn,dlntau,Maxtau
 14207         real(dl), dimension(:), allocatable :: vis,dvis,ddvis,expmmu,dopac, opac
 14208     
 14209         real(dl) :: tight_tau, actual_opt_depth
 14210          !Times when 1/(opacity*tau) = 0.01, for use switching tight coupling approximation
 14211         real(dl) :: matter_verydom_tau
 14212         real(dl) :: r_drag0, z_star, z_drag  !!JH for updated BAO likelihood.
 14213         public thermo,inithermo,vis,opac,expmmu,dvis,dopac,ddvis, tight_tau,&
 14214                Thermo_OpacityToTime,matter_verydom_tau, ThermoData_Free,&
 14215                z_star, z_drag !!JH for updated BAO likelihood.
 14216        contains
 14217 
 14218         subroutine thermo(tau,cs2b,opacity, dopacity)
 14219         !Compute unperturbed sound speed squared,
 14220         !and ionization fraction by interpolating pre-computed tables.
 14221         !If requested also get time derivative of opacity
 14222         implicit none
 14223         real(dl) tau,cs2b,opacity
 14224         real(dl), intent(out), optional :: dopacity
 14225 
 14226         integer i
 14227         real(dl) d
 14228         
 14229         d = log(tau/tauminn)/dlntau+1
 14230         i = int(d)
 14231         d = d-i
 14232         if (i < 1) then
 14233         !Linear interpolation if out of bounds (should not occur).
 14234           cs2b = cs2(1)+(d+i-1)*dcs2(1)
 14235           opacity = dotmu(1)+(d-1)*ddotmu(1)
 14236           stop 'thermo out of bounds'
 14237         else if (i > = nthermo) then
 14238           cs2b = cs2(nthermo)+(d+i-nthermo)*dcs2(nthermo)
 14239           opacity = dotmu(nthermo)+(d-nthermo)*ddotmu(nthermo)
 14240           if (present(dopacity)) then
 14241              dopacity = 0
 14242              stop 'thermo: shouldn''t happen'
 14243            end if
 14244         else
 14245         !Cubic spline interpolation.
 14246           cs2b = cs2(i)+d*(dcs2(i)+d*(3*(cs2(i+1)-cs2(i))  &
 14247               -2*dcs2(i)-dcs2(i+1)+d*(dcs2(i)+dcs2(i+1)  &
 14248               +2*(cs2(i)-cs2(i+1)))))
 14249           opacity = dotmu(i)+d*(ddotmu(i)+d*(3*(dotmu(i+1)-dotmu(i)) &
 14250               -2*ddotmu(i)-ddotmu(i+1)+d*(ddotmu(i)+ddotmu(i+1) &
 14251               +2*(dotmu(i)-dotmu(i+1)))))
 14252 
 14253          if (present(dopacity)) then
 14254 
 14255           dopacity = (ddotmu(i)+d*(dddotmu(i)+d*(3*(ddotmu(i+1)  &
 14256               -ddotmu(i))-2*dddotmu(i)-dddotmu(i+1)+d*(dddotmu(i) &
 14257               +dddotmu(i+1)+2*(ddotmu(i)-ddotmu(i+1))))))/(tau*dlntau)
 14258 
 14259          end if
 14260         end if
 14261         end subroutine thermo
 14262         
 14263 
 14264 
 14265        function Thermo_OpacityToTime(opacity)
 14266          real(dl), intent(in) :: opacity
 14267          integer j
 14268          real(dl) Thermo_OpacityToTime
 14269          !Do this the bad slow way for now..
 14270           !The answer is approximate
 14271          j = 1
 14272          do while(dotmu(j)> opacity)
 14273             j = j+1
 14274          end do
 14275           
 14276          Thermo_OpacityToTime = exp((j-1)*dlntau)*tauminn
 14277 
 14278        end function Thermo_OpacityToTime
 14279 
 14280      subroutine inithermo(taumin,taumax)
 14281 !  Compute and save unperturbed baryon temperature and ionization fraction
 14282 !  as a function of time.  With nthermo = 10000, xe(tau) has a relative 
 14283 ! accuracy (numerical integration precision) better than 1.e-5.
 14284         use constants
 14285         use precision
 14286         use ModelParams
 14287         use MassiveNu
 14288         real(dl) taumin,taumax
 14289    
 14290    
 14291         real(dl) tau01,adot0,a0,a02,x1,x2,barssc,dtau
 14292         real(dl) xe0,tau,a,a2
 14293         real(dl) adot,tg0,ahalf,adothalf,fe,thomc,thomc0,etc,a2t
 14294         real(dl) dtbdla,vfi,cf1,maxvis, vis
 14295         integer ncount,i,j1,j2,iv,ns
 14296         real(dl) spline_data(nthermo)
 14297         real(dl) last_dotmu
 14298         real(dl) dtauda  !diff of tau w.CP%r.t a and integration
 14299         external dtauda
 14300         real(dl) a_verydom
 14301      
 14302         call Recombination_Init(CP%Recomb, CP%omegac, CP%omegab,CP%Omegan, CP%Omegav, CP%h0,CP%tcmb,CP%yhe)
 14303           !almost all the time spent here
 14304         if (global_error_flag/= 0) return
 14305         Maxtau = taumax
 14306         tight_tau = 0
 14307         actual_opt_depth = 0
 14308         ncount = 0
 14309         thomc0 = Compton_CT * CP%tcmb**4 
 14310         !thomc0 = 5.0577d-8*CP%tcmb**4
 14311         
 14312         tauminn = 0.05*taumin
 14313         dlntau = log(CP%tau0/tauminn)/(nthermo-1)
 14314         last_dotmu = 0
 14315 
 14316         matter_verydom_tau = 0
 14317         a_verydom = AccuracyBoost*5*(grhog+grhornomass)/(grhoc+grhob)
 14318  
 14319 !  Initial conditions: assume radiation-dominated universe.
 14320         tau01 = tauminn
 14321         adot0 = adotrad
 14322         a0 = adotrad*tauminn
 14323         a02 = a0*a0
 14324 !  Assume that any entropy generation occurs before tauminn.
 14325 !  This gives wrong temperature before pair annihilation, but
 14326 !  the error is harmless.
 14327         tb(1) = CP%tcmb/a0
 14328         xe0 = 1
 14329         x1 = 0
 14330         x2 = 1
 14331         xe(1) = xe0+0.25*CP%yhe/(1-CP%yhe)*(x1+2*x2)
 14332         barssc = barssc0*(1-0.75*CP%yhe+(1-CP%yhe)*xe(1))
 14333         cs2(1) = 4/3*barssc*tb(1)
 14334         dotmu(1) = xe(1)*akthom/a02
 14335         sdotmu(1) = 0
 14336   
 14337           do i = 2,nthermo
 14338           tau = tauminn*exp((i-1)*dlntau)
 14339           dtau = tau-tau01
 14340 !  Integrate Friedmann equation using inverse trapezoidal rule.
 14341       
 14342           a = a0+adot0*dtau
 14343           a2 = a*a
 14344 
 14345           adot = 1/dtauda(a)
 14346 
 14347           if (matter_verydom_tau = 0 .and. a > a_verydom) then
 14348              matter_verydom_tau = tau  
 14349           end if
 14350           
 14351           a = a0+2*dtau/(1/adot0+1/adot)         
 14352 !  Baryon temperature evolution: adiabatic except for Thomson cooling.
 14353 !  Use  quadrature solution.
 14354 ! This is redundant as also calculated in REFCAST, but agrees well before reionization
 14355           tg0 = CP%tcmb/a0
 14356           ahalf = 0.5*(a0+a)
 14357           adothalf = 0.5*(adot0+adot)
 14358 !  fe = number of free electrons divided by total number of free baryon
 14359 !  particles (e+p+H+He).  Evaluate at timstep i-1 for convenience; if
 14360 !  more accuracy is required (unlikely) then this can be iterated with
 14361 !  the solution of the ionization equation.
 14362           fe = (1-CP%yhe)*xe(i-1)/(1-0.75*CP%yhe+(1-CP%yhe)*xe(i-1))
 14363           thomc = thomc0*fe/adothalf/ahalf**3
 14364           etc = exp(-thomc*(a-a0))
 14365           a2t = a0*a0*(tb(i-1)-tg0)*etc-CP%tcmb/thomc*(1-etc)
 14366           tb(i) = CP%tcmb/a+a2t/(a*a)
 14367        
 14368 ! If there is re-ionization, smoothly increase xe to the 
 14369 ! requested value.
 14370           if (CP%Reion%Reionization .and. tau > CP%ReionHist%tau_start) then
 14371              if(ncount = 0) then
 14372                 ncount = i-1
 14373              end if   
 14374 
 14375             xe(i) = Reionization_xe(a, tau, xe(ncount))
 14376             !print *,1/a-1,xe(i)
 14377             if (CP%AccurateReionization .and. FeedbackLevel > 0) then                         
 14378                 dotmu(i) = (Recombination_xe(a) - xe(i))*akthom/a2
 14379                 
 14380                 if (last_dotmu /= 0) then
 14381                  actual_opt_depth = actual_opt_depth - 2*dtau/(1/dotmu(i)+1/last_dotmu)
 14382                 end if
 14383                 last_dotmu = dotmu(i) 
 14384             end if
 14385            
 14386           else
 14387             xe(i) = Recombination_xe(a)
 14388           end if 
 14389        
 14390        
 14391 !  Baryon sound speed squared (over c**2).
 14392           dtbdla = -2*tb(i)-thomc*adothalf/adot*(a*tb(i)-CP%tcmb)
 14393           barssc = barssc0*(1-0.75*CP%yhe+(1-CP%yhe)*xe(i))
 14394           cs2(i) = barssc*tb(i)*(1-dtbdla/tb(i)/3)
 14395           
 14396           
 14397 ! Calculation of the visibility function
 14398           dotmu(i) = xe(i)*akthom/a2
 14399 
 14400           if (tight_tau = 0 .and. 1/(tau*dotmu(i)) > 0.005) tight_tau = tau !0.005
 14401            !Tight coupling switch time when k/opacity is smaller than 1/(tau*opacity)
 14402            
 14403           if (tau < 0.001) then
 14404              sdotmu(i) = 0
 14405           else
 14406              sdotmu(i) = sdotmu(i-1)+2*dtau/(1/dotmu(i)+1/dotmu(i-1))
 14407           end if
 14408 
 14409           a0 = a
 14410           tau01 = tau
 14411           adot0 = adot
 14412           end do !i
 14413                  
 14414           if (CP%Reion%Reionization .and. (xe(nthermo) < 0.999)) then
 14415              write(*,*)'Warning: xe at redshift zero is < 1'
 14416              write(*,*) 'Check input parameters an Reionization_xe'
 14417              write(*,*) 'function in the Reionization module'
 14418           end if
 14419    
 14420         do j1 = 1,nthermo
 14421            if (sdotmu(j1) - sdotmu(nthermo)< -69) then
 14422            emmu(j1) = 1.d-30
 14423            else
 14424            emmu(j1) = exp(sdotmu(j1)-sdotmu(nthermo))
 14425            if (.not. CP%AccurateReionization .and. &
 14426                actual_opt_depth = 0 .and. xe(j1) < 1e-3) then
 14427               actual_opt_depth = -sdotmu(j1)+sdotmu(nthermo) 
 14428            end if
 14429           end if
 14430         end do  
 14431 
 14432         if (CP%AccurateReionization .and. FeedbackLevel > 0) then                         
 14433          write(*,'("Reion opt depth      = ",f7.4)') actual_opt_depth
 14434         end if
 14435 
 14436         iv = 0
 14437         vfi = 0
 14438 ! Getting the starting and finishing times for decoupling and time of maximum visibility
 14439         if (ncount = 0) then
 14440            cf1 = 1
 14441            ns = nthermo
 14442            else
 14443               cf1 = exp(sdotmu(nthermo)-sdotmu(ncount))
 14444               ns = ncount
 14445            end if
 14446          maxvis = 0
 14447          do j1 = 1,ns
 14448            vis = emmu(j1)*dotmu(j1)
 14449            tau = tauminn*exp((j1-1)*dlntau)
 14450            vfi = vfi+vis*cf1*dlntau*tau
 14451            if ((iv = 0).and.(vfi > 1.0d-7/AccuracyBoost)) then  
 14452               taurst = 9/10*tau
 14453               iv = 1
 14454            elseif (iv = 1) then 
 14455                if (vis > maxvis) then
 14456                 maxvis = vis
 14457                 tau_maxvis = tau
 14458                end if
 14459                if (vfi > 0.995) then 
 14460                 taurend = tau 
 14461                 iv = 2
 14462                 exit
 14463                end if
 14464            end if
 14465          end do
 14466 
 14467            if (iv /= 2) then
 14468              call GlobalError('inithermo: failed to find end of recombination',error_reionization)
 14469              return
 14470            end if
 14471 
 14472 ! Calculating the timesteps during recombination.
 14473     
 14474            if (CP%WantTensors) then
 14475               dtaurec = min(dtaurec,taurst/160)/AccuracyBoost 
 14476            else
 14477               dtaurec = min(dtaurec,taurst/40)/AccuracyBoost  
 14478               if (do_bispectrum .and. hard_bispectrum) dtaurec = dtaurec / 4
 14479            end if
 14480             
 14481            if (CP%Reion%Reionization) taurend = min(taurend,CP%ReionHist%tau_start)
 14482 
 14483          if (DebugMsgs) then
 14484            write (*,*) 'taurst, taurend = ', taurst, taurend
 14485          end if
 14486   
 14487         call splini(spline_data,nthermo)
 14488         call splder(cs2,dcs2,nthermo,spline_data)
 14489         call splder(dotmu,ddotmu,nthermo,spline_data)
 14490         call splder(ddotmu,dddotmu,nthermo,spline_data)  
 14491         call splder(dddotmu,ddddotmu,nthermo,spline_data)
 14492         call splder(emmu,demmu,nthermo,spline_data)
 14493    
 14494         call SetTimeSteps
 14495 
 14496         !$OMP PARALLEL DO DEFAULT(SHARED),SCHEDULE(STATIC) 
 14497         do j2 = 1,TimeSteps%npoints
 14498              call DoThermoSpline(j2,TimeSteps%points(j2))
 14499         end do 
 14500          !$OMP END PARALLEL DO 
 14501 
 14502         if (CP%want_zdrag .or. CP%want_zstar) then !JH: calculate exact zstar and/or zdrag
 14503 
 14504            r_drag0 = 3/4*CP%omegab*grhom/grhog
 14505 
 14506            if (CP%want_zstar) call find_z(optdepth,z_star)
 14507            if (CP%want_zdrag) call find_z(dragoptdepth,z_drag)
 14508 
 14509         end if
 14510         end subroutine inithermo        
 14511 
 14512 
 14513         subroutine SetTimeSteps
 14514         real(dl) dtau0
 14515         integer nri0, nstep
 14516 
 14517          call Ranges_Init(TimeSteps)
 14518          
 14519          call Ranges_Add_delta(TimeSteps, taurst, taurend, dtaurec)
 14520 
 14521         ! Calculating the timesteps after recombination
 14522            if (CP%WantTensors) then
 14523               dtau0 = max(taurst/40,Maxtau/2000/AccuracyBoost)
 14524            else       
 14525               dtau0 = Maxtau/500/AccuracyBoost 
 14526               if (do_bispectrum) dtau0 = dtau0/3 
 14527              !Don't need this since adding in Limber on small scales
 14528               !  if (CP%DoLensing) dtau0 = dtau0/2 
 14529               !  if (CP%AccurateBB) dtau0 = dtau0/3 !Need to get C_Phi accurate on small scales
 14530            end if
 14531     
 14532          call Ranges_Add_delta(TimeSteps,taurend, CP%tau0, dtau0)
 14533 
 14534          if (CP%Reion%Reionization) then
 14535            
 14536               nri0 = int(Reionization_timesteps(CP%ReionHist)*AccuracyBoost) 
 14537                 !Steps while reionization going from zero to maximum
 14538               call Ranges_Add(TimeSteps,CP%ReionHist%tau_start,CP%ReionHist%tau_complete,nri0) 
 14539 
 14540          end if
 14541 
 14542 !Create arrays out of the region information.
 14543         call Ranges_GetArray(TimeSteps)
 14544         nstep = TimeSteps%npoints
 14545 
 14546         if (allocated(vis)) then
 14547            deallocate(vis,dvis,ddvis,expmmu,dopac, opac)
 14548         end if
 14549         allocate(vis(nstep),dvis(nstep),ddvis(nstep),expmmu(nstep),dopac(nstep),opac(nstep))
 14550 
 14551         if (DebugMsgs .and. FeedbackLevel > 0) write(*,*) 'Set ',nstep, ' time steps'
 14552     
 14553         end subroutine SetTimeSteps
 14554 
 14555 
 14556         subroutine ThermoData_Free
 14557          if (allocated(vis)) then
 14558            deallocate(vis,dvis,ddvis,expmmu,dopac, opac)
 14559          end if
 14560          call Ranges_Free(TimeSteps)
 14561 
 14562         end subroutine ThermoData_Free
 14563 
 14564 !cccccccccccccc
 14565         subroutine DoThermoSpline(j2,tau)
 14566         integer j2,i
 14567         real(dl) d,ddopac,tau
 14568         
 14569 !     Cubic-spline interpolation.
 14570            d = log(tau/tauminn)/dlntau+1
 14571            i = int(d)
 14572       
 14573            d = d-i
 14574            if (i < nthermo) then
 14575           opac(j2) = dotmu(i)+d*(ddotmu(i)+d*(3*(dotmu(i+1)-dotmu(i)) &
 14576               -2*ddotmu(i)-ddotmu(i+1)+d*(ddotmu(i)+ddotmu(i+1) &
 14577               +2*(dotmu(i)-dotmu(i+1)))))
 14578           dopac(j2) = (ddotmu(i)+d*(dddotmu(i)+d*(3*(ddotmu(i+1)  &
 14579               -ddotmu(i))-2*dddotmu(i)-dddotmu(i+1)+d*(dddotmu(i) &
 14580               +dddotmu(i+1)+2*(ddotmu(i)-ddotmu(i+1))))))/(tau &
 14581               *dlntau)
 14582           ddopac = (dddotmu(i)+d*(ddddotmu(i)+d*(3*(dddotmu(i+1) &
 14583               -dddotmu(i))-2*ddddotmu(i)-ddddotmu(i+1)  &
 14584               +d*(ddddotmu(i)+ddddotmu(i+1)+2*(dddotmu(i) &
 14585               -dddotmu(i+1)))))-(dlntau**2)*tau*dopac(j2)) &
 14586               /(tau*dlntau)**2
 14587           expmmu(j2) = emmu(i)+d*(demmu(i)+d*(3*(emmu(i+1)-emmu(i)) &
 14588               -2*demmu(i)-demmu(i+1)+d*(demmu(i)+demmu(i+1) &
 14589               +2*(emmu(i)-emmu(i+1)))))
 14590  
 14591           vis(j2) = opac(j2)*expmmu(j2)
 14592           dvis(j2) = expmmu(j2)*(opac(j2)**2+dopac(j2))
 14593           ddvis(j2) = expmmu(j2)*(opac(j2)**3+3*opac(j2)*dopac(j2)+ddopac)
 14594           else
 14595           opac(j2) = dotmu(nthermo)
 14596           dopac(j2) = ddotmu(nthermo)
 14597           ddopac = dddotmu(nthermo)
 14598           expmmu(j2) = emmu(nthermo)
 14599           vis(j2) = opac(j2)*expmmu(j2)
 14600           dvis(j2) = expmmu(j2)*(opac(j2)**2+dopac(j2))
 14601           ddvis(j2) = expmmu(j2)*(opac(j2)**3+3*opac(j2)*dopac(j2)+ddopac)
 14602 
 14603           end if
 14604         end subroutine DoThermoSpline
 14605 
 14606 !!!!!!!!!!!!!!!!!!!
 14607 !JH: functions and subroutines for calculating z_star and z_drag
 14608 
 14609         function doptdepth_dz(z)
 14610           real(dl) :: doptdepth_dz
 14611           real(dl), intent(in) :: z
 14612           real(dl) :: a
 14613           real(dl) :: dtauda
 14614           external dtauda
 14615 
 14616           a = 1/(1+z)
 14617 
 14618           !ignoring reionisation, not relevant for distance measures
 14619           doptdepth_dz = Recombination_xe(a)*akthom*dtauda(a)
 14620 
 14621         end function doptdepth_dz
 14622 
 14623         function optdepth(z)
 14624           real(dl) :: rombint2
 14625           external rombint2
 14626           real(dl) optdepth
 14627           real(dl),intent(in) :: z
 14628 
 14629           optdepth = rombint2(doptdepth_dz, 0, z, 1d-5, 20, 100)
 14630 
 14631         end function optdepth
 14632 
 14633 
 14634         function ddragoptdepth_dz(z)
 14635           real(dl) :: ddragoptdepth_dz
 14636           real(dl), intent(in) :: z
 14637           real(dl) :: a
 14638           real(dl) :: dtauda
 14639           external dtauda
 14640 
 14641           a = 1/(1+z)
 14642           ddragoptdepth_dz = doptdepth_dz(z)/r_drag0/a
 14643 
 14644         end function ddragoptdepth_dz
 14645 
 14646 
 14647         function dragoptdepth(z)
 14648           real(dl) :: rombint2
 14649           external rombint2
 14650           real(dl) dragoptdepth
 14651           real(dl),intent(in) :: z
 14652 
 14653           dragoptdepth =  rombint2(ddragoptdepth_dz, 0, z, 1d-5, 20, 100)
 14654 
 14655         end function dragoptdepth
 14656 
 14657 
 14658        subroutine find_z(func,zout)  !find redshift at which (photon/drag) optical depth = 1
 14659           real(dl), external :: func
 14660           real(dl), intent(out) :: zout
 14661           real(dl) :: try1,try2,diff,avg
 14662           integer :: i
 14663 
 14664           try1 = 0
 14665           try2 = 10000
 14666 
 14667           i = 0
 14668           diff = 10
 14669          do while (diff  >  1d-3)
 14670              i = i+1
 14671              if (i  =  100) then
 14672                call GlobalError('optical depth redshift finder did not converge',error_reionization)
 14673                zout = 0
 14674                return
 14675             end if 
 14676 
 14677              diff = func(try2)-func(try1)
 14678              avg = 0.5*(try2+try1)
 14679              if (func(avg)  >  1) then
 14680                 try2 = avg
 14681              else
 14682                 try1 = avg
 14683              end if
 14684           end do
 14685 
 14686           zout = avg
 14687 
 14688         end subroutine find_z
 14689 
 14690 !!!!!!!!!!!!!!!!!!! end JH
 14691  
 14692       end module ThermoData
 14693 
 14694 ** power_tilt.f90
 14695 
 14696 !This module provides the initial power spectra, parameterized as an expansion in ln k
 14697 !
 14698 ! ln P = ln A_s + (n_s -1)*ln(k/k_0) + n_{run}/2 * ln(k/k_0)^2 
 14699 !
 14700 ! so if n_run = 0
 14701 !
 14702 ! P = A_s (k/k_0_scalar)^(n_s-1)
 14703 !
 14704 !for the scalar spectrum, when an(in) is the in'th spectral index. k_0_scalar
 14705 !is a pivot scale, fixed here to 0.05/Mpc (change it below as desired).
 14706 !
 14707 !This module uses the same inputs an(in), ant(in) and rat(in) as CMBFAST, however here
 14708 !rat(in) is used to set the ratio of the initial power spectra, so here
 14709 !
 14710 !** rat(in) is not the Cl quadrupole ratio ***
 14711 !
 14712 !in general models the quadrupole ratio depends in a complicated way on the ratio of the initial
 14713 !power spectra
 14714 
 14715 !The absolute normalization of the Cls is unimportant here, but the relative ratio
 14716 !of the tensor and scalar Cls generated with this module will be correct for general models
 14717 
 14718 
 14719 !The OutputNormalization parameter controls the final output
 14720 !Absolute Cls can be obtained by setting OuputNormalization = outNone, otherwise the overall normalization
 14721 !of the power spectra doesn't matter
 14722 
 14723 !This version December 2003 - changed default tensor pivot to 0.05 (consistent with CMBFAST 4.5)
 14724 
 14725      module InitialPower   
 14726      use Precision
 14727      implicit none   
 14728 
 14729      private
 14730     
 14731       character(LEN = *), parameter :: Power_Name = 'power_tilt'
 14732 
 14733       integer, parameter :: nnmax = 5 
 14734        !Maximum possible number of different power spectra to use
 14735 
 14736       Type InitialPowerParams
 14737 
 14738        integer nn  !Must have this variable
 14739       !The actual number of power spectra to use
 14740   
 14741       !For the default implementation return power spectra based on spectral indices
 14742        real(dl) an(nnmax) !scalar spectral indices
 14743        real(dl) n_run(nnmax) !running of spectral index 
 14744        real(dl) ant(nnmax) !tensor spectral indices
 14745        real(dl) rat(nnmax) !ratio of scalar to tensor initial power spectrum amplitudes
 14746        real(dl) k_0_scalar, k_0_tensor
 14747        real(dl) ScalarPowerAmp(nnmax)
 14748  
 14749       end Type InitialPowerParams
 14750 
 14751       real(dl) curv  !Curvature contant, set in InitializePowers     
 14752       
 14753       Type(InitialPowerParams) :: P
 14754   
 14755 !Make things visible as neccessary...
 14756  
 14757       public InitialPowerParams, InitialPower_ReadParams, InitializePowers, ScalarPower, TensorPower
 14758       public nnmax,Power_Descript, Power_Name, SetDefPowerParams
 14759 !      public 
 14760     contains
 14761        
 14762   
 14763        subroutine SetDefPowerParams(AP)
 14764         Type (InitialPowerParams) :: AP
 14765 
 14766          AP%nn     = 1 !number of initial power spectra
 14767          AP%an     = 1 !scalar spectral index
 14768          AP%n_run   = 0 !running of scalar spectral index
 14769          AP%ant    = 0 !tensor spectra index
 14770          AP%rat    = 1
 14771          AP%k_0_scalar = 0.05
 14772          AP%k_0_tensor = 0.05
 14773          AP%ScalarPowerAmp = 1
 14774 
 14775        end subroutine SetDefPowerParams
 14776 
 14777        subroutine InitializePowers(AParamSet,acurv)
 14778          Type (InitialPowerParams) :: AParamSet
 14779          !Called before computing final Cls in cmbmain.f90
 14780          !Could read spectra from disk here, do other processing, etc.
 14781 
 14782         real(dl) acurv
 14783 
 14784         if (AParamSet%nn > nnmax) then
 14785            write (*,*) 'To use ',AParamSet%nn,'power spectra you need to increase'
 14786            write (*,*) 'nnmax in power_tilt.f90, currently ',nnmax
 14787         end if
 14788         P = AParamSet
 14789 
 14790         curv = acurv         
 14791 
 14792 !Write implementation specific code here...
 14793 
 14794        end subroutine InitializePowers
 14795        
 14796 
 14797       function ScalarPower(k,in)
 14798 
 14799        !"in" gives the index of the power to return for this k
 14800        !ScalarPower = const for scale invariant spectrum
 14801        !The normalization is defined so that for adiabatic perturbations the gradient of the 3-Ricci 
 14802        !scalar on co-moving hypersurfaces receives power
 14803        ! < |D_a R^{(3)}|^2 > = int dk/k 16 k^6/S^6 (1-3K/k^2)^2 ScalarPower(k) 
 14804        !In other words ScalarPower is the power spectrum of the conserved curvature perturbation given by
 14805        !-chi = \Phi + 2/3*\Omega^{-1} \frac{H^{-1}\Phi' - \Psi}{1+w}
 14806        !(w = p/\rho), so < |\chi(x)|^2 > = \int dk/k ScalarPower(k).
 14807        !Near the end of inflation chi is equal to 3/2 Psi.
 14808        !Here nu^2 = (k^2 + curv)/|curv| 
 14809 
 14810        !This power spectrum is also used for isocurvature modes where 
 14811        !< |\Delta(x)|^2 > = \int dk/k ScalarPower(k)
 14812        !For the isocurvture velocity mode ScalarPower is the power in the neutrino heat flux.
 14813 
 14814         real(dl) ScalarPower,k, lnrat
 14815         integer in
 14816 
 14817           lnrat = log(k/P%k_0_scalar)
 14818           ScalarPower = P%ScalarPowerAmp(in)*exp((P%an(in)-1)*lnrat + P%n_run(in)/2*lnrat**2)   
 14819      
 14820 !         ScalarPower = ScalarPower * (1 + 0.1*cos( lnrat*30 ) )
 14821  
 14822       end function ScalarPower
 14823 
 14824       
 14825       function TensorPower(k,in)
 14826       
 14827        !TensorPower = const for scale invariant spectrum
 14828        !The normalization is defined so that
 14829        ! < h_{ij}(x) h^{ij}(x) > = \sum_nu nu /(nu^2-1) (nu^2-4)/nu^2 TensorPower(k)
 14830        !for a closed model
 14831        ! < h_{ij}(x) h^{ij}(x) > = int d nu /(nu^2+1) (nu^2+4)/nu^2 TensorPower(k)
 14832        !for an open model
 14833        !"in" gives the index of the power spectrum to return 
 14834        !Here nu^2 = (k^2 + 3*curv)/|curv| 
 14835 
 14836 
 14837         real(dl) TensorPower,k   
 14838         real(dl), parameter :: PiByTwo = 3.14159265/2
 14839    
 14840         integer in
 14841 
 14842         TensorPower = P%rat(in)*P%ScalarPowerAmp(in)*exp(P%ant(in)*log(k/P%k_0_tensor))
 14843         if (curv < 0) TensorPower = TensorPower*tanh(PiByTwo*sqrt(-k**2/curv-3)) 
 14844 
 14845        
 14846       end function TensorPower
 14847 
 14848       !Get parameters describing parameterisation (for FITS file)
 14849      function Power_Descript(in, Scal, Tens, Keys, Vals)
 14850          character(LEN = 8), intent(out) :: Keys(*)
 14851          real(dl), intent(out) :: Vals(*)
 14852          integer, intent(IN) :: in
 14853          logical, intent(IN) :: Scal, Tens
 14854          integer num, Power_Descript
 14855          num = 0
 14856          if (Scal) then
 14857          num = num+1
 14858          Keys(num) = 'n_s'
 14859          Vals(num) = P%an(in)
 14860          num = num+1
 14861          Keys(num) = 'n_run'
 14862          Vals(num) = P%n_run(in)
 14863          num = num+1
 14864          Keys(num) = 's_pivot'
 14865          Vals(num) = P%k_0_scalar
 14866          end if
 14867          if (Tens) then
 14868          num = num+1
 14869          Keys(num) = 'n_t'
 14870          Vals(num) = P%ant(in)
 14871          num = num+1
 14872          Keys(num) = 't_pivot'
 14873          Vals(num) = P%k_0_tensor
 14874          if (Scal) then
 14875            num = num+1
 14876            Keys(num) = 'p_ratio'
 14877            Vals(num) = P%rat(in)
 14878          end if
 14879          end if
 14880          Power_Descript = num
 14881 
 14882        end  function Power_Descript
 14883         
 14884        subroutine InitialPower_ReadParams(InitPower, Ini, WantTensors)
 14885           use IniFile
 14886           Type(InitialPowerParams) :: InitPower
 14887           Type(TIniFile) :: Ini
 14888           logical, intent(in) :: WantTensors
 14889           integer i
 14890           
 14891            InitPower%k_0_scalar = Ini_Read_Double_File(Ini,'pivot_scalar',InitPower%k_0_scalar)
 14892            InitPower%k_0_tensor = Ini_Read_Double_File(Ini,'pivot_tensor',InitPower%k_0_tensor) 
 14893            InitPower%nn = Ini_Read_Int('initial_power_num')
 14894            if (InitPower%nn>nnmax) stop 'Too many initial power spectra - increase nnmax in InitialPower'
 14895            InitPower%rat(:) = 1
 14896            do i = 1, InitPower%nn
 14897 
 14898               InitPower%an(i) = Ini_Read_Double_Array_File(Ini,'scalar_spectral_index', i)
 14899               InitPower%n_run(i) = Ini_Read_Double_Array_File(Ini,'scalar_nrun',i,0) 
 14900               
 14901               if (WantTensors) then
 14902                  InitPower%ant(i) = Ini_Read_Double_Array_File(Ini,'tensor_spectral_index',i)
 14903                  InitPower%rat(i) = Ini_Read_Double_Array_File(Ini,'initial_ratio',i)
 14904               end if              
 14905 
 14906               InitPower%ScalarPowerAmp(i) = Ini_Read_Double_Array_File(Ini,'scalar_amp',i,1) 
 14907               !Always need this as may want to set tensor amplitude even if scalars not computed
 14908            end do
 14909           
 14910        end  subroutine InitialPower_ReadParams 
 14911 
 14912 
 14913      end module InitialPower
 14914 
 14915 ** recfast.f90
 14916 
 14917 !Recombination module for CAMB, using RECFAST
 14918 
 14919 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 14920 !C Integrator for Cosmic Recombination of Hydrogen and Helium,
 14921 !C developed by Douglas Scott (dscott@astro.ubc.ca)
 14922 !C based on calculations in the paper Seager, Sasselov & Scott
 14923 !C (ApJ, 523, L1, 1999).
 14924 !and "fudge" updates in Wong, Moss & Scott (2008).
 14925 !C
 14926 !C Permission to use, copy, modify and distribute without fee or royalty at
 14927 !C any tier, this software and its documentation, for any purpose and without
 14928 !C fee or royalty is hereby granted, provided that you agree to comply with
 14929 !C the following copyright notice and statements, including the disclaimer,
 14930 !C and that the same appear on ALL copies of the software and documentation,
 14931 !C including modifications that you make for internal use or for distribution:
 14932 !C
 14933 !C Copyright 1999-2010 by University of British Columbia.  All rights reserved.
 14934 !C
 14935 !C THIS SOFTWARE IS PROVIDED "AS IS", AND U.B.C. MAKES NO 
 14936 !C REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.  
 14937 !C BY WAY OF EXAMPLE, BUT NOT LIMITATION,
 14938 !c U.B.C. MAKES NO REPRESENTATIONS OR WARRANTIES OF 
 14939 !C MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT 
 14940 !C THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT INFRINGE 
 14941 !C ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS.   
 14942 !C
 14943 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 14944 !
 14945 !CN     Name:        RECFAST
 14946 !CV     Version: 1.5
 14947 !C 
 14948 !CP     Purpose:  Calculate ionised fraction as a function of redshift.
 14949 !CP            Solves for H and He simultaneously, and includes
 14950 !CP           H "fudge factor" for low z effect, as well as
 14951 !CP           HeI fudge factor.
 14952 !C
 14953 !CD     Description: Solves for ionisation history since recombination
 14954 !CD     using the equations in Seager, Sasselov & Scott (ApJ, 1999).
 14955 !CD     The Cosmological model can be flat or open.
 14956 !CD	 The matter temperature is also followed, with an update from
 14957 !CD	 Scott & Scott (2009).
 14958 !CD	 The values for \alpha_B for H are from Hummer (1994).
 14959 !CD	 The singlet HeI coefficient is a fit from the full code.
 14960 !CD	 Additional He "fudge factors" are as described in Wong, Moss
 14961 !CD	 and Scott (2008).
 14962 !CD	 Extra fitting function included (in optical depth) to account
 14963 !CD	 for extra H physics described in Rubino-Martin et al. (2010).
 14964 !CD	 Care is taken to use the most accurate constants.
 14965 !C            
 14966 !CA     Arguments:
 14967 !CA     Name, Description
 14968 !CA     real(dl) throughout
 14969 !CA
 14970 !CA     z is redshift - W is sqrt(1+z), like conformal time
 14971 !CA     x is total ionised fraction, relative to H
 14972 !CA     x_H is ionized fraction of H - y(1) in R-K routine
 14973 !CA     x_He is ionized fraction of He - y(2) in R-K routine
 14974 !CA       (note that x_He = n_He+/n_He here and not n_He+/n_H)
 14975 !CA     Tmat is matter temperature - y(3) in R-K routine
 14976 !CA     f's are the derivatives of the Y's
 14977 !CA     alphaB is case B recombination rate
 14978 !CA     alpHe is the singlet only HeII recombination rate
 14979 !CA     a_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
 14980 !CA     b_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
 14981 !CA     c_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
 14982 !CA     d_PPB is Pequignot, Petitjean & Boisson fitting parameter for Hydrogen
 14983 !CA     a_VF is Verner and Ferland type fitting parameter for Helium
 14984 !CA     b_VF is Verner and Ferland type fitting parameter for Helium
 14985 !CA     T_0 is Verner and Ferland type fitting parameter for Helium
 14986 !CA     T_1 is Verner and Ferland type fitting parameter for Helium
 14987 !CA     Tnow is the observed CMB temperature today
 14988 !CA     Yp is the primordial helium abundace
 14989 !CA     fHe is He/H number ratio = Yp/4(1-Yp)
 14990 !CA     Trad and Tmat are radiation and matter temperatures
 14991 !CA	    epsilon is the approximate difference ( = Trad-Tmat) at high z
 14992 !CA     OmegaB is Omega in baryons today
 14993 !CA     H is Hubble constant in units of 100 km/s/Mpc
 14994 !CA     HO is Hubble constant in SI units
 14995 !CA     bigH is 100 km/s/Mpc in SI units
 14996 !CA	    Hz is the value of H at the specific z (in ION)
 14997 !CA     G is grvitational constant
 14998 !CA     n is number density of hydrogen
 14999 !CA     Nnow is number density today
 15000 !CA     x0 is initial ionized fraction
 15001 !CA     x_H0 is initial ionized fraction of Hydrogen
 15002 !CA     x_He0 is initial ionized fraction of Helium
 15003 !CA     rhs is dummy for calculating x0
 15004 !CA     zinitial and zfinal are starting and ending redshifts
 15005 !CA     zeq is the redshift of matter-radiation equality
 15006 !CA     zstart and zend are for each pass to the integrator
 15007 !CA     C,k_B,h_P: speed of light, Boltzmann's and Planck's constants
 15008 !CA     m_e,m_H: electron mass and mass of H atom in SI
 15009 !CA     not4: ratio of 4He atomic mass to 1H atomic mass
 15010 !CA     sigma: Thomson cross-section
 15011 !CA     a_rad: radiation constant for u = aT^4
 15012 !CA     Lambda: 2s-1s two photon rate for Hydrogen
 15013 !CA     Lambda_He: 2s-1s two photon rate for Helium
 15014 !CA     DeltaB: energy of first excited state from continuum = 3.4eV
 15015 !CA     DeltaB_He: energy of first excited state from cont. for He = 3.4eV
 15016 !CA     L_H_ion: level for H ionization in m^-1
 15017 !CA     L_H_alpha: level for H Ly alpha in m^-1
 15018 !CA     L_He1_ion: level for HeI ionization
 15019 !CA     L_He2_ion: level for HeII ionization
 15020 !CA     L_He_2s: level for HeI 2s
 15021 !CA     L_He_2p: level for HeI 2p (21P1-11S0) in m^-1
 15022 !CA     Lalpha: Ly alpha wavelength in SI
 15023 !CA     Lalpha_He: Helium I 2p-1s wavelength in SI
 15024 !CA     mu_H,mu_T: mass per H atom and mass per particle
 15025 !CA     H_frac: follow Tmat when t_Compton / t_Hubble > H_frac
 15026 !CA     CDB = DeltaB/k_B                     Constants derived from B1,B2,R
 15027 !CA     CDB_He = DeltaB_He/k_B  n = 2-infinity for He in Kelvin
 15028 !CA     CB1 = CDB*4.         Lalpha and sigma_Th, calculated
 15029 !CA     CB1_He1: CB1 for HeI ionization potential
 15030 !CA     CB1_He2: CB1 for HeII ionization potential
 15031 !CA     CR = 2*Pi*(m_e/h_P)*(k_B/h_P)  once and passed in a common block
 15032 !CA     CK = Lalpha**3/(8.*Pi)
 15033 !CA     CK_He = Lalpha_He**3/(8.*Pi)
 15034 !CA     CL = C*h_P/(k_B*Lalpha)
 15035 !CA     CL_He = C*h_P/(k_B*Lalpha_He)
 15036 !CA     CT = (8./3.)*(sigma/(m_e*C))*a
 15037 !CA     Bfact = exp((E_2p-E_2s)/kT)    Extra Boltzmann factor
 15038 !CA b_He = "fudge factor" for HeI, to approximate higher z behaviour
 15039 !CA Heswitch = integer for modifying HeI recombination
 15040 !CA Parameters and quantities to describe the extra triplet states
 15041 !CA  and also the continuum opacity of H, with a fitting function
 15042 !CA  suggested by KIV, astro-ph/0703438
 15043 !CA a_trip: used to fit HeI triplet recombination rate
 15044 !CA b_trip: used to fit HeI triplet recombination rate
 15045 !CA L_He_2Pt: level for 23P012-11S0 in m^-1
 15046 !CA L_He_2St: level for 23S1-11S0 in m^-1
 15047 !CA L_He2St_ion: level for 23S1-continuum in m^-1
 15048 !CA A2P_s: Einstein A coefficient for He 21P1-11S0
 15049 !CA A2P_t: Einstein A coefficient for He 23P1-11S0    
 15050 !CA sigma_He_2Ps: H ionization x-section at HeI 21P1-11S0 freq. in m^2
 15051 !CA sigma_He_2Pt: H ionization x-section at HeI 23P1-11S0 freq. in m^2
 15052 !CA CL_PSt = h_P*C*(L_He_2Pt - L_He_2st)/k_B
 15053 !CA CfHe_t: triplet statistical correction
 15054 !CA	Hswitch is an boolean for modifying the H recombination
 15055 !CA	AGauss1 is the amplitude of the 1st Gaussian for the H fudging
 15056 !CA	AGauss2 is the amplitude of the 2nd Gaussian for the H fudging
 15057 !CA	zGauss1 is the ln(1+z) central value of the 1st Gaussian
 15058 !CA	zGauss2 is the ln(1+z) central value of the 2nd Gaussian
 15059 !CA	wGauss1 is the width of the 1st Gaussian
 15060 !CA	wGauss2 is the width of the 2nd Gaussian
 15061 
 15062 
 15063 !CA     tol: tolerance for the integrator
 15064 !CA     cw(24),w(3,9): work space for DVERK
 15065 !CA     Ndim: number of d.e.'s to solve (integer)
 15066 !CA     Nz: number of output redshitf (integer)
 15067 !CA     I: loop index (integer)
 15068 !CA     ind,nw: work-space for DVERK (integer)
 15069 !C
 15070 !CF     File & device access:
 15071 !CF     Unit /I,IO,O  /Name (if known)
 15072 !C
 15073 !CM     Modules called:
 15074 !CM     DVERK (numerical integrator)
 15075 !CM     GET_INIT (initial values for ionization fractions)
 15076 !CM     ION (ionization and Temp derivatives)
 15077 !C
 15078 !CC     Comments:
 15079 !CC     none
 15080 !C
 15081 !CH     History:
 15082 !CH     CREATED            (simplest version) 19th March 1989
 15083 !CH     RECREATED    11th January 1995
 15084 !CH               includes variable Cosmology
 15085 !CH               uses DVERK integrator
 15086 !CH               initial conditions are Saha
 15087 !CH     TESTED              a bunch, well, OK, not really
 15088 !CH     MODIFIED     January 1995 (include Hummer's 1994 alpha table)
 15089 !CH               January 1995 (include new value for 2s-1s rate)
 15090 !CH               January 1995 (expand comments)
 15091 !CH               March 1995 (add Saha for Helium)
 15092 !CH               August 1997 (add HeII alpha table)
 15093 !CH               July 1998 (include OmegaT correction and H fudge factor)
 15094 !CH               Nov 1998 (change Trad to Tmat in Rup)
 15095 !CH               Jan 1999 (tidied up for public consumption)
 15096 !CH               Sept 1999 (switch to formula for alpha's, fix glitch)
 15097 !CH                  Sept 1999 modified to CMBFAST by US & MZ          
 15098 !CH                     Nov 1999 modified for F90 and CAMB (AML)
 15099 !CH                     Aug 2000 modified to prevent overflow erorr in He_Boltz (AML)
 15100 !CH                     Feb 2001 corrected fix of Aug 2000 (AML)
 15101 !CH                     Oct 2001 fixed error in hubble parameter, now uses global function (AML)
 15102 !                       March 2003 fixed bugs reported by savita gahlaut
 15103 !                       March 2005 added option for corrections from astro-ph/0501672.
 15104 !                                  thanks to V.K.Dubrovich, S.I.Grachev
 15105 !                       June 2006 defined RECFAST_fudge as free parameter (AML)
 15106 !                       October 2006 (included new value for G)
 15107 !                       October 2006 (improved m_He/m_H to be "not4")
 15108 !                       October 2006 (fixed error, x for x_H in part of f(1))
 15109 !CH              January 2008 (improved HeI recombination effects,
 15110 !CH                       including HeI rec. fudge factor)
 15111 !                Feb 2008   Recfast 1.4 changes above added (AML)
 15112 !                           removed Dubrovich option (wrong anyway)
 15113 !CH   			 Sept 2008 (added extra term to make transition, smoother for Tmat evolution)
 15114 !                Sept 2008 Recfast 1.4.2 changes above added (AML) 
 15115 !                          General recombination module structure, fix to make He x_e smooth also in recfast (AML)
 15116 !CH		      	 Jan 2010 (added fitting function to modify K
 15117 !CH			 	 to match x_e(z) for new H physics)
 15118 
 15119 !!      = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 15120 
 15121        module RECDATA
 15122         use constants
 15123         implicit none
 15124          
 15125 
 15126         real(dl) Lambda,DeltaB,DeltaB_He,Lalpha,mu_H,mu_T,H_frac
 15127         real(dl) Lambda_He,Lalpha_He,Bfact,CK_He,CL_He
 15128         real(dl) L_H_ion,L_H_alpha,L_He1_ion,L_He2_ion,L_He_2s,L_He_2p
 15129         real(dl) CB1,CDB,CR,CK,CL,CT,CB1_He1,CB1_He2,CDB_He,fu
 15130         real(dl) A2P_s,A2P_t,sigma_He_2Ps,sigma_He_2Pt
 15131         real(dl)  L_He_2Pt,L_He_2St,L_He2St_ion
 15132 
 15133 
 15134         real(dl), parameter :: bigH = 100.0D3/Mpc !Ho in s-1
 15135         real(dl), parameter :: sigma = sigma_thomson
 15136         real(dl), parameter :: not4  = mass_ratio_He_H    !mass He/H atom
 15137 
 15138         real(dl) Tnow,HO
 15139         integer :: n_eq = 3
 15140 
 15141 !The following only used for approximations where small effect
 15142        real(dl) OmegaK, OmegaT, z_eq
 15143 
 15144 
 15145 !Fundamental constants in SI units
 15146 !      ("not4" pointed out by Gary Steigman)
 15147 
 15148         data    Lambda      /8.2245809/
 15149         data    Lambda_He   /51.3/    !new value from Dalgarno
 15150         data    L_H_ion     /1.096787737D7/ !level for H ion. (in m^-1)
 15151         data    L_H_alpha   /8.225916453D6/ !averaged over 2 levels
 15152         data    L_He1_ion   /1.98310772D7/  !from Drake (1993)
 15153         data    L_He2_ion   /4.389088863D7/ !from JPhysChemRefData (1987)
 15154         data    L_He_2s     /1.66277434D7/  !from Drake (1993)
 15155         data    L_He_2p     /1.71134891D7/  !from Drake (1993)
 15156 !   2 photon rates and atomic levels in SI units
 15157 
 15158         data    A2P_s       /1.798287D9/    !Morton, Wu & Drake (2006)
 15159         data    A2P_t       /177.58/      !Lach & Pachuski (2001)
 15160         data    L_He_2Pt    /1.690871466D7/ !Drake & Morton (2007)
 15161         data    L_He_2St    /1.5985597526D7/ !Drake & Morton (2007)
 15162         data    L_He2St_ion /3.8454693845D6/ !Drake & Morton (2007)
 15163         data    sigma_He_2Ps    /1.436289D-22/  !Hummer & Storey (1998)
 15164         data    sigma_He_2Pt    /1.484872D-22/  !Hummer & Storey (1998)
 15165 !    Atomic data for HeI 
 15166 
 15167 
 15168        end module RECDATA
 15169 
 15170 
 15171         module Recombination
 15172         use constants
 15173         use AMLUtils
 15174         implicit none
 15175         private
 15176 
 15177         real(dl), parameter ::  zinitial = 1e4 !highest redshift
 15178         real(dl), parameter ::  zfinal = 0
 15179         integer,  parameter :: Nz = 10000  
 15180         real(dl), parameter :: delta_z = (zinitial-zfinal)/Nz
 15181 
 15182         integer, parameter ::  RECFAST_Heswitch_default = 6
 15183         real(dl), parameter :: RECFAST_fudge_He_default = 0.86 !Helium fudge parameter
 15184         logical, parameter  :: RECFAST_Hswitch_default = .true. !include H corrections (v1.5, 2010)
 15185         real(dl), parameter :: RECFAST_fudge_default = 1.14
 15186         real(dl), parameter :: RECFAST_fudge_default2 = 1.105 
 15187               !fudge parameter if RECFAST_Hswitch
 15188         
 15189         real(dl), parameter :: AGauss1 =   -0.14  !Amplitude of 1st Gaussian
 15190         real(dl), parameter :: AGauss2 =    0.05  !Amplitude of 2nd Gaussian
 15191         real(dl), parameter :: zGauss1 =    7.28  !ln(1+z) of 1st Gaussian
 15192         real(dl), parameter :: zGauss2 = 	    6.75  !ln(1+z) of 2nd Gaussian
 15193         real(dl), parameter :: wGauss1 = 	    0.18  !Width of 1st Gaussian
 15194         real(dl), parameter :: wGauss2 = 	    0.33  !Width of 2nd Gaussian
 15195          !	Gaussian fits for extra H physics (fit by Adam Moss)
 15196 
 15197         type RecombinationParams
 15198 
 15199           real(dl) :: RECFAST_fudge 
 15200           real(dl) :: RECFAST_fudge_He 
 15201           integer  :: RECFAST_Heswitch
 15202           logical  :: RECFAST_Hswitch  
 15203          !0) no change from old Recfast'
 15204          !1) full expression for escape probability for singlet'
 15205          !'   1P-1S transition'
 15206          !2) also including effect of contiuum opacity of H on HeI'
 15207          !'   singlet (based in fitting formula suggested by'
 15208          !'   Kholupenko, Ivanchik & Varshalovich, 2007)'
 15209          !3) only including recombination through the triplets'
 15210          !4) including 3 and the effect of the contiuum '
 15211          !'   (although this is probably negligible)' 
 15212          !5) including only 1, 2 and 3'
 15213          !6) including all of 1 to 4'
 15214    
 15215         end  type RecombinationParams
 15216 
 15217         character(LEN = *), parameter :: Recombination_Name = 'Recfast_1.5'
 15218       
 15219         real(dl) zrec(Nz),xrec(Nz),dxrec(Nz), Tsrec(Nz) ,dTsrec(Nz), tmrec(Nz),dtmrec(Nz)
 15220 
 15221         real(dl), parameter :: Do21cm_mina = 1/(1+900.) !at which to start evolving Delta_TM
 15222         logical, parameter :: evolve_Ts = .false. !local equilibrium is very accurate
 15223         real(dl), parameter :: Do21cm_minev = 1/(1+400.) !at which to evolve T_s
 15224        
 15225  
 15226         real(dl), parameter :: B01 = 3*B10
 15227         real(dl) :: NNow, fHe 
 15228                
 15229 
 15230         logical :: Do21cm = .false.
 15231         logical :: doTmatTspin = .false.
 15232 
 15233         real(dl) :: recombination_saha_z !Redshift at which saha OK
 15234         real(dl) :: recombination_saha_tau !set externally
 15235 
 15236 
 15237         public RecombinationParams, Recombination_xe, Recombination_tm,Recombination_ts ,Recombination_init,   &
 15238                Recombination_ReadParams, Recombination_SetDefParams, Recombination_Validate, Recombination_Name, &
 15239                kappa_HH_21cm,kappa_eH_21cm,kappa_pH_21cm, &
 15240                Do21cm, doTmatTspin, Do21cm_mina, dDeltaxe_dtau, &
 15241                recombination_saha_tau, recombination_saha_z
 15242  
 15243        contains
 15244 
 15245 
 15246 
 15247          subroutine Recombination_ReadParams(R, Ini)
 15248           use IniFile
 15249           Type(RecombinationParams) :: R
 15250           Type(TIniFile) :: Ini
 15251 
 15252 
 15253              R%RECFAST_fudge_He = Ini_Read_Double_File(Ini,'RECFAST_fudge_He',RECFAST_fudge_He_default)
 15254              R%RECFAST_Heswitch = Ini_Read_Int_File(Ini, 'RECFAST_Heswitch',RECFAST_Heswitch_default)
 15255              R%RECFAST_Hswitch = Ini_Read_Logical_File(Ini, 'RECFAST_Hswitch',RECFAST_Hswitch_default)
 15256              R%RECFAST_fudge = Ini_Read_Double_File(Ini,'RECFAST_fudge',RECFAST_fudge_default)
 15257              if (R%RECFAST_Hswitch) then
 15258                 R%RECFAST_fudge = R%RECFAST_fudge - (RECFAST_fudge_default - RECFAST_fudge_default2)
 15259              end if   
 15260          end subroutine Recombination_ReadParams 
 15261 
 15262         subroutine Recombination_SetDefParams(R)
 15263          type (RecombinationParams) ::R
 15264 
 15265       
 15266           R%RECFAST_fudge = RECFAST_fudge_default
 15267           R%RECFAST_fudge_He = RECFAST_fudge_He_default !Helium fudge parameter
 15268           R%RECFAST_Heswitch = RECFAST_Heswitch_default
 15269           R%RECFAST_Hswitch =  RECFAST_Hswitch_default
 15270           if (R%RECFAST_Hswitch) then
 15271                 R%RECFAST_fudge = RECFAST_fudge_default2
 15272           end if   
 15273     
 15274         end subroutine Recombination_SetDefParams
 15275 
 15276 
 15277         subroutine Recombination_Validate(R, OK)
 15278           Type(RecombinationParams),intent(in) :: R
 15279           logical, intent(inout) :: OK
 15280  
 15281               if (R%RECFAST_Heswitch<0 .or. R%RECFAST_Heswitch > 6) then
 15282                      OK = .false.
 15283                      write(*,*) 'RECFAST_Heswitch unknown'
 15284                end if
 15285              
 15286          end subroutine Recombination_Validate
 15287 
 15288 
 15289         function Recombination_tm(a)
 15290         use RECDATA, only : Tnow
 15291         real(dl) zst,a,z,az,bz,Recombination_tm
 15292         integer ilo,ihi
 15293         
 15294         if (.not. doTmatTspin) stop 'RECFAST: Recombination_tm not stored'
 15295         z = 1/a-1
 15296         if (z > = zrec(1)) then
 15297             Recombination_tm = Tnow/a
 15298         else
 15299          if (z < = zrec(nz)) then
 15300           Recombination_tm = Tmrec(nz)
 15301          else
 15302           zst = (zinitial-z)/delta_z
 15303           ihi = int(zst)
 15304           ilo = ihi+1
 15305           az = zst - int(zst)
 15306           bz = 1-az     
 15307           Recombination_tm = az*Tmrec(ilo)+bz*Tmrec(ihi)+ &
 15308            ((az**3-az)*dTmrec(ilo)+(bz**3-bz)*dTmrec(ihi))/6
 15309          endif
 15310         endif
 15311 
 15312         end function Recombination_tm
 15313 
 15314 
 15315         function Recombination_ts(a)
 15316         !zrec(1) is zinitial-delta_z
 15317         real(dl), intent(in) :: a
 15318         real(dl) zst,z,az,bz,Recombination_ts
 15319         integer ilo,ihi
 15320         
 15321         z = 1/a-1
 15322         if (z.ge.zrec(1)) then
 15323           Recombination_ts = tsrec(1)
 15324         else
 15325          if (z< = zrec(nz)) then
 15326           Recombination_ts = tsrec(nz)
 15327          else
 15328           zst = (zinitial-z)/delta_z
 15329           ihi = int(zst)
 15330           ilo = ihi+1
 15331           az = zst - int(zst)
 15332           bz = 1-az     
 15333 
 15334           Recombination_ts = az*tsrec(ilo)+bz*tsrec(ihi)+ &
 15335            ((az**3-az)*dtsrec(ilo)+(bz**3-bz)*dtsrec(ihi))/6
 15336          endif
 15337         endif
 15338 
 15339         end function Recombination_ts
 15340 
 15341 
 15342         function Recombination_xe(a)
 15343         real(dl), intent(in) :: a
 15344         real(dl) zst,z,az,bz,Recombination_xe
 15345         integer ilo,ihi
 15346         
 15347         z = 1/a-1
 15348         if (z.ge.zrec(1)) then
 15349           Recombination_xe = xrec(1)
 15350         else
 15351          if (z< = zrec(nz)) then
 15352           Recombination_xe = xrec(nz)
 15353          else
 15354           zst = (zinitial-z)/delta_z
 15355           ihi = int(zst)
 15356           ilo = ihi+1
 15357           az = zst - int(zst)
 15358           bz = 1-az     
 15359           Recombination_xe = az*xrec(ilo)+bz*xrec(ihi)+ &
 15360            ((az**3-az)*dxrec(ilo)+(bz**3-bz)*dxrec(ihi))/6
 15361          endif
 15362         endif
 15363 
 15364         end function Recombination_xe
 15365 
 15366 
 15367 
 15368         subroutine Recombination_init(Recomb, OmegaC, OmegaB, Omegan, Omegav, h0inp,tcmb,yp)
 15369         !Would love to pass structure as arguments, but F90 would give circular reference...
 15370         !hence mess passing parameters explcitly and non-generally
 15371         !Note recfast only uses OmegaB, h0inp, tcmb and yp - others used only for Tmat approximation where effect small
 15372         use RECDATA
 15373         use AMLUtils
 15374         implicit none
 15375         Type (RecombinationParams) :: Recomb
 15376  
 15377         real(dl), save :: last_OmB = 0, Last_YHe = 0, Last_H0 = 0, Last_dtauda = 0, last_fudge, last_fudgeHe 
 15378 
 15379         real(dl) Trad,Tmat,Tspin,hi,ddlo
 15380         integer I
 15381 
 15382         real(dl) OmegaB,OmegaC, Omegan, Omegav, H
 15383         real(dl) z,n,x,x0,rhs,x_H,x_He,x_H0,x_He0,h0inp
 15384         real(dl) zstart,zend,tcmb
 15385         real(dl) cw(24)
 15386         real(dl), dimension(:,:), allocatable :: w
 15387         real(dl) y(4)
 15388         real(dl) yp
 15389         real(dl) C10, tau_21Ts
 15390         real(dl) fnu
 15391         integer ind,nw
 15392 
 15393 !       --- Parameter statements
 15394         real(dl), parameter :: tol = 1.D-5                !Tolerance for R-K
 15395 
 15396         real(dl) dtauda
 15397         external dtauda, dverk
 15398 
 15399 !       = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 15400 
 15401         if (Last_OmB = OmegaB .and. Last_H0 = h0inp .and. yp = Last_YHe .and. & 
 15402              dtauda(0.2352375823) = Last_dtauda .and. last_fudge = Recomb%RECFAST_fudge &
 15403               .and. last_fudgeHe = Recomb%RECFAST_fudge_He) return
 15404            !This takes up most of the single thread time, so cache if at all possible
 15405            !For example if called with different reionization, or tensor rather than scalar
 15406         
 15407         Last_dtauda =  dtauda(0.2352375823) !Just get it at a random scale factor
 15408         Last_OmB = OmegaB
 15409         Last_H0 = h0inp
 15410         Last_YHe = yp
 15411         last_fudge = Recomb%RECFAST_FUDGE
 15412         last_fudgeHe = Recomb%RECFAST_FUDGE_He
 15413 
 15414         if (Do21cm) doTmatTspin = .true.
 15415 
 15416 
 15417 !       write(*,*)'recfast version 1.0'
 15418 !       write(*,*)'Using Hummer''s case B recombination rates for H'
 15419 !       write(*,*)' with fudge factor = 1.14'
 15420 !       write(*,*)'and tabulated HeII singlet recombination rates'
 15421 !       write(*,*)
 15422 
 15423         n_eq = 3
 15424         if (Evolve_Ts) n_eq = 4
 15425         allocate(w(n_eq,9))
 15426 
 15427         recombination_saha_z = 0
 15428 
 15429         Tnow = tcmb
 15430 !       These are easy to inquire as input, but let's use simple values
 15431         z = zinitial
 15432 !       will output every 1 in z, but this is easily changed also
 15433 
 15434  !Not general, but only for approx 
 15435         OmegaT = OmegaC+OmegaB            !total dark matter + baryons
 15436         OmegaK = 1-OmegaT-OmegaV       !curvature
 15437     
 15438   
 15439 !       convert the Hubble constant units
 15440         H = H0inp/100
 15441         HO = H*bigH
 15442 
 15443 
 15444 !       sort out the helium abundance parameters
 15445         mu_H = 1/(1-Yp)           !Mass per H atom
 15446         mu_T = not4/(not4-(not4-1)*Yp)   !Mass per atom
 15447         fHe = Yp/(not4*(1-Yp))       !n_He_tot / n_H_tot
 15448 
 15449 
 15450         Nnow = 3*HO*HO*OmegaB/(8*Pi*G*mu_H*m_H)
 15451 
 15452         n = Nnow * (1+z)**3
 15453         fnu = (21/8)*(4/11)**(4/3)
 15454 !	(this is explictly for 3 massless neutrinos - change if N_nu <> 3; but only used for approximation so not critical)
 15455         z_eq = (3*(HO*C)**2/(8*Pi*G*a_rad*(1+fnu)*Tnow**4))*(OmegaB+OmegaC)
 15456         z_eq = z_eq - 1
 15457 
 15458       
 15459 !       Set up some constants so they don't have to be calculated later
 15460         Lalpha = 1/L_H_alpha
 15461         Lalpha_He = 1/L_He_2p
 15462         DeltaB = h_P*C*(L_H_ion-L_H_alpha)
 15463         CDB = DeltaB/k_B
 15464         DeltaB_He = h_P*C*(L_He1_ion-L_He_2s)   !2s, not 2p
 15465         CDB_He = DeltaB_He/k_B
 15466         CB1 = h_P*C*L_H_ion/k_B
 15467         CB1_He1 = h_P*C*L_He1_ion/k_B   !ionization for HeI
 15468         CB1_He2 = h_P*C*L_He2_ion/k_B   !ionization for HeII
 15469         CR = 2*Pi*(m_e/h_P)*(k_B/h_P)
 15470         CK = Lalpha**3/(8*Pi)
 15471         CK_He = Lalpha_He**3/(8*Pi)
 15472         CL = C*h_P/(k_B*Lalpha)
 15473         CL_He = C*h_P/(k_B/L_He_2s) !comes from det.bal. of 2s-1s
 15474         CT = Compton_CT / MPC_in_sec
 15475 
 15476         Bfact = h_P*C*(L_He_2p-L_He_2s)/k_B
 15477 
 15478         
 15479 !       Matter departs from radiation when t(Th) > H_frac * t(H)
 15480 !       choose some safely small number
 15481         H_frac = 1D-3
 15482 
 15483 !       Fudge factor to approximate for low z out of equilibrium effect
 15484         fu = Recomb%RECFAST_fudge
 15485 
 15486 !       Set initial matter temperature
 15487         y(3) = Tnow*(1+z)            !Initial rad. & mat. temperature
 15488         Tmat = y(3)
 15489         y(4) = Tmat
 15490         Tspin = Tmat
 15491 
 15492         call get_init(z,x_H0,x_He0,x0)
 15493     
 15494         y(1) = x_H0
 15495         y(2) = x_He0
 15496 
 15497 !       OK that's the initial conditions, now start writing output file
 15498 
 15499 
 15500 !       Set up work-space stuff for DVERK
 15501         ind  = 1
 15502         nw   = n_eq
 15503         do i = 1,24
 15504           cw(i) = 0
 15505         end do
 15506 
 15507         do i = 1,Nz
 15508 !       calculate the start and end redshift for the interval at each z
 15509 !       or just at each z
 15510           zstart = zinitial  - real(i-1,dl)*delta_z
 15511           zend   = zinitial  - real(i,dl)*delta_z
 15512 
 15513 ! Use Saha to get x_e, using the equation for x_e for ionized helium
 15514 ! and for neutral helium.
 15515 ! Everything ionized above z = 8000.  First ionization over by z = 5000.
 15516 ! Assume He all singly ionized down to z = 3500, then use He Saha until
 15517 ! He is 99% singly ionized, and *then* switch to joint H/He recombination.
 15518 
 15519           z = zend
 15520         
 15521           if (zend > 8000) then
 15522 
 15523             x_H0 = 1
 15524             x_He0 = 1
 15525             x0 = 1+2*fHe
 15526             y(1) = x_H0
 15527             y(2) = x_He0
 15528             y(3) = Tnow*(1+z)
 15529             y(4) = y(3)
 15530 
 15531           else if(z > 5000)then
 15532 
 15533             x_H0 = 1
 15534             x_He0 = 1
 15535             rhs = exp( 1.5 * log(CR*Tnow/(1+z)) &
 15536                 - CB1_He2/(Tnow*(1+z)) ) / Nnow
 15537             rhs = rhs*1            !ratio of g's is 1 for He++ <-> He+
 15538             x0 = 0.5 * ( sqrt( (rhs-1-fHe)**2 &
 15539                 + 4*(1+2*fHe)*rhs) - (rhs-1-fHe) )
 15540             y(1) = x_H0
 15541             y(2) = x_He0
 15542             y(3) = Tnow*(1+z)
 15543             y(4) = y(3)
 15544 
 15545           else if(z > 3500)then
 15546 
 15547             x_H0 = 1
 15548             x_He0 = 1
 15549             x0 = x_H0 + fHe*x_He0
 15550             y(1) = x_H0
 15551             y(2) = x_He0
 15552             y(3) = Tnow*(1+z)
 15553             y(4) = y(3)
 15554 
 15555           else if(y(2) > 0.99)then
 15556 
 15557             x_H0 = 1
 15558             rhs = exp( 1.5 * log(CR*Tnow/(1+z)) &
 15559                 - CB1_He1/(Tnow*(1+z)) ) / Nnow
 15560             rhs = rhs*4            !ratio of g's is 4 for He+ <-> He0
 15561             x_He0 = 0.5 * ( sqrt( (rhs-1)**2 &
 15562                 + 4*(1+fHe)*rhs )- (rhs-1))
 15563             x0 = x_He0
 15564             x_He0 = (x0 - 1)/fHe
 15565             y(1) = x_H0
 15566             y(2) = x_He0
 15567             y(3) = Tnow*(1+z)
 15568             y(4) = y(3)
 15569 
 15570           else if (y(1) > 0.99) then
 15571 
 15572             rhs = exp( 1.5 * log(CR*Tnow/(1+z)) &
 15573                 - CB1/(Tnow*(1+z)) ) / Nnow
 15574             x_H0 = 0.5 * (sqrt( rhs**2+4*rhs ) - rhs )
 15575 
 15576             call DVERK(Recomb,3,ION,zstart,y,zend,tol,ind,cw,nw,w)
 15577             y(1) = x_H0
 15578             x0 = y(1) + fHe*y(2)
 15579             y(4) = y(3)
 15580           else
 15581             
 15582             call DVERK(Recomb,nw,ION,zstart,y,zend,tol,ind,cw,nw,w)
 15583           
 15584             x0 = y(1) + fHe*y(2)
 15585           
 15586           end if
 15587           
 15588           Trad = Tnow * (1+zend)
 15589           Tmat = y(3)
 15590           x_H = y(1)
 15591           x_He = y(2)
 15592           x = x0
 15593 
 15594           zrec(i) = zend
 15595           xrec(i) = x
 15596 
 15597     
 15598           if (doTmatTspin) then
 15599               if (Evolve_Ts .and. zend< 1/Do21cm_minev-1 ) then
 15600                Tspin = y(4)
 15601               else 
 15602                C10 = Nnow * (1+zend)**3*(kappa_HH_21cm(Tmat,.false.)*(1-x_H) + kappa_eH_21cm(Tmat,.false.)*x)
 15603                tau_21Ts = line21_const*NNow*(1+zend)*dtauda(1/(1+zend))/1000
 15604         
 15605                Tspin = Trad*( C10/Trad + A10/T_21cm)/(C10/Tmat + A10/T_21cm) + &
 15606                      tau_21Ts/2*A10*( 1/(C10*T_21cm/Tmat+A10) -  1/(C10*T_21cm/Trad+A10) )
 15607           
 15608                y(4) = Tspin
 15609               end if
 15610 
 15611               tsrec(i) = Tspin
 15612               tmrec(i) = Tmat
 15613            
 15614           end if   
 15615 
 15616 !          write (*,'(5E15.5)') zend, Trad, Tmat, Tspin, x
 15617      
 15618         end do
 15619         
 15620         ddhi = 1.0d40
 15621         ddlo = 1.0d40
 15622         call spline(zrec,xrec,nz,ddlo,ddhi,dxrec)
 15623         if (doTmatTspin) then
 15624          call spline(zrec,tsrec,nz,ddlo,ddhi,dtsrec)
 15625          call spline(zrec,tmrec,nz,ddlo,ddhi,dtmrec)
 15626         end if
 15627         deallocate(w)
 15628         
 15629         end subroutine Recombination_init
 15630 
 15631 !       = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 15632         subroutine GET_INIT(z,x_H0,x_He0,x0)
 15633 
 15634 !       Set up the initial conditions so it will work for general,
 15635 !       but not pathological choices of zstart
 15636 !       Initial ionization fraction using Saha for relevant species
 15637         use RECDATA
 15638         implicit none
 15639   
 15640         
 15641         real(dl) z,x0,rhs,x_H0,x_He0
 15642   
 15643 
 15644         if(z > 8000)then
 15645 
 15646             x_H0 = 1
 15647             x_He0 = 1
 15648             x0 = 1+2*fHe
 15649 
 15650         else if(z > 3500)then
 15651 
 15652             x_H0 = 1
 15653             x_He0 = 1
 15654             rhs = exp( 1.5 * log(CR*Tnow/(1+z)) &
 15655                 - CB1_He2/(Tnow*(1+z)) ) / Nnow
 15656         rhs = rhs*1    !ratio of g's is 1 for He++ <-> He+
 15657         x0 = 0.5 * ( sqrt( (rhs-1-fHe)**2 &
 15658                 + 4*(1+2*fHe)*rhs) - (rhs-1-fHe) )
 15659 
 15660         else if(z > 2000)then
 15661 
 15662         x_H0 = 1
 15663             rhs = exp( 1.5 * log(CR*Tnow/(1+z)) &
 15664                 - CB1_He1/(Tnow*(1+z)) ) / Nnow
 15665         rhs = rhs*4    !ratio of g's is 4 for He+ <-> He0
 15666             x_He0 = 0.5  * ( sqrt( (rhs-1)**2 + 4*(1+fHe)*rhs )- (rhs-1))
 15667             x0 = x_He0
 15668             x_He0 = (x0 - 1)/fHe
 15669 
 15670         else
 15671 
 15672             rhs = exp( 1.5 * log(CR*Tnow/(1+z)) &
 15673                 - CB1/(Tnow*(1+z)) ) / Nnow
 15674             x_H0 = 0.5 * (sqrt( rhs**2+4*rhs ) - rhs )
 15675             x_He0 = 0
 15676             x0 = x_H0
 15677 
 15678         end if
 15679 
 15680         
 15681         end subroutine GET_INIT
 15682 
 15683 
 15684 
 15685         subroutine ION(Recomb,Ndim,z,Y,f)
 15686         use RECDATA
 15687         implicit none
 15688 
 15689         integer Ndim
 15690         Type (RecombinationParams) :: Recomb
 15691 
 15692         real(dl) z,x,n,n_He,Trad,Tmat,Tspin,x_H,x_He, Hz
 15693         real(dl) y(Ndim),f(Ndim)
 15694         real(dl) Rup,Rdown,K,K_He,Rup_He,Rdown_He,He_Boltz
 15695         real(dl) timeTh,timeH
 15696         real(dl) a_VF,b_VF,T_0,T_1,sq_0,sq_1,a_PPB,b_PPB,c_PPB,d_PPB
 15697         real(dl) tauHe_s,pHe_s
 15698         real(dl) a_trip,b_trip,Rdown_trip,Rup_trip
 15699         real(dl) Doppler,gamma_2Ps,pb,qb,AHcon
 15700         real(dl) tauHe_t,pHe_t,CL_PSt,CfHe_t,gamma_2Pt
 15701         real(dl) epsilon
 15702         integer Heflag
 15703         real(dl) dtauda
 15704         real(dl) C10, dHdz
 15705         external dtauda
 15706 
 15707 !       the Pequignot, Petitjean & Boisson fitting parameters for Hydrogen    
 15708         a_PPB = 4.309
 15709         b_PPB = -0.6166
 15710         c_PPB = 0.6703
 15711         d_PPB = 0.5300
 15712 !       the Verner and Ferland type fitting parameters for Helium
 15713 !       fixed to match those in the SSS papers, and now correct
 15714         a_VF = 10**(-16.744)
 15715         b_VF = 0.711
 15716         T_0 = 10**(0.477121)   !3K
 15717         T_1 = 10**(5.114)
 15718 !      fitting parameters for HeI triplets
 15719 !      (matches Hummer's table with <1% error for 10^2.8 < T/K < 10^4)
 15720 
 15721         a_trip = 10**(-16.306)
 15722         b_trip = 0.761
 15723 
 15724        
 15725         x_H = y(1)
 15726         x_He = y(2)
 15727         x = x_H + fHe * x_He
 15728         Tmat = y(3)
 15729 !        Tspin = y(4)
 15730 
 15731         n = Nnow * (1+z)**3
 15732         n_He = fHe * Nnow * (1+z)**3
 15733         Trad = Tnow * (1+z)
 15734 
 15735         Hz = 1/dtauda(1/(1+z))*(1+z)**2/MPC_in_sec       
 15736      
 15737 
 15738 !       Get the radiative rates using PPQ fit, identical to Hummer's table
 15739         
 15740         Rdown = 1.d-19*a_PPB*(Tmat/1.d4)**b_PPB &
 15741                 /(1+c_PPB*(Tmat/1.d4)**d_PPB)
 15742         Rup = Rdown * (CR*Tmat)**(1.5)*exp(-CDB/Tmat)
 15743       
 15744 !       calculate He using a fit to a Verner & Ferland type formula
 15745         sq_0 = sqrt(Tmat/T_0)
 15746         sq_1 = sqrt(Tmat/T_1)
 15747 !       typo here corrected by Wayne Hu and Savita Gahlaut
 15748         Rdown_He = a_VF/(sq_0*(1+sq_0)**(1-b_VF))
 15749         Rdown_He = Rdown_He/(1+sq_1)**(1+b_VF)
 15750         Rup_He = Rdown_He*(CR*Tmat)**(1.5)*exp(-CDB_He/Tmat)
 15751         Rup_He = 4*Rup_He    !statistical weights factor for HeI
 15752 !       Avoid overflow (pointed out by Jacques Roland)
 15753         if((Bfact/Tmat) > 680)then
 15754           He_Boltz = exp(680)
 15755         else
 15756           He_Boltz = exp(Bfact/Tmat)
 15757         end if
 15758 !	now deal with H and its fudges
 15759     if (.not. Recomb%RECFAST_Hswitch) then
 15760       K = CK/Hz		!Peebles coefficient K = lambda_a^3/8piH
 15761     else
 15762 !c	fit a double Gaussian correction function
 15763       K = CK/Hz*(1.0 &
 15764         +AGauss1*exp(-((log(1.0+z)-zGauss1)/wGauss1)**2) &
 15765         +AGauss2*exp(-((log(1.0+z)-zGauss2)/wGauss2)**2))
 15766     end if        
 15767         
 15768         
 15769  !  add the HeI part, using same T_0 and T_1 values
 15770     Rdown_trip = a_trip/(sq_0*(1+sq_0)**(1.0-b_trip))
 15771     Rdown_trip = Rdown_trip/((1+sq_1)**(1+b_trip))
 15772     Rup_trip = Rdown_trip*dexp(-h_P*C*L_He2St_ion/(k_B*Tmat))
 15773     Rup_trip = Rup_trip*((CR*Tmat)**(1.5))*(4/3)
 15774 !   last factor here is the statistical weight
 15775 
 15776 !       try to avoid "NaN" when x_He gets too small
 15777     if ((x_He < 5.d-9) .or. (x_He > 0.98)) then 
 15778       Heflag = 0
 15779     else
 15780       Heflag = Recomb%RECFAST_Heswitch
 15781     end if
 15782     if (Heflag = 0)then        !use Peebles coeff. for He
 15783       K_He = CK_He/Hz
 15784     else    !for Heflag>0       !use Sobolev escape probability
 15785       tauHe_s = A2P_s*CK_He*3*n_He*(1-x_He)/Hz
 15786       pHe_s = (1 - dexp(-tauHe_s))/tauHe_s
 15787       K_He = 1/(A2P_s*pHe_s*3*n_He*(1-x_He))
 15788 !      if (((Heflag = 2) .or. (Heflag.ge.5)) .and. x_H < 0.99999) then 
 15789       if (((Heflag = 2) .or. (Heflag.ge.5)) .and. x_H < 0.9999999) then
 15790        !AL changed July 08 to get smoother Helium
 15791 
 15792 !   use fitting formula for continuum opacity of H
 15793 !   first get the Doppler width parameter
 15794         Doppler = 2*k_B*Tmat/(m_H*not4*C*C)
 15795         Doppler = C*L_He_2p*dsqrt(Doppler)
 15796         gamma_2Ps = 3*A2P_s*fHe*(1-x_He)*C*C &
 15797             /(dsqrt(Pi)*sigma_He_2Ps*8*Pi*Doppler*(1-x_H)) &
 15798             /((C*L_He_2p)**2)
 15799         pb = 0.36  !value from KIV (2007)
 15800         qb = Recomb%RECFAST_fudge_He
 15801 !   calculate AHcon, the value of A*p_(con,H) for H continuum opacity
 15802         AHcon = A2P_s/(1+pb*(gamma_2Ps**qb))
 15803         K_He = 1/((A2P_s*pHe_s+AHcon)*3*n_He*(1-x_He))
 15804       end if
 15805       if (Heflag.ge.3) then     !include triplet effects
 15806         tauHe_t = A2P_t*n_He*(1-x_He)*3
 15807         tauHe_t = tauHe_t /(8*Pi*Hz*L_He_2Pt**(3))
 15808         pHe_t = (1 - dexp(-tauHe_t))/tauHe_t
 15809         CL_PSt = h_P*C*(L_He_2Pt - L_He_2st)/k_B
 15810         if ((Heflag = 3) .or. (Heflag = 5).or.(x_H > 0.99999)) then !Recfast 1.4.2 (?)
 15811 !        if ((Heflag = 3) .or. (Heflag = 5) .or. x_H > = 0.9999999) then    !no H cont. effect
 15812             CfHe_t = A2P_t*pHe_t*dexp(-CL_PSt/Tmat)
 15813             CfHe_t = CfHe_t/(Rup_trip+CfHe_t)   !"C" factor for triplets
 15814         else                  !include H cont. effect
 15815             Doppler = 2*k_B*Tmat/(m_H*not4*C*C)
 15816             Doppler = C*L_He_2Pt*dsqrt(Doppler)
 15817             gamma_2Pt = 3*A2P_t*fHe*(1-x_He)*C*C &
 15818             /(dsqrt(Pi)*sigma_He_2Pt*8*Pi*Doppler*(1-x_H)) &
 15819             /((C*L_He_2Pt)**2)
 15820     !   use the fitting parameters from KIV (2007) in this case
 15821             pb = 0.66
 15822             qb = 0.9
 15823             AHcon = A2P_t/(1+pb*gamma_2Pt**qb)/3
 15824             CfHe_t = (A2P_t*pHe_t+AHcon)*dexp(-CL_PSt/Tmat)
 15825             CfHe_t = CfHe_t/(Rup_trip+CfHe_t)   !"C" factor for triplets
 15826         end if
 15827       end if
 15828     end if
 15829         
 15830         
 15831 !       Estimates of Thomson scattering time and Hubble time
 15832         timeTh = (1/(CT*Trad**4))*(1+x+fHe)/x       !Thomson time
 15833         timeH = 2./(3.*HO*(1+z)**1.5)      !Hubble time
 15834 
 15835 !       calculate the derivatives
 15836 !       turn on H only for x_H<0.99, and use Saha derivative for 0.98 0.99) then   !don't change at all
 15839                 f(1) = 0
 15840 !!        else if (x_H > 0.98) then
 15841       else if (x_H > 0.985) then     !use Saha rate for Hydrogen
 15842             f(1) = (x*x_H*n*Rdown - Rup*(1-x_H)*dexp(-CL/Tmat)) /(Hz*(1+z))
 15843             recombination_saha_z = z  
 15844 !AL: following commented as not used
 15845 !   for interest, calculate the correction factor compared to Saha
 15846 !   (without the fudge)
 15847 !       factor = (1 + K*Lambda*n*(1-x_H))
 15848 !       /(Hz*(1+z)*(1+K*Lambda*n*(1-x)
 15849 !       +K*Rup*n*(1-x)))       
 15850       else !use full rate for H
 15851 
 15852         f(1) = ((x*x_H*n*Rdown - Rup*(1-x_H)*exp(-CL/Tmat)) &
 15853                 *(1 + K*Lambda*n*(1-x_H))) &
 15854                 /(Hz*(1+z)*(1/fu+K*Lambda*n*(1-x_H)/fu &
 15855                 +K*Rup*n*(1-x_H)))
 15856 
 15857       end if
 15858    
 15859 !       turn off the He once it is small
 15860       if (x_He < 1.e-15) then 
 15861                 f(2) = 0
 15862       else
 15863 
 15864         f(2) = ((x*x_He*n*Rdown_He &
 15865             - Rup_He*(1-x_He)*exp(-CL_He/Tmat)) &
 15866                 *(1 + K_He*Lambda_He*n_He*(1-x_He)*He_Boltz)) &
 15867                 /(Hz*(1+z) &
 15868                 * (1 + K_He*(Lambda_He+Rup_He)*n_He*(1-x_He)*He_Boltz))
 15869                 
 15870 !   Modification to HeI recombination including channel via triplets
 15871           if (Heflag.ge.3) then
 15872             f(2) = f(2)+ (x*x_He*n*Rdown_trip & 
 15873              - (1-x_He)*3*Rup_trip*dexp(-h_P*C*L_He_2st/(k_B*Tmat))) &
 15874              *CfHe_t/(Hz*(1+z))
 15875           end if
 15876 
 15877         end if
 15878 
 15879         if (timeTh < H_frac*timeH) then
 15880 !                f(3) = Tmat/(1+z)      !Tmat follows Trad
 15881 !	additional term to smooth transition to Tmat evolution,
 15882 !	(suggested by Adam Moss)
 15883          dHdz = (HO**2/2/Hz)*(4*(1+z)**3/(1+z_eq)*OmegaT &
 15884          + 3*OmegaT*(1+z)**2 + 2*OmegaK*(1+z) )
 15885 
 15886         epsilon = Hz*(1+x+fHe)/(CT*Trad**3*x)
 15887         f(3) = Tnow &
 15888         + epsilon*((1+fHe)/(1+fHe+x))*((f(1)+fHe*f(2))/x) &
 15889         - epsilon* dHdz/Hz + 3.0*epsilon/(1+z) 
 15890                 
 15891         else
 15892                 f(3) = CT * (Trad**4) * x / (1+x+fHe) &
 15893                         * (Tmat-Trad) / (Hz*(1+z)) + 2*Tmat/(1+z)    
 15894         end if
 15895 
 15896          ! print *, z, f(3)*(1+z)/Tmat
 15897          
 15898         if (Do21cm .and. evolve_Ts) then
 15899 
 15900     !       follow the matter temperature once it has a chance of diverging
 15901             if (timeTh < H_frac*timeH) then
 15902                 f(4) = Tnow !spin follows Trad and Tmat
 15903             else
 15904                 if (z< 1/Do21cm_minev-1) then
 15905        
 15906                  Tspin = y(4) 
 15907                  C10 = n*(kappa_HH_21cm(Tmat,.false.)*(1-x_H) + kappa_eH_21cm(Tmat,.false.)*x)
 15908        
 15909                  f(4) = 4*Tspin/Hz/(1+z)*( (Tspin/Tmat-1)*C10 + Trad/T_21cm*(Tspin/Trad-1)*A10) - f(1)*Tspin/(1-x_H)
 15910                 else
 15911                  f(4) = f(3)
 15912                 end if
 15913             end if
 15914       
 15915         end if
 15916 
 15917         end subroutine ION
 15918 
 15919 
 15920 
 15921         function dDeltaxe_dtau(a, Delta_xe,Delta_nH, Delta_Tm, hdot, kvb)
 15922         !d x_e/d tau assuming Helium all neutral and temperature perturbations negligible
 15923         !it is not accurate for x_e of order 1
 15924         use RECDATA
 15925         implicit none
 15926         real(dl) dDeltaxe_dtau
 15927         real(dl), intent(in):: a, Delta_xe,Delta_nH, Delta_Tm, hdot, kvb
 15928         real(dl) Delta_Tg
 15929         real(dl) xedot,z,x,n,n_He,Trad,Tmat,x_H,Hz, C_r, dlnC_r
 15930         real(dl) Rup,Rdown,K
 15931         real(dl) a_PPB,b_PPB,c_PPB,d_PPB
 15932         real(dl) delta_alpha, delta_beta, delta_K, clh
 15933         real(dl) dtauda
 15934         external dtauda
 15935 
 15936        
 15937         Delta_tg = Delta_Tm
 15938         x_H = min(1,Recombination_xe(a))
 15939 
 15940 !       the Pequignot, Petitjean & Boisson fitting parameters for Hydrogen    
 15941         a_PPB = 4.309
 15942         b_PPB = -0.6166
 15943         c_PPB = 0.6703
 15944         d_PPB = 0.5300
 15945  
 15946         z = 1/a-1
 15947 
 15948         x = x_H 
 15949 
 15950         n = Nnow /a**3
 15951         n_He = fHe * n
 15952         Trad = Tnow /a
 15953         clh = 1/dtauda(a)/a !conformal time
 15954         Hz = clh/a/MPC_in_sec !normal time in seconds
 15955 
 15956         Tmat = Recombination_tm(a)
 15957 
 15958 !       Get the radiative rates using PPQ fit, identical to Hummer's table
 15959         
 15960         Rdown = 1.d-19*a_PPB*(Tmat/1.d4)**b_PPB &
 15961                 /(1+c_PPB*(Tmat/1.d4)**d_PPB)   !alpha
 15962         Rup = Rdown * (CR*Tmat)**(1.5)*exp(-CDB/Tmat)
 15963       
 15964         K = CK/Hz              !Peebles coefficient K = lambda_a^3/8piH
 15965 
 15966 
 15967         Rdown = Rdown*fu
 15968         Rup = Rup*fu
 15969         C_r =  a*(1 + K*Lambda*n*(1-x_H)) /( 1+K*(Lambda+Rup)*n*(1-x_H) )*MPC_in_sec
 15970  
 15971         xedot = -(x*x_H*n*Rdown - Rup*(1-x_H)*exp(-CL/Tmat))*C_r
 15972                
 15973         delta_alpha = (b_PPB + c_PPB*(Tmat/1d4)**d_PPB*(b_PPB-d_PPB))/(1+c_PPB*(Tmat/1d4)**d_PPB)*Delta_Tg
 15974         delta_beta = delta_alpha + (3./2 + CDB/Tmat)*delta_Tg !(Rup = beta)
 15975         delta_K = - hdot/clh - kvb/clh/3
 15976 
 15977 
 15978         dlnC_r = -Rup*K*n*( (Delta_nH+Delta_K + Delta_beta*(1+K*Lambda*n*(1-x_H)))*(1-x_H) - x_H*Delta_xe) &
 15979           / ( 1+K*(Lambda+Rup)*n*(1-x_H) ) /(1 + K*Lambda*n*(1-x_H)) 
 15980              
 15981         dDeltaxe_dtau = xedot/x_H*(dlnC_r +Delta_alpha - Delta_xe) &
 15982          - C_r*( (2*Delta_xe + Delta_nH)*x_H*n*Rdown + (Delta_xe - (3./2+ CB1/Tmat)*(1/x_H-1)*Delta_Tg)*Rup*exp(-CL/Tmat))
 15983         
 15984  
 15985 !Approximate form valid at late times
 15986 !        dDeltaxe_dtau = xedot/x_H*(Delta_alpha + Delta_xe + Delta_nH)
 15987 
 15988 
 15989         end function dDeltaxe_dtau
 15990 
 15991 !  = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 15992 
 15993 
 15994           function polevl(x,coef,N)
 15995           implicit none
 15996           integer N
 15997           real(dl) polevl
 15998           real(dl) x,ans
 15999           real(dl) coef(N+1)
 16000 
 16001           integer i
 16002 
 16003           ans = coef(1)
 16004           do i = 2,N+1
 16005              ans = ans*x+coef(i)
 16006           end do
 16007           polevl = ans
 16008       
 16009           end function polevl
 16010 
 16011 
 16012           function derivpolevl(x,coef,N)
 16013           implicit none
 16014           integer N
 16015           real(dl) derivpolevl
 16016           real(dl) x,ans
 16017           real(dl) coef(N+1)
 16018           integer i
 16019 
 16020           ans = coef(1)*N
 16021           do i = 2,N
 16022              ans = ans*x+coef(i)*(N-i+1)
 16023           end do
 16024           derivpolevl = ans
 16025       
 16026           end function derivpolevl
 16027 
 16028 
 16029         function kappa_HH_21cm(T, deriv)
 16030         !Polynomail fit to Hydrogen-Hydrogen collision rate as function of Tmatter, from astro-ph/0608032
 16031         !if deriv return d log kappa / d log T
 16032          real(dl), intent(in) :: T
 16033          logical, intent(in) :: deriv
 16034  !        real(dl), dimension(8), parameter :: fit = &
 16035  !         (/ 0.00120402, -0.0322247,0.339581, -1.75094,4.3528,-4.03562, 1.26899, -29.6113 /)
 16036          integer, parameter :: n_table = 27
 16037          integer, dimension(n_table), parameter :: Temps = &
 16038           (/ 1, 2, 4, 6,8,10,15,20,25,30,40,50,60,70,80,90,100,200,300,500,700,1000,2000,3000,5000,7000,10000/) 
 16039          real, dimension(n_table), parameter :: rates = &
 16040           (/ 1.38e-13, 1.43e-13,2.71e-13, 6.60e-13,1.47e-12,2.88e-12,9.10e-12,1.78e-11,2.73e-11,&
 16041            3.67e-11,5.38e-11,6.86e-11,8.14e-11,9.25e-11, &
 16042            1.02e-10,1.11e-10,1.19e-10,1.75e-10,2.09e-10,2.56e-10,2.91e-10,3.31e-10,4.27e-10,&
 16043            4.97e-10,6.03e-10,6.87e-10,7.87e-10/) 
 16044           
 16045          real(dl) kappa_HH_21cm, logT, logRate
 16046          real(dl), save, dimension(:), allocatable :: logRates, logTemps, ddlogRates
 16047          integer xlo, xhi
 16048          real(dl) :: a0, b0, ho
 16049 
 16050          if (.not. allocated(logRates)) then
 16051 
 16052              allocate(logRates(n_table),logTemps(n_table),ddlogRates(n_table))
 16053              logRates = log(real(rates,dl)*0.01**3)
 16054              logTemps = log(real(Temps,dl))
 16055              call spline(logTemps,logRates,n_table,1d30,1d30,ddlogRates)
 16056          end if
 16057 
 16058          if (T< = Temps(1)) then
 16059              if (deriv) then
 16060               kappa_HH_21cm = 0
 16061              else
 16062               kappa_HH_21cm = rates(1)*0.01**3
 16063              end if
 16064             return
 16065          elseif (T > = Temps(n_table)) then
 16066              if (deriv) then
 16067               kappa_HH_21cm = 0
 16068              else
 16069               kappa_HH_21cm = rates(n_table)*0.01**3
 16070              end if
 16071              return
 16072          end if
 16073          
 16074          logT = log(T)
 16075          xlo = 0
 16076          do xhi = 2, n_table
 16077           if (logT < logTemps(xhi)) then
 16078             xlo = xhi-1
 16079             exit
 16080           end  if
 16081          end do
 16082          xhi = xlo+1
 16083  
 16084          ho = logTemps(xhi)-logTemps(xlo) 
 16085          a0 = (logTemps(xhi)-logT)/ho
 16086          b0 = 1-a0
 16087  
 16088          if (deriv) then
 16089           kappa_HH_21cm  = (logRates(xhi) - logRates(xlo))/ho + &
 16090               ( ddlogRates(xhi)*(3*b0**2-1) - ddlogRates(xlo)*(3*a0**2-1))*ho/6
 16091 !          kappa_HH_21cm = derivpolevl(logT,fit,7)     
 16092          else
 16093           logRate = a0*logRates(xlo)+ b0*logRates(xhi)+ ((a0**3-a0)* ddlogRates(xlo) +(b0**3-b0)*ddlogRates(xhi))*ho**2/6
 16094           kappa_HH_21cm = exp(logRate)
 16095 !          kappa_HH_21cm = exp(polevl(logT,fit,7))*0.01**3          
 16096   
 16097          end if
 16098 
 16099         end function kappa_HH_21cm
 16100 
 16101 
 16102         function kappa_eH_21cm(T, deriv)
 16103         !Polynomail fit to electron-Hydrogen collision rate as function of Tmatter; from astro-ph/0608032
 16104         !if deriv return d log kappa / d log T
 16105         ! from astro-ph/0608032
 16106         !    1 2.39e-10
 16107         !    2 3.37e-10
 16108         !    5 5.3e-10
 16109         !    10 7.46e-10
 16110         !    20 1.05e-9
 16111         !    50 1.63e-9
 16112         !    100 2.26e-9
 16113         !    200 3.11e-9
 16114         !    500 4.59e-9
 16115         !    1000 5.92e-9
 16116         !    2000 7.15e-9
 16117         !    5000 8.17e-9
 16118         !    10000 8.37e-9
 16119         !    15000 8.29e-9
 16120         !    20000 8.11e-9
 16121          real(dl), intent(in) :: T
 16122          logical, intent(in) :: deriv
 16123          real(dl), dimension(6), parameter :: fit = &
 16124           (/5.86236d-005,  -0.00171375, 0.0137303, -0.0435277, 0.540905,-22.1596 /)
 16125        
 16126          real(dl) kappa_eH_21cm, logT
 16127 
 16128          logT = log(T)
 16129          if (deriv) then
 16130           kappa_eH_21cm = derivpolevl(logT,fit,5)      
 16131          else
 16132           kappa_eH_21cm = exp(polevl(logT,fit,5))*0.01**3          
 16133          end if
 16134 
 16135         end function kappa_eH_21cm
 16136 
 16137 
 16138 
 16139 
 16140         function kappa_pH_21cm(T, deriv) ! from astro-ph/0702487
 16141         !Not actually used
 16142         !Polynomail fit to proton-Hydrogen collision rate as function of Tmatter
 16143         !if deriv return d log kappa / d log T
 16144          real(dl), intent(in) :: T
 16145          logical, intent(in) :: deriv
 16146          integer, parameter :: n_table = 17
 16147          integer, dimension(n_table), parameter :: Temps = &
 16148           (/ 1, 2, 5, 10,20,50,100,200,500,1000,2000,3000,5000,7000,10000,15000,20000/) 
 16149          real, dimension(n_table), parameter :: rates = &
 16150           (/ 0.4028, 0.4517,0.4301,0.3699,0.3172,0.3047, 0.3379, 0.4043, 0.5471, 0.7051, 0.9167, 1.070, &
 16151               1.301, 1.48,1.695,1.975,2.201/) 
 16152           
 16153          real(dl) kappa_pH_21cm, logT, logRate
 16154          real(dl), save, dimension(:), allocatable :: logRates, logTemps, ddlogRates
 16155          integer xlo, xhi
 16156          real(dl) :: a0, b0, ho
 16157          real(dl):: factor = 0.01**3*1e-9
 16158 
 16159          if (.not. allocated(logRates)) then
 16160 
 16161              allocate(logRates(n_table),logTemps(n_table),ddlogRates(n_table))
 16162              logRates = log(real(rates,dl)*factor)
 16163              logTemps = log(real(Temps,dl))
 16164              call spline(logTemps,logRates,n_table,1d30,1d30,ddlogRates)
 16165          end if
 16166 
 16167          if (T< = Temps(1)) then
 16168              if (deriv) then
 16169               kappa_pH_21cm = 0
 16170              else
 16171               kappa_pH_21cm = rates(1)*factor
 16172              end if
 16173             return
 16174          elseif (T > = Temps(n_table)) then
 16175              if (deriv) then
 16176               kappa_pH_21cm = 0
 16177              else
 16178               kappa_pH_21cm = rates(n_table)*factor
 16179              end if
 16180              return
 16181          end if
 16182          
 16183          logT = log(T)
 16184          xlo = 0
 16185          do xhi = 2, n_table
 16186           if (logT < logTemps(xhi)) then
 16187             xlo = xhi-1
 16188             exit
 16189           end  if
 16190          end do
 16191          xhi = xlo+1
 16192  
 16193          ho = logTemps(xhi)-logTemps(xlo) 
 16194          a0 = (logTemps(xhi)-logT)/ho
 16195          b0 = 1-a0
 16196  
 16197          if (deriv) then
 16198           kappa_pH_21cm  = (logRates(xhi) - logRates(xlo))/ho + &
 16199            ( ddlogRates(xhi)*(3*b0**2-1) - ddlogRates(xlo)*(3*a0**2-1))*ho/6
 16200          else
 16201           logRate = a0*logRates(xlo)+ b0*logRates(xhi)+ ((a0**3-a0)* ddlogRates(xlo) +(b0**3-b0)*ddlogRates(xhi))*ho**2/6
 16202           kappa_pH_21cm = exp(logRate)
 16203          end if
 16204 
 16205         end function kappa_pH_21cm
 16206 
 16207 
 16208         end module Recombination
 16209 
 16210 ** rionization.f90
 16211 
 16212 
 16213 module Reionization
 16214  use Precision
 16215  use AMLutils
 16216  implicit none  
 16217 
 16218 !This module puts smooth tanh reionization of specified mid-point (z_{re}) and width
 16219 !The tanh function is in the variable (1+z)**Rionization_zexp
 16220 
 16221 !Rionization_zexp = 1.5 has the property that for the same z_{re} 
 16222 !the optical depth agrees with infinitely sharp model for matter domination 
 16223 !So tau and zre can be mapped into each other easily (for any symmetric window)
 16224 !However for generality the module maps tau into z_{re} using a binary search
 16225 !so could be easily modified for other monatonic parameterizations.
 16226 
 16227 !AL March 2008
 16228 !AL July 2008 - added trap for setting optical depth without use_optical_depth
 16229 
 16230 !See CAMB notes for further discussion: http://cosmologist.info/notes/CAMB.pdf
 16231 
 16232        character(LEN = *), parameter :: Reionization_Name = 'CAMB_reionization'
 16233 
 16234        real(dl), parameter :: Reionization_DefFraction = -1 
 16235         !if -1 set from YHe assuming Hydrogen and first ionization of Helium follow each other
 16236        
 16237        real(dl) :: Reionization_AccuracyBoost = 1
 16238        real(dl) :: Rionization_zexp = 1.5
 16239 
 16240        logical :: include_helium_fullreion = .true.
 16241        real(dl) :: helium_fullreion_redshift  = 3.5
 16242        real(dl) :: helium_fullreion_deltaredshift  = 0.5
 16243        real(dl) :: helium_fullreion_redshiftstart  = 5
 16244        
 16245        
 16246        type ReionizationParams
 16247              logical    :: Reionization
 16248              logical    :: use_optical_depth
 16249              real(dl)   :: redshift, delta_redshift, fraction
 16250              real(dl)   :: optical_depth
 16251         end type ReionizationParams
 16252   
 16253         type ReionizationHistory
 16254 !These two are used by main code to bound region where xe changing 
 16255           real(dl) :: tau_start, tau_complete
 16256 !This is set from main code          
 16257           real(dl) :: akthom, fHe
 16258 
 16259 !The rest are internal to this module.
 16260           real(dl) :: WindowVarMid, WindowVarDelta
 16261 
 16262         end type ReionizationHistory
 16263 
 16264       real(dl), parameter :: Reionization_maxz = 40
 16265       real(dl), private, parameter :: Reionization_tol = 1d-5
 16266 
 16267       real(dl), private, external :: dtauda, rombint,rombint2
 16268 
 16269     Type(ReionizationParams), private, pointer ::  ThisReion
 16270     Type(ReionizationHistory), private, pointer :: ThisReionHist
 16271 
 16272 contains
 16273 
 16274  
 16275  function Reionization_xe(a, tau, xe_recomb)
 16276  !a and time tau and redundant, both provided for convenience
 16277  !xe_recomb is xe(tau_start) from recombination (typically very small, ~2e-4)
 16278  !xe should map smoothly onto xe_recomb
 16279   real(dl), intent(in) :: a
 16280   real(dl), intent(in), optional :: tau, xe_recomb
 16281   real(dl) Reionization_xe
 16282   real(dl) tgh, xod
 16283   real(dl) xstart
 16284   
 16285         if (present(xe_recomb)) then
 16286         xstart = xe_recomb
 16287         else
 16288         xstart = 0
 16289         end if
 16290         
 16291         xod = (ThisReionHist%WindowVarMid - 1/a**Rionization_zexp)/ThisReionHist%WindowVarDelta
 16292         if (xod > 100) then
 16293             tgh = 1
 16294         else
 16295             tgh = tanh(xod)
 16296         end if
 16297         Reionization_xe = (ThisReion%fraction-xstart)*(tgh+1)/2+xstart
 16298      
 16299         if (include_helium_fullreion .and. a > (1/(1+ helium_fullreion_redshiftstart))) then
 16300         
 16301          !Effect of Helium becoming fully ionized at z <~ 3.5 is very small so details not important
 16302           xod = (1+helium_fullreion_redshift - 1/a)/helium_fullreion_deltaredshift
 16303           if (xod > 100) then
 16304              tgh = 1
 16305           else
 16306              tgh = tanh(xod)
 16307           end if
 16308       
 16309         Reionization_xe =  Reionization_xe + ThisReionHist%fHe*(tgh+1)/2
 16310   
 16311        end if
 16312       
 16313  end function Reionization_xe  
 16314  
 16315  function Reionization_timesteps(ReionHist)
 16316  !minimum number of time steps to use between tau_start and tau_complete
 16317  !Scaled by AccuracyBoost later
 16318  !steps may be set smaller than this anyway
 16319   Type(ReionizationHistory) :: ReionHist
 16320   integer Reionization_timesteps
 16321   
 16322   Reionization_timesteps = 50 
 16323   
 16324  end  function Reionization_timesteps
 16325  
 16326  subroutine Reionization_ReadParams(Reion, Ini)
 16327   use IniFile
 16328   Type(ReionizationParams) :: Reion
 16329   Type(TIniFile) :: Ini
 16330 
 16331    Reion%Reionization = Ini_Read_Logical_File(Ini,'reionization')
 16332    if (Reion%Reionization) then
 16333    
 16334     Reion%use_optical_depth = Ini_Read_Logical_File(Ini,'re_use_optical_depth') 
 16335   
 16336     if (Reion%use_optical_depth) then
 16337               Reion%optical_depth = Ini_Read_Double_File(Ini,'re_optical_depth')
 16338     else 
 16339               Reion%redshift = Ini_Read_Double_File(Ini,'re_redshift')
 16340     end if 
 16341 
 16342     Reion%delta_redshift = Ini_Read_Double_File(Ini,'re_delta_redshift', 0.5) !default similar to CMBFAST original
 16343     Reion%fraction = Ini_Read_Double_File(Ini,'re_ionization_frac',Reionization_DefFraction)
 16344   
 16345   end if
 16346 
 16347  end subroutine Reionization_ReadParams 
 16348 
 16349  subroutine Reionization_SetParamsForZre(Reion,ReionHist)
 16350   Type(ReionizationParams), target :: Reion
 16351   Type(ReionizationHistory), target :: ReionHist 
 16352      
 16353        ReionHist%WindowVarMid = (1+Reion%redshift)**Rionization_zexp
 16354        ReionHist%WindowVarDelta = &
 16355          Rionization_zexp*(1+Reion%redshift)**(Rionization_zexp-1)*Reion%delta_redshift
 16356  
 16357  end subroutine Reionization_SetParamsForZre
 16358 
 16359  subroutine Reionization_Init(Reion, ReionHist, Yhe, akthom, tau0, FeedbackLevel)
 16360   use constants
 16361   Type(ReionizationParams), target :: Reion
 16362   Type(ReionizationHistory), target :: ReionHist
 16363   real(dl), intent(in) :: akthom, tau0, Yhe 
 16364   integer, intent(in) :: FeedbackLevel
 16365   real(dl) astart
 16366 
 16367      ReionHist%akthom = akthom  
 16368      ReionHist%fHe =  YHe/(mass_ratio_He_H*(1-YHe))
 16369  
 16370      ReionHist%tau_start = tau0
 16371      ReionHist%tau_complete = tau0
 16372       
 16373      ThisReion = > Reion
 16374      ThisReionHist = > ReionHist
 16375 
 16376      if (Reion%Reionization) then
 16377  
 16378             if (Reion%optical_depth /= 0 .and. .not. Reion%use_optical_depth) &
 16379              write (*,*) 'WARNING: You seem to have set the optical depth, but use_optical_depth = F'
 16380     
 16381 
 16382            if (Reion%use_optical_depth.and.Reion%optical_depth<0.001 &
 16383                 .or. .not.Reion%use_optical_depth .and. Reion%Redshift<0.001) then
 16384                Reion%Reionization = .false.
 16385            end if
 16386           
 16387       end if   
 16388      
 16389      if (Reion%Reionization) then
 16390            
 16391         if (Reion%fraction = Reionization_DefFraction) &
 16392                  Reion%fraction = 1 + ReionHist%fHe  !H + singly ionized He
 16393           
 16394        if (Reion%use_optical_depth) then
 16395         call Reionization_SetFromOptDepth(Reion,ReionHist)
 16396         if (FeedbackLevel > 0) write(*,'("Reion redshift       =  ",f6.3)') Reion%redshift
 16397        end if
 16398 
 16399        call Reionization_SetParamsForZre(ThisReion,ThisReionHist)
 16400        
 16401       !this is a check, agrees very well in default parameterization
 16402        if (FeedbackLevel > 1) write(*,'("Integrated opt depth = ",f7.4)') &
 16403             Reionization_GetOptDepth(Reion, ReionHist) 
 16404 
 16405       !Get relevant times       
 16406        astart = 1/(1+Reion%redshift + Reion%delta_redshift*8)
 16407        ReionHist%tau_start = max(0.05, rombint(dtauda,0,astart,1d-3))
 16408           !Time when a very small reionization fraction (assuming tanh fitting)
 16409 
 16410        ReionHist%tau_complete = min(tau0, &
 16411           ReionHist%tau_start+ rombint(dtauda,astart,1/(1+max(0,Reion%redshift-Reion%delta_redshift*8)),1d-3))
 16412 
 16413     end if   
 16414        
 16415  end subroutine Reionization_Init
 16416  
 16417  
 16418  subroutine Reionization_SetDefParams(Reion)
 16419   Type(ReionizationParams) :: Reion
 16420  
 16421        Reion%Reionization = .true.
 16422        Reion%use_optical_depth = .false.
 16423        Reion%optical_depth = 0
 16424        Reion%redshift = 10
 16425        Reion%fraction = Reionization_DefFraction
 16426        Reion%delta_redshift = 0.5
 16427 
 16428  end subroutine Reionization_SetDefParams
 16429 
 16430  subroutine Reionization_Validate(Reion, OK)
 16431   Type(ReionizationParams),intent(in) :: Reion
 16432   logical, intent(inout) :: OK
 16433  
 16434       if (Reion%Reionization) then
 16435         if (Reion%use_optical_depth) then
 16436             if (Reion%optical_depth<0 .or. Reion%optical_depth > 0.9  .or. &
 16437                include_helium_fullreion .and. Reion%optical_depth<0.01) then
 16438              OK = .false.
 16439              write(*,*) 'Optical depth is strange. You have:', Reion%optical_depth 
 16440             end if
 16441         else
 16442             if (Reion%redshift < 0 .or. Reion%Redshift +Reion%delta_redshift*3 > Reionization_maxz .or. &
 16443               include_helium_fullreion .and. Reion%redshift < helium_fullreion_redshift) then
 16444                 OK = .false.
 16445                 write(*,*) 'Reionization redshift strange. You have: ',Reion%Redshift
 16446             end if
 16447         end if
 16448         if (Reion%fraction/= Reionization_DefFraction .and. (Reion%fraction < 0 .or. Reion%fraction > 1.5)) then
 16449                 OK = .false.
 16450                 write(*,*) 'Reionization fraction strange. You have: ',Reion%fraction
 16451         end if
 16452         if (Reion%delta_redshift > 3 .or. Reion%delta_redshift<0.1 ) then
 16453         !Very narrow windows likely to cause problems in interpolation etc.
 16454         !Very broad likely to conflic with quasar data at z = 6
 16455                 OK = .false.
 16456                 write(*,*) 'Reionization delta_redshift is strange. You have: ',Reion%delta_redshift
 16457         end if
 16458 
 16459 
 16460       end if
 16461              
 16462   end  subroutine Reionization_Validate
 16463 
 16464 
 16465  function Reionization_doptdepth_dz(z)
 16466    real(dl) :: Reionization_doptdepth_dz
 16467    real(dl), intent(in) :: z
 16468    real(dl) a
 16469    
 16470    a = 1/(1+z)
 16471    
 16472    Reionization_doptdepth_dz = Reionization_xe(a)*ThisReionHist%akthom*dtauda(a)
 16473 
 16474  end function Reionization_doptdepth_dz
 16475 
 16476 function Reionization_GetOptDepth(Reion, ReionHist) 
 16477  Type(ReionizationParams), target :: Reion
 16478  Type(ReionizationHistory), target :: ReionHist
 16479  real(dl) Reionization_GetOptDepth      
 16480   
 16481   ThisReion = > Reion
 16482   ThisReionHist = > ReionHist
 16483   Reionization_GetOptDepth = rombint2(Reionization_doptdepth_dz,0,Reionization_maxz,&
 16484          Reionization_tol, 20, nint(Reionization_maxz/Reion%delta_redshift*5))
 16485 
 16486 end function Reionization_GetOptDepth
 16487 
 16488  subroutine Reionization_zreFromOptDepth(Reion, ReionHist)
 16489  !General routine to find zre parameter given optical depth
 16490  !Not used for Rionization_zexp = 1.5
 16491   Type(ReionizationParams) :: Reion
 16492   Type(ReionizationHistory) :: ReionHist
 16493   real(dl) try_b, try_t
 16494   real(dl) tau
 16495   integer i
 16496   
 16497   try_b = 0
 16498   try_t = Reionization_maxz
 16499   i = 0
 16500   do 
 16501        i = i+1  
 16502        Reion%redshift = (try_t + try_b)/2
 16503        call Reionization_SetParamsForZre(Reion,ReionHist)
 16504        tau = Reionization_GetOptDepth(Reion, ReionHist)
 16505        
 16506        if (tau > Reion%optical_depth) then
 16507                   try_t = Reion%redshift
 16508           else
 16509                   try_b = Reion%redshift
 16510        end if
 16511        if (abs(try_b - try_t) < 2e-3/Reionization_AccuracyBoost) exit
 16512        if (i>100) call mpiStop('Reionization_zreFromOptDepth: failed to converge')        
 16513   end do
 16514   
 16515   
 16516    if (abs(tau - Reion%optical_depth) > 0.002) then
 16517     write (*,*) 'Reionization_zreFromOptDepth: Did not converge to optical depth'
 16518     write (*,*) 'tau = ',tau, 'optical_depth = ', Reion%optical_depth
 16519     write (*,*) try_t, try_b
 16520     call mpiStop()
 16521   end if
 16522     
 16523  end subroutine Reionization_zreFromOptDepth 
 16524 
 16525 
 16526  
 16527  subroutine Reionization_SetFromOptDepth(Reion, ReionHist)
 16528   Type(ReionizationParams) :: Reion
 16529   Type(ReionizationHistory) :: ReionHist
 16530    
 16531 ! This subroutine calculates the redshift of reionization
 16532 
 16533 ! This implementation is approximate but quite accurate and fast
 16534 
 16535       real(dl) dz, optd
 16536       real(dl) z, tmp, tmpHe
 16537       integer na
 16538       
 16539       Reion%redshift = 0
 16540 
 16541       if (Reion%Reionization .and. Reion%optical_depth /= 0) then
 16542 
 16543            !Do binary search to find zre from z
 16544            !This is general method
 16545            call Reionization_zreFromOptDepth(Reion, ReionHist)
 16546 
 16547         if (.false.) then
 16548           !Use equivalence with sharp for special case
 16549             optd = 0
 16550             na = 1
 16551             dz = 1/2000/Reionization_AccuracyBoost
 16552             tmp = dz*Reion%fraction*ThisReionHist%akthom
 16553             tmpHe = dz*(Reion%fraction+ReionHist%fHe)*ThisReionHist%akthom
 16554             z = 0
 16555             do while (optd < Reion%optical_depth)
 16556                 z = na*dz
 16557                 if (include_helium_fullreion .and. z < helium_fullreion_redshift) then
 16558                 optd = optd+ tmpHe*dtauda(1/(1+z))
 16559                 else
 16560                 optd = optd+tmp*dtauda(1/(1+z))
 16561                 end if
 16562                 na = na+1
 16563             end do
 16564          end if
 16565       else
 16566          Reion%Reionization = .false.
 16567       end if
 16568  
 16569  end  subroutine Reionization_SetFromOptDepth 
 16570 
 16571 
 16572 
 16573 end module Reionization
 16574 
 16575 
 16576 ** SepableBispectrum.f90
 16577 
 16578 !First version AL October 2010
 16579 
 16580 !Calculates local fnl and CMB lensing bispectra
 16581 !CMB lensing bispectra are calculated in the approximation in which the first-order
 16582 !result is used replacing the unlensed with the lensing power spectra
 16583 !This is non-perturbatively correct to about 1%
 16584 !Note the lensing bispectrum only includes the linear potentials, no Rees-Sciama or SZ
 16585 !See Lewis, Challinor & Hanson 2010 for details
 16586 
 16587 !Note that the primordial local bispectra are unlensed (see arXiv: 0905.4732)
 16588 
 16589 !Compile with LAPACK and -DFISHER if you want to get the fisher matrix outputs
 16590 !This is disabled by default in order not to require LAPACK
 16591 
 16592 !Fisher results are with and without the cosmic variance from low L_1
 16593 
 16594 module Bispectrum
 16595  use ModelParams
 16596  use ModelData
 16597  use InitialPower
 16598  use SpherBessels
 16599  use IniFile
 16600  implicit none
 16601  
 16602    integer, parameter :: max_bispectrum_deltas = 5, max_bispectrum_fields = 3
 16603 
 16604    Type TBispectrumParams
 16605      logical do_lensing_bispectrum 
 16606      logical do_primordial_bispectrum
 16607      integer nfields
 16608      integer Slice_Base_L, ndelta, deltas(max_bispectrum_deltas)
 16609      logical do_parity_odd
 16610      logical DoFisher
 16611      logical export_alpha_beta
 16612      real(dl) FisherNoise, FisherNoisePol, FisherNoiseFwhmArcmin
 16613      character(LEN = Ini_max_string_len)  FullOutputFile
 16614      logical SparseFullOutput
 16615    end Type
 16616 
 16617     !global parameter for now, only intend for this module to be used interactively for the moment
 16618     Type(TBispectrumParams)  :: BispectrumParams
 16619 
 16620    Type TBispectrum
 16621       real(dl), pointer :: b(:,:)
 16622    end Type 
 16623    Type TCov
 16624       real(dl), pointer :: C(:,:)
 16625    end type TCov
 16626 
 16627    Type TCov2
 16628       real(dl) :: C(2,2)
 16629    end type TCov2
 16630 
 16631    Type TCov3
 16632       real(dl) :: C(3,3)
 16633    end type TCov3
 16634  
 16635    real(dl), allocatable :: dJl(:,:), dddJl(:,:)
 16636    real(dl), parameter :: InternalScale = 1d10
 16637    character(LEN = 1024) :: output_root = ''
 16638    integer, parameter :: shape_local = 1, shape_warm = 2, shape_warm2 = 3
 16639    integer, parameter :: shape = shape_local
 16640 
 16641    real(dl), allocatable :: TransferPolFac(:)      !sqrt((l+2)!/(l-2)!)      
 16642 contains
 16643         
 16644         subroutine InitBesselDerivs(CTrans)
 16645          ! j_l' array for interpolation if needed; not needed for local fnl
 16646          Type(ClTransferData) :: CTrans
 16647          integer i,l1,j
 16648          real(dl) Jm, Jp
 16649          
 16650            if (allocated(dJl)) then
 16651             deallocate(dJL, dddJl)
 16652            end if
 16653            allocate(dJl(BessRanges%npoints,CTrans%ls%l0),dddJl(BessRanges%npoints,CTrans%ls%l0))
 16654            
 16655            do i = 1, CTrans%ls%l0
 16656            !Spline agrees well
 16657            !  call spline_deriv(BessRanges%points,ajl(1,i),ajlpr(1,i),dJl(1,i),BessRanges%npoints)
 16658            !  call spline(BessRanges%points,dJl(1,i),BessRanges%npoints,spl_large,spl_large,dddJl(1,i))
 16659            
 16660              l1 = CTrans%ls%l(i)
 16661              do j = 1, BessRanges%npoints
 16662               call BJL(l1-1,BessRanges%points(j),Jm)
 16663               call BJL(l1+1,BessRanges%points(j),Jp)
 16664               dJl(j,i) =  ( l1*Jm - (l1+1)*Jp)/(2*l1+1)
 16665              end do
 16666             call spline(BessRanges%points,dJl(1,i),BessRanges%npoints,spl_large,spl_large,dddJl(1,i))
 16667            
 16668            end do           
 16669         
 16670         end subroutine InitBesselDerivs
 16671 
 16672      subroutine NonGauss_l_r_localOpt(CTrans, ind, indP, res, resP, nfields, r)
 16673          !functions of the form int dk k^2 k^i j_l(kr) Delta_l(k) [P]
 16674          !ind and indP are arrays of required k^i powers
 16675          !res and resP are the results without and with the power spectrum P in the integrand
 16676           Type(ClTransferData) :: CTrans
 16677           integer, intent(in) :: ind(:), indP(:) 
 16678           integer :: nfields
 16679           real(dl) res(CTrans%ls%l0,size(ind),nfields), resP(CTrans%ls%l0,size(indP),nfields)
 16680           real(dl), intent(in) :: r
 16681           integer q_ix, j, bes_ix
 16682           integer n, nP, ellmax
 16683           real(dl) xf , J_l, fac, a2, k, dlnk, term, P, kpow, kpowP        
 16684           
 16685           n = size(ind)
 16686           nP = size(indP)          
 16687           res = 0
 16688           resP = 0
 16689           do q_ix = 1, CTrans%q%npoints 
 16690             k = CTrans%q%points(q_ix)
 16691             xf = k*r  
 16692             bes_ix = Ranges_indexOf(BessRanges,xf)
 16693             fac = BessRanges%points(bes_ix+1)-BessRanges%points(bes_ix)
 16694             a2 = (BessRanges%points(bes_ix+1)-xf)/fac
 16695             fac = fac**2*a2/6
 16696             dlnk = CTrans%q%dpoints(q_ix) /k
 16697             P = ScalarPower(k, 1)*InternalScale  !!only first index for now
 16698           
 16699             ellmax = max(xf/(1-xlimfrac), xf + xlimmin) * AccuracyBoost
 16700             kpow =  k**(ind(1)+3)  
 16701             kpowP = k**indP(1) * P      
 16702             do j = 1,CTrans%ls%l0
 16703              if (CTrans%ls%l(j) < = ellmax) then
 16704               J_l = a2*ajl(bes_ix,j)+(1-a2)*(ajl(bes_ix+1,j) - ((a2+1) &
 16705                          *ajlpr(bes_ix,j)+(2-a2)*ajlpr(bes_ix+1,j))* fac) !cubic spline
 16706               term = CTrans%Delta_p_l_k(1,j,q_ix)*J_l*dlnk  
 16707               res(j,1,1) = res(j,1,1) + term * kpow
 16708               resP(j,1,1) = resP(j,1,1) + term * kpowP
 16709               if (nfields>1) then
 16710                 !E pol
 16711                   term = CTrans%Delta_p_l_k(2,j,q_ix)*J_l*dlnk * TransferPolFac(CTrans%ls%l(j))  
 16712                   res(j,1,2) = res(j,1,2) + term * kpow
 16713                   resP(j,1,2) = resP(j,1,2) + term * kpowP
 16714                   if (nfields>2) then
 16715                   !lensing potential
 16716                   term = CTrans%Delta_p_l_k(3,j,q_ix)*J_l*dlnk 
 16717                   res(j,1,3) = res(j,1,3) + term * kpow
 16718                   resP(j,1,3) = resP(j,1,3) + term * kpowP
 16719                   end if
 16720               end if
 16721              
 16722              end if
 16723            end do
 16724          end do
 16725          resP = resP * fourpi
 16726          res = res * 2/pi
 16727                
 16728         end subroutine NonGauss_l_r_localOpt
 16729 
 16730         subroutine NonGauss_l_r(CTrans, ind, indP,res, resP,nfields, r)
 16731          !functions of the form int dk k^2 k^i j_l(kr) Delta_l(k) [P]
 16732          !ind and indP are arrays of required k^i powers
 16733          !res and resP are the results without and with the power spectrum P in the integrand
 16734          !Output of P scaled by 1d10 (so bispectrum by 1d20)
 16735           Type(ClTransferData) :: CTrans
 16736           integer:: nfields
 16737           integer, intent(in) :: ind(:), indP(:) 
 16738           real(dl) res(CTrans%ls%l0,size(ind),nfields), resP(CTrans%ls%l0,size(indP),nfields)
 16739           real(dl), intent(in) :: r
 16740           integer q_ix, j, bes_ix, i
 16741           integer n, nP, ellmax
 16742           real(dl) xf , J_l, fac, a2, k, dlnk, term, P, kpow(size(ind)), kpow2(size(indP))        
 16743      
 16744           if (shape = shape_local) then
 16745             call NonGauss_l_r_localOpt(CTrans, ind, indP,res, resP, nfields, r)
 16746             return
 16747           end if
 16748           
 16749           n = size(ind)
 16750           nP = size(indP)          
 16751           res = 0
 16752           resP = 0
 16753           do q_ix = 1, CTrans%q%npoints 
 16754             k = CTrans%q%points(q_ix)
 16755             xf = k*r  
 16756             bes_ix = Ranges_indexOf(BessRanges,xf)
 16757             fac = BessRanges%points(bes_ix+1)-BessRanges%points(bes_ix)
 16758             a2 = (BessRanges%points(bes_ix+1)-xf)/fac
 16759             fac = fac**2*a2/6
 16760             dlnk = CTrans%q%dpoints(q_ix) /k
 16761             P = ScalarPower(k, 1)*InternalScale  !!only first index for now
 16762           
 16763             ellmax = max(xf/(1-xlimfrac), xf + xlimmin) * AccuracyBoost
 16764             do i = 1,n
 16765               kpow(i) = k**(ind(i)+3)
 16766             end do
 16767             do i = 1,nP
 16768               kpow2(i) = k**indP(i) * P
 16769             end do
 16770                       
 16771             do j = 1,CTrans%ls%l0
 16772              if (CTrans%ls%l(j) < = ellmax) then
 16773 
 16774               J_l = a2*ajl(bes_ix,j)+(1-a2)*(ajl(bes_ix+1,j) - ((a2+1) &
 16775                          *ajlpr(bes_ix,j)+(2-a2)*ajlpr(bes_ix+1,j))* fac) !cubic spline
 16776               !call BJL(CTrans%ls%l(j), xf, J_l)           
 16777               term = CTrans%Delta_p_l_k(1,j,q_ix)*J_l*dlnk  
 16778               do i = 1,n
 16779                res(j,i,1) = res(j,i,1) + term *kpow(i)
 16780               end do
 16781               do i = 1,nP
 16782                resP(j,i,1) = resP(j,i,1) + term * kpow2(i)
 16783               end do
 16784          !     if (CTrans%ls%l(j) = 8) write (1,'(9D20.7)') &
 16785          !      k, xf, real(term * k**3/dlnk), real(term * k**indP(1) * P), &
 16786          !      real(res(j,1)),real(resP(j,1)), J_l, real(term), real(CTrans%Delta_p_l_k(1,j,q_ix))
 16787               if (nfields>1) then
 16788                 !E pol
 16789                   term = CTrans%Delta_p_l_k(2,j,q_ix)*J_l*dlnk* TransferPolFac(CTrans%ls%l(j))  
 16790                   do i = 1,n
 16791                    res(j,i,2) = res(j,i,2) + term *kpow(i)
 16792                   end do
 16793                   do i = 1,nP
 16794                    resP(j,i,2) = resP(j,i,2) + term * kpow2(i)
 16795                   end do
 16796                   if (nfields>2) then
 16797                   !lensing potential
 16798                   term = CTrans%Delta_p_l_k(3,j,q_ix)*J_l*dlnk 
 16799                       do i = 1,n
 16800                        res(j,i,3) = res(j,i,3) + term *kpow(i)
 16801                       end do
 16802                       do i = 1,nP
 16803                        resP(j,i,3) = resP(j,i,3) + term * kpow2(i)
 16804                       end do
 16805                   end if
 16806               end if
 16807                               
 16808              end if
 16809            end do
 16810          end do
 16811          resP = resP * fourpi
 16812          res = res * 2/pi
 16813                
 16814         end subroutine NonGauss_l_r
 16815 
 16816 
 16817         subroutine GetBispectrum(CTrans)
 16818          !Note: may need high maxetak to make sure oscillatory k integrals cancel correctly
 16819          !for accurate alpha(r), beta(r), e.g. 8000; not so important for bispectrum
 16820          !increase accuracy_boost
 16821           use lensing
 16822           use lvalues
 16823           use constants
 16824           use Ranges
 16825 !ifdef FISHER
 16826           use MatrixUtils
 16827 !endif          
 16828           integer, parameter :: max_bispectra = 2  !fnl, lensing
 16829           Type(ClTransferData) :: CTrans
 16830           Type(Regions) :: TimeStepsNongauss
 16831           integer, allocatable ::  ind(:), indP(:), indPd(:)
 16832           real(dl), allocatable :: res(:,:,:), resP(:,:,:), resPd(:,:)
 16833           real(dl), allocatable :: res_l(:,:,:), resP_l(:,:,:), resPd_l(:,:)
 16834           real(dl) r, term
 16835           Type(TBispectrum), target,allocatable :: Bispectra(:,:,:,:), OddBispectra (:)
 16836             !TTT, TTE, etc; last index is bispectrum kind, default 1 = fnl, 2 = lensing
 16837             !OddBispectra are parity odd terms like TEB (if do_parity_odd requested for lensing)
 16838           Type(TBispectrum), pointer :: Bispectrum
 16839               !For use in Fisher approximations 
 16840           real(dl) test(lmin:CTrans%ls%l(CTrans%ls%l0))
 16841           integer i, j, l1,l2,l3, il1, n,np, npd
 16842           integer min_l, max_l, lmax
 16843           real(dl) tmp, tmp1, tmp2, tmp3
 16844           real(dl) a3j(0:CTrans%ls%l(CTrans%ls%l0)*2+1)         
 16845           real(dl) a3j2(0:CTrans%ls%l(CTrans%ls%l0)*2+1,4,2)
 16846           real(dl) CLForLensingIn(4,lmin:CTrans%ls%l(CTrans%ls%l0)),CPhi(3,lmin:CTrans%ls%l(CTrans%ls%l0))
 16847           Type(lSamples) :: SampleL
 16848           real starttime  
 16849           real(dl) Bscale
 16850           integer field, field1,field2,field3, bi_ix,bix
 16851           Type(TCov2), allocatable :: CForLensing(:)
 16852           integer nfields, nbispectra, bispectrum_type      
 16853           integer :: fnl_bispectrum_ix = 1
 16854           integer :: lens_bispectrum_ix = 2
 16855           character(LEN = 256) ::  file_tag = ''
 16856           integer idelta, fileid
 16857           character(LEN = 26) :: BispectrumNames(max_bispectra)
 16858           integer :: parities(3), oddix  
 16859           integer, parameter :: lmax_lensing_corrT = 300 
 16860             !assume C^{T\psi} zero above this for CMB lensing; also neglect lensing contributions to variance
 16861           integer, parameter :: lmax_lensing_corrE = 40 !assume C^{E\psi} zero above this for CMB lensing
 16862 
 16863           integer, parameter :: first_order_unlensed = 1, first_order_lensed = 2
 16864           integer, parameter :: lens_bispectrum_approx = first_order_lensed
 16865 !ifdef FISHER
 16866          Type(TBispectrum), pointer :: Bispectrum2
 16867           real(dl) Cl(4,lmin:CTrans%ls%l(CTrans%ls%l0))
 16868           real(dl)  a3j_00(0:CTrans%ls%l(CTrans%ls%l0)*2+1)          
 16869           integer lstart
 16870           real(dl) Noise, NoiseP, bias
 16871           real(dl), allocatable:: fish_contribs(:,:,:)
 16872           real(dl) fish_contribs_sig(lmin:CTrans%ls%l(CTrans%ls%l0))
 16873           real(dl), allocatable :: ifish_contribs(:,:,:,:,:), Fisher(:,:), tmpFisher(:,:),OptimalFisher(:,:)
 16874           real(dl), allocatable :: tmpBigFisher(:,:), Fisher_L1(:,:,:),tmpProjFisher(:,:)
 16875           real(dl), allocatable :: fish_l1(:,:,:,:), fish_L_ij(:,:), fish_L_noise(:,:)
 16876           Type(TBispectrum), target,allocatable :: SqueezedLensingKernel(:,:)
 16877           real(dl) sigma2, xlc, tmpf(3)
 16878           integer  f1,f2,f3, minl2,bigi,bigj, bispectrum_type2, lmaxcuti
 16879           integer sz,corrsize
 16880           Type(TCov), allocatable :: InvC(:)
 16881           integer ix1,ix2
 16882           real(dl) tmpArr(lmin:CTrans%ls%l(CTrans%ls%l0))
 16883 !endif
 16884           
 16885           parities(1) = 1  !T
 16886           parities(2) = 1  !E
 16887           parities(3) = -1 !B
 16888 
 16889 
 16890           if (BispectrumParams%do_primordial_bispectrum) then
 16891            fnl_bispectrum_ix = 1
 16892            nbispectra = 1
 16893            BispectrumNames(fnl_bispectrum_ix) = 'fnl'
 16894           else
 16895            fnl_bispectrum_ix = 0
 16896            nbispectra = 0
 16897           end if
 16898           if (BispectrumParams%do_lensing_bispectrum) then
 16899            lens_bispectrum_ix = fnl_bispectrum_ix+1
 16900            nbispectra = nbispectra+1
 16901            BispectrumNames(lens_bispectrum_ix) = 'lensing'
 16902           end if
 16903           if (nbispectra>max_bispectra) stop 'check max_bispectra'
 16904            
 16905           if (CP%InitPower%nn>1) stop 'Bispectrum: multiple initial power spectra not supported'         
 16906                 
 16907           nfields = BispectrumParams%nfields    
 16908                
 16909           if (lSampleBoost <50) stop 'Bispectrum assumes lSampleBoost = 50 (all L sampled)'     
 16910           
 16911           if (lens_bispectrum_approx = first_order_unlensed) file_tag = '_unlens'
 16912           
 16913           lmax = CTrans%ls%l(CTrans%ls%l0)      
 16914           if (CP%DoLensing) lmax = lmax_lensed
 16915           SampleL%l0 = 0
 16916           l1 = 1
 16917           do 
 16918             if (l1< = lmax_lensing_corrE) then
 16919              l1 = l1+1
 16920             else if (l1<120) then
 16921              l1 = l1+nint(7/AccuracyBoost)
 16922             else 
 16923              l1 = l1+nint(50/AccuracyBoost)
 16924             end if    
 16925             if (l1>lmax) then 
 16926               l1 = lmax
 16927             end if
 16928             if (BispectrumParams%Slice_Base_L>0 .and. SampleL%l0>0) then
 16929               !Make sure requested slice base is actually calculated   
 16930               if ( BispectrumParams%Slice_Base_L SampleL%l(SampleL%l0)) then
 16931                 SampleL%l0 = SampleL%l0 + 1
 16932                 SampleL%l(SampleL%l0) = BispectrumParams%Slice_Base_L                
 16933               end if
 16934             end if
 16935             SampleL%l0 = SampleL%l0 + 1
 16936            ! print *,l1          
 16937             SampleL%l(SampleL%l0) = l1
 16938             if (l1 = lmax) exit
 16939           end do  
 16940           
 16941           allocate(Bispectra(nfields,nfields,nfields,nbispectra))
 16942           do field1 = 1,nfields
 16943              do field2 = 1,nfields
 16944                   do field3 = 1,nfields
 16945                     !Only store l2,l3 that are non-zero, array size is approx
 16946                     do bispectrum_type = 1,nbispectra
 16947                     allocate(Bispectra(field1,field2,field3,bispectrum_type)%b((lmax*(lmax+1))/4,SampleL%l0))
 16948                     Bispectra(field1,field2,field3,bispectrum_type)%b = 0
 16949                     end do
 16950                   end do
 16951              end do
 16952           end do  
 16953 
 16954           if (BispectrumParams%do_lensing_bispectrum) then
 16955               
 16956               if (.not. CP%DoLensing) stop 'Must turn on lensing to get lensing bispectra'
 16957               print *,'Getting lensing reduced bispectra'
 16958               
 16959               allocate(CForLensing(lmax))
 16960 
 16961               CPhi = 0  
 16962               do i = lmin,lmax
 16963                  CPhi(1,i) = Cl_scalar(i,1,C_Phi)/real(i,dl)**4 * InternalScale
 16964                  !set correlations to zero where very small to avoid numerical issues
 16965                  if (i< = lmax_lensing_corrT) then
 16966                   CPhi(2,i) = Cl_scalar(i,1,C_PhiTemp) /real(i,dl)**3 * InternalScale
 16967                  end if
 16968                  if (i< = lmax_lensing_corrE) then
 16969                   CPhi(3,i) = Cl_scalar(i,1,C_PhiE) /real(i,dl)**3 * InternalScale
 16970                  end if
 16971                  tmp = i*(i+1)/(2*pi)
 16972                  CLForLensingIn(:,i) = CL_lensed(i,1,CT_Temp:CT_Cross) * InternalScale/tmp
 16973                 ! CForLensing(i)%C = 0
 16974                  CForLensing(i)%C(1,1) = CLForLensingIn(1,i)
 16975                  CForLensing(i)%C(1,2) = CLForLensingIn(4,i)
 16976                  CForLensing(i)%C(2,1) = CLForLensingIn(4,i)
 16977                  CForLensing(i)%C(2,2) = CLForLensingIn(2,i)
 16978                 ! CForLensing(i)%C(3,3) = CL_lensed(i,1,CT_B) * InternalScale/tmp
 16979               end do
 16980 
 16981 !ifdef FISHER             
 16982               allocate(SqueezedLensingKernel(nfields,nfields))
 16983               do field2 = 1,nfields
 16984                       do field3 = 1,nfields
 16985                         allocate(SqueezedLensingKernel(field2,field3)%b((lmax*(lmax+1))/4,SampleL%l0))
 16986                         SqueezedLensingKernel(field2,field3)%b = 0
 16987                       end do
 16988               end do  
 16989 !endif
 16990               if (DebugMsgs) starttime = GetTestTime()         
 16991                         
 16992           
 16993            !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDULE(STATIC,3) &
 16994            !$OMP PRIVATE(il1,l1,l2,l3,max_l,min_l,bix,bi_ix, tmp1,tmp2,tmp3), &
 16995            !$OMP PRIVATE(field1,field2,field3, Bispectrum, a3j,a3j2)
 16996 
 16997             do il1 = 1, SampleL%l0
 16998                 l1 = SampleL%l(il1)
 16999                 if (l1 > lmax_lensing_corrT) cycle !no exit in parallel loop
 17000                 tmp1 = l1*(l1+1)
 17001                 bi_ix = 0
 17002                 do l2 = max(lmin,l1), lmax 
 17003                   tmp2 = l2*(l2+1)
 17004                   min_l = max(abs(l1-l2),l2)
 17005                   if (mod(l1+l2+min_l,2)/= 0) then
 17006                      min_l = min_l+1
 17007                   end if 
 17008                   max_l = min(lmax,l1+l2) 
 17009                   bix = bi_ix
 17010                   a3j2(:,:,1) = 0.5
 17011                   if (nfields>1) then
 17012                     call GetThreeJs(a3j(abs(l2-l1)),l1,l2,0,0)   
 17013                     call GetThreeJs(a3j2(max(2,abs(l2-l1)),1,2),l1,l2,2,0)   
 17014                     call GetThreeJs(a3j2(max(2,abs(l2-l1)),2,2),l1,l2,0,2)   
 17015                     call GetThreeJs(a3j2(max(0,abs(l2-l1)),3,2),l1,l2,2,-2)                                       
 17016                     do l3 = min_l,max_l ,2
 17017                       a3j2(l3,:,2) = a3j2(l3,:,2)/a3j(l3)*0.5           
 17018                     end do
 17019                   end if
 17020                   do field1 = 1,nfields
 17021                      do field2 = 1,nfields
 17022                           do field3 = 1,nfields
 17023                             Bispectrum = > Bispectra(field1,field2,field3, lens_bispectrum_ix)
 17024                             bi_ix = bix   
 17025                              do l3 = min_l,max_l ,2
 17026                               bi_ix = bi_ix+1
 17027                               tmp3 = l3*(l3+1)
 17028                               !bispectrum is the reduced bispectrum 
 17029 !ifdef FISHER             
 17030                              if (field1 = 1) then  
 17031                               SqueezedLensingKernel(field2,field3)%b(bi_ix,il1) =  &
 17032                                (-tmp2+tmp3+tmp1)*(a3j2(l3,2,field2)*CForLensing(l3)%C(field2,field3)) + &       
 17033                                (-tmp3+tmp1+tmp2)*(a3j2(l3,2,field3)*CForLensing(l2)%C(field3,field2))
 17034                              end if
 17035 !endif            
 17036                      
 17037                               Bispectrum%b(bi_ix,il1) =  &
 17038                                  (-tmp1+tmp2+tmp3) *  &
 17039                                  (a3j2(l3,1,field1)*CPhi(1+field2,l2)*CForLensing(l3)%C(field1,field3) + &
 17040                                   a3j2(l3,3,field1)*CPhi(1+field3,l3)*CForLensing(l2)%C(field1,field2) ) + &       
 17041                                  (-tmp2+tmp3+tmp1)* &
 17042                                  (a3j2(l3,3,field2)*CPhi(1+field3,l3)*CForLensing(l1)%C(field2,field1) + &
 17043                                   a3j2(l3,2,field2)*CPhi(1+field1,l1)*CForLensing(l3)%C(field2,field3) ) + &       
 17044                                  (-tmp3+tmp1+tmp2)* &
 17045                                  (a3j2(l3,2,field3)*CPhi(1+field1,l1)*CForLensing(l2)%C(field3,field2) + &
 17046                                   a3j2(l3,1,field3)*CPhi(1+field2,l2)*CForLensing(l1)%C(field3,field1) )         
 17047                               
 17048                              end do
 17049                             
 17050                           end do
 17051                      end do
 17052                   end do  
 17053                   
 17054               end do
 17055              end do  
 17056             !$OMP END PARAllEl DO
 17057             if (DebugMsgs) print *,'Time for lensing:', GetTestTime()-starttime
 17058            
 17059             if (nfields = 1) BispectrumParams%do_parity_odd = .false.
 17060             
 17061             if (BispectrumParams%do_parity_odd) then 
 17062   
 17063               allocate(OddBispectra(12))
 17064               oddix = 0
 17065               do field1 = 1,3
 17066                  do field2 = 1,3
 17067                       do field3 = 1,3
 17068                         if (parities(field1)+parities(field2)+parities(field3)/= 1) cycle
 17069                         oddix = oddix+1
 17070                         !Only store l2,l3 that are non-zero, array size is approx
 17071                         allocate(OddBispectra(oddix)%b((lmax*(lmax+1))/4,SampleL%l0))
 17072                         OddBispectra(oddix)%b = 0
 17073                       end do
 17074                  end do
 17075               end do  
 17076   
 17077            !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDULE(STATIC,3) &
 17078            !$OMP PRIVATE(il1,l1,l2,l3,max_l,min_l,bix,bi_ix, tmp1,tmp2,tmp3), &
 17079            !$OMP PRIVATE(field1,field2,field3, Bispectrum, a3j2, oddix)
 17080 
 17081             do il1 = 1, SampleL%l0
 17082                 l1 = SampleL%l(il1)
 17083                 if (l1 > lmax_lensing_corrT) cycle !no exit in parallel loop
 17084                 tmp1 = l1*(l1+1)
 17085                 bi_ix = 0
 17086                 do l2 = max(lmin,l1), lmax 
 17087                   tmp2 = l2*(l2+1)
 17088                   min_l = max(abs(l1-l2),l2)
 17089                   if (mod(l1+l2+min_l,2)/= 1) then
 17090                      min_l = min_l+1
 17091                   end if 
 17092                   max_l = min(lmax,l1+l2) 
 17093                   bix = bi_ix
 17094                     
 17095                     a3j2(:,:,1) = 0.5
 17096                     call GetThreeJs(a3j2(max(2,abs(l2-l1)),1,2),l1,l2,2,0)   
 17097                     call GetThreeJs(a3j2(max(2,abs(l2-l1)),2,2),l1,l2,0,2)   
 17098                     call GetThreeJs(a3j2(max(0,abs(l2-l1)),3,2),l1,l2,2,-2)                                       
 17099                     do l3 = min_l,max_l ,2
 17100                      a3j2(l3,:,2) = a3j2(l3,:,2)*0.5*sqrt(real((2*L1+1)*(2*L2+1),dl)*(2*L3+1)/(3.1415926535*4))            
 17101                     end do
 17102 
 17103                     
 17104                   oddix = 0
 17105                   do field1 = 1,3
 17106                      do field2 = 1,3
 17107                          do field3 = 1,3
 17108                             !Only calculate terms with one B
 17109                             if (parities(field1)+parities(field2)+parities(field3)/= 1) cycle               
 17110                             oddix = oddix+1
 17111                             Bispectrum = > OddBispectra(oddix)
 17112                             bi_ix = bix   
 17113                              do l3 = min_l,max_l ,2
 17114                               bi_ix = bi_ix+1
 17115                               
 17116                               tmp3 = l3*(l3+1)
 17117                               !bispectrum the non-reduced bispectrum without the i
 17118                               if (parities(field1) = -1) then
 17119                                Bispectrum%b(bi_ix,il1) =  &
 17120                                  (-tmp1+tmp2+tmp3) *  &
 17121                                  (a3j2(l3,1,min(2,field1))*CPhi(1+field2,l2)*CForLensing(l3)%C(2,field3)  &
 17122                                   -a3j2(l3,3,min(2,field1))*CPhi(1+field3,l3)*CForLensing(l2)%C(2,field2) ) 
 17123                               elseif (parities(field2) = -1) then
 17124                                Bispectrum%b(bi_ix,il1) =  &
 17125                                    (-tmp2+tmp3+tmp1)* &
 17126                                  (-a3j2(l3,3,min(2,field2))*CPhi(1+field3,l3)*CForLensing(l1)%C(2,field1)  &
 17127                                   -a3j2(l3,2,min(2,field2))*CPhi(1+field1,l1)*CForLensing(l3)%C(2,field3) )  
 17128                               else if (parities(field3) = -1) then
 17129                                Bispectrum%b(bi_ix,il1) =  &
 17130                                  (-tmp3+tmp1+tmp2)* &
 17131                                  (-a3j2(l3,2,min(2,field3))*CPhi(1+field1,l1)*CForLensing(l2)%C(2,field2) + &
 17132                                   a3j2(l3,1,min(2,field3))*CPhi(1+field2,l2)*CForLensing(l1)%C(2,field1) )         
 17133                               end if
 17134                               
 17135                              end do
 17136                             
 17137                           end do
 17138                      end do
 17139                   end do  
 17140                   
 17141               end do
 17142              end do  
 17143             !$OMP END PARAllEl DO
 17144             end if
 17145 
 17146           end if
 17147 
 17148           if (BispectrumParams%do_primordial_bispectrum) then
 17149 
 17150           print *,'getting reduced local fnl bispectra'
 17151           
 17152           allocate(TransferPolFac(lmax))
 17153           do i = 2,lmax
 17154            TransferPolFac(i) = sqrt( real((i+1)*i,dl)*(i+2)*(i-1))
 17155           end do
 17156           
 17157           if (shape /= shape_local) stop 'Non-local shapes not working'
 17158     
 17159           if (shape = shape_local) then
 17160            n = 1
 17161            np = 1
 17162            npd = 0 !derivatives of function
 17163           else if (shape = shape_warm) then
 17164            n = 2
 17165            np = 3
 17166            npd = 0
 17167           else if (shape = shape_warm2) then
 17168            n = 1
 17169            np = 2
 17170            npd = 2
 17171           else
 17172            stop 'unknown shape'
 17173           end if        
 17174                          
 17175           allocate(ind(n))
 17176           allocate(indP(np))
 17177           
 17178           if (npd>0) then
 17179               call InitBesselDerivs(CTrans)
 17180               allocate(indPd(npd))
 17181           end if   
 17182         
 17183           if (shape = shape_warm) then
 17184            !Separable form is very unstable and unworkable probably
 17185            ind(1) = 0
 17186            ind(2) = 2
 17187            indP(1) = 0
 17188            indP(2) = 2           
 17189            indP(3) = -2
 17190           else if (shape = shape_warm2) then
 17191            ind(1) = 0
 17192            indP(1) = 0
 17193            indP(2) = -2
 17194            indPd(1) = 0
 17195            indPd(2) = -2           
 17196           else
 17197            ind(1) = 0
 17198            indP(1) = 0
 17199           end if
 17200           
 17201           test = 0
 17202           call Ranges_Nullify(TimeStepsNongauss)
 17203           call Ranges_Assign(TimeStepsNongauss,TimeSteps)
 17204           call Ranges_Add_delta(TimeStepsNongauss, -taurst*10*AccuracyBoost, taurst, dtaurec)
 17205           call Ranges_getArray(TimeStepsNongauss, .true.)
 17206      
 17207 !$        if (BispectrumParams%export_alpha_beta) call OMP_SET_NUM_THREADS(1)
 17208           if (BispectrumParams%export_alpha_beta) then 
 17209                !Note that all the points outside recombination are not really needed
 17210                !And these are for curvature perturbation, so do not include 3/5 factor
 17211                call CreateTxtFile(trim(output_root)//'_alpha.txt',100)
 17212                call CreateTxtFile(trim(output_root)//'_beta.txt',101)
 17213                call CreateTxtFile(trim(output_root)//'_alpha_beta_r.txt',102)
 17214           end if
 17215 
 17216           if (DebugMsgs) starttime = GetTestTime()
 17217          
 17218          !$OMP PARALLEL DO DEFAUlT(SHARED),SCHEDULE(STATIC,3) &
 17219          !$OMP PRIVATE(i,r,res,resP,resPd,res_l,resP_l,resPd_l,term,j), &
 17220          !$OMP PRIVATE(il1,l1,l2,l3,min_l,max_l,tmp,tmp1,tmp2,Bispectrum), &
 17221          !$OMP PRIVATE(bi_ix,bix,field1,field2,field3,field)
 17222 
 17223           do i = TimeStepsNongauss%npoints-1, 2,-1 
 17224           r = (CP%tau0-TimeStepsNongauss%points(i))
 17225 
 17226           allocate(res(CTrans%ls%l0,n,nfields))
 17227           allocate(resP(CTrans%ls%l0,np,nfields))
 17228           
 17229           allocate(res_l(1:CTrans%ls%l(CTrans%ls%l0),n,nfields))
 17230           allocate(resP_l(1:CTrans%ls%l(CTrans%ls%l0),np,nfields))
 17231           if (npd>0) then
 17232               allocate(resPd(CTrans%ls%l0,npd))
 17233               allocate(resPd_l(1:CTrans%ls%l(CTrans%ls%l0),npd))
 17234            end if   
 17235            
 17236             call NonGauss_l_r(CTrans, ind, indP,res, resP, nfields, r)
 17237             if (npd>0) call NonGauss_deriv_l_r(CTrans, indPd,resPd, r, dJl,dddJl)
 17238 
 17239             do field = 1,nfields
 17240              do j = 1,n
 17241               call InterpolateClArr(CTransScal%ls,res(1,j,field),res_l(lmin,j,field),CTransScal%ls%l0)
 17242              end do
 17243              do j = 1,np
 17244               call InterpolateClArr(CTransScal%ls,resP(1,j,field),resP_l(lmin,j,field),CTransScal%ls%l0)
 17245              end do
 17246             end do
 17247             deallocate(res,resP)
 17248  
 17249             if (BispectrumParams%export_alpha_beta) then
 17250              write(100,concat('(',lmax-lmin+1 ,'E15.5)')) res_l(lmin:lmax,1,1)
 17251              write(101,concat('(',lmax-lmin+1 ,'E15.5)')) resP_l(lmin:lmax,1,1)
 17252              write(102,'(1E15.5)') r
 17253             end if
 17254             
 17255             if (npd>0) then
 17256              do j = 1,npd
 17257                call InterpolateClArr(CTransScal%ls,resPd(1,j),resPd_l(lmin,j),CTransScal%ls%l0)
 17258              end do
 17259              deallocate(resPd)
 17260             end if
 17261             
 17262             term = r**2 * TimeStepsNongauss%dpoints(i) * (3./5) 
 17263 
 17264         
 17265  !Restrict to l1< = l2< =l3
 17266            do il1 = 1, SampleL%l0
 17267             l1 = SampleL%l(il1)
 17268             bi_ix = 0
 17269             do l2 = max(lmin,l1), lmax 
 17270               min_l = max(abs(l1-l2),l2)
 17271               if (mod(l1+l2+min_l,2)/= 0) then
 17272                  min_l = min_l+1
 17273               end if 
 17274               max_l = min(lmax,l1+l2) 
 17275               do field1 = 1,nfields
 17276                  do field2 = 1,nfields
 17277                      tmp1 = 2*term*(res_l(l1,1,field1)*resP_l(l2,1,field2) + &
 17278                                     res_l(l2,1,field2)*resP_l(l1,1,field1))
 17279                      tmp2 = 2*term*(resP_l(l1,1,field1)*resP_l(l2,1,field2))
 17280                   do field3 = 1,nfields
 17281                      Bispectrum = > Bispectra(field1,field2,field3,fnl_bispectrum_ix)
 17282                      bix = bi_ix    
 17283                      do l3 = min_l,max_l ,2
 17284                        bix = bix+1
 17285                        Bispectrum%b(bix,il1) = Bispectrum%b(bix,il1) + &
 17286                            (tmp1*resP_l(l3,1,field3) +   tmp2*res_l(l3,1,field3))
 17287                      end do
 17288                   end do
 17289                  end do
 17290               end do
 17291               bi_ix = bix    
 17292               
 17293             end do !l2
 17294            end do !il1
 17295 
 17296             deallocate(res_l,resP_l)           
 17297             if (npd>0) deallocate(resPd_l)            
 17298           end do !TimeStepsNongauss   
 17299  !$OMP END PARAllEl DO
 17300           if (BispectrumParams%export_alpha_beta) then
 17301             close(100)
 17302             close(101)
 17303             close(102)
 17304           end if
 17305           deallocate(TransferPolFac)
 17306           call Ranges_Free(TimeStepsNongauss)
 17307   
 17308           if (DebugMsgs) print *,'Time for fnl bispectrum:', GetTestTime()-starttime
 17309           
 17310           end if !DoPrimordial  
 17311    
 17312           if (BispectrumParams%Slice_Base_L>0 .or. BispectrumParams%FullOutputFile/= '') then
 17313           !write out slice in (muK)^3 units
 17314            Bscale = (COBE_CMBTemp*1d6)**3/InternalScale**2;
 17315            do bispectrum_type = 1,nbispectra
 17316             if (BispectrumParams%Slice_Base_L>0) then
 17317              do idelta = 1,BispectrumParams%ndelta
 17318              if (mod(BispectrumParams%Slice_Base_L + BispectrumParams%deltas(idelta),2) = 1 &
 17319                       .and. bispectrum_type/= lens_bispectrum_ix) cycle
 17320              call CreateTxtFile(concat(trim(output_root)//'bispectrum_'//trim(BispectrumNames(bispectrum_type))//'_base_', &
 17321                             BispectrumParams%Slice_Base_L,'_delta_',BispectrumParams%deltas(idelta),trim(file_tag)//'.dat'),&
 17322                             nbispectra +BispectrumParams%ndelta*(bispectrum_type-1)+idelta)
 17323              end do
 17324             end if                          
 17325             if (BispectrumParams%FullOutputFile/= '') then
 17326              call CreateTxtFile(concat(output_root,BispectrumParams%FullOutputFile, &
 17327                   '_', BispectrumNames(bispectrum_type), file_tag, '.dat'),bispectrum_type)
 17328             end if                
 17329            end do
 17330            do il1 = 1, SampleL%l0
 17331             l1 = SampleL%l(il1)
 17332             bi_ix = 0
 17333             do l2 = max(lmin,l1), lmax 
 17334               min_l = max(abs(l1-l2),l2)
 17335               if (mod(l1+l2+min_l,2)/= 0) then
 17336                  min_l = min_l+1
 17337               end if 
 17338               max_l = min(lmax,l1+l2) 
 17339               do l3 = min_l, max_l ,2
 17340                   bi_ix = bi_ix+1
 17341                   if (l1 = BispectrumParams%Slice_Base_L &
 17342                    .and. any(l3-l2 = BispectrumParams%deltas(1:BispectrumParams%ndelta))) then
 17343                   !Particular slice
 17344                    idelta = IndexOf(l3-l2,BispectrumParams%deltas,BispectrumParams%ndelta)
 17345                    do bispectrum_type = 1,nbispectra
 17346                     fileid = nbispectra +BispectrumParams%ndelta*(bispectrum_type-1)+idelta
 17347                     write (fileid,'(1I5)', advance = 'NO') L2
 17348                     do field1 = 1,nfields
 17349                      do field2 = 1,nfields
 17350                        do field3 = 1,nfields
 17351                            write(fileid,'(1E15.5)', advance = 'NO') &
 17352                                    Bispectra(field1,field2,field3,bispectrum_type)%b(bi_ix,il1)*Bscale
 17353                        end do
 17354                       end do
 17355                      end do   
 17356                     write (fileid,'(a)') ''                            
 17357                    end do
 17358                   end if !slice
 17359                   if (BispectrumParams%FullOutputFile/= '') then
 17360                     if (BispectrumParams%SparseFullOutput .and. .not. any( SampleL%l(1:SampleL%l0) = L2) .or. &
 17361                           l1 > 30 .and. mod(l3-min_l,10)/= 0 .and. l3 /= max_l) cycle
 17362 
 17363                      do bispectrum_type = 1,nbispectra
 17364                        if (bispectrum_type = lens_bispectrum_ix .and. L1 > lmax_lensing_corrT) cycle
 17365                        write(bispectrum_type,'(3I5)', advance = 'NO') L1, L2, L3
 17366                        do field1 = 1,nfields
 17367                         do field2 = 1,nfields
 17368                          do field3 = 1,nfields
 17369                          write(bispectrum_type,'(1E14.5)', advance = 'NO') &
 17370                                  Bispectra(field1,field2,field3,bispectrum_type)%b(bi_ix,il1)*Bscale
 17371                         end do
 17372                        end do
 17373                       end do  
 17374                       write (bispectrum_type,'(a)') ''       
 17375                      end do
 17376                   end if
 17377                    
 17378               end do    
 17379             end do          
 17380           end do
 17381           if (BispectrumParams%do_parity_odd) then          
 17382               do il1 = 1, SampleL%l0
 17383                 l1 = SampleL%l(il1)
 17384                 bi_ix = 0
 17385                 do l2 = max(lmin,l1), lmax 
 17386                   min_l = max(abs(l1-l2),l2)
 17387                   if (mod(l1+l2+min_l,2)/= 1) then
 17388                      min_l = min_l+1
 17389                   end if 
 17390                   max_l = min(lmax,l1+l2) 
 17391                   do l3 = min_l, max_l ,2
 17392                       bi_ix = bi_ix+1
 17393                       if (l1 = BispectrumParams%Slice_Base_L &
 17394                        .and. any(l3-l2 = BispectrumParams%deltas(1:BispectrumParams%ndelta))) then
 17395                       !Particular slice
 17396                        idelta = IndexOf(l3-l2,BispectrumParams%deltas,BispectrumParams%ndelta)
 17397                        do bispectrum_type = 1,nbispectra
 17398                         if (bispectrum_type/= lens_bispectrum_ix) cycle
 17399                         fileid = nbispectra +BispectrumParams%ndelta*(bispectrum_type-1)+idelta
 17400                         write (fileid,'(1I5)', advance = 'NO') L2
 17401                         oddix = 0
 17402                         do field1 = 1,3
 17403                          do field2 = 1,3
 17404                            do field3 = 1,3
 17405                               if (parities(field1)+parities(field2)+parities(field3)/= 1) cycle
 17406                               oddix = oddix+1
 17407                               write(fileid,'(1E15.5)', advance = 'NO') OddBispectra(oddix)%b(bi_ix,il1)*Bscale
 17408                            end do
 17409                           end do
 17410                          end do   
 17411                         write (fileid,'(a)') ''                            
 17412                        end do
 17413                       end if !slice
 17414                      
 17415                   end do    
 17416                 end do          
 17417               end do
 17418          end if
 17419           
 17420           do bispectrum_type = 1,nbispectra
 17421             if (BispectrumParams%Slice_Base_L>0) then
 17422              do idelta = 1,BispectrumParams%ndelta
 17423               if (mod(BispectrumParams%Slice_Base_L + BispectrumParams%deltas(idelta),2) = 1 &
 17424                       .and. bispectrum_type/= lens_bispectrum_ix) cycle
 17425               close(nbispectra +BispectrumParams%ndelta*(bispectrum_type-1)+idelta)
 17426              end do
 17427             end if
 17428             if (BispectrumParams%FullOutputFile/= '') close(bispectrum_type)                            
 17429           end do
 17430    
 17431           end if
 17432 
 17433 !ifdef FISHER
 17434           if (BispectrumParams%DoFisher) then
 17435  !Get stuff for Fisher etc.
 17436  
 17437           print *,'Getting Fisher for lmax = ', lmax
 17438          
 17439           Noise = BispectrumParams%FisherNoise/ (COBE_CMBTemp*1e6)**2  !Planckish, dimensionless units  
 17440           NoiseP = BispectrumParams%FisherNoisePol/ (COBE_CMBTemp*1e6)**2 
 17441              
 17442           do i = lmin,lmax
 17443              if (CP%DoLensing) then
 17444               cl(:,i) = CL_lensed(i,1,CT_Temp:CT_Cross)
 17445              else
 17446               cl(1,i) = CL_Scalar(i,1,C_Temp)
 17447               cl(2,i) = CL_Scalar(i,1,C_E)
 17448               cl(4,i) = CL_Scalar(i,1,C_Cross)
 17449               cl(3,i) = 0              
 17450              end if 
 17451           end do
 17452           if (.false.) then
 17453               call OpenTxtFile('CAMBdefault_lensedCls.dat',3)
 17454               do i = lmin,lmax
 17455                !Assume T,E,B,X ordering
 17456                read(3,*) j, cl(1:4,i)
 17457                if (j0) then
 17464            file_tag = concat(file_tag,'_noise')
 17465           end if
 17466           xlc = 180*sqrt(8.*log(2.))/3.14159
 17467           sigma2 = (BispectrumParams%FisherNoiseFwhmArcmin/60/xlc)**2
 17468           allocate(InvC(lmax))
 17469           do l1 = lmin, lmax
 17470              tmp = l1*(l1+1)/(2*pi)
 17471              Cl(1,l1) = Cl(1,l1)/tmp + Noise*exp(l1*(l1+1)*sigma2)
 17472              Cl(2:3,l1) = Cl(2:3,l1)/tmp + NoiseP*exp(l1*(l1+1)*sigma2)
 17473              Cl(4,l1) = Cl(4,l1)/tmp  
 17474              allocate(InvC(l1)%C(nfields,nfields))
 17475              if (nfields > 2) stop 'Not implemented nfields>2 in detail'
 17476              if (nfields = 1) then
 17477               InvC(l1)%C(1,1) = (2*l1+1)/cl(1,l1)/InternalScale
 17478              else 
 17479               InvC(l1)%C(1,1) = cl(2,l1)
 17480               InvC(l1)%C(1,2) = -cl(4,l1)
 17481               InvC(l1)%C(2,1) = -cl(4,l1)
 17482               InvC(l1)%C(2,2) = cl(1,l1)              
 17483               InvC(l1)%C = InvC(l1)%C * (2*l1+1)/(cl(1,l1)*cl(2,l1)-cl(4,l1)**2)/InternalScale
 17484              end if
 17485           end do
 17486    
 17487         if (debugMsgs) starttime = GetTestTime() 
 17488         allocate(ifish_contribs(SampleL%l0,nbispectra,nbispectra,nfields,nfields) )
 17489         !This loop is just in case want to plot out lmax dependence
 17490         do lmaxcuti = SampleL%l0, SampleL%l0
 17491      !    call CreateTxtFile('TE-Planck-LensFish.txt',20)
 17492      !   do lmaxcuti = 1, SampleL%l0
 17493      !   if (SampleL%l(lmaxcuti) < 425) cycle
 17494          
 17495           lmax = SampleL%l(lmaxcuti)    
 17496             
 17497           ifish_contribs = 0
 17498           lstart = 2 !lmin
 17499          !$OMP PARAllEl DO DEFAUlT(SHARED),SCHEDULE(STATIC,3) &
 17500          !$OMP PRIVATE(il1,l1,l2,l3,fish_l1,bi_ix,min_l,max_l,a3j_00,a3j), &
 17501          !$OMP PRIVATE(Bispectrum,Bispectrum2,minl2,bix,tmp,tmp1,tmp2,tmpf), &
 17502          !$OMP PRIVATE(field1,field2,field3,f1,f2,f3,bispectrum_type,bispectrum_type2)
 17503 
 17504           do il1 = 1,  lmaxcuti !!!SampleL%l0
 17505             allocate(fish_l1(nbispectra,nbispectra,nfields,nfields)) !last indices are field1,f1
 17506             l1 = SampleL%l(il1)
 17507             if (l1< lstart) cycle
 17508             fish_l1 = 0
 17509             bi_ix = 0
 17510             do l2 = l1,lmax
 17511               if (l2< lstart) cycle
 17512               min_l = max(lstart,max(abs(l1-l2),l2))
 17513               if (mod(l1+l2+min_l,2)/= 0) then
 17514                  min_l = min_l+1
 17515               end if 
 17516               max_l = min(lmax,l1+l2) 
 17517               call GetThreeJs(a3j(abs(l2-l1)),l1,l2,0,0)
 17518               do l3 = min_l,max_l ,2    
 17519                 a3j_00(l3) = a3j(l3)**2
 17520               end do
 17521               
 17522               tmp1 = 1/(4*pi)  !(2l+1) factors included in InvC
 17523               minl2 = min_l
 17524               bix = bi_ix
 17525                do field1 = 1,nfields
 17526                 do f1 = 1,nfields
 17527                  tmpf(1) = InvC(l1)%C(field1,f1)*tmp1
 17528                  do field2 = 1,nfields
 17529                    do f2 = 1,nfields
 17530                     tmpf(2) = InvC(l2)%C(field2,f2)*tmpf(1)
 17531                      do field3 = 1,nfields
 17532                       do bispectrum_type = 1,nbispectra
 17533                       if (bispectrum_type = lens_bispectrum_ix) then
 17534                         Bispectrum = >SqueezedLensingKernel(field2,field3)
 17535                       else
 17536                         Bispectrum = >bispectra(field1,field2,field3,bispectrum_type)
 17537                       end if
 17538                       do f3 = 1,nfields
 17539                         
 17540                         do bispectrum_type2 = bispectrum_type,nbispectra
 17541                         if (bispectrum_type2 = lens_bispectrum_ix) then
 17542                           Bispectrum2 = >SqueezedLensingKernel(f2,f3)
 17543                         else
 17544                           Bispectrum2 = >Bispectra(f1,f2,f3,bispectrum_type2)
 17545                         end if
 17546    
 17547           
 17548                         min_l = minl2          
 17549                         bi_ix = bix
 17550                         if (min_l = l2) then
 17551                             !Symmetry factors
 17552                              bi_ix = bi_ix+1
 17553                              l3 = l2
 17554                              if (l2 = l1) then
 17555                               !l1 = l2 =l3
 17556                               tmp = Bispectrum%b(bi_ix,il1)*tmpf(2)*Bispectrum2%b(bi_ix,il1) &
 17557                                       *InvC(l3)%C(field3,f3)*a3j_00(l3)/6  
 17558                              else
 17559                               !l3 = l2 (l3 = l1<>l2 can't happen because l1< = l2<=l3)
 17560                               tmp = Bispectrum%b(bi_ix,il1)*tmpf(2)*Bispectrum2%b(bi_ix,il1) &
 17561                                       * InvC(l3)%C(field3,f3)*a3j_00(l3)/2 
 17562                              end if
 17563                              min_l = min_l+2
 17564                         else
 17565                          tmp = 0
 17566                         end if
 17567                         tmp2 = 0  
 17568                         do l3 = min_l,max_l ,2    
 17569                             bi_ix = bi_ix+1
 17570                             tmp2 = tmp2 + Bispectrum%b(bi_ix,il1)*Bispectrum2%b(bi_ix,il1) &
 17571                                    * InvC(l3)%C(field3,f3)*a3j_00(l3)
 17572                         end do  
 17573                         if (l2 = l1) then
 17574                            tmp2 = tmp2*tmpf(2)/2
 17575                           else
 17576                            tmp2 = tmp2*tmpf(2)     
 17577                         end if     
 17578                         fish_l1(bispectrum_type,bispectrum_type2,field1,f1) = &
 17579                          fish_l1(bispectrum_type,bispectrum_type2,field1,f1)+(tmp+tmp2) 
 17580                         
 17581                         end do !bispectrum_type2
 17582    
 17583                       end do
 17584                       end do !bispectrum_type
 17585                      end do !field3
 17586                     end do !f2                   
 17587                   end do !field2
 17588                  end do !f1
 17589                end do  !field1
 17590 
 17591             end do !l2
 17592 
 17593             ifish_contribs(il1,:,:,:,:) = fish_l1(1:nbispectra,1:nbispectra,:,:) /InternalScale
 17594             deallocate(fish_L1) 
 17595  
 17596           end do
 17597          !$OMP END PARAllEl DO
 17598           if (DebugMsgs) print *,'Time for Fisher:', GetTestTime()-starttime
 17599     
 17600           
 17601           allocate(fish_contribs(lmin:CTrans%ls%l(CTrans%ls%l0),nfields,nfields))
 17602           allocate(Fisher(nbispectra,nbispectra))
 17603           allocate(tmpFisher(nbispectra,nbispectra))
 17604           allocate(Fisher_L1(lmin:CTrans%ls%l(CTrans%ls%l0),nbispectra*nfields,nbispectra*nfields))
 17605           
 17606           do bispectrum_type = 1,nbispectra
 17607            do bispectrum_type2 = bispectrum_type,nbispectra
 17608 
 17609            fish_contribs = 0 
 17610            do field1 = 1,nfields
 17611             do f1 = 1,nfields
 17612             call InterpolateClArr(SampleL,ifish_contribs(1,bispectrum_type,bispectrum_type2,field1,f1), &
 17613                         fish_contribs(lmin,field1,f1),lmaxcuti)  !SampleL%l0)
 17614             end do
 17615            end do          
 17616            Fisher(bispectrum_type,bispectrum_type2) = 0
 17617            do i = lmin, CTrans%ls%l(CTrans%ls%l0)
 17618             do field1 = 1,nfields
 17619              do f1 = 1,nfields
 17620               Fisher_L1(i,(bispectrum_type-1)*nfields+field1,(bispectrum_type2-1)*nfields+f1) = fish_contribs(i,field1,f1)
 17621               Fisher_L1(i,(bispectrum_type2-1)*nfields+f1,(bispectrum_type-1)*nfields+field1) = fish_contribs(i,field1,f1)
 17622               tmp = fish_contribs(i,field1,f1)
 17623               if (bispectrum_type = lens_bispectrum_ix) then
 17624                tmp = tmp * CPhi(1+field1,i)
 17625               end if
 17626               if (bispectrum_type2 = lens_bispectrum_ix) then
 17627                tmp = tmp * CPhi(1+f1,i)
 17628               end if              
 17629               Fisher(bispectrum_type,bispectrum_type2) = Fisher(bispectrum_type,bispectrum_type2)+ tmp
 17630              end do
 17631             end do 
 17632            end do
 17633            Fisher(bispectrum_type2,bispectrum_type) = Fisher(bispectrum_type,bispectrum_type2) 
 17634            
 17635            print *,'Zero-signal Fisher ',trim(BispectrumNames(bispectrum_type))//'-'//trim(BispectrumNames(bispectrum_type2)), &
 17636                       ':', Fisher(bispectrum_type2,bispectrum_type) 
 17637            
 17638 !!!! contribution of lensing to the fnl variance for temperature:
 17639 !           if (bispectrum_type = fnl_bispectrum_ix .and. bispectrum_type2 = fnl_bispectrum_ix ) then 
 17640 !              fish_contribs_sig = 0
 17641 !              tmpArr = 0
 17642 !              call InterpolateClArr(SampleL,ifish_contribs(1,1,2,1,1),tmpArr(lmin),lmaxcuti) 
 17643 !               do i = lmin, lmax_lensing_corrT
 17644 !               if (CPhi(1+1,i)/= 0) then
 17645 !                 fish_contribs_sig(i) = &
 17646 !                  tmpArr(i)**2*(1+ CPhi(1,i)*CForLensing(i)%C(1,1)/(CPhi(1+1,i)*CPhi(1+1,i)))/(2*i+1)
 17647 !               end if
 17648 !              end do
 17649 !              print *,'signal contribution to fnl variance', sum(fish_contribs_sig)/Fisher(bispectrum_type,bispectrum_type2)**2
 17650 !           end if
 17651  !!! same with polarization
 17652 !  if (bispectrum_type = fnl_bispectrum_ix .and. bispectrum_type2 = lens_bispectrum_ix ) then 
 17653 !            fish_contribs_sig = 0
 17654 !            do i = lmin, lmax_lensing_corrT
 17655 !             corrsize = count(CPhi(2:1+nfields,i)/= 0)
 17656 !             allocate(fish_L_ij(corrsize,corrsize))
 17657 !             allocate(fish_L_noise(corrsize,corrsize))
 17658 !             fish_L_ij = 0 
 17659 !             ix1 = 0
 17660 !             do field1 = 1,nfields
 17661 !              ix1 = ix1+1
 17662 !              ix2 = 0
 17663 !              do f1 = 1,nfields
 17664 !                 ix2 = ix2+1
 17665 !                 fish_L_noise(ix1,ix2) = fish_contribs(i,field1, f1)
 17666 !                 fish_L_ij(ix1,ix2) = (CPhi(1+f1,i)*CPhi(1+field1,i) + &
 17667 !                     CPhi(1,i)*CForLensing(i)%C(field1,f1) )/(2*i+1)
 17668 !              end do
 17669 !             end do 
 17670 !             fish_L_ij = matmul(matmul((fish_L_noise(:,:)),fish_L_ij),transpose(fish_L_noise(:,:)))
 17671 !             fish_contribs_sig(i) = sum(fish_L_ij)!Matrix_trace(fish_L_ij)
 17672 !             deallocate(fish_L_ij)
 17673 !             deallocate(fish_L_noise)
 17674 !            end do
 17675 !            print *,'fnl signal factor', sum(fish_contribs_sig)
 17676 !       end if                 
 17677             
 17678 
 17679            if (bispectrum_type = lens_bispectrum_ix .and. bispectrum_type2 = lens_bispectrum_ix ) then 
 17680             print *,'doing signal part of the lensing variance'
 17681             fish_contribs_sig = 0
 17682             do i = lmin, lmax_lensing_corrT
 17683              corrsize = count(CPhi(2:1+nfields,i)/= 0)
 17684              allocate(fish_L_ij(corrsize,corrsize))
 17685              allocate(fish_L_noise(corrsize,corrsize))
 17686              fish_L_ij = 0 
 17687              ix1 = 0
 17688              do field1 = 1,nfields
 17689               if (CPhi(1+field1,i)/= 0) then
 17690               ix1 = ix1+1
 17691               ix2 = 0
 17692               do f1 = 1,nfields
 17693                if (CPhi(1+f1,i)/= 0) then
 17694                  ix2 = ix2+1
 17695                  fish_L_noise(ix1,ix2) = fish_contribs(i,field1, f1)*CPhi(1+f1,i)*CPhi(1+field1,i)
 17696                  fish_L_ij(ix1,ix2) =  (1 + &
 17697                      CPhi(1,i)*CForLensing(i)%C(field1,f1)/(CPhi(1+f1,i)*CPhi(1+field1,i)))/(2*i+1)
 17698 
 17699                end if
 17700               end do
 17701               end if
 17702              end do 
 17703               call Matrix_Inverse(fish_L_noise)
 17704               fish_L_ij = fish_L_ij+fish_L_noise
 17705               call Matrix_Inverse(fish_L_ij) 
 17706               fish_contribs_sig(i) = sum(fish_L_ij)  
 17707              deallocate(fish_L_ij)
 17708              deallocate(fish_L_noise)
 17709             end do
 17710             print *,'Lensing Fisher including lensing variance ', sum(fish_contribs_sig)
 17711     
 17712            end if
 17713            
 17714            end do
 17715           end do
 17716          deallocate(fish_contribs)
 17717       
 17718           print *, 'Results assuming zero fiducial bispectra' 
 17719           do bispectrum_type = 1,nbispectra
 17720            print *,trim(IntToStr(bispectrum_type))//'-'//trim(BispectrumNames(bispectrum_type)), &
 17721                       ': 1/sqrt(F_ii) = ',1/sqrt(Fisher(bispectrum_type,bispectrum_type))
 17722           end do
 17723 
 17724           do bispectrum_type = 1,nbispectra
 17725            do bispectrum_type2 = bispectrum_type+1,nbispectra
 17726             bias = Fisher(bispectrum_type2,bispectrum_type)/Fisher(bispectrum_type,bispectrum_type)
 17727             print *,'Bias of ',trim(BispectrumNames(bispectrum_type2)),' on ', &
 17728              trim(BispectrumNames(bispectrum_type)),':', bias 
 17729            end do
 17730 !           if (bispectrum_type = 1) write(1,concat('(1I10,',nbispectra,'E15.5)')) lmax, Fisher(1,1), &
 17731 !                                  Fisher(2:nbispectra,1)/Fisher(1,1)
 17732           end do 
 17733           
 17734           tmpFisher = Fisher
 17735           do bispectrum_type = 1,nbispectra
 17736             tmp = sqrt(tmpFisher(bispectrum_type,bispectrum_type))
 17737             tmpFisher(bispectrum_type,:) = tmpFisher(bispectrum_type,:)/tmp
 17738             tmpFisher(:,bispectrum_type) = tmpFisher(:,bispectrum_type)/tmp
 17739           end do     
 17740           if (nbispectra>1) then
 17741            print *,'Zero-signal Bispectrum correlation matrix:'
 17742            do bispectrum_type = 1,nbispectra
 17743             print *,tmpFisher(:,bispectrum_type)
 17744            end do
 17745          
 17746           if (nbispectra > 1) then
 17747               allocate(OptimalFisher(nbispectra,nbispectra))
 17748               allocate(tmpBigFisher(nbispectra*nfields,nbispectra*nfields))
 17749 !              allocate(diag(nbispectra*nfields))
 17750               OptimalFisher = 0
 17751               do i = lmin, lmax  
 17752                  tmpBigFisher = Fisher_L1(i,:,:)
 17753                  if (lens_bispectrum_ix/= 0 .and. i< = lmax_lensing_corrT) then
 17754 
 17755                      call Matrix_Inverse(tmpBigFisher)
 17756                      do field1 = 1,nfields
 17757                        do field2 = 1, nfields
 17758                         tmpBigFisher((lens_bispectrum_ix-1)*nfields+field1, &
 17759                                      (lens_bispectrum_ix-1)*nfields+field2) = &
 17760                               tmpBigFisher((lens_bispectrum_ix-1)*nfields+field1, &
 17761                                      (lens_bispectrum_ix-1)*nfields+field2) + &
 17762                        (CPhi(1+field1,i)*CPhi(1+field2,i) + CPhi(1,i)*CForLensing(i)%C(field1,field2))/(2*i+1)
 17763                        end do
 17764                      end do  
 17765                      call Matrix_Inverse(tmpBigFisher)
 17766                      
 17767                  end if
 17768                            
 17769                  do field1 = 1,nfields
 17770                   do field2 = 1,nfields
 17771                    do bispectrum_type = 1,nbispectra
 17772                      do bispectrum_type2 = 1,nbispectra
 17773                        if (bispectrum_type = lens_bispectrum_ix) then
 17774                         tmp = CPhi(1+field1,i)
 17775                        else
 17776                         tmp = 1 
 17777                        end if
 17778                        if (bispectrum_type2 = lens_bispectrum_ix) then
 17779                         tmp = tmp*CPhi(1+field2,i)
 17780                        end if
 17781                        OptimalFisher(bispectrum_type,bispectrum_type2) = OptimalFisher(bispectrum_type,bispectrum_type2)+ &
 17782                          tmp*tmpBigFisher((bispectrum_type-1)*nfields+field1,(bispectrum_type2-1)*nfields+field2)
 17783                      end do
 17784                    end do
 17785                   end do
 17786                  end do      
 17787               end do
 17788               deallocate(tmpBigFisher)
 17789           end if
 17790 
 17791           do bispectrum_type = 1,nbispectra
 17792            print *,'Optimal Inc. lensing:', trim(IntToStr(bispectrum_type))//'-'//trim(BispectrumNames(bispectrum_type)), &
 17793                       ': 1/sqrt(F_ii) = ',1/sqrt(OptimalFisher(bispectrum_type,bispectrum_type))
 17794           end do
 17795           tmpFisher = OptimalFisher
 17796           call Matrix_Inverse(tmpFIsher)
 17797           do bispectrum_type = 1,nbispectra
 17798            print *,'Optimal Inc. lensing:', trim(IntToStr(bispectrum_type))//'-'//trim(BispectrumNames(bispectrum_type)), &
 17799                       ': Cov_ii = ', sqrt(tmpFIsher(bispectrum_type,bispectrum_type))
 17800           end do
 17801           tmpFisher = OptimalFisher
 17802           do bispectrum_type = 1,nbispectra
 17803             tmp = sqrt(tmpFisher(bispectrum_type,bispectrum_type))
 17804             tmpFisher(bispectrum_type,:) = tmpFisher(bispectrum_type,:)/tmp
 17805             tmpFisher(:,bispectrum_type) = tmpFisher(:,bispectrum_type)/tmp
 17806           end do     
 17807            print *,'Optimal Bispectrum correlation matrix with lensing variance:'
 17808            do bispectrum_type = 1,nbispectra
 17809             print *,tmpFisher(:,bispectrum_type)
 17810            end do
 17811           end if
 17812           
 17813           deallocate(Fisher, tmpFisher)
 17814  
 17815           end do
 17816   
 17817           deallocate(ifish_contribs)
 17818           deallocate(InvC)
 17819 
 17820           end if !DoFIsher
 17821 !else
 17822           if (BispectrumParams%DoFisher) stop 'compile with FISHER defined'
 17823 !endif                    
 17824           
 17825           !Tidy up a bit
 17826           do field1 = 1,nfields
 17827              do field2 = 1,nfields
 17828                   do field3 = 1,nfields
 17829                     do bispectrum_type = 1,nbispectra
 17830                     deallocate(Bispectra(field1,field2,field3,bispectrum_type)%b)
 17831                     end do
 17832                   end do
 17833              end do
 17834           end do  
 17835           deallocate(Bispectra)   
 17836           if (allocated(CForLensing)) deallocate(CForLensing)
 17837 
 17838          if (allocated(OddBispectra)) then 
 17839               oddix = 0
 17840               do field1 = 1,3
 17841                  do field2 = 1,3
 17842                       do field3 = 1,3
 17843                         if (parities(field1)+parities(field2)+parities(field3)/= 1) cycle
 17844                         oddix = oddix+1
 17845                         deallocate(OddBispectra(oddix)%b)
 17846                       end do
 17847                  end do
 17848               end do  
 17849            deallocate(OddBispectra)
 17850           end if   
 17851           
 17852         end subroutine GetBispectrum
 17853 
 17854 
 17855 !not needed for local NG
 17856         subroutine NonGauss_deriv_l_r(CTrans, indP,resP, r, dJl, dddJl)
 17857         !As above, but integral against derivative of bessel function to get derivative of function
 17858           Type(ClTransferData) :: CTrans
 17859           real(dl), intent(in) :: dJl(BessRanges%npoints,CTrans%ls%l0), dddJl(BessRanges%npoints,CTrans%ls%l0)        
 17860           integer, intent(in) :: indP(:) 
 17861           real(dl) resP(CTrans%ls%l0,size(indP))
 17862           real(dl), intent(in) :: r
 17863           integer q_ix, j, bes_ix, i
 17864           integer nP, ellmax
 17865          real(dl) xf , dJ_l, fac, a2,  k, dlnk, term, P        
 17866      
 17867           nP = size(indP)          
 17868           resP = 0
 17869           do q_ix = 1, CTrans%q%npoints 
 17870             
 17871             k = CTrans%q%points(q_ix)
 17872             xf = k*r  !kr
 17873             bes_ix = Ranges_indexOf(BessRanges,xf)
 17874             fac = BessRanges%points(bes_ix+1)-BessRanges%points(bes_ix)
 17875             a2 = (BessRanges%points(bes_ix+1)-xf)/fac
 17876             fac = fac**2*a2/6
 17877             dlnk = CTrans%q%dpoints(q_ix) /k
 17878             P = ScalarPower(k, 1)  !!only first index for now
 17879             ellmax = max(xf/(1-xlimfrac), xf + xlimmin) * AccuracyBoost
 17880             
 17881             do j = 1,CTrans%ls%l0
 17882              if (CTrans%ls%l(j) < = ellmax) then
 17883              dJ_l = a2*djl(bes_ix,j)+(1-a2)*(djl(bes_ix+1,j) - ((a2+1) &
 17884                         *dddjl(bes_ix,j)+(2-a2)*dddjl(bes_ix+1,j))* fac) !cubic spline
 17885      
 17886              term = CTrans%Delta_p_l_k(1,j,q_ix)*dJ_l*dlnk *k  
 17887              do i = 1,nP
 17888               resP(j,i) = resP(j,i) + term * k**indP(i) * P
 17889              end do
 17890             
 17891             end if
 17892            end do
 17893          end do
 17894          resP = resP * fourpi
 17895                
 17896         end subroutine NonGauss_deriv_l_r
 17897 
 17898        subroutine Bispectrum_SetDefParams(B)
 17899        Type(TBispectrumParams) :: B
 17900        
 17901           B%nfields = 2
 17902           B%Slice_Base_L = 0
 17903           B%ndelta = 0
 17904           B%DoFisher = .true.
 17905           B%FisherNoise = 0 !2d-4 !Planckish
 17906           B%FisherNoisePol = 4*B%FisherNoise
 17907           B%FisherNoiseFwhmArcmin = 7
 17908           B%FullOutputFile = '' !quite large
 17909           B%SparseFullOutput = .false.
 17910           B%do_lensing_bispectrum = .true.
 17911           B%do_primordial_bispectrum = .true.
 17912           B%do_parity_odd = .false.
 17913           B%export_alpha_beta = .false.
 17914        
 17915        end subroutine Bispectrum_SetDefParams      
 17916        
 17917                 
 17918        subroutine Bispectrum_ReadParams(B, Ini, outroot)
 17919           use IniFile
 17920           Type(TBispectrumParams) :: B
 17921           character(LEN = *), intent(in) :: outroot
 17922           Type(TIniFile) :: Ini
 17923           integer i
 17924           
 17925           call Bispectrum_SetDefParams(B)
 17926    
 17927           B%do_lensing_bispectrum = Ini_Read_Logical_File(Ini,'do_lensing_bispectrum',.false.)
 17928           B%do_primordial_bispectrum = Ini_Read_Logical_File(Ini,'do_primordial_bispectrum',.false.)
 17929        
 17930           do_bispectrum = B%do_lensing_bispectrum .or. B%do_primordial_bispectrum
 17931           
 17932           if (do_bispectrum) then
 17933           
 17934           output_root = outroot
 17935           
 17936           B%nfields = Ini_Read_Int_File(Ini,'bispectrum_nfields',B%nfields)
 17937           if (B%nfields /= 2 .and. B%nfields/= 1) stop 'Bispectrum: nfields = 1 for T only or 2 for polarization'
 17938           B%do_parity_odd = Ini_Read_Logical_File(Ini,'do_parity_odd',.false.)
 17939           if (B%do_parity_odd .and. (.not.  B%do_lensing_bispectrum .or. B%nfields = 1)) then
 17940              B%do_parity_odd = .false.
 17941              write(*,*) 'Ignoring do_parity_odd since do_lensing_bispectrum = F or no polarization'
 17942           end if   
 17943           B%Slice_Base_L = Ini_Read_Int_File(Ini,'bispectrum_slice_base_L',B%Slice_Base_L)
 17944           if (B%Slice_Base_L>0) then
 17945            B%ndelta = Ini_Read_Int_File(Ini,'bispectrum_ndelta',B%ndelta)
 17946            if (B%ndelta > max_bispectrum_deltas) stop 'Bispectrum : increase max_bispectrum_deltas'
 17947            do i = 1, B%ndelta
 17948               B%deltas(i) = Ini_Read_Int_Array_File(Ini,'bispectrum_delta', i)
 17949            end do    
 17950            if (.not. B%do_parity_odd .and. B%Slice_Base_L>0 .and. &
 17951              any(mod(B%Slice_Base_L + B%deltas(1:B%ndelta),2) /= 0)) &
 17952                stop 'Slice is zero for even parity with L1+L2+L3 odd, i.e. Base+DeltaL3 odd'
 17953               
 17954           end if
 17955           B%DoFisher = Ini_Read_Logical_File(Ini,'bispectrum_do_fisher',B%DoFisher)        
 17956           if (B%DoFisher) then
 17957            B%FisherNoise = Ini_Read_Double_File(Ini,'bispectrum_fisher_noise',B%FisherNoise)        
 17958            B%FisherNoisePol = Ini_Read_Double_File(Ini,'bispectrum_fisher_noise_pol',B%FisherNoisePol )        
 17959            B%FisherNoiseFwhmArcmin = Ini_Read_Double_File(Ini,'bispectrum_fisher_fwhm_arcmin',B%FisherNoiseFwhmArcmin)
 17960           end if
 17961           B%FullOutputFile = Ini_Read_String_File(Ini,'bispectrum_full_output_file') 
 17962           if (B%FullOutputFile /= '') then
 17963            B%SparseFullOutput = Ini_Read_Logical_file(Ini,'bispectrum_full_output_sparse',B%SparseFullOutput)
 17964           end if
 17965           
 17966           if (B%do_primordial_bispectrum) then
 17967              B%export_alpha_beta = Ini_Read_Logical_file(Ini,'bispectrum_export_alpha_beta', B%export_alpha_beta)
 17968           end if
 17969           
 17970           end if
 17971           
 17972         end subroutine Bispectrum_ReadParams  
 17973  
 17974 end module Bispectrum
 17975 
 17976 ** sigma8.f90
 17977 
 17978      !Simple test program to print out sigma_8 as a function of the CDM density
 17979      program GetSigma8
 17980         use CAMB
 17981         implicit none
 17982         integer i
 17983     
 17984         type(CAMBparams)  P !defined in ModelParams in modules.f90
 17985 
 17986         call CAMB_SetDefParams(P)
 17987 
 17988         P%WantTransfer = .true.
 17989 
 17990         P%WantCls = .false.
 17991 
 17992         P%omegab  = .045
 17993         P%omegac  = 0.155
 17994         P%omegav  = 0.8
 17995         P%omegan  = 0.0
 17996         P%H0      = 65
 17997        
 17998         P%InitPower%ScalarPowerAmp = 2e-9
 17999         P%InitPower%nn     = 1 !number of initial power spectra
 18000         P%InitPower%an(1)  = 1 !scalar spectral index
 18001         P%InitPower%ant(1) = 0 !Not used here
 18002         P%InitPower%rat(1) = 1 !ditto
 18003 
 18004         !these settings seem good enough for sigma8 to a percent or so
 18005         P%Transfer%high_precision = .false.
 18006         P%Transfer%kmax = 0.5
 18007         P%Transfer%k_per_logint = 3
 18008         P%Transfer%num_redshifts = 1
 18009         P%Transfer%redshifts(1) = 0
 18010 
 18011         do i = 1,10
 18012          P%Omegav = P%Omegav-0.05
 18013          P%Omegac = P%Omegac+0.05
 18014         call CAMB_GetResults(P) 
 18015 
 18016         !Results are in the Transfer module in modules.f90
 18017              
 18018         write (*,*) 'Omc = ',real(P%Omegac),'OmLam = ',real(P%Omegav) &
 18019            , 'sigma_8 = ', real(MT%sigma_8(1,1))
 18020         end do
 18021 
 18022         end program GetSigma8
 18023 
 18024 
 18025 ** subroutines.f90
 18026 
 18027 !General numerical routines and global accuracy. Includes modified dverk for CAMB.
 18028 
 18029 
 18030 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18031 
 18032         subroutine splder(y,dy,n, g)
 18033         use Precision
 18034 !  Splder fits a cubic spline to y and returns the first derivatives at
 18035 !  the grid points in dy.  Dy is equivalent to a 4th-order Pade
 18036 !  difference formula for dy/di.
 18037         implicit none
 18038         integer, intent(in) :: n
 18039         real(dl), intent(in) :: y(n),g(n)
 18040         real(dl), intent(out) :: dy(n)
 18041         integer :: n1, i
 18042         real(dl), allocatable, dimension(:) :: f
 18043 
 18044         allocate(f(n))
 18045         n1 = n-1
 18046 !  Quartic fit to dy/di at boundaries, assuming d3y/di3 = 0.
 18047         f(1) = (-10*y(1)+15*y(2)-6*y(3)+y(4))/6
 18048         f(n) = (10*y(n)-15*y(n1)+6*y(n-2)-y(n-3))/6
 18049 !  Solve the tridiagonal system
 18050 !  dy(i-1)+4*dy(i)+dy(i+1) = 3*(y(i+1)-y(i-1)), i = 2,3,...,n1,
 18051 !  with dy(1) = f(1), dy(n) = f(n).
 18052         do i = 2,n1
 18053           f(i) = g(i)*(3*(y(i+1)-y(i-1))-f(i-1))
 18054         end do
 18055         dy(n) = f(n)
 18056         do i = n1,1,-1
 18057           dy(i) = f(i)-g(i)*dy(i+1)
 18058         end do
 18059         deallocate(f)
 18060         end subroutine splder
 18061 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18062         subroutine splini(g,n)
 18063         use Precision
 18064 !  Splini must be called before splder to initialize array g in common.
 18065         implicit none
 18066         integer, intent(in) :: n
 18067         real(dl), intent(out):: g(n)
 18068         integer :: i
 18069 
 18070         g(1) = 0
 18071         do i = 2,n
 18072           g(i) = 1/(4-g(i-1))
 18073         end do
 18074         end subroutine splini
 18075 
 18076 
 18077  !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18078         function rombint2(f,a,b,tol, maxit, minsteps)
 18079         use precision
 18080 !  Rombint returns the integral from a to b of using Romberg integration.
 18081 !  The method converges provided that f(x) is continuous in (a,b).
 18082 !  f must be real(dl) and must be declared external in the calling
 18083 !  routine.  tol indicates the desired relative accuracy in the integral.
 18084 
 18085 ! Modified by AL to specify max iterations and minimum number of steps
 18086 ! (min steps useful to stop wrong results on periodic or sharp functions)
 18087         implicit none
 18088         integer, parameter :: MAXITER = 20,MAXJ=5
 18089         dimension g(MAXJ+1)
 18090         real(dl) f
 18091         external f
 18092         real(dl) :: rombint2
 18093         real(dl), intent(in) :: a,b,tol
 18094         integer, intent(in):: maxit,minsteps
 18095      
 18096         integer :: nint, i, k, jmax, j
 18097         real(dl) :: h, gmax, error, g, g0, g1, fourj
 18098       
 18099         h = 0.5*(b-a)
 18100         gmax = h*(f(a)+f(b))
 18101         g(1) = gmax
 18102         nint = 1
 18103         error = 1.0d20
 18104         i = 0
 18105         do
 18106           i = i+1
 18107           if (i > maxit.or.(i > 5.and.abs(error) < tol) .and. nint > minsteps) exit
 18108 !  Calculate next trapezoidal rule approximation to integral.
 18109           g0 = 0
 18110           do k = 1,nint
 18111             g0 = g0+f(a+(k+k-1)*h)
 18112           end do
 18113           g0 = 0.5*g(1)+h*g0
 18114           h = 0.5*h
 18115           nint = nint+nint
 18116           jmax = min(i,MAXJ)
 18117           fourj = 1
 18118           do j = 1,jmax
 18119 !  Use Richardson extrapolation.
 18120             fourj = 4*fourj
 18121             g1 = g0+(g0-g(j))/(fourj-1)
 18122             g(j) = g0
 18123             g0 = g1
 18124           end do  
 18125           if (abs(g0) > tol) then
 18126             error = 1-gmax/g0
 18127           else
 18128             error = gmax
 18129           end if
 18130           gmax = g0
 18131           g(jmax+1) = g0
 18132         end do
 18133   
 18134         rombint2 = g0
 18135         if (i > maxit .and. abs(error) > tol)  then
 18136           write(*,*) 'Warning: Rombint failed to converge; '
 18137           write (*,*)'integral, error, tol:', rombint2,error, tol
 18138         end if
 18139         
 18140         end function rombint2
 18141 
 18142 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18143         function rombint(f,a,b,tol)
 18144         use Precision
 18145 !  Rombint returns the integral from a to b of using Romberg integration.
 18146 !  The method converges provided that f(x) is continuous in (a,b).
 18147 !  f must be real(dl) and must be declared external in the calling
 18148 !  routine.  tol indicates the desired relative accuracy in the integral.
 18149 !
 18150         implicit none
 18151         integer, parameter :: MAXITER = 20
 18152         integer, parameter :: MAXJ = 5
 18153         dimension g(MAXJ+1)
 18154         real(dl) f
 18155         external f
 18156         real(dl) :: rombint
 18157         real(dl), intent(in) :: a,b,tol
 18158         integer :: nint, i, k, jmax, j
 18159         real(dl) :: h, gmax, error, g, g0, g1, fourj
 18160 !
 18161 
 18162         h = 0.5*(b-a)
 18163         gmax = h*(f(a)+f(b))
 18164         g(1) = gmax
 18165         nint = 1
 18166         error = 1.0d20
 18167         i = 0
 18168 10        i = i+1
 18169           if (i > MAXITER.or.(i > 5.and.abs(error) < tol)) &
 18170             go to 40
 18171 !  Calculate next trapezoidal rule approximation to integral.
 18172           g0 = 0
 18173             do 20 k = 1,nint
 18174             g0 = g0+f(a+(k+k-1)*h)
 18175 20        continue
 18176           g0 = 0.5*g(1)+h*g0
 18177           h = 0.5*h
 18178           nint = nint+nint
 18179           jmax = min(i,MAXJ)
 18180           fourj = 1
 18181             do 30 j = 1,jmax
 18182 !  Use Richardson extrapolation.
 18183             fourj = 4*fourj
 18184             g1 = g0+(g0-g(j))/(fourj-1)
 18185             g(j) = g0
 18186             g0 = g1
 18187 30        continue
 18188           if (abs(g0) > tol) then
 18189             error = 1-gmax/g0
 18190           else
 18191             error = gmax
 18192           end if
 18193           gmax = g0
 18194           g(jmax+1) = g0
 18195         go to 10
 18196 40      rombint = g0
 18197         if (i > MAXITER.and.abs(error) > tol)  then
 18198           write(*,*) 'Warning: Rombint failed to converge; '
 18199           write (*,*)'integral, error, tol:', rombint,error, tol
 18200         end if
 18201         
 18202         end function rombint
 18203 
 18204 
 18205 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18206         function rombint_obj(obj,f,a,b,tol, maxit)
 18207         use Precision
 18208 !  Rombint returns the integral from a to b of using Romberg integration.
 18209 !  The method converges provided that f(x) is continuous in (a,b).
 18210 !  f must be real(dl) and must be declared external in the calling
 18211 !  routine.  tol indicates the desired relative accuracy in the integral.
 18212 !
 18213         implicit none
 18214         integer, intent(in), optional :: maxit
 18215         integer :: MAXITER = 20
 18216         integer, parameter :: MAXJ = 5
 18217         dimension g(MAXJ+1)
 18218         real obj !dummy
 18219         real(dl) f
 18220         external f
 18221         real(dl) :: rombint_obj
 18222         real(dl), intent(in) :: a,b,tol
 18223         integer :: nint, i, k, jmax, j
 18224         real(dl) :: h, gmax, error, g, g0, g1, fourj
 18225 !
 18226 
 18227         if (present(maxit)) then
 18228             MaxIter = maxit
 18229         end if
 18230         h = 0.5*(b-a)
 18231         gmax = h*(f(obj,a)+f(obj,b))
 18232         g(1) = gmax
 18233         nint = 1
 18234         error = 1.0d20
 18235         i = 0
 18236 10        i = i+1
 18237           if (i > MAXITER.or.(i > 5.and.abs(error) < tol)) &
 18238             go to 40
 18239 !  Calculate next trapezoidal rule approximation to integral.
 18240           g0 = 0
 18241             do 20 k = 1,nint
 18242             g0 = g0+f(obj,a+(k+k-1)*h)
 18243 20        continue
 18244           g0 = 0.5*g(1)+h*g0
 18245           h = 0.5*h
 18246           nint = nint+nint
 18247           jmax = min(i,MAXJ)
 18248           fourj = 1
 18249             do 30 j = 1,jmax
 18250 !  Use Richardson extrapolation.
 18251             fourj = 4*fourj
 18252             g1 = g0+(g0-g(j))/(fourj-1)
 18253             g(j) = g0
 18254             g0 = g1
 18255 30        continue
 18256           if (abs(g0) > tol) then
 18257             error = 1-gmax/g0
 18258           else
 18259             error = gmax
 18260           end if
 18261           gmax = g0
 18262           g(jmax+1) = g0
 18263         go to 10
 18264 40      rombint_obj = g0
 18265         if (i > MAXITER.and.abs(error) > tol)  then
 18266           write(*,*) 'Warning: Rombint failed to converge; '
 18267           write (*,*)'integral, error, tol:', rombint_obj,error, tol
 18268         end if
 18269         
 18270         end function rombint_obj
 18271 
 18272 
 18273 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18274 ! calculates array of second derivatives used by cubic spline
 18275 ! interpolation. y2 is array of second derivatives, yp1 and ypn are first
 18276 ! derivatives at end points.
 18277 
 18278 
 18279       SUBROUTINE spline(x,y,n,yp1,ypn,y2)
 18280       use Precision
 18281       implicit none
 18282       INTEGER, intent(in) :: n
 18283       real(dl), intent(in) :: x(n), y(n), yp1, ypn
 18284       real(dl), intent(out) :: y2(n)
 18285       INTEGER i,k
 18286       real(dl) p,qn,sig,un
 18287       real(dl), dimension(:), allocatable :: u
 18288 
 18289        
 18290       Allocate(u(1:n))
 18291       if (yp1 > .99d30) then
 18292         y2(1) = 0
 18293         u(1) = 0
 18294       else
 18295         y2(1) = -0.5
 18296         u(1) = (3/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
 18297       endif
 18298       
 18299       do i = 2,n-1
 18300         sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
 18301         p = sig*y2(i-1)+2 
 18302    
 18303         y2(i) = (sig-1)/p
 18304       
 18305          u(i) = (6*((y(i+1)-y(i))/(x(i+ &
 18306          1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
 18307          u(i-1))/p
 18308       end do
 18309       if (ypn > .99d30) then
 18310         qn = 0
 18311         un = 0
 18312       else
 18313         qn = 0.5
 18314         un = (3/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
 18315       endif
 18316       y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1)
 18317       do k = n-1,1,-1
 18318         y2(k) = y2(k)*y2(k+1)+u(k)
 18319       end do
 18320 
 18321       Deallocate(u)
 18322   
 18323 !  (C) Copr. 1986-92 Numerical Recipes Software = $j*m,).
 18324       END SUBROUTINE spline
 18325 
 18326 
 18327      SUBROUTINE spline_deriv(x,y,y2,y1,n)
 18328      !Get derivative y1 given array of x, y and y''
 18329       use Precision
 18330       implicit none
 18331       INTEGER, intent(in) :: n
 18332       real(dl), intent(in) :: x(n), y(n), y2(n)
 18333       real(dl), intent(out) :: y1(n)
 18334       INTEGER i
 18335       real(dl) dx
 18336    
 18337 
 18338       do i = 1, n-1
 18339            
 18340          dx = (x(i+1) - x(i))
 18341          y1(i) = (y(i+1) - y(i))/dx - dx*(2*y2(i) + y2(i+1))/6
 18342       end do
 18343        dx = x(n) - x(n-1)
 18344        y1(n) = (y(n) - y(n-1))/dx + dx* ( y2(i-1)  + 2*y2(i) )/6
 18345 
 18346       END SUBROUTINE spline_deriv
 18347 
 18348       subroutine spline_integrate(x,y,y2,yint,n)
 18349        !Cumulative integral of cubic spline
 18350        use Precision
 18351        integer, intent(in) :: n
 18352        real(dl), intent(in) :: x(n), y(n), y2(n)
 18353        real(dl), intent(out) :: yint(n)
 18354        real(dl) dx
 18355        integer i
 18356 
 18357        yint(1) = 0
 18358        do i = 2, n
 18359            
 18360          dx = (x(i) - x(i-1))
 18361          yint(i) = yint(i-1) + dx*( (y(i)+y(i-1))/2 - dx**2/24*(y2(i)+y2(i-1))) 
 18362           
 18363        end do
 18364        
 18365       end subroutine spline_integrate
 18366 
 18367 
 18368 
 18369 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 18370 !  this is not the splint given in numerical recipes
 18371 
 18372 
 18373         subroutine splint(y,z,n)
 18374         use Precision
 18375 !  Splint integrates a cubic spline, providing the output value
 18376 !  z = integral from 1 to n of s(i)di, where s(i) is the spline fit
 18377 !  to y(i).
 18378 !
 18379         implicit none
 18380         integer, intent(in) :: n
 18381         real(dl), intent(in) :: y(n)
 18382         real(dl), intent(out) :: z
 18383 
 18384         integer :: n1
 18385         real(dl) :: dy1, dyn
 18386 !
 18387         n1 = n-1
 18388 !  Cubic fit to dy/di at boundaries.
 18389 !       dy1 = (-11*y(1)+18*y(2)-9*y(3)+2*y(4))/6
 18390         dy1 = 0
 18391         dyn = (11*y(n)-18*y(n1)+9*y(n-2)-2*y(n-3))/6
 18392 !
 18393         z = 0.5*(y(1)+y(n))+(dy1-dyn)/12
 18394         z = z + sum(y(2:n1))
 18395         end subroutine splint
 18396 
 18397 
 18398 !This version is modified to pass an object parameter to the function on each call
 18399 !Fortunately Fortran doesn't do type checking on functions, so we can pretend the
 18400 !passed object parameter (EV) is any type we like. In reality it is just a pointer.
 18401 
 18402       subroutine dverk (EV,n, fcn, x, y, xend, tol, ind, c, nw, w)
 18403       use Precision
 18404       use AMLUtils
 18405       integer n, ind, nw, k
 18406       real(dl) x, y(n), xend, tol, c(*), w(nw,9), temp
 18407       real EV !It isn't, but as long as it maintains it as a pointer we are OK
 18408 !
 18409 !***********************************************************************
 18410 !                                                                      *
 18411 ! note added 11/14/85.                                                 *
 18412 !                                                                      *
 18413 ! if you discover any errors in this subroutine, please contact        *
 18414 !                                                                      *
 18415 !        kenneth r. jackson                                            *
 18416 !        department of computer science                                *
 18417 !        university of toronto                                         *
 18418 !        toronto, ontario,                                             *
 18419 !        canada   m5s 1a4                                              *
 18420 !                                                                      *
 18421 !        phone: 416-978-7075                                           *
 18422 !                                                                      *
 18423 !        electronic mail:                                              *
 18424 !        uucp:   {cornell,decvax,ihnp4,linus,uw-beaver}!utcsri!krj     *
 18425 !        csnet:  krj@toronto                                           *
 18426 !        arpa:   krj.toronto@csnet-relay                               *
 18427 !        bitnet: krj%toronto@csnet-relay.arpa                          *
 18428 !                                                                      *
 18429 ! dverk is written in fortran 66.                                      *
 18430 !                                                                      *
 18431 ! the constants dwarf and rreb -- c(10) and c(11), respectively -- are *
 18432 ! set for a  vax  in  double  precision.  they  should  be  reset,  as *
 18433 ! described below, if this program is run on another machine.          *
 18434 !                                                                      *
 18435 ! the c array is declared in this subroutine to have one element only, *
 18436 ! although  more  elements  are  referenced  in this subroutine.  this *
 18437 ! causes some compilers to issue warning messages.  there is,  though, *
 18438 ! no  error  provided  c is declared sufficiently large in the calling *
 18439 ! program, as described below.                                         *
 18440 !                                                                      *
 18441 ! the following external statement  for  fcn  was  added  to  avoid  a *
 18442 ! warning  message  from  the  unix  f77 compiler.  the original dverk *
 18443 ! comments and code follow it.                                         *
 18444 !                                                                      *
 18445 !***********************************************************************
 18446 !
 18447       external fcn
 18448 !
 18449 !***********************************************************************
 18450 !                                                                      *
 18451 !     purpose - this is a runge-kutta  subroutine  based  on  verner's *
 18452 ! fifth and sixth order pair of formulas for finding approximations to *
 18453 ! the solution of  a  system  of  first  order  ordinary  differential *
 18454 ! equations  with  initial  conditions. it attempts to keep the global *
 18455 ! error proportional to  a  tolerance  specified  by  the  user.  (the *
 18456 ! proportionality  depends  on the kind of error control that is used, *
 18457 ! as well as the differential equation and the range of integration.)  *
 18458 !                                                                      *
 18459 !     various options are available to the user,  including  different *
 18460 ! kinds  of  error control, restrictions on step sizes, and interrupts *
 18461 ! which permit the user to examine the state of the  calculation  (and *
 18462 ! perhaps make modifications) during intermediate stages.              *
 18463 !                                                                      *
 18464 !     the program is efficient for non-stiff systems.  however, a good *
 18465 ! variable-order-adams  method  will probably be more efficient if the *
 18466 ! function evaluations are very costly.  such a method would  also  be *
 18467 ! more suitable if one wanted to obtain a large number of intermediate *
 18468 ! solution values by interpolation, as might be the case  for  example *
 18469 ! with graphical output.                                               *
 18470 !                                                                      *
 18471 !                                    hull-enright-jackson   1/10/76    *
 18472 !                                                                      *
 18473 !***********************************************************************
 18474 !                                                                      *
 18475 !     use - the user must specify each of the following                *
 18476 !                                                                      *
 18477 !     n  number of equations                                           *
 18478 !                                                                      *
 18479 !   fcn  name of subroutine for evaluating functions - the  subroutine *
 18480 !           itself must also be provided by the user - it should be of *
 18481 !           the following form                                         *
 18482 !              subroutine fcn(n, x, y, yprime)                         *
 18483 !              integer n                                               *
 18484 !              real(dl) x, y(n), yprime(n)                     *
 18485 !                      *** etc ***                                     *
 18486 !           and it should evaluate yprime, given n, x and y            *
 18487 !                                                                      *
 18488 !     x  independent variable - initial value supplied by user         *
 18489 !                                                                      *
 18490 !     y  dependent variable - initial values of components y(1), y(2), *
 18491 !           ..., y(n) supplied by user                                 *
 18492 !                                                                      *
 18493 !  xend  value of x to which integration is to be carried out - it may *
 18494 !           be less than the initial value of x                        *
 18495 !                                                                      *
 18496 !   tol  tolerance - the subroutine attempts to control a norm of  the *
 18497 !           local  error  in  such  a  way  that  the  global error is *
 18498 !           proportional to tol. in some problems there will be enough *
 18499 !           damping  of  errors, as well as some cancellation, so that *
 18500 !           the global error will be less than tol. alternatively, the *
 18501 !           control   can   be  viewed  as  attempting  to  provide  a *
 18502 !           calculated value of y at xend which is the exact  solution *
 18503 !           to  the  problem y' = f(x,y) + e(x) where the norm of e(x) *
 18504 !           is proportional to tol.  (the norm  is  a  max  norm  with *
 18505 !           weights  that  depend on the error control strategy chosen *
 18506 !           by the user.  the default weight for the k-th component is *
 18507 !           1/max(1,abs(y(k))),  which therefore provides a mixture of *
 18508 !           absolute and relative error control.)                      *
 18509 !                                                                      *
 18510 !   ind  indicator - on initial entry ind must be set equal to  either *
 18511 !           1  or  2. if the user does not wish to use any options, he *
 18512 !           should set ind to 1 - all that remains for the user to  do *
 18513 !           then  is  to  declare c and w, and to specify nw. the user *
 18514 !           may also  select  various  options  on  initial  entry  by *
 18515 !           setting ind = 2 and initializing the first 9 components of *
 18516 !           c as described in the next section.  he may also  re-enter *
 18517 !           the  subroutine  with ind = 3 as mentioned again below. in *
 18518 !           any event, the subroutine returns with ind equal to        *
 18519 !              3 after a normal return                                 *
 18520 !              4, 5, or 6 after an interrupt (see options c(8), c(9))  *
 18521 !              -1, -2, or -3 after an error condition (see below)      *
 18522 !                                                                      *
 18523 !     c  communications vector - the dimension must be greater than or *
 18524 !           equal to 24, unless option c(1) = 4 or 5 is used, in which *
 18525 !           case the dimension must be greater than or equal to n+30   *
 18526 !                                                                      *
 18527 !    nw  first dimension of workspace w -  must  be  greater  than  or *
 18528 !           equal to n                                                 *
 18529 !                                                                      *
 18530 !     w  workspace matrix - first dimension must be nw and second must *
 18531 !           be greater than or equal to 9                              *
 18532 !                                                                      *
 18533 !     the subroutine  will  normally  return  with  ind  =  3,  having *
 18534 ! replaced the initial values of x and y with, respectively, the value *
 18535 ! of xend and an approximation to y at xend.  the  subroutine  can  be *
 18536 ! called  repeatedly  with new values of xend without having to change *
 18537 ! any other argument.  however, changes in tol, or any of the  options *
 18538 ! described below, may also be made on such a re-entry if desired.     *
 18539 !                                                                      *
 18540 !     three error returns are also possible, in which  case  x  and  y *
 18541 ! will be the most recently accepted values -                          *
 18542 !     with ind = -3 the subroutine was unable  to  satisfy  the  error *
 18543 !        requirement  with a particular step-size that is less than or *
 18544 !        equal to hmin, which may mean that tol is too small           *
 18545 !     with ind = -2 the value of hmin  is  greater  than  hmax,  which *
 18546 !        probably  means  that the requested tol (which is used in the *
 18547 !        calculation of hmin) is too small                             *
 18548 !     with ind = -1 the allowed maximum number of fcn evaluations  has *
 18549 !        been  exceeded,  but  this  can only occur if option c(7), as *
 18550 !        described in the next section, has been used                  *
 18551 !                                                                      *
 18552 !     there are several circumstances that will cause the calculations *
 18553 ! to  be  terminated,  along with output of information that will help *
 18554 ! the user determine the cause of  the  trouble.  these  circumstances *
 18555 ! involve  entry with illegal or inconsistent values of the arguments, *
 18556 ! such as attempting a normal  re-entry  without  first  changing  the *
 18557 ! value of xend, or attempting to re-enter with ind less than zero.    *
 18558 !                                                                      *
 18559 !***********************************************************************
 18560 !                                                                      *
 18561 !     options - if the subroutine is entered with ind = 1, the first 9 *
 18562 ! components of the communications vector are initialized to zero, and *
 18563 ! the subroutine uses only default values  for  each  option.  if  the *
 18564 ! subroutine  is  entered  with ind = 2, the user must specify each of *
 18565 ! these 9 components - normally he would first set them all  to  zero, *
 18566 ! and  then  make  non-zero  those  that  correspond to the particular *
 18567 ! options he wishes to select. in any event, options may be changed on *
 18568 ! re-entry  to  the  subroutine  -  but if the user changes any of the *
 18569 ! options, or tol, in the course of a calculation he should be careful *
 18570 ! about  how  such changes affect the subroutine - it may be better to *
 18571 ! restart with ind = 1 or 2. (components 10 to 24 of c are used by the *
 18572 ! program  -  the information is available to the user, but should not *
 18573 ! normally be changed by him.)                                         *
 18574 !                                                                      *
 18575 !  c(1)  error control indicator - the norm of the local error is  the *
 18576 !           max  norm  of  the  weighted  error  estimate  vector, the *
 18577 !           weights being determined according to the value of c(1) -  *
 18578 !              if c(1) = 1 the weights are 1 (absolute error control)    *
 18579 !              if c(1) = 2 the weights are 1/abs(y(k))  (relative  error *
 18580 !                 control)                                             *
 18581 !              if c(1) = 3 the  weights  are  1/max(abs(c(2)),abs(y(k))) *
 18582 !                 (relative  error  control,  unless abs(y(k)) is less *
 18583 !                 than the floor value, abs(c(2)) )                    *
 18584 !              if c(1) = 4 the weights are 1/max(abs(c(k+30)),abs(y(k))) *
 18585 !                 (here individual floor values are used)              *
 18586 !              if c(1) = 5 the weights are 1/abs(c(k+30))                *
 18587 !              for all other values of c(1), including  c(1) = 0,  the *
 18588 !                 default  values  of  the  weights  are  taken  to be *
 18589 !                 1/max(1,abs(y(k))), as mentioned earlier             *
 18590 !           (in the two cases c(1) = 4 or 5 the user must declare  the *
 18591 !           dimension of c to be at least n+30 and must initialize the *
 18592 !           components c(31), c(32), ..., c(n+30).)                    *
 18593 !                                                                      *
 18594 !  c(2)  floor value - used when the indicator c(1) has the value 3    *
 18595 !                                                                      *
 18596 !  c(3)  hmin specification - if not zero, the subroutine chooses hmin *
 18597 !           to be abs(c(3)) - otherwise it uses the default value      *
 18598 !              10*max(dwarf,rreb*max(weighted norm y/tol,abs(x))),     *
 18599 !           where dwarf is a very small positive  machine  number  and *
 18600 !           rreb is the relative roundoff error bound                  *
 18601 !                                                                      *
 18602 !  c(4)  hstart specification - if not zero, the subroutine  will  use *
 18603 !           an  initial  hmag equal to abs(c(4)), except of course for *
 18604 !           the restrictions imposed by hmin and hmax  -  otherwise it *
 18605 !           uses the default value of hmax*(tol)**(1/6)                *
 18606 !                                                                      *
 18607 !  c(5)  scale specification - this is intended to be a measure of the *
 18608 !           scale of the problem - larger values of scale tend to make *
 18609 !           the method more reliable, first  by  possibly  restricting *
 18610 !           hmax  (as  described  below) and second, by tightening the *
 18611 !           acceptance requirement - if c(5) is zero, a default  value *
 18612 !           of  1  is  used.  for  linear  homogeneous  problems  with *
 18613 !           constant coefficients, an appropriate value for scale is a *
 18614 !           norm  of  the  associated  matrix.  for other problems, an *
 18615 !           approximation to  an  average  value  of  a  norm  of  the *
 18616 !           jacobian along the trajectory may be appropriate           *
 18617 !                                                                      *
 18618 !  c(6)  hmax specification - four cases are possible                  *
 18619 !           if c(6) <> 0 and c(5) <> 0, hmax is taken to be            *
 18620 !              min(abs(c(6)),2/abs(c(5)))                              *
 18621 !           if c(6) <> 0 and c(5) = 0, hmax is taken to be  abs(c(6)) *
 18622 !           if c(6) = 0 and c(5) <> 0, hmax is taken to be            *
 18623 !              2/abs(c(5))                                             *
 18624 !           if c(6) = 0 and c(5) = 0, hmax is given a default  value *
 18625 !              of 2                                                    *
 18626 !                                                                      *
 18627 !  c(7)  maximum number of function evaluations  -  if  not  zero,  an *
 18628 !           error  return with ind = -1 will be caused when the number *
 18629 !           of function evaluations exceeds abs(c(7))                  *
 18630 !                                                                      *
 18631 !  c(8)  interrupt number  1  -  if  not  zero,  the  subroutine  will *
 18632 !           interrupt   the  calculations  after  it  has  chosen  its *
 18633 !           preliminary value of hmag, and just before choosing htrial *
 18634 !           and  xtrial  in  preparation for taking a step (htrial may *
 18635 !           differ from hmag in sign, and may  require  adjustment  if *
 18636 !           xend  is  near) - the subroutine returns with ind = 4, and *
 18637 !           will resume calculation at the point  of  interruption  if *
 18638 !           re-entered with ind = 4                                    *
 18639 !                                                                      *
 18640 !  c(9)  interrupt number  2  -  if  not  zero,  the  subroutine  will *
 18641 !           interrupt   the  calculations  immediately  after  it  has *
 18642 !           decided whether or not to accept the result  of  the  most *
 18643 !           recent  trial step, with ind = 5 if it plans to accept, or *
 18644 !           ind = 6 if it plans to reject -  y(*)  is  the  previously *
 18645 !           accepted  result, while w(*,9) is the newly computed trial *
 18646 !           value, and w(*,2) is the unweighted error estimate vector. *
 18647 !           the  subroutine  will  resume calculations at the point of *
 18648 !           interruption on re-entry with ind = 5 or 6. (the user  may *
 18649 !           change ind in this case if he wishes, for example to force *
 18650 !           acceptance of a step that would otherwise be rejected,  or *
 18651 !           vice versa. he can also restart with ind = 1 or 2.)        *
 18652 !                                                                      *
 18653 !***********************************************************************
 18654 !                                                                      *
 18655 !  summary of the components of the communications vector              *
 18656 !                                                                      *
 18657 !     prescribed at the option       determined by the program         *
 18658 !           of the user                                                *
 18659 !                                                                      *
 18660 !                                    c(10) rreb(rel roundoff err bnd)  *
 18661 !     c(1) error control indicator   c(11) dwarf (very small mach no)  *
 18662 !     c(2) floor value               c(12) weighted norm y             *
 18663 !     c(3) hmin specification        c(13) hmin                        *
 18664 !     c(4) hstart specification      c(14) hmag                        *
 18665 !     c(5) scale specification       c(15) scale                       *
 18666 !     c(6) hmax specification        c(16) hmax                        *
 18667 !     c(7) max no of fcn evals       c(17) xtrial                      *
 18668 !     c(8) interrupt no 1            c(18) htrial                      *
 18669 !     c(9) interrupt no 2            c(19) est                         *
 18670 !                                    c(20) previous xend               *
 18671 !                                    c(21) flag for xend               *
 18672 !                                    c(22) no of successful steps      *
 18673 !                                    c(23) no of successive failures   *
 18674 !                                    c(24) no of fcn evals             *
 18675 !                                                                      *
 18676 !  if c(1) = 4 or 5, c(31), c(32), ... c(n+30) are floor values        *
 18677 !                                                                      *
 18678 !***********************************************************************
 18679 !                                                                      *
 18680 !  an overview of the program                                          *
 18681 !                                                                      *
 18682 !     begin initialization, parameter checking, interrupt re-entries   *
 18683 !  ......abort if ind out of range 1 to 6                              *
 18684 !  .     cases - initial entry, normal re-entry, interrupt re-entries  *
 18685 !  .     case 1 - initial entry (ind  =  1 or 2)                      *
 18686 !  v........abort if n > nw or tol< = 0                               *
 18687 !  .        if initial entry without options (ind  =  1)              *
 18688 !  .           set c(1) to c(9) equal to zero                          *
 18689 !  .        else initial entry with options (ind  =  2)               *
 18690 !  .           make c(1) to c(9) non-negative                          *
 18691 !  .           make floor values non-negative if they are to be used   *
 18692 !  .        end if                                                     *
 18693 !  .        initialize rreb, dwarf, prev xend, flag, counts            *
 18694 !  .     case 2 - normal re-entry (ind  =  3)                         *
 18695 !  .........abort if xend reached, and either x changed or xend not    *
 18696 !  .        re-initialize flag                                         *
 18697 !  .     case 3 - re-entry following an interrupt (ind  =  4 to 6)    *
 18698 !  v        transfer control to the appropriate re-entry point.......  *
 18699 !  .     end cases                                                  .  *
 18700 !  .  end initialization, etc.                                      .  *
 18701 !  .                                                                v  *
 18702 !  .  loop through the following 4 stages, once for each trial step .  *
 18703 !  .     stage 1 - prepare                                          .  *
 18704 !***********error return (with ind = -1) if no of fcn evals too great .  *
 18705 !  .        calc slope (adding 1 to no of fcn evals) if ind  <>  6  .  *
 18706 !  .        calc hmin, scale, hmax                                  .  *
 18707 !***********error return (with ind = -2) if hmin  >  hmax            .  *
 18708 !  .        calc preliminary hmag                                   .  *
 18709 !***********interrupt no 1 (with ind = 4) if requested.......re-entry.v  *
 18710 !  .        calc hmag, xtrial and htrial                            .  *
 18711 !  .     end stage 1                                                .  *
 18712 !  v     stage 2 - calc ytrial (adding 7 to no of fcn evals)        .  *
 18713 !  .     stage 3 - calc the error estimate                          .  *
 18714 !  .     stage 4 - make decisions                                   .  *
 18715 !  .        set ind = 5 if step acceptable, else set ind = 6            .  *
 18716 !***********interrupt no 2 if requested....................re-entry.v  *
 18717 !  .        if step accepted (ind  =  5)                              *
 18718 !  .           update x, y from xtrial, ytrial                         *
 18719 !  .           add 1 to no of successful steps                         *
 18720 !  .           set no of successive failures to zero                   *
 18721 !**************return(with ind = 3, xend saved, flag set) if x  =  xend *
 18722 !  .        else step not accepted (ind  =  6)                        *
 18723 !  .           add 1 to no of successive failures                      *
 18724 !**************error return (with ind = -3) if hmag < = hmin            *
 18725 !  .        end if                                                     *
 18726 !  .     end stage 4                                                   *
 18727 !  .  end loop                                                         *
 18728 !  .                                                                   *
 18729 !  begin abort action                                                  *
 18730 !     output appropriate  message  about  stopping  the  calculations, *
 18731 !        along with values of ind, n, nw, tol, hmin,  hmax,  x,  xend, *
 18732 !        previous xend,  no of  successful  steps,  no  of  successive *
 18733 !        failures, no of fcn evals, and the components of y            *
 18734 !     stop                                                             *
 18735 !  end abort action                                                    *
 18736 !                                                                      *
 18737 !***********************************************************************
 18738 !
 18739 !     ******************************************************************
 18740 !     * begin initialization, parameter checking, interrupt re-entries *
 18741 !     ******************************************************************
 18742 !
 18743 !  ......abort if ind out of range 1 to 6
 18744          if (ind < 1 .or. ind > 6) go to 500
 18745 !
 18746 !        cases - initial entry, normal re-entry, interrupt re-entries
 18747 !         go to (5, 5, 45, 1111, 2222, 2222), ind
 18748          if (ind = 3) goto 45
 18749          if (ind = 4) goto 1111
 18750          if (ind = 5 .or. ind = 6) goto 2222
 18751 
 18752 !        case 1 - initial entry (ind  =  1 or 2)
 18753 !  .........abort if n > nw or tol< = 0
 18754             if (n > nw .or. tol< = 0) go to 500
 18755             if (ind =  2) go to 15
 18756 !              initial entry without options (ind  =  1)
 18757 !              set c(1) to c(9) equal to 0
 18758                do k = 1, 9
 18759                   c(k) = 0
 18760                end do
 18761                go to 35
 18762    15       continue
 18763 !              initial entry with options (ind  =  2)
 18764 !              make c(1) to c(9) non-negative
 18765                do k = 1, 9
 18766                   c(k) = dabs(c(k))
 18767                end do
 18768 !              make floor values non-negative if they are to be used
 18769                if (c(1) <> 4 .and. c(1) <> 5) go to 30
 18770                   do k = 1, n
 18771                      c(k+30) = dabs(c(k+30))
 18772                   end do
 18773    30          continue
 18774    35       continue
 18775 !           initialize rreb, dwarf, prev xend, flag, counts
 18776             c(10) = 2**(-56)
 18777             c(11) = 1.d-35
 18778 !           set previous xend initially to initial value of x
 18779             c(20) = x
 18780             do k = 21, 24
 18781                c(k) = 0
 18782             end do
 18783             go to 50
 18784 !        case 2 - normal re-entry (ind  =  3)
 18785 !  .........abort if xend reached, and either x changed or xend not
 18786    45       if (c(21) <> 0 .and. &
 18787                               (x <> c(20) .or. xend = c(20))) go to 500
 18788 !           re-initialize flag
 18789             c(21) = 0
 18790             go to 50
 18791 !        case 3 - re-entry following an interrupt (ind  =  4 to 6)
 18792 !           transfer control to the appropriate re-entry point..........
 18793 !           this has already been handled by the computed go to        .
 18794 !        end cases                                                     v
 18795    50    continue
 18796 !
 18797 !     end initialization, etc.
 18798 !
 18799 !     ******************************************************************
 18800 !     * loop through the following 4 stages, once for each trial  step *
 18801 !     * until the occurrence of one of the following                   *
 18802 !     *    (a) the normal return (with ind  =  3) on reaching xend in *
 18803 !     *        stage 4                                                 *
 18804 !     *    (b) an error return (with ind  <  0) in stage 1 or stage 4 *
 18805 !     *    (c) an interrupt return (with ind   =   4,  5  or  6),  if *
 18806 !     *        requested, in stage 1 or stage 4                        *
 18807 !     ******************************************************************
 18808 !
 18809 99999 continue
 18810 !
 18811 !        ***************************************************************
 18812 !        * stage 1 - prepare - do calculations of  hmin,  hmax,  etc., *
 18813 !        * and some parameter  checking,  and  end  up  with  suitable *
 18814 !        * values of hmag, xtrial and htrial in preparation for taking *
 18815 !        * an integration step.                                        *
 18816 !        ***************************************************************
 18817 !
 18818 !***********error return (with ind = -1) if no of fcn evals too great
 18819             if (c(7) = 0 .or. c(24) < c(7)) go to 100
 18820                ind = -1
 18821                return
 18822   100       continue
 18823 !
 18824 !           calculate slope (adding 1 to no of fcn evals) if ind  <>  6
 18825             if (ind  =  6) go to 105
 18826                call fcn(EV,n, x, y, w(1,1))
 18827                c(24) = c(24) + 1
 18828   105       continue
 18829 !
 18830 !           calculate hmin - use default unless value prescribed
 18831             c(13) = c(3)
 18832             if (c(3)  <>  0) go to 165
 18833 !              calculate default value of hmin
 18834 !              first calculate weighted norm y - c(12) - as specified
 18835 !              by the error control indicator c(1)
 18836                temp = 0
 18837                if (c(1)  <>  1) go to 115
 18838 !                 absolute error control - weights are 1
 18839                   do 110 k = 1, n
 18840                      temp = dmax1(temp, dabs(y(k)))
 18841   110             continue
 18842                   c(12) = temp
 18843                   go to 160
 18844   115          if (c(1)  <>  2) go to 120
 18845 !                 relative error control - weights are 1/dabs(y(k)) so
 18846 !                 weighted norm y is 1
 18847                   c(12) = 1
 18848                   go to 160
 18849   120          if (c(1)  <>  3) go to 130
 18850 !                 weights are 1/max(c(2),abs(y(k)))
 18851                   do 125 k = 1, n
 18852                      temp = dmax1(temp, dabs(y(k))/c(2))
 18853   125             continue
 18854                   c(12) = dmin1(temp, 1)
 18855                   go to 160
 18856   130          if (c(1)  <>  4) go to 140
 18857 !                 weights are 1/max(c(k+30),abs(y(k)))
 18858                   do 135 k = 1, n
 18859                      temp = dmax1(temp, dabs(y(k))/c(k+30))
 18860   135             continue
 18861                   c(12) = dmin1(temp, 1)
 18862                   go to 160
 18863   140          if (c(1)  <>  5) go to 150
 18864 !                 weights are 1/c(k+30)
 18865                   do 145 k = 1, n
 18866                      temp = dmax1(temp, dabs(y(k))/c(k+30))
 18867   145             continue
 18868                   c(12) = temp
 18869                   go to 160
 18870   150          continue
 18871 !                 default case - weights are 1/max(1,abs(y(k)))
 18872                   do 155 k = 1, n
 18873                      temp = dmax1(temp, dabs(y(k)))
 18874   155             continue
 18875                   c(12) = dmin1(temp, 1)
 18876   160          continue
 18877                c(13) = 10*dmax1(c(11),c(10)*dmax1(c(12)/tol,dabs(x)))
 18878   165       continue
 18879 !
 18880 !           calculate scale - use default unless value prescribed
 18881             c(15) = c(5)
 18882             if (c(5)  =  0) c(15) = 1
 18883 !
 18884 !           calculate hmax - consider 4 cases
 18885 !           case 1 both hmax and scale prescribed
 18886                if (c(6) <> 0 .and. c(5) <> 0) &
 18887                                           c(16) = dmin1(c(6), 2/c(5))
 18888 !           case 2 - hmax prescribed, but scale not
 18889                if (c(6) <> 0 .and. c(5) = 0) c(16) = c(6)
 18890 !           case 3 - hmax not prescribed, but scale is
 18891                if (c(6) = 0 .and. c(5) <> 0) c(16) = 2/c(5)
 18892 !           case 4 - neither hmax nor scale is provided
 18893                if (c(6) = 0 .and. c(5) = 0) c(16) = 2
 18894 !
 18895 !***********error return (with ind = -2) if hmin  >  hmax
 18896             if (c(13) < = c(16)) go to 170
 18897                ind = -2
 18898                return
 18899   170       continue
 18900 !
 18901 !           calculate preliminary hmag - consider 3 cases
 18902             if (ind  >  2) go to 175
 18903 !           case 1 - initial entry - use prescribed value of hstart, if
 18904 !              any, else default
 18905                c(14) = c(4)
 18906                if (c(4)  =  0) c(14) = c(16)*tol**(1/6)
 18907                go to 185
 18908   175       if (c(23)  >  1) go to 180
 18909 !           case 2 - after a successful step, or at most  one  failure,
 18910 !              use min(2, .9*(tol/est)**(1/6))*hmag, but avoid possible
 18911 !              overflow. then avoid reduction by more than half.
 18912                temp = 2*c(14)
 18913                if (tol  <  (2/.9)**6*c(19)) &
 18914                        temp = .9*(tol/c(19))**(1/6)*c(14)
 18915                c(14) = dmax1(temp, .5*c(14))
 18916                go to 185
 18917   180       continue
 18918 !           case 3 - after two or more successive failures
 18919                c(14) = .5*c(14)
 18920   185       continue
 18921 !
 18922 !           check against hmax
 18923             c(14) = dmin1(c(14), c(16))
 18924 !
 18925 !           check against hmin
 18926             c(14) = dmax1(c(14), c(13))
 18927 !
 18928 !***********interrupt no 1 (with ind = 4) if requested
 18929             if (c(8)  =  0) go to 1111
 18930                ind = 4
 18931                return
 18932 !           resume here on re-entry with ind  =  4   ........re-entry..
 18933  1111       continue
 18934 !
 18935 !           calculate hmag, xtrial - depending on preliminary hmag, xend
 18936             if (c(14) .ge. dabs(xend - x)) go to 190
 18937 !              do not step more than half way to xend
 18938                c(14) = dmin1(c(14), .5*dabs(xend - x))
 18939                c(17) = x + dsign(c(14), xend - x)
 18940                go to 195
 18941   190       continue
 18942 !              hit xend exactly
 18943                c(14) = dabs(xend - x)
 18944                c(17) = xend
 18945   195       continue
 18946 !
 18947 !           calculate htrial
 18948             c(18) = c(17) - x
 18949 !
 18950 !        end stage 1
 18951 !
 18952 !        ***************************************************************
 18953 !        * stage 2 - calculate ytrial (adding 7 to no of  fcn  evals). *
 18954 !        * w(*,2), ... w(*,8)  hold  intermediate  results  needed  in *
 18955 !        * stage 3. w(*,9) is temporary storage until finally it holds *
 18956 !        * ytrial.                                                     *
 18957 !        ***************************************************************
 18958 !
 18959             temp = c(18)/1398169080000
 18960 !
 18961             do 200 k = 1, n
 18962                w(k,9) = y(k) + temp*w(k,1)*233028180000
 18963   200       continue
 18964             call fcn(EV,n, x + c(18)/6, w(1,9), w(1,2))
 18965 !
 18966             do 205 k = 1, n
 18967                w(k,9) = y(k) + temp*(   w(k,1)*74569017600 &
 18968                                       + w(k,2)*298276070400  )
 18969   205       continue
 18970             call fcn(EV,n, x + c(18)*(4/15), w(1,9), w(1,3))
 18971 !
 18972             do 210 k = 1, n
 18973                w(k,9) = y(k) + temp*(   w(k,1)*1165140900000 &
 18974                                       - w(k,2)*3728450880000 &
 18975                                       + w(k,3)*3495422700000 )
 18976   210       continue
 18977             call fcn(EV,n, x + c(18)*(2/3), w(1,9), w(1,4))
 18978 !
 18979             do 215 k = 1, n
 18980                w(k,9) = y(k) + temp*( - w(k,1)*3604654659375 &
 18981                                       + w(k,2)*12816549900000 &
 18982                                       - w(k,3)*9284716546875 &
 18983                                       + w(k,4)*1237962206250 )
 18984   215       continue
 18985             call fcn(EV,n, x + c(18)*(5/6), w(1,9), w(1,5))
 18986 !
 18987             do 220 k = 1, n
 18988                w(k,9) = y(k) + temp*(   w(k,1)*3355605792000 &
 18989                                       - w(k,2)*11185352640000 &
 18990                                       + w(k,3)*9172628850000 &
 18991                                       - w(k,4)*427218330000 &
 18992                                       + w(k,5)*482505408000  )
 18993   220       continue
 18994             call fcn(EV,n, x + c(18), w(1,9), w(1,6))
 18995 !
 18996             do 225 k = 1, n
 18997                w(k,9) = y(k) + temp*( - w(k,1)*770204740536 &
 18998                                       + w(k,2)*2311639545600 &
 18999                                       - w(k,3)*1322092233000 &
 19000                                       - w(k,4)*453006781920 &
 19001                                       + w(k,5)*326875481856  )
 19002   225       continue
 19003             call fcn(EV,n, x + c(18)/15, w(1,9), w(1,7))
 19004 !
 19005             do 230 k = 1, n
 19006                w(k,9) = y(k) + temp*(   w(k,1)*2845924389000 &
 19007                                       - w(k,2)*9754668000000 &
 19008                                       + w(k,3)*7897110375000 &
 19009                                       - w(k,4)*192082660000 &
 19010                                       + w(k,5)*400298976000 &
 19011                                       + w(k,7)*201586000000  )
 19012   230       continue
 19013             call fcn(EV,n, x + c(18), w(1,9), w(1,8))
 19014 !
 19015 !           calculate ytrial, the extrapolated approximation and store
 19016 !              in w(*,9)
 19017             do 235 k = 1, n
 19018                w(k,9) = y(k) + temp*(   w(k,1)*104862681000 &
 19019                                       + w(k,3)*545186250000 &
 19020                                       + w(k,4)*446637345000 &
 19021                                       + w(k,5)*188806464000 &
 19022                                       + w(k,7)*15076875000 &
 19023                                       + w(k,8)*97599465000   )
 19024   235       continue
 19025 !
 19026 !           add 7 to the no of fcn evals
 19027             c(24) = c(24) + 7
 19028 !
 19029 !        end stage 2
 19030 !
 19031 !        ***************************************************************
 19032 !        * stage 3 - calculate the error estimate est. first calculate *
 19033 !        * the  unweighted  absolute  error  estimate vector (per unit *
 19034 !        * step) for the unextrapolated approximation and store it  in *
 19035 !        * w(*,2).  then  calculate the weighted max norm of w(*,2) as *
 19036 !        * specified by the error  control  indicator  c(1).  finally, *
 19037 !        * modify  this result to produce est, the error estimate (per *
 19038 !        * unit step) for the extrapolated approximation ytrial.       *
 19039 !        ***************************************************************
 19040 !
 19041 !           calculate the unweighted absolute error estimate vector
 19042             do 300 k = 1, n
 19043                w(k,2) = (   w(k,1)*8738556750 &
 19044                           + w(k,3)*9735468750 &
 19045                           - w(k,4)*9709507500 &
 19046                           + w(k,5)*8582112000 &
 19047                           + w(k,6)*95329710000 &
 19048                           - w(k,7)*15076875000 &
 19049                           - w(k,8)*97599465000)/1398169080000
 19050   300       continue
 19051 !
 19052 !           calculate the weighted max norm of w(*,2) as specified by
 19053 !           the error control indicator c(1)
 19054             temp = 0
 19055             if (c(1)  <>  1) go to 310
 19056 !              absolute error control
 19057                do 305 k = 1, n
 19058                   temp = dmax1(temp,dabs(w(k,2)))
 19059   305          continue
 19060                go to 360
 19061   310       if (c(1)  <>  2) go to 320
 19062 !              relative error control
 19063                do 315 k = 1, n
 19064                   temp = dmax1(temp, dabs(w(k,2)/y(k)))
 19065   315          continue
 19066                go to 360
 19067   320       if (c(1)  <>  3) go to 330
 19068 !              weights are 1/max(c(2),abs(y(k)))
 19069                do 325 k = 1, n
 19070                   temp = dmax1(temp, dabs(w(k,2)) &
 19071                                    / dmax1(c(2), dabs(y(k))) )
 19072   325          continue
 19073                go to 360
 19074   330       if (c(1)  <>  4) go to 340
 19075 !              weights are 1/max(c(k+30),abs(y(k)))
 19076                do 335 k = 1, n
 19077                   temp = dmax1(temp, dabs(w(k,2)) &
 19078                                    / dmax1(c(k+30), dabs(y(k))) )
 19079   335          continue
 19080                go to 360
 19081   340       if (c(1)  <>  5) go to 350
 19082 !              weights are 1/c(k+30)
 19083                do 345 k = 1, n
 19084                   temp = dmax1(temp, dabs(w(k,2)/c(k+30)))
 19085   345          continue
 19086                go to 360
 19087   350       continue
 19088 !              default case - weights are 1/max(1,abs(y(k)))
 19089                do 355 k = 1, n
 19090                   temp = dmax1(temp, dabs(w(k,2)) &
 19091                                    / dmax1(1, dabs(y(k))) )
 19092   355          continue
 19093   360       continue
 19094 !
 19095 !           calculate est - (the weighted max norm of w(*,2))*hmag*scale
 19096 !              - est is intended to be a measure of the error  per  unit
 19097 !              step in ytrial
 19098             c(19) = temp*c(14)*c(15)
 19099 !
 19100 !        end stage 3
 19101 !
 19102 !        ***************************************************************
 19103 !        * stage 4 - make decisions.                                   *
 19104 !        ***************************************************************
 19105 !
 19106 !           set ind = 5 if step acceptable, else set ind=6
 19107             ind = 5
 19108             if (c(19)  >  tol) ind = 6
 19109 !
 19110 !***********interrupt no 2 if requested
 19111             if (c(9)  =  0) go to 2222
 19112                return
 19113 !           resume here on re-entry with ind  =  5 or 6   ...re-entry..
 19114  2222       continue
 19115 !
 19116             if (ind  =  6) go to 410
 19117 !              step accepted (ind  =  5), so update x, y from xtrial,
 19118 !                 ytrial, add 1 to the no of successful steps, and set
 19119 !                 the no of successive failures to zero
 19120                x = c(17)
 19121                do 400 k = 1, n
 19122                   y(k) = w(k,9)
 19123   400          continue
 19124                c(22) = c(22) + 1
 19125                c(23) = 0
 19126 !**************return(with ind = 3, xend saved, flag set) if x  =  xend
 19127                if (x  <>  xend) go to 405
 19128                   ind = 3
 19129                   c(20) = xend
 19130                   c(21) = 1
 19131                   return
 19132   405          continue
 19133                go to 420
 19134   410       continue
 19135 !              step not accepted (ind  =  6), so add 1 to the no of
 19136 !                 successive failures
 19137                c(23) = c(23) + 1
 19138 !**************error return (with ind = -3) if hmag < = hmin
 19139                if (c(14)  >  c(13)) go to 415
 19140                   ind = -3
 19141                   return
 19142   415          continue
 19143   420       continue
 19144 !
 19145 !        end stage 4
 19146 !
 19147       go to 99999
 19148 !     end loop
 19149 !
 19150 !  begin abort action
 19151   500 continue
 19152 !
 19153 
 19154       write (*,*) 'Error in dverk, x = ',x, 'xend = ', xend
 19155       call MpiStop()
 19156 !
 19157 !  end abort action
 19158 !
 19159       end subroutine dverk
 19160 
 19161 
 19162 ** tester.f90
 19163 
 19164 !Simple program to get the scalar and tensor Cls, and print them out (and the sum)
 19165 
 19166       program tester
 19167        use CAMB
 19168         implicit none
 19169         integer l
 19170         real(dl) ratio
 19171 
 19172         type(CAMBparams)  P !defined in ModelParams in modules.f90
 19173 
 19174         
 19175         call CAMB_SetDefParams(P)
 19176 
 19177         P%omegab  = .045
 19178         P%omegac  = 0.355
 19179         P%omegav  = 0.6
 19180         P%omegan  = 0.0
 19181         P%H0      = 65
 19182    
 19183         P%InitPower%nn     = 1 !number of initial power spectra
 19184         P%InitPower%an(1)  = 1 !scalar spectral index
 19185         P%InitPower%ant(1) = 0 !tensor spectra index
 19186         P%InitPower%rat(1) = 1 !ratio of initial amplitudes
 19187          !actually we don't use this here since we generate the Cls separately
 19188          !so set to 1, and then put in the ratio after calculating the Cls
 19189 
 19190  
 19191         P%OutputNormalization = outNone
 19192       
 19193         !Generate scalars first so that start with maximum Max_l that is used
 19194         P%WantScalars = .true.
 19195         P%WantTensors = .true.
 19196       
 19197         P%Max_l = 1500
 19198         P%Max_eta_k = 3000
 19199         P%Max_l_tensor = 200
 19200         P%Max_eta_k_tensor = 500
 19201 
 19202         P%AccuratePolarization = .false. !We are only interested in the temperature here
 19203 
 19204         call CAMB_GetResults(P) 
 19205 
 19206         ratio = 0.1
 19207 
 19208         do l = 2,P%Max_l
 19209            !print out scalar and tensor temperature, then sum
 19210            if (l < = P%Max_l_tensor) then
 19211               !The indices of the Cl_xxx arrays are l, initial power spectrum index, Cl type
 19212              write(*,'(1I5,3E15.5)') l, Cl_scalar(l,1, C_Temp), ratio*Cl_tensor(l,1,CT_Temp), &
 19213                    ratio*Cl_tensor(l,1,C_Temp)+Cl_scalar(l,1,C_Temp) 
 19214            else
 19215              write(*,'(1I5,3E15.5)') l,  Cl_scalar(l,1, C_Temp),0,Cl_scalar(l,1,C_Temp) 
 19216            end if
 19217         end do   
 19218 
 19219 
 19220         end program Tester
 19221 
 19222 
 19223 ** utils.f90
 19224 
 19225 !Module of generally useful routines and definitions
 19226 !Antony Lewis, http://cosmologist.info/
 19227 
 19228 !April 2006: fix to TList_RealArr_Thin
 19229 !March 2008: fix to Ranges
 19230 !June 2010: fixed bug in  DeleteFile gradually using up file units
 19231 
 19232  module Ranges
 19233  !A collection of ranges, consisting of sections of minimum step size
 19234   implicit none
 19235 
 19236   integer, parameter :: Max_Ranges = 100
 19237   double precision, parameter :: RangeTol = 0.1 
 19238     !fraction of bin width we are prepared for merged bin widths to increase by
 19239 
 19240   Type Region
 19241     integer start_index
 19242     integer steps
 19243     logical :: IsLog
 19244     double precision Low, High
 19245     double precision delta
 19246     double precision delta_max, delta_min !for log spacing, the non-log max and min step size
 19247   end Type Region
 19248 
 19249   Type Regions
 19250     
 19251      integer count
 19252      integer npoints
 19253      double precision Lowest, Highest
 19254      Type(Region) :: R(Max_ranges)
 19255      logical :: has_dpoints
 19256      double precision, dimension(:), pointer :: points, dpoints
 19257        !dpoints is (points(i+1)-points(i-1))/2
 19258  
 19259   end Type Regions
 19260 
 19261  contains
 19262   
 19263    subroutine Ranges_Init(R)
 19264     Type(Regions) R
 19265 
 19266      call Ranges_Free(R)
 19267     
 19268    end  subroutine Ranges_Init
 19269 
 19270    subroutine Ranges_Free(R)
 19271     Type(Regions) R
 19272     integer status     
 19273 
 19274      deallocate(R%points,stat = status)
 19275      deallocate(R%dpoints,stat = status)
 19276      call Ranges_Nullify(R)
 19277     
 19278    end  subroutine Ranges_Free
 19279 
 19280     
 19281   subroutine Ranges_Nullify(R)
 19282    Type(Regions) R
 19283   
 19284      nullify(R%points)
 19285      nullify(R%dpoints)
 19286      R%count = 0
 19287      R%npoints = 0
 19288      R%has_dpoints = .false.
 19289    
 19290 
 19291   end subroutine Ranges_Nullify
 19292 
 19293   subroutine Ranges_Assign(R,Rin)
 19294    Type(Regions) R, Rin
 19295 
 19296     call Ranges_Init(R)
 19297     R = Rin
 19298     nullify(R%points,R%dpoints)
 19299     if (associated(Rin%points)) then
 19300       call Ranges_GetArray(R, associated(Rin%dpoints))
 19301     end if
 19302   
 19303   end subroutine Ranges_Assign
 19304 
 19305    function Ranges_IndexOf(Reg, tau) result(pointstep)
 19306       Type(Regions), intent(in), target :: Reg
 19307       Type(Region), pointer :: AReg
 19308       double precision :: tau
 19309       integer pointstep
 19310       integer i
 19311 
 19312       
 19313       pointstep = 0
 19314       do i = 1,Reg%count
 19315           AReg = > Reg%R(i)
 19316 
 19317           if (tau < AReg%High .and. tau > = AReg%Low) then
 19318              if (AReg%IsLog) then
 19319               pointstep = AReg%start_index + int( log(tau/AReg%Low)/AReg%delta)
 19320               else
 19321               pointstep = AReg%start_index + int(( tau - AReg%Low)/AReg%delta)
 19322              end if
 19323              return
 19324           end if
 19325 
 19326       end do
 19327 
 19328       if (tau > = Reg%Highest) then
 19329          pointstep = Reg%npoints
 19330       else
 19331        write (*,*) 'Ranges_IndexOf: value out of range'
 19332        stop 
 19333       end if
 19334 
 19335    end function Ranges_IndexOf
 19336 
 19337      
 19338    subroutine Ranges_GetArray(Reg, want_dpoints)
 19339      Type(Regions), target :: Reg
 19340      Type(Region), pointer :: AReg
 19341      logical, intent(in), optional :: want_dpoints 
 19342      integer status,i,j,ix     
 19343      
 19344 
 19345      if (present(want_dpoints)) then
 19346       Reg%has_dpoints = want_dpoints
 19347      else
 19348       Reg%has_dpoints = .true.
 19349      end if
 19350 
 19351      deallocate(Reg%points,stat = status)
 19352      allocate(Reg%points(Reg%npoints)) 
 19353 
 19354      ix = 0   
 19355      do i = 1, Reg%count
 19356        AReg = > Reg%R(i)
 19357        do j = 0, AReg%steps-1
 19358         ix = ix+1
 19359         if (AReg%IsLog) then
 19360          Reg%points(ix) = AReg%Low*exp(j*AReg%delta)
 19361         else
 19362          Reg%points(ix) = AReg%Low + AReg%delta*j
 19363         end if
 19364        end do
 19365      end do
 19366      ix = ix+1
 19367      Reg%points(ix) = Reg%Highest
 19368      if (ix /= Reg%npoints) stop 'Ranges_GetArray: ERROR'
 19369 
 19370      if (Reg%has_dpoints) call Ranges_Getdpoints(Reg)
 19371 
 19372    end subroutine Ranges_GetArray
 19373 
 19374 
 19375    subroutine Ranges_Getdpoints(Reg, half_ends)
 19376       Type(Regions), target :: Reg
 19377       logical, intent(in), optional :: half_ends
 19378       integer i, status
 19379       logical halfs
 19380 
 19381       if (present(half_ends)) then
 19382         halfs = half_ends
 19383       else
 19384         halfs = .true.
 19385       end if
 19386        
 19387       deallocate(Reg%dpoints,stat = status)
 19388       allocate(Reg%dpoints(Reg%npoints)) 
 19389 
 19390       do i = 2, Reg%npoints-1
 19391         Reg%dpoints(i) = (Reg%points(i+1) - Reg%points(i-1))/2
 19392       end do
 19393       if (halfs) then
 19394        Reg%dpoints(1) = (Reg%points(2) - Reg%points(1))/2
 19395        Reg%dpoints(Reg%npoints) = (Reg%points(Reg%npoints) - Reg%points(Reg%npoints-1))/2
 19396       else
 19397        Reg%dpoints(1) = (Reg%points(2) - Reg%points(1))
 19398        Reg%dpoints(Reg%npoints) = (Reg%points(Reg%npoints) - Reg%points(Reg%npoints-1))
 19399      end if
 19400    end subroutine Ranges_Getdpoints
 19401 
 19402 
 19403    subroutine Ranges_Add_delta(Reg, t_start, t_end, t_approx_delta, IsLog)
 19404      Type(Regions), target :: Reg
 19405      logical, intent(in), optional :: IsLog
 19406      double precision, intent(in) :: t_start, t_end, t_approx_delta
 19407      integer n
 19408      logical :: WantLog
 19409 
 19410      if (present(IsLog)) then
 19411         WantLog = IsLog      
 19412      else
 19413         WantLog = .false.    
 19414      end if
 19415      
 19416      if (t_end < = t_start) & 
 19417        stop 'Ranges_Add_delta: end must be larger than start'
 19418      if (t_approx_delta < = 0) stop 'Ranges_Add_delta: delta must be > 0'
 19419 
 19420      if (WantLog) then
 19421       n  = max(1,int(log(t_end/t_start)/t_approx_delta + 1 - RangeTol))
 19422      else
 19423       n  = max(1,int((t_end-t_start)/t_approx_delta + 1 - RangeTol))
 19424      end if
 19425      call Ranges_Add(Reg,t_start, t_end, n, WantLog)
 19426        
 19427    end subroutine Ranges_Add_delta
 19428 
 19429 
 19430    subroutine Ranges_Add(Reg, t_start, t_end, nstep, IsLog)
 19431      Type(Regions), target :: Reg
 19432      logical, intent(in), optional :: IsLog
 19433      double precision, intent(in) :: t_start, t_end
 19434      integer, intent(in) :: nstep
 19435      Type(Region), pointer :: AReg, LastReg
 19436      Type(Region), target :: NewRegions(Max_Ranges)
 19437      double precision EndPoints(0:Max_Ranges*2)
 19438      integer ixin, nreg, ix, i,j, nsteps
 19439      double precision delta
 19440      logical WantLog
 19441      double precision min_request, max_request, min_log_step, max_log_step, diff, max_delta
 19442      double precision RequestDelta(Max_Ranges)
 19443 
 19444      if (present(IsLog)) then
 19445       WantLog = IsLog
 19446      else
 19447       WantLog = .false.
 19448      end if
 19449 
 19450      if (WantLog) then
 19451       delta = log(t_end/t_start) / nstep
 19452      else
 19453       delta = (t_end - t_start) / nstep
 19454      end if
 19455 
 19456      if (t_end < = t_start) stop 'Ranges_Add: end must be larger than start'
 19457      if (nstep < = 0) stop 'Ranges_Add: nstep must be > 0'
 19458      if (Reg%Count> = Max_Ranges) stop 'Ranges_Add: Increase Max_Ranges'
 19459 
 19460 !avoid IBM compiler bug, from Angel de Vicente
 19461 !    if (Reg%count > 0) NewRegions(1:Reg%count) = Reg%R(1:Reg%count)
 19462      if (Reg%count > 0) THEN
 19463          DO i = 1,Reg%count
 19464          NewRegions(i) = Reg%R(i)
 19465          END DO
 19466      END IF
 19467      nreg = Reg%count + 1
 19468      AReg = > NewRegions(nreg)
 19469      AReg%Low = t_start
 19470      AReg%High = t_end
 19471      AReg%delta = delta
 19472      AReg%steps = nstep
 19473      AReg%IsLog = WantLog 
 19474 
 19475 !Get end point in order
 19476      ix = 0
 19477      do i = 1, nreg
 19478 
 19479        AReg = > NewRegions(i)
 19480        if (ix = 0) then
 19481           ix = 1
 19482           EndPoints(ix) = AReg%Low
 19483           ix = 2
 19484           EndPoints(ix) = AReg%High
 19485        else
 19486         ixin = ix
 19487         do j = 1,ixin
 19488          if (AReg%Low < EndPoints(j)) then
 19489            EndPoints(j+1:ix+1) = EndPoints(j:ix)
 19490            EndPoints(j) = AReg%Low
 19491            ix = ix+1
 19492            exit
 19493          end if
 19494         end do
 19495         if (ixin = ix) then
 19496           ix = ix+1
 19497           EndPoints(ix) = AReg%Low
 19498           ix = ix+1
 19499           EndPoints(ix) = AReg%High
 19500         else
 19501             ixin = ix
 19502             do j = 1,ixin
 19503              if (AReg%High < EndPoints(j)) then
 19504                EndPoints(j+1:ix+1) = EndPoints(j:ix)
 19505                EndPoints(j) = AReg%High
 19506                ix = ix+1
 19507                exit
 19508              end if
 19509             end do
 19510             if (ixin = ix) then
 19511               ix = ix+1
 19512               EndPoints(ix) = AReg%High
 19513             end if
 19514                   
 19515         end if
 19516        end if
 19517 
 19518      end do
 19519 
 19520 !remove duplicate points
 19521      ixin = ix
 19522      ix = 1
 19523      do i = 2, ixin
 19524        if (EndPoints(i) /= EndPoints(ix)) then
 19525         ix = ix+1
 19526         EndPoints(ix) = EndPoints(i)
 19527        end if
 19528      end do
 19529     
 19530 
 19531 !ix is the number of end points
 19532      Reg%Lowest = EndPoints(1)
 19533      Reg%Highest = EndPoints(ix)
 19534      Reg%count = 0
 19535 
 19536      max_delta = Reg%Highest - Reg%Lowest
 19537 
 19538      do i = 1, ix - 1
 19539           AReg = > Reg%R(i)
 19540           AReg%Low = EndPoints(i)
 19541           AReg%High = EndPoints(i+1)
 19542           
 19543 !          max_delta = EndPoints(i+1) - EndPoints(i)
 19544           delta = max_delta
 19545           AReg%IsLog = .false.
 19546 
 19547           do j = 1, nreg
 19548            if (AReg%Low > = NewRegions(j)%Low .and. Areg%Low < NewRegions(j)%High) then
 19549              if (NewRegions(j)%IsLog) then
 19550                 if (AReg%IsLog) then
 19551                  delta = min(delta,NewRegions(j)%delta) 
 19552                 else
 19553                  min_log_step = AReg%Low*(exp(NewRegions(j)%delta)-1)
 19554                  if (min_log_step < delta) then
 19555                    max_log_step = AReg%High*(1-exp(-NewRegions(j)%delta)) 
 19556                    if  (delta < max_log_step) then
 19557                      delta = min_log_step
 19558                    else
 19559                      AReg%IsLog = .true.
 19560                      delta = NewRegions(j)%delta 
 19561                    end if 
 19562                  end if
 19563                 end if
 19564              else !NewRegion is not log
 19565               if (AReg%IsLog) then
 19566                 max_log_step = AReg%High*(1-exp(-delta)) 
 19567                 if (NewRegions(j)%delta < max_log_step) then
 19568                   min_log_step = AReg%Low*(exp(delta)-1)
 19569                   if (min_log_step <  NewRegions(j)%delta) then
 19570                      AReg%IsLog = .false.
 19571                      delta =  min_log_step
 19572                   else
 19573                      delta = - log(1- NewRegions(j)%delta/AReg%High)
 19574                   end if
 19575                 end if
 19576               else
 19577                delta = min(delta, NewRegions(j)%delta)  
 19578               end if
 19579              end if
 19580            end if
 19581           end do
 19582 
 19583          if (AReg%IsLog) then
 19584            Diff = log(AReg%High/AReg%Low)
 19585          else
 19586            Diff = AReg%High - AReg%Low
 19587          endif
 19588          if (delta > = Diff) then
 19589            AReg%delta = Diff
 19590            AReg%steps = 1
 19591          else    
 19592            AReg%steps  = max(1,int(Diff/delta + 1 - RangeTol))
 19593            AReg%delta = Diff / AReg%steps
 19594          end if
 19595 
 19596          Reg%count = Reg%count + 1
 19597          RequestDelta(Reg%Count) = delta
 19598 
 19599          if (AReg%IsLog) then
 19600           if (AReg%steps = 1) then
 19601            AReg%Delta_min = AReg%High - AReg%Low
 19602            AReg%Delta_max = AReg%Delta_min
 19603           else
 19604            AReg%Delta_min = AReg%Low*(exp(AReg%delta)-1)
 19605            AReg%Delta_max = AReg%High*(1-exp(-AReg%delta))
 19606           end if
 19607          else
 19608            AReg%Delta_max = AReg%delta
 19609            AReg%Delta_min = AReg%delta
 19610          end if
 19611      end do
 19612 
 19613 
 19614 !Get rid of tiny regions
 19615      ix = Reg%Count
 19616      do i = ix, 1, -1  
 19617          AReg = > Reg%R(i)
 19618          if (AReg%steps = 1) then
 19619               Diff = AReg%High - AReg%Low
 19620               if (AReg%IsLog) then
 19621                min_request = AReg%Low*(exp(RequestDelta(i))-1)
 19622                max_request = AReg%High*(1-exp(-RequestDelta(i)))
 19623               else
 19624                min_request = RequestDelta(i)
 19625                max_request = min_request
 19626               end if
 19627               if (i/= Reg%Count) then  !from i/= ix Mar08
 19628                LastReg = > Reg%R(i+1)
 19629                if (RequestDelta(i) > = AReg%delta .and. Diff < = LastReg%Delta_min &
 19630                           .and. LastReg%Delta_min < = max_request) then 
 19631 
 19632                    LastReg%Low = AReg%Low
 19633                    if (Diff > LastReg%Delta_min*RangeTol) then
 19634                       LastReg%steps =  LastReg%steps + 1
 19635                    end if
 19636                    if (LastReg%IsLog) then
 19637                       LastReg%delta = log(LastReg%High/LastReg%Low) / LastReg%steps 
 19638                    else
 19639                       LastReg%delta = (LastReg%High -LastReg%Low) / LastReg%steps 
 19640                    end if
 19641                    Reg%R(i:Reg%Count-1) = Reg%R(i+1:Reg%Count)
 19642                    Reg%Count = Reg%Count -1
 19643                    cycle
 19644                end if          
 19645               end if
 19646               if (i/= 1) then
 19647                LastReg = > Reg%R(i-1)
 19648                if (RequestDelta(i) > = AReg%delta .and. Diff < = LastReg%Delta_max &
 19649                           .and. LastReg%Delta_max < = min_request) then
 19650                    LastReg%High = AReg%High
 19651                    !AlMat08 LastReg%Low = AReg%Low
 19652                    if (Diff > LastReg%Delta_max*RangeTol) then
 19653                       LastReg%steps =  LastReg%steps + 1
 19654                    end if
 19655                    if (LastReg%IsLog) then
 19656                       LastReg%delta = log(LastReg%High/LastReg%Low) / LastReg%steps 
 19657                    else
 19658                       LastReg%delta = (LastReg%High -LastReg%Low) / LastReg%steps 
 19659                    end if
 19660                    Reg%R(i:Reg%Count-1) = Reg%R(i+1:Reg%Count)
 19661                    Reg%Count = Reg%Count -1
 19662                end if
 19663               end if           
 19664          end if       
 19665      end do
 19666 
 19667 
 19668 !Set up start indices and get total number of steps
 19669     nsteps = 1
 19670     do i = 1, Reg%Count
 19671          AReg = > Reg%R(i)
 19672          AReg%Start_index = nsteps
 19673          nsteps = nsteps + AReg%steps
 19674          if (AReg%IsLog) then
 19675           if (AReg%steps = 1) then
 19676            AReg%Delta_min = AReg%High - AReg%Low
 19677            AReg%Delta_max = AReg%Delta_min
 19678           else
 19679            AReg%Delta_min = AReg%Low*(exp(AReg%delta)-1)
 19680            AReg%Delta_max = AReg%High*(1-exp(-AReg%delta))
 19681           end if
 19682          else
 19683            AReg%Delta_max = AReg%delta
 19684            AReg%Delta_min = AReg%delta
 19685          end if
 19686     end do
 19687 
 19688     Reg%npoints = nsteps
 19689 
 19690    end subroutine Ranges_Add
 19691 
 19692 
 19693    subroutine Ranges_Write(Reg) 
 19694       Type(Regions), intent(in), target :: Reg
 19695       Type(Region), pointer :: AReg
 19696       integer i
 19697 
 19698       do i = 1,Reg%count
 19699           AReg = > Reg%R(i)
 19700           if (AReg%IsLog) then
 19701            Write (*,'("Range ",I3,":", 3E14.4," log")') i, AReg%Low, AReg%High, AReg%delta 
 19702           else
 19703            Write (*,'("Range ",I3,":", 3E14.4," linear")') i, AReg%Low, AReg%High, AReg%delta 
 19704           end if
 19705       end do
 19706    end subroutine Ranges_Write
 19707 
 19708 
 19709  end module Ranges
 19710 
 19711 
 19712  module Lists
 19713   !Currently implements lists of strings and lists of arrays of reals
 19714   implicit none
 19715 
 19716   type real_pointer
 19717     real, dimension(:), pointer :: p 
 19718   end type real_pointer
 19719 
 19720   type double_pointer
 19721     double precision, dimension(:), pointer :: p 
 19722   end type double_pointer
 19723 
 19724   type String_pointer
 19725     character, dimension(:), pointer :: p
 19726   end type String_pointer
 19727 
 19728 
 19729   Type TList_RealArr
 19730     integer Count
 19731     integer Delta
 19732     integer Capacity
 19733     type(Real_Pointer), dimension(:), pointer :: Items 
 19734   end Type TList_RealArr
 19735 
 19736   Type TStringList
 19737     integer Count
 19738     integer Delta
 19739     integer Capacity 
 19740     type(String_Pointer), dimension(:), pointer :: Items
 19741   end Type TStringList
 19742 
 19743  contains
 19744  
 19745    subroutine TList_RealArr_Init(L)
 19746     Type (TList_RealArr) :: L
 19747     
 19748      L%Count = 0
 19749      L%Capacity = 0
 19750      L%Delta = 1024
 19751      nullify(L%items)
 19752 
 19753    end subroutine TList_RealArr_Init
 19754 
 19755    subroutine TList_RealArr_Clear(L)
 19756     Type (TList_RealArr) :: L
 19757     integer i, status
 19758      
 19759      do i = L%Count,1,-1 
 19760        deallocate (L%Items(i)%P, stat = status)
 19761      end do
 19762     deallocate (L%Items, stat = status)
 19763     nullify(L%Items)
 19764     L%Count = 0
 19765     L%Capacity = 0
 19766 
 19767    end subroutine TList_RealArr_Clear
 19768 
 19769     
 19770    subroutine TList_RealArr_Add(L, P)
 19771     Type (TList_RealArr) :: L
 19772     real, intent(in) :: P(:)
 19773     integer s
 19774   
 19775     if (L%Count = L%Capacity) call TList_RealArr_SetCapacity(L, L%Capacity + L%Delta)
 19776     s = size(P)
 19777     L%Count = L%Count + 1
 19778     allocate(L%Items(L%Count)%P(s))
 19779     L%Items(L%Count)%P = P
 19780 
 19781    end subroutine TList_RealArr_Add
 19782 
 19783    subroutine TList_RealArr_SetCapacity(L, C)
 19784     Type (TList_RealArr) :: L
 19785     integer C
 19786     type(Real_Pointer), dimension(:), pointer :: TmpItems
 19787     
 19788     if (L%Count > 0) then
 19789       if (C < L%Count) stop 'TList_RealArr_SetCapacity: smaller than Count'
 19790       allocate(TmpItems(L%Count))
 19791       TmpItems = L%Items(1:L%Count)
 19792       deallocate(L%Items)
 19793       allocate(L%Items(C))
 19794       L%Items(1:L%Count) = TmpItems
 19795       deallocate(TmpItems)
 19796     else
 19797      allocate(L%Items(C))
 19798     end if  
 19799     L%Capacity = C
 19800    end subroutine TList_RealArr_SetCapacity
 19801 
 19802    subroutine TList_RealArr_Delete(L, i)
 19803     Type (TList_RealArr) :: L
 19804     integer, intent(in) :: i
 19805     integer status
 19806      
 19807      deallocate(L%items(i)%P, stat = status)
 19808      if (L%Count > 1) L%Items(i:L%Count-1) = L%Items(i+1:L%Count)
 19809      L%Count = L%Count -1
 19810      
 19811    end subroutine TList_RealArr_Delete
 19812 
 19813    subroutine TList_RealArr_SaveBinary(L,fid)
 19814     Type (TList_RealArr) :: L
 19815     integer, intent(in) :: fid
 19816     integer i
 19817      
 19818       write (fid) L%Count
 19819       do i = 1,L%Count
 19820        write(fid) size(L%Items(i)%P)
 19821        write(fid) L%Items(i)%P
 19822       end do
 19823 
 19824    end subroutine TList_RealArr_SaveBinary
 19825 
 19826    subroutine TList_RealArr_ReadBinary(L,fid)
 19827     Type (TList_RealArr) :: L
 19828     integer, intent(in) :: fid
 19829     integer num,i,sz
 19830      
 19831       call TList_RealArr_Clear(L) 
 19832       read (fid) num
 19833       call TList_RealArr_SetCapacity(L, num)
 19834       do i = 1,num
 19835        read(fid) sz
 19836        allocate(L%Items(i)%P(sz))
 19837        read(fid) L%Items(i)%P
 19838       end do
 19839       L%Count = num
 19840 
 19841    end subroutine TList_RealArr_ReadBinary
 19842 
 19843 
 19844    subroutine TList_RealArr_Thin(L, i)
 19845     Type (TList_RealArr) :: L
 19846     integer, intent(in) :: i
 19847     integer newCount
 19848     type(Real_Pointer), dimension(:), pointer :: TmpItems
 19849     
 19850     if (L%Count > 1) then
 19851       newCount = (L%Count-1)/i+1
 19852       allocate(TmpItems(newCount))
 19853       TmpItems = L%Items(1:L%Count:i)
 19854       deallocate(L%Items)
 19855       L%Capacity = newCount
 19856       allocate(L%Items(L%Capacity))
 19857       L%Items = TmpItems
 19858       L%Count = newCount
 19859       deallocate(TmpItems)
 19860     end if    
 19861    end subroutine TList_RealArr_Thin
 19862 
 19863    subroutine TList_RealArr_ConfidVal(L, ix, limfrac, ix1, ix2, Lower, Upper)
 19864    !Taking the ix'th entry in each array to be a sample, value for which
 19865    !limfrac of the items between ix1 and ix2 (inc) are above or below
 19866    !e.g. if limfrac = 0.05 get two tail 90% confidence limits
 19867      Type (TList_RealArr) :: L
 19868      integer, intent(IN) :: ix
 19869      real, intent(IN) :: limfrac
 19870      real, intent(OUT), optional :: Lower, Upper
 19871      integer, intent(IN), optional :: ix1,ix2
 19872      integer b,t,samps
 19873      real pos, d
 19874      type(Real_Pointer), dimension(:), pointer :: SortItems
 19875     
 19876      b = 1
 19877      t = L%Count
 19878      if (present(ix1)) b = ix1
 19879      if (present(ix2)) t = ix2
 19880      samps = t - b + 1
 19881   
 19882      allocate(SortItems(samps))
 19883      SortItems = L%Items(b:t)
 19884      call QuickSortArr_Real(SortItems, 1, samps, ix)
 19885      if (present(Lower)) then
 19886        pos = (samps-1)*limfrac + 1 
 19887        b = max(int(pos),1)
 19888        Lower = SortItems(b)%P(ix)
 19889       if (b < samps .and. pos>b) then
 19890        d = pos - b
 19891        Lower = Lower*(1 - d) + d * SortItems(b+1)%P(ix) 
 19892       end if
 19893      end if
 19894      if (present(Upper)) then
 19895       pos = (samps-1)*(1.-limfrac) + 1
 19896       b = max(int(pos),1)
 19897       Upper = SortItems(b)%P(ix)
 19898       if (b < samps .and. pos>b) then
 19899        d = pos - b
 19900        Upper = Upper*(1 - d) + d * SortItems(b+1)%P(ix) 
 19901       end if
 19902      end if
 19903    
 19904      deallocate(SortItems)
 19905 
 19906     end subroutine TList_RealArr_ConfidVal
 19907 
 19908    subroutine TStringList_Init(L)
 19909     Type (TStringList) :: L
 19910     
 19911      L%Count = 0
 19912      L%Capacity = 0
 19913      L%Delta = 128
 19914      nullify(L%items)
 19915      
 19916    end subroutine TStringList_Init
 19917 
 19918    subroutine TStringList_Clear(L)
 19919     Type (TStringList) :: L
 19920     integer i, status
 19921      
 19922      do i = L%Count,1,-1 
 19923        deallocate (L%Items(i)%P, stat = status)
 19924      end do
 19925     deallocate (L%Items, stat = status)
 19926     call TStringList_Init(L)
 19927 
 19928    end subroutine TStringList_Clear
 19929 
 19930    subroutine TStringList_SetFromString(L, S, valid_chars_in)
 19931     Type (TStringList) :: L
 19932     character(Len = *), intent(in) :: S
 19933     character(Len = *), intent(in), optional :: valid_chars_in
 19934     character(LEN = 1024) item
 19935     integer i,j
 19936     character(LEN = 256) valid_chars
 19937     
 19938     if (present(valid_chars_in)) then
 19939        valid_chars = valid_chars_in
 19940     else
 19941        valid_chars = 'abcdefghijklmopqrstuvwxyzABCDEFGHIJKLMOPQRSTUVWXYZ0123456789_-.'
 19942     endif
 19943 
 19944      call TStringList_Clear(L)
 19945      item = '' 
 19946      j = 0
 19947      do i = 1, len_trim(S)
 19948         if (verify(S(i:i),trim(valid_chars)) = 0) then
 19949           j = j+1
 19950           item(j:j) = S(i:i)
 19951         else
 19952           if (trim(S(i:i))/= '') then
 19953            write (*,*) 'Invalid character in: '//trim(S)
 19954           end if 
 19955           if (j>0) call TStringList_Add(L, item(1:j))
 19956           j = 0
 19957         end if          
 19958      end do
 19959      if (j>0) call TStringList_Add(L, item(1:j))
 19960    
 19961    end subroutine TStringList_SetFromString
 19962 
 19963 
 19964     
 19965    subroutine TStringList_Add(L, P)
 19966     Type (TStringList) :: L
 19967     character(LEN = *), intent(in) :: P
 19968     integer s,i
 19969   
 19970     if (L%Count = L%Capacity) call TStringList_SetCapacity(L, L%Capacity + L%Delta)
 19971     s = len_trim(P)
 19972     L%Count = L%Count + 1
 19973     allocate(L%Items(L%Count)%P(s))
 19974     do i = 1,s
 19975     L%Items(L%Count)%P(i) = P(i:i)
 19976     end do
 19977    end subroutine TStringList_Add
 19978 
 19979    function TStringList_Item(L, i) result(S)
 19980     Type (TStringList) :: L
 19981     integer, intent(in) :: i
 19982     integer j
 19983     character(LEN = 1024) S
 19984 
 19985     S = ''
 19986     if (i< = L%Count .and. i>0) then
 19987      do j = 1,size(L%Items(i)%P)
 19988        S(j:j) = L%Items(i)%P(j)       
 19989      end do
 19990     end if
 19991    end function TStringList_Item
 19992 
 19993    subroutine TStringList_SetCapacity(L, C)
 19994     Type (TStringList) :: L
 19995     integer C
 19996     type(String_Pointer), dimension(:), pointer :: TmpItems
 19997     
 19998     if (L%Count > 0) then
 19999       if (C < L%Count) stop 'TStringList_SetCapacity: smaller than Count'
 20000       allocate(TmpItems(L%Count))
 20001       TmpItems = L%Items(1:L%Count)
 20002       deallocate(L%Items)
 20003       allocate(L%Items(C))
 20004       L%Items(1:L%Count) = TmpItems
 20005       deallocate(TmpItems)
 20006     else
 20007      allocate(L%Items(C))
 20008     end if  
 20009     L%Capacity = C
 20010   
 20011    end subroutine TStringList_SetCapacity
 20012 
 20013    subroutine TStringList_Delete(L, i)
 20014     Type (TStringList) :: L
 20015     integer, intent(in) :: i
 20016     integer status
 20017      
 20018      deallocate(L%items(i)%P, stat = status)
 20019      if (L%Count > 1) L%Items(i:L%Count-1) = L%Items(i+1:L%Count)
 20020      L%Count = L%Count -1
 20021      
 20022    end subroutine TStringList_Delete
 20023 
 20024    function TStringList_IndexOf(L, S)
 20025     Type (TStringList) :: L
 20026     character(LEN = *), intent(in) :: S
 20027     integer TStringList_IndexOf, i, j,slen
 20028 
 20029     slen = len_trim(S)
 20030     do i = 1,L%Count
 20031      if ( size(L%Items(i)%P) = slen) then
 20032  !Yes, comparing strings and pointer strings really is this horrible...
 20033        j = 1
 20034        do while (L%Items(i)%P(j) = S(j:j)) 
 20035           j = j+1
 20036           if (j>slen) then
 20037             TStringList_IndexOf = i
 20038             return         
 20039           end if
 20040        end do
 20041      end if
 20042     end do
 20043     TStringList_IndexOf = -1
 20044      
 20045    end function TStringList_IndexOf
 20046 
 20047 
 20048       recursive subroutine QuickSortArr_Real(Arr, Lin, R, index)
 20049       !Sorts an array of pointers to arrays of reals by the value of the index'th entry
 20050       integer, intent(in) :: Lin, R, index
 20051 !ifdef __GFORTRAN__
 20052       type(real_pointer), dimension(:) :: Arr
 20053 !else
 20054       type(real_pointer), dimension(*) :: Arr
 20055 !endif
 20056       integer I, J, L
 20057       real P
 20058       type(real_pointer) :: temp
 20059   
 20060       L = Lin
 20061       do
 20062 
 20063       I = L
 20064       J = R
 20065       P = Arr((L + R)/2)%p(index)
 20066    
 20067       do
 20068       do while (Arr(I)%p(index) <  P) 
 20069          I = I + 1
 20070       end do
 20071     
 20072       do while (Arr(J)%p(index) > P) 
 20073          J = J - 1
 20074       end do
 20075 
 20076       if (I < = J) then
 20077      
 20078        Temp%p = > Arr(I)%p
 20079        Arr(I)%p = > Arr(J)%p
 20080        Arr(J)%p = > Temp%p
 20081        I = I + 1
 20082        J = J - 1
 20083       end if
 20084       if (I > J) exit
 20085       
 20086       end do
 20087     if (L < J) call QuickSortArr_Real(Arr, L, J, index);
 20088     L = I
 20089     if (I > = R) exit
 20090     end do
 20091 
 20092     end subroutine QuickSortArr_Real
 20093 
 20094 
 20095 
 20096     recursive subroutine QuickSortArr(Arr, Lin, R, index)
 20097       !Sorts an array of pointers to arrays of reals by the value of the index'th entry
 20098       integer, intent(in) :: Lin, R, index
 20099 !ifdef __GFORTRAN__
 20100       type(double_pointer), dimension(:) :: Arr
 20101 !else
 20102       type(double_pointer), dimension(*) :: Arr
 20103 !endif
 20104       integer I, J, L
 20105       double precision P
 20106       type(double_pointer) :: temp
 20107   
 20108       L = Lin
 20109       do
 20110 
 20111       I = L
 20112       J = R
 20113       P = Arr((L + R)/2)%p(index)
 20114    
 20115       do
 20116       do while (Arr(I)%p(index) <  P) 
 20117          I = I + 1
 20118       end do
 20119     
 20120       do while (Arr(J)%p(index) > P) 
 20121          J = J - 1
 20122       end do
 20123 
 20124       if (I < = J) then
 20125      
 20126        Temp%p = > Arr(I)%p
 20127        Arr(I)%p = > Arr(J)%p
 20128        Arr(J)%p = > Temp%p
 20129        I = I + 1
 20130        J = J - 1
 20131       end if
 20132       if (I > J) exit
 20133       
 20134       end do
 20135     if (L < J) call QuickSortArr(Arr, L, J, index);
 20136     L = I
 20137     if (I > = R) exit
 20138     end do
 20139 
 20140     end subroutine QuickSortArr
 20141 
 20142 
 20143  end module Lists
 20144 
 20145   module AMLutils
 20146   use Lists
 20147        
 20148 !ifdef DECONLY
 20149    !Comment out if linking to LAPACK/MKL separetly 
 20150    !CXML only has LAPACK 2.0
 20151     include 'CXML_INCLUDE.F90'
 20152 !endif
 20153  
 20154 
 20155 !ifdef NAGF95
 20156         use F90_UNIX
 20157 !endif
 20158 
 20159      implicit none
 20160 
 20161 !ifndef NAGF95
 20162 !ifndef GFC
 20163 !ifndef __INTEL_COMPILER_BUILD_DATE
 20164 !ifndef __GFORTRAN__
 20165         integer iargc
 20166         external iargc
 20167 !endif        
 20168 !endif
 20169 !endif
 20170 !endif
 20171 
 20172 
 20173 !ifdef MPI
 20174     include "mpif.h"
 20175 !endif
 20176 
 20177   integer :: Feedback = 1
 20178   integer, parameter :: tmp_file_unit = 50
 20179 
 20180 
 20181   double precision, parameter :: pi = 3.14159265358979323846264338328, &
 20182       twopi = 2*pi, fourpi = 4*pi
 20183   double precision, parameter :: root2 = 1.41421356237309504880168872421, sqrt2 = root2
 20184   double precision, parameter :: log2 = 0.693147180559945309417232121458
 20185 
 20186   real, parameter :: pi_r = 3.141592653, twopi_r = 2*pi_r, fourpi_r = twopi_r*2
 20187 
 20188   logical :: flush_write = .true.
 20189     !True means no data lost on crashes, but may make it slower
 20190     
 20191   integer, parameter :: file_units_start = 20
 20192   integer, parameter :: file_units_end = 100
 20193   
 20194   logical file_units(file_units_start:file_units_end)
 20195 
 20196   INTERFACE CONCAT
 20197     module procedure concat_s, concat_s_n
 20198     
 20199   END INTERFACE
 20200 
 20201 
 20202 
 20203   contains
 20204 
 20205  function new_file_unit()
 20206   integer i, new_file_unit
 20207   logical, save :: file_units_inited = .false.
 20208   logical notfree
 20209  
 20210   if (.not. file_units_inited) then
 20211    file_units = .false.
 20212    file_units_inited = .true.
 20213   end if
 20214  
 20215   do i = file_units_start, file_units_end
 20216    if (.not. file_units(i) .and. i/= tmp_file_unit) then
 20217     inquire(i,opened = notfree)
 20218     if (notfree) cycle
 20219     file_units(i) = .true.
 20220     new_file_unit = i
 20221     return
 20222    end if
 20223   end do 
 20224   
 20225   call mpiStop('No unused file unit numbers')
 20226   
 20227  end function new_file_unit
 20228 
 20229 
 20230  subroutine CloseFile(i)
 20231   integer, intent(in) :: i
 20232   
 20233   close(i)
 20234   file_units(i) = .false.
 20235     
 20236  end subroutine CloseFile 
 20237 
 20238  subroutine ClearFileUnit(i)
 20239   integer, intent(in) :: i
 20240   
 20241   file_units(i) = .false.
 20242     
 20243  end subroutine ClearFileUnit
 20244 
 20245   function GetParamCount()
 20246    integer GetParamCount
 20247  
 20248     GetParamCount = iargc() 
 20249 
 20250   end function GetParamCount
 20251 
 20252   function GetMpiRank()
 20253   integer GetMpiRank
 20254 !ifdef MPI 
 20255    integer ierror
 20256    call mpi_comm_rank(mpi_comm_world,GetMPIrank,ierror)
 20257 !else
 20258     GetMpiRank = 0
 20259 !endif    
 20260    
 20261   end function GetMpiRank
 20262 
 20263   function IsMainMPI()
 20264    logical IsMainMPI
 20265 
 20266    IsMainMPI =  GetMpiRank() = 0
 20267    
 20268   end function IsMainMPI
 20269 
 20270   subroutine MpiStop(Msg)
 20271    character(LEN = *), intent(in), optional :: Msg
 20272    integer i
 20273 !ifdef MPI 
 20274    integer ierror, MpiRank
 20275 !endif
 20276 
 20277    if (present(Msg)) write(*,*) trim(Msg)
 20278    
 20279 !ifdef MPI
 20280     call mpi_comm_rank(mpi_comm_world,MPIrank,ierror)
 20281     write (*,*) 'MpiStop: ', MpiRank
 20282     call MPI_ABORT(MPI_COMM_WORLD,i)
 20283 !endif
 20284     i = 1     !put breakpoint on this line to debug
 20285     stop
 20286     
 20287  end subroutine MpiStop
 20288  
 20289    subroutine MpiStat(MpiID, MpiSize)
 20290    implicit none
 20291    integer MpiID,MpiSize  
 20292 !ifdef MPI  
 20293    integer ierror
 20294         call mpi_comm_rank(mpi_comm_world,MpiID,ierror)
 20295         if (ierror/= MPI_SUCCESS) stop 'MpiStat: MPI rank'
 20296         call mpi_comm_size(mpi_comm_world,MpiSize,ierror)
 20297 !else
 20298   MpiID = 0
 20299   MpiSize = 1   
 20300 !endif
 20301   end subroutine MpiStat
 20302                   
 20303   subroutine MpiQuietWait
 20304   !Set MPI thread to sleep, e.g. so can run openmp on cpu instead
 20305 !ifdef MPI  
 20306      integer flag, ierr, STATUS(MPI_STATUS_SIZE)
 20307      integer i, MpiId, MpiSize
 20308        
 20309      call MpiStat(MpiID, MpiSize)
 20310      if (MpiID/= 0) then  
 20311       do
 20312        call MPI_IPROBE(0,0,MPI_COMM_WORLD,flag, MPI_STATUS_IGNORE,ierr)
 20313        if (flag/= 0) then
 20314              call MPI_RECV(i,1,MPI_INTEGER, 0,0,MPI_COMM_WORLD,status,ierr)
 20315              exit
 20316        end if
 20317        call sleep(1)
 20318       end do
 20319      end if 
 20320 !endif
 20321   end subroutine
 20322   
 20323   subroutine MpiWakeQuietWait
 20324 !ifdef MPI  
 20325     integer j, MpiId, MpiSize, ierr,r
 20326        
 20327      call MpiStat(MpiID, MpiSize)
 20328      if (MpiID = 0) then
 20329      do j = 1, MpiSize-1              
 20330            call MPI_ISSEND(MpiId,1,MPI_INTEGER, j,0,MPI_COMM_WORLD,r,ierr)
 20331      end do  
 20332      end if
 20333 !endif
 20334   end subroutine MpiWakeQuietWait
 20335  
 20336 !ifdef __GFORTRAN__
 20337   
 20338   ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 20339   function iargc ()
 20340     ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 20341     integer iargc
 20342     ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 20343     
 20344     iargc = command_argument_count()
 20345   end function iargc
 20346   
 20347   ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 20348   subroutine getarg(num, res)
 20349     ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 20350     integer, intent(in) :: num
 20351     character(len = *), intent(out) :: res
 20352     integer l, err
 20353     ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 20354     call get_command_argument(num,res,l,err)
 20355   end subroutine getarg
 20356   
 20357 !endif
 20358 
 20359 
 20360   function GetParam(i)
 20361 
 20362    character(LEN = 512) GetParam
 20363    integer, intent(in) :: i
 20364  
 20365    if (iargc() < i) then
 20366      GetParam = ''
 20367    else
 20368     call getarg(i,GetParam)
 20369    end if
 20370   end function GetParam
 20371 
 20372   function concat_s(S1,S2,S3,S4,S5,S6,S7,S8) result(concat)
 20373    character(LEN = *), intent(in) :: S1, S2
 20374    character(LEN = *), intent(in) , optional :: S3, S4, S5, S6,S7,S8
 20375    character(LEN = 1000) concat
 20376 
 20377    concat = trim(S1) // S2
 20378    if (present(S3)) then
 20379     concat = trim(concat) // S3
 20380      if (present(S4)) then
 20381        concat = trim(concat) // S4
 20382        if (present(S5)) then
 20383          concat = trim(concat) // S5
 20384            if (present(S6)) then
 20385              concat = trim(concat) // S6
 20386               if (present(S7)) then
 20387                 concat = trim(concat) // S7
 20388                 if (present(S8)) then
 20389                   concat = trim(concat) // S8
 20390                 end if
 20391               end if    
 20392            end if
 20393        end if
 20394      end if
 20395    end if
 20396 
 20397   end function concat_s
 20398 
 20399  function concat_s_n(SS1,N2,SS3,N4,SS5,N6,SS7,N8,SS9,N10,SS11) result(concat)
 20400    character(LEN = *), intent(in) :: SS1
 20401    integer, intent(in) :: N2
 20402    character(LEN = *), intent(in) , optional :: SS3, SS5, SS7, SS9,SS11
 20403    integer, intent(in), optional ::N4,N6,N8, N10
 20404    character(LEN = 1000) concat
 20405    
 20406    concat = trim(SS1) //trim(IntToStr(N2))
 20407      if (present(SS3)) then
 20408     concat = trim(concat) // SS3
 20409      if (present(N4)) then
 20410        concat = trim(concat) // trim(IntToStr(N4))
 20411        if (present(SS5)) then
 20412          concat = trim(concat) // SS5
 20413            if (present(N6)) then
 20414              concat = trim(concat) // trim(intToStr(N6))
 20415              if (present(SS7)) then
 20416              concat = trim(concat) // SS7
 20417               if (present(N8)) then
 20418                concat = trim(concat) // trim(intToStr(N8))
 20419               if (present(SS9)) then
 20420                concat = trim(concat) // SS9
 20421                 if (present(N10)) then
 20422                 concat = trim(concat) // trim(intToStr(N10))
 20423                   if (present(SS11)) then
 20424                    concat = trim(concat) // SS11
 20425                   end if
 20426                 end if
 20427               end if       
 20428            end if
 20429        end if
 20430      end if
 20431    end if
 20432    end if
 20433    end if
 20434    
 20435  end  function concat_s_n
 20436 
 20437   subroutine Exchange(i1,i2)
 20438    integer i1,i2,tmp
 20439  
 20440    tmp = i1
 20441    i1 = i2
 20442    i2 = tmp
 20443 
 20444   end subroutine Exchange
 20445 
 20446   subroutine WriteS(S)
 20447    character(LEN = *), intent(in) :: S
 20448 
 20449     write (*,*) trim(S)
 20450  
 20451   end subroutine WriteS
 20452 
 20453   subroutine StringReplace(FindS, RepS, S)
 20454    character(LEN = *), intent(in) :: FindS, RepS
 20455    character(LEN = *), intent(inout) :: S
 20456    integer i
 20457    
 20458    i = index(S,FindS)
 20459    if (i>0) then
 20460      S = S(1:i-1)//trim(RepS)//S(i+len_trim(FindS):len_trim(S))
 20461    end if
 20462 
 20463   end subroutine StringReplace
 20464 
 20465   function numcat(S, num)
 20466    character(LEN = *) S
 20467    character(LEN = 120) numcat, numstr
 20468    integer num
 20469 
 20470    write (numstr, *) num
 20471    numcat = trim(S) // trim(adjustl(numstr))
 20472    !OK, so can probably do with with a format statement too... 
 20473   end function numcat
 20474 
 20475   function LogicalToint(B)
 20476    integer LogicalToint
 20477    logical, intent(in) :: B
 20478    
 20479    if (B) then
 20480     LogicalToInt = 1
 20481    else
 20482     LogicalToint = 0
 20483    end if  
 20484    
 20485   end function LogicalToInt
 20486  
 20487   function IntToLogical(I)
 20488    integer, intent(in) :: I
 20489    logical IntToLogical
 20490    
 20491    IntToLogical = I /= 0
 20492    
 20493   end  function IntToLogical
 20494  
 20495   function IntToStr(I, minlen)
 20496    integer , intent(in) :: I
 20497    character(LEN = 30) IntToStr
 20498    integer, intent(in), optional :: minlen
 20499    integer n
 20500    character (LEN = 20) :: form
 20501 
 20502    if (present(minlen)) then
 20503     n = minlen
 20504     if (I<0) n = n+1
 20505     form = concat('(I',n,'.',minlen,')')
 20506     write (IntToStr,form) i
 20507    else
 20508     write (IntToStr,*) i
 20509     IntToStr = adjustl(IntToStr)
 20510    end if
 20511 
 20512  
 20513   end function IntToStr
 20514 
 20515   function StrToInt(S)
 20516    integer :: StrToInt
 20517    character(LEN = 30), intent(in) :: S
 20518 
 20519    read (S,*) StrToInt
 20520   end function StrToInt
 20521 
 20522 
 20523    function RealToStr(R, figs)
 20524    real, intent(in) :: R
 20525    integer, intent(in), optional :: figs
 20526    character(LEN = 30) RealToStr
 20527 
 20528     if (abs(R)> = 0.001 .or. R = 0.) then
 20529      write (RealToStr,'(f12.6)') R
 20530 
 20531    RealToStr = adjustl(RealToStr)
 20532    if (present(figs)) then
 20533     RealToStr = RealToStr(1:figs)
 20534    else
 20535     RealToStr = RealToStr(1:6)  
 20536    end if
 20537 
 20538     else
 20539      if (present(figs)) then
 20540       write (RealToStr,trim(numcat('(E',figs))//'.2)') R
 20541      else
 20542       write (RealToStr,'(G9.2)') R
 20543      end if
 20544      RealToStr = adjustl(RealToStr)
 20545     end if
 20546         
 20547 
 20548   end function RealToStr
 20549   
 20550   function IndexOf(aval,arr, n)
 20551      integer, intent(in) :: n, arr(n), aval
 20552      integer IndexOf, i
 20553 
 20554      do i = 1,n
 20555         if (arr(i) = aval) then
 20556           IndexOf = i
 20557           return
 20558         end if
 20559      end do
 20560     IndexOf = 0
 20561 
 20562   end function IndexOf
 20563 
 20564   function MaxIndex(arr, n)
 20565      integer, intent(in) :: n
 20566      real, intent(in) :: arr(n)
 20567      integer locs(1:1), MaxIndex
 20568 
 20569      locs = maxloc(arr(1:n))
 20570      MaxIndex = locs(1)
 20571 
 20572   end function MaxIndex
 20573 
 20574  
 20575   function MinIndex(arr, n)
 20576      integer, intent(in) :: n
 20577      real, intent(in) :: arr(n)
 20578      integer locs(1:1), MinIndex
 20579 
 20580      locs = minloc(arr(1:n))
 20581      MinIndex = locs(1)
 20582 
 20583   end function MinIndex
 20584 
 20585 
 20586    subroutine TList_RealArr_SaveToFile(L,fname)
 20587     character(LEN = *), intent(IN) :: fname
 20588     Type (TList_RealArr) :: L
 20589     character(LEN = 20) aform
 20590     integer i
 20591     integer :: Plen = -1
 20592     integer :: file_id
 20593 
 20594     file_id = new_file_unit()
 20595     call CreateTxtFile(fname,file_id)
 20596     do i = 1, L%Count 
 20597      if (PLen /= size(L%Items(i)%P)) then
 20598       PLen = size(L%Items(i)%P)
 20599       aform = '('//trim(IntToStr(PLen))//'E16.8)'
 20600      end if 
 20601      write (file_id,aform) L%Items(i)%P
 20602     end do
 20603     call CloseFile(file_id)   
 20604 
 20605    end subroutine TList_RealArr_SaveToFile
 20606 
 20607 
 20608   function ExtractFilePath(aname)
 20609     character(LEN = *), intent(IN) :: aname
 20610     character(LEN = 1024) ExtractFilePath
 20611     integer len, i
 20612 
 20613     len = len_trim(aname)
 20614     do i = len, 1, -1
 20615        if (aname(i:i) = '/') then
 20616           ExtractFilePath = aname(1:i)
 20617           return
 20618        end if
 20619     end do
 20620     ExtractFilePath = ''
 20621 
 20622   end function ExtractFilePath
 20623 
 20624   function ExtractFileExt(aname)
 20625     character(LEN = *), intent(IN) :: aname
 20626     character(LEN = 120) ExtractFileExt
 20627     integer len, i
 20628 
 20629     len = len_trim(aname)
 20630     do i = len, 1, -1
 20631        if (aname(i:i) = '/') then
 20632           ExtractFileExt = ''
 20633           return
 20634        else if (aname(i:i) = '.') then
 20635           ExtractFileExt = aname(i:len)   
 20636           return
 20637        end if
 20638     end do
 20639     ExtractFileExt = ''
 20640 
 20641   end function ExtractFileExt
 20642 
 20643 
 20644  function ExtractFileName(aname)
 20645     character(LEN = *), intent(IN) :: aname
 20646     character(LEN = 120) ExtractFileName
 20647     integer len, i
 20648 
 20649     len = len_trim(aname)
 20650     do i = len, 1, -1
 20651        if (aname(i:i) = '/') then
 20652           ExtractFileName = aname(i+1:len)
 20653           return
 20654        end if
 20655     end do
 20656     ExtractFileName = aname
 20657 
 20658   end function ExtractFileName
 20659 
 20660  function ChangeFileExt(aname,ext)
 20661     character(LEN = *), intent(IN) :: aname,ext
 20662     character(LEN = 1024) ChangeFileExt
 20663     integer len, i
 20664 
 20665     len = len_trim(aname)
 20666     do i = len, 1, -1
 20667        if (aname(i:i) = '.') then
 20668           ChangeFileExt = aname(1:i) // trim(ext)
 20669           return
 20670        end if
 20671     end do
 20672     ChangeFileExt = trim(aname) // '.' // trim(ext)
 20673 
 20674   end function ChangeFileExt
 20675 
 20676 
 20677   function CheckTrailingSlash(aname)
 20678      character(LEN = *), intent(in) :: aname
 20679      character(LEN = 1024) CheckTrailingSlash
 20680      integer len
 20681      
 20682      len = len_trim(aname)
 20683 !ifdef IBMXL
 20684      if (aname(len:len) /= '\\' .and. aname(len:len) /= '/') then
 20685 !else
 20686 !ifdef ESCAPEBACKSLASH
 20687      if (aname(len:len) /= '\\' .and. aname(len:len) /= '/') then
 20688 !else
 20689      if (aname(len:len) /= '\' .and. aname(len:len) /= '/') then
 20690 !endif
 20691 !endif
 20692       CheckTrailingSlash = trim(aname)//'/'
 20693      else
 20694       CheckTrailingSlash = aname
 20695      end if 
 20696 
 20697 
 20698   end  function CheckTrailingSlash
 20699 
 20700 
 20701   subroutine DeleteFile(aname)
 20702     character(LEN = *), intent(IN) :: aname
 20703     integer file_id 
 20704 
 20705      if (FileExists(aname)) then
 20706       file_id = new_file_unit()
 20707       open(unit = file_id, file = aname, err = 2)
 20708       close(unit = file_id, status = 'DELETE')
 20709  2    file_units(file_id) = .false.
 20710      end if
 20711      
 20712   end subroutine DeleteFile
 20713 
 20714 
 20715   subroutine FlushFile(aunit)
 20716 !ifdef __INTEL_COMPILER_BUILD_DATE
 20717   USE IFPORT
 20718 !endif
 20719     integer, intent(IN) :: aunit
 20720 
 20721 
 20722 !ifdef IBMXL
 20723      call flush_(aunit)
 20724 !else
 20725      call flush(aunit)
 20726 !endif
 20727     
 20728   end subroutine FlushFile
 20729 
 20730 
 20731   function FileExists(aname)
 20732     character(LEN = *), intent(IN) :: aname
 20733     logical FileExists
 20734         
 20735         inquire(file = aname, exist = FileExists)
 20736 
 20737   end function FileExists
 20738 
 20739  subroutine OpenFile(aname, aunit,mode)
 20740    character(LEN = *), intent(IN) :: aname,mode
 20741    integer, intent(in) :: aunit
 20742 
 20743 
 20744    open(unit = aunit,file = aname,form = mode,status = 'old', action = 'read', err=500)
 20745    return
 20746 
 20747 500 call MpiStop('File not found: '//trim(aname))
 20748     
 20749 
 20750  end subroutine OpenFile
 20751  
 20752  
 20753  subroutine OpenTxtFile(aname, aunit)
 20754    character(LEN = *), intent(IN) :: aname
 20755    integer, intent(in) :: aunit
 20756 
 20757    call OpenFile(aname,aunit,'formatted')
 20758  
 20759  end subroutine OpenTxtFile
 20760 
 20761 subroutine CreateOpenTxtFile(aname, aunit, append)
 20762    character(LEN = *), intent(IN) :: aname
 20763    integer, intent(in) :: aunit
 20764    logical, optional, intent(in) :: append
 20765    logical A
 20766 
 20767    if (present(append)) then
 20768       A = append
 20769    else
 20770       A = .false.
 20771    endif
 20772 
 20773    call CreateOpenFile(aname,aunit,'formatted',A)
 20774 
 20775  end subroutine CreateOpenTxtFile
 20776 
 20777 
 20778  subroutine CreateTxtFile(aname, aunit)
 20779     character(LEN = *), intent(IN) :: aname
 20780    integer, intent(in) :: aunit
 20781 
 20782    call CreateFile(aname,aunit,'formatted')
 20783 
 20784  end subroutine CreateTxtFile
 20785 
 20786  
 20787  subroutine CreateFile(aname, aunit,mode)
 20788     character(LEN = *), intent(IN) :: aname,mode
 20789    integer, intent(in) :: aunit
 20790 
 20791      open(unit = aunit,file = aname,form = mode,status = 'replace', err=500)
 20792 
 20793    return
 20794 
 20795 500 call MpiStop('Error creating file '//trim(aname))
 20796     
 20797 
 20798  end subroutine CreateFile
 20799 
 20800  subroutine CreateOpenFile(aname, aunit,mode, append)
 20801     character(LEN = *), intent(IN) :: aname,mode
 20802    integer, intent(in) :: aunit
 20803    logical, optional, intent(in) :: append
 20804    logical A
 20805 
 20806    if (present(append)) then
 20807       A = append
 20808    else
 20809       A = .false.
 20810    endif
 20811 
 20812    if (A) then
 20813      open(unit = aunit,file = aname,form = mode,status = 'unknown', err = 500, position='append')
 20814    else
 20815      open(unit = aunit,file = aname,form = mode,status = 'replace', err=500)
 20816    end if
 20817 
 20818    return
 20819 
 20820 500 call MpiStop('Error creatinging or opening '//trim(aname))
 20821     
 20822 
 20823  end subroutine CreateOpenFile
 20824 
 20825  function TxtNumberColumns(InLine) result(n)
 20826    character(LEN = *) :: InLine
 20827    integer n,i
 20828    logical isNum    
 20829    
 20830    n = 0
 20831    isNum = .false.
 20832    do i = 1, len_trim(InLIne)
 20833     if (verify(InLine(i:i),'-+eE.0123456789') = 0) then
 20834       if (.not. IsNum) n = n+1
 20835       IsNum = .true.
 20836     else
 20837       IsNum = .false.     
 20838     end if
 20839    end do
 20840    
 20841  end function TxtNumberColumns
 20842  
 20843   function TxtColumns(InLine) result(n)
 20844    character(LEN = *) :: InLine
 20845    integer n,i
 20846    logical isNum    
 20847    
 20848    n = 0
 20849    isNum = .false.
 20850    do i = 1, len_trim(InLine)
 20851     if (InLine(i:i) > char(32)) then
 20852       if (.not. IsNum) n = n+1
 20853       IsNum = .true.
 20854     else
 20855       IsNum = .false.     
 20856     end if
 20857    end do
 20858    
 20859  end function TxtColumns
 20860 
 20861  function FileColumns(aunit) result(n)
 20862    integer, intent(in) :: aunit
 20863    integer n
 20864    character(LEN = 4096*32) :: InLine
 20865 
 20866    n = 0
 20867    read(aunit,'(a)', end = 10) InLine
 20868    n = TxtNumberColumns(InLine)
 20869 10 rewind aunit
 20870   
 20871  end function FileColumns
 20872 
 20873  function FileLines(aunit) result(n)
 20874    integer, intent(in) :: aunit
 20875    integer n
 20876    character(LEN = 4096) :: InLine
 20877 
 20878    n = 0
 20879    do
 20880 
 20881    read(aunit,'(a)', end = 200) InLine
 20882    n = n+1
 20883    end do
 20884  
 20885 200 rewind aunit
 20886     
 20887 
 20888  end function FileLines
 20889 
 20890 
 20891  function TopCommentLine(aname) result(res)
 20892     character(LEN = *), intent(IN) :: aname
 20893     integer file_id 
 20894     character(LEN = 1024) :: InLine, res
 20895     
 20896     res = ''
 20897     file_id = new_file_unit()
 20898     call OpenTxtFile(aname, file_id)
 20899     InLine = ''
 20900     do while (InLine /= '') 
 20901      read(file_id,'(a)', end = 10) InLine
 20902     end do
 20903     If (InLIne(1:1) = '!') then
 20904      res = InLine
 20905     end if
 20906 
 20907 10  call CloseFile(file_id)
 20908 
 20909  end function TopCommentLine
 20910 
 20911 
 20912  function TxtFileColumns(aname) result(n)
 20913     character(LEN = *), intent(IN) :: aname
 20914     integer n, file_id 
 20915 
 20916 
 20917     file_id = new_file_unit()
 20918 
 20919     call OpenTxtFile(aname, file_id)
 20920     n = FileColumns(file_id)
 20921     call CloseFile(file_id)
 20922 
 20923  end function TxtFileColumns
 20924  
 20925  
 20926  function LastFileLine(aname)
 20927    character(LEN = *), intent(IN) :: aname
 20928    character(LEN = 5000) LastFileLine, InLine
 20929    integer  file_id 
 20930    
 20931    file_id = new_file_unit()
 20932  
 20933    InLine = ''
 20934    call OpenTxtFile(aname,file_id)
 20935    do
 20936     read(file_id,'(a)', end = 200) InLine
 20937    end do
 20938  
 20939 200 call CloseFile(file_id)
 20940 
 20941    LastFileLine = InLine
 20942  
 20943  end function LastFileLine
 20944 
 20945  
 20946 
 20947       subroutine spline_real(x,y,n,y2)
 20948 
 20949       integer, intent(in) :: n
 20950       real, intent(in) :: x(n),y(n)
 20951       real, intent(out) :: y2(n)
 20952       integer i,k
 20953       real p,qn,sig,un
 20954       real, dimension(:), allocatable :: u
 20955 
 20956        
 20957       allocate(u(1:n))
 20958   
 20959         y2(1) = 0
 20960         u(1) = 0
 20961         
 20962       do i = 2,n-1
 20963         sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
 20964         p = sig*y2(i-1)+2.0 
 20965    
 20966         y2(i) = (sig-1.0)/p
 20967       
 20968          u(i) = (6.0*((y(i+1)-y(i))/(x(i+ &
 20969          1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
 20970          u(i-1))/p
 20971       end do
 20972         qn = 0.0
 20973         un = 0.0
 20974 
 20975       y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.0)
 20976       do k = n-1,1,-1
 20977         y2(k) = y2(k)*y2(k+1)+u(k)
 20978       end do
 20979 
 20980       deallocate(u)
 20981   
 20982 !  (C) Copr. 1986-92 Numerical Recipes Software, adapted.
 20983       end subroutine spline_real
 20984 
 20985 
 20986       subroutine spline_double(x,y,n,y2)
 20987 
 20988       integer, intent(in) :: n
 20989       double precision, intent(in) :: x(n),y(n)
 20990       double precision, intent(out) :: y2(n)
 20991       integer i,k
 20992       double precision p,qn,sig,un
 20993       double precision, dimension(:), allocatable :: u
 20994 
 20995        
 20996       allocate(u(1:n))
 20997   
 20998         y2(1) = 0
 20999         u(1) = 0
 21000         
 21001       do i = 2,n-1
 21002         sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
 21003         p = sig*y2(i-1)+2 
 21004    
 21005         y2(i) = (sig-1)/p
 21006       
 21007          u(i) = (6*((y(i+1)-y(i))/(x(i+ &
 21008          1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* &
 21009          u(i-1))/p
 21010       end do
 21011       qn = 0
 21012       un = 0
 21013 
 21014       y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1)
 21015       do k = n-1,1,-1
 21016         y2(k) = y2(k)*y2(k+1)+u(k)
 21017       end do
 21018 
 21019       deallocate(u)
 21020   
 21021 !  (C) Copr. 1986-92 Numerical Recipes Software, adapted.
 21022       end subroutine spline_double
 21023 
 21024 
 21025       function DLGAMMA(x)
 21026        !Use Stirling generalization for large x
 21027        !See e.g. http://en.wikipedia.org/wiki/Stirling's_approximation
 21028        !Is accurate to at least 10 decimals, worse just about 30
 21029        double precision :: x
 21030        double precision:: DLGAMMA !approx log gamma
 21031        double precision, parameter :: const = .91893853320467274180 !log(2pi)/2
 21032    
 21033        if (x<32) then
 21034         DLGAMMA = log(GAMMA(x))
 21035        else
 21036         DLGAMMA = (x-0.5)*log(x) - x + const +  &
 21037          1/12/(1+x)*(1+1/(x+2)*(1+59/30/(x+3)*(1+2.9491525423728813559/(x+4))))
 21038       end if
 21039       end function DLGAMMA
 21040 
 21041 
 21042       function LogGamma(x)
 21043         real LogGamma
 21044         real, intent(in) :: x
 21045         integer i, j
 21046         real r
 21047 
 21048         i = nint(x*2)
 21049         if (abs(i-x*2) > 1e-4) call MpiStop('LogGamma function for half integral only')
 21050         if (mod(i,2) = 0) then
 21051            r = 0
 21052            do j = 2, i/2-1
 21053               r = r + log(real(j))
 21054            end do
 21055            LogGamma = r
 21056         else
 21057            r = log(pi)/2
 21058            do j = 1, i-2 , 2
 21059              r = r+ log(j/2.0)
 21060            end do
 21061            LogGamma = r
 21062         end if
 21063 
 21064       end function LogGamma
 21065 
 21066     DOUBLE PRECISION FUNCTION GAMMA(X)
 21067 !----------------------------------------------------------------------
 21068 !
 21069 ! This routine calculates the GAMMA function for a real argument X.
 21070 !   Computation is based on an algorithm outlined in reference 1.
 21071 !   The program uses rational functions that approximate the GAMMA
 21072 !   function to at least 20 significant decimal digits.  Coefficients
 21073 !   for the approximation over the interval (1,2) are unpublished.
 21074 !   Those for the approximation for X .GE. 12 are from reference 2.
 21075 !   The accuracy achieved depends on the arithmetic system, the
 21076 !   compiler, the intrinsic functions, and proper selection of the
 21077 !   machine-dependent constants.
 21078 !*******************************************************************
 21079 !
 21080 ! Explanation of machine-dependent constants
 21081 !
 21082 ! beta   - radix for the floating-point representation
 21083 ! maxexp - the smallest positive power of beta that overflows
 21084 ! XBIG   - the largest argument for which GAMMA(X) is representable
 21085 !          in the machine, i.e., the solution to the equation
 21086 !                  GAMMA(XBIG) = beta**maxexp
 21087 ! XINF   - the largest machine representable floating-point number;
 21088 !          approximately beta**maxexp
 21089 ! EPS    - the smallest positive floating-point number such that
 21090 !          1.0+EPS  >  1.0
 21091 ! XMININ - the smallest positive floating-point number such that
 21092 !          1/XMININ is machine representable
 21093 !
 21094 !     Approximate values for some important machines are:
 21095 !
 21096 !                            beta       maxexp        XBIG
 21097 !
 21098 ! CRAY-1         (S.P.)        2         8191        966.961
 21099 ! Cyber 180/855
 21100 !   under NOS    (S.P.)        2         1070        177.803
 21101 ! IEEE (IBM/XT,
 21102 !   SUN, etc.)   (S.P.)        2          128        35.040
 21103 ! IEEE (IBM/XT,
 21104 !   SUN, etc.)   (D.P.)        2         1024        171.624
 21105 ! IBM 3033       (D.P.)       16           63        57.574
 21106 ! VAX D-Format   (D.P.)        2          127        34.844
 21107 ! VAX G-Format   (D.P.)        2         1023        171.489
 21108 !
 21109 !                            XINF         EPS        XMININ
 21110 !
 21111 ! CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
 21112 ! Cyber 180/855
 21113 !   under NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
 21114 ! IEEE (IBM/XT,
 21115 !   SUN, etc.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
 21116 ! IEEE (IBM/XT,
 21117 !   SUN, etc.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
 21118 ! IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
 21119 ! VAX D-Format   (D.P.)   1.70D+38     1.39D-17    5.88D-39
 21120 ! VAX G-Format   (D.P.)   8.98D+307    1.11D-16    1.12D-308
 21121 !
 21122 !*******************************************************************
 21123 !*******************************************************************
 21124 !
 21125 ! Error returns
 21126 !
 21127 !  The program returns the value XINF for singularities or
 21128 !     when overflow would occur.  The computation is believed
 21129 !     to be free of underflow and overflow.
 21130 !
 21131 !
 21132 !  Intrinsic functions required are:
 21133 !
 21134 !     INT, DBLE, EXP, LOG, REAL, SIN
 21135 !
 21136 !
 21137 ! References: "An Overview of Software Development for Special
 21138 !              Functions", W. J. Cody, Lecture Notes in Mathemati,
 21139 !              506, Numerical Analysis Dundee, 1975, G. A. Watson
 21140 !              (ed.), Springer Verlag, Berlin, 1976.
 21141 !
 21142 !              Computer Approximations, Hart, Et. Al., Wiley and
 21143 !              sons, New York, 1968.
 21144 !
 21145 !  Latest modification: October 12, 1989
 21146 !
 21147 !  Authors: W. J. Cody and L. Stoltz
 21148 !           Applied Mathemati Division
 21149 !           Argonne National Laboratory
 21150 !           Argonne, IL 60439
 21151 !
 21152 !----------------------------------------------------------------------
 21153       INTEGER I,N
 21154       LOGICAL PARITY
 21155     DOUBLE PRECISION C,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE, &
 21156          TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
 21157       DIMENSION C(7),P(8),Q(8)
 21158 !----------------------------------------------------------------------
 21159 !  Mathematical constants
 21160 !----------------------------------------------------------------------
 21161     DATA ONE,HALF,TWELVE,TWO,ZERO/1.0,0.5,12.0,2.0,0.0/, &
 21162         SQRTPI/0.9189385332046727417803297/, &
 21163         PI/3.1415926535897932384626434/
 21164 !----------------------------------------------------------------------
 21165 !  Machine dependent parameters
 21166 !----------------------------------------------------------------------
 21167     DATA XBIG,XMININ,EPS/35.040,1.18D-38,1.19D-7/, &
 21168         XINF/3.4E38/
 21169 !----------------------------------------------------------------------
 21170 !  Numerator and denominator coefficients for rational minimax
 21171 !     approximation over (1,2).
 21172 !----------------------------------------------------------------------
 21173     DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1, &
 21174           -3.79804256470945635097577E+2,6.29331155312818442661052E+2, &
 21175           8.66966202790413211295064E+2,-3.14512729688483675254357E+4, &
 21176           -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
 21177     DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2, &
 21178          -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, &
 21179            2.25381184209801510330112E+4,4.75584627752788110767815E+3, &
 21180          -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
 21181 !----------------------------------------------------------------------
 21182 ! Coefficients for minimax approximation over (12, INF).
 21183 !----------------------------------------------------------------------
 21184     DATA C/-1.910444077728D-03,8.4171387781295D-04, &
 21185         -5.952379913043012D-04,7.93650793500350248D-04, &
 21186         -2.777777777777681622553D-03,8.333333333333333331554247D-02, &
 21187          5.7083835261D-03/
 21188 !----------------------------------------------------------------------
 21189 !  Statement functions for conversion between integer and float
 21190 !----------------------------------------------------------------------
 21191       PARITY = .FALSE.
 21192       FACT = ONE
 21193       N = 0
 21194       Y = X
 21195       IF (Y < = ZERO) THEN
 21196 !----------------------------------------------------------------------
 21197 !  Argument is negative
 21198 !----------------------------------------------------------------------
 21199             Y = -X
 21200             Y1 = AINT(Y)
 21201             RES = Y - Y1
 21202             IF (RES  <>  ZERO) THEN
 21203                   IF (Y1  <>  AINT(Y1*HALF)*TWO) PARITY = .TRUE.
 21204                   FACT = -PI / SIN(PI*RES)
 21205                   Y = Y + ONE
 21206                ELSE
 21207                   RES = XINF
 21208                   GO TO 900
 21209             END IF
 21210       END IF
 21211 !----------------------------------------------------------------------
 21212 !  Argument is positive
 21213 !----------------------------------------------------------------------
 21214       IF (Y  <  EPS) THEN
 21215 !----------------------------------------------------------------------
 21216 !  Argument  <  EPS
 21217 !----------------------------------------------------------------------
 21218             IF (Y .GE. XMININ) THEN
 21219                   RES = ONE / Y
 21220                ELSE
 21221                   RES = XINF
 21222                   GO TO 900
 21223             END IF
 21224          ELSE IF (Y  <  TWELVE) THEN
 21225             Y1 = Y
 21226             IF (Y  <  ONE) THEN
 21227 !----------------------------------------------------------------------
 21228 !  0.0  <  argument  <  1.0
 21229 !----------------------------------------------------------------------
 21230                   Z = Y
 21231                   Y = Y + ONE
 21232                ELSE
 21233 !----------------------------------------------------------------------
 21234 !  1.0  <  argument  <  12.0, reduce argument if necessary
 21235 !----------------------------------------------------------------------
 21236                   N = INT(Y) - 1
 21237                   Y = Y - REAL(N)
 21238                   Z = Y - ONE
 21239             END IF
 21240 !----------------------------------------------------------------------
 21241 !  Evaluate approximation for 1.0  <  argument  <  2.0
 21242 !----------------------------------------------------------------------
 21243             XNUM = ZERO
 21244             XDEN = ONE
 21245             DO 260 I = 1, 8
 21246                XNUM = (XNUM + P(I)) * Z
 21247                XDEN = XDEN * Z + Q(I)
 21248   260       CONTINUE
 21249             RES = XNUM / XDEN + ONE
 21250             IF (Y1  <  Y) THEN
 21251 !----------------------------------------------------------------------
 21252 !  Adjust result for case  0.0  <  argument  <  1.0
 21253 !----------------------------------------------------------------------
 21254                   RES = RES / Y1
 21255                ELSE IF (Y1  >  Y) THEN
 21256 !----------------------------------------------------------------------
 21257 !  Adjust result for case  2.0  <  argument  <  12.0
 21258 !----------------------------------------------------------------------
 21259                   DO 290 I = 1, N
 21260                      RES = RES * Y
 21261                      Y = Y + ONE
 21262   290             CONTINUE
 21263             END IF
 21264          ELSE
 21265 !----------------------------------------------------------------------
 21266 !  Evaluate for argument .GE. 12.0,
 21267 !----------------------------------------------------------------------
 21268             IF (Y < = XBIG) THEN
 21269                   YSQ = Y * Y
 21270                   SUM = C(7)
 21271                   DO 350 I = 1, 6
 21272                      SUM = SUM / YSQ + C(I)
 21273   350             CONTINUE
 21274                   SUM = SUM/Y - Y + SQRTPI
 21275                   SUM = SUM + (Y-HALF)*LOG(Y)
 21276                   RES = EXP(SUM)
 21277                ELSE
 21278                   RES = XINF
 21279                   GO TO 900
 21280             END IF
 21281       END IF
 21282 !----------------------------------------------------------------------
 21283 !  Final adjustments and return
 21284 !----------------------------------------------------------------------
 21285       IF (PARITY) RES = -RES
 21286       IF (FACT  <>  ONE) RES = FACT / RES
 21287   900 GAMMA = RES
 21288 
 21289       END FUNCTION GAMMA
 21290 
 21291   subroutine SetIdlePriority
 21292 !ifdef RUNIDLE
 21293     USE DFWIN
 21294     Integer dwPriority 
 21295     Integer CheckPriority
 21296 
 21297     dwPriority = 64 ! idle priority
 21298     CheckPriority = SetPriorityClass(GetCurrentProcess(), dwPriority)
 21299 !endif
 21300   end subroutine SetIdlePriority
 21301 
 21302 
 21303     subroutine GetThreeJs(thrcof,l2in,l3in,m2in,m3in)
 21304       !Recursive evaluation of 3j symbols. Does minimal error checking on input parameters.
 21305       implicit none
 21306       integer, parameter :: dl = KIND(1)
 21307       integer, intent(in) :: l2in,l3in, m2in,m3in
 21308       real(dl), dimension(*) :: thrcof
 21309       INTEGER, PARAMETER :: i8 = selected_int_kind(18)
 21310       integer(i8) :: l2,l3,m2,m3
 21311       integer(i8) :: l1, m1, l1min,l1max, lmatch, nfin, a1, a2
 21312       
 21313       real(dl) :: newfac, oldfac, sumfor, c1,c2,c1old, dv, denom, x, sum1, sumuni
 21314       real(dl) :: x1,x2,x3, y,y1,y2,y3,sum2,sumbac, ratio,cnorm, sign1, thresh
 21315       integer i,ier, index, nlim, sign2
 21316       integer nfinp1,nfinp2,nfinp3, lstep, nstep2,n
 21317       real(dl), parameter :: zero = 0, one = 1
 21318       real(dl), parameter ::  tiny = 1.0d-30, srtiny = 1.0d-15, huge = 1.d30, srhuge = 1.d15
 21319   
 21320     ! routine to generate set of 3j-coeffs (l1,l2,l3\\ m1,m2,m3)
 21321 
 21322     ! by recursion from l1min = max(abs(l2-l3),abs(m1)) 
 21323     !                to l1max = l2+l3
 21324     ! the resulting 3j-coeffs are stored as thrcof(l1-l1min+1)
 21325 
 21326     ! to achieve the numerical stability, the recursion will proceed
 21327     ! simultaneously forwards and backwards, starting from l1min and l1max
 21328     ! respectively.
 21329     !
 21330     ! lmatch is the l1-value at which forward and backward recursion are matched.
 21331     !
 21332     ! ndim is the length of the array thrcof
 21333     !
 21334     ! ier = -1 for all 3j vanish(l2-abs(m2)<0, l3-abs(m3)<0 or not integer)
 21335     ! ier = -2 if possible 3j's exceed ndim
 21336     ! ier > = 0 otherwise
 21337 
 21338       l2 = l2in
 21339       l3 = l3in
 21340       m2 = m2in
 21341       m3 = m3in
 21342       newfac = 0
 21343       lmatch = 0
 21344       m1 = -(m2+m3)
 21345 
 21346     ! check relative magnitude of l and m values
 21347       ier = 0
 21348  
 21349       if (l2 < abs(m2) .or. l3 < m3) then
 21350       ier = -1
 21351       call MpiStop('error ier = -1')
 21352       return
 21353       end if
 21354 
 21355     ! limits for l1
 21356       l1min = max(abs(l2-l3),abs(m1))
 21357       l1max = l2+l3
 21358 
 21359       if (l1min > = l1max) then
 21360        if (l1min/= l1max) then
 21361        ier = -1
 21362         call MpiStop('error ier = -1')
 21363        return
 21364        end if
 21365 
 21366     ! reached if l1 can take only one value, i.e.l1min = l1max
 21367       thrcof(1) = (-1)**abs(l2+m2-l3+m3)/sqrt(real(l1min+l2+l3+1,dl))
 21368       return
 21369 
 21370       end if
 21371 
 21372       nfin = l1max-l1min+1
 21373  
 21374     ! starting forward recursion from l1min taking nstep1 steps
 21375       l1 = l1min
 21376       thrcof(1) = srtiny
 21377       sum1 = (2*l1 + 1)*tiny
 21378 
 21379       lstep = 1
 21380 
 21381 30    lstep = lstep+1
 21382       l1 = l1+1
 21383 
 21384       oldfac = newfac
 21385       a1 = (l1+l2+l3+1)*(l1-l2+l3)*(l1+l2-l3)
 21386       a2 = (l1+m1)*(l1-m1)*(-l1+l2+l3+1)
 21387       newfac = sqrt(a2*real(a1,dl))
 21388       if (l1 = 1) then
 21389          !IF L1 = 1  (L1-1) HAS TO BE FACTORED OUT OF DV, HENCE
 21390          c1 = -(2*l1-1)*l1*(m3-m2)/newfac
 21391       else
 21392 
 21393        dv = -l2*(l2+1)*m1 + l3*(l3+1)*m1 + l1*(l1-1)*(m3-m2)
 21394        denom = (l1-1)*newfac
 21395 
 21396        if (lstep > 2) c1old = abs(c1)
 21397        c1 = -(2*l1-1)*dv/denom
 21398 
 21399       end if
 21400 
 21401       if (lstep< = 2) then
 21402 
 21403     ! if l1 = l1min+1 the third term in the recursion eqn vanishes, hence
 21404        x = srtiny*c1
 21405        thrcof(2) = x
 21406        sum1 = sum1+tiny*(2*l1+1)*c1*c1
 21407        if(lstep = nfin) then
 21408           sumuni = sum1
 21409           go to 230
 21410        end if
 21411        goto 30
 21412 
 21413       end if
 21414 
 21415       c2 = -l1*oldfac/denom
 21416 
 21417     ! recursion to the next 3j-coeff x  
 21418       x = c1*thrcof(lstep-1) + c2*thrcof(lstep-2)
 21419       thrcof(lstep) = x
 21420       sumfor = sum1
 21421       sum1 = sum1 + (2*l1+1)*x*x
 21422       if (lstep/= nfin) then
 21423 
 21424     ! see if last unnormalised 3j-coeff exceeds srhuge
 21425       if (abs(x) > = srhuge) then
 21426      
 21427          ! REACHED IF LAST 3J-COEFFICIENT LARGER THAN SRHUGE
 21428          ! SO THAT THE RECURSION SERIES THRCOF(1), ... , THRCOF(LSTEP)
 21429          ! HAS TO BE RESCALED TO PREVENT OVERFLOW
 21430      
 21431          ier = ier+1
 21432          do i = 1, lstep
 21433             if (abs(thrcof(i)) < srtiny) thrcof(i) = zero
 21434             thrcof(i) = thrcof(i)/srhuge
 21435          end do
 21436 
 21437          sum1 = sum1/huge
 21438          sumfor = sumfor/huge
 21439          x = x/srhuge
 21440 
 21441       end if
 21442 
 21443     ! as long as abs(c1) is decreasing, the recursion proceeds towards increasing
 21444     ! 3j-valuse and so is numerically stable. Once an increase of abs(c1) is 
 21445     ! detected, the recursion direction is reversed.
 21446 
 21447      if (c1old > abs(c1)) goto 30
 21448 
 21449      end if !lstep/= nfin
 21450 
 21451     ! keep three 3j-coeffs around lmatch for comparison with backward recursion
 21452 
 21453       lmatch = l1-1
 21454       x1 = x
 21455       x2 = thrcof(lstep-1)
 21456       x3 = thrcof(lstep-2)
 21457       nstep2 = nfin-lstep+3
 21458 
 21459     ! --------------------------------------------------------------------------
 21460     !
 21461     ! starting backward recursion from l1max taking nstep2 stpes, so that
 21462     ! forward and backward recursion overlap at 3 points 
 21463     ! l1 = lmatch-1, lmatch, lmatch+1
 21464 
 21465       nfinp1 = nfin+1
 21466       nfinp2 = nfin+2
 21467       nfinp3 = nfin+3
 21468       l1 = l1max
 21469       thrcof(nfin) = srtiny
 21470       sum2 = tiny*(2*l1+1)
 21471  
 21472       l1 = l1+2
 21473       lstep = 1
 21474 
 21475       do
 21476       lstep = lstep + 1
 21477       l1 = l1-1
 21478 
 21479       oldfac = newfac
 21480       a1 = (l1+l2+l3)*(l1-l2+l3-1)*(l1+l2-l3-1)
 21481       a2 = (l1+m1-1)*(l1-m1-1)*(-l1+l2+l3+2)
 21482       newfac = sqrt(a1*real(a2,dl))
 21483 
 21484       dv = -l2*(l2+1)*m1 + l3*(l3+1)*m1 +l1*(l1-1)*(m3-m2)
 21485 
 21486       denom = l1*newfac
 21487       c1 = -(2*l1-1)*dv/denom
 21488       if (lstep < = 2) then
 21489 
 21490          ! if l2 = l2max+1, the third term in the recursion vanishes
 21491      
 21492          y = srtiny*c1
 21493          thrcof(nfin-1) = y
 21494          sumbac = sum2
 21495          sum2 = sum2 + tiny*(2*l1-3)*c1*c1
 21496 
 21497          cycle
 21498 
 21499       end if
 21500 
 21501       c2 = -(l1-1)*oldfac/denom
 21502 
 21503     ! recursion to the next 3j-coeff y
 21504       y = c1*thrcof(nfinp2-lstep)+c2*thrcof(nfinp3-lstep)
 21505 
 21506       if (lstep = nstep2) exit
 21507   
 21508       thrcof(nfinp1-lstep) = y
 21509       sumbac = sum2
 21510       sum2 = sum2+(2*l1-3)*y*y
 21511 
 21512     ! see if last unnormalised 3j-coeff exceeds srhuge
 21513       if (abs(y) > = srhuge) then
 21514      
 21515          ! reached if 3j-coeff larger than srhuge so that the recursion series
 21516          ! thrcof(nfin),..., thrcof(nfin-lstep+1) has to be rescaled to prevent overflow
 21517      
 21518          ier = ier+1
 21519          do i = 1, lstep
 21520             index = nfin-i+1
 21521             if (abs(thrcof(index)) < srtiny) thrcof(index) = zero
 21522             thrcof(index) = thrcof(index)/srhuge
 21523          end do
 21524 
 21525          sum2 = sum2/huge
 21526          sumbac = sumbac/huge
 21527 
 21528       end if
 21529 
 21530       end do
 21531 
 21532     ! the forward recursion 3j-coeffs x1, x2, x3 are to be matched with the 
 21533     ! corresponding backward recursion vals y1, y2, y3
 21534 
 21535       y3 = y
 21536       y2 = thrcof(nfinp2-lstep)
 21537       y1 = thrcof(nfinp3-lstep)
 21538 
 21539     ! determine now ratio such that yi = ratio*xi (i = 1,2,3) holds with minimal error
 21540 
 21541       ratio = (x1*y1+x2*y2+x3*y3)/(x1*x1+x2*x2+x3*x3)
 21542       nlim = nfin-nstep2+1
 21543 
 21544       if (abs(ratio) > = 1) then
 21545 
 21546        thrcof(1:nlim) = ratio*thrcof(1:nlim) 
 21547        sumuni = ratio*ratio*sumfor + sumbac
 21548 
 21549       else
 21550 
 21551       nlim = nlim+1
 21552       ratio = 1/ratio
 21553       do n = nlim, nfin
 21554          thrcof(n) = ratio*thrcof(n)
 21555       end do
 21556       sumuni = sumfor + ratio*ratio*sumbac
 21557 
 21558       end if
 21559     ! normalise 3j-coeffs
 21560 
 21561 230  cnorm = 1/sqrt(sumuni)
 21562 
 21563     ! sign convention for last 3j-coeff determines overall phase
 21564 
 21565       sign1 = sign(one,thrcof(nfin))
 21566       sign2 = (-1)**(abs(l2+m2-l3+m3))
 21567       if (sign1*sign2 < = 0) then
 21568         cnorm = -cnorm
 21569       end if
 21570       if (abs(cnorm) > = one) then
 21571          thrcof(1:nfin) = cnorm*thrcof(1:nfin)
 21572          return
 21573       end if
 21574 
 21575       thresh = tiny/abs(cnorm)
 21576 
 21577       do n = 1, nfin
 21578          if (abs(thrcof(n)) < thresh) thrcof(n) = zero
 21579          thrcof(n) = cnorm*thrcof(n)
 21580       end do
 21581       return 
 21582 
 21583     end subroutine GetThreeJs
 21584 
 21585 
 21586 
 21587   end module AMLutils
 21588  
 21589   
 21590 !ifdef ZIGGURAT
 21591 MODULE Ziggurat
 21592 ! Marsaglia & Tsang generator for random normals & random exponentials.
 21593 ! Translated from C by Alan Miller (amiller@bigpond.net.au)
 21594 
 21595 ! Marsaglia, G. & Tsang, W.W. (2000) `The ziggurat method for generating
 21596 ! random variables', J. Statist. Software, v5(8).
 21597 
 21598 ! This is an electronic journal which can be downloaded from:
 21599 ! http://www.jstatsoft.org/v05/i08
 21600 
 21601 ! N.B. It is assumed that all integers are 32-bit.
 21602 ! N.B. The value of M2 has been halved to compensate for the lack of
 21603 !      unsigned integers in Fortran.
 21604 
 21605 ! Latest version - 1 January 2001
 21606 !
 21607 ! AL: useful material at http://en.wikipedia.org/wiki/Ziggurat_algorithm
 21608    IMPLICIT NONE
 21609 
 21610    PRIVATE
 21611 
 21612    INTEGER,  PARAMETER  ::  DP = SELECTED_REAL_KIND( 12, 60 )
 21613    REAL(DP), PARAMETER  ::  m1 = 2147483648.0_DP,   m2 = 2147483648.0_DP,      &
 21614                             half = 0.5_DP
 21615    REAL(DP)             ::  dn = 3.442619855899_DP, tn = 3.442619855899_DP,    &
 21616                             vn = 0.00991256303526217_DP,                     &
 21617                             q,                    de = 7.697117470131487_DP, &
 21618                             te = 7.697117470131487_DP,                       &
 21619                             ve = 0.003949659822581572_DP
 21620    INTEGER,  SAVE       ::  iz, jz, jsr = 123456789, kn(0:127),              &
 21621                             ke(0:255), hz
 21622    REAL(DP), SAVE       ::  wn(0:127), fn(0:127), we(0:255), fe(0:255)
 21623    LOGICAL,  SAVE       ::  initialized = .FALSE.
 21624 
 21625    PUBLIC  :: zigset, shr3, uni, rnor, rexp
 21626 
 21627 
 21628 CONTAINS
 21629 
 21630 
 21631 SUBROUTINE zigset( jsrseed )
 21632 
 21633    INTEGER, INTENT(IN)  :: jsrseed
 21634 
 21635    INTEGER  :: i
 21636 
 21637    !  Set the seed
 21638    jsr = jsrseed
 21639 
 21640    !  Tables for RNOR
 21641    q = vn*EXP(half*dn*dn)
 21642    kn(0) = (dn/q)*m1
 21643    kn(1) = 0
 21644    wn(0) = q/m1
 21645    wn(127) = dn/m1
 21646    fn(0) = 1.0_DP
 21647    fn(127) = EXP( -half*dn*dn )
 21648    DO  i = 126, 1, -1
 21649       dn = SQRT( -2.0_DP * LOG( vn/dn + EXP( -half*dn*dn ) ) )
 21650       kn(i+1) = (dn/tn)*m1
 21651       tn = dn
 21652       fn(i) = EXP(-half*dn*dn)
 21653       wn(i) = dn/m1
 21654    END DO
 21655 
 21656    !  Tables for REXP
 21657    q = ve*EXP( de )
 21658    ke(0) = (de/q)*m2
 21659    ke(1) = 0
 21660    we(0) = q/m2
 21661    we(255) = de/m2
 21662    fe(0) = 1.0_DP
 21663    fe(255) = EXP( -de )
 21664    DO  i = 254, 1, -1
 21665       de = -LOG( ve/de + EXP( -de ) )
 21666       ke(i+1) = m2 * (de/te)
 21667       te = de
 21668       fe(i) = EXP( -de )
 21669       we(i) = de/m2
 21670    END DO
 21671    initialized = .TRUE.
 21672    RETURN
 21673 END SUBROUTINE zigset
 21674 
 21675 
 21676 
 21677 !  Generate random 32-bit integers
 21678 FUNCTION shr3( ) RESULT( ival )
 21679    INTEGER  ::  ival
 21680 
 21681    jz = jsr
 21682    jsr = IEOR( jsr, ISHFT( jsr,  13 ) )
 21683    jsr = IEOR( jsr, ISHFT( jsr, -17 ) )
 21684    jsr = IEOR( jsr, ISHFT( jsr,   5 ) )
 21685    ival = jz + jsr
 21686    RETURN
 21687 END FUNCTION shr3
 21688 
 21689 
 21690 
 21691 !  Generate uniformly distributed random numbers
 21692 FUNCTION uni( ) RESULT( fn_val )
 21693    REAL(DP)  ::  fn_val
 21694 
 21695    fn_val = half + 0.2328306e-9_DP * shr3( )
 21696    RETURN
 21697 END FUNCTION uni
 21698 
 21699 
 21700 
 21701 !  Generate random normals
 21702 FUNCTION rnor( ) RESULT( fn_val )
 21703    REAL(DP)             ::  fn_val
 21704 
 21705    REAL(DP), PARAMETER  ::  r = 3.442620_DP
 21706    REAL(DP)             ::  x, y
 21707 
 21708    IF( .NOT. initialized ) CALL zigset( jsr )
 21709    hz = shr3( )
 21710    iz = IAND( hz, 127 )
 21711    IF( ABS( hz ) < kn(iz) ) THEN
 21712       fn_val = hz * wn(iz)
 21713    ELSE
 21714       DO
 21715          IF( iz = 0 ) THEN
 21716             DO
 21717                x = -0.2904764_DP* LOG( uni( ) )
 21718                y = -LOG( uni( ) )
 21719                IF( y+y > = x*x ) EXIT
 21720             END DO
 21721             fn_val = r+x
 21722             IF( hz < = 0 ) fn_val = -fn_val
 21723             RETURN
 21724          END IF
 21725          x = hz * wn(iz)
 21726          IF( fn(iz) + uni( )*(fn(iz-1)-fn(iz)) < EXP(-half*x*x) ) THEN
 21727             fn_val = x
 21728             RETURN
 21729          END IF
 21730          hz = shr3( )
 21731          iz = IAND( hz, 127 )
 21732          IF( ABS( hz ) < kn(iz) ) THEN
 21733             fn_val = hz * wn(iz)
 21734             RETURN
 21735          END IF
 21736       END DO
 21737    END IF
 21738    RETURN
 21739 END FUNCTION rnor
 21740 
 21741 
 21742 
 21743 !  Generate random exponentials
 21744 FUNCTION rexp( ) RESULT( fn_val )
 21745    REAL(DP)  ::  fn_val
 21746 
 21747    REAL(DP)  ::  x
 21748 
 21749    IF( .NOT. initialized ) CALL Zigset( jsr )
 21750    jz = shr3( )
 21751    iz = IAND( jz, 255 )
 21752    IF( ABS( jz ) < ke(iz) ) THEN
 21753       fn_val = ABS(jz) * we(iz)
 21754       RETURN
 21755    END IF
 21756    DO
 21757       IF( iz = 0 ) THEN
 21758          fn_val = 7.69711 - LOG( uni( ) )
 21759          RETURN
 21760       END IF
 21761       x = ABS( jz ) * we(iz)
 21762       IF( fe(iz) + uni( )*(fe(iz-1) - fe(iz)) < EXP( -x ) ) THEN
 21763          fn_val = x
 21764          RETURN
 21765       END IF
 21766       jz = shr3( )
 21767       iz = IAND( jz, 255 )
 21768       IF( ABS( jz ) < ke(iz) ) THEN
 21769          fn_val = ABS( jz ) * we(iz)
 21770          RETURN
 21771       END IF
 21772    END DO
 21773    RETURN
 21774 END FUNCTION rexp
 21775 
 21776 END MODULE ziggurat
 21777 !endif 
 21778 
 21779   
 21780 
 21781 module Random
 21782  integer :: rand_inst = 0 
 21783  logical, parameter :: use_ziggurat = .false.
 21784   !Ziggurat is significantly (3-4x) faster, see Wikipedia for details
 21785   !Have seem some suspicious things, though couldn't replicate; may be OK..
 21786 
 21787 contains
 21788    
 21789   subroutine initRandom(i, i2)
 21790   use AMLUtils
 21791 !ifdef ZIGGURAT
 21792   use Ziggurat
 21793 !endif
 21794   implicit none
 21795   integer, optional, intent(IN) :: i
 21796   integer, optional, intent(IN) :: i2
 21797   integer seed_in,kl,ij
 21798   character(len = 10) :: fred
 21799   real :: klr
 21800   
 21801    if (present(i)) then
 21802     seed_in = i
 21803    else
 21804     seed_in = -1
 21805    end if
 21806       if (seed_in /= -1) then
 21807        if (present(i2)) then
 21808         kl = i2
 21809         if (i2 > 30081) call MpiStop('initRandom:second seed too large')
 21810        else
 21811         kl = 9373
 21812        end if
 21813        ij = i
 21814       else
 21815        call system_clock(count = ij)
 21816        ij = mod(ij + rand_inst*100, 31328)
 21817        call date_and_time(time = fred)
 21818        read (fred,'(e10.3)') klr
 21819        kl = mod(int(klr*1000), 30081)       
 21820       end if
 21821 
 21822       if (Feedback > 0 ) write(*,'(" Random seeds:",1I6,",",1I6," rand_inst:",1I4)') ij,kl,rand_inst
 21823       call rmarin(ij,kl)
 21824 !ifdef ZIGGURAT
 21825       if (use_ziggurat) call zigset(ij)
 21826 !endif
 21827   end subroutine initRandom
 21828 
 21829   subroutine RandIndices(indices, nmax, n)
 21830    use AMLUtils
 21831      integer, intent(in) :: nmax, n
 21832     integer indices(n),i, ix
 21833     integer tmp(nmax)
 21834  
 21835     if (n> nmax) call MpiStop('Error in RandIndices, n > nmax')
 21836     do i = 1, nmax
 21837        tmp(i) = i
 21838     end do
 21839     do i = 1, n
 21840        ix = int(ranmar()*(nmax +1 -i)) + 1
 21841        indices(i) = tmp(ix)
 21842        tmp(ix) = tmp(nmax+1-i)
 21843     end do
 21844 
 21845   end subroutine RandIndices
 21846 
 21847 
 21848   subroutine RandRotation(R, N)
 21849    !this is most certainly not the world's most efficient or robust random rotation generator
 21850     integer, intent(in) :: N
 21851     real R(N,N), vec(N), norm
 21852     integer i,j
 21853     
 21854     do j = 1, N
 21855      do
 21856          do i = 1, N
 21857           vec(i) = Gaussian1()
 21858          end do
 21859          do i = 1, j-1
 21860            vec = vec - sum(vec*R(i,:))*R(i,:)
 21861          end do
 21862          norm = sum(vec**2)
 21863          if (norm > 1e-3) exit
 21864      end do
 21865      R(j,:) = vec / sqrt(norm)
 21866     end do
 21867     
 21868   end subroutine RandRotation
 21869 
 21870 
 21871   double precision function GAUSSIAN1()
 21872 !ifdef ZIGGURAT
 21873     use Ziggurat
 21874 !endif
 21875     implicit none
 21876     double precision R, V1, V2, FAC
 21877     integer, save :: iset = 0
 21878     double precision, save :: gset
 21879 
 21880     if (use_ziggurat) then
 21881 !ifdef ZIGGURAT
 21882      Gaussian1 = rnor( )
 21883 !endif
 21884     else
 21885      !Box muller
 21886      if (ISET = 0) then
 21887         R = 2
 21888         do while (R > = 1)
 21889         V1 = 2*ranmar()-1
 21890         V2 = 2*ranmar()-1
 21891         R = V1**2+V2**2
 21892         end do
 21893         FAC = sqrt(-2*log(R)/R)
 21894         GSET = V1*FAC
 21895         GAUSSIAN1 = V2*FAC
 21896         ISET = 1
 21897       else
 21898         GAUSSIAN1 = GSET
 21899         ISET = 0
 21900       endif
 21901       end if
 21902       end function GAUSSIAN1
 21903 
 21904 
 21905      double precision function CAUCHY1()
 21906       implicit none
 21907 
 21908       Cauchy1 = Gaussian1()/max(1d-15,abs(Gaussian1()))
 21909 
 21910      end function CAUCHY1
 21911 
 21912 
 21913      real FUNCTION RANDEXP1()
 21914 !
 21915 !     Random-number generator for the exponential distribution
 21916 !     Algorithm EA from J. H. Ahrens and U. Dieter,
 21917 !     Communications of the ACM, 31 (1988) 1330--1337.
 21918 !     Coded by K. G. Hamilton, December 1996, with corrections.
 21919 !
 21920       real u, up, g, y
 21921   
 21922       real, parameter ::   alog2 = 0.6931471805599453
 21923       real, parameter ::      a = 5.7133631526454228
 21924       real, parameter ::      b = 3.4142135623730950
 21925       real, parameter ::     c = -1.6734053240284925
 21926       real, parameter ::      p = 0.9802581434685472
 21927       real, parameter ::     aa = 5.6005707569738080
 21928       real, parameter ::     bb = 3.3468106480569850
 21929       real, parameter ::     hh = 0.0026106723602095
 21930       real, parameter ::     dd = 0.0857864376269050
 21931 
 21932       u = ranmar()
 21933       do while (u< = 0)                 ! Comment out this block 
 21934         u = ranmar()                    ! if your RNG can never
 21935       enddo                             ! return exact zero
 21936       g = c
 21937       u = u+u
 21938       do while (u < 1.0)
 21939          g = g + alog2
 21940          u = u+u
 21941       enddo
 21942       u = u-1.0
 21943       if (u< = p) then
 21944         randexp1 = g + aa/(bb-u)
 21945         return
 21946       endif
 21947       do
 21948         u = ranmar()
 21949         y = a/(b-u)
 21950         up = ranmar()
 21951         if ((up*hh+dd)*(b-u)**2 < = exp(-(y+c))) then
 21952           randexp1 = g+y
 21953           return
 21954         endif
 21955       enddo
 21956 
 21957       end function randexp1
 21958 
 21959 
 21960 ! This random number generator originally appeared in ''Toward a Universal 
 21961 ! Random Number Generator'' by George Marsaglia and Arif Zaman. 
 21962 ! Florida State University Report: FSU-SCRI-87-50 (1987)
 21963 ! 
 21964 ! It was later modified by F. James and published in ''A Review of Pseudo-
 21965 ! random Number Generators'' 
 21966 ! 
 21967 ! THIS IS THE BEST KNOWN RANDOM NUMBER GENERATOR AVAILABLE.
 21968 !    (However, a newly discovered technique can yield 
 21969 !        a period of 10^600. But that is still in the development stage.)
 21970 !
 21971 ! It passes ALL of the tests for random number generators and has a period 
 21972 !   of 2^144, is completely portable (gives bit identical results on all 
 21973 !   machines with at least 24-bit mantissas in the floating point 
 21974 !   representation). 
 21975 ! 
 21976 ! The algorithm is a combination of a Fibonacci sequence (with lags of 97
 21977 !   and 33, and operation "subtraction plus one, modulo one") and an 
 21978 !   "arithmetic sequence" (using subtraction).
 21979 !
 21980 ! On a Vax 11/780, this random number generator can produce a number in 
 21981 !    13 microseconds. 
 21982 ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 
 21983 !
 21984 !      PROGRAM TstRAN
 21985 !     INTEGER IJ, KL, I
 21986 ! Thee are the seeds needed to produce the test case results
 21987 !      IJ = 1802
 21988 !      KL = 9373
 21989 !
 21990 !
 21991 ! Do the initialization
 21992 !      call rmarin(ij,kl)
 21993 !
 21994 ! Generate 20000 random numbers
 21995 !      do 10 I = 1, 20000
 21996 !         x = RANMAR()
 21997 !10    continue
 21998 !
 21999 ! If the random number generator is working properly, the next six random
 22000 !    numbers should be:
 22001 !          6533892.0  14220222.0  7275067.0
 22002 !    6172232.0  8354498.0   10633180.0
 22003 !           
 22004 !           
 22005 !        
 22006 !      write(6,20) (4096.0*4096.0*RANMAR(), I = 1,6)
 22007 !20    format (3f12.1)
 22008 !      end
 22009 !
 22010       subroutine RMARIN(IJ,KL)
 22011 ! This is the initialization routine for the random number generator RANMAR()
 22012 ! NOTE: The seed variables can have values between:    0 < = IJ < = 31328
 22013 !                                                      0 < = KL < = 30081
 22014 !The random number sequences created by these two seeds are of sufficient 
 22015 ! length to complete an entire calculation with. For example, if sveral 
 22016 ! different groups are working on different parts of the same calculation,
 22017 ! each group could be assigned its own IJ seed. This would leave each group
 22018 ! with 30000 choices for the second seed. That is to say, this random 
 22019 ! number generator can create 900 million different subsequences -- with 
 22020 ! each subsequence having a length of approximately 10^30.
 22021 !
 22022 ! Use IJ = 1802 & KL = 9373 to test the random number generator. The
 22023 ! subroutine RANMAR should be used to generate 20000 random numbers.
 22024 ! Then display the next six random numbers generated multiplied by 4096*4096
 22025 ! If the random number generator is working properly, the random numbers
 22026 !    should be:
 22027 !           6533892.0  14220222.0  7275067.0
 22028 !           6172232.0  8354498.0   10633180.0
 22029       double precision U(97), C, CD, CM, S, T
 22030       integer I97, J97,i,j,k,l,m
 22031       integer ij,kl
 22032       integer ii,jj
 22033            
 22034     
 22035 !      INTEGER IRM(103)
 22036       
 22037       common /RASET1/ U, C, CD, CM, I97, J97
 22038       if( IJ  <  0  .or.  IJ  >  31328  .or. &
 22039          KL  <  0  .or.  KL  >  30081 ) then
 22040           print '(A)', ' The first random number seed must have a value  between 0 and 31328'
 22041           print '(A)',' The second seed must have a value between 0 and   30081'
 22042             stop
 22043       endif
 22044       I = mod(IJ/177, 177) + 2
 22045       J = mod(IJ    , 177) + 2
 22046       K = mod(KL/169, 178) + 1
 22047       L = mod(KL,     169) 
 22048       do 2 II = 1, 97
 22049          S = 0.0
 22050          T = 0.5
 22051          do 3 JJ = 1, 24
 22052             M = mod(mod(I*J, 179)*K, 179)
 22053             I = J
 22054             J = K
 22055             K = M
 22056             L = mod(53*L+1, 169)
 22057             if (mod(L*M, 64) .ge. 32) then
 22058                S = S + T
 22059             endif
 22060             T = 0.5 * T
 22061 3        continue
 22062          U(II) = S
 22063 2     continue
 22064       C = 362436.0 / 16777216.0
 22065       CD = 7654321.0 / 16777216.0
 22066       CM = 16777213.0 /16777216.0
 22067       I97 = 97
 22068       J97 = 33
 22069     
 22070       end subroutine RMARIN
 22071 
 22072       double precision function RANMAR()
 22073 ! This is the random number generator proposed by George Marsaglia in 
 22074 ! Florida State University Report: FSU-SCRI-87-50
 22075 ! It was slightly modified by F. James to produce an array of pseudorandom
 22076 ! numbers.
 22077       double precision U(97), C, CD, CM
 22078       integer I97, J97
 22079        double precision uni
 22080     
 22081       common /RASET1/ U, C, CD, CM, I97, J97
 22082 !      INTEGER IVEC
 22083          UNI = U(I97) - U(J97)
 22084          if( UNI  <  0.0 ) UNI = UNI + 1.0
 22085          U(I97) = UNI
 22086          I97 = I97 - 1
 22087          if(I97  =  0) I97 = 97
 22088          J97 = J97 - 1
 22089          if(J97  =  0) J97 = 97
 22090          C = C - CD
 22091          if( C  <  0 ) C = C + CM
 22092          UNI = UNI - C
 22093          if( UNI  <  0 ) UNI = UNI + 1.0 ! bug?
 22094          RANMAR = UNI
 22095       
 22096       end function RANMAR
 22097 
 22098 
 22099 end module Random
 22100 
 22101 
 22102  
 22103 ** writefits.f90
 22104 
 22105 !subroutine to export Cls in FITS format for HEALPix 1.2
 22106 !Antony Lewis July 2003
 22107 
 22108 
 22109  subroutine WriteFitsCls(Clsfile, lmx)
 22110   use CAMB
 22111   use head_fits, ONLY : add_card 
 22112   use fitstools, only : write_asctab
 22113   implicit none
 22114   character(LEN = *), INTENT(IN) ::  Clsfile
 22115   integer, INTENT(IN) :: lmx
 22116   CHARACTER(LEN = 80), DIMENSION(1:120) :: header
 22117   INTEGER nlheader,i, j
 22118   real, allocatable, dimension (:,:) :: clout,allcl
 22119   real(dl) :: fac,  PowerVals(20)
 22120   character(Len = 40) :: unitstr
 22121   character(Len = 8) :: PowerKeys(20)
 22122   logical COBEnorm
 22123 
 22124 
 22125   if (CP%InitPower%nn>1) write(*,*) &
 22126        'Warning: FITS file contains result for first power spectrum only'
 22127 
 22128   allocate(clout(2:lmx,1:4))
 22129    
 22130   call CAMB_GetCls(clout, lmx, 1, .false.)
 22131   !HealPix 1.2 uses E-B conventions
 22132 
 22133   if (CP%OutputNormalization = outCOBE) then
 22134      fac = 2*pi*CP%tcmb**2
 22135   else
 22136      if (CP%OutputNormalization > = 2) then
 22137       fac = 1
 22138      else
 22139       fac = OutputDenominator*CP%tcmb**2
 22140      end if
 22141   end if
 22142 
 22143 !FITS file has Cls without l(l+1)/twopi factors
 22144   do i = 2,lmx
 22145      clout(i,:) = clout(i,:)/i/dble(i+1)*fac
 22146   end do
 22147 
 22148   allocate(allcl(0:lmx,1:4))
 22149   allcl(2:lmx,1:4) = clout
 22150   allcl(0:1,1:4) = 0
 22151   deallocate(clout)
 22152 
 22153   header = ''
 22154 
 22155   if (CP%OutputNormalization = outCOBE) then
 22156      unitstr = 'Kelvin-squared'
 22157   else
 22158      unitstr = 'unknown'
 22159   end if
 22160 
 22161   call add_card(header,'COMMENT','-----------------------------------------------')
 22162   call add_card(header,'COMMENT','     CMB power spectrum C(l) keywords          ')
 22163   call add_card(header,'COMMENT','-----------------------------------------------')
 22164   call add_card(header,'EXTNAME','''COMPUTED POWER SPECTRUM''')
 22165   call add_card(header,'COMMENT',' POWER SPECTRUM : C(l) ')
 22166   call add_card(header)
 22167   call add_card(header,'CREATOR','CAMB',        'Software creating the FITS file')
 22168   call add_card(header,'VERSION',version,     'Version of the simulation software')
 22169   call add_card(header,'POLAR',.true.,'Polarisation included (True/False)')
 22170   call add_card(header,'POLNORM','CMBFAST','Uses E-B conventions')
 22171   call add_card(header)
 22172   call add_card(header)
 22173   call add_card(header,'TTYPE1', 'TEMPERATURE','Temperature C(l)')
 22174   call add_card(header,'TUNIT1', unitstr,'unit')
 22175   call add_card(header)
 22176 
 22177      call add_card(header,'TTYPE2', 'E-mode C_l','ELECTRIC polarisation C(l)')
 22178      call add_card(header,'TUNIT2', unitstr,'unit')
 22179      call add_card(header)
 22180 
 22181      call add_card(header,'TTYPE3', 'B-mode C_l','MAGNETIC polarisation C(l)')
 22182      call add_card(header,'TUNIT3', unitstr,'unit')
 22183      call add_card(header)
 22184 
 22185      call add_card(header,'TTYPE4', 'E-T cross corr.','Gradient-Temperature cross terms')
 22186      call add_card(header,'TUNIT4', unitstr,'unit')
 22187      call add_card(header)
 22188 
 22189  call add_card(header,'COMMENT','-----------------------------------------------')
 22190  call add_card(header,'COMMENT','     Cosmological parameters')
 22191  call add_card(header,'COMMENT','-----------------------------------------------')
 22192  call add_card(header,'OMEGAB',CP%omegab, 'Omega in baryons')
 22193  call add_card(header,'OMEGAC',CP%omegac, 'Omega in CDM')
 22194  call add_card(header,'OMEGAV',CP%omegav, 'Omega in cosmological constant')
 22195  call add_card(header,'OMEGAN',CP%omegan, 'Omega in neutrinos')
 22196  call add_card(header,'HUBBLE', CP%h0, 'Hublle constant in km/s/Mpc')
 22197  call add_card(header,'NNUNR',CP%Num_Nu_massive, 'number of massive neutrinos')
 22198  call add_card(header,'NNUR',CP%Num_Nu_massless, 'number of massless neutrinos')
 22199  call add_card(header,'TCMB',CP%tcmb, 'CMB temperature in Kelvin')
 22200  call add_card(header,'HELFRACT',CP%yhe, 'Helium fraction')
 22201  call add_card(header,'OPTDLSS',CP%Reion%optical_depth, 'reionisation optical depth')
 22202  call add_card(header,'IONFRACT',CP%Reion%fraction, 'ionisation fraction')
 22203  call add_card(header,'ZREION',CP%reion%redshift, 'reionisation redshift')
 22204  call add_card(header,'COMMENT','-----------------------------------------------')
 22205  call add_card(header,'COMMENT','     Other parameters')
 22206  call add_card(header,'COMMENT','-----------------------------------------------')
 22207  call add_card(header,'SCALARS',CP%WantScalars, 'includes scalar modes')
 22208  call add_card(header,'TENSORS',CP%WantTensors, 'includes tensor modes')
 22209  call add_card(header,'INITFLAG',CP%Scalar_initial_condition, 'initial condition flag') 
 22210  COBEnorm = CP%outputNormalization = outCOBE
 22211  call add_card(header,'COBENORM',COBEnorm, 'COBE normalized') 
 22212  call add_card(header,'KETA_MAX',CP%Max_eta_k, 'Max wavenumber') 
 22213  call add_card(header,'PRECIS',AccuracyBoost, 'Relative computation accuracy') 
 22214  call add_card(header,'EQS_FILE',Eqns_name, 'Gauge-dependent and background equations') 
 22215  call add_card(header,'POW_FILE',Power_Name, 'Initial power spectrum file') 
 22216  i = Power_Descript(1,CP%WantScalars,CP%WantTensors,PowerKeys,PowerVals)
 22217  do j = 1,i
 22218  call add_card(header,PowerKeys(j),PowerVals(j), 'Initial power spectrum details') 
 22219  end do
 22220   
 22221   nlheader = SIZE(header)
 22222   call write_asctab (allcl, lmx, 4, header, nlheader, Clsfile)
 22223   deallocate(allcl)
 22224 
 22225 end subroutine WriteFitsCls
 22226 
 22227 '' params.ini
 22228 
 22229 subroutine params.ini
 22230 
 22231 !Parameters for CAMB
 22232 
 22233 !output_root is prefixed to output file names
 22234 output_root = test
 22235 
 22236 !What to do
 22237 get_scalar_cls = T
 22238 get_vector_cls = F
 22239 get_tensor_cls = F
 22240 get_transfer   = F
 22241 
 22242 !if do_lensing then scalar_output_file contains additional columns of l^4 C_l^{pp} and l^3 C_l^{pT}
 22243 !where p is the projected potential. Output lensed CMB Cls (without tensors) are in lensed_output_file below.
 22244 do_lensing     = T
 22245 
 22246 ! 0: linear, 1: non-linear matter power (HALOFIT), 2: non-linear CMB lensing (HALOFIT)
 22247 do_nonlinear = 0
 22248 
 22249 !Maximum multipole and k*eta. 
 22250 !  Note that C_ls near l_max are inaccurate (about 5%), go to 50 more than you need
 22251 !  Lensed power spectra are computed to l_max_scalar-100 
 22252 !  To get accurate lensed BB need to have l_max_scalar>2000, k_eta_max_scalar > 10000
 22253 !  Otherwise k_eta_max_scalar = 2*l_max_scalar usually suffices, or don't set to use default
 22254 l_max_scalar      = 2200
 22255 !k_eta_max_scalar  = 4000
 22256 
 22257 !  Tensor settings should be less than or equal to the above
 22258 l_max_tensor      = 1500
 22259 k_eta_max_tensor  = 3000
 22260 
 22261 !Main cosmological parameters, neutrino masses are assumed degenerate
 22262 ! If use_phyical set phyiscal densities in baryone, CDM and neutrinos + Omega_k
 22263 use_physical   = T
 22264 ombh2          = 0.0226
 22265 omch2          = 0.112
 22266 omnuh2         = 0
 22267 omk            = 0
 22268 hubble         = 70
 22269 !effective equation of state parameter for dark energy, assumed constant
 22270 w              = -1
 22271 !constant comoving sound speed of the dark energy (1 = quintessence)
 22272 cs2_lam        = 1
 22273 
 22274 !if use_physical = F set parameters as here
 22275 !omega_baryon   = 0.0462
 22276 !omega_cdm      = 0.2538
 22277 !omega_lambda   = 0.7
 22278 !omega_neutrino = 0
 22279 
 22280 temp_cmb           = 2.726
 22281 helium_fraction    = 0.24
 22282 ! massless_neutrinos is the effective number (for QED + non-instantaneous decoupling)
 22283 ! fractional part of the number is used to increase the neutrino temperature, e.g.
 22284 ! 2.99 correponds to 2 neutrinos with a much higher temperature, 3.04 correponds to
 22285 ! 3 neutrinos with a slightly higher temperature. 3.046 is consistent with CosmoMC.
 22286 massless_neutrinos = 3.046
 22287 massive_neutrinos  = 0
 22288 
 22289 !Neutrino mass splittings
 22290 nu_mass_eigenstates = 1
 22291 !nu_mass_degeneracies = 0 sets nu_mass_degeneracies = massive_neutrinos
 22292 !otherwise should be an array
 22293 !e.g. for 3 neutrinos with 2 non-degenerate eigenstates, nu_mass_degeneracies = 2 1
 22294 nu_mass_degeneracies = 0  
 22295 !Fraction of total omega_nu h^2 accounted for by each eigenstate, eg. 0.5 0.5
 22296 nu_mass_fractions = 1
 22297 
 22298 !Initial power spectrum, amplitude, spectral index and running. Pivot k in Mpc^{-1}.
 22299 initial_power_num         = 1
 22300 pivot_scalar              = 0.05
 22301 pivot_tensor              = 0.05
 22302 scalar_amp(1)             = 2.1e-9
 22303 scalar_spectral_index(1)  = 0.96
 22304 scalar_nrun(1)            = 0
 22305 tensor_spectral_index(1)  = 0
 22306 !ratio is that of the initial tens/scal power spectrum amplitudes
 22307 initial_ratio(1)          = 1
 22308 !note vector modes use the scalar settings above
 22309 
 22310 
 22311 !Reionization, ignored unless reionization = T, re_redshift measures where x_e = 0.5
 22312 reionization         = T
 22313 
 22314 re_use_optical_depth = T
 22315 re_optical_depth     = 0.09
 22316 !If re_use_optical_depth = F then use following, otherwise ignored
 22317 re_redshift          = 11
 22318 !width of reionization transition. CMBFAST model was similar to re_delta_redshift~0.5.
 22319 re_delta_redshift    = 1.5
 22320 !re_ionization_frac = -1 sets to become fully ionized using YHe to get helium contribution
 22321 !Otherwise x_e varies from 0 to re_ionization_frac
 22322 re_ionization_frac   = -1
 22323 
 22324 
 22325 !RECFAST 1.5 recombination parameters;
 22326 RECFAST_fudge = 1.14
 22327 RECFAST_fudge_He = 0.86
 22328 RECFAST_Heswitch = 6
 22329 RECFAST_Hswitch  = T
 22330 
 22331 !Initial scalar perturbation mode (adiabatic = 1, CDM iso = 2, Baryon iso=3, 
 22332 ! neutrino density iso = 4, neutrino velocity iso = 5) 
 22333 initial_condition   = 1
 22334 !If above is zero, use modes in the following (totally correlated) proportions
 22335 !Note: we assume all modes have the same initial power spectrum
 22336 initial_vector = -1 0 0 0 0
 22337 
 22338 !For vector modes: 0 for regular (neutrino vorticity mode), 1 for magnetic
 22339 vector_mode = 0
 22340 
 22341 !Normalization
 22342 COBE_normalize = F
 22343 !!CMB_outputscale scales the output Cls
 22344 !To get MuK^2 set realistic initial amplitude (e.g. scalar_amp(1) = 2.3e-9 above) and
 22345 !otherwise for dimensionless transfer functions set scalar_amp(1) = 1 and use
 22346 !CMB_outputscale = 1
 22347 CMB_outputscale = 7.4311e12
 22348 
 22349 !Transfer function settings, transfer_kmax = 0.5 is enough for sigma_8
 22350 !transfer_k_per_logint = 0 sets sensible non-even sampling; 
 22351 !transfer_k_per_logint = 5 samples fixed spacing in log-k
 22352 !transfer_interp_matterpower = T produces matter power in regular interpolated grid in log k; 
 22353 ! use transfer_interp_matterpower = F to output calculated values (e.g. for later interpolation)
 22354 transfer_high_precision = F
 22355 transfer_kmax           = 2
 22356 transfer_k_per_logint   = 0
 22357 transfer_num_redshifts  = 1
 22358 transfer_interp_matterpower = T
 22359 transfer_redshift(1)    = 0
 22360 transfer_filename(1)    = transfer_out.dat
 22361 !Matter power spectrum output against k/h in units of h^{-3} Mpc^3
 22362 transfer_matterpower(1) = matterpower.dat
 22363 
 22364 
 22365 !Output files not produced if blank. make camb_fits to use use the FITS setting.
 22366 scalar_output_file = scalCls.dat
 22367 vector_output_file = vecCls.dat
 22368 tensor_output_file = tensCls.dat
 22369 total_output_file  = totCls.dat
 22370 lensed_output_file = lensedCls.dat
 22371 lensed_total_output_file  = lensedtotCls.dat
 22372 lens_potential_output_file = lenspotentialCls.dat
 22373 FITS_filename      = scalCls.fits
 22374 
 22375 !Bispectrum parameters if required; primordial is currently only local model (fnl = 1)
 22376 !lensing is fairly quick, primordial takes several minutes on quad core
 22377 do_lensing_bispectrum = F
 22378 do_primordial_bispectrum = F
 22379 
 22380 !1 for just temperature, 2 with E
 22381 bispectrum_nfields = 1
 22382 !set slice non-zero to output slice b_{bispectrum_slice_base_L L L+delta}
 22383 bispectrum_slice_base_L = 0
 22384 bispectrum_ndelta = 3
 22385 bispectrum_delta(1) = 0
 22386 bispectrum_delta(2) = 2
 22387 bispectrum_delta(3) = 4
 22388 !bispectrum_do_fisher estimates errors and correlations between bispectra
 22389 !note you need to compile with LAPACK and FISHER defined to use get the Fisher info
 22390 bispectrum_do_fisher = F
 22391 !Noise is in muK^2, e.g. 2e-4 roughly for Planck temperature
 22392 bispectrum_fisher_noise = 0
 22393 bispectrum_fisher_noise_pol = 0
 22394 bispectrum_fisher_fwhm_arcmin = 7
 22395 !Filename if you want to write full reduced bispectrum (at sampled values of l_1)
 22396 bispectrum_full_output_file =
 22397 bispectrum_full_output_sparse = F
 22398 !Export alpha_l(r), beta_l(r) for local non-Gaussianity
 22399 bispectrum_export_alpha_beta = F
 22400 
 22401 !!Optional parameters to control the computation speed,accuracy and feedback
 22402 
 22403 !If feedback_level > 0 print out useful information computed about the model
 22404 feedback_level = 1
 22405 
 22406 ! 1: curved correlation function, 2: flat correlation function, 3: inaccurate harmonic method
 22407 lensing_method = 1
 22408 accurate_BB = F
 22409 
 22410 
 22411 !massive_nu_approx: 0 - integrate distribution function
 22412 !                   1 - switch to series in velocity weight once non-relativistic
 22413 massive_nu_approx = 1
 22414 
 22415 !Whether you are bothered about polarization. 
 22416 accurate_polarization   = T
 22417 
 22418 !Whether you are bothered about percent accuracy on EE from reionization
 22419 accurate_reionization   = T
 22420 
 22421 !whether or not to include neutrinos in the tensor evolution equations
 22422 do_tensor_neutrinos     = T
 22423 
 22424 !Whether to turn off small-scale late time radiation hierarchies (save time,v. accurate)
 22425 do_late_rad_truncation   = T
 22426 
 22427 !Computation parameters
 22428 !if number_of_threads = 0 assigned automatically
 22429 number_of_threads       = 0
 22430 
 22431 !Default scalar accuracy is about 0.3% (except lensed BB) if high_accuracy_default = F
 22432 !If high_accuracy_default = T the default taget accuracy is 0.1% at L>600 (with boost parameter = 1 below)
 22433 !Try accuracy_boost = 2, l_accuracy_boost = 2 if you want to check stability/even higher accuracy
 22434 !Note increasing accuracy_boost parameters is very inefficient if you want higher accuracy,
 22435 !but high_accuracy_default is efficient 
 22436 
 22437 high_accuracy_default = F
 22438 
 22439 !Increase accuracy_boost to decrease time steps, use more k values,  etc.
 22440 !Decrease to speed up at cost of worse accuracy. Suggest 0.8 to 3.
 22441 accuracy_boost          = 1
 22442 
 22443 !Larger to keep more terms in the hierarchy evolution. 
 22444 l_accuracy_boost        = 1
 22445 
 22446 !Increase to use more C_l values for interpolation.
 22447 !Increasing a bit will improve the polarization accuracy at l up to 200 -
 22448 !interpolation errors may be up to 3%
 22449 !Decrease to speed up non-flat models a bit
 22450 l_sample_boost          = 1
 22451 
 22452 end subroutine params.ini