Index: trunk/src/threshold/threshold.nw =================================================================== --- trunk/src/threshold/threshold.nw (revision 8779) +++ trunk/src/threshold/threshold.nw (revision 8780) @@ -1,11176 +1,11593 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD threshold code as NOWEB source: threshold %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Infrastructure for threshold processes} \includemodulegraph{threshold} <<[[interpolation.f90]]>>= <> module interpolation - use kinds - implicit none +<> + +<> save - private +<> public :: interpolate_linear, strictly_monotonous +<> + + interface +<> + end interface + +end module interpolation +@ %def interpolation +@ +<<[[interpolation_sub.f90]]>>= +<> + +submodule (interpolation) interpolation_s + + implicit none + +<> + +contains + +<> + +end submodule interpolation_s + +@ %def interpolation_s +@ +<>= interface interpolate_linear module procedure interpolate_linear_1D_complex_array, & interpolate_linear_1D_complex_scalar, & interpolate_linear_1D_real_array, & interpolate_linear_1D_real_scalar, & interpolate_linear_2D_complex_array, & interpolate_linear_2D_complex_scalar, & interpolate_linear_2D_real_array, & interpolate_linear_2D_real_scalar, & interpolate_linear_3D_complex_array, & interpolate_linear_3D_complex_scalar, & interpolate_linear_3D_real_array, & interpolate_linear_3D_real_scalar end interface interface strictly_monotonous module procedure monotonous end interface strictly_monotonous interface find_nearest_left !!! recursive bisection is slower module procedure find_nearest_left_loop end interface find_nearest_left -contains - - pure subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y) +<>= + pure module subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y) + real(default), dimension(:), intent(in) :: xa + complex(default), dimension(:), intent(in) :: ya + real(default), intent(in) :: x + complex(default), intent(out) :: y + end subroutine interpolate_linear_1D_complex_scalar +<>= + pure module subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa complex(default), dimension(:), intent(in) :: ya real(default), intent(in) :: x complex(default), intent(out) :: y integer :: ixl real(default) :: t y = 0.0_default !!! don't check this at runtime: ! if ( .not.monotonous(xa) ) return if ( out_of_range(xa, x) ) return ixl = 0 call find_nearest_left (xa, x, ixl) t = ( x - xa(ixl) ) / ( xa(ixl+1) - xa(ixl) ) y = (1.-t)*ya(ixl) + t*ya(ixl+1) end subroutine interpolate_linear_1D_complex_scalar - pure subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y) +@ %def interpolate_linear_1D_complex_scalar +@ +<>= + pure module subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + complex(default), dimension(:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + complex(default), intent(out) :: y + end subroutine interpolate_linear_2D_complex_scalar +<>= + pure module subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a complex(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 complex(default), intent(out) :: y integer :: ix1l, ix2l real(default) :: t, u y = 0.0_default !!! don't check this at runtime: ! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) ) return ix1l = 0 call find_nearest_left (x1a, x1, ix1l) ix2l = 0 call find_nearest_left (x2a, x2, ix2l) t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) ) u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) ) y = (1.-t)*(1.-u)*ya(ix1l ,ix2l ) & + t *(1.-u)*ya(ix1l+1,ix2l ) & + t * u *ya(ix1l+1,ix2l+1) & +(1.-t)* u *ya(ix1l ,ix2l+1) end subroutine interpolate_linear_2D_complex_scalar - pure subroutine interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y) +@ %def interpolate_linear_2D_complex_scalar +@ +<>= + pure module subroutine interpolate_linear_3D_complex_scalar & + (x1a, x2a, x3a, ya, x1, x2, x3, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + real(default), dimension(:), intent(in) :: x3a + complex(default), dimension(:,:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + real(default), intent(in) :: x3 + complex(default), intent(out) :: y + end subroutine interpolate_linear_3D_complex_scalar +<>= + pure module subroutine interpolate_linear_3D_complex_scalar & + (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a complex(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 complex(default), intent(out) :: y integer :: ix1l, ix2l, ix3l real(default) :: t, u, v y = 0.0_default !!! don't check this at runtime: ! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) .or. out_of_range(x3a, x3) ) return ix1l = 0 call find_nearest_left (x1a, x1, ix1l) ix2l = 0 call find_nearest_left (x2a, x2, ix2l) ix3l = 0 call find_nearest_left (x3a, x3, ix3l) t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) ) u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) ) v = ( x3 - x3a(ix3l) ) / ( x3a(ix3l+1) - x3a(ix3l) ) y = (1.-t)*(1.-u)*(1.-v)*ya(ix1l ,ix2l ,ix3l ) & +(1.-t)*(1.-u)* v *ya(ix1l ,ix2l ,ix3l+1) & +(1.-t)* u *(1.-v)*ya(ix1l ,ix2l+1,ix3l ) & +(1.-t)* u * v *ya(ix1l ,ix2l+1,ix3l+1) & + t *(1.-u)*(1.-v)*ya(ix1l+1,ix2l ,ix3l ) & + t *(1.-u)* v *ya(ix1l+1,ix2l ,ix3l+1) & + t * u *(1.-v)*ya(ix1l+1,ix2l+1,ix3l ) & + t * u * v *ya(ix1l+1,ix2l+1,ix3l+1) end subroutine interpolate_linear_3D_complex_scalar - pure subroutine find_nearest_left_loop (xa, x, ixl) +@ %def interpolate_linear_3D_complex_scalar +@ +<>= + pure module subroutine find_nearest_left_loop (xa, x, ixl) + real(default), dimension(:), intent(in) :: xa + real(default), intent(in) :: x + integer, intent(out) :: ixl + end subroutine find_nearest_left_loop +<>= + pure module subroutine find_nearest_left_loop (xa, x, ixl) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x integer, intent(out) :: ixl integer :: ixm, ixr ixl = 1 ixr = size(xa) do if ( ixr-ixl <= 1 ) return ixm = (ixr+ixl) / 2 if ( x < xa(ixm) ) then ixr = ixm else ixl = ixm end if end do end subroutine find_nearest_left_loop +@ %def find_nearest_left_loop +@ +<>= pure recursive subroutine find_nearest_left_rec (xa, x, ixl) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x integer, intent(inout) :: ixl integer :: nx, bs real(default), dimension(:), allocatable :: xa_new nx = size(xa) bs = nx/2 + 1 if ( nx < 3 ) then ixl = ixl + bs - 1 return else if ( x < xa(bs) ) then allocate( xa_new(1:bs) ) xa_new = xa(1:bs) else ixl = ixl + bs - 1 allocate( xa_new(bs:nx) ) xa_new = xa(bs:nx) end if call find_nearest_left_rec (xa_new, x, ixl) deallocate( xa_new ) end if end subroutine find_nearest_left_rec - pure function monotonous (xa) result (flag) +@ %def find_nearest_left_rec +@ +<>= + pure module function monotonous (xa) result (flag) + real(default), dimension(:), intent(in) :: xa + logical :: flag + end function monotonous +<>= + pure module function monotonous (xa) result (flag) real(default), dimension(:), intent(in) :: xa integer :: ix logical :: flag flag = .false. do ix = 1, size(xa)-1 flag = ( xa(ix) < xa(ix+1) ) if ( .not. flag ) return end do end function monotonous +@ %def monotonous +@ +<>= pure function out_of_range (xa, x) result (flag) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x logical :: flag flag = ( x < xa(1) .or. x > xa(size(xa)) ) end function out_of_range - pure subroutine interpolate_linear_1D_complex_array (xa, ya, x, y) +@ %def out_of_range +@ +<>= + pure module subroutine interpolate_linear_1D_complex_array (xa, ya, x, y) + real(default), dimension(:), intent(in) :: xa + complex(default), dimension(:,:), intent(in) :: ya + real(default), intent(in) :: x + complex(default), dimension(size(ya(1,:))), intent(out) :: y + end subroutine interpolate_linear_1D_complex_array +<>= + pure module subroutine interpolate_linear_1D_complex_array (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa complex(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x complex(default), dimension(size(ya(1,:))), intent(out) :: y integer :: iy do iy=1, size(y) call interpolate_linear_1D_complex_scalar (xa, ya(:,iy), x, y(iy)) end do end subroutine interpolate_linear_1D_complex_array - pure subroutine interpolate_linear_1D_real_array (xa, ya, x, y) +@ %def interpolate_linear_1D_complex_array +@ +<>= + pure module subroutine interpolate_linear_1D_real_array (xa, ya, x, y) + real(default), dimension(:), intent(in) :: xa + real(default), dimension(:,:), intent(in) :: ya + real(default), intent(in) :: x + real(default), dimension(:), intent(out) :: y + end subroutine interpolate_linear_1D_real_array +<>= + pure module subroutine interpolate_linear_1D_real_array (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa real(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x real(default), dimension(:), intent(out) :: y complex(default), dimension(size(ya(1,:))) :: y_c call interpolate_linear_1D_complex_array (xa, cmplx(ya,kind=default), x, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_1D_real_array - pure subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y) +@ %def interpolate_linear_1D_real_array +@ +<>= + pure module subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y) + real(default), dimension(:), intent(in) :: xa + real(default), dimension(:), intent(in) :: ya + real(default), intent(in) :: x + real(default), intent(out) :: y + complex(default), dimension(size(ya)) :: ya_c + end subroutine interpolate_linear_1D_real_scalar +<>= + pure module subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y) real(default), dimension(:), intent(in) :: xa real(default), dimension(:), intent(in) :: ya real(default), intent(in) :: x real(default), intent(out) :: y complex(default), dimension(size(ya)) :: ya_c complex(default) :: y_c ya_c = cmplx(ya,kind=default) call interpolate_linear_1D_complex_scalar (xa, ya_c, x, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_1D_real_scalar - pure subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y) +@ %def interpolate_linear_1D_real_scalar +@ +<>= + pure module subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + complex(default), dimension(:,:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + complex(default), dimension(size(ya(1,1,:))), intent(out) :: y + end subroutine interpolate_linear_2D_complex_array +<>= + pure module subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a complex(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 complex(default), dimension(size(ya(1,1,:))), intent(out) :: y integer :: iy do iy=1, size(y) call interpolate_linear_2D_complex_scalar (x1a, x2a, ya(:,:,iy), x1, x2, y(iy)) end do end subroutine interpolate_linear_2D_complex_array - pure subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y) +@ %def interpolate_linear_2D_complex_array +@ +<>= + pure module subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + real(default), dimension(:,:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + real(default), dimension(:), intent(out) :: y + end subroutine interpolate_linear_2D_real_array +<>= + pure module subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), dimension(:), intent(out) :: y complex(default), dimension(size(ya(1,1,:))) :: y_c call interpolate_linear_2D_complex_array (x1a, x2a, cmplx(ya,kind=default), x1, x2, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_2D_real_array - pure subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y) +@ %def interpolate_linear_2D_real_array +@ +<>= + pure module subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + real(default), dimension(:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + real(default), intent(out) :: y + end subroutine interpolate_linear_2D_real_scalar +<>= + pure module subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(out) :: y complex(default), dimension(size(ya(:,1)),size(ya(1,:))) :: ya_c complex(default) :: y_c ya_c = reshape (ya_c, shape(ya)) ya_c = cmplx(ya,kind=default) call interpolate_linear_2D_complex_scalar (x1a, x2a, ya_c, x1, x2, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_2D_real_scalar - pure subroutine interpolate_linear_3D_complex_array (x1a, x2a, x3a, ya, x1, x2, x3, y) +@ %def interpolate_linear_2D_real_scalar +@ +<>= + pure module subroutine interpolate_linear_3D_complex_array & + (x1a, x2a, x3a, ya, x1, x2, x3, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + real(default), dimension(:), intent(in) :: x3a + complex(default), dimension(:,:,:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + real(default), intent(in) :: x3 + complex(default), dimension(size(ya(1,1,1,:))), intent(out) :: y + end subroutine interpolate_linear_3D_complex_array +<>= + pure module subroutine interpolate_linear_3D_complex_array & + (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a complex(default), dimension(:,:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 complex(default), dimension(size(ya(1,1,1,:))), intent(out) :: y integer :: iy do iy=1, size(y) call interpolate_linear_3D_complex_scalar & (x1a, x2a, x3a, ya(:,:,:,iy), x1, x2, x3, y(iy)) end do end subroutine interpolate_linear_3D_complex_array - pure subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y) +@ %def interpolate_linear_3D_complex_array +@ +<>= + pure module subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + real(default), dimension(:), intent(in) :: x3a + real(default), dimension(:,:,:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + real(default), intent(in) :: x3 + real(default), dimension(:), intent(out) :: y + end subroutine interpolate_linear_3D_real_array +<>= + pure module subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a real(default), dimension(:,:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 real(default), dimension(:), intent(out) :: y complex(default), dimension(size(ya(1,1,1,:))) :: y_c call interpolate_linear_3D_complex_array & (x1a, x2a, x3a, cmplx(ya,kind=default), x1, x2, x3, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_3D_real_array - pure subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y) +@ %def interpolate_linear_3D_real_array +@ +<>= + pure module subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y) + real(default), dimension(:), intent(in) :: x1a + real(default), dimension(:), intent(in) :: x2a + real(default), dimension(:), intent(in) :: x3a + real(default), dimension(:,:,:), intent(in) :: ya + real(default), intent(in) :: x1 + real(default), intent(in) :: x2 + real(default), intent(in) :: x3 + real(default), intent(out) :: y + end subroutine interpolate_linear_3D_real_scalar +<>= + pure module subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y) real(default), dimension(:), intent(in) :: x1a real(default), dimension(:), intent(in) :: x2a real(default), dimension(:), intent(in) :: x3a real(default), dimension(:,:,:), intent(in) :: ya real(default), intent(in) :: x1 real(default), intent(in) :: x2 real(default), intent(in) :: x3 real(default), intent(out) :: y complex(default), dimension(size(ya(:,1,1)),size(ya(1,:,1)),size(ya(1,1,:))) :: ya_c complex(default) :: y_c ya_c = cmplx(ya,kind=default) call interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya_c, x1, x2, x3, y_c) y = real(y_c,kind=default) end subroutine interpolate_linear_3D_real_scalar -end module interpolation + +@ %def interpolate_linear_3D_real_scalar @ <<[[nr_tools.f90]]>>= !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! WHIZARD <> <> ! routine hypgeo and other useful procedures from: ! ! Numerical Recipes in Fortran 77 and 90 (Second Edition) ! ! Book and code Copyright (c) 1986-2001, ! William H. Press, Saul A. Teukolsky, ! William T. Verrerling, Brian P. Flannery. ! ! Information at http://www.nr.com ! ! ! ! FB: -replaced tabs by 2 whitespaces ! -reduced hardcoded default stepsize for subroutine 'odeint' ! called by hypgeo, cf. line 4751 ! -added explicit interface for function 'qgaus' to main module 'nr' ! -renamed function 'locate' to 'locatenr' to avoid segfault (???) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MODULE nrtype INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) INTEGER, PARAMETER :: SP = KIND(1.0) INTEGER, PARAMETER :: DP = KIND(1.0D0) INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) INTEGER, PARAMETER :: LGT = KIND(.true.) REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp TYPE sprs2_sp INTEGER(I4B) :: n,len REAL(SP), DIMENSION(:), POINTER :: val INTEGER(I4B), DIMENSION(:), POINTER :: irow INTEGER(I4B), DIMENSION(:), POINTER :: jcol END TYPE sprs2_sp TYPE sprs2_dp INTEGER(I4B) :: n,len REAL(DP), DIMENSION(:), POINTER :: val INTEGER(I4B), DIMENSION(:), POINTER :: irow INTEGER(I4B), DIMENSION(:), POINTER :: jcol END TYPE sprs2_dp END MODULE nrtype MODULE nrutil USE nrtype IMPLICIT NONE INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8 INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2 INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16 INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8 INTEGER(I4B), PARAMETER :: NPAR_POLY=8 INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8 INTERFACE array_copy MODULE PROCEDURE array_copy_r, array_copy_d, array_copy_i END INTERFACE INTERFACE swap MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, & swap_cv,swap_cm,swap_z,swap_zv,swap_zm, & masked_swap_rs,masked_swap_rv,masked_swap_rm END INTERFACE INTERFACE reallocate MODULE PROCEDURE reallocate_rv,reallocate_rm,& reallocate_iv,reallocate_im,reallocate_hv END INTERFACE INTERFACE imaxloc MODULE PROCEDURE imaxloc_r,imaxloc_i END INTERFACE INTERFACE assert MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v END INTERFACE INTERFACE assert_eq MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn END INTERFACE INTERFACE arth MODULE PROCEDURE arth_r, arth_d, arth_i END INTERFACE INTERFACE geop MODULE PROCEDURE geop_r, geop_d, geop_i, geop_c, geop_dv END INTERFACE INTERFACE cumsum MODULE PROCEDURE cumsum_r,cumsum_i END INTERFACE INTERFACE poly MODULE PROCEDURE poly_rr,poly_rrv,poly_dd,poly_ddv,& poly_rc,poly_cc,poly_msk_rrv,poly_msk_ddv END INTERFACE INTERFACE poly_term MODULE PROCEDURE poly_term_rr,poly_term_cc END INTERFACE INTERFACE outerprod MODULE PROCEDURE outerprod_r,outerprod_d END INTERFACE INTERFACE outerdiff MODULE PROCEDURE outerdiff_r,outerdiff_d,outerdiff_i END INTERFACE INTERFACE scatter_add MODULE PROCEDURE scatter_add_r,scatter_add_d END INTERFACE INTERFACE scatter_max MODULE PROCEDURE scatter_max_r,scatter_max_d END INTERFACE INTERFACE diagadd MODULE PROCEDURE diagadd_rv,diagadd_r END INTERFACE INTERFACE diagmult MODULE PROCEDURE diagmult_rv,diagmult_r END INTERFACE INTERFACE get_diag MODULE PROCEDURE get_diag_rv, get_diag_dv END INTERFACE INTERFACE put_diag MODULE PROCEDURE put_diag_rv, put_diag_r END INTERFACE CONTAINS !BL SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied) REAL(SP), DIMENSION(:), INTENT(IN) :: src REAL(SP), DIMENSION(:), INTENT(OUT) :: dest INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied n_copied=min(size(src),size(dest)) n_not_copied=size(src)-n_copied dest(1:n_copied)=src(1:n_copied) END SUBROUTINE array_copy_r !BL SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied) REAL(DP), DIMENSION(:), INTENT(IN) :: src REAL(DP), DIMENSION(:), INTENT(OUT) :: dest INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied n_copied=min(size(src),size(dest)) n_not_copied=size(src)-n_copied dest(1:n_copied)=src(1:n_copied) END SUBROUTINE array_copy_d !BL SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied n_copied=min(size(src),size(dest)) n_not_copied=size(src)-n_copied dest(1:n_copied)=src(1:n_copied) END SUBROUTINE array_copy_i !BL !BL SUBROUTINE swap_i(a,b) INTEGER(I4B), INTENT(INOUT) :: a,b INTEGER(I4B) :: dum dum=a a=b b=dum END SUBROUTINE swap_i !BL SUBROUTINE swap_r(a,b) REAL(SP), INTENT(INOUT) :: a,b REAL(SP) :: dum dum=a a=b b=dum END SUBROUTINE swap_r !BL SUBROUTINE swap_rv(a,b) REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b REAL(SP), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum END SUBROUTINE swap_rv !BL SUBROUTINE swap_c(a,b) COMPLEX(SPC), INTENT(INOUT) :: a,b COMPLEX(SPC) :: dum dum=a a=b b=dum END SUBROUTINE swap_c !BL SUBROUTINE swap_cv(a,b) COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum END SUBROUTINE swap_cv !BL SUBROUTINE swap_cm(a,b) COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum dum=a a=b b=dum END SUBROUTINE swap_cm !BL SUBROUTINE swap_z(a,b) COMPLEX(DPC), INTENT(INOUT) :: a,b COMPLEX(DPC) :: dum dum=a a=b b=dum END SUBROUTINE swap_z !BL SUBROUTINE swap_zv(a,b) COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: a,b COMPLEX(DPC), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum END SUBROUTINE swap_zv !BL SUBROUTINE swap_zm(a,b) COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: a,b COMPLEX(DPC), DIMENSION(size(a,1),size(a,2)) :: dum dum=a a=b b=dum END SUBROUTINE swap_zm !BL SUBROUTINE masked_swap_rs(a,b,mask) REAL(SP), INTENT(INOUT) :: a,b LOGICAL(LGT), INTENT(IN) :: mask REAL(SP) :: swp if (mask) then swp=a a=b b=swp end if END SUBROUTINE masked_swap_rs !BL SUBROUTINE masked_swap_rv(a,b,mask) REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask REAL(SP), DIMENSION(size(a)) :: swp where (mask) swp=a a=b b=swp end where END SUBROUTINE masked_swap_rv !BL SUBROUTINE masked_swap_rm(a,b,mask) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp where (mask) swp=a a=b b=swp end where END SUBROUTINE masked_swap_rm !BL !BL FUNCTION reallocate_rv(p,n) REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B) :: nold,ierr allocate(reallocate_rv(n),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_rv: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p) reallocate_rv(1:min(nold,n))=p(1:min(nold,n)) deallocate(p) END FUNCTION reallocate_rv !BL FUNCTION reallocate_iv(p,n) INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B) :: nold,ierr allocate(reallocate_iv(n),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_iv: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p) reallocate_iv(1:min(nold,n))=p(1:min(nold,n)) deallocate(p) END FUNCTION reallocate_iv !BL FUNCTION reallocate_hv(p,n) CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B) :: nold,ierr allocate(reallocate_hv(n),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_hv: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p) reallocate_hv(1:min(nold,n))=p(1:min(nold,n)) deallocate(p) END FUNCTION reallocate_hv !BL FUNCTION reallocate_rm(p,n,m) REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm INTEGER(I4B), INTENT(IN) :: n,m INTEGER(I4B) :: nold,mold,ierr allocate(reallocate_rm(n,m),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_rm: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p,1) mold=size(p,2) reallocate_rm(1:min(nold,n),1:min(mold,m))=& p(1:min(nold,n),1:min(mold,m)) deallocate(p) END FUNCTION reallocate_rm !BL FUNCTION reallocate_im(p,n,m) INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im INTEGER(I4B), INTENT(IN) :: n,m INTEGER(I4B) :: nold,mold,ierr allocate(reallocate_im(n,m),stat=ierr) if (ierr /= 0) call & nrerror('reallocate_im: problem in attempt to allocate memory') if (.not. associated(p)) RETURN nold=size(p,1) mold=size(p,2) reallocate_im(1:min(nold,n),1:min(mold,m))=& p(1:min(nold,n),1:min(mold,m)) deallocate(p) END FUNCTION reallocate_im !BL FUNCTION ifirstloc(mask) LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask INTEGER(I4B) :: ifirstloc INTEGER(I4B), DIMENSION(1) :: loc loc=maxloc(merge(1,0,mask)) ifirstloc=loc(1) if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1 END FUNCTION ifirstloc !BL FUNCTION imaxloc_r(arr) REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B) :: imaxloc_r INTEGER(I4B), DIMENSION(1) :: imax imax=maxloc(arr(:)) imaxloc_r=imax(1) END FUNCTION imaxloc_r !BL FUNCTION imaxloc_i(iarr) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr INTEGER(I4B), DIMENSION(1) :: imax INTEGER(I4B) :: imaxloc_i imax=maxloc(iarr(:)) imaxloc_i=imax(1) END FUNCTION imaxloc_i !BL FUNCTION iminloc(arr) REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(1) :: imin INTEGER(I4B) :: iminloc imin=minloc(arr(:)) iminloc=imin(1) END FUNCTION iminloc !BL SUBROUTINE assert1(n1,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1 if (.not. n1) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert1' end if END SUBROUTINE assert1 !BL SUBROUTINE assert2(n1,n2,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1,n2 if (.not. (n1 .and. n2)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert2' end if END SUBROUTINE assert2 !BL SUBROUTINE assert3(n1,n2,n3,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1,n2,n3 if (.not. (n1 .and. n2 .and. n3)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert3' end if END SUBROUTINE assert3 !BL SUBROUTINE assert4(n1,n2,n3,n4,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, INTENT(IN) :: n1,n2,n3,n4 if (.not. (n1 .and. n2 .and. n3 .and. n4)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert4' end if END SUBROUTINE assert4 !BL SUBROUTINE assert_v(n,string) CHARACTER(LEN=*), INTENT(IN) :: string LOGICAL, DIMENSION(:), INTENT(IN) :: n if (.not. all(n)) then write (*,*) 'nrerror: an assertion failed with this tag:', & string STOP 'program terminated by assert_v' end if END SUBROUTINE assert_v !BL FUNCTION assert_eq2(n1,n2,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, INTENT(IN) :: n1,n2 INTEGER :: assert_eq2 if (n1 == n2) then assert_eq2=n1 else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eq2' end if END FUNCTION assert_eq2 !BL FUNCTION assert_eq3(n1,n2,n3,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, INTENT(IN) :: n1,n2,n3 INTEGER :: assert_eq3 if (n1 == n2 .and. n2 == n3) then assert_eq3=n1 else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eq3' end if END FUNCTION assert_eq3 !BL FUNCTION assert_eq4(n1,n2,n3,n4,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, INTENT(IN) :: n1,n2,n3,n4 INTEGER :: assert_eq4 if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then assert_eq4=n1 else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eq4' end if END FUNCTION assert_eq4 !BL FUNCTION assert_eqn(nn,string) CHARACTER(LEN=*), INTENT(IN) :: string INTEGER, DIMENSION(:), INTENT(IN) :: nn INTEGER :: assert_eqn if (all(nn(2:) == nn(1))) then assert_eqn=nn(1) else write (*,*) 'nrerror: an assert_eq failed with this tag:', & string STOP 'program terminated by assert_eqn' end if END FUNCTION assert_eqn !BL SUBROUTINE nrerror(string) CHARACTER(LEN=*), INTENT(IN) :: string write (*,*) 'nrerror: ',string STOP 'program terminated by nrerror' END SUBROUTINE nrerror !BL FUNCTION arth_r(first,increment,n) REAL(SP), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: arth_r INTEGER(I4B) :: k,k2 REAL(SP) :: temp if (n > 0) arth_r(1)=first if (n <= NPAR_ARTH) then do k=2,n arth_r(k)=arth_r(k-1)+increment end do else do k=2,NPAR2_ARTH arth_r(k)=arth_r(k-1)+increment end do temp=increment*NPAR2_ARTH k=NPAR2_ARTH do if (k >= n) exit k2=k+k arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k)) temp=temp+temp k=k2 end do end if END FUNCTION arth_r !BL FUNCTION arth_d(first,increment,n) REAL(DP), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n REAL(DP), DIMENSION(n) :: arth_d INTEGER(I4B) :: k,k2 REAL(DP) :: temp if (n > 0) arth_d(1)=first if (n <= NPAR_ARTH) then do k=2,n arth_d(k)=arth_d(k-1)+increment end do else do k=2,NPAR2_ARTH arth_d(k)=arth_d(k-1)+increment end do temp=increment*NPAR2_ARTH k=NPAR2_ARTH do if (k >= n) exit k2=k+k arth_d(k+1:min(k2,n))=temp+arth_d(1:min(k,n-k)) temp=temp+temp k=k2 end do end if END FUNCTION arth_d !BL FUNCTION arth_i(first,increment,n) INTEGER(I4B), INTENT(IN) :: first,increment,n INTEGER(I4B), DIMENSION(n) :: arth_i INTEGER(I4B) :: k,k2,temp if (n > 0) arth_i(1)=first if (n <= NPAR_ARTH) then do k=2,n arth_i(k)=arth_i(k-1)+increment end do else do k=2,NPAR2_ARTH arth_i(k)=arth_i(k-1)+increment end do temp=increment*NPAR2_ARTH k=NPAR2_ARTH do if (k >= n) exit k2=k+k arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k)) temp=temp+temp k=k2 end do end if END FUNCTION arth_i !BL !BL FUNCTION geop_r(first,factor,n) REAL(SP), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: geop_r INTEGER(I4B) :: k,k2 REAL(SP) :: temp if (n > 0) geop_r(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_r(k)=geop_r(k-1)*factor end do else do k=2,NPAR2_GEOP geop_r(k)=geop_r(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_r !BL FUNCTION geop_d(first,factor,n) REAL(DP), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n REAL(DP), DIMENSION(n) :: geop_d INTEGER(I4B) :: k,k2 REAL(DP) :: temp if (n > 0) geop_d(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_d(k)=geop_d(k-1)*factor end do else do k=2,NPAR2_GEOP geop_d(k)=geop_d(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_d(k+1:min(k2,n))=temp*geop_d(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_d !BL FUNCTION geop_i(first,factor,n) INTEGER(I4B), INTENT(IN) :: first,factor,n INTEGER(I4B), DIMENSION(n) :: geop_i INTEGER(I4B) :: k,k2,temp if (n > 0) geop_i(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_i(k)=geop_i(k-1)*factor end do else do k=2,NPAR2_GEOP geop_i(k)=geop_i(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_i !BL FUNCTION geop_c(first,factor,n) COMPLEX(SP), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n COMPLEX(SP), DIMENSION(n) :: geop_c INTEGER(I4B) :: k,k2 COMPLEX(SP) :: temp if (n > 0) geop_c(1)=first if (n <= NPAR_GEOP) then do k=2,n geop_c(k)=geop_c(k-1)*factor end do else do k=2,NPAR2_GEOP geop_c(k)=geop_c(k-1)*factor end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k)) temp=temp*temp k=k2 end do end if END FUNCTION geop_c !BL FUNCTION geop_dv(first,factor,n) REAL(DP), DIMENSION(:), INTENT(IN) :: first,factor INTEGER(I4B), INTENT(IN) :: n REAL(DP), DIMENSION(size(first),n) :: geop_dv INTEGER(I4B) :: k,k2 REAL(DP), DIMENSION(size(first)) :: temp if (n > 0) geop_dv(:,1)=first(:) if (n <= NPAR_GEOP) then do k=2,n geop_dv(:,k)=geop_dv(:,k-1)*factor(:) end do else do k=2,NPAR2_GEOP geop_dv(:,k)=geop_dv(:,k-1)*factor(:) end do temp=factor**NPAR2_GEOP k=NPAR2_GEOP do if (k >= n) exit k2=k+k geop_dv(:,k+1:min(k2,n))=geop_dv(:,1:min(k,n-k))*& spread(temp,2,size(geop_dv(:,1:min(k,n-k)),2)) temp=temp*temp k=k2 end do end if END FUNCTION geop_dv !BL !BL RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans) REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP), OPTIONAL, INTENT(IN) :: seed REAL(SP), DIMENSION(size(arr)) :: ans INTEGER(I4B) :: n,j REAL(SP) :: sd n=size(arr) if (n == 0_i4b) RETURN sd=0.0_sp if (present(seed)) sd=seed ans(1)=arr(1)+sd if (n < NPAR_CUMSUM) then do j=2,n ans(j)=ans(j-1)+arr(j) end do else ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd) ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) end if END FUNCTION cumsum_r !BL RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed INTEGER(I4B), DIMENSION(size(arr)) :: ans INTEGER(I4B) :: n,j,sd n=size(arr) if (n == 0_i4b) RETURN sd=0_i4b if (present(seed)) sd=seed ans(1)=arr(1)+sd if (n < NPAR_CUMSUM) then do j=2,n ans(j)=ans(j-1)+arr(j) end do else ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd) ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) end if END FUNCTION cumsum_i !BL !BL RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans) REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP), OPTIONAL, INTENT(IN) :: seed REAL(SP), DIMENSION(size(arr)) :: ans INTEGER(I4B) :: n,j REAL(SP) :: sd n=size(arr) if (n == 0_i4b) RETURN sd=1.0_sp if (present(seed)) sd=seed ans(1)=arr(1)*sd if (n < NPAR_CUMPROD) then do j=2,n ans(j)=ans(j-1)*arr(j) end do else ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd) ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2) end if END FUNCTION cumprod !BL !BL FUNCTION poly_rr(x,coeffs) REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs REAL(SP) :: poly_rr REAL(SP) :: pow REAL(SP), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_rr=0.0_sp else if (n < NPAR_POLY) then poly_rr=coeffs(n) do i=n-1,1,-1 poly_rr=x*poly_rr+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_sp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_rr=vec(1) deallocate(vec) end if END FUNCTION poly_rr !BL FUNCTION poly_dd(x,coeffs) REAL(DP), INTENT(IN) :: x REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs REAL(DP) :: poly_dd REAL(DP) :: pow REAL(DP), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_dd=0.0_dp else if (n < NPAR_POLY) then poly_dd=coeffs(n) do i=n-1,1,-1 poly_dd=x*poly_dd+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_dp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_dd=vec(1) deallocate(vec) end if END FUNCTION poly_dd !BL FUNCTION poly_rc(x,coeffs) COMPLEX(SPC), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs COMPLEX(SPC) :: poly_rc COMPLEX(SPC) :: pow COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_rc=0.0_sp else if (n < NPAR_POLY) then poly_rc=coeffs(n) do i=n-1,1,-1 poly_rc=x*poly_rc+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_sp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_rc=vec(1) deallocate(vec) end if END FUNCTION poly_rc !BL FUNCTION poly_cc(x,coeffs) COMPLEX(SPC), INTENT(IN) :: x COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs COMPLEX(SPC) :: poly_cc COMPLEX(SPC) :: pow COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec INTEGER(I4B) :: i,n,nn n=size(coeffs) if (n <= 0) then poly_cc=0.0_sp else if (n < NPAR_POLY) then poly_cc=coeffs(n) do i=n-1,1,-1 poly_cc=x*poly_cc+coeffs(i) end do else allocate(vec(n+1)) pow=x vec(1:n)=coeffs do vec(n+1)=0.0_sp nn=ishft(n+1,-1) vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) if (nn == 1) exit pow=pow*pow n=nn end do poly_cc=vec(1) deallocate(vec) end if END FUNCTION poly_cc !BL FUNCTION poly_rrv(x,coeffs) REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x REAL(SP), DIMENSION(size(x)) :: poly_rrv INTEGER(I4B) :: i,n,m m=size(coeffs) n=size(x) if (m <= 0) then poly_rrv=0.0_sp else if (m < n .or. m < NPAR_POLY) then poly_rrv=coeffs(m) do i=m-1,1,-1 poly_rrv=x*poly_rrv+coeffs(i) end do else do i=1,n poly_rrv(i)=poly_rr(x(i),coeffs) end do end if END FUNCTION poly_rrv !BL FUNCTION poly_ddv(x,coeffs) REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x REAL(DP), DIMENSION(size(x)) :: poly_ddv INTEGER(I4B) :: i,n,m m=size(coeffs) n=size(x) if (m <= 0) then poly_ddv=0.0_dp else if (m < n .or. m < NPAR_POLY) then poly_ddv=coeffs(m) do i=m-1,1,-1 poly_ddv=x*poly_ddv+coeffs(i) end do else do i=1,n poly_ddv(i)=poly_dd(x(i),coeffs) end do end if END FUNCTION poly_ddv !BL FUNCTION poly_msk_rrv(x,coeffs,mask) REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp) END FUNCTION poly_msk_rrv !BL FUNCTION poly_msk_ddv(x,coeffs,mask) REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask REAL(DP), DIMENSION(size(x)) :: poly_msk_ddv poly_msk_ddv=unpack(poly_ddv(pack(x,mask),coeffs),mask,0.0_dp) END FUNCTION poly_msk_ddv !BL !BL RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u) REAL(SP), DIMENSION(:), INTENT(IN) :: a REAL(SP), INTENT(IN) :: b REAL(SP), DIMENSION(size(a)) :: u INTEGER(I4B) :: n,j n=size(a) if (n <= 0) RETURN u(1)=a(1) if (n < NPAR_POLYTERM) then do j=2,n u(j)=a(j)+b*u(j-1) end do else u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b) u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) end if END FUNCTION poly_term_rr !BL RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u) COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a COMPLEX(SPC), INTENT(IN) :: b COMPLEX(SPC), DIMENSION(size(a)) :: u INTEGER(I4B) :: n,j n=size(a) if (n <= 0) RETURN u(1)=a(1) if (n < NPAR_POLYTERM) then do j=2,n u(j)=a(j)+b*u(j-1) end do else u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b) u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) end if END FUNCTION poly_term_cc !BL !BL FUNCTION zroots_unity(n,nn) INTEGER(I4B), INTENT(IN) :: n,nn COMPLEX(SPC), DIMENSION(nn) :: zroots_unity INTEGER(I4B) :: k REAL(SP) :: theta zroots_unity(1)=1.0 theta=TWOPI/n k=1 do if (k >= nn) exit zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC) zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*& zroots_unity(2:min(k,nn-k)) k=2*k end do END FUNCTION zroots_unity !BL FUNCTION outerprod_r(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r outerprod_r = spread(a,dim=2,ncopies=size(b)) * & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerprod_r !BL FUNCTION outerprod_d(a,b) REAL(DP), DIMENSION(:), INTENT(IN) :: a,b REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d outerprod_d = spread(a,dim=2,ncopies=size(b)) * & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerprod_d !BL FUNCTION outerdiv(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv outerdiv = spread(a,dim=2,ncopies=size(b)) / & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiv !BL FUNCTION outersum(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outersum outersum = spread(a,dim=2,ncopies=size(b)) + & spread(b,dim=1,ncopies=size(a)) END FUNCTION outersum !BL FUNCTION outerdiff_r(a,b) REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r outerdiff_r = spread(a,dim=2,ncopies=size(b)) - & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiff_r !BL FUNCTION outerdiff_d(a,b) REAL(DP), DIMENSION(:), INTENT(IN) :: a,b REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d outerdiff_d = spread(a,dim=2,ncopies=size(b)) - & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiff_d !BL FUNCTION outerdiff_i(a,b) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i outerdiff_i = spread(a,dim=2,ncopies=size(b)) - & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerdiff_i !BL FUNCTION outerand(a,b) LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand outerand = spread(a,dim=2,ncopies=size(b)) .and. & spread(b,dim=1,ncopies=size(a)) END FUNCTION outerand !BL SUBROUTINE scatter_add_r(dest,source,dest_index) REAL(SP), DIMENSION(:), INTENT(OUT) :: dest REAL(SP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_add_r') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) end do END SUBROUTINE scatter_add_r SUBROUTINE scatter_add_d(dest,source,dest_index) REAL(DP), DIMENSION(:), INTENT(OUT) :: dest REAL(DP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_add_d') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) end do END SUBROUTINE scatter_add_d SUBROUTINE scatter_max_r(dest,source,dest_index) REAL(SP), DIMENSION(:), INTENT(OUT) :: dest REAL(SP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_max_r') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) end do END SUBROUTINE scatter_max_r SUBROUTINE scatter_max_d(dest,source,dest_index) REAL(DP), DIMENSION(:), INTENT(OUT) :: dest REAL(DP), DIMENSION(:), INTENT(IN) :: source INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index INTEGER(I4B) :: m,n,j,i n=assert_eq2(size(source),size(dest_index),'scatter_max_d') m=size(dest) do j=1,n i=dest_index(j) if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) end do END SUBROUTINE scatter_max_d !BL SUBROUTINE diagadd_rv(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), DIMENSION(:), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv') do j=1,n mat(j,j)=mat(j,j)+diag(j) end do END SUBROUTINE diagadd_rv !BL SUBROUTINE diagadd_r(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = min(size(mat,1),size(mat,2)) do j=1,n mat(j,j)=mat(j,j)+diag end do END SUBROUTINE diagadd_r !BL SUBROUTINE diagmult_rv(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), DIMENSION(:), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv') do j=1,n mat(j,j)=mat(j,j)*diag(j) end do END SUBROUTINE diagmult_rv !BL SUBROUTINE diagmult_r(mat,diag) REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat REAL(SP), INTENT(IN) :: diag INTEGER(I4B) :: j,n n = min(size(mat,1),size(mat,2)) do j=1,n mat(j,j)=mat(j,j)*diag end do END SUBROUTINE diagmult_r !BL FUNCTION get_diag_rv(mat) REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv INTEGER(I4B) :: j j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv') do j=1,size(mat,1) get_diag_rv(j)=mat(j,j) end do END FUNCTION get_diag_rv !BL FUNCTION get_diag_dv(mat) REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat REAL(DP), DIMENSION(size(mat,1)) :: get_diag_dv INTEGER(I4B) :: j j=assert_eq2(size(mat,1),size(mat,2),'get_diag_dv') do j=1,size(mat,1) get_diag_dv(j)=mat(j,j) end do END FUNCTION get_diag_dv !BL SUBROUTINE put_diag_rv(diagv,mat) REAL(SP), DIMENSION(:), INTENT(IN) :: diagv REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat INTEGER(I4B) :: j,n n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv') do j=1,n mat(j,j)=diagv(j) end do END SUBROUTINE put_diag_rv !BL SUBROUTINE put_diag_r(scal,mat) REAL(SP), INTENT(IN) :: scal REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat INTEGER(I4B) :: j,n n = min(size(mat,1),size(mat,2)) do j=1,n mat(j,j)=scal end do END SUBROUTINE put_diag_r !BL SUBROUTINE unit_matrix(mat) REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat INTEGER(I4B) :: i,n n=min(size(mat,1),size(mat,2)) mat(:,:)=0.0_sp do i=1,n mat(i,i)=1.0_sp end do END SUBROUTINE unit_matrix !BL FUNCTION upper_triangle(j,k,extra) INTEGER(I4B), INTENT(IN) :: j,k INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle INTEGER(I4B) :: n n=0 if (present(extra)) n=extra upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n) END FUNCTION upper_triangle !BL FUNCTION lower_triangle(j,k,extra) INTEGER(I4B), INTENT(IN) :: j,k INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle INTEGER(I4B) :: n n=0 if (present(extra)) n=extra lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n) END FUNCTION lower_triangle !BL FUNCTION vabs(v) REAL(SP), DIMENSION(:), INTENT(IN) :: v REAL(SP) :: vabs vabs=sqrt(dot_product(v,v)) END FUNCTION vabs !BL END MODULE nrutil MODULE ode_path USE nrtype INTEGER(I4B) :: nok,nbad,kount LOGICAL(LGT), SAVE :: save_steps=.false. REAL(SP) :: dxsav REAL(SP), DIMENSION(:), POINTER :: xp REAL(SP), DIMENSION(:,:), POINTER :: yp END MODULE ode_path MODULE hypgeo_info USE nrtype COMPLEX(SPC) :: hypgeo_aa,hypgeo_bb,hypgeo_cc,hypgeo_dz,hypgeo_z0 END MODULE hypgeo_info MODULE nr INTERFACE SUBROUTINE airy(x,ai,bi,aip,bip) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: ai,bi,aip,bip END SUBROUTINE airy END INTERFACE INTERFACE SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr) USE nrtype INTEGER(I4B), INTENT(INOUT) :: iter REAL(SP), INTENT(INOUT) :: yb REAL(SP), INTENT(IN) :: ftol,temptr REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE amebsa END INTERFACE INTERFACE SUBROUTINE amoeba(p,y,ftol,func,iter) USE nrtype INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: ftol REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE amoeba END INTERFACE INTERFACE SUBROUTINE anneal(x,y,iorder) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: iorder REAL(SP), DIMENSION(:), INTENT(IN) :: x,y END SUBROUTINE anneal END INTERFACE INTERFACE SUBROUTINE asolve(b,x,itrnsp) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: b REAL(DP), DIMENSION(:), INTENT(OUT) :: x INTEGER(I4B), INTENT(IN) :: itrnsp END SUBROUTINE asolve END INTERFACE INTERFACE SUBROUTINE atimes(x,r,itrnsp) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x REAL(DP), DIMENSION(:), INTENT(OUT) :: r INTEGER(I4B), INTENT(IN) :: itrnsp END SUBROUTINE atimes END INTERFACE INTERFACE SUBROUTINE avevar(data,ave,var) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data REAL(SP), INTENT(OUT) :: ave,var END SUBROUTINE avevar END INTERFACE INTERFACE SUBROUTINE balanc(a) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a END SUBROUTINE balanc END INTERFACE INTERFACE SUBROUTINE banbks(a,m1,m2,al,indx,b) USE nrtype INTEGER(I4B), INTENT(IN) :: m1,m2 INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,al REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE banbks END INTERFACE INTERFACE SUBROUTINE bandec(a,m1,m2,al,indx,d) USE nrtype INTEGER(I4B), INTENT(IN) :: m1,m2 INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx REAL(SP), INTENT(OUT) :: d REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al END SUBROUTINE bandec END INTERFACE INTERFACE SUBROUTINE banmul(a,m1,m2,x,b) USE nrtype INTEGER(I4B), INTENT(IN) :: m1,m2 REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: b REAL(SP), DIMENSION(:,:), INTENT(IN) :: a END SUBROUTINE banmul END INTERFACE INTERFACE SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c) USE nrtype REAL(SP), INTENT(IN) :: d1,d2 REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c END SUBROUTINE bcucof END INTERFACE INTERFACE SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,& ansy1,ansy2) USE nrtype REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 REAL(SP), INTENT(IN) :: x1l,x1u,x2l,x2u,x1,x2 REAL(SP), INTENT(OUT) :: ansy,ansy1,ansy2 END SUBROUTINE bcuint END INTERFACE INTERFACE beschb SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi) USE nrtype REAL(DP), INTENT(IN) :: x REAL(DP), INTENT(OUT) :: gam1,gam2,gampl,gammi END SUBROUTINE beschb_s !BL SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x REAL(DP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi END SUBROUTINE beschb_v END INTERFACE INTERFACE bessi FUNCTION bessi_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessi_s END FUNCTION bessi_s !BL FUNCTION bessi_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessi_v END FUNCTION bessi_v END INTERFACE INTERFACE bessi0 FUNCTION bessi0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessi0_s END FUNCTION bessi0_s !BL FUNCTION bessi0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessi0_v END FUNCTION bessi0_v END INTERFACE INTERFACE bessi1 FUNCTION bessi1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessi1_s END FUNCTION bessi1_s !BL FUNCTION bessi1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessi1_v END FUNCTION bessi1_v END INTERFACE INTERFACE SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp) USE nrtype REAL(SP), INTENT(IN) :: x,xnu REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp END SUBROUTINE bessik END INTERFACE INTERFACE bessj FUNCTION bessj_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessj_s END FUNCTION bessj_s !BL FUNCTION bessj_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessj_v END FUNCTION bessj_v END INTERFACE INTERFACE bessj0 FUNCTION bessj0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessj0_s END FUNCTION bessj0_s !BL FUNCTION bessj0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessj0_v END FUNCTION bessj0_v END INTERFACE INTERFACE bessj1 FUNCTION bessj1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessj1_s END FUNCTION bessj1_s !BL FUNCTION bessj1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessj1_v END FUNCTION bessj1_v END INTERFACE INTERFACE bessjy SUBROUTINE bessjy_s(x,xnu,rj,ry,rjp,ryp) USE nrtype REAL(SP), INTENT(IN) :: x,xnu REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp END SUBROUTINE bessjy_s !BL SUBROUTINE bessjy_v(x,xnu,rj,ry,rjp,ryp) USE nrtype REAL(SP), INTENT(IN) :: xnu REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: rj,rjp,ry,ryp END SUBROUTINE bessjy_v END INTERFACE INTERFACE bessk FUNCTION bessk_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessk_s END FUNCTION bessk_s !BL FUNCTION bessk_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessk_v END FUNCTION bessk_v END INTERFACE INTERFACE bessk0 FUNCTION bessk0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessk0_s END FUNCTION bessk0_s !BL FUNCTION bessk0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessk0_v END FUNCTION bessk0_v END INTERFACE INTERFACE bessk1 FUNCTION bessk1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessk1_s END FUNCTION bessk1_s !BL FUNCTION bessk1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessk1_v END FUNCTION bessk1_v END INTERFACE INTERFACE bessy FUNCTION bessy_s(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: bessy_s END FUNCTION bessy_s !BL FUNCTION bessy_v(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessy_v END FUNCTION bessy_v END INTERFACE INTERFACE bessy0 FUNCTION bessy0_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessy0_s END FUNCTION bessy0_s !BL FUNCTION bessy0_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessy0_v END FUNCTION bessy0_v END INTERFACE INTERFACE bessy1 FUNCTION bessy1_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: bessy1_s END FUNCTION bessy1_s !BL FUNCTION bessy1_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: bessy1_v END FUNCTION bessy1_v END INTERFACE INTERFACE beta FUNCTION beta_s(z,w) USE nrtype REAL(SP), INTENT(IN) :: z,w REAL(SP) :: beta_s END FUNCTION beta_s !BL FUNCTION beta_v(z,w) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: z,w REAL(SP), DIMENSION(size(z)) :: beta_v END FUNCTION beta_v END INTERFACE INTERFACE betacf FUNCTION betacf_s(a,b,x) USE nrtype REAL(SP), INTENT(IN) :: a,b,x REAL(SP) :: betacf_s END FUNCTION betacf_s !BL FUNCTION betacf_v(a,b,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x REAL(SP), DIMENSION(size(x)) :: betacf_v END FUNCTION betacf_v END INTERFACE INTERFACE betai FUNCTION betai_s(a,b,x) USE nrtype REAL(SP), INTENT(IN) :: a,b,x REAL(SP) :: betai_s END FUNCTION betai_s !BL FUNCTION betai_v(a,b,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x REAL(SP), DIMENSION(size(a)) :: betai_v END FUNCTION betai_v END INTERFACE INTERFACE bico FUNCTION bico_s(n,k) USE nrtype INTEGER(I4B), INTENT(IN) :: n,k REAL(SP) :: bico_s END FUNCTION bico_s !BL FUNCTION bico_v(n,k) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k REAL(SP), DIMENSION(size(n)) :: bico_v END FUNCTION bico_v END INTERFACE INTERFACE FUNCTION bnldev(pp,n) USE nrtype REAL(SP), INTENT(IN) :: pp INTEGER(I4B), INTENT(IN) :: n REAL(SP) :: bnldev END FUNCTION bnldev END INTERFACE INTERFACE FUNCTION brent(ax,bx,cx,func,tol,xmin) USE nrtype REAL(SP), INTENT(IN) :: ax,bx,cx,tol REAL(SP), INTENT(OUT) :: xmin REAL(SP) :: brent INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION brent END INTERFACE INTERFACE SUBROUTINE broydn(x,check) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: x LOGICAL(LGT), INTENT(OUT) :: check END SUBROUTINE broydn END INTERFACE INTERFACE SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE bsstep END INTERFACE INTERFACE SUBROUTINE caldat(julian,mm,id,iyyy) USE nrtype INTEGER(I4B), INTENT(IN) :: julian INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy END SUBROUTINE caldat END INTERFACE INTERFACE FUNCTION chder(a,b,c) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(size(c)) :: chder END FUNCTION chder END INTERFACE INTERFACE chebev FUNCTION chebev_s(a,b,c,x) USE nrtype REAL(SP), INTENT(IN) :: a,b,x REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP) :: chebev_s END FUNCTION chebev_s !BL FUNCTION chebev_v(a,b,c,x) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: c,x REAL(SP), DIMENSION(size(x)) :: chebev_v END FUNCTION chebev_v END INTERFACE INTERFACE FUNCTION chebft(a,b,n,func) USE nrtype REAL(SP), INTENT(IN) :: a,b INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: chebft INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION chebft END INTERFACE INTERFACE FUNCTION chebpc(c) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(size(c)) :: chebpc END FUNCTION chebpc END INTERFACE INTERFACE FUNCTION chint(a,b,c) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(size(c)) :: chint END FUNCTION chint END INTERFACE INTERFACE SUBROUTINE choldc(a,p) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: p END SUBROUTINE choldc END INTERFACE INTERFACE SUBROUTINE cholsl(a,p,b,x) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(IN) :: p,b REAL(SP), DIMENSION(:), INTENT(INOUT) :: x END SUBROUTINE cholsl END INTERFACE INTERFACE SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob) USE nrtype INTEGER(I4B), INTENT(IN) :: knstrn REAL(SP), INTENT(OUT) :: df,chsq,prob REAL(SP), DIMENSION(:), INTENT(IN) :: bins,ebins END SUBROUTINE chsone END INTERFACE INTERFACE SUBROUTINE chstwo(bins1,bins2,knstrn,df,chsq,prob) USE nrtype INTEGER(I4B), INTENT(IN) :: knstrn REAL(SP), INTENT(OUT) :: df,chsq,prob REAL(SP), DIMENSION(:), INTENT(IN) :: bins1,bins2 END SUBROUTINE chstwo END INTERFACE INTERFACE SUBROUTINE cisi(x,ci,si) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: ci,si END SUBROUTINE cisi END INTERFACE INTERFACE SUBROUTINE cntab1(nn,chisq,df,prob,cramrv,ccc) USE nrtype INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc END SUBROUTINE cntab1 END INTERFACE INTERFACE SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy) USE nrtype INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy END SUBROUTINE cntab2 END INTERFACE INTERFACE FUNCTION convlv(data,respns,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data REAL(SP), DIMENSION(:), INTENT(IN) :: respns INTEGER(I4B), INTENT(IN) :: isign REAL(SP), DIMENSION(size(data)) :: convlv END FUNCTION convlv END INTERFACE INTERFACE FUNCTION correl(data1,data2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), DIMENSION(size(data1)) :: correl END FUNCTION correl END INTERFACE INTERFACE SUBROUTINE cosft1(y) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y END SUBROUTINE cosft1 END INTERFACE INTERFACE SUBROUTINE cosft2(y,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE cosft2 END INTERFACE INTERFACE SUBROUTINE covsrt(covar,maska) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska END SUBROUTINE covsrt END INTERFACE INTERFACE SUBROUTINE cyclic(a,b,c,alpha,beta,r,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN):: a,b,c,r REAL(SP), INTENT(IN) :: alpha,beta REAL(SP), DIMENSION(:), INTENT(OUT):: x END SUBROUTINE cyclic END INTERFACE INTERFACE SUBROUTINE daub4(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE daub4 END INTERFACE INTERFACE dawson FUNCTION dawson_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: dawson_s END FUNCTION dawson_s !BL FUNCTION dawson_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: dawson_v END FUNCTION dawson_v END INTERFACE INTERFACE FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin) USE nrtype REAL(SP), INTENT(IN) :: ax,bx,cx,tol REAL(SP), INTENT(OUT) :: xmin REAL(SP) :: dbrent INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func !BL FUNCTION dbrent_dfunc(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: dbrent_dfunc END FUNCTION dbrent_dfunc END INTERFACE END FUNCTION dbrent END INTERFACE INTERFACE SUBROUTINE ddpoly(c,x,pd) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: c REAL(SP), DIMENSION(:), INTENT(OUT) :: pd END SUBROUTINE ddpoly END INTERFACE INTERFACE FUNCTION decchk(string,ch) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(IN) :: string CHARACTER(1), INTENT(OUT) :: ch LOGICAL(LGT) :: decchk END FUNCTION decchk END INTERFACE INTERFACE SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc) USE nrtype INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: gtol REAL(SP), INTENT(OUT) :: fret REAL(SP), DIMENSION(:), INTENT(INOUT) :: p INTERFACE FUNCTION func(p) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: p REAL(SP) :: func END FUNCTION func !BL FUNCTION dfunc(p) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: p REAL(SP), DIMENSION(size(p)) :: dfunc END FUNCTION dfunc END INTERFACE END SUBROUTINE dfpmin END INTERFACE INTERFACE FUNCTION dfridr(func,x,h,err) USE nrtype REAL(SP), INTENT(IN) :: x,h REAL(SP), INTENT(OUT) :: err REAL(SP) :: dfridr INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION dfridr END INTERFACE INTERFACE SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac) USE nrtype REAL(SP), INTENT(IN) :: w,delta,a,b REAL(SP), INTENT(OUT) :: corre,corim,corfac REAL(SP), DIMENSION(:), INTENT(IN) :: endpts END SUBROUTINE dftcor END INTERFACE INTERFACE SUBROUTINE dftint(func,a,b,w,cosint,sinint) USE nrtype REAL(SP), INTENT(IN) :: a,b,w REAL(SP), INTENT(OUT) :: cosint,sinint INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE dftint END INTERFACE INTERFACE SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,s,y) USE nrtype INTEGER(I4B), INTENT(IN) :: is1,isf,jsf,k,k1,k2 INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv REAL(SP), DIMENSION(:,:), INTENT(OUT) :: s REAL(SP), DIMENSION(:,:), INTENT(IN) :: y END SUBROUTINE difeq END INTERFACE INTERFACE FUNCTION eclass(lista,listb,n) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: lista,listb INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), DIMENSION(n) :: eclass END FUNCTION eclass END INTERFACE INTERFACE FUNCTION eclazz(equiv,n) USE nrtype INTERFACE FUNCTION equiv(i,j) USE nrtype LOGICAL(LGT) :: equiv INTEGER(I4B), INTENT(IN) :: i,j END FUNCTION equiv END INTERFACE INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), DIMENSION(n) :: eclazz END FUNCTION eclazz END INTERFACE INTERFACE FUNCTION ei(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: ei END FUNCTION ei END INTERFACE INTERFACE SUBROUTINE eigsrt(d,v) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: d REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: v END SUBROUTINE eigsrt END INTERFACE INTERFACE elle FUNCTION elle_s(phi,ak) USE nrtype REAL(SP), INTENT(IN) :: phi,ak REAL(SP) :: elle_s END FUNCTION elle_s !BL FUNCTION elle_v(phi,ak) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak REAL(SP), DIMENSION(size(phi)) :: elle_v END FUNCTION elle_v END INTERFACE INTERFACE ellf FUNCTION ellf_s(phi,ak) USE nrtype REAL(SP), INTENT(IN) :: phi,ak REAL(SP) :: ellf_s END FUNCTION ellf_s !BL FUNCTION ellf_v(phi,ak) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak REAL(SP), DIMENSION(size(phi)) :: ellf_v END FUNCTION ellf_v END INTERFACE INTERFACE ellpi FUNCTION ellpi_s(phi,en,ak) USE nrtype REAL(SP), INTENT(IN) :: phi,en,ak REAL(SP) :: ellpi_s END FUNCTION ellpi_s !BL FUNCTION ellpi_v(phi,en,ak) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: phi,en,ak REAL(SP), DIMENSION(size(phi)) :: ellpi_v END FUNCTION ellpi_v END INTERFACE INTERFACE SUBROUTINE elmhes(a) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a END SUBROUTINE elmhes END INTERFACE INTERFACE erf FUNCTION erf_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: erf_s END FUNCTION erf_s !BL FUNCTION erf_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: erf_v END FUNCTION erf_v END INTERFACE INTERFACE erfc FUNCTION erfc_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: erfc_s END FUNCTION erfc_s !BL FUNCTION erfc_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: erfc_v END FUNCTION erfc_v END INTERFACE INTERFACE erfcc FUNCTION erfcc_s(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: erfcc_s END FUNCTION erfcc_s !BL FUNCTION erfcc_v(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: erfcc_v END FUNCTION erfcc_v END INTERFACE INTERFACE SUBROUTINE eulsum(sum,term,jterm) USE nrtype REAL(SP), INTENT(INOUT) :: sum REAL(SP), INTENT(IN) :: term INTEGER(I4B), INTENT(IN) :: jterm END SUBROUTINE eulsum END INTERFACE INTERFACE FUNCTION evlmem(fdt,d,xms) USE nrtype REAL(SP), INTENT(IN) :: fdt,xms REAL(SP), DIMENSION(:), INTENT(IN) :: d REAL(SP) :: evlmem END FUNCTION evlmem END INTERFACE INTERFACE expdev SUBROUTINE expdev_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE expdev_s !BL SUBROUTINE expdev_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE expdev_v END INTERFACE INTERFACE FUNCTION expint(n,x) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP) :: expint END FUNCTION expint END INTERFACE INTERFACE factln FUNCTION factln_s(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP) :: factln_s END FUNCTION factln_s !BL FUNCTION factln_v(n) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n REAL(SP), DIMENSION(size(n)) :: factln_v END FUNCTION factln_v END INTERFACE INTERFACE factrl FUNCTION factrl_s(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP) :: factrl_s END FUNCTION factrl_s !BL FUNCTION factrl_v(n) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n REAL(SP), DIMENSION(size(n)) :: factrl_v END FUNCTION factrl_v END INTERFACE INTERFACE SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(IN) :: ofac,hifac INTEGER(I4B), INTENT(OUT) :: jmax REAL(SP), INTENT(OUT) :: prob REAL(SP), DIMENSION(:), POINTER :: px,py END SUBROUTINE fasper END INTERFACE INTERFACE SUBROUTINE fdjac(x,fvec,df) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: fvec REAL(SP), DIMENSION(:), INTENT(INOUT) :: x REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df END SUBROUTINE fdjac END INTERFACE INTERFACE SUBROUTINE fgauss(x,a,y,dyda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,a REAL(SP), DIMENSION(:), INTENT(OUT) :: y REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda END SUBROUTINE fgauss END INTERFACE INTERFACE SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q REAL(SP), DIMENSION(:), OPTIONAL, INTENT(IN) :: sig END SUBROUTINE fit END INTERFACE INTERFACE SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sigx,sigy REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q END SUBROUTINE fitexy END INTERFACE INTERFACE SUBROUTINE fixrts(d) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: d END SUBROUTINE fixrts END INTERFACE INTERFACE FUNCTION fleg(x,n) USE nrtype REAL(SP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: fleg END FUNCTION fleg END INTERFACE INTERFACE SUBROUTINE flmoon(n,nph,jd,frac) USE nrtype INTEGER(I4B), INTENT(IN) :: n,nph INTEGER(I4B), INTENT(OUT) :: jd REAL(SP), INTENT(OUT) :: frac END SUBROUTINE flmoon END INTERFACE INTERFACE four1 SUBROUTINE four1_dp(data,isign) USE nrtype COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_dp !BL SUBROUTINE four1_sp(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_sp END INTERFACE INTERFACE SUBROUTINE four1_alt(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_alt END INTERFACE INTERFACE SUBROUTINE four1_gather(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four1_gather END INTERFACE INTERFACE SUBROUTINE four2(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B),INTENT(IN) :: isign END SUBROUTINE four2 END INTERFACE INTERFACE SUBROUTINE four2_alt(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four2_alt END INTERFACE INTERFACE SUBROUTINE four3(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B),INTENT(IN) :: isign END SUBROUTINE four3 END INTERFACE INTERFACE SUBROUTINE four3_alt(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE four3_alt END INTERFACE INTERFACE SUBROUTINE fourcol(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourcol END INTERFACE INTERFACE SUBROUTINE fourcol_3d(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourcol_3d END INTERFACE INTERFACE SUBROUTINE fourn_gather(data,nn,isign) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourn_gather END INTERFACE INTERFACE fourrow SUBROUTINE fourrow_dp(data,isign) USE nrtype COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourrow_dp !BL SUBROUTINE fourrow_sp(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourrow_sp END INTERFACE INTERFACE SUBROUTINE fourrow_3d(data,isign) USE nrtype COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE fourrow_3d END INTERFACE INTERFACE FUNCTION fpoly(x,n) USE nrtype REAL(SP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: fpoly END FUNCTION fpoly END INTERFACE INTERFACE SUBROUTINE fred2(a,b,t,f,w,g,ak) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w INTERFACE FUNCTION g(t) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t REAL(SP), DIMENSION(size(t)) :: g END FUNCTION g !BL FUNCTION ak(t,s) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t,s REAL(SP), DIMENSION(size(t),size(s)) :: ak END FUNCTION ak END INTERFACE END SUBROUTINE fred2 END INTERFACE INTERFACE FUNCTION fredin(x,a,b,t,f,w,g,ak) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(IN) :: x,t,f,w REAL(SP), DIMENSION(size(x)) :: fredin INTERFACE FUNCTION g(t) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t REAL(SP), DIMENSION(size(t)) :: g END FUNCTION g !BL FUNCTION ak(t,s) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: t,s REAL(SP), DIMENSION(size(t),size(s)) :: ak END FUNCTION ak END INTERFACE END FUNCTION fredin END INTERFACE INTERFACE SUBROUTINE frenel(x,s,c) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: s,c END SUBROUTINE frenel END INTERFACE INTERFACE SUBROUTINE frprmn(p,ftol,iter,fret) USE nrtype INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: ftol REAL(SP), INTENT(OUT) :: fret REAL(SP), DIMENSION(:), INTENT(INOUT) :: p END SUBROUTINE frprmn END INTERFACE INTERFACE SUBROUTINE ftest(data1,data2,f,prob) USE nrtype REAL(SP), INTENT(OUT) :: f,prob REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 END SUBROUTINE ftest END INTERFACE INTERFACE FUNCTION gamdev(ia) USE nrtype INTEGER(I4B), INTENT(IN) :: ia REAL(SP) :: gamdev END FUNCTION gamdev END INTERFACE INTERFACE gammln FUNCTION gammln_s(xx) USE nrtype REAL(SP), INTENT(IN) :: xx REAL(SP) :: gammln_s END FUNCTION gammln_s !BL FUNCTION gammln_v(xx) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), DIMENSION(size(xx)) :: gammln_v END FUNCTION gammln_v END INTERFACE INTERFACE gammp FUNCTION gammp_s(a,x) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP) :: gammp_s END FUNCTION gammp_s !BL FUNCTION gammp_v(a,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(size(a)) :: gammp_v END FUNCTION gammp_v END INTERFACE INTERFACE gammq FUNCTION gammq_s(a,x) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP) :: gammq_s END FUNCTION gammq_s !BL FUNCTION gammq_v(a,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(size(a)) :: gammq_v END FUNCTION gammq_v END INTERFACE INTERFACE gasdev SUBROUTINE gasdev_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE gasdev_s !BL SUBROUTINE gasdev_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE gasdev_v END INTERFACE INTERFACE SUBROUTINE gaucof(a,b,amu0,x,w) USE nrtype REAL(SP), INTENT(IN) :: amu0 REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gaucof END INTERFACE INTERFACE SUBROUTINE gauher(x,w) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gauher END INTERFACE INTERFACE SUBROUTINE gaujac(x,w,alf,bet) USE nrtype REAL(SP), INTENT(IN) :: alf,bet REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gaujac END INTERFACE INTERFACE SUBROUTINE gaulag(x,w,alf) USE nrtype REAL(SP), INTENT(IN) :: alf REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gaulag END INTERFACE INTERFACE SUBROUTINE gauleg(x1,x2,x,w) USE nrtype REAL(SP), INTENT(IN) :: x1,x2 REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w END SUBROUTINE gauleg END INTERFACE INTERFACE SUBROUTINE gaussj(a,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b END SUBROUTINE gaussj END INTERFACE INTERFACE gcf FUNCTION gcf_s(a,x,gln) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP), OPTIONAL, INTENT(OUT) :: gln REAL(SP) :: gcf_s END FUNCTION gcf_s !BL FUNCTION gcf_v(a,x,gln) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln REAL(SP), DIMENSION(size(a)) :: gcf_v END FUNCTION gcf_v END INTERFACE INTERFACE FUNCTION golden(ax,bx,cx,func,tol,xmin) USE nrtype REAL(SP), INTENT(IN) :: ax,bx,cx,tol REAL(SP), INTENT(OUT) :: xmin REAL(SP) :: golden INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION golden END INTERFACE INTERFACE gser FUNCTION gser_s(a,x,gln) USE nrtype REAL(SP), INTENT(IN) :: a,x REAL(SP), OPTIONAL, INTENT(OUT) :: gln REAL(SP) :: gser_s END FUNCTION gser_s !BL FUNCTION gser_v(a,x,gln) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,x REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln REAL(SP), DIMENSION(size(a)) :: gser_v END FUNCTION gser_v END INTERFACE INTERFACE SUBROUTINE hqr(a,wr,wi) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: wr,wi REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a END SUBROUTINE hqr END INTERFACE INTERFACE SUBROUTINE hunt(xx,x,jlo) USE nrtype INTEGER(I4B), INTENT(INOUT) :: jlo REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: xx END SUBROUTINE hunt END INTERFACE INTERFACE SUBROUTINE hypdrv(s,ry,rdyds) USE nrtype REAL(SP), INTENT(IN) :: s REAL(SP), DIMENSION(:), INTENT(IN) :: ry REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds END SUBROUTINE hypdrv END INTERFACE INTERFACE FUNCTION hypgeo(a,b,c,z) USE nrtype COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC) :: hypgeo END FUNCTION hypgeo END INTERFACE INTERFACE SUBROUTINE hypser(a,b,c,z,series,deriv) USE nrtype COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC), INTENT(OUT) :: series,deriv END SUBROUTINE hypser END INTERFACE INTERFACE FUNCTION icrc(crc,buf,jinit,jrev) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(IN) :: buf INTEGER(I2B), INTENT(IN) :: crc,jinit INTEGER(I4B), INTENT(IN) :: jrev INTEGER(I2B) :: icrc END FUNCTION icrc END INTERFACE INTERFACE FUNCTION igray(n,is) USE nrtype INTEGER(I4B), INTENT(IN) :: n,is INTEGER(I4B) :: igray END FUNCTION igray END INTERFACE INTERFACE RECURSIVE SUBROUTINE index_bypack(arr,index,partial) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: index INTEGER, OPTIONAL, INTENT(IN) :: partial END SUBROUTINE index_bypack END INTERFACE INTERFACE indexx SUBROUTINE indexx_sp(arr,index) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index END SUBROUTINE indexx_sp SUBROUTINE indexx_i4b(iarr,index) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index END SUBROUTINE indexx_i4b END INTERFACE INTERFACE FUNCTION interp(uc) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: uc REAL(DP), DIMENSION(2*size(uc,1)-1,2*size(uc,1)-1) :: interp END FUNCTION interp END INTERFACE INTERFACE FUNCTION rank(indx) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx INTEGER(I4B), DIMENSION(size(indx)) :: rank END FUNCTION rank END INTERFACE INTERFACE FUNCTION irbit1(iseed) USE nrtype INTEGER(I4B), INTENT(INOUT) :: iseed INTEGER(I4B) :: irbit1 END FUNCTION irbit1 END INTERFACE INTERFACE FUNCTION irbit2(iseed) USE nrtype INTEGER(I4B), INTENT(INOUT) :: iseed INTEGER(I4B) :: irbit2 END FUNCTION irbit2 END INTERFACE INTERFACE SUBROUTINE jacobi(a,d,v,nrot) USE nrtype INTEGER(I4B), INTENT(OUT) :: nrot REAL(SP), DIMENSION(:), INTENT(OUT) :: d REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v END SUBROUTINE jacobi END INTERFACE INTERFACE SUBROUTINE jacobn(x,y,dfdx,dfdy) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dfdx REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dfdy END SUBROUTINE jacobn END INTERFACE INTERFACE FUNCTION julday(mm,id,iyyy) USE nrtype INTEGER(I4B), INTENT(IN) :: mm,id,iyyy INTEGER(I4B) :: julday END FUNCTION julday END INTERFACE INTERFACE SUBROUTINE kendl1(data1,data2,tau,z,prob) USE nrtype REAL(SP), INTENT(OUT) :: tau,z,prob REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 END SUBROUTINE kendl1 END INTERFACE INTERFACE SUBROUTINE kendl2(tab,tau,z,prob) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: tab REAL(SP), INTENT(OUT) :: tau,z,prob END SUBROUTINE kendl2 END INTERFACE INTERFACE FUNCTION kermom(y,m) USE nrtype REAL(DP), INTENT(IN) :: y INTEGER(I4B), INTENT(IN) :: m REAL(DP), DIMENSION(m) :: kermom END FUNCTION kermom END INTERFACE INTERFACE SUBROUTINE ks2d1s(x1,y1,quadvl,d1,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1 REAL(SP), INTENT(OUT) :: d1,prob INTERFACE SUBROUTINE quadvl(x,y,fa,fb,fc,fd) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: fa,fb,fc,fd END SUBROUTINE quadvl END INTERFACE END SUBROUTINE ks2d1s END INTERFACE INTERFACE SUBROUTINE ks2d2s(x1,y1,x2,y2,d,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1,x2,y2 REAL(SP), INTENT(OUT) :: d,prob END SUBROUTINE ks2d2s END INTERFACE INTERFACE SUBROUTINE ksone(data,func,d,prob) USE nrtype REAL(SP), INTENT(OUT) :: d,prob REAL(SP), DIMENSION(:), INTENT(INOUT) :: data INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE ksone END INTERFACE INTERFACE SUBROUTINE kstwo(data1,data2,d,prob) USE nrtype REAL(SP), INTENT(OUT) :: d,prob REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 END SUBROUTINE kstwo END INTERFACE INTERFACE SUBROUTINE laguer(a,x,its) USE nrtype INTEGER(I4B), INTENT(OUT) :: its COMPLEX(SPC), INTENT(INOUT) :: x COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a END SUBROUTINE laguer END INTERFACE INTERFACE SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig REAL(SP), DIMENSION(:), INTENT(INOUT) :: a LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar REAL(SP), INTENT(OUT) :: chisq INTERFACE SUBROUTINE funcs(x,arr) USE nrtype REAL(SP),INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: arr END SUBROUTINE funcs END INTERFACE END SUBROUTINE lfit END INTERFACE INTERFACE SUBROUTINE linbcg(b,x,itol,tol,itmax,iter,err) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: b REAL(DP), DIMENSION(:), INTENT(INOUT) :: x INTEGER(I4B), INTENT(IN) :: itol,itmax REAL(DP), INTENT(IN) :: tol INTEGER(I4B), INTENT(OUT) :: iter REAL(DP), INTENT(OUT) :: err END SUBROUTINE linbcg END INTERFACE INTERFACE SUBROUTINE linmin(p,xi,fret) USE nrtype REAL(SP), INTENT(OUT) :: fret REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi END SUBROUTINE linmin END INTERFACE INTERFACE SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g REAL(SP), DIMENSION(:), INTENT(INOUT) :: p REAL(SP), INTENT(IN) :: fold,stpmax REAL(SP), DIMENSION(:), INTENT(OUT) :: x REAL(SP), INTENT(OUT) :: f LOGICAL(LGT), INTENT(OUT) :: check INTERFACE FUNCTION func(x) USE nrtype REAL(SP) :: func REAL(SP), DIMENSION(:), INTENT(IN) :: x END FUNCTION func END INTERFACE END SUBROUTINE lnsrch END INTERFACE INTERFACE FUNCTION locatenr(xx,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), INTENT(IN) :: x INTEGER(I4B) :: locatenr END FUNCTION locatenr END INTERFACE INTERFACE FUNCTION lop(u) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: u REAL(DP), DIMENSION(size(u,1),size(u,1)) :: lop END FUNCTION lop END INTERFACE INTERFACE SUBROUTINE lubksb(a,indx,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE lubksb END INTERFACE INTERFACE SUBROUTINE ludcmp(a,indx,d) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx REAL(SP), INTENT(OUT) :: d END SUBROUTINE ludcmp END INTERFACE INTERFACE SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,& maxexp,eps,epsneg,xmin,xmax) USE nrtype INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,irnd,it,machep,maxexp,& minexp,negep,ngrd REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin END SUBROUTINE machar END INTERFACE INTERFACE SUBROUTINE medfit(x,y,a,b,abdev) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: a,b,abdev END SUBROUTINE medfit END INTERFACE INTERFACE SUBROUTINE memcof(data,xms,d) USE nrtype REAL(SP), INTENT(OUT) :: xms REAL(SP), DIMENSION(:), INTENT(IN) :: data REAL(SP), DIMENSION(:), INTENT(OUT) :: d END SUBROUTINE memcof END INTERFACE INTERFACE SUBROUTINE mgfas(u,maxcyc) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u INTEGER(I4B), INTENT(IN) :: maxcyc END SUBROUTINE mgfas END INTERFACE INTERFACE SUBROUTINE mglin(u,ncycle) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u INTEGER(I4B), INTENT(IN) :: ncycle END SUBROUTINE mglin END INTERFACE INTERFACE SUBROUTINE midexp(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midexp END INTERFACE INTERFACE SUBROUTINE midinf(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midinf END INTERFACE INTERFACE SUBROUTINE midpnt(func,a,b,s,n) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE midpnt END INTERFACE INTERFACE SUBROUTINE midsql(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midsql END INTERFACE INTERFACE SUBROUTINE midsqu(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE midsqu END INTERFACE INTERFACE RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var) USE nrtype INTERFACE FUNCTION func(x) USE nrtype REAL(SP) :: func REAL(SP), DIMENSION(:), INTENT(IN) :: x END FUNCTION func END INTERFACE REAL(SP), DIMENSION(:), INTENT(IN) :: regn INTEGER(I4B), INTENT(IN) :: ndim,npts REAL(SP), INTENT(IN) :: dith REAL(SP), INTENT(OUT) :: ave,var END SUBROUTINE miser END INTERFACE INTERFACE SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs) USE nrtype INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), INTENT(IN) :: xs,htot REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE mmid END INTERFACE INTERFACE SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) USE nrtype REAL(SP), INTENT(INOUT) :: ax,bx REAL(SP), INTENT(OUT) :: cx,fa,fb,fc INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE mnbrak END INTERFACE INTERFACE SUBROUTINE mnewt(ntrial,x,tolx,tolf,usrfun) USE nrtype INTEGER(I4B), INTENT(IN) :: ntrial REAL(SP), INTENT(IN) :: tolx,tolf REAL(SP), DIMENSION(:), INTENT(INOUT) :: x INTERFACE SUBROUTINE usrfun(x,fvec,fjac) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec REAL(SP), DIMENSION(:,:), INTENT(OUT) :: fjac END SUBROUTINE usrfun END INTERFACE END SUBROUTINE mnewt END INTERFACE INTERFACE SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt) USE nrtype REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt REAL(SP), DIMENSION(:), INTENT(IN) :: data END SUBROUTINE moment END INTERFACE INTERFACE SUBROUTINE mp2dfr(a,s,n,m) USE nrtype INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), INTENT(OUT) :: m CHARACTER(1), DIMENSION(:), INTENT(INOUT) :: a CHARACTER(1), DIMENSION(:), INTENT(OUT) :: s END SUBROUTINE mp2dfr END INTERFACE INTERFACE SUBROUTINE mpdiv(q,r,u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(OUT) :: q,r CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpdiv END INTERFACE INTERFACE SUBROUTINE mpinv(u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(OUT) :: u CHARACTER(1), DIMENSION(:), INTENT(IN) :: v INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpinv END INTERFACE INTERFACE SUBROUTINE mpmul(w,u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpmul END INTERFACE INTERFACE SUBROUTINE mppi(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n END SUBROUTINE mppi END INTERFACE INTERFACE SUBROUTINE mprove(a,alud,indx,b,x) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,alud INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx REAL(SP), DIMENSION(:), INTENT(IN) :: b REAL(SP), DIMENSION(:), INTENT(INOUT) :: x END SUBROUTINE mprove END INTERFACE INTERFACE SUBROUTINE mpsqrt(w,u,v,n,m) USE nrtype CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w,u CHARACTER(1), DIMENSION(:), INTENT(IN) :: v INTEGER(I4B), INTENT(IN) :: n,m END SUBROUTINE mpsqrt END INTERFACE INTERFACE SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,chisq,funcs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig REAL(SP), DIMENSION(:), INTENT(OUT) :: beta REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha REAL(SP), INTENT(OUT) :: chisq LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska INTERFACE SUBROUTINE funcs(x,a,yfit,dyda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,a REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda END SUBROUTINE funcs END INTERFACE END SUBROUTINE mrqcof END INTERFACE INTERFACE SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig REAL(SP), DIMENSION(:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha REAL(SP), INTENT(OUT) :: chisq REAL(SP), INTENT(INOUT) :: alamda LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska INTERFACE SUBROUTINE funcs(x,a,yfit,dyda) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,a REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda END SUBROUTINE funcs END INTERFACE END SUBROUTINE mrqmin END INTERFACE INTERFACE SUBROUTINE newt(x,check) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: x LOGICAL(LGT), INTENT(OUT) :: check END SUBROUTINE newt END INTERFACE INTERFACE SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs !BL SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkqs END INTERFACE END SUBROUTINE odeint END INTERFACE INTERFACE SUBROUTINE orthog(anu,alpha,beta,a,b) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: anu,alpha,beta REAL(SP), DIMENSION(:), INTENT(OUT) :: a,b END SUBROUTINE orthog END INTERFACE INTERFACE SUBROUTINE pade(cof,resid) USE nrtype REAL(DP), DIMENSION(:), INTENT(INOUT) :: cof REAL(SP), INTENT(OUT) :: resid END SUBROUTINE pade END INTERFACE INTERFACE FUNCTION pccheb(d) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: d REAL(SP), DIMENSION(size(d)) :: pccheb END FUNCTION pccheb END INTERFACE INTERFACE SUBROUTINE pcshft(a,b,d) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), DIMENSION(:), INTENT(INOUT) :: d END SUBROUTINE pcshft END INTERFACE INTERFACE SUBROUTINE pearsn(x,y,r,prob,z) USE nrtype REAL(SP), INTENT(OUT) :: r,prob,z REAL(SP), DIMENSION(:), INTENT(IN) :: x,y END SUBROUTINE pearsn END INTERFACE INTERFACE SUBROUTINE period(x,y,ofac,hifac,px,py,jmax,prob) USE nrtype INTEGER(I4B), INTENT(OUT) :: jmax REAL(SP), INTENT(IN) :: ofac,hifac REAL(SP), INTENT(OUT) :: prob REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), DIMENSION(:), POINTER :: px,py END SUBROUTINE period END INTERFACE INTERFACE plgndr FUNCTION plgndr_s(l,m,x) USE nrtype INTEGER(I4B), INTENT(IN) :: l,m REAL(SP), INTENT(IN) :: x REAL(SP) :: plgndr_s END FUNCTION plgndr_s !BL FUNCTION plgndr_v(l,m,x) USE nrtype INTEGER(I4B), INTENT(IN) :: l,m REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: plgndr_v END FUNCTION plgndr_v END INTERFACE INTERFACE FUNCTION poidev(xm) USE nrtype REAL(SP), INTENT(IN) :: xm REAL(SP) :: poidev END FUNCTION poidev END INTERFACE INTERFACE FUNCTION polcoe(x,y) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), DIMENSION(size(x)) :: polcoe END FUNCTION polcoe END INTERFACE INTERFACE FUNCTION polcof(xa,ya) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya REAL(SP), DIMENSION(size(xa)) :: polcof END FUNCTION polcof END INTERFACE INTERFACE SUBROUTINE poldiv(u,v,q,r) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: u,v REAL(SP), DIMENSION(:), INTENT(OUT) :: q,r END SUBROUTINE poldiv END INTERFACE INTERFACE SUBROUTINE polin2(x1a,x2a,ya,x1,x2,y,dy) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya REAL(SP), INTENT(IN) :: x1,x2 REAL(SP), INTENT(OUT) :: y,dy END SUBROUTINE polin2 END INTERFACE INTERFACE SUBROUTINE polint(xa,ya,x,y,dy) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: y,dy END SUBROUTINE polint END INTERFACE INTERFACE SUBROUTINE powell(p,xi,ftol,iter,fret) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: p REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: xi INTEGER(I4B), INTENT(OUT) :: iter REAL(SP), INTENT(IN) :: ftol REAL(SP), INTENT(OUT) :: fret END SUBROUTINE powell END INTERFACE INTERFACE FUNCTION predic(data,d,nfut) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data,d INTEGER(I4B), INTENT(IN) :: nfut REAL(SP), DIMENSION(nfut) :: predic END FUNCTION predic END INTERFACE INTERFACE FUNCTION probks(alam) USE nrtype REAL(SP), INTENT(IN) :: alam REAL(SP) :: probks END FUNCTION probks END INTERFACE INTERFACE psdes SUBROUTINE psdes_s(lword,rword) USE nrtype INTEGER(I4B), INTENT(INOUT) :: lword,rword END SUBROUTINE psdes_s !BL SUBROUTINE psdes_v(lword,rword) USE nrtype INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: lword,rword END SUBROUTINE psdes_v END INTERFACE INTERFACE SUBROUTINE pwt(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE pwt END INTERFACE INTERFACE SUBROUTINE pwtset(n) USE nrtype INTEGER(I4B), INTENT(IN) :: n END SUBROUTINE pwtset END INTERFACE INTERFACE pythag FUNCTION pythag_dp(a,b) USE nrtype REAL(DP), INTENT(IN) :: a,b REAL(DP) :: pythag_dp END FUNCTION pythag_dp !BL FUNCTION pythag_sp(a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: pythag_sp END FUNCTION pythag_sp END INTERFACE INTERFACE SUBROUTINE pzextr(iest,xest,yest,yz,dy) USE nrtype INTEGER(I4B), INTENT(IN) :: iest REAL(SP), INTENT(IN) :: xest REAL(SP), DIMENSION(:), INTENT(IN) :: yest REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy END SUBROUTINE pzextr END INTERFACE !!! FB: ! INTERFACE ! FUNCTION qgaus(func,a,b) ! USE nrtype ! REAL(SP), INTENT(IN) :: a,b ! REAL(SP) :: qgaus ! INTERFACE ! FUNCTION func(x) ! USE nrtype ! REAL(SP), DIMENSION(:), INTENT(IN) :: x ! REAL(SP), DIMENSION(size(x)) :: func ! END FUNCTION func ! END INTERFACE ! END FUNCTION qgaus ! END INTERFACE !!! /FB INTERFACE SUBROUTINE qrdcmp(a,c,d,sing) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: c,d LOGICAL(LGT), INTENT(OUT) :: sing END SUBROUTINE qrdcmp END INTERFACE INTERFACE FUNCTION qromb(func,a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qromb INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION qromb END INTERFACE INTERFACE FUNCTION qromo(func,a,b,choose) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qromo INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE INTERFACE SUBROUTINE choose(funk,aa,bb,s,n) USE nrtype REAL(SP), INTENT(IN) :: aa,bb REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION funk(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: funk END FUNCTION funk END INTERFACE END SUBROUTINE choose END INTERFACE END FUNCTION qromo END INTERFACE INTERFACE SUBROUTINE qroot(p,b,c,eps) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: p REAL(SP), INTENT(INOUT) :: b,c REAL(SP), INTENT(IN) :: eps END SUBROUTINE qroot END INTERFACE INTERFACE SUBROUTINE qrsolv(a,c,d,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(IN) :: c,d REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE qrsolv END INTERFACE INTERFACE SUBROUTINE qrupdt(r,qt,u,v) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: r,qt REAL(SP), DIMENSION(:), INTENT(INOUT) :: u REAL(SP), DIMENSION(:), INTENT(IN) :: v END SUBROUTINE qrupdt END INTERFACE INTERFACE FUNCTION qsimp(func,a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qsimp INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION qsimp END INTERFACE INTERFACE FUNCTION qtrap(func,a,b) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP) :: qtrap INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END FUNCTION qtrap END INTERFACE INTERFACE SUBROUTINE quadct(x,y,xx,yy,fa,fb,fc,fd) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy REAL(SP), INTENT(OUT) :: fa,fb,fc,fd END SUBROUTINE quadct END INTERFACE INTERFACE SUBROUTINE quadmx(a) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(OUT) :: a END SUBROUTINE quadmx END INTERFACE INTERFACE SUBROUTINE quadvl(x,y,fa,fb,fc,fd) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP), INTENT(OUT) :: fa,fb,fc,fd END SUBROUTINE quadvl END INTERFACE INTERFACE FUNCTION ran(idum) INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum REAL :: ran END FUNCTION ran END INTERFACE INTERFACE ran0 SUBROUTINE ran0_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran0_s !BL SUBROUTINE ran0_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran0_v END INTERFACE INTERFACE ran1 SUBROUTINE ran1_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran1_s !BL SUBROUTINE ran1_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran1_v END INTERFACE INTERFACE ran2 SUBROUTINE ran2_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran2_s !BL SUBROUTINE ran2_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran2_v END INTERFACE INTERFACE ran3 SUBROUTINE ran3_s(harvest) USE nrtype REAL(SP), INTENT(OUT) :: harvest END SUBROUTINE ran3_s !BL SUBROUTINE ran3_v(harvest) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest END SUBROUTINE ran3_v END INTERFACE INTERFACE SUBROUTINE ratint(xa,ya,x,y,dy) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: y,dy END SUBROUTINE ratint END INTERFACE INTERFACE SUBROUTINE ratlsq(func,a,b,mm,kk,cof,dev) USE nrtype REAL(DP), INTENT(IN) :: a,b INTEGER(I4B), INTENT(IN) :: mm,kk REAL(DP), DIMENSION(:), INTENT(OUT) :: cof REAL(DP), INTENT(OUT) :: dev INTERFACE FUNCTION func(x) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x REAL(DP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE ratlsq END INTERFACE INTERFACE ratval FUNCTION ratval_s(x,cof,mm,kk) USE nrtype REAL(DP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: mm,kk REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof REAL(DP) :: ratval_s END FUNCTION ratval_s !BL FUNCTION ratval_v(x,cof,mm,kk) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: mm,kk REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof REAL(DP), DIMENSION(size(x)) :: ratval_v END FUNCTION ratval_v END INTERFACE INTERFACE rc FUNCTION rc_s(x,y) USE nrtype REAL(SP), INTENT(IN) :: x,y REAL(SP) :: rc_s END FUNCTION rc_s !BL FUNCTION rc_v(x,y) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), DIMENSION(size(x)) :: rc_v END FUNCTION rc_v END INTERFACE INTERFACE rd FUNCTION rd_s(x,y,z) USE nrtype REAL(SP), INTENT(IN) :: x,y,z REAL(SP) :: rd_s END FUNCTION rd_s !BL FUNCTION rd_v(x,y,z) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z REAL(SP), DIMENSION(size(x)) :: rd_v END FUNCTION rd_v END INTERFACE INTERFACE realft SUBROUTINE realft_dp(data,isign,zdata) USE nrtype REAL(DP), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign COMPLEX(DPC), DIMENSION(:), OPTIONAL, TARGET :: zdata END SUBROUTINE realft_dp !BL SUBROUTINE realft_sp(data,isign,zdata) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: data INTEGER(I4B), INTENT(IN) :: isign COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata END SUBROUTINE realft_sp END INTERFACE INTERFACE RECURSIVE FUNCTION recur1(a,b) RESULT(u) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b REAL(SP), DIMENSION(size(a)) :: u END FUNCTION recur1 END INTERFACE INTERFACE FUNCTION recur2(a,b,c) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c REAL(SP), DIMENSION(size(a)) :: recur2 END FUNCTION recur2 END INTERFACE INTERFACE SUBROUTINE relax(u,rhs) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs END SUBROUTINE relax END INTERFACE INTERFACE SUBROUTINE relax2(u,rhs) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs END SUBROUTINE relax2 END INTERFACE INTERFACE FUNCTION resid(u,rhs) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,rhs REAL(DP), DIMENSION(size(u,1),size(u,1)) :: resid END FUNCTION resid END INTERFACE INTERFACE rf FUNCTION rf_s(x,y,z) USE nrtype REAL(SP), INTENT(IN) :: x,y,z REAL(SP) :: rf_s END FUNCTION rf_s !BL FUNCTION rf_v(x,y,z) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z REAL(SP), DIMENSION(size(x)) :: rf_v END FUNCTION rf_v END INTERFACE INTERFACE rj FUNCTION rj_s(x,y,z,p) USE nrtype REAL(SP), INTENT(IN) :: x,y,z,p REAL(SP) :: rj_s END FUNCTION rj_s !BL FUNCTION rj_v(x,y,z,p) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z,p REAL(SP), DIMENSION(size(x)) :: rj_v END FUNCTION rj_v END INTERFACE INTERFACE SUBROUTINE rk4(y,dydx,x,h,yout,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), INTENT(IN) :: x,h REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rk4 END INTERFACE INTERFACE SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), INTENT(IN) :: x,h REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkck END INTERFACE INTERFACE SUBROUTINE rkdumb(vstart,x1,x2,nstep,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: vstart REAL(SP), INTENT(IN) :: x1,x2 INTEGER(I4B), INTENT(IN) :: nstep INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkdumb END INTERFACE INTERFACE SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkqs END INTERFACE INTERFACE SUBROUTINE rlft2(data,spec,speq,isign) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: spec COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE rlft2 END INTERFACE INTERFACE SUBROUTINE rlft3(data,spec,speq,isign) USE nrtype REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: speq INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE rlft3 END INTERFACE INTERFACE SUBROUTINE rotate(r,qt,i,a,b) USE nrtype REAL(SP), DIMENSION(:,:), TARGET, INTENT(INOUT) :: r,qt INTEGER(I4B), INTENT(IN) :: i REAL(SP), INTENT(IN) :: a,b END SUBROUTINE rotate END INTERFACE INTERFACE SUBROUTINE rsolv(a,d,b) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(IN) :: d REAL(SP), DIMENSION(:), INTENT(INOUT) :: b END SUBROUTINE rsolv END INTERFACE INTERFACE FUNCTION rstrct(uf) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: uf REAL(DP), DIMENSION((size(uf,1)+1)/2,(size(uf,1)+1)/2) :: rstrct END FUNCTION rstrct END INTERFACE INTERFACE FUNCTION rtbis(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtbis INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION rtbis END INTERFACE INTERFACE FUNCTION rtflsp(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtflsp INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION rtflsp END INTERFACE INTERFACE FUNCTION rtnewt(funcd,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtnewt INTERFACE SUBROUTINE funcd(x,fval,fderiv) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: fval,fderiv END SUBROUTINE funcd END INTERFACE END FUNCTION rtnewt END INTERFACE INTERFACE FUNCTION rtsafe(funcd,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtsafe INTERFACE SUBROUTINE funcd(x,fval,fderiv) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: fval,fderiv END SUBROUTINE funcd END INTERFACE END FUNCTION rtsafe END INTERFACE INTERFACE FUNCTION rtsec(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: rtsec INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION rtsec END INTERFACE INTERFACE SUBROUTINE rzextr(iest,xest,yest,yz,dy) USE nrtype INTEGER(I4B), INTENT(IN) :: iest REAL(SP), INTENT(IN) :: xest REAL(SP), DIMENSION(:), INTENT(IN) :: yest REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy END SUBROUTINE rzextr END INTERFACE INTERFACE FUNCTION savgol(nl,nrr,ld,m) USE nrtype INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m REAL(SP), DIMENSION(nl+nrr+1) :: savgol END FUNCTION savgol END INTERFACE INTERFACE SUBROUTINE scrsho(func) USE nrtype INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE scrsho END INTERFACE INTERFACE FUNCTION select(k,arr) USE nrtype INTEGER(I4B), INTENT(IN) :: k REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr REAL(SP) :: select END FUNCTION select END INTERFACE INTERFACE FUNCTION select_bypack(k,arr) USE nrtype INTEGER(I4B), INTENT(IN) :: k REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr REAL(SP) :: select_bypack END FUNCTION select_bypack END INTERFACE INTERFACE SUBROUTINE select_heap(arr,heap) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP), DIMENSION(:), INTENT(OUT) :: heap END SUBROUTINE select_heap END INTERFACE INTERFACE FUNCTION select_inplace(k,arr) USE nrtype INTEGER(I4B), INTENT(IN) :: k REAL(SP), DIMENSION(:), INTENT(IN) :: arr REAL(SP) :: select_inplace END FUNCTION select_inplace END INTERFACE INTERFACE SUBROUTINE simplx(a,m1,m2,m3,icase,izrov,iposv) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: m1,m2,m3 INTEGER(I4B), INTENT(OUT) :: icase INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv END SUBROUTINE simplx END INTERFACE INTERFACE SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs) USE nrtype REAL(SP), INTENT(IN) :: xs,htot REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx,dfdx REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE simpr END INTERFACE INTERFACE SUBROUTINE sinft(y) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y END SUBROUTINE sinft END INTERFACE INTERFACE SUBROUTINE slvsm2(u,rhs) USE nrtype REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs END SUBROUTINE slvsm2 END INTERFACE INTERFACE SUBROUTINE slvsml(u,rhs) USE nrtype REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs END SUBROUTINE slvsml END INTERFACE INTERFACE SUBROUTINE sncndn(uu,emmc,sn,cn,dn) USE nrtype REAL(SP), INTENT(IN) :: uu,emmc REAL(SP), INTENT(OUT) :: sn,cn,dn END SUBROUTINE sncndn END INTERFACE INTERFACE FUNCTION snrm(sx,itol) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: sx INTEGER(I4B), INTENT(IN) :: itol REAL(DP) :: snrm END FUNCTION snrm END INTERFACE INTERFACE SUBROUTINE sobseq(x,init) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: x INTEGER(I4B), OPTIONAL, INTENT(IN) :: init END SUBROUTINE sobseq END INTERFACE INTERFACE SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y) USE nrtype INTEGER(I4B), INTENT(IN) :: itmax,nb REAL(SP), INTENT(IN) :: conv,slowc REAL(SP), DIMENSION(:), INTENT(IN) :: scalv INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: y END SUBROUTINE solvde END INTERFACE INTERFACE SUBROUTINE sor(a,b,c,d,e,f,u,rjac) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: a,b,c,d,e,f REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u REAL(DP), INTENT(IN) :: rjac END SUBROUTINE sor END INTERFACE INTERFACE SUBROUTINE sort(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort END INTERFACE INTERFACE SUBROUTINE sort2(arr,slave) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave END SUBROUTINE sort2 END INTERFACE INTERFACE SUBROUTINE sort3(arr,slave1,slave2) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave1,slave2 END SUBROUTINE sort3 END INTERFACE INTERFACE SUBROUTINE sort_bypack(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_bypack END INTERFACE INTERFACE SUBROUTINE sort_byreshape(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_byreshape END INTERFACE INTERFACE SUBROUTINE sort_heap(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_heap END INTERFACE INTERFACE SUBROUTINE sort_pick(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_pick END INTERFACE INTERFACE SUBROUTINE sort_radix(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_radix END INTERFACE INTERFACE SUBROUTINE sort_shell(arr) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr END SUBROUTINE sort_shell END INTERFACE INTERFACE SUBROUTINE spctrm(p,k,ovrlap,unit,n_window) USE nrtype REAL(SP), DIMENSION(:), INTENT(OUT) :: p INTEGER(I4B), INTENT(IN) :: k LOGICAL(LGT), INTENT(IN) :: ovrlap INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit END SUBROUTINE spctrm END INTERFACE INTERFACE SUBROUTINE spear(data1,data2,d,zd,probd,rs,probrs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs END SUBROUTINE spear END INTERFACE INTERFACE sphbes SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: x REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp END SUBROUTINE sphbes_s !BL SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp END SUBROUTINE sphbes_v END INTERFACE INTERFACE SUBROUTINE splie2(x1a,x2a,ya,y2a) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a END SUBROUTINE splie2 END INTERFACE INTERFACE FUNCTION splin2(x1a,x2a,ya,y2a,x1,x2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a REAL(SP), INTENT(IN) :: x1,x2 REAL(SP) :: splin2 END FUNCTION splin2 END INTERFACE INTERFACE SUBROUTINE spline(x,y,yp1,ypn,y2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(IN) :: yp1,ypn REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 END SUBROUTINE spline END INTERFACE INTERFACE FUNCTION splint(xa,ya,y2a,x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a REAL(SP), INTENT(IN) :: x REAL(SP) :: splint END FUNCTION splint END INTERFACE INTERFACE sprsax SUBROUTINE sprsax_dp(sa,x,b) USE nrtype TYPE(sprs2_dp), INTENT(IN) :: sa REAL(DP), DIMENSION (:), INTENT(IN) :: x REAL(DP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprsax_dp !BL SUBROUTINE sprsax_sp(sa,x,b) USE nrtype TYPE(sprs2_sp), INTENT(IN) :: sa REAL(SP), DIMENSION (:), INTENT(IN) :: x REAL(SP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprsax_sp END INTERFACE INTERFACE sprsdiag SUBROUTINE sprsdiag_dp(sa,b) USE nrtype TYPE(sprs2_dp), INTENT(IN) :: sa REAL(DP), DIMENSION(:), INTENT(OUT) :: b END SUBROUTINE sprsdiag_dp !BL SUBROUTINE sprsdiag_sp(sa,b) USE nrtype TYPE(sprs2_sp), INTENT(IN) :: sa REAL(SP), DIMENSION(:), INTENT(OUT) :: b END SUBROUTINE sprsdiag_sp END INTERFACE INTERFACE sprsin SUBROUTINE sprsin_sp(a,thresh,sa) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: a REAL(SP), INTENT(IN) :: thresh TYPE(sprs2_sp), INTENT(OUT) :: sa END SUBROUTINE sprsin_sp !BL SUBROUTINE sprsin_dp(a,thresh,sa) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: a REAL(DP), INTENT(IN) :: thresh TYPE(sprs2_dp), INTENT(OUT) :: sa END SUBROUTINE sprsin_dp END INTERFACE INTERFACE SUBROUTINE sprstp(sa) USE nrtype TYPE(sprs2_sp), INTENT(INOUT) :: sa END SUBROUTINE sprstp END INTERFACE INTERFACE sprstx SUBROUTINE sprstx_dp(sa,x,b) USE nrtype TYPE(sprs2_dp), INTENT(IN) :: sa REAL(DP), DIMENSION (:), INTENT(IN) :: x REAL(DP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprstx_dp !BL SUBROUTINE sprstx_sp(sa,x,b) USE nrtype TYPE(sprs2_sp), INTENT(IN) :: sa REAL(SP), DIMENSION (:), INTENT(IN) :: x REAL(SP), DIMENSION (:), INTENT(OUT) :: b END SUBROUTINE sprstx_sp END INTERFACE INTERFACE SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE stifbs END INTERFACE INTERFACE SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE stiff END INTERFACE INTERFACE SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: y,d2y REAL(SP), INTENT(IN) :: xs,htot INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE stoerm END INTERFACE INTERFACE svbksb SUBROUTINE svbksb_dp(u,w,v,b,x) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,v REAL(DP), DIMENSION(:), INTENT(IN) :: w,b REAL(DP), DIMENSION(:), INTENT(OUT) :: x END SUBROUTINE svbksb_dp !BL SUBROUTINE svbksb_sp(u,w,v,b,x) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v REAL(SP), DIMENSION(:), INTENT(IN) :: w,b REAL(SP), DIMENSION(:), INTENT(OUT) :: x END SUBROUTINE svbksb_sp END INTERFACE INTERFACE svdcmp SUBROUTINE svdcmp_dp(a,w,v) USE nrtype REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(DP), DIMENSION(:), INTENT(OUT) :: w REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v END SUBROUTINE svdcmp_dp !BL SUBROUTINE svdcmp_sp(a,w,v) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: w REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v END SUBROUTINE svdcmp_sp END INTERFACE INTERFACE SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v REAL(SP), INTENT(OUT) :: chisq INTERFACE FUNCTION funcs(x,n) USE nrtype REAL(SP), INTENT(IN) :: x INTEGER(I4B), INTENT(IN) :: n REAL(SP), DIMENSION(n) :: funcs END FUNCTION funcs END INTERFACE END SUBROUTINE svdfit END INTERFACE INTERFACE SUBROUTINE svdvar(v,w,cvm) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(IN) :: v REAL(SP), DIMENSION(:), INTENT(IN) :: w REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm END SUBROUTINE svdvar END INTERFACE INTERFACE FUNCTION toeplz(r,y) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: r,y REAL(SP), DIMENSION(size(y)) :: toeplz END FUNCTION toeplz END INTERFACE INTERFACE SUBROUTINE tptest(data1,data2,t,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: t,prob END SUBROUTINE tptest END INTERFACE INTERFACE SUBROUTINE tqli(d,e,z) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z END SUBROUTINE tqli END INTERFACE INTERFACE SUBROUTINE trapzd(func,a,b,s,n) USE nrtype REAL(SP), INTENT(IN) :: a,b REAL(SP), INTENT(INOUT) :: s INTEGER(I4B), INTENT(IN) :: n INTERFACE FUNCTION func(x) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: x REAL(SP), DIMENSION(size(x)) :: func END FUNCTION func END INTERFACE END SUBROUTINE trapzd END INTERFACE INTERFACE SUBROUTINE tred2(a,d,e,novectors) USE nrtype REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: d,e LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors END SUBROUTINE tred2 END INTERFACE ! On a purely serial machine, for greater efficiency, remove ! the generic name tridag from the following interface, ! and put it on the next one after that. INTERFACE tridag RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u END SUBROUTINE tridag_par END INTERFACE INTERFACE SUBROUTINE tridag_ser(a,b,c,r,u) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u END SUBROUTINE tridag_ser END INTERFACE INTERFACE SUBROUTINE ttest(data1,data2,t,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: t,prob END SUBROUTINE ttest END INTERFACE INTERFACE SUBROUTINE tutest(data1,data2,t,prob) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 REAL(SP), INTENT(OUT) :: t,prob END SUBROUTINE tutest END INTERFACE INTERFACE SUBROUTINE twofft(data1,data2,fft1,fft2) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2 END SUBROUTINE twofft END INTERFACE INTERFACE FUNCTION vander(x,q) USE nrtype REAL(DP), DIMENSION(:), INTENT(IN) :: x,q REAL(DP), DIMENSION(size(x)) :: vander END FUNCTION vander END INTERFACE INTERFACE SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: region INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn REAL(SP), INTENT(OUT) :: tgral,sd,chi2a INTERFACE FUNCTION func(pt,wgt) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: pt REAL(SP), INTENT(IN) :: wgt REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE vegas END INTERFACE INTERFACE SUBROUTINE voltra(t0,h,t,f,g,ak) USE nrtype REAL(SP), INTENT(IN) :: t0,h REAL(SP), DIMENSION(:), INTENT(OUT) :: t REAL(SP), DIMENSION(:,:), INTENT(OUT) :: f INTERFACE FUNCTION g(t) USE nrtype REAL(SP), INTENT(IN) :: t REAL(SP), DIMENSION(:), POINTER :: g END FUNCTION g !BL FUNCTION ak(t,s) USE nrtype REAL(SP), INTENT(IN) :: t,s REAL(SP), DIMENSION(:,:), POINTER :: ak END FUNCTION ak END INTERFACE END SUBROUTINE voltra END INTERFACE INTERFACE SUBROUTINE wt1(a,isign,wtstep) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign INTERFACE SUBROUTINE wtstep(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE wtstep END INTERFACE END SUBROUTINE wt1 END INTERFACE INTERFACE SUBROUTINE wtn(a,nn,isign,wtstep) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn INTEGER(I4B), INTENT(IN) :: isign INTERFACE SUBROUTINE wtstep(a,isign) USE nrtype REAL(SP), DIMENSION(:), INTENT(INOUT) :: a INTEGER(I4B), INTENT(IN) :: isign END SUBROUTINE wtstep END INTERFACE END SUBROUTINE wtn END INTERFACE INTERFACE FUNCTION wwghts(n,h,kermom) USE nrtype INTEGER(I4B), INTENT(IN) :: n REAL(SP), INTENT(IN) :: h REAL(SP), DIMENSION(n) :: wwghts INTERFACE FUNCTION kermom(y,m) USE nrtype REAL(DP), INTENT(IN) :: y INTEGER(I4B), INTENT(IN) :: m REAL(DP), DIMENSION(m) :: kermom END FUNCTION kermom END INTERFACE END FUNCTION wwghts END INTERFACE INTERFACE SUBROUTINE zbrac(func,x1,x2,succes) USE nrtype REAL(SP), INTENT(INOUT) :: x1,x2 LOGICAL(LGT), INTENT(OUT) :: succes INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE zbrac END INTERFACE INTERFACE SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,nb) USE nrtype INTEGER(I4B), INTENT(IN) :: n INTEGER(I4B), INTENT(OUT) :: nb REAL(SP), INTENT(IN) :: x1,x2 REAL(SP), DIMENSION(:), POINTER :: xb1,xb2 INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END SUBROUTINE zbrak END INTERFACE INTERFACE FUNCTION zbrent(func,x1,x2,tol) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,tol REAL(SP) :: zbrent INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION zbrent END INTERFACE INTERFACE SUBROUTINE zrhqr(a,rtr,rti) USE nrtype REAL(SP), DIMENSION(:), INTENT(IN) :: a REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti END SUBROUTINE zrhqr END INTERFACE INTERFACE FUNCTION zriddr(func,x1,x2,xacc) USE nrtype REAL(SP), INTENT(IN) :: x1,x2,xacc REAL(SP) :: zriddr INTERFACE FUNCTION func(x) USE nrtype REAL(SP), INTENT(IN) :: x REAL(SP) :: func END FUNCTION func END INTERFACE END FUNCTION zriddr END INTERFACE INTERFACE SUBROUTINE zroots(a,roots,polish) USE nrtype COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots LOGICAL(LGT), INTENT(IN) :: polish END SUBROUTINE zroots END INTERFACE END MODULE nr SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) USE nrtype; USE nrutil, ONLY : assert_eq IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), INTENT(IN) :: x,h REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B) :: ndum REAL(SP), DIMENSION(size(y)) :: ak2,ak3,ak4,ak5,ak6,ytemp REAL(SP), PARAMETER :: A2=0.2_sp,A3=0.3_sp,A4=0.6_sp,A5=1.0_sp,& A6=0.875_sp,B21=0.2_sp,B31=3.0_sp/40.0_sp,B32=9.0_sp/40.0_sp,& B41=0.3_sp,B42=-0.9_sp,B43=1.2_sp,B51=-11.0_sp/54.0_sp,& B52=2.5_sp,B53=-70.0_sp/27.0_sp,B54=35.0_sp/27.0_sp,& B61=1631.0_sp/55296.0_sp,B62=175.0_sp/512.0_sp,& B63=575.0_sp/13824.0_sp,B64=44275.0_sp/110592.0_sp,& B65=253.0_sp/4096.0_sp,C1=37.0_sp/378.0_sp,& C3=250.0_sp/621.0_sp,C4=125.0_sp/594.0_sp,& C6=512.0_sp/1771.0_sp,DC1=C1-2825.0_sp/27648.0_sp,& DC3=C3-18575.0_sp/48384.0_sp,DC4=C4-13525.0_sp/55296.0_sp,& DC5=-277.0_sp/14336.0_sp,DC6=C6-0.25_sp ndum=assert_eq(size(y),size(dydx),size(yout),size(yerr),'rkck') ytemp=y+B21*h*dydx call derivs(x+A2*h,ytemp,ak2) ytemp=y+h*(B31*dydx+B32*ak2) call derivs(x+A3*h,ytemp,ak3) ytemp=y+h*(B41*dydx+B42*ak2+B43*ak3) call derivs(x+A4*h,ytemp,ak4) ytemp=y+h*(B51*dydx+B52*ak2+B53*ak3+B54*ak4) call derivs(x+A5*h,ytemp,ak5) ytemp=y+h*(B61*dydx+B62*ak2+B63*ak3+B64*ak4+B65*ak5) call derivs(x+A6*h,ytemp,ak6) yout=y+h*(C1*dydx+C3*ak3+C4*ak4+C6*ak6) yerr=h*(DC1*dydx+DC3*ak3+DC4*ak4+DC5*ak5+DC6*ak6) END SUBROUTINE rkck SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror USE nr, ONLY : rkck IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B) :: ndum REAL(SP) :: errmax,h,htemp,xnew REAL(SP), DIMENSION(size(y)) :: yerr,ytemp REAL(SP), PARAMETER :: SAFETY=0.9_sp,PGROW=-0.2_sp,PSHRNK=-0.25_sp,& ERRCON=1.89e-4 ndum=assert_eq(size(y),size(dydx),size(yscal),'rkqs') h=htry do call rkck(y,dydx,x,h,ytemp,yerr,derivs) errmax=maxval(abs(yerr(:)/yscal(:)))/eps if (errmax <= 1.0) exit htemp=SAFETY*h*(errmax**PSHRNK) h=sign(max(abs(htemp),0.1_sp*abs(h)),h) xnew=x+h if (xnew == x) call nrerror('stepsize underflow in rkqs') end do if (errmax > ERRCON) then hnext=SAFETY*h*(errmax**PGROW) else hnext=5.0_sp*h end if hdid=h x=x+h y(:)=ytemp(:) END SUBROUTINE rkqs SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs) USE nrtype; USE nrutil, ONLY : assert_eq,swap IMPLICIT NONE INTEGER(I4B), INTENT(IN) :: nstep REAL(SP), INTENT(IN) :: xs,htot REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx REAL(SP), DIMENSION(:), INTENT(OUT) :: yout INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B) :: n,ndum REAL(SP) :: h,h2,x REAL(SP), DIMENSION(size(y)) :: ym,yn ndum=assert_eq(size(y),size(dydx),size(yout),'mmid') h=htot/nstep ym=y yn=y+h*dydx x=xs+h call derivs(x,yn,yout) h2=2.0_sp*h do n=2,nstep call swap(ym,yn) yn=yn+h2*yout x=x+h call derivs(x,yn,yout) end do yout=0.5_sp*(ym+yn+h*yout) END SUBROUTINE mmid SUBROUTINE pzextr(iest,xest,yest,yz,dy) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror IMPLICIT NONE INTEGER(I4B), INTENT(IN) :: iest REAL(SP), INTENT(IN) :: xest REAL(SP), DIMENSION(:), INTENT(IN) :: yest REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy INTEGER(I4B), PARAMETER :: IEST_MAX=16 INTEGER(I4B) :: j,nv INTEGER(I4B), SAVE :: nvold=-1 REAL(SP) :: delta,f1,f2 REAL(SP), DIMENSION(size(yz)) :: d,tmp,q REAL(SP), DIMENSION(IEST_MAX), SAVE :: x REAL(SP), DIMENSION(:,:), ALLOCATABLE, SAVE :: qcol nv=assert_eq(size(yz),size(yest),size(dy),'pzextr') if (iest > IEST_MAX) call & nrerror('pzextr: probable misuse, too much extrapolation') if (nv /= nvold) then if (allocated(qcol)) deallocate(qcol) allocate(qcol(nv,IEST_MAX)) nvold=nv end if x(iest)=xest dy(:)=yest(:) yz(:)=yest(:) if (iest == 1) then qcol(:,1)=yest(:) else d(:)=yest(:) do j=1,iest-1 delta=1.0_sp/(x(iest-j)-xest) f1=xest*delta f2=x(iest-j)*delta q(:)=qcol(:,j) qcol(:,j)=dy(:) tmp(:)=d(:)-q(:) dy(:)=f1*tmp(:) d(:)=f2*tmp(:) yz(:)=yz(:)+dy(:) end do qcol(:,iest)=dy(:) end if END SUBROUTINE pzextr SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype; USE nrutil, ONLY : arth,assert_eq,cumsum,iminloc,nrerror,& outerdiff,outerprod,upper_triangle USE nr, ONLY : mmid,pzextr IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE INTEGER(I4B), PARAMETER :: IMAX=9, KMAXX=IMAX-1 REAL(SP), PARAMETER :: SAFE1=0.25_sp,SAFE2=0.7_sp,REDMAX=1.0e-5_sp,& REDMIN=0.7_sp,TINY=1.0e-30_sp,SCALMX=0.1_sp INTEGER(I4B) :: k,km,ndum INTEGER(I4B), DIMENSION(IMAX) :: nseq = (/ 2,4,6,8,10,12,14,16,18 /) INTEGER(I4B), SAVE :: kopt,kmax REAL(SP), DIMENSION(KMAXX,KMAXX), SAVE :: alf REAL(SP), DIMENSION(KMAXX) :: err REAL(SP), DIMENSION(IMAX), SAVE :: a REAL(SP), SAVE :: epsold = -1.0_sp,xnew REAL(SP) :: eps1,errmax,fact,h,red,scale,wrkmin,xest REAL(SP), DIMENSION(size(y)) :: yerr,ysav,yseq LOGICAL(LGT) :: reduct LOGICAL(LGT), SAVE :: first=.true. ndum=assert_eq(size(y),size(dydx),size(yscal),'bsstep') if (eps /= epsold) then hnext=-1.0e29_sp xnew=-1.0e29_sp eps1=SAFE1*eps a(:)=cumsum(nseq,1) where (upper_triangle(KMAXX,KMAXX)) alf=eps1** & (outerdiff(a(2:),a(2:))/outerprod(arth( & 3.0_sp,2.0_sp,KMAXX),(a(2:)-a(1)+1.0_sp))) epsold=eps do kopt=2,KMAXX-1 if (a(kopt+1) > a(kopt)*alf(kopt-1,kopt)) exit end do kmax=kopt end if h=htry ysav(:)=y(:) if (h /= hnext .or. x /= xnew) then first=.true. kopt=kmax end if reduct=.false. main_loop: do do k=1,kmax xnew=x+h if (xnew == x) call nrerror('step size underflow in bsstep') call mmid(ysav,dydx,x,h,nseq(k),yseq,derivs) xest=(h/nseq(k))**2 call pzextr(k,xest,yseq,y,yerr) if (k /= 1) then errmax=maxval(abs(yerr(:)/yscal(:))) errmax=max(TINY,errmax)/eps km=k-1 err(km)=(errmax/SAFE1)**(1.0_sp/(2*km+1)) end if if (k /= 1 .and. (k >= kopt-1 .or. first)) then if (errmax < 1.0) exit main_loop if (k == kmax .or. k == kopt+1) then red=SAFE2/err(km) exit else if (k == kopt) then if (alf(kopt-1,kopt) < err(km)) then red=1.0_sp/err(km) exit end if else if (kopt == kmax) then if (alf(km,kmax-1) < err(km)) then red=alf(km,kmax-1)*SAFE2/err(km) exit end if else if (alf(km,kopt) < err(km)) then red=alf(km,kopt-1)/err(km) exit end if end if end do red=max(min(red,REDMIN),REDMAX) h=h*red reduct=.true. end do main_loop x=xnew hdid=h first=.false. kopt=1+iminloc(a(2:km+1)*max(err(1:km),SCALMX)) scale=max(err(kopt-1),SCALMX) wrkmin=scale*a(kopt) hnext=h/scale if (kopt >= k .and. kopt /= kmax .and. .not. reduct) then fact=max(scale/alf(kopt-1,kopt),SCALMX) if (a(kopt+1)*fact <= wrkmin) then hnext=h/fact kopt=kopt+1 end if end if END SUBROUTINE bsstep FUNCTION hypgeo(a,b,c,z) USE nrtype USE hypgeo_info USE nr, ONLY : bsstep,hypdrv,hypser,odeint IMPLICIT NONE COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC) :: hypgeo REAL(SP), PARAMETER :: EPS=1.0e-6_sp COMPLEX(SPC), DIMENSION(2) :: y REAL(SP), DIMENSION(4) :: ry if (real(z)**2+aimag(z)**2 <= 0.25) then call hypser(a,b,c,z,hypgeo,y(2)) RETURN else if (real(z) < 0.0) then hypgeo_z0=cmplx(-0.5_sp,0.0_sp,kind=spc) else if (real(z) <= 1.0) then hypgeo_z0=cmplx(0.5_sp,0.0_sp,kind=spc) else hypgeo_z0=cmplx(0.0_sp,sign(0.5_sp,aimag(z)),kind=spc) end if hypgeo_aa=a hypgeo_bb=b hypgeo_cc=c hypgeo_dz=z-hypgeo_z0 call hypser(hypgeo_aa,hypgeo_bb,hypgeo_cc,hypgeo_z0,y(1),y(2)) ry(1:4:2)=real(y) ry(2:4:2)=aimag(y) ! call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.0001_sp,hypdrv,bsstep) call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.000001_sp,hypdrv,bsstep) !!! FB y=cmplx(ry(1:4:2),ry(2:4:2),kind=spc) hypgeo=y(1) END FUNCTION hypgeo SUBROUTINE hypdrv(s,ry,rdyds) USE nrtype USE hypgeo_info IMPLICIT NONE REAL(SP), INTENT(IN) :: s REAL(SP), DIMENSION(:), INTENT(IN) :: ry REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds COMPLEX(SPC), DIMENSION(2) :: y,dyds COMPLEX(SPC) :: z y=cmplx(ry(1:4:2),ry(2:4:2),kind=spc) z=hypgeo_z0+s*hypgeo_dz dyds(1)=y(2)*hypgeo_dz dyds(2)=((hypgeo_aa*hypgeo_bb)*y(1)-(hypgeo_cc-& ((hypgeo_aa+hypgeo_bb)+1.0_sp)*z)*y(2))*hypgeo_dz/(z*(1.0_sp-z)) rdyds(1:4:2)=real(dyds) rdyds(2:4:2)=aimag(dyds) END SUBROUTINE hypdrv SUBROUTINE hypser(a,b,c,z,series,deriv) USE nrtype; USE nrutil, ONLY : nrerror IMPLICIT NONE COMPLEX(SPC), INTENT(IN) :: a,b,c,z COMPLEX(SPC), INTENT(OUT) :: series,deriv INTEGER(I4B) :: n INTEGER(I4B), PARAMETER :: MAXIT=1000 COMPLEX(SPC) :: aa,bb,cc,fac,temp deriv=cmplx(0.0_sp,0.0_sp,kind=spc) fac=cmplx(1.0_sp,0.0_sp,kind=spc) temp=fac aa=a bb=b cc=c do n=1,MAXIT fac=((aa*bb)/cc)*fac deriv=deriv+fac fac=fac*z/n series=temp+fac if (series == temp) RETURN temp=series aa=aa+1.0 bb=bb+1.0 cc=cc+1.0 end do call nrerror('hypser: convergence failure') END SUBROUTINE hypser SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs) USE nrtype; USE nrutil, ONLY : nrerror,reallocate USE ode_path IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs !BL SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) USE nrtype IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: y REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal REAL(SP), INTENT(INOUT) :: x REAL(SP), INTENT(IN) :: htry,eps REAL(SP), INTENT(OUT) :: hdid,hnext INTERFACE SUBROUTINE derivs(x,y,dydx) USE nrtype IMPLICIT NONE REAL(SP), INTENT(IN) :: x REAL(SP), DIMENSION(:), INTENT(IN) :: y REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx END SUBROUTINE derivs END INTERFACE END SUBROUTINE rkqs END INTERFACE REAL(SP), PARAMETER :: TINY=1.0e-30_sp INTEGER(I4B), PARAMETER :: MAXSTP=10000 INTEGER(I4B) :: nstp REAL(SP) :: h,hdid,hnext,x,xsav REAL(SP), DIMENSION(size(ystart)) :: dydx,y,yscal x=x1 h=sign(h1,x2-x1) nok=0 nbad=0 kount=0 y(:)=ystart(:) nullify(xp,yp) if (save_steps) then xsav=x-2.0_sp*dxsav allocate(xp(256)) allocate(yp(size(ystart),size(xp))) end if do nstp=1,MAXSTP call derivs(x,y,dydx) yscal(:)=abs(y(:))+abs(h*dydx(:))+TINY if (save_steps .and. (abs(x-xsav) > abs(dxsav))) & call save_a_step if ((x+h-x2)*(x+h-x1) > 0.0) h=x2-x call rkqs(y,dydx,x,h,eps,yscal,hdid,hnext,derivs) if (hdid == h) then nok=nok+1 else nbad=nbad+1 end if if ((x-x2)*(x2-x1) >= 0.0) then ystart(:)=y(:) if (save_steps) call save_a_step RETURN end if if (abs(hnext) < hmin) then print *, "abs(hnext) = ", abs(hnext) print *, "hmin = ", hmin call nrerror('stepsize smaller than minimum in odeint') end if h=hnext end do call nrerror('too many steps in odeint') CONTAINS !BL SUBROUTINE save_a_step kount=kount+1 if (kount > size(xp)) then xp=>reallocate(xp,2*size(xp)) yp=>reallocate(yp,size(yp,1),size(xp)) end if xp(kount)=x yp(:,kount)=y(:) xsav=x END SUBROUTINE save_a_step END SUBROUTINE odeint FUNCTION gammln_s(xx) USE nrtype; USE nrutil, ONLY : arth,assert IMPLICIT NONE REAL(SP), INTENT(IN) :: xx REAL(SP) :: gammln_s REAL(DP) :: tmp,x REAL(DP) :: stp = 2.5066282746310005_dp REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& -86.50532032941677_dp,24.01409824083091_dp,& -1.231739572450155_dp,0.1208650973866179e-2_dp,& -0.5395239384953e-5_dp/) call assert(xx > 0.0, 'gammln_s arg') x=xx tmp=x+5.5_dp tmp=(x+0.5_dp)*log(tmp)-tmp gammln_s=tmp+log(stp*(1.000000000190015_dp+& sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x) END FUNCTION gammln_s FUNCTION gammln_v(xx) USE nrtype; USE nrutil, ONLY: assert IMPLICIT NONE INTEGER(I4B) :: i REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), DIMENSION(size(xx)) :: gammln_v REAL(DP), DIMENSION(size(xx)) :: ser,tmp,x,y REAL(DP) :: stp = 2.5066282746310005_dp REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& -86.50532032941677_dp,24.01409824083091_dp,& -1.231739572450155_dp,0.1208650973866179e-2_dp,& -0.5395239384953e-5_dp/) if (size(xx) == 0) RETURN call assert(all(xx > 0.0), 'gammln_v arg') x=xx tmp=x+5.5_dp tmp=(x+0.5_dp)*log(tmp)-tmp ser=1.000000000190015_dp y=x do i=1,size(coef) y=y+1.0_dp ser=ser+coef(i)/y end do gammln_v=tmp+log(stp*ser/x) END FUNCTION gammln_v ! FUNCTION qgaus(func,a,b) ! USE nrtype ! REAL(SP), INTENT(IN) :: a,b ! REAL(SP) :: qgaus ! INTERFACE ! FUNCTION func(x) ! USE nrtype ! REAL(SP), DIMENSION(:), INTENT(IN) :: x ! REAL(SP), DIMENSION(size(x)) :: func ! END FUNCTION func ! END INTERFACE ! REAL(SP) :: xm,xr ! REAL(SP), DIMENSION(5) :: dx, w = (/ 0.2955242247_sp,0.2692667193_sp,& ! 0.2190863625_sp,0.1494513491_sp,0.0666713443_sp /),& ! x = (/ 0.1488743389_sp,0.4333953941_sp,0.6794095682_sp,& ! 0.8650633666_sp,0.9739065285_sp /) ! xm=0.5_sp*(b+a) ! xr=0.5_sp*(b-a) ! dx(:)=xr*x(:) ! qgaus=xr*sum(w(:)*(func(xm+dx)+func(xm-dx))) ! END FUNCTION qgaus FUNCTION locatenr(xx,x) USE nrtype IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: xx REAL(SP), INTENT(IN) :: x INTEGER(I4B) :: locatenr INTEGER(I4B) :: n,jl,jm,ju LOGICAL :: ascnd n=size(xx) ascnd = (xx(n) >= xx(1)) jl=0 ju=n+1 do if (ju-jl <= 1) exit jm=(ju+jl)/2 if (ascnd .eqv. (x >= xx(jm))) then jl=jm else ju=jm end if end do if (x == xx(1)) then locatenr=1 else if (x == xx(n)) then locatenr=n-1 else locatenr=jl end if END FUNCTION locatenr SUBROUTINE tridag_ser(a,b,c,r,u) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u REAL(SP), DIMENSION(size(b)) :: gam INTEGER(I4B) :: n,j REAL(SP) :: bet n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_ser') bet=b(1) if (bet == 0.0) call nrerror('tridag_ser: Error at code stage 1') u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) if (bet == 0.0) & call nrerror('tridag_ser: Error at code stage 2') u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 u(j)=u(j)-gam(j+1)*u(j+1) end do END SUBROUTINE tridag_ser RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror USE nr, ONLY : tridag_ser IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r REAL(SP), DIMENSION(:), INTENT(OUT) :: u INTEGER(I4B), PARAMETER :: NPAR_TRIDAG=4 INTEGER(I4B) :: n,n2,nm,nx REAL(SP), DIMENSION(size(b)/2) :: y,q,piva REAL(SP), DIMENSION(size(b)/2-1) :: x,z REAL(SP), DIMENSION(size(a)/2) :: pivc n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_par') if (n < NPAR_TRIDAG) then call tridag_ser(a,b,c,r,u) else if (maxval(abs(b(1:n))) == 0.0) & call nrerror('tridag_par: possible singular matrix') n2=size(y) nm=size(pivc) nx=size(x) piva = a(1:n-1:2)/b(1:n-1:2) pivc = c(2:n-1:2)/b(3:n:2) y(1:nm) = b(2:n-1:2)-piva(1:nm)*c(1:n-2:2)-pivc*a(2:n-1:2) q(1:nm) = r(2:n-1:2)-piva(1:nm)*r(1:n-2:2)-pivc*r(3:n:2) if (nm < n2) then y(n2) = b(n)-piva(n2)*c(n-1) q(n2) = r(n)-piva(n2)*r(n-1) end if x = -piva(2:n2)*a(2:n-2:2) z = -pivc(1:nx)*c(3:n-1:2) call tridag_par(x,y,z,q,u(2:n:2)) u(1) = (r(1)-c(1)*u(2))/b(1) u(3:n-1:2) = (r(3:n-1:2)-a(2:n-2:2)*u(2:n-2:2) & -c(3:n-1:2)*u(4:n:2))/b(3:n-1:2) if (nm == n2) u(n)=(r(n)-a(n-1)*u(n-1))/b(n) end if END SUBROUTINE tridag_par SUBROUTINE spline(x,y,yp1,ypn,y2) USE nrtype; USE nrutil, ONLY : assert_eq USE nr, ONLY : tridag IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: x,y REAL(SP), INTENT(IN) :: yp1,ypn REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 INTEGER(I4B) :: n REAL(SP), DIMENSION(size(x)) :: a,b,c,r n=assert_eq(size(x),size(y),size(y2),'spline') c(1:n-1)=x(2:n)-x(1:n-1) r(1:n-1)=6.0_sp*((y(2:n)-y(1:n-1))/c(1:n-1)) r(2:n-1)=r(2:n-1)-r(1:n-2) a(2:n-1)=c(1:n-2) b(2:n-1)=2.0_sp*(c(2:n-1)+a(2:n-1)) b(1)=1.0 b(n)=1.0 if (yp1 > 0.99e30_sp) then r(1)=0.0 c(1)=0.0 else r(1)=(3.0_sp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) c(1)=0.5 end if if (ypn > 0.99e30_sp) then r(n)=0.0 a(n)=0.0 else r(n)=(-3.0_sp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) a(n)=0.5 end if call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n)) END SUBROUTINE spline FUNCTION splint(xa,ya,y2a,x) USE nrtype; USE nrutil, ONLY : assert_eq,nrerror USE nr, ONLY: locatenr IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a REAL(SP), INTENT(IN) :: x REAL(SP) :: splint INTEGER(I4B) :: khi,klo,n REAL(SP) :: a,b,h n=assert_eq(size(xa),size(ya),size(y2a),'splint') klo=max(min(locatenr(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) if (h == 0.0) call nrerror('bad xa input in splint') a=(xa(khi)-x)/h b=(x-xa(klo))/h splint=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_sp END FUNCTION splint SUBROUTINE sort(arr) USE nrtype; USE nrutil, ONLY : swap,nrerror IMPLICIT NONE REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 REAL(SP) :: a INTEGER(I4B) :: n,k,i,j,jstack,l,r INTEGER(I4B), DIMENSION(NSTACK) :: istack n=size(arr) jstack=0 l=1 r=n do if (r-l < NN) then do j=l+1,r a=arr(j) do i=j-1,l,-1 if (arr(i) <= a) exit arr(i+1)=arr(i) end do arr(i+1)=a end do if (jstack == 0) RETURN r=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else k=(l+r)/2 call swap(arr(k),arr(l+1)) call swap(arr(l),arr(r),arr(l)>arr(r)) call swap(arr(l+1),arr(r),arr(l+1)>arr(r)) call swap(arr(l),arr(l+1),arr(l)>arr(l+1)) i=l+1 j=r a=arr(l+1) do do i=i+1 if (arr(i) >= a) exit end do do j=j-1 if (arr(j) <= a) exit end do if (j < i) exit call swap(arr(i),arr(j)) end do arr(l+1)=arr(j) arr(j)=a jstack=jstack+2 if (jstack > NSTACK) call nrerror('sort: NSTACK too small') if (r-i+1 >= j-l) then istack(jstack)=r istack(jstack-1)=i r=j-1 else istack(jstack)=j-1 istack(jstack-1)=l l=i end if end if end do END SUBROUTINE sort !!! Whizard wrapper for NR tools module nr_tools use kinds, only: default !NODEP! use nrtype, only: i4b, sp, spc !NODEP! use nr, only: gammln, hypgeo, locatenr, sort, spline, splint !NODEP! implicit none save private public :: nr_hypgeo, nr_gamma, nr_locate, nr_sort, nr_spline_t type :: nr_spline_t real(sp), dimension(:), allocatable :: xa, ya_re, ya_im, y2a_re, y2a_im contains procedure :: init => nr_spline_init procedure :: interpolate => nr_spline_interpolate procedure :: dealloc => nr_spline_dealloc end type nr_spline_t contains function nr_hypgeo (a, b, c, d) result (h) complex(default), intent(in) :: a, b, c, d complex(default) :: h complex(spc) :: a_sp, b_sp, c_sp, d_sp a_sp = cmplx(a,kind=sp) b_sp = cmplx(b,kind=sp) c_sp = cmplx(c,kind=sp) d_sp = cmplx(d,kind=sp) h = cmplx( hypgeo (a_sp, b_sp, c_sp, d_sp) , kind=default ) end function nr_hypgeo function nr_gamma (x) result (y) real(default), intent(in) :: x real(default) :: y y = real( exp(gammln(real(x,kind=sp))) , kind=default ) end function nr_gamma function nr_locate (xa, x) result (pos) real(default), dimension(:), intent(in) :: xa real(default), intent(in) :: x integer :: pos pos = locatenr (real(xa,kind=sp), real(x,kind=sp)) end function ! function nr_qgaus (fun, pts) result (res) ! real(default), dimension(:), intent(in) :: pts ! complex(default) :: res ! integer :: i_pts ! real(sp) :: lo, hi, re, im ! interface ! function fun (x) ! use kinds, only: default !NODEP! ! real(default), intent(in) :: x ! complex(default) :: fun ! end function fun ! end interface ! res = 0.0_default ! if ( size(pts) < 2 ) return ! do i_pts=1, size(pts)-1 ! lo = real(pts(i_pts ),kind=sp) ! hi = real(pts(i_pts+1),kind=sp) ! re = qgaus (fun_re, lo, hi) ! im = qgaus (fun_im, lo, hi) ! res = res + cmplx(re,im,kind=default) ! end do ! contains ! function fun_re (xa_sp) ! use kinds, only: default !NODEP! ! use nrtype, only: sp !NODEP! ! real(sp), dimension(:), intent(in) :: xa_sp ! real(sp), dimension(size(xa_sp)) :: fun_re ! real(default), dimension(size(xa_sp)) :: xa ! integer :: ix ! xa = real(xa_sp,kind=default) ! fun_re = (/ (real(fun(xa(ix)),kind=sp), ix=1, size(xa)) /) ! end function fun_re ! function fun_im (xa_sp) ! use kinds, only: default !NODEP! ! use nrtype, only: sp !NODEP! ! real(sp), dimension(:), intent(in) :: xa_sp ! real(sp), dimension(size(xa_sp)) :: fun_im ! real(default), dimension(size(xa_sp)) :: xa ! integer :: ix ! xa = real(xa_sp,kind=default) ! fun_im = (/ (real(aimag(fun(xa(ix))),kind=sp), ix=1, size(xa)) /) ! end function fun_im ! end function nr_qgaus subroutine nr_sort (array) real(default), dimension(:), intent(inout) :: array real(sp), dimension(size(array)) :: array_sp array_sp = real(array,kind=sp) call sort (array_sp) array = real(array_sp,kind=default) end subroutine nr_sort subroutine nr_spline_init (spl, xa_in, ya_in) class(nr_spline_t), intent(inout) :: spl real(default), dimension(:), intent(in) :: xa_in complex(default), dimension(:), intent(in) :: ya_in integer :: n if ( allocated(spl%xa) ) then print *, "ERROR: nr_spline: init: already initialized!" stop end if n = size(xa_in) allocate( spl%xa(n) ) allocate( spl%ya_re(n) ) allocate( spl%ya_im(n) ) allocate( spl%y2a_re(n) ) allocate( spl%y2a_im(n) ) spl%xa = real(xa_in,kind=sp) spl%ya_re = real(ya_in,kind=sp) spl%ya_im = real(aimag(ya_in),kind=sp) call spline (spl%xa, spl%ya_re, 1.e30, 1.e30, spl%y2a_re) call spline (spl%xa, spl%ya_im, 1.e30, 1.e30, spl%y2a_im) end subroutine nr_spline_init function nr_spline_interpolate (spl, x) result (y) complex(default) :: y class(nr_spline_t), intent(in) :: spl real(default), intent(in) :: x real(sp) :: y_re, y_im if ( .not.allocated(spl%xa) ) then print *, "ERROR: nr_spline: interpolate: not initialized!" stop end if y_re = splint (spl%xa, spl%ya_re, spl%y2a_re, real(x,kind=sp)) y_im = splint (spl%xa, spl%ya_im, spl%y2a_im, real(x,kind=sp)) y = cmplx(y_re,y_im,kind=default) end function nr_spline_interpolate subroutine nr_spline_dealloc (spl) class(nr_spline_t), intent(inout) :: spl if ( .not.allocated(spl%xa) ) then print *, "ERROR: nr_spline: dealloc: not initialized!" stop end if deallocate( spl%xa ) deallocate( spl%ya_re ) deallocate( spl%ya_im ) deallocate( spl%y2a_re ) deallocate( spl%y2a_im ) end subroutine nr_spline_dealloc end module nr_tools @ <<[[toppik.f]]>>= ! WHIZARD <> <> ! TOPPIK code by M. Jezabek, T. Teubner (v1.1, 1992), T. Teubner (1998) ! ! FB: -commented out numerical recipes code for hypergeometric 2F1 ! included in hypgeo.f90; ! -commented out unused function 'ZAPVQ1'; ! -replaced function 'cdabs' by 'abs'; ! -replaced function 'dimag' by 'aimag'; ! -replaced function 'dcmplx(,)' by 'cmplx(,,kind=kind(0d0))'; ! -replaced function 'dreal' by 'real'; ! -replaced function 'cdlog' by 'log'; ! -replaced PAUSE by PRINT statement to avoid compiler warning; ! -initialized 'idum' explicitly as real to avoid compiler warning. ! -modified 'adglg1', 'adglg2' and 'tttoppik' to catch unstable runs. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c ********************************************************************* c c Working version with all the different original potentials c like (p^2+q^2)/|p-q|^2, not transformed in terms of delta and 1/r^2; c accuracy eps=1.d-3 possible (only), but should be save, 13.8.'98, tt. c c ********************************************************************* c subroutine tttoppik(xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv, u xc0,xc1,xc2,xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2, u xkincm,xkinca,jknflg,jgcflg, u xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zvfct) c c ********************************************************************* c c !! THIS IS NOT A PUBLIC VERSION !! c c -- Calculation of the Green function in momentum space by solving the c Lippmann-Schwinger equation c G(p) = G_0(p) + G_0(p) int_0^xcutn V(p,q) G(q) dq c c -- Written by Thomas Teubner, Hamburg, November 1998 c * Based on TOPPIK Version 1.1 c from M. Jezabek and TT, Karlsruhe, June 1992 c * Version originally for non-constant top-width c * Constant width supplied here c * No generator included c c -- Use of double precision everywhere c c -- All masses, momenta, energies, widths in GeV c c -- Input parameters: c c xenergy : E=Sqrt[s]-2*topmass c xtm : topmass (in the Pole scheme) c xtg : top-width c xalphas : alpha_s^{MSbar,n_f=5}(xscale) c xscale : soft scale mu_{soft} c xcutn : numerical UV cutoff on all momenta c (UV cutoff of the Gauss-Legendre grid) c xcutv : renormalization cutoff on the c delta-, the (p^2+q^2)/(p-q)^2-, and the c 1/r^2-[1/|p-q|]-potential: c if (max(p,q).ge.xcutv) then the three potentials c are set to zero in the Lippmann-Schwinger equation c xc0 : 0th order coefficient for the Coulomb potential, c see calling example above c xc1 : 1st order coefficient for the Coulomb potential c xc2 : 2nd order coefficient for the Coulomb potential c xcdeltc : constant of the delta(r)- c [= constant in momentum space-] potential c xcdeltl : constant for the additional log(q^2/mu^2)-part of the c delta-potential: c xcdeltc*1 + xcdeltl*log(q^2/mu^2) c xcfullc : constant of the (p^2+q^2)/(p-q)^2-potential c xcfulll : constant for the additional log(q^2/mu^2)-part of the c (p^2+q^2)/(p-q)^2-potential c xcrm2 : constant of the 1/r^2-[1/|p-q|]-potential c xkincm : } kinetic corrections in the 0th order Green-function: c xkinca : } G_0(p):=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c !!! WATCH THE SIGN IN G_0 !!! c jknflg : flag for these kinetic corrections: c 0 : no kinetic corrections applied c 1 : kinetic corrections applied with cutoff xcutv c for xkinca only c 2 : kinetic corrections applied with cutoff xcutv c for xkinca AND xkincm c jgcflg : flag for G_0(p) in the LS equation: c 0 (standard choice) : G_0(p) as given above c 1 (for TIPT) : G_0(p) = G_c^{0}(p) the 0th c order Coulomb-Green-function c in analytical form; not for c momenta p > 1000*topmass c xkincv : additional kinematic vertexcorrection in G_0, see below: c jvflg : flag for the additional vertexcorrection xkincv in the c ``zeroth order'' G_0(p) in the LS-equation: c 0 : no correction, means G = G_0 + G_0 int V G c with G_0=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c 1 : apply the correction in the LS equation as c G = G_0 + xkincv*p^2/m_t^2/[E+iGamma_t-p^2/m_t] + c G_0 int V G c and correct the integral over Im[G(p)] to get sigma_tot c from the optical theorem by the same factor. c The cutoff xcutv is applied for these corrections. c c -- Output: c c xim : R_{ttbar} from the imaginary part of the green c function c xdi : R_{ttbar} form the integral over the momentum c distribution (no cutoff but the numerical one here!!) c np : number of points used for the grid; fixed in tttoppik c xpp : 1-dim array (max. 900 elements) giving the momenta of c the Gauss-Legendre grid (pp(i) in the code) c xww : 1-dim array (max. 900 elements) giving the corresponding c Gauss-Legendre weights for the grid c xdsdp : 1-dim array (max. 900 elements) giving the c momentum distribution of top: d\sigma/dp, c normalized to R, c at the momenta of the Gauss-Legendre grid xpp(i) c zvfct : 1-dim array (max. 900 elements) of COMPLEX*16 numbers c giving the vertex function K(p), G(p)=K(p)*G_0(p) c at the momenta of the grid c c ********************************************************************* c c implicit none real*8 u pi,energy,vzero,eps, u pp, u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u xx,critp,consde, u w1,w2,sig1,sig2,const, u gtpcor,etot, u xenergy,xtm,xtg,xalphas,xscale,xc0,xc1,xc2,xim,xdi, u xdsdp,xpp,xww, u cplas,scale,c0,c1,c2,cdeltc,cdeltl,cfullc,cfulll,crm2, u xcutn,dcut,xcutv, u xp,xpmax,hmass, u kincom,kincoa,kincov,xkincm,xkinca,xkincv, u xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,chiggs complex*16 bb,gg,a1,a,g0,g0c,zvfct integer i,n,nmax,npot,np,gcflg,kinflg,jknflg,jgcflg, u jvflg,vflag parameter (nmax=900) dimension pp(nmax), bb(nmax), xx(nmax), gg(nmax), u w1(nmax), w2(nmax), a1(nmax), u xdsdp(nmax),xpp(nmax),xww(nmax),zvfct(nmax) c external a,gtpcor,g0,g0c c common/ovalco/ pi, energy, vzero, eps, npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c pi=3.141592653589793238d0 c c Number of points to evaluate on the integral equation c (<=900 and n mod 3 = 0 !!): c n=66 n=600 np=n c c For second order potential with free parameters: c npot=5 c Internal accuracy for TOPPIK, the reachable limit may be smaller, c depending on the parameters. But increase in real accuracy only c in combination with large number of points. eps=1.d-3 c Some physical parameters: wgamma=2.07d0 zmass=91.187d0 wmass=80.33d0 bmass=4.7d0 c c Input: energy=xenergy tmass=xtm tgamma=xtg cplas=xalphas scale=xscale c0=xc0 c1=xc1 c2=xc2 cdeltc=xcdeltc cdeltl=xcdeltl cfullc=xcfullc cfulll=xcfulll crm2=xcrm2 kincom=xkincm kincoa=xkinca kincov=xkincv kinflg=jknflg gcflg=jgcflg vflag=jvflg c alphas=xalphas c c Cut for divergent potential-terms for large momenta in the function vhat c and in the integrals a(p): dcut=xcutv c c Numerical Cutoff of all momenta (maximal momenta of the grid): xpmax=xcutn if (dcut.gt.xpmax) then write(*,*) ' dcut > xpmax makes no sense! Stop.' stop endif c c Not needed for the fixed order potentials: alamb5=0.2d0 c c WRITE(*,*) 'INPUT TGAMMA=',TGAMMA c Needed in subroutine GAMMAT: GFERMI=1.16637d-5 c CALL GAMMAT c WRITE(*,*) 'CALCULATED TGAMMA=',TGAMMA c etot=2.d0*tmass+energy c if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or. u (npot.eq.5)) then c For pure coulomb and fixed order potentials there is no delta-part: consde = 0.d0 else if (npot.eq.2) then c Initialize QCD-potential common-blocks and calculate constant multiplying c the delta-part of the 'qcutted' potential in momentum-space: call iniphc(1) call vqdelt(consde) else write (*,*) ' Potential not implemented! Stop.' stop endif c Delta-part of potential is absorbed by subtracting vzero from the c original energy (shift from the potential to the free Hamiltonian): vzero = consde / (2.d0*pi)**3 c write (*,*) 'vzero=', vzero c c Find x-values pp(i) and weigths w1(i) for the gaussian quadrature; c care about large number of points in the important intervals: c if (energy-vzero.le.0.d0) then cc call gauleg(0.d0, 1.d0, pp, w1, n/3) cc call gauleg(1.d0, 5.d0, pp(n/3+1), w1(n/3+1), n/3) cc call gauleg(0.d0, 0.2d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c call gauleg(0.d0, 5.d0, pp, w1, n/3) c call gauleg(5.d0, 20.d0, pp(n/3+1), w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Avoid numerical singular points in the inner of the intervals: c critp = dsqrt((energy-vzero)*tmass) c if (critp.le.1.d0) then cc Gauss-Legendre is symmetric => automatically principal-value prescription: c call gauleg(0.d0, 2.d0*critp, pp, w1, n/3) c call gauleg(2.d0*critp, 20.d0, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Better behaviour at the border of the intervals: c call gauleg(0.d0, critp, pp, w1, n/3) c call gauleg(critp, 2.d0*critp, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 1.d0/(2.d0*critp), pp(2*n/3+1), c u w1(2*n/3+1), n/3) c endif c endif c c Or different (simpler) method, good for V_JKT: if (energy.le.0.d0) then critp=tmass/3.d0 else critp=max(tmass/3.d0,2.d0*dsqrt(energy*tmass)) endif call gauleg(0.d0, critp, pp, w1, 2*n/3) call gauleg(1.d0/xpmax, 1.d0/critp, pp(2*n/3+1), u w1(2*n/3+1), n/3) c c Do substitution p => 1/p for the last interval explicitly: do 10 i=2*n/3+1,n pp(i) = 1.d0/pp(i) 10 continue c c Reorder the arrays for the third interval: do 20 i=1,n/3 xx(i) = pp(2*n/3+i) w2(i) = w1(2*n/3+i) 20 continue do 30 i=1,n/3 pp(n-i+1) = xx(i) w1(n-i+1) = w2(i) 30 continue c c Calculate the integrals a(p) for the given momenta pp(i) c and store weights and momenta for the output arrays: do 40 i=1,n a1(i) = a(pp(i)) !!! FB: can get stuck in original Toppik! !!! FB: abuse 'np' as a flag to communicate unstable runs if ( abs(a1(i)) .gt. 1d10 ) then np = -1 return endif xpp(i)=pp(i) xww(i)=w1(i) 40 continue do 41 i=n+1,nmax xpp(i)=0.d0 xww(i)=0.d0 41 continue c c Solve the integral-equation by solving a system of algebraic equations: call sae(pp, w1, bb, a1, n) c c (The substitution for the integration to infinity pp => 1/pp c is done already.) do 50 i=1,n zvfct(i)=bb(i) gg(i) = bb(i)*g0c(pp(i)) cc gg(i) = (1.d0 + bb(i))*g0c(pp(i)) cc Urspruenglich anderes (Minus) VZ hier, dafuer kein Minus mehr bei der cc Definition des WQs ueber Im G, 2.6.1998, tt. cc gg(i) = - (1.d0 + bb(i))*g0c(pp(i)) 50 continue c c Normalisation on R: const = 8.d0*pi/tmass**2 c c Proove of the optical theorem for the output values of sae: c Simply check if sig1 = sig2. sig1 = 0.d0 sig2 = 0.d0 do 60 i=1,n*2/3 c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/dsqrt(tmass**2+pp(i)**2) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const endif c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) 60 continue c '*p**2' because of substitution p => 1/p in the integration of p**2*G(p) c to infinity do 70 i=n*2/3+1,n c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/dsqrt(tmass**2+pp(i)**2) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) xdsdp(i)=pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const endif c c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) 70 continue do 71 i=n+1,nmax xdsdp(i)=0.d0 zvfct(i)=(0.d0,0.d0) 71 continue c c Normalisation on R: sig1 = sig1 / (2.d0*pi**2) * const sig2 = sig2 / (2.d0*pi**2) * const c c The results from the momentum space approach finally are: cc Jetzt Minus hier, 2.6.98, tt. xim=-sig1 xdi=sig2 c end c c complex*16 function g0(p) c implicit none real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi,energy,vzero,eps, u p,gtpcor,hmass integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot external gtpcor save g0=1.d0/cmplx(energy-vzero-p**2/tmass, u tgamma*gtpcor(p,2.d0*tmass+energy), u kind=kind(0d0)) end c complex*16 function g0c(p) c implicit none complex*16 hypgeo,green,zk,zi,amd2k,aa,bb,cc,zzp,zzm, u hypp,hypm,g0 real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi,energy,vzero,eps, u p,gtpcor,hmass, u kincom,kincoa,kincov,xp,xpmax,dcut integer npot,kinflg,gcflg,vflag COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag common/mom/ xp,xpmax,dcut external hypgeo,gtpcor,g0 save c if (gcflg.eq.0) then if (kinflg.eq.0) then g0c=g0(p) else if (kinflg.eq.1.and.p.lt.dcut) then g0c=g0(p)*(1.d0+kincom)+kincoa else if (kinflg.eq.1.and.p.ge.dcut) then g0c=g0(p)*(1.d0+kincom) else if (kinflg.eq.2.and.p.lt.dcut) then g0c=g0(p)*(1.d0+kincom)+kincoa else if (kinflg.eq.2.and.p.ge.dcut) then g0c=g0(p) else write(*,*) ' kinflg wrong! Stop.' stop endif else if (gcflg.eq.1) then zi=(0.d0,1.d0) zk=-tmass*cmplx(energy,tgamma u *gtpcor(p,2.d0*tmass+energy), u kind=kind(0d0)) zk=sqrt(zk) amd2k=4.d0/3.d0*alphas*tmass/2.d0/zk aa=(2.d0,0.d0) bb=(1.d0,0.d0) cc=2.d0-amd2k zzp=(1.d0+zi*p/zk)/2.d0 zzm=(1.d0-zi*p/zk)/2.d0 if (abs(zzp).gt.20.d0) then hypp=(1.d0-zzp)**(-aa)* u hypgeo(aa,cc-bb,cc,zzp/(zzp-1.d0)) else hypp=hypgeo(aa,bb,cc,zzp) endif if (abs(zzm).gt.20.d0) then hypm=(1.d0-zzm)**(-aa)* u hypgeo(aa,cc-bb,cc,zzm/(zzm-1.d0)) else hypm=hypgeo(aa,bb,cc,zzm) endif green=-zi*tmass/(4.d0*p*zk)/(1.d0-amd2k)*(hypp-hypm) c VZ anders herum als in Andres Konvention, da bei ihm G_0=1/[-E-i G+p^2/m]: g0c=-green if (p.gt.1.d3*tmass) then write(*,*) ' g0cana = ',g0c,' not reliable. Stop.' stop endif else write(*,*) ' gcflg wrong! Stop.' stop endif c end c c complex*16 function a(p) c implicit none real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy,ETOT,vzero, eps, $ QCUT,QMAT1,ALR,PCUT, u p, u xp,xpmax, xb1,xb2,dcut,ddcut, u a1, a2, a3, a4,a5,a6, u adglg1, fretil1, fretil2, fimtil1, fimtil2, u ALEFVQ, gtpcor, ad8gle, buf,adglg2, c u xerg, u kincom,kincoa,kincov,hmass ! complex*16 zapvq1,ZAPVGP complex*16 ZAPVGP !!! FB c u ,acomp integer npot,ILFLAG,kinflg,gcflg,vflag c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG common/ovalco/ pi, energy, vzero, eps, npot common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c external adglg1, fretil1, fretil2, fimtil1, fimtil2, ! u zapvq1, ALEFVQ, gtpcor,ZAPVGP,ad8gle,adglg2 u ALEFVQ, gtpcor,ZAPVGP,ad8gle,adglg2 !!! FB c if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or. u (npot.eq.5)) then c xp=p buf=0.d0 c a1=0.d0 a2=0.d0 a3=0.d0 a4=0.d0 a5=0.d0 a6=0.d0 if (gcflg.eq.0) then ddcut=xpmax else if (gcflg.eq.1) then ddcut=dcut else write(*,*) ' gcflg wrong! Stop.' stop endif c if (2.d0*xp.lt.ddcut) then xb1=xp xb2=2.d0*xp c c More stable for logarithmically divergent fixed order potentials: c a1=adglg1(fretil1, buf, xb1, eps) !!! FB: can get stuck! a2=adglg1(fimtil1, buf, xb1, eps) c Slightly unstable: a3=adglg2(fretil1,xb1,xb2,eps) !!! FB: can get stuck! c No good: c a3=adglg1(fretil1,xb1,xb2,eps) c Not better: c call adqua(xb1,xb2,fretil1,xerg,eps) c a3=xerg c Also not better: c a1=adglg1(fretil1, buf, xb2, eps) c a4=adglg2(fimtil1,xb1,xb2,eps) c a5 = adglg2(fretil1, xb2, ddcut, eps) c a6 = adglg2(fimtil1, xb2, ddcut, eps) a5 = adglg2(fretil2, 1.d0/ddcut, 1.d0/xb2, eps) a6 = adglg2(fimtil2, 1.d0/ddcut, 1.d0/xb2, eps) else if (xp.lt.ddcut) then xb1=xp xb2=ddcut a1=adglg1(fretil1, buf, xb1, eps) a2=adglg1(fimtil1, buf, xb1, eps) a3=adglg2(fretil1,xb1,xb2,eps) a4=adglg2(fimtil1,xb1,xb2,eps) else if (ddcut.le.xp) then else write(*,*) ' Constellation not possible! Stop.' stop endif c a = 1.d0/(4.d0*pi**2)*cmplx(a1+a3+a5,a2+a4+a6, u kind=kind(0d0)) c else if (npot.eq.2) then PCUT=QCUT ETOT=ENERGY+2*TMASS a = ZAPVGP(P,ETOT,VZERO-ENERGY,PCUT,EPS) c acomp = zapvq1(ALEFVQ, p, vzero-energy, gtpcor, eps) c a = zapvq1(ALEFVQ, p, vzero-energy, gtpcor, eps) c acomp = acomp/a c if (abs(acomp-1.d0).gt.1.d-3) then c write (*,*) 'p=', p c write (*,*) 'acomp/a=', acomp c endif else write (*,*) ' Potential not implemented! Stop.' stop endif c end c real*8 function fretil1(xk) implicit none real*8 xk, freal external freal fretil1 = freal(xk) end c real*8 function fretil2(xk) implicit none real*8 xk, freal external freal fretil2 = freal(1.d0/xk) * xk**(-2) end c real*8 function fimtil1(xk) implicit none real*8 xk, fim external fim fimtil1 = fim(xk) end c real*8 function fimtil2(xk) implicit none real*8 xk, fim external fim fimtil2 = fim(1.d0/xk) * xk**(-2) end c real*8 function freal(xk) implicit none complex*16 vhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhat, g0, g0c, gtpcor c freal = real(g0c(xk)*vhat(p, xk)) !!! FB: NaN? end c real*8 function fim(xk) implicit none complex*16 vhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhat, g0, g0c, gtpcor fim = aimag(g0c(xk)*vhat(p, xk)) end c c complex*16 function vhat(p, xk) c implicit none complex*16 zi real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p, xk, u cnspot, phiint, phfqcd, AD8GLE, u pm, xkm, ALPHEF, u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2, u xkpln1st,xkpln2nd,xkpln3rd, u pp,pmax,dcut,hmass,chiggs integer npot parameter(zi=(0.d0,1.d0)) parameter(zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0, u xnf=5.d0) c external AD8GLE, phfqcd, ALPHEF c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/pmaxkm/ pm, xkm common/mom/ pp,pmax,dcut common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c pm=p xkm=xk cnspot=-4.d0/3.d0*4.d0*pi c if (p/xk.le.1.d-5.and.p.le.1.d-5) then xkpln1st=2.d0 xkpln2nd=-4.d0*dlog(scale/xk) xkpln3rd=-6.d0*dlog(scale/xk)**2 else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then xkpln1st=2.d0*(xk/p)**2 xkpln2nd=-4.d0*(xk/p)**2*dlog(scale/p) xkpln3rd=-6.d0*(xk/p)**2*dlog(scale/p)**2 else c xkpln1st=xk/p*dlog(dabs((p+xk)/(p-xk))) xkpln1st=xk/p*(dlog(p+xk)-dlog(dabs(p-xk))) xkpln2nd=xk/p*(-1.d0)*(dlog(scale/(p+xk))**2- u dlog(scale/dabs(p-xk))**2) xkpln3rd=xk/p*(-4.d0/3.d0)*(dlog(scale/(p+xk))**3- u dlog(scale/dabs(p-xk))**3) endif c if (npot.eq.2) then if (p/xk.le.1.d-5.and.p.le.1.d-5) then vhat = 2.d0 * cnspot * ALPHEF(xk) else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then vhat = 2.d0 * cnspot * xk**2 / p**2 * ALPHEF(p) else phiint = cnspot * (AD8GLE(phfqcd, 0.d0, 0.3d0, 1.d-5) u +AD8GLE(phfqcd, 0.3d0, 1.d0, 1.d-5)) vhat = xk / p * dlog(dabs((p+xk)/(p-xk))) * phiint endif else if (npot.eq.1) then c0=1.d0 c1=0.d0 c2=0.d0 else if (npot.eq.3) then c0=1.d0+alphas/(4.d0*pi)*a1 c1=alphas/(4.d0*pi)*b0 c2=0 else if (npot.eq.4) then c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2 c1=alphas/(4.d0*pi)*b0+ u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1) c2=(alphas/(4.d0*pi))**2*b0**2 else if (npot.eq.5) then else write (*,*) ' Potential not implemented! Stop.' stop endif phiint=cnspot*alphas c c if ((xk+p).le.dcut) then c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(p+xk-dabs(xk-p)) c else if (dabs(xk-p).lt.dcut) then c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(dcut-dabs(xk-p)) c else if (dcut.le.dabs(xk-p)) then c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c else c write(*,*) ' Not possible! Stop.' c stop c endif c if (max(xk,p).lt.dcut) then c Coulomb + first + second order corrections: vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c All other potentials: u +cdeltc*2.d0*xk**2 u +cdeltl*xk/p/2.d0*( u (p+xk)**2*(dlog(((p+xk)/scale)**2)-1.d0)- u (p-xk)**2*(dlog(((p-xk)/scale)**2)-1.d0)) u +cfullc*(p**2+xk**2)*xkpln1st u +cfulll*(p**2+xk**2)*xk/p/4.d0* u (dlog(((p+xk)/scale)**2)**2- u dlog(((p-xk)/scale)**2)**2) u +crm2*xk/p*(p+xk-dabs(xk-p)) else vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) endif endif c end c c c c --- Routines needed for use of phenomenological potentials --- c SUBROUTINE INIPHC(INIFLG) implicit real*8(a-h,o-z) save COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG CHARACTER QCTCHR,QMTCHR,ALFCHR DATA QCUT0/.100d0/,QMT1S/5.0d0/ c zmass= 91.187d0 if(INIFLG.eq.0) then c standard set of parameters ilflag= 1 alphas=.12d0 qcut= qcut0 qmat1= qmt1s else c Parameters of QCD potential specified by USER 5 write(*,*) 'QCD coupling at M_z: ALPHAS or LAMBDA ?' write(*,*) 'A/L :' read(*,895) ALFCHR if(ALFCHR.eq.'A'.or.ALFCHR.eq.'a') then ilflag= 1 write(*,*) 'alpha_s(M_z)= ?' read(*,*) alphas elseif(ALFCHR.eq.'L'.or.ALFCHR.eq.'l') then write(*,*) 'Lambda(nf=5) =?' read(*,*) alamb5 ilflag= 0 else write(*,*) '!!! PLEASE TYPE: A OR L !!!' goto 5 endif 10 write(*,896) qcut0 read(*,895) QCTCHR if(QCTCHR.eq.'Y'.or.QCTCHR.eq.'y') then qcut=qcut0 elseif(QCTCHR.eq.'N'.or.QCTCHR.eq.'n') then write(*,*) 'QCUT (GeV) = ?' read(*,*) qcut else write(*,*) '!!! PLEASE TYPE: Y OR N !!!' goto 10 endif 15 write(*,902) qmt1s read(*,895) QMTCHR if(QMTCHR.eq.'Y'.or.QMTCHR.eq.'y') then qmat1=qmt1s elseif(QMTCHR.eq.'N'.or.QMTCHR.eq.'n') then write(*,*) 'QMAT1 (GeV) = ?' read(*,*) qmat1 else write(*,*) '!!! PLEASE TYPE: Y OR N !!!' goto 15 endif endif 895 format(1A) 896 format(1x,'Long distance cut off for QCD potential'/ $ 1x,'QCUT = ',f5.4,' GeV. OK ? Y/N') 902 format(1x, $ 'Matching QCD for NF=5 and Richardson for NF=3 at QMAT1 =', $ f5.2,' GeV.'/1x,' OK ? Y/N') end c c real*8 function phfqcd(x) c integrand over k ? real*8 pm, xkm, x, ALPHEF external ALPHEF common/pmaxkm/ pm, xkm phfqcd = ALPHEF((pm+xkm)*(dabs(pm-xkm)/(pm+xkm))**x) end c c FUNCTION ALEFVQ(x) implicit real*8(a-h,o-z) external ALPHEF common/xtr101/ p0 data pi/3.1415926535897930d0/ q= p0*x ALEFVQ= - 4d0/3* 4*pi*ALPHEF(q) return end C C C C COMPLEX*16 FUNCTION ZAPVGP(P,ETOT,VME,PCUT,ACC) C C A(p,E)= ZAPVGP(P,ETOT,VME,PCUT,ACC) C for QCD potential VQQBAR(q) and GAMTPE(P,E) - momentum C dependent width of top quark in t-tbar system. C 2-dimensional integration C P - intrinsic momentum of t quark, ETOT - total energy of t-tbar, C VME=V0-E, where V0-potential at spatial infinity, E=ETOT-2*TMASS, C PCUT - cut off in momentum space; e.g. for QCD potential C given by ALPHEF PCUT=QCUT in COMMON/parflg/, C ACC - accuracy C external functions: VQQBAR,GAMTPE,ADQUA,AD8GLE,ADGLG1,ADGLG2 C IMPLICIT REAL*8(A-Z) EXTERNAL FIN01P,FIN02P,FIN03P,FIN04P,AD8GLE,ADGLG1,ADGLG2 COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/XTR102/ P0,E0,VMEM,TM,ACC0 DATA PI/3.14159265/,BUF/1D-10/,SMALL/1D-2/ C For Testing only small = 1.d-1 C CONST= -TMASS/(8*PI**2*P) TM= TMASS ACC0=ACC*SMALL P0=P E0=ETOT VMEM=VME*TMASS IF(PCUT.LE.P) THEN XXRE=AD8GLE(FIN01P,BUF,PCUT,ACC)+ADGLG1(FIN01P,PCUT,P,ACC)+ $ ADGLG1(FIN02P,BUF,1/P,ACC) XXIM=AD8GLE(FIN03P,BUF,PCUT,ACC)+ADGLG1(FIN03P,PCUT,P,ACC)+ $ ADGLG1(FIN04P,BUF,1/P,ACC) ELSE XXRE=ADGLG1(FIN01P,BUF,P,ACC)+ADGLG2(FIN01P,P,PCUT,ACC)+ $ AD8GLE(FIN02P,BUF,1/PCUT,ACC) XXIM=ADGLG1(FIN03P,BUF,P,ACC)+ADGLG2(FIN03P,P,PCUT,ACC)+ $ AD8GLE(FIN04P,BUF,1/PCUT,ACC) ENDIF ZAPVGP=CONST*CMPLX(XXRE,XXIM,KIND=KIND(0d0)) END C REAL*8 FUNCTION FIN01P(Q) C this segment contains FIN01P,FIN02P,FIN03P,FIN04P IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL VQQBAR,FIN11P, FIN12P COMMON/XTR102/ P0,E0,VMEM,TM,ACC0 DATA PI/3.14159265/,BUF/1d-10/ Q0=Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN11P,Y,ACC0) FIN01P= VQQBAR(Q0)*Q0*Y RETURN ENTRY FIN02P(Q) Q0=1/Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN11P,Y,ACC0) FIN02P= VQQBAR(Q0)*Q0**3*Y RETURN ENTRY FIN03P(Q) Q0=Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN12P,Y,ACC0) FIN03P= VQQBAR(Q0)*Q0*Y RETURN ENTRY FIN04P(Q) Q0=1/Q XL=(P0-Q0)**2 XU=(P0+Q0)**2 CALL ADQUA(XL,XU,FIN12P,Y,ACC0) FIN04P= VQQBAR(Q0)*Q0**3*Y END REAL*8 FUNCTION FIN11P(T) C this segment contains FIN11P,FIN12P IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL GAMTPE COMMON/XTR102/ P0,E0,VMEM,TM,ACC0 T1= T+VMEM TSQRT= SQRT(T) GAMMA= TM*GAMTPE(TSQRT,E0) FIN11P= T1/(T1**2+GAMMA**2) RETURN ENTRY FIN12P(T) T1= T+VMEM TSQRT= SQRT(T) GAMMA= TM*GAMTPE(TSQRT,E0) FIN12P= GAMMA/(T1**2+GAMMA**2) END C c SUBROUTINE VQDELT(VQ) c c evaluates constants multiplying Dirac delta in potentials VQCUT c calls: ADQUA c implicit real*8(a-h,o-z) external alphef,fncqct COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG data pi/3.141592653589793238D0/ c call adqua(1d-8,1d4,fncqct,y,1d-4) v=-4d0/3*2/pi*y VQ=(-.25-v)*(2*pi)**3 end c function fncqct(q) implicit real*8(a-h,o-z) fncqct=sin(q)/q*alphef(q) end c C REAL*8 FUNCTION VQQBAR(P) C C interquark potential for q- qbar singlet state C IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL ALPHEF COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass DATA PI/3.14159265/ VQQBAR = -4D0/3*4*PI*ALPHEF(P)/P**2 END C FUNCTION ALPHEF(q) c c V(q) = -4/3 * 4*pi*ALPHEF(q)/q**2 c input: alphas or alamb5 in COMMON/PHCONS/. If: c ILFLAG.EQ.0 alamb5= \Lambda_\{\bar MS}^{(5)} at M_z c ILFLAG.EQ.1 alphas = alpha_{strong} at M_z (91.161) c c effective coupling ALPHEF is defined as follows: c for q > qmat1=m_b: c alphas*( 1 +(31/3-10*nf/9)*alphas/(4*pi) ) c where alphas=\alpha_\bar{MS} for nf=5, i.e. c alpha=4*pi/( b0(nf=5)*x + b1(5)/b0(5)*ln(x) ) c and x = ln(q**2/alamb5**2) c for qmat1 > q > qcut: c 4*pi/b0(nefr=3)*(alfmt+1/log(1+q**2/alr**2)) c where alr=.4 GeV, nefr=3, and continuity --> alfmt c below qcut: alphrc*2*q**2/(q**2+qcut**2) (cont.-->alphrc) c implicit real*8(a-h,o-z) SAVE COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG common/parpot/ a5,b5,c5,alfmt,d,alphrc data pi/3.141592653589793238D0/, $ zold/-1d0/,qctold/-1d0/,alfold/-1d0/, $olmbd/-1d0/ c if(zmass.le.0d0 .or. qcut.le.0d0) STOP 10001 if(zold.ne.zmass .or. qcut.ne.qctold) num=0 if(ilflag.eq.0 .and. olmbd.ne.alamb5) num=0 if(ilflag.eq.1 .and. alfold.ne.alphas) num=0 if(num.eq.0)then num=num+1 zold=zmass qctold=qcut call potpar alfold= alphas olmbd= alamb5 endif if(q.le.qcut) then alphef=alphrc*(2*q**2)/(qcut**2+q**2) elseif(q.le.qmat1) then alphef=alfmt+d/log(1+q**2/alr**2) else x=2*log(q/alamb5) alfas5=1/(a5*x+b5*log(x)) alphef=alfas5*(1+c5*alfas5) endif end c c Only called by ALPHEF: SUBROUTINE POTPAR implicit real*8(a-h,o-z) COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG common/parpot/ a5,b5,c5,alfmt,d,alphrc data pi/3.141592653589793238D0/,nefr/3/ b0(nf)=11-2./3*nf b1(nf)=102-38./3*nf cn(nf)=31./3-10./9*nf alr=400d-3 a5=b0(5)/(4*pi) b5=b1(5)/b0(5)/(4*pi) c5=cn(5)/(4*pi) d=4*pi/b0(nefr) if(ilflag.eq.0) then if(alamb5.le.0d0) STOP 10002 xa=2*log(zmass/alamb5) alphas= 1/(a5*xa + b5*log(xa)) else if(alphas.le.0d0) STOP 10003 t0=0 t1=max(1d0,alphas*a5) 10 tm=(t0+t1)/2 fm=tm/alphas+b5*tm*log(tm)-a5 if(fm.lt.-1d-10) then t0=tm goto 10 elseif(fm.gt.1d-10) then t1=tm goto 10 endif alamb5=zmass*exp(-5d-1/tm) endif x=2*log(qmat1/alamb5) alfas=1/(a5*x+b5*log(x)) alfmt=alfas*(1+c5*alfas)-d/log(1+qmat1**2/alr**2) alphrc=alfmt+ d/log(1+qcut**2/alr**2) return end c c --- End of routines for phenomenological potentials --- c c c --- Routines for Gamma_top --- C SUBROUTINE GAMMAT C C on shell width of top quark including QCD corrections, c.f. C M.Jezabek and J.H. Kuhn, Nucl. Phys. B314(1989)1 C IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL DILOGG COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass DATA PI/3.14159265/ F(X)= PI**2+2*DILOGG(X)-2*DILOGG(1-X)+( 4*X*(1-X-2*X**2)*LOG(X)+ $2*(1-X)**2*(5+4*X)*LOG(1-X) - (1-X)*(5+9*X-6*X**2) ) / $(2*(1-X)**2*(1+2*X)) Y= (WMASS/TMASS)**2 cc alpha_s(M_t) corresponding to alpha_s(M_Z)=0.118: cc alphas=0.107443d0 cc write(*,*) 'alphas=',alphas c Usage of alpha_s as given as input for the potential.. better use c alpha_s at a scale close to m_t.. TGAMMA= GFERMI*TMASS**3/(8*SQRT(2D0)*PI)*(1-Y)**2*(1+2*Y)* $(1- 2D0/3*ALPHAS/PI*F(Y)) END C C REAL*8 FUNCTION GAMTPE(P,ETOT) C C momentum dependent width of top quark in t-tbar system C GAMTPE = TGAMMA*GTPCOR(P,E), where TGAMMA includes C QCD corrections, see JKT, eq.(8), and C GTPCOR - correction factor for bound t quark C IMPLICIT REAL*8(A-C,D-H,O-Z) EXTERNAL GTPCOR COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass GAMTPE= TGAMMA*GTPCOR(P,ETOT) END C C C GTPCOR and GTPCOR1 should be merged (M.J.) !!!! c real*8 function gtpcor(topp,etot) real*8 topp,etot, u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI,hmass COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass c if (topp.ge.tmass/2.d0) then c gtpcor1=0.001d0 c else gtpcor=1.d0 c endif end c c c Correction function for non-constant (energy and momentum dependent) width: FUNCTION GTPCOR1(TOPP,ETOT) c c TOPP - momentum of t quark = - momentum of tbar c ETOT - total energy of t-tbar system c calls: GENWDS, RAN2 c c Evaluates a correction factor to the width of t-tbar system. c in future has to be replaced by a function evaluating c width including radiative corrections and GTPCOR. c I include two factors reducing the width: c a - time dilatation: for decay in flight lifetime c increased accordingly to relativistic kinematics c b - overall energy-momentum conservation: I assume that c t and tbar decay in flight and in this decays energies c of Ws follow from 2-body kinematics. Then I calculate c effective mass squared of b-bar system (it may be c negative!) from en-momentum conservation. c If effective mass is < 2*Mb + 2 GeV configuration c is rejected. The weight is acceptance. c IMPLICIT REAL*8(A-H,O-Z) real ran2 external ran2 PARAMETER(NG=20,NC=4) dimension gamma(0:NG),pw1(0:3),pw2(0:3),AIJ(NC,NC),BJ(NC), $AI(NC),SIG2IN(0:NG),XIK(0:NG,NC),INDX(NC) COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass SAVE NUM,EOLD,TOLD,AI data nevent/10000/, num/0/, eold/-1d5/, told/-1d0/ c C for test runs!! C nevent=1000 C if(etot.ne.eold) num=0 if(tmass.ne.told) num=0 5 if(num.eq.0) then c xdumm= ran2(-2) do 10 itp=0,NG tp=itp*tmass/NG*2 gamma(itp)=0 do 10 ix=1,nevent call GENWDS(tp,etot,pw1,pw2,efmsq) if(efmsq.gt.0d0) then efms=sqrt(efmsq) if(efms.ge. 2*bmass+2) gamma(itp)=gamma(itp)+1 endif 10 continue do 15 ix=0,NG 15 SIG2IN(IX)= MAX(1D0,GAMMA(IX)) DO 17 JX=1,NC IF(JX.EQ.1)THEN XIK(0,JX)= .5D0 ELSE XIK(0,JX)= 0D0 ENDIF DO 17 IX=1,NG tp= 2D0*ix/NG 17 XIK(IX,JX)= tp**(JX-1)/(1+EXP(tp*3)) DO 20 I=1,NC BJ(I)=0 DO 20 J=1,NC 20 AIJ(I,J)=0 DO 30 I=1,NC DO 25 IX=0,NG 25 BJ(I)= BJ(I)+GAMMA(IX)*XIK(IX,I)*SIG2IN(IX) DO 30 J=1,I DO 30 IX=0,NG 30 AIJ(I,J)= AIJ(I,J)+XIK(IX,I)*XIK(IX,J)*SIG2IN(IX) DO 35 I=1,NC DO 35 J=I,NC 35 AIJ(I,J)= AIJ(J,I) CALL LUDCMP(AIJ,NC,NC,INDX,D) CALL LUBKSB(AIJ,NC,NC,INDX,BJ) DO 40 I=1,NC 40 AI(I)= BJ(I)/NEVENT do 42 i=1,nc 42 write(*,*)'a(',i,')=',ai(i) do 100 ix=0,NG 100 gamma(ix)= gamma(ix)/nevent eold=etot told=tmass num= 1 endif SUM=AI(1) DO 110 I=2,NC 110 SUM= SUM+AI(I)*(TOPP/TMASS)**(I-1) C CORRF2= SUM/(1+ EXP(TOPP/TMASS*3)) CORRF2= SUM/(1+ EXP(MIN(1d1,TOPP/TMASS*3))) C if(topp.gt. 2d0*tmass) then C corrf1= 0.001d0 C else C ip= NG*topp/tmass/2 C corrf1= gamma(ip) C endif C write(*,*)'ratio=',corrf1/corrf2 C GTPCOR1 = CORRF2 GTPCOR1 = CORRF2*SQRT(1-TOPP**2/(TOPP**2+TMASS**2)) END c c Generator: only called by GTPCOR1 SUBROUTINE GENWDS(tp,etot,pw1,pw2,efm2) c c generates 4-momenta of W's and effective mass of b-bbar c from t and tbar quarks decays at flight (tp = momentum of t c = - momentum of tbar (in GeV) ) in Oz direction c implicit real*8(a-h,o-z) c real ran2 real ranf c external ran2 external ranf dimension pw1(0:3),pw2(0:3) save COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass data PI/3.141592653589793238D0/ real idum c 3 s1= wmass**2+wmass*wgamma*TAN((2*ran2(idum)-1)*pi/2) 3 s1= wmass**2+wmass*wgamma*TAN((2*ranf(idum)-1)*pi/2) if(s1.le.0d0) goto 3 wmass1= sqrt(s1) if(abs(wmass1-wmass).ge.3*wgamma) goto 3 c 4 s2= wmass**2+wmass*wgamma*TAN((2*ran2(idum)-1)*pi/2) 4 s2= wmass**2+wmass*wgamma*TAN((2*ranf(idum)-1)*pi/2) if(s2.le.0d0) goto 4 wmass2= sqrt(s2) if(abs(wmass2-wmass).ge.3*wgamma) goto 4 ew1= (tmass**2+wmass1**2-bmass**2)/(2*tmass) pwt1= sqrt(ew1**2-wmass1**2) ew2= (tmass**2+wmass2**2-bmass**2)/(2*tmass) pwt2= sqrt(ew2**2-wmass2**2) 5 p=tp c u1= 2*ran2(idum)-1 u1= 2*ranf(idum)-1 pw1z= pwt1*u1 c u2= 2*ran2(idum)-1 u2= 2*ranf(idum)-1 pw2z= pwt2*u2 et= sqrt(tmass**2+p**2) bet= p/et gam= et/tmass pw1(0)= gam*(ew1+bet*pw1z) pw1(3)= gam*(pw1z+bet*ew1) pw2(0)= gam*(ew2-bet*pw2z) pw2(3)= gam*(pw2z-bet*ew2) pw1tr= sqrt(pw1(0)**2-pw1(3)**2-wmass1**2) pw2tr= sqrt(pw2(0)**2-pw2(3)**2-wmass2**2) c phi1= 2*pi*ran2(idum) phi1= 2*pi*ranf(idum) c phi2= 2*pi*ran2(idum) phi2= 2*pi*ranf(idum) pw1(1)= pw1tr*cos(phi1) pw1(2)= pw1tr*sin(phi1) pw2(1)= pw2tr*cos(phi2) pw2(2)= pw2tr*sin(phi2) prec2= (pw1(1)+pw2(1))**2+(pw1(2)+pw2(2))**2+(pw1(3)+pw2(3))**2 erest=etot-pw1(0)-pw2(0) c efm2= erest*abs(erest)-prec2 END c c --- End of routines for Gamma_top --- c c --- Routines for solving linear equations and matrix inversion (complex) --- c subroutine sae(pp, w1, bb, a1, n) c implicit none complex*16 vhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u d, pp, w1, gtpcor,hmass, u xp,xpmax,dcut,kincom,kincoa,kincov complex*16 a, a1, bb, ff, cw, svw, g0, g0c integer i, j, npot, n, nmax, indx,kinflg,gcflg,vflag parameter (nmax=900) dimension bb(nmax), ff(nmax,nmax), pp(nmax), w1(nmax), u indx(nmax), cw(nmax), a1(nmax) c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c external a, vhat, gtpcor, g0, g0c c do 10 i=1,n*2/3 cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy), c u kind=kind(0d0))-pp(i)**2/tmass)) 10 continue do 20 i=n*2/3+1,n cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) * pp(i)**2 c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy), c u kind=kind(0d0)) / c u pp(i)**2 - 1.d0/tmass)) 20 continue c do 30 i=1,n cc bb(i) = a1(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then c bb(i) = cmplx(1.d0+kincov*(pp(i)/tmass)**2,0.d0, c u kind=kind(0d0)) bb(i)=1.d0+kincov* u g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i)) else bb(i) = (1.d0,0.d0) endif svw = (0.d0,0.d0) do 40 j=1,n if (i.ne.j) then ff(i,j) = - vhat(pp(i),pp(j)) * cw(j) svw = svw + ff(i,j) endif 40 continue ff(i,i) = 1.d0 - a1(i) - svw 30 continue c call zldcmp(ff, n, nmax, indx, d) call zlbksb(ff, n, nmax, indx, bb) c end c c SUBROUTINE ZLBKSB(A,N,NP,INDX,B) C complex version of lubksb IMPLICIT NONE INTEGER I, II, INDX, J, LL, N, NP COMPLEX*16 A, B, SUM DIMENSION A(NP,NP),INDX(N),B(N) II=0 DO 12 I=1,N LL=INDX(I) SUM=B(LL) B(LL)=B(I) IF (II.NE.0)THEN DO 11 J=II,I-1 SUM=SUM-A(I,J)*B(J) 11 CONTINUE ELSE IF (SUM.NE.(0.D0,0.D0)) THEN II=I ENDIF B(I)=SUM 12 CONTINUE DO 14 I=N,1,-1 SUM=B(I) IF(I.LT.N)THEN DO 13 J=I+1,N SUM=SUM-A(I,J)*B(J) 13 CONTINUE ENDIF B(I)=SUM/A(I,I) 14 CONTINUE RETURN END c SUBROUTINE ZLDCMP(A,N,NP,INDX,D) C complex version of ludcmp IMPLICIT NONE INTEGER I, IMAX, INDX, J, K, N, NP, NMAX REAL*8 AAMAX, D, TINY, VV COMPLEX*16 A, DUM, SUM PARAMETER (NMAX=900) DIMENSION A(NP,NP), INDX(N), VV(NMAX) c tiny=1.d-5 c D=1.D0 DO 12 I=1,N AAMAX=0.D0 DO 11 J=1,N IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) 11 CONTINUE c IF (AAMAX.EQ.0.D0) PAUSE 'Singular matrix.' IF (AAMAX.EQ.0.D0) print *, "Singular matrix." VV(I)=1.D0/AAMAX 12 CONTINUE DO 19 J=1,N IF (J.GT.1) THEN DO 14 I=1,J-1 SUM=A(I,J) IF (I.GT.1)THEN DO 13 K=1,I-1 SUM=SUM-A(I,K)*A(K,J) 13 CONTINUE A(I,J)=SUM ENDIF 14 CONTINUE ENDIF AAMAX=0.D0 DO 16 I=J,N SUM=A(I,J) IF (J.GT.1)THEN DO 15 K=1,J-1 SUM=SUM-A(I,K)*A(K,J) 15 CONTINUE A(I,J)=SUM ENDIF DUM=VV(I)*ABS(SUM) IF (ABS(DUM).GE.AAMAX) THEN IMAX=I AAMAX=DUM ENDIF 16 CONTINUE IF (J.NE.IMAX) THEN DO 17 K=1,N DUM=A(IMAX,K) A(IMAX,K)=A(J,K) A(J,K)=DUM 17 CONTINUE D=-D VV(IMAX)=VV(J) ENDIF INDX(J)=IMAX IF (J.NE.N) THEN IF (A(J,J).EQ.(0.D0,0.D0)) A(J,J)=cmplx(TINY, 0.d0, u kind=kind(0d0)) DUM=1.D0/A(J,J) DO 18 I=J+1,N A(I,J)=A(I,J)*DUM 18 CONTINUE ENDIF 19 CONTINUE IF(A(N,N).EQ.(0.D0,0.D0)) A(N,N)=cmplx(TINY, 0.d0, u kind=kind(0d0)) RETURN END C C C *** TOOLS *** C C C ******* ROUTINES FOR GAUSSIAN INTEGRATIONS C C SUBROUTINE GAULEG(X1,X2,X,W,N) C C Given the lower and upper limits of integration X1 and X2 C and given N, this routine returns arrays X(N) and W(N) C containing the abscissas and weights of the Gauss-Legendre C N-point quadrature formula C IMPLICIT REAL*8 (A-H,O-Z) REAL*8 X1,X2,X(N),W(N) PARAMETER (EPS=3.D-14) save M=(N+1)/2 XM=0.5D0*(X2+X1) XL=0.5D0*(X2-X1) DO 12 I=1,M Z=DCOS(3.141592653589793238D0*(I-.25D0)/(N+.5D0)) 1 CONTINUE P1=1.D0 P2=0.D0 DO 11 J=1,N P3=P2 P2=P1 P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J 11 CONTINUE PP=N*(Z*P1-P2)/(Z*Z-1.D0) Z1=Z Z=Z1-P1/PP IF(DABS(Z-Z1).GT.EPS)GO TO 1 X(I)=XM-XL*Z X(N+1-I)=XM+XL*Z W(I)=2.D0*XL/((1.D0-Z*Z)*PP*PP) W(N+1-I)=W(I) 12 CONTINUE RETURN END C C DOUBLE PRECISION FUNCTION AD8GLE(F,A,B,EPS) implicit double precision (a-h,o-z) EXTERNAL F DIMENSION W(12),X(12) c SAVE W, X SAVE C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** C DATA W / 0.10122 85362 90376 25915 25313 543D0, $ 0.22238 10344 53374 47054 43559 944D0, $ 0.31370 66458 77887 28733 79622 020D0, $ 0.36268 37833 78361 98296 51504 493D0, $ 0.27152 45941 17540 94851 78057 246D-1, $ 0.62253 52393 86478 92862 84383 699D-1, $ 0.95158 51168 24927 84809 92510 760D-1, $ 0.12462 89712 55533 87205 24762 822D0, $ 0.14959 59888 16576 73208 15017 305D0, $ 0.16915 65193 95002 53818 93120 790D0, $ 0.18260 34150 44923 58886 67636 680D0, $ 0.18945 06104 55068 49628 53967 232D0/ C DATA X / 0.96028 98564 97536 23168 35608 686D0, $ 0.79666 64774 13626 73959 15539 365D0, $ 0.52553 24099 16328 98581 77390 492D0, $ 0.18343 46424 95649 80493 94761 424D0, $ 0.98940 09349 91649 93259 61541 735D0, $ 0.94457 50230 73232 57607 79884 155D0, $ 0.86563 12023 87831 74388 04678 977D0, $ 0.75540 44083 55003 03389 51011 948D0, $ 0.61787 62444 02643 74844 66717 640D0, $ 0.45801 67776 57227 38634 24194 430D0, $ 0.28160 35507 79258 91323 04605 015D0, $ 0.95012 50983 76374 40185 31933 543D-1/ C C ****************************************************************** C GAUSS=0.0D0 AD8GLE=GAUSS IF(B.EQ.A) RETURN CONST=EPS/(B-A) BB=A C C COMPUTATIONAL LOOP. 1 AA=BB BB=B 2 C1=0.5D0*(BB+AA) C2=0.5D0*(BB-AA) S8=0.0D0 DO 3 I=1,4 U=C2*X(I) S8=S8+W(I)*(F(C1+U)+F(C1-U)) 3 CONTINUE S8=C2*S8 S16=0.0D0 DO 4 I=5,12 U=C2*X(I) S16=S16+W(I)*(F(C1+U)+F(C1-U)) 4 CONTINUE S16=C2*S16 IF( ABS(S16-S8) .LE. EPS*(abs(s8)+ABS(S16))*0.5D0 ) GO TO 5 BB=C1 IF( 1.D0+ABS(CONST*C2) .NE. 1.D0) GO TO 2 AD8GLE=0.0D0 write(*,*)'too high accuracy required in function ad8gle!' RETURN 5 GAUSS=GAUSS+S16 IF(BB.NE.B) GO TO 1 AD8GLE=GAUSS RETURN END C C DOUBLE PRECISION FUNCTION ADGLG1(F,A,B,EPS) IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL F,AD8GLE,adqua DIMENSION W(6),X(6),xx(6) c SAVE W, XX, NUM SAVE C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C For x->b f(x) = O (ln^k (b-x) ) C A - lower limit, B - upper limit (integrable singularity) C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** DATA W / 4.58964 673950d-1, $ 4.17000 830772d-1, $ 1.13373 382074d-1, $ 1.03991 974531d-2, $ 2.61017 202815d-4, $ 8.98547 906430d-7/ C DATA X / 0.22284 66041 79d0, $ 1.18893 21016 73d0, $ 2.99273 63260 59d0, $ 5.77514 35691 05d0, $ 9.83746 74183 83d0, $ 15.98287 39806 02d0/ DATA NUM/0/ IF(NUM.eq.0d0) then do 1 ix=1,6 1 xx(ix)= EXP(-x(ix)) ENDIF num=num+1 sum=0d0 c=b-a sum6=0d0 do 10 in=1,6 10 sum6= sum6+ w(in)*f(b-c*xx(in)) sum6=sum6*c a1=a 15 a2= (a1+b)/2 c=b-a2 sumn=0d0 do 20 in=1,6 !!! FB: catch NaN if ( c/b .lt. 1d-9 ) then adglg1 = 1d15 return endif 20 sumn= sumn+ w(in)*f(b-c*xx(in)) !!! FB: f(b) = NaN ! sumn=sumn*c ctt c call adqua(a1,a2,f,sum1,eps) c sum1=sum1+sum sum1=AD8GLE(F,A1,A2,eps)+sum IF(ABS( (sum+sum6)/(sum1+sumn)-1d0 ).lt.EPS) THEN ctt c call adqua(a,a2,f,sum2,eps) sum2=AD8GLE(F,A,A2,eps) IF(ABS( (sum2+sumn)/(sum1+sumn)-1d0 ).gt.EPS) THEN sum=sum2 a1=a2 sum6=sumn goto 15 ENDIF ADGLG1= SUM1+SUMN RETURN ELSE sum=sum1 a1=a2 sum6=sumn goto 15 ENDIF END C DOUBLE PRECISION FUNCTION ADGLG2(F,A,B,EPS) IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL F,AD8GLE DIMENSION W(6),X(6),xx(6) c SAVE W,XX,NUM SAVE C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C For x->A f(x) = O (ln^k (x-a) ) C A - lower limit (integrable singularity), B - upper limit C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** DATA W / 4.58964 673950d-1, $ 4.17000 830772d-1, $ 1.13373 382074d-1, $ 1.03991 974531d-2, $ 2.61017 202815d-4, $ 8.98547 906430d-7/ C DATA X / 0.22284 66041 79d0, $ 1.18893 21016 73d0, $ 2.99273 63260 59d0, $ 5.77514 35691 05d0, $ 9.83746 74183 83d0, $ 15.98287 39806 02d0/ DATA NUM/0/ IF(NUM.eq.0d0) then do 1 ix=1,6 1 xx(ix)= EXP(-x(ix)) ENDIF num=num+1 sum=0d0 c=b-a sum6=0d0 do 10 in=1,6 10 sum6= sum6+ w(in)*f(A+c*xx(in)) sum6=sum6*c b1=b 15 b2= (a+b1)/2 c=b2-a sumn=0d0 do 20 in=1,6 !!! FB: catch NaN if ( c/a .lt. 1d-9 ) then adglg2 = 1d15 return endif 20 sumn= sumn+ w(in)*f(a+c*xx(in)) !!! FB: f(a) = NaN ! sumn=sumn*c sum1=AD8GLE(F,b2,b1,eps)+sum IF(ABS( (sum+sum6)/(sum1+sumn)-1d0 ).lt.EPS) THEN sum2=AD8GLE(F,b2,b,eps) IF(ABS( (sum2+sumn)/(sum1+sumn)-1d0 ).gt.EPS) THEN sum=sum2 b1=b2 sum6=sumn goto 15 ENDIF ADGLG2= SUM1+SUMN RETURN ELSE sum=sum1 b1=b2 sum6=sumn goto 15 ENDIF END C C C------------------------------------------------------------------ C INTEGRATION ROUTINE ADQUA written by M. Jezabek ------ C------------------------------------------------------------------ C SUBROUTINE ADQUA(XL,XU,F,Y,ACC) C C ADAPTIVE GAUSS-LEGENDRE + SIMPSON'S RULE QUADRATURE C XL - LOWER LIMIT, XU - UPPER LIMIT, F - FUNCTION TO INTEGRATE C Y - INTEGRAL C ACC - ACCURACY (IF .LE. 0. ACC=1.D-6) c ****** new constants, 1 error removed, Oct '92 C C CALLS: SIMPSA C C PARAMETERS: NSUB > NO OF SUBDIVISION LEVELS IN GAUSS INTEGRATION C 100*2**IMAX > NO OF POINTS IN SIMPSON INTEGRATION C IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL F DIMENSION VAL(25,2), BOUND(25,2,2), LEV(25),SING(25,3) DIMENSION W8(4),X8(4) DATA W8 $/0.101228536290376D0, 0.222381034453374D0, 0.313706645877887D0, $ 0.362683783378362D0/ DATA X8 $/0.960289856497536D0, 0.796666477413627D0, 0.525532409916329D0, $ 0.183434642495650D0/ save C IF(ACC.LE.0.D0) ACC=1.D-6 NSUB=24 NSG=25 NSC=0 A=XL B=XU C1=0.5d0*(A+B) C2=C1-A S8=0d0 DO 1 I=1,4 U=X8(I)*C2 1 S8=S8+W8(I)*(F(C1+U)+F(C1-U)) S8=S8*C2 XM=(XL+XU)/2.d0 BOUND(1,1,1)=XL BOUND(1,1,2)=XM BOUND(1,2,1)=XM BOUND(1,2,2)=XU NC=1 DO 3 IX=1,2 A=BOUND(NC,IX,1) B=BOUND(NC,IX,2) C1=0.5d0*(A+B) C2=C1-A VAL(NC,IX)=0.d0 DO 2 I=1,4 U=X8(I)*C2 2 VAL(NC,IX)=VAL(NC,IX)+W8(I)*(F(C1+U)+F(C1-U)) 3 VAL(NC,IX)=VAL(NC,IX)*C2 S16=VAL(NC,1)+VAL(NC,2) IF(DABS(S8-S16).GT.ACC*DABS(S16)) GOTO 4 Y=S16 RETURN 4 DO 5 I=1,NSUB 5 LEV(I)=0 NC1= NC+1 11 XM=(BOUND(NC,1,1)+BOUND(NC,1,2))/2.d0 BOUND(NC1,1,1)=BOUND(NC,1,1) BOUND(NC1,1,2)=XM BOUND(NC1,2,1)=XM BOUND(NC1,2,2)=BOUND(NC,1,2) DO 13 IX=1,2 A=BOUND(NC1,IX,1) B=BOUND(NC1,IX,2) C1=0.5d0*(A+B) C2=C1-A VAL(NC1,IX)=0.d0 DO 12 I=1,4 U=X8(I)*C2 12 VAL(NC1,IX)=VAL(NC1,IX)+W8(I)*(F(C1+U)+F(C1-U)) 13 VAL(NC1,IX)=VAL(NC1,IX)*C2 S16=VAL(NC1,1)+VAL(NC1,2) S8=VAL(NC,1) IF(DABS(S8-S16).LE.ACC*DABS(S16)) GOTO 20 NC=NC1 NC1= NC+1 IF(NC1.LE.NSUB) GOTO 11 C NC=NSUB USE SIMPSON'S RULE NSC=NSC+1 IF(NSC.LE.NSG) GOTO 15 WRITE(*,911) 911 FORMAT(1X,'ADQUA: TOO MANY SINGULARITIES') STOP 15 SING(NSC,1)=BOUND(NC,1,1) SING(NSC,2)=BOUND(NC,2,2) SING(NSC,3)=S16 S16=0.d0 NC=NC-1 20 VAL(NC,1)= S16 121 LEV(NC)=1 21 XM=(BOUND(NC,2,1)+BOUND(NC,2,2))/2.d0 BOUND(NC1,1,1)=BOUND(NC,2,1) BOUND(NC1,1,2)=XM BOUND(NC1,2,1)=XM BOUND(NC1,2,2)=BOUND(NC,2,2) DO 23 IX=1,2 A=BOUND(NC1,IX,1) B=BOUND(NC1,IX,2) C1=0.5d0*(A+B) C2=C1-A VAL(NC1,IX)=0.d0 DO 22 I=1,4 U=X8(I)*C2 22 VAL(NC1,IX)=VAL(NC1,IX)+W8(I)*(F(C1+U)+F(C1-U)) 23 VAL(NC1,IX)=VAL(NC1,IX)*C2 S16=VAL(NC1,1)+VAL(NC1,2) S8=VAL(NC,2) IF(DABS(S8-S16).LE.ACC*DABS(S16)) GOTO 40 NC=NC+1 NC1=NC+1 IF(NC1.LE.NSUB) GOTO 11 C NC=NSUB USE SIMPSON'S RULE NSC=NSC+1 IF(NSC.LE.NSG) GOTO 35 WRITE(*,911) STOP 35 SING(NSC,1)=BOUND(NC,1,1) SING(NSC,2)=BOUND(NC,2,2) SING(NSC,3)=S16 S16=0.d0 NC=NC-1 40 VAL(NC,2)= S16 45 IF(NC.GT.1) GOTO 50 Y1=VAL(1,1)+VAL(1,2) GOTO 100 50 NC0=NC-1 IF(LEV(NC0).EQ.0) IX=1 IF(LEV(NC0).EQ.1) IX=2 LEV(NC)=0 NC1=NC VAL(NC0,IX)=VAL(NC,1)+VAL(NC,2) NC=NC0 IF(IX.EQ.1) GOTO 121 GOTO 45 100 CONTINUE IF(NSC.GT.0) GOTO 101 Y=Y1 RETURN 101 FSUM=0.d0 DO 102 IK=1,NSC 102 FSUM=FSUM+DABS(SING(IK,3)) ACCR=ACC*DMAX1(FSUM,DABS(Y1))/FSUM/10.d0 DO 104 IK=1,NSC 104 CALL SIMPSA(SING(IK,1),SING(IK,2),F,SING(IK,3),ACCR) DO 106 IK=1,NSC 106 Y1=Y1+SING(IK,3) Y=Y1 RETURN END C SUBROUTINE SIMPSA(A,B,F,F0,ACC) C SIMPSON'S ADAPTIVE QUADRATURE IMPLICIT REAL*8 (A-H,O-Z) save EXTERNAL F IMAX=5 N0=100 H=(B-A)/N0 N02=N0/2 S2=0.d0 IC=1 S0=F(A)+F(B) DO 5 K=1,N02 5 S2=S2+F(A+2.d0*K*H) 7 S1=0.d0 DO 10 K=1,N02 10 S1=S1+F(A+(2.d0*K-1.d0)*H) Y=H/3.d0*(S0+4.d0*S1+2.d0*S2) IF(DABS(F0/Y-1.d0).GT.ACC) GOTO 20 RETURN 20 N02=N0 N0=2*N0 S2=S1+S2 H=H/2.d0 IF(IC.GT.IMAX) GOTO 30 F0=Y IC=IC+1 GOTO 7 30 ACC0=DABS(Y/F0-1.d0) WRITE(*,900) A,B,ACC0 STOP 900 FORMAT(1H ,'SIMPSA: TOO HIGH ACCURACY REQUIRED'/ /1X, 29HSINGULARITY IN THE INTERVAL ,D20.12,1X,D20.12/ /1X, 29HACCURACY ACHIEVED ,D20.12) END C C C ******* matrix-inversion-routines C SUBROUTINE LUDCMP(A,N,NP,INDX,D) IMPLICIT REAL*8(A-H,O-Z) PARAMETER (NMAX=100,TINY=1.0E-20) DIMENSION A(NP,NP),INDX(N),VV(NMAX) D=1. DO 12 I=1,N AAMAX=0. DO 11 J=1,N IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) 11 CONTINUE ! IF (AAMAX.EQ.0.) PAUSE 'Singular matrix.' IF (AAMAX.EQ.0.) print *, 'Singular matrix.' VV(I)=1./AAMAX 12 CONTINUE DO 19 J=1,N IF (J.GT.1) THEN DO 14 I=1,J-1 SUM=A(I,J) IF (I.GT.1)THEN DO 13 K=1,I-1 SUM=SUM-A(I,K)*A(K,J) 13 CONTINUE A(I,J)=SUM ENDIF 14 CONTINUE ENDIF AAMAX=0. DO 16 I=J,N SUM=A(I,J) IF (J.GT.1)THEN DO 15 K=1,J-1 SUM=SUM-A(I,K)*A(K,J) 15 CONTINUE A(I,J)=SUM ENDIF DUM=VV(I)*ABS(SUM) IF (DUM.GE.AAMAX) THEN IMAX=I AAMAX=DUM ENDIF 16 CONTINUE IF (J.NE.IMAX)THEN DO 17 K=1,N DUM=A(IMAX,K) A(IMAX,K)=A(J,K) A(J,K)=DUM 17 CONTINUE D=-D VV(IMAX)=VV(J) ENDIF INDX(J)=IMAX IF(J.NE.N)THEN IF(A(J,J).EQ.0.)A(J,J)=TINY DUM=1./A(J,J) DO 18 I=J+1,N A(I,J)=A(I,J)*DUM 18 CONTINUE ENDIF 19 CONTINUE IF(A(N,N).EQ.0.)A(N,N)=TINY RETURN END c SUBROUTINE LUBKSB(A,N,NP,INDX,B) IMPLICIT REAL*8(A-H,O-Z) DIMENSION A(NP,NP),INDX(N),B(N) II=0 DO 12 I=1,N LL=INDX(I) SUM=B(LL) B(LL)=B(I) IF (II.NE.0)THEN DO 11 J=II,I-1 SUM=SUM-A(I,J)*B(J) 11 CONTINUE ELSE IF (SUM.NE.0.) THEN II=I ENDIF B(I)=SUM 12 CONTINUE DO 14 I=N,1,-1 SUM=B(I) IF(I.LT.N)THEN DO 13 J=I+1,N SUM=SUM-A(I,J)*B(J) 13 CONTINUE ENDIF B(I)=SUM/A(I,I) 14 CONTINUE RETURN END C C C ******* RANDOM NUMBER GENERATORS C C FUNCTION RANF(DUMMY) C C RANDOM NUMBER FUNCTION TAKEN FROM KNUTH C (SEMINUMERICAL ALGORITHMS). C METHOD IS X(N)=MOD(X(N-55)-X(N-24),1/FMODUL) C NO PROVISION YET FOR CONTROL OVER THE SEED NUMBER. C C RANF GIVES ONE RANDOM NUMBER BETWEEN 0 AND 1. C IRN55 GENERATES 55 RANDOM NUMBERS BETWEEN 0 AND 1/FMODUL. C IN55 INITIALIZES THE 55 NUMBERS AND WARMS UP THE SEQUENCE. C PARAMETER (FMODUL=1.E-09) SAVE /CIRN55/ COMMON /CIRN55/NCALL,MCALL,IA(55) INTEGER IA CALL RANDAT IF( NCALL.EQ.0 ) THEN CALL IN55 ( IA,234612947 ) MCALL = 55 NCALL = 1 ENDIF IF ( MCALL.EQ.0 ) THEN CALL IRN55(IA) MCALL=55 ENDIF RANF=IA(MCALL)*FMODUL MCALL=MCALL-1 RETURN END C SUBROUTINE RANDAT C C INITIALISES THE NUMBER NCALL TO 0 TO FLAG THE FIRST CALL C OF THE RANDOM NUMBER GENERATOR C C SAVE /CIRN55/ C SAVE FIRST SAVE COMMON /CIRN55/NCALL,MCALL,IA(55) INTEGER IA LOGICAL FIRST DATA FIRST /.TRUE./ IF(FIRST)THEN FIRST=.FALSE. NCALL=0 ENDIF RETURN END C SUBROUTINE IN55(IA,IX) PARAMETER (MODULO=1000000000) INTEGER IA(55) C IA(55)=IX J=IX K=1 DO 10 I=1,54 II=MOD(21*I,55) IA(II)=K K=J-K IF(K.LT.0)K=K+MODULO J=IA(II) 10 CONTINUE DO 20 I=1,10 CALL IRN55(IA) 20 CONTINUE RETURN END C SUBROUTINE IRN55(IA) PARAMETER (MODULO=1000000000) INTEGER IA(55) DO 10 I=1,24 J=IA(I)-IA(I+31) IF(J.LT.0)J=J+MODULO IA(I)=J 10 CONTINUE DO 20 I=25,55 J=IA(I)-IA(I-24) IF(J.LT.0)J=J+MODULO IA(I)=J 20 CONTINUE RETURN END C C FUNCTION RAN2(IDUM) C ******************* REAL RDM(31) DATA IWARM/0/ C IF (IDUM.LT.0.OR.IWARM.EQ.0) THEN C INITIALIZATION OR REINITIALISATION IWARM=1 IA1= 1279 IC1= 351762 M1= 1664557 IA2= 2011 IC2= 221592 M2= 1048583 IA3= 15091 IC3= 6171 M3= 29201 IX1=MOD(-IDUM,M1) IX1=MOD(IA1*IX1+IC1,M1) IX2=MOD(IX1,M2) IX1=MOD(IA1*IX1+IC1,M1) IX3=MOD(IX1,M3) RM1=1./FLOAT(M1) RM2=1./FLOAT(M2) DO 10 J=1,31 IX1=MOD(IA1*IX1+IC1,M1) IX2=MOD(IA2*IX2+IC2,M2) 10 RDM(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 ENDIF C C GENERATE NEXT NUMBER IN SEQUENCE IF(IWARM.EQ.0) GOTO 901 IX1=MOD(IA1*IX1+IC1,M1) IX2=MOD(IA2*IX2+IC2,M2) IX3=MOD(IA3*IX3+IC3,M3) J=1+(31*IX3)/M3 RAN2=RDM(J) RDM(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1 RETURN 901 PRINT 9010 9010 FORMAT(' RAN2: LACK OF ITINIALISATION') STOP END C C C ******* SPECIAL FUNCTIONS C C DOUBLE PRECISION FUNCTION DILOGG(X) C C SPENCE'S DILOGARITHM IN DOUBLE PRECISION C IMPLICIT REAL*8 (A-H,O-Z) Z=-1.644934066848226 IF(X .LT.-1.0) GO TO 1 IF(X .LE. 0.5) GO TO 2 IF(X .EQ. 1.0) GO TO 3 IF(X .LE. 2.0) GO TO 4 Z=3.289868133696453 1 T=1.0/X S=-0.5 Z=Z-0.5*DLOG(DABS(X))**2 GO TO 5 2 T=X S=0.5 Z=0. GO TO 5 3 DILOGG=1.644934066848226 RETURN 4 T=1.0-X S=-0.5 Z=1.644934066848226-DLOG(X)*DLOG(DABS(T)) 5 Y=2.666666666666667*T+0.666666666666667 B= 0.00000 00000 00001 A=Y*B +0.00000 00000 00004 B=Y*A-B+0.00000 00000 00011 A=Y*B-A+0.00000 00000 00037 B=Y*A-B+0.00000 00000 00121 A=Y*B-A+0.00000 00000 00398 B=Y*A-B+0.00000 00000 01312 A=Y*B-A+0.00000 00000 04342 B=Y*A-B+0.00000 00000 14437 A=Y*B-A+0.00000 00000 48274 B=Y*A-B+0.00000 00001 62421 A=Y*B-A+0.00000 00005 50291 B=Y*A-B+0.00000 00018 79117 A=Y*B-A+0.00000 00064 74338 B=Y*A-B+0.00000 00225 36705 A=Y*B-A+0.00000 00793 87055 B=Y*A-B+0.00000 02835 75385 A=Y*B-A+0.00000 10299 04264 B=Y*A-B+0.00000 38163 29463 A=Y*B-A+0.00001 44963 00557 B=Y*A-B+0.00005 68178 22718 A=Y*B-A+0.00023 20021 96094 B=Y*A-B+0.00100 16274 96164 A=Y*B-A+0.00468 63619 59447 B=Y*A-B+0.02487 93229 24228 A=Y*B-A+0.16607 30329 27855 A=Y*A-B+1.93506 43008 69969 DILOGG=S*T*(A-B)+Z RETURN END c SUBROUTINE pzext0(iest,xest,yest,yz,dy,nv) implicit none INTEGER iest,nv,IMAX,NMAX REAL*8 xest,dy(nv),yest(nv),yz(nv) PARAMETER (IMAX=13,NMAX=50) INTEGER j,k1 REAL*8 delta,f1,f2,q,d(NMAX),qcol(NMAX,IMAX),x(IMAX) SAVE qcol,x x(iest)=xest do 11 j=1,nv dy(j)=yest(j) yz(j)=yest(j) 11 continue if(iest.eq.1) then do 12 j=1,nv qcol(j,1)=yest(j) 12 continue else do 13 j=1,nv d(j)=yest(j) 13 continue do 15 k1=1,iest-1 delta=1.d0/(x(iest-k1)-xest) f1=xest*delta f2=x(iest-k1)*delta do 14 j=1,nv q=qcol(j,k1) qcol(j,k1)=dy(j) delta=d(j)-q dy(j)=f1*delta d(j)=f2*delta yz(j)=yz(j)+dy(j) 14 continue 15 continue do 16 j=1,nv qcol(j,iest)=dy(j) 16 continue endif return END c c complex*16 function zdigamma(z) implicit none complex*16 z,psi,psipr1,psipr2 call mkpsi(z,psi,psipr1,psipr2) zdigamma=psi end c subroutine mkpsi(z,psi,psipr1,psipr2) implicit none complex*16 tmp,tmps2,tmps3,tmp0,tmp1,tmp2,ser0,ser1,ser2,ser3, . zz,z,psi,psipr1,psipr2,off0,off1,off2,zcf,ser02,ser12, . z1,z2 real*8 cof(6),re1 integer i data cof/76.18009173d0,-86.50532033d0,24.01409822d0, . -1.231739516d0,.120858003d-2,-.536382d-5/ save zz=z off0=cmplx(0.d0,0.d0,kind=kind(0d0)) off1=cmplx(0.d0,0.d0,kind=kind(0d0)) off2=cmplx(0.d0,0.d0,kind=kind(0d0)) 5 re1=real(zz) if (re1.le.0.d0) then off0=off0+1.d0/zz z1=zz*zz off1=off1-1.d0/z1 z2=z1*zz off2=off2+2.d0/z2 zz=zz+(1.d0,0.d0) goto 5 endif tmp=zz+cmplx(4.5d0,0.d0,kind=kind(0d0)) tmps2=tmp*tmp tmps3=tmp*tmps2 tmp0=(zz-cmplx(0.5d0,0.d0,kind=kind(0d0)))/tmp+log(tmp) u -cmplx(1.d0,0.d0,kind=kind(0d0)) tmp1=(5.d0,0.d0)/tmps2+1.d0/tmp tmp2=(-10.0d0,0.d0)/tmps3-1.d0/tmps2 ser0=cmplx(1.d0,0.d0,kind=kind(0d0)) ser1=cmplx(0.d0,0.d0,kind=kind(0d0)) ser2=cmplx(0.d0,0.d0,kind=kind(0d0)) ser3=cmplx(0.d0,0.d0,kind=kind(0d0)) do 10 i=1,6 zcf=cof(i)/zz ser0=ser0+zcf zcf=zcf/zz ser1=ser1+zcf zcf=zcf/zz ser2=ser2+zcf zcf=zcf/zz ser3=ser3+zcf zz=zz+(1.d0,0.d0) 10 continue ser1=-ser1 ser2=2.d0*ser2 ser3=-6.d0*ser3 ser02=ser0*ser0 ser12=ser1*ser1 psi=tmp0+ser1/ser0-off0 psipr1=tmp1+(ser2*ser0-ser12)/ser02-off1 psipr2=tmp2+(ser3*ser02-3.d0*ser2*ser1*ser0+2.d0*ser12*ser1) . /ser02/ser0-off2 return end @ <<[[toppik_axial.f]]>>= ! WHIZARD <> <> ! TOPPIK code by M. Jezabek, T. Teubner (v1.1, 1992), T. Teubner (1998) ! ! NOTE: axial part (p-wave) only ! ! FB: -commented out numerical recipes code for hypergeometric 2F1 ! included in hypgeo.f90; ! -replaced function 'cdabs' by 'abs'; ! -replaced function 'dabs' by 'abs'; ! -replaced function 'dimag' by 'aimag'; ! -replaced function 'dcmplx(,)' by 'cmplx(,,kind=kind(0d0))'; ! -replaced function 'dreal' by 'real'; ! -replaced function 'dlog' by 'log'; ! -replaced function 'dsqrt' by 'sqrt'; ! -renamed function 'a' to 'aax' ! -renamed function 'fretil1' to 'fretil1ax' ! -renamed function 'fretil2' to 'fretil2ax' ! -renamed function 'fimtil1' to 'fimtil1ax' ! -renamed function 'fimtil2' to 'fimtil2ax' ! -renamed function 'freal' to 'frealax' ! -renamed function 'fim' to 'fimax' ! -renamed subroutine 'vhat' to 'vhatax' ! -renamed subroutine 'sae' to 'saeax' ! -commented out many routines identically defined in 'toppik.f' ! -modified 'tttoppikaxial' to catch unstable runs. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c ************************************************************************ c Version tuned to provide O(1%) relative accuracy for Coulomb axial c vertex function at first and second order (search for `cctt'): c - integrals A(p), Vhat, Vhhat provided analytically w/out cut-off c - grid range fixed to 0.1 ... 10**6 absolut c - and grid size enhanced to 600 points (900 foreseen in arrays). c c This provides a compromise between stability and accuracy: c We need a relatively high momentum resolution and large maximal c momenta to achieve a ~1 percent accuracy, but the method of c direct inversion of the discretised integral equation for objects c whose integral is divergent induces instabilities at small c momenta. As the behaviour there is known, they can be cut off and c the vertex function fixed by hand; but limiting the grid c further would impact on the accuracy. c 22.3.2017, tt c ************************************************************************ c c Working version with all the different original potentials c like (p^2+q^2)/|p-q|^2, not transformed in terms of delta and 1/r^2; c accuracy eps=1.d-3 possible (only), but should be save, 13.8.'98, tt. c cleaned up a bit, 24.2.1999, tt. c c ********************************************************************* c c subroutine tttoppikaxial(xenergy,xtm,xtg,xalphas,xscale,xcutn, u xcutv, u xc0,xc1,xc2,xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2, u xkincm,xkinca,jknflg,jgcflg,xkincv,jvflg, u xim,xdi,np,xpp,xww,xdsdp,zftild) c c ********************************************************************* c c !! THIS IS NOT A PUBLIC VERSION !! c c !!! Only P wave result given as output!!! 9.4.1999, tt. c c -- Calculation of the Green function in momentum space by solving the c Lippmann-Schwinger equation c F(p) = G_0(p) + G_0(p) int_0^xcutn V(p,q) q.p/p^2 F(q) dq c c -- Written by Thomas Teubner, Hamburg, November 1998 c * Based on TOPPIK Version 1.1 c from M. Jezabek and TT, Karlsruhe, June 1992 c * Version originally for non-constant top-width c * Constant width supplied here c * No generator included c c -- Use of double precision everywhere c c -- All masses, momenta, energies, widths in GeV c c -- Input parameters: c c xenergy : E=Sqrt[s]-2*topmass c xtm : topmass (in the Pole scheme) c xtg : top-width c xalphas : alpha_s^{MSbar,n_f=5}(xscale) c xscale : soft scale mu_{soft} c xcutn : numerical UV cutoff on all momenta c (UV cutoff of the Gauss-Legendre grid) c xcutv : renormalization cutoff on the c delta-, the (p^2+q^2)/(p-q)^2-, and the c 1/r^2-[1/|p-q|]-potential: c if (max(p,q).ge.xcutv) then the three potentials c are set to zero in the Lippmann-Schwinger equation c xc0 : 0th order coefficient for the Coulomb potential, c see calling example above c xc1 : 1st order coefficient for the Coulomb potential c xc2 : 2nd order coefficient for the Coulomb potential c xcdeltc : constant of the delta(r)- c [= constant in momentum space-] potential c xcdeltl : constant for the additional log(q^2/mu^2)-part of the c delta-potential: c xcdeltc*1 + xcdeltl*log(q^2/mu^2) c xcfullc : constant of the (p^2+q^2)/(p-q)^2-potential c xcfulll : constant for the additional log(q^2/mu^2)-part of the c (p^2+q^2)/(p-q)^2-potential c xcrm2 : constant of the 1/r^2-[1/|p-q|]-potential c xkincm : } kinetic corrections in the 0th order Green function: c xkinca : } G_0(p):=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c !!! WATCH THE SIGN IN G_0 !!! c jknflg : flag for these kinetic corrections: c 0 : no kinetic corrections applied c 1 : kinetic corrections applied with cutoff xcutv c for xkinca only c 2 : kinetic corrections applied with cutoff xcutv c for xkinca AND xkincm c jgcflg : flag for G_0(p) in the LS equation: c 0 (standard choice) : G_0(p) as given above c 1 (for TIPT) : G_0(p) = G_c^{0}(p) the 0th c order Coulomb Green function c in analytical form; not for c momenta p > 1000*topmass c xkincv : additional kinematic vertexcorrection in G_0, see below: c jvflg : flag for the additional vertexcorrection xkincv in the c ``zeroth order'' G_0(p) in the LS-equation: c 0 : no correction, means G = G_0 + G_0 int V G c with G_0=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca c 1 : apply the correction in the LS equation as c G = G_0 + xkincv*p^2/m_t^2/[E+iGamma_t-p^2/m_t] + c G_0 int V G c and correct the integral over Im[G(p)] to get sigma_tot c from the optical theorem by the same factor. c The cutoff xcutv is applied for these corrections. c c -- Output: c c xim : R^{P wave}_{ttbar} from the imaginary part of the Green c function c xdi : R^{P wave}_{ttbar} from the integral over the momentum c distribution: int_0^xcutv dp p^3/m_t*|F(p,E)|^2 c np : number of points used for the grid; fixed in tttoppik c xpp : 1-dim array (max. 900 elements) giving the momenta of c the Gauss-Legendre grid (pp(i) in the code) c xww : 1-dim array (max. 900 elements) giving the corresponding c Gauss-Legendre weights for the grid c xdsdp : 1-dim array (max. 900 elements) giving the c momentum distribution of top: d\sigma^{P wave}/dp, c normalized to R, c at the momenta of the Gauss-Legendre grid xpp(i) c zftild : 1-dim array (max. 900 elements) of COMPLEX*16 numbers c giving the vertex function K_A for the P-wave c at the momenta of the grid. c Then F(p)=K_A (p)*G_0(p) corresponding to G=K_V*G_0. c c ********************************************************************* c c implicit none real*8 u pi,energy,vzero,eps, u pp, u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI,hmass, u xx,critp,consde, u w1,w2,sig1,sig2,const, u gtpcor,etot, u xenergy,xtm,xtg,xalphas,xscale,xc0,xc1,xc2,xim,xdi, u xaai,xaad,xdsdp,xpp,xww, u cplas,scale,c0,c1,c2,cdeltc,cdeltl,cfullc,cfulll,crm2, u chiggs,xcutn,dcut,xcutv, u xp,xpmax, u kincom,kincoa,kincov,xkincm,xkinca,xkincv, u xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2 complex*16 bb,vec,gg,a1,aax,g0,g0c,zvfct,zftild integer i,n,nmax,npot,np,gcflg,kinflg,jknflg,jgcflg, u jvflg,vflag parameter (nmax=900) dimension pp(nmax),bb(nmax),vec(nmax),xx(nmax),gg(nmax), u w1(nmax),w2(nmax),a1(nmax), u xdsdp(nmax),xpp(nmax),xww(nmax), u zvfct(nmax),zftild(nmax) c external aax,gtpcor,g0,g0c c common/ovalco/ pi, energy, vzero, eps, npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c pi=3.141592653589793238d0 c c Number of points to evaluate on the integral equation c (<=900 and n mod 3 = 0 !!): n=600 np=n c c For second order potential with free parameters: c npot=5 c Internal accuracy for TOPPIK, the reachable limit may be smaller, c depending on the parameters. But increase in real accuracy only c in combination with large number of points. eps=1.d-3 c Some physical parameters: wgamma=2.07d0 zmass=91.187d0 wmass=80.33d0 bmass=4.7d0 c c Input: tmass=xtm energy=xenergy tgamma=xtg cplas=xalphas scale=xscale c0=xc0 c1=xc1 c2=xc2 cdeltc=xcdeltc cdeltl=xcdeltl cfullc=xcfullc cfulll=xcfulll crm2=xcrm2 kincom=xkincm kincoa=xkinca kincov=xkincv kinflg=jknflg gcflg=jgcflg vflag=jvflg c alphas=xalphas c c Cut for divergent potential-terms for large momenta in the function vhatax c and in the integrals aax(p): dcut=xcutv c c Numerical Cutoff of all momenta (maximal momenta of the grid): xpmax=xcutn if (dcut.gt.xpmax) then write(*,*) ' dcut > xpmax makes no sense! Stop.' stop endif c c Not needed for the fixed order potentials: alamb5=0.2d0 c c WRITE(*,*) 'INPUT TGAMMA=',TGAMMA c Needed in subroutine GAMMAT: GFERMI=1.16637d-5 c CALL GAMMAT c WRITE(*,*) 'CALCULATED TGAMMA=',TGAMMA c etot=2.d0*tmass+energy c if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or. u (npot.eq.5)) then c For pure coulomb and fixed order potentials there is no delta-part: consde = 0.d0 else if (npot.eq.2) then c Initialize QCD-potential common-blocks and calculate constant multiplying c the delta-part of the 'qcutted' potential in momentum-space: c call iniphc(1) c call vqdelt(consde) write(*,*) ' Not supplied with this version. Stop.' stop else write (*,*) ' Potential not implemented! Stop. 1' stop endif c Delta-part of potential is absorbed by subtracting vzero from the c original energy (shift from the potential to the free Hamiltonian): vzero = consde / (2.d0*pi)**3 c write (*,*) 'vzero=', vzero c c Find x-values pp(i) and weigths w1(i) for the gaussian quadrature; c care about large number of points in the important intervals: c if (energy-vzero.le.0.d0) then cc call gauleg(0.d0, 1.d0, pp, w1, n/3) cc call gauleg(1.d0, 5.d0, pp(n/3+1), w1(n/3+1), n/3) cc call gauleg(0.d0, 0.2d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c call gauleg(0.d0, 5.d0, pp, w1, n/3) c call gauleg(5.d0, 20.d0, pp(n/3+1), w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Avoid numerical singular points in the inner of the intervals: c critp = sqrt((energy-vzero)*tmass) c if (critp.le.1.d0) then cc Gauss-Legendre is symmetric => automatically principal-value prescription: c call gauleg(0.d0, 2.d0*critp, pp, w1, n/3) c call gauleg(2.d0*critp, 20.d0, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3) c else cc Better behaviour at the border of the intervals: c call gauleg(0.d0, critp, pp, w1, n/3) c call gauleg(critp, 2.d0*critp, pp(n/3+1), c u w1(n/3+1), n/3) c call gauleg(0.d0, 1.d0/(2.d0*critp), pp(2*n/3+1), c u w1(2*n/3+1), n/3) c endif c endif c c Or different (simpler) method, good for V_JKT: if (energy.le.0.d0) then critp=tmass/3.d0 else critp=max(tmass/3.d0,2.d0*sqrt(energy*tmass)) endif c call gauleg(0.d0, critp, pp, w1, 2*n/3) c call gauleg(1.d0/xpmax, 1.d0/critp, pp(2*n/3+1), c u w1(2*n/3+1), n/3) cctt Tuned March 2017 for best possible numerical behaviour of P-wave call gauleg(0.1d0, 2.d0, pp, w1, 10) call gauleg(2.d0, critp, pp(11), w1(11), 2*n/3-10) call gauleg(1.d-6, 1.d0/critp, pp(2*n/3+1), u w1(2*n/3+1), n/3) c c Do substitution p => 1/p for the last interval explicitly: do 10 i=2*n/3+1,n pp(i) = 1.d0/pp(i) 10 continue c c Reorder the arrays for the third interval: do 20 i=1,n/3 xx(i) = pp(2*n/3+i) w2(i) = w1(2*n/3+i) 20 continue do 30 i=1,n/3 pp(n-i+1) = xx(i) w1(n-i+1) = w2(i) 30 continue c c Calculate the integrals aax(p) for the given momenta pp(i) c and store weights and momenta for the output arrays: do 40 i=1,n a1(i) = aax(pp(i)) !!! FB: can get stuck in original Toppik! !!! FB: abuse 'np' as a flag to communicate unstable runs if ( abs(a1(i)) .gt. 1d10 ) then np = -1 return endif xpp(i)=pp(i) xww(i)=w1(i) 40 continue do 41 i=n+1,nmax xpp(i)=0.d0 xww(i)=0.d0 41 continue c c Solve the integral-equation by solving a system of algebraic equations: call saeax(pp, w1, bb, vec, a1, n) c c (The substitution for the integration to infinity pp => 1/pp c is done already.) do 50 i=1,n zvfct(i)=bb(i) zftild(i)=vec(i) gg(i) = bb(i)*g0c(pp(i)) cc gg(i) = (1.d0 + bb(i))*g0c(pp(i)) cc Urspruenglich anderes (Minus) VZ hier, dafuer kein Minus mehr bei der cc Definition des WQs ueber Im G, 2.6.1998, tt. cc gg(i) = - (1.d0 + bb(i))*g0c(pp(i)) 50 continue c c Normalisation on R: const = 8.d0*pi/tmass**2 c c Proove of the optical theorem for the output values of saeax: c Simply check if sig1 = sig2. sig1 = 0.d0 sig2 = 0.d0 xaai = 0.d0 xaad = 0.d0 do 60 i=1,n*2/3 c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/sqrt(tmass**2+pp(i)**2) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u *(1.d0-pp(i)**2/2.d0/tmass**2) c u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u /(2.d0*pi**2)*const endif xdsdp(i)=pp(i)**4/tmass**2*abs(zftild(i)*g0c(pp(i)))**2 u *tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const xaai=xaai+w1(i)*pp(i)**4/tmass**2* u aimag(zftild(i)*g0c(pp(i))) xaad=xaad+w1(i)*pp(i)**4/tmass**2* u abs(zftild(i)*g0c(pp(i)))**2 * u tgamma*gtpcor(pp(i),etot) c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) c write(*,*) 'zftild = ',zftild(i) 60 continue c '*p**2' because of substitution p => 1/p in the integration of p**2*G(p) c to infinity do 70 i=n*2/3+1,n c write(*,*) 'check! p(',i,') = ',pp(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i) cc u *(1.d0+kincov*(pp(i)/tmass)**2) u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))) u ) else sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i)) endif if (pp(i).lt.dcut.and.kinflg.ne.0) then sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) u *(1.d0-pp(i)**2/2.d0/tmass**2) cc u *tmass/sqrt(tmass**2+pp(i)**2) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u *(1.d0-pp(i)**2/2.d0/tmass**2) c u /(2.d0*pi**2)*const else sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 * u tgamma*gtpcor(pp(i),etot) c xdsdp(i)=pp(i)**2*abs(gg(i))**2 * c u tgamma*gtpcor(pp(i),etot) c u /(2.d0*pi**2)*const endif xdsdp(i)=pp(i)**4/tmass**2*abs(zftild(i)*g0c(pp(i)))**2 u *tgamma*gtpcor(pp(i),etot) u /(2.d0*pi**2)*const xaai=xaai+w1(i)*pp(i)**6/tmass**2* u aimag(zftild(i)*g0c(pp(i))) xaad=xaad+w1(i)*pp(i)**6/tmass**2* u abs(zftild(i)*g0c(pp(i)))**2 * u tgamma*gtpcor(pp(i),etot) c write(*,*) 'xdsdp = ',xdsdp(i) c write(*,*) 'zvfct = ',zvfct(i) c write(*,*) 'zftild = ',zftild(i) 70 continue do 71 i=n+1,nmax xdsdp(i)=0.d0 zvfct(i)=(0.d0,0.d0) zftild(i)=(0.d0,0.d0) 71 continue c c Normalisation on R: sig1 = sig1 / (2.d0*pi**2) * const sig2 = sig2 / (2.d0*pi**2) * const c c The results from the momentum space approach finally are: cc Jetzt Minus hier, 2.6.98, tt. c xim=-sig1 c xdi=sig2 xaai=-xaai / (2.d0*pi**2) * const xaad=xaad / (2.d0*pi**2) * const c Output of P wave part only: xim=xaai xdi=xaad c write(*,*) 'vvi = ',-sig1,' . vvd = ',sig2 c write(*,*) 'aai = ',xim,' . aad = ',xdi c end c c c c complex*16 function aax(p) c c Neue Funktion fuer die Integrale aax(p), die hier im Falle Cutoff -> infinity c fuer reine Coulombpotentiale vollstaendig analytisch loesbar sind. c 22.3.2001, tt. c implicit none complex*16 zi,zb,zlp,zlm,zalo,zanlo,zannlo,zahig,za real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI,hmass, u pi,energy,vzero,eps, u p,zeta3,cf,ca,tf,xnf,b0,b1,a1,a2,cnspot,phiint, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs integer npot parameter(zi=(0.d0,1.d0),zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0,xnf=5.d0) c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c cnspot=-4.d0/3.d0*4.d0*pi phiint=cnspot*alphas c zb=sqrt(tmass*cmplx(energy,tgamma,kind=kind(0d0))) zlp=log(zb+p) zlm=log(zb-p) c LO: no log in z-integral zalo=zi*pi/2.d0/p*(zlp-zlm) c from NL0: log in the z-integral zanlo=pi/2.d0/p*(zlp-zlm)*(pi+zi*(zlp+zlm)) c from NNLO: log**2 in the z-integral zannlo=pi/3.d0/p*(zlp-zlm) u *(3.d0*pi*(zlp+zlm)+2.d0*zi*(zlm**2+zlm*zlp+zlp**2)) c Sum of the Coulomb contributions: za=c0*zalo-c1*(zanlo-2.d0*dlog(scale)*zalo) u +c2*(zannlo-4.d0*dlog(scale)*zanlo u +4.d0*dlog(scale)**2*zalo) c (Higgs) Yukawa contribution cctt zahig=zi*pi/2.d0/p*log((zb+p+zi*hmass)/(zb-p+zi*hmass)) c Alltogether: cctt aax=-tmass/(4.d0*pi**2)*(phiint*za+chiggs*zahig) aax=-tmass/(4.d0*pi**2)*phiint*za c c write(*,*) 'aax(',p,')= ',aax end c real*8 function fretil1ax(xk) implicit none real*8 xk, frealax external frealax fretil1ax = frealax(xk) end c real*8 function fretil2ax(xk) implicit none real*8 xk, frealax external frealax fretil2ax = frealax(1.d0/xk) * xk**(-2) end c real*8 function fimtil1ax(xk) implicit none real*8 xk, fimax external fimax fimtil1ax = fimax(xk) end c real*8 function fimtil2ax(xk) implicit none real*8 xk, fimax external fimax fimtil2ax = fimax(1.d0/xk) * xk**(-2) end c real*8 function frealax(xk) implicit none complex*16 vhatax real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhatax, g0, g0c, gtpcor c frealax = real(g0c(xk)*vhatax(p, xk)) end c real*8 function fimax(xk) implicit none complex*16 vhatax real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p,pmax, xk, gtpcor,dcut,hmass complex*16 g0,g0c integer npot COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ p,pmax,dcut external vhatax, g0, g0c, gtpcor fimax = aimag(g0c(xk)*vhatax(p, xk)) end c c complex*16 function vhatax(p, xk) c implicit none complex*16 zi real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p, xk, u cnspot, phiint, AD8GLE, u pm, xkm, c u phfqcd, ALPHEF, u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2, u xkpln1st,xkpln2nd,xkpln3rd, u pp,pmax,dcut,hmass,chiggs integer npot parameter(zi=(0.d0,1.d0)) parameter(zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0, u xnf=5.d0) c external AD8GLE c u , phfqcd, ALPHEF c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/pmaxkm/ pm, xkm common/mom/ pp,pmax,dcut common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c pm=p xkm=xk cnspot=-4.d0/3.d0*4.d0*pi c if (p/xk.le.1.d-5.and.p.le.1.d-5) then xkpln1st=2.d0 xkpln2nd=-4.d0*log(scale/xk) xkpln3rd=-6.d0*log(scale/xk)**2 else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then xkpln1st=2.d0*(xk/p)**2 xkpln2nd=-4.d0*(xk/p)**2*log(scale/p) xkpln3rd=-6.d0*(xk/p)**2*log(scale/p)**2 else c xkpln1st=xk/p*log(abs((p+xk)/(p-xk))) xkpln1st=xk/p*(log(p+xk)-log(abs(p-xk))) cctt sign checked again, 2.2.2017, tt. xkpln2nd=xk/p*(-1.d0)*(log(scale/(p+xk))**2- u log(scale/abs(p-xk))**2) xkpln3rd=xk/p*(-4.d0/3.d0)*(log(scale/(p+xk))**3- u log(scale/abs(p-xk))**3) endif c c if (npot.eq.2) then c if (p/xk.le.1.d-5.and.p.le.1.d-5) then c vhatax = 2.d0 * cnspot * ALPHEF(xk) c else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then c vhatax = 2.d0 * cnspot * xk**2 / p**2 * ALPHEF(p) c else c phiint = cnspot * (AD8GLE(phfqcd, 0.d0, 0.3d0, 1.d-5) c u +AD8GLE(phfqcd, 0.3d0, 1.d0, 1.d-5)) c vhatax = xk / p * log(abs((p+xk)/(p-xk))) * phiint c endif c else if (npot.eq.1) then c0=1.d0 c1=0.d0 c2=0.d0 else if (npot.eq.3) then c0=1.d0+alphas/(4.d0*pi)*a1 c1=alphas/(4.d0*pi)*b0 c2=0 else if (npot.eq.4) then c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2 c1=alphas/(4.d0*pi)*b0+ u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1) c2=(alphas/(4.d0*pi))**2*b0**2 else if (npot.eq.5) then else write (*,*) ' Potential not implemented! Stop. 3' stop endif phiint=cnspot*alphas c c if ((xk+p).le.dcut) then c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(p+xk-abs(xk-p)) c else if (abs(xk-p).lt.dcut) then c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c u -1.d0/2.d0*(1.d0+2.d0*ca/cf) c u *(pi*cf*alphas)**2/tmass c u *xk/p*(dcut-abs(xk-p)) c else if (dcut.le.abs(xk-p)) then c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c else c write(*,*) ' Not possible! Stop.' c stop c endif c c ctt c Cut not applied here, should be left hard-wired in gauleg for stability of axial part. March 2017, tt. c if (max(xk,p).lt.dcut) then c Coulomb + first + second order corrections: vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c All other potentials: c u +cdeltc*2.d0*xk**2 c u +cdeltl*xk/p/2.d0*( c u (p+xk)**2*(log(((p+xk)/scale)**2)-1.d0)- c u (p-xk)**2*(log(((p-xk)/scale)**2)-1.d0)) c u +cfullc*(p**2+xk**2)*xkpln1st c u +cfulll*(p**2+xk**2)*xk/p/4.d0* c u (log(((p+xk)/scale)**2)**2- c u log(((p-xk)/scale)**2)**2) c u +crm2*xk/p*(p+xk-abs(xk-p)) c else c vhatax=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd) c endif c endif c end c c complex*16 function vhhat(p, xk) c implicit none complex*16 zi real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u p, xk, u cnspot, phiint, AD8GLE, u pm, xkm, u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1, u cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2, u xkpln1st,xkpln2nd, u pp,pmax,dcut,hmass,chiggs integer npot parameter(zi=(0.d0,1.d0)) parameter(zeta3=1.20205690316d0, u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0, u xnf=5.d0) c external AD8GLE c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/pmaxkm/ pm, xkm common/mom/ pp,pmax,dcut common/cplcns/cplas,scale,c0,c1,c2, u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs c b0=11.d0-2.d0/3.d0*xnf b1=102.d0-38.d0/3.d0*xnf c a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+ u 22.d0/3.d0*zeta3)*ca**2- u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf- u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+ u (20.d0/9.d0*tf*xnf)**2 c pm=p xkm=xk cnspot=-4.d0/3.d0*4.d0*pi c if (npot.eq.1) then c0=1.d0 c1=0.d0 c2=0.d0 else if (npot.eq.3) then c0=1.d0+alphas/(4.d0*pi)*a1 c1=alphas/(4.d0*pi)*b0 c2=0 else if (npot.eq.4) then write(*,*) '2nd order Coulomb in Vhhat not implemented yet.' stop c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2 c1=alphas/(4.d0*pi)*b0+ u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1) c2=(alphas/(4.d0*pi))**2*b0**2 else if (npot.eq.5) then else write (*,*) ' Potential not implemented! Stop. 4' stop endif phiint=cnspot*alphas c cctt No cut-off description used here either. c if (max(xk,p).lt.dcut) then cctt Pure Coulomb in first order and second order only: c xkpln1st=-(xk/p)**2*(1.d0+(xk**2+p**2)/(2.d0*xk*p)* u (dlog(dabs(p-xk))-dlog(p+xk))) c xkpln1st=-(xk/p)**2*(1.d0+(xk**2+p**2)/(4.d0*xk*p)* c u (dlog((p-xk)**2)-2.d0*dlog(p+xk))) c xkpln2nd=((xk/p)**2/2.d0+xk*(xk**2+p**2)/8.d0/p**3* u (dlog((p-xk)**2)-2.d0*dlog(p+xk)))* u (-2.d0+dlog((xk-p)**2/scale**2) u +dlog((xk+p)**2/scale**2)) c cctt 3rd order not yet. xkpln3rd= if (c2.ne.0.d0) then write(*,*) ' Vhhat: 2nd order not implemented yet. Stop.' stop endif c cctt vhhat=dcmplx(phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd), cctt u 0.d0) vhhat=cmplx(phiint*(c0*xkpln1st+c1*xkpln2nd), u 0.d0,kind=kind(0d0)) c else c vhhat=(0.d0,0.d0) c endif c end c c c c c --- Routines for solving linear equations and matrix inversion (complex) --- c subroutine saeax(pp, w1, bb, vec, a1, n) c implicit none complex*16 vhatax,vhhat real*8 u tmass,tgamma,zmass,alphas,alamb5, u wmass,wgamma,bmass,GFERMI, u pi, energy, vzero, eps, u d, d1, pp, w1, gtpcor,hmass, u xp,xpmax,dcut,kincom,kincoa,kincov complex*16 aax, a1, bb, vec, ff, kk, cw, svw, g0, g0c integer i, j, npot, n, nmax, indx,kinflg,gcflg,vflag parameter (nmax=900) dimension bb(nmax),vec(nmax),ff(nmax,nmax),kk(nmax,nmax), u pp(nmax),w1(nmax),indx(nmax),cw(nmax),a1(nmax) c COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5, $ WMASS,WGAMMA,BMASS,GFERMI,hmass common/ovalco/ pi, energy, vzero, eps, npot common/mom/ xp,xpmax,dcut common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag c external aax, vhatax, gtpcor, g0, g0c, vhhat c do 10 i=1,n*2/3 cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy), c u kind=kind(0d0))-pp(i)**2/tmass)) 10 continue do 20 i=n*2/3+1,n cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) * pp(i)**2 c cw(i) = w1(i) / (4.d0*pi**2 * c u (cmplx(energy-vzero, tgamma* c u gtpcor(pp(i),2.d0*tmass+energy),kind=kind(0d0)) / c u pp(i)**2 - 1.d0/tmass)) 20 continue c do 30 i=1,n cc bb(i) = a1(i) cvv if (pp(i).lt.dcut.and.vflag.eq.1) then c bb(i) = cmplx(1.d0+kincov*(pp(i)/tmass)**2,0.d0, c u kind=kind(0d0)) bb(i)=1.d0+kincov* u g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i)) else bb(i) = (1.d0,0.d0) endif c c Without extra kinematic corrections: vec(i)=(1.d0,0.d0) c svw = (0.d0,0.d0) do 40 j=1,n if (i.ne.j) then ff(i,j) = - vhatax(pp(i),pp(j)) * cw(j) kk(i,j) = - vhhat(pp(i),pp(j)) * cw(j) svw = svw + ff(i,j) endif 40 continue ff(i,i) = 1.d0 - a1(i) - svw kk(i,i) = ff(i,i) 30 continue c call zldcmp(ff, n, nmax, indx, d) call zldcmp(kk, n, nmax, indx, d1) call zlbksb(ff, n, nmax, indx, bb) call zlbksb(kk, n, nmax, indx, vec) c end c c @ +\clearpage +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Top threshold form factor code} + +This module contains the infrastructure for the resummed form factors +for the top threshold simulation as well as the calculation of the top +mass and width etc. <<[[ttv_formfactors.f90]]>>= <> module ttv_formfactors + use, intrinsic :: iso_fortran_env !NODEP! + use kinds +<> <> use constants - use numeric_utils - use physics_defs, only: CF, CA, TR use sm_physics use lorentz use interpolation use nr_tools - use io_units, only: free_unit, given_output_unit - use string_utils - use iso_varying_string, string_t => varying_string - use system_dependencies - use, intrinsic :: iso_fortran_env !NODEP! use diagnostics + <> save -<> +<> + +<> + +<> + +<> -<> + interface +<> + end interface + +end module ttv_formfactors +@ %def ttv_formfactors +@ +<<[[ttv_formfactors_sub.f90]]>>= +<> + +submodule (ttv_formfactors) ttv_formfactors_s + + use numeric_utils + use string_utils + use physics_defs, only: CF, CA, TR + use io_units + use system_dependencies -<> + implicit none -<> +<> -<> +<> contains -<> +<> -end module ttv_formfactors -@ %def ttv_formfactors +end submodule ttv_formfactors_s + +@ %def ttv_formfactors_s @ -<>= +<>= public :: onshell_projection_t -<>= +<>= type :: onshell_projection_t logical :: production logical :: decay logical :: width logical :: boost_decay contains - <> + <> end type onshell_projection_t @ %def onshell_projection_t @ -<>= +<>= procedure :: debug_write => onshell_projection_debug_write -<>= - subroutine onshell_projection_debug_write (onshell_projection) +<>= + module subroutine onshell_projection_debug_write (onshell_projection) + class(onshell_projection_t), intent(in) :: onshell_projection + end subroutine onshell_projection_debug_write +<>= + module subroutine onshell_projection_debug_write (onshell_projection) class(onshell_projection_t), intent(in) :: onshell_projection if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%production", & onshell_projection%production) if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%decay", & onshell_projection%decay) if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%width", & onshell_projection%width) if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%boost_decay", & onshell_projection%boost_decay) end subroutine onshell_projection_debug_write @ %def onshell_projection_debug_write @ -<>= +<>= procedure :: set_all => onshell_projection_set_all -<>= - pure subroutine onshell_projection_set_all (onshell_projection, flag) +<>= + pure module subroutine onshell_projection_set_all (onshell_projection, flag) + class(onshell_projection_t), intent(inout) :: onshell_projection + logical, intent(in) :: flag + end subroutine onshell_projection_set_all +<>= + pure module subroutine onshell_projection_set_all (onshell_projection, flag) class(onshell_projection_t), intent(inout) :: onshell_projection logical, intent(in) :: flag onshell_projection%production = flag onshell_projection%decay = flag end subroutine onshell_projection_set_all @ %def onshell_projection_set_all @ -<>= +<>= procedure :: active => onshell_projection_active -<>= - pure function onshell_projection_active (onshell_projection) result (active) +<>= + pure module function onshell_projection_active (onshell_projection) result (active) + logical :: active + class(onshell_projection_t), intent(in) :: onshell_projection + end function onshell_projection_active +<>= + pure module function onshell_projection_active (onshell_projection) result (active) logical :: active class(onshell_projection_t), intent(in) :: onshell_projection active = onshell_projection%production .or. & onshell_projection%decay end function onshell_projection_active @ %def onshell_projection_active @ -<>= +<>= type :: helicity_approximation_t logical :: simple = .false. logical :: extra = .false. logical :: ultra = .false. contains - <> + <> end type helicity_approximation_t @ %def helicity_approximation_t @ -<>= +<>= public :: settings_t -<>= +<>= type :: settings_t ! look what is set by initialized_parameters, bundle them in a class and rename to initialized logical :: initialized_parameters ! this belongs to init_threshold_phase_space_grid in phase_space_grid_t logical :: initialized_ps ! this belongs to the ff_grid_t, its usefulness is doubtful logical :: initialized_ff logical :: mpole_dynamic integer :: offshell_strategy logical :: factorized_computation logical :: interference logical :: only_interference_term logical :: nlo logical :: no_nlo_width_in_signal_propagators logical :: force_minus_one logical :: flip_relative_sign integer :: sel_hel_top = 0 integer :: sel_hel_topbar = 0 logical :: Z_disabled type(onshell_projection_t) :: onshell_projection type(helicity_approximation_t) :: helicity_approximation contains - <> + <> end type settings_t @ %def settings_t @ -<>= +<>= procedure :: setup_flags => settings_setup_flags -<>= +<>= + module subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, & + top_helicity_selection) + class(settings_t), intent(inout) :: settings + integer, intent(in) :: ff_in, offshell_strategy_in, top_helicity_selection + end subroutine settings_setup_flags +<>= ! TODO: (bcn 2016-03-21) break this up into a part regarding the ! FF grid and a part regarding the settings - subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, & + module subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, & top_helicity_selection) class(settings_t), intent(inout) :: settings integer, intent(in) :: ff_in, offshell_strategy_in, top_helicity_selection logical :: bit_top, bit_topbar !!! RESUMMED_SWITCHOFF = - 2 !!! MATCHED = -1, & SWITCHOFF_RESUMMED = ff_in < 0 TOPPIK_RESUMMED = ff_in <= 1 settings%nlo = btest(offshell_strategy_in, 0) settings%factorized_computation = btest(offshell_strategy_in, 1) settings%interference = btest(offshell_strategy_in, 2) call settings%onshell_projection%set_all(btest(offshell_strategy_in, 3)) settings%no_nlo_width_in_signal_propagators = btest(offshell_strategy_in, 4) settings%helicity_approximation%simple = btest(offshell_strategy_in, 5) if (.not. settings%onshell_projection%active ()) then settings%onshell_projection%production = btest(offshell_strategy_in, 6) settings%onshell_projection%decay = btest(offshell_strategy_in, 7) end if settings%onshell_projection%width = .not. btest(offshell_strategy_in, 8) settings%onshell_projection%boost_decay = btest(offshell_strategy_in, 9) settings%helicity_approximation%extra = btest(offshell_strategy_in, 10) settings%force_minus_one = btest(offshell_strategy_in, 11) settings%flip_relative_sign = btest(offshell_strategy_in, 12) if (top_helicity_selection > -1) then settings%helicity_approximation%ultra = .true. bit_top = btest (top_helicity_selection, 0) bit_topbar = btest (top_helicity_selection, 1) if (bit_top) then settings%sel_hel_top = 1 else settings%sel_hel_top = -1 end if if (bit_topbar) then settings%sel_hel_topbar = 1 else settings%sel_hel_topbar = -1 end if end if settings%only_interference_term = btest(offshell_strategy_in, 14) settings%Z_disabled = btest(offshell_strategy_in, 15) if (ff_in == MATCHED .or. ff_in == MATCHED_NOTSOHARD) then settings%onshell_projection%width = .true. settings%onshell_projection%production = .true. settings%onshell_projection%decay = .true. settings%factorized_computation = .true. settings%interference = .true. settings%onshell_projection%boost_decay = .true. end if if (debug_on) call msg_debug (D_THRESHOLD, "SWITCHOFF_RESUMMED", SWITCHOFF_RESUMMED) if (debug_on) call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED) if (debug_active (D_THRESHOLD)) & call settings%write () end subroutine settings_setup_flags @ %def settings_setup_flags @ -<>= +<>= procedure :: write => settings_write -<>= - subroutine settings_write (settings, unit) +<>= + module subroutine settings_write (settings, unit) + class(settings_t), intent(in) :: settings + integer, intent(in), optional :: unit + end subroutine settings_write +<>= + module subroutine settings_write (settings, unit) class(settings_t), intent(in) :: settings integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, '(A,L1)') "settings%helicity_approximation%simple = ", & settings%helicity_approximation%simple write (u, '(A,L1)') "settings%helicity_approximation%extra = ", & settings%helicity_approximation%extra write (u, '(A,L1)') "settings%helicity_approximation%ultra = ", & settings%helicity_approximation%ultra write (u, '(A,L1)') "settings%initialized_parameters = ", & settings%initialized_parameters write (u, '(A,L1)') "settings%initialized_ps = ", & settings%initialized_ps write (u, '(A,L1)') "settings%initialized_ff = ", & settings%initialized_ff write (u, '(A,L1)') "settings%mpole_dynamic = ", & settings%mpole_dynamic write (u, '(A,I5)') "settings%offshell_strategy = ", & settings%offshell_strategy write (u, '(A,L1)') "settings%factorized_computation = ", & settings%factorized_computation write (u, '(A,L1)') "settings%interference = ", settings%interference write (u, '(A,L1)') "settings%only_interference_term = ", & settings%only_interference_term write (u, '(A,L1)') "settings%Z_disabled = ", & settings%Z_disabled write (u, '(A,L1)') "settings%nlo = ", settings%nlo write (u, '(A,L1)') "settings%no_nlo_width_in_signal_propagators = ", & settings%no_nlo_width_in_signal_propagators write (u, '(A,L1)') "settings%force_minus_one = ", settings%force_minus_one write (u, '(A,L1)') "settings%flip_relative_sign = ", settings%flip_relative_sign call settings%onshell_projection%debug_write () end subroutine settings_write @ %def settings_write @ -<>= +<>= procedure :: use_nlo_width => settings_use_nlo_width -<>= - pure function settings_use_nlo_width (settings, ff) result (nlo) +<>= + pure module function settings_use_nlo_width (settings, ff) result (nlo) + logical :: nlo + class(settings_t), intent(in) :: settings + integer, intent(in) :: ff + end function settings_use_nlo_width +<>= + pure module function settings_use_nlo_width (settings, ff) result (nlo) logical :: nlo class(settings_t), intent(in) :: settings integer, intent(in) :: ff nlo = settings%nlo end function settings_use_nlo_width @ %def settings_use_nlo_width @ -<>= +<>= public :: formfactor_t -<>= +<>= type :: formfactor_t logical :: active contains - <> + <> end type formfactor_t @ %def formfactor_t @ -<>= +<>= procedure :: activate => formfactor_activate -<>= - pure subroutine formfactor_activate (formfactor) +<>= + pure module subroutine formfactor_activate (formfactor) + class(formfactor_t), intent(inout) :: formfactor + end subroutine formfactor_activate +<>= + pure module subroutine formfactor_activate (formfactor) class(formfactor_t), intent(inout) :: formfactor formfactor%active = .true. end subroutine formfactor_activate @ %def formfactor_activate @ -<>= +<>= procedure :: disable => formfactor_disable -<>= - pure subroutine formfactor_disable (formfactor) +<>= + pure module subroutine formfactor_disable (formfactor) + class(formfactor_t), intent(inout) :: formfactor + end subroutine formfactor_disable +<>= + pure module subroutine formfactor_disable (formfactor) class(formfactor_t), intent(inout) :: formfactor formfactor%active = .false. end subroutine formfactor_disable @ %def formfactor_disable @ This function actually returns $\tilde{F}$, i.e. $F-1$. -<>= +<>= procedure :: compute => formfactor_compute -<>= - function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF) +<>= + module function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF) + complex(default) :: FF + class(formfactor_t), intent(in) :: formfactor + type(phase_space_point_t), intent(in) :: ps + integer, intent(in) :: vec_type, FF_mode + end function formfactor_compute +<>= + module function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF) complex(default) :: FF class(formfactor_t), intent(in) :: formfactor type(phase_space_point_t), intent(in) :: ps integer, intent(in) :: vec_type, FF_mode real(default) :: f if (threshold%settings%initialized_parameters .and. formfactor%active) then select case (FF_mode) case (MATCHED, MATCHED_NOTSOHARD, RESUMMED, RESUMMED_SWITCHOFF) FF = resummed_formfactor (ps, vec_type) - one case (MATCHED_EXPANDED) f = f_switch_off (v_matching (ps%sqrts, GAM_M1S)) FF = - expanded_formfactor (f * AS_HARD, f * AS_HARD, ps, vec_type) & + resummed_formfactor (ps, vec_type) case (MATCHED_EXPANDED_NOTSOHARD) f = f_switch_off (v_matching (ps%sqrts, GAM_M1S)) FF = - expanded_formfactor (f * alphas_notsohard (ps%sqrts), f * & alphas_notsohard (ps%sqrts), ps, vec_type) & + resummed_formfactor (ps, vec_type) case (EXPANDED_HARD) FF = expanded_formfactor (AS_HARD, AS_HARD, ps, vec_type) - one case (EXPANDED_NOTSOHARD) FF = expanded_formfactor (alphas_notsohard (ps%sqrts), & alphas_notsohard (ps%sqrts), ps, vec_type) - one case (EXPANDED_SOFT) FF = expanded_formfactor (AS_HARD, alphas_soft (ps%sqrts), ps, & vec_type) - one case (EXPANDED_SOFT_SWITCHOFF) f = f_switch_off (v_matching (ps%sqrts, GAM_M1S)) FF = expanded_formfactor (f * AS_HARD, & f * alphas_soft (ps%sqrts), ps, vec_type) - one case (RESUMMED_ANALYTIC_LL) FF = formfactor_LL_analytic (alphas_soft (ps%sqrts), ps%sqrts, & ps%p, vec_type) - one case (TREE) FF = zero case default FF = zero end select else FF = zero end if if (debug2_active (D_THRESHOLD)) then call update_global_sqrts_dependent_variables (ps%sqrts) - call msg_debug2 (D_THRESHOLD, "threshold%settings%initialized_parameters", threshold%settings%initialized_parameters) + call msg_debug2 (D_THRESHOLD, "threshold%settings%initialized_parameters", & + threshold%settings%initialized_parameters) call msg_debug2 (D_THRESHOLD, "formfactor%active", formfactor%active) call msg_debug2 (D_THRESHOLD, "FF_mode", FF_mode) call msg_debug2 (D_THRESHOLD, "FF", FF) call msg_debug2 (D_THRESHOLD, "v", sqrts_to_v (ps%sqrts, GAM)) call msg_debug2 (D_THRESHOLD, "vec_type", vec_type) call ps%write () end if end function formfactor_compute @ %def formfactor_compute @ -<>= +<>= public :: width_t -<>= +<>= type :: width_t real(default) :: aem real(default) :: sw real(default) :: mw real(default) :: mb real(default) :: vtb real(default) :: gam_inv contains - <> + <> end type width_t @ %def width_t @ -<>= +<>= procedure :: init => width_init -<>= - pure subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv) +<>= + pure module subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv) + class(width_t), intent(inout) :: width + real(default), intent(in) :: aemi, sw, mw, mb, vtb, gam_inv + end subroutine width_init +<>= + pure module subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv) class(width_t), intent(inout) :: width real(default), intent(in) :: aemi, sw, mw, mb, vtb, gam_inv width%aem = one / aemi width%sw = sw width%mw = mw width%mb = mb width%vtb = vtb width%gam_inv = gam_inv end subroutine width_init @ %def width_init @ -<>= +<>= procedure :: compute => width_compute -<>= - pure function width_compute (width, top_mass, sqrts, initial) result (gamma) +<>= + pure module function width_compute (width, top_mass, sqrts, initial) result (gamma) + real(default) :: gamma + class(width_t), intent(in) :: width + real(default), intent(in) :: top_mass, sqrts + logical, intent(in), optional :: initial + end function width_compute +<>= + pure module function width_compute (width, top_mass, sqrts, initial) result (gamma) real(default) :: gamma class(width_t), intent(in) :: width real(default), intent(in) :: top_mass, sqrts logical, intent(in), optional :: initial real(default) :: alphas logical :: ini ini = .false.; if (present (initial)) ini = initial if (ini) then alphas = AS_HARD else alphas = alphas_notsohard (sqrts) end if if (threshold%settings%nlo) then gamma = top_width_sm_qcd_nlo_jk (width%aem, width%sw, width%vtb, & top_mass, width%mw, width%mb, alphas) + width%gam_inv else gamma = top_width_sm_lo (width%aem, width%sw, width%vtb, top_mass, & width%mw, width%mb) + width%gam_inv end if end function width_compute @ %def width_compute @ Use singleton pattern instead of global variables. At least shows where the variables are from. -<>= +<>= public :: threshold -<>= - type(threshold_t) :: threshold -<>= +<>= public :: threshold_t -<>= +<>= + type(threshold_t) :: threshold +<>= type :: threshold_t type(settings_t) :: settings type(formfactor_t) :: formfactor type(width_t) :: width contains - <> + <> end type threshold_t @ %def threshold_t @ -<>= +<>= + integer, parameter, public :: & + MATCHED_EXPANDED_NOTSOHARD = -5, & + MATCHED_NOTSOHARD = -4, & + MATCHED_EXPANDED = - 3, & + RESUMMED_SWITCHOFF = - 2, & + MATCHED = -1, & + RESUMMED = 1, & + EXPANDED_HARD = 4, & + EXPANDED_SOFT = 5, & + EXPANDED_SOFT_SWITCHOFF = 6, & + RESUMMED_ANALYTIC_LL = 7, & + EXPANDED_NOTSOHARD = 8, & + TREE = 9 +<>= integer, parameter :: VECTOR = 1 integer, parameter :: AXIAL = 2 - integer, parameter, public :: MATCHED_EXPANDED_NOTSOHARD = -5, & - MATCHED_NOTSOHARD = -4, & - MATCHED_EXPANDED = - 3, & - RESUMMED_SWITCHOFF = - 2, & - MATCHED = -1, & - RESUMMED = 1, & - EXPANDED_HARD = 4, & - EXPANDED_SOFT = 5, & - EXPANDED_SOFT_SWITCHOFF = 6, & - RESUMMED_ANALYTIC_LL = 7, & - EXPANDED_NOTSOHARD = 8, & - TREE = 9 real(default), parameter :: NF = 5.0_default real(default), parameter :: z3 = 1.20205690315959428539973816151_default real(default), parameter :: A1 = 31./9.*CA - 20./9.*TR*NF real(default), parameter :: A2 = (4343./162. + 4.*pi**2 - pi**4/4. + & 22./3.*z3)*CA**2 - (1798./81. + 56./3.*z3)*CA*TR*NF - & (55./3. - 16.*z3)*CF*TR*NF + (20./9.*TR*NF)**2 complex(default), parameter :: ieps = imago*tiny_10 @ [[gam_m1s]] is only used for the scale nustar -<>= +<>= public :: GAM, GAM_M1S -<>= +<>= real(default) :: M1S, GAM, GAM_M1S integer :: NRQCD_ORDER real(default) :: MTPOLE = - one real(default) :: mtpole_init real(default) :: RESCALE_H, MU_HARD, AS_HARD real(default) :: AS_MZ, MASS_Z real(default) :: MU_USOFT, AS_USOFT @ [[NUSTAR_FIXED]] is normally not used -<>= +<>= public :: AS_SOFT public :: AS_LL_SOFT public :: AS_USOFT public :: AS_HARD public :: SWITCHOFF_RESUMMED public :: TOPPIK_RESUMMED -<>= +<>= real(default) :: RESCALE_F, MU_SOFT, AS_SOFT, AS_LL_SOFT, NUSTAR_FIXED logical :: NUSTAR_DYNAMIC, SWITCHOFF_RESUMMED, TOPPIK_RESUMMED real(default) :: B0 real(default) :: B1 real(default), dimension(2) :: aa2, aa3, aa4, aa5, aa8, aa0 character(len=200) :: parameters_ref type(nr_spline_t) :: ff_p_spline real(default) :: v1, v2 integer :: POINTS_SQ, POINTS_P, POINTS_P0, n_q real(default), dimension(:), allocatable :: sq_grid, p_grid, p0_grid, q_grid complex(default), dimension(:,:,:,:), allocatable :: ff_grid complex(single), dimension(:,:,:,:,:), allocatable :: Vmatrix @ Explicit range and step size of the sqrts-grid relative to 2*M1S: -<>= +<>= real(default) :: sqrts_min, sqrts_max, sqrts_it @ -<>= +<>= interface char module procedure int_to_char, real_to_char, complex_to_char, logical_to_char end interface char -<>= +<>= public :: m1s_to_mpole @ -<>= - type, public :: phase_space_point_t +<>= + public :: phase_space_point_t +<>= + type :: phase_space_point_t real(default) :: p2 = 0, k2 = 0, q2 = 0 real(default) :: sqrts = 0, p = 0, p0 = 0 real(default) :: mpole = 0, en = 0 logical :: inside_grid = .false., onshell = .false. contains - <> + <> end type phase_space_point_t +@ %def phase_space_point_t @ -<>= +<>= procedure :: init => phase_space_point_init_rel -<>= - pure subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m) +<>= + pure module subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m) + class(phase_space_point_t), intent(inout) :: ps_point + real(default), intent(in) :: p2 + real(default), intent(in) :: k2 + real(default), intent(in) :: q2 + real(default), intent(in), optional :: m + end subroutine phase_space_point_init_rel +<>= + pure module subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m) class(phase_space_point_t), intent(inout) :: ps_point real(default), intent(in) :: p2 real(default), intent(in) :: k2 real(default), intent(in) :: q2 real(default), intent(in), optional :: m ps_point%p2 = p2 ps_point%k2 = k2 ps_point%q2 = q2 call rel_to_nonrel (p2, k2, q2, ps_point%sqrts, ps_point%p, ps_point%p0) ps_point%mpole = m1s_to_mpole (ps_point%sqrts) ps_point%en = sqrts_to_en (ps_point%sqrts) ps_point%inside_grid = sqrts_within_range (ps_point%sqrts) if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m) end subroutine phase_space_point_init_rel +@ %def phase_space_point_init_rel @ -<>= +<>= procedure :: init_nonrel => phase_space_point_init_nonrel -<>= - pure subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m) +<>= + pure module subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m) + class(phase_space_point_t), intent(inout) :: ps_point + real(default), intent(in) :: sqrts + real(default), intent(in) :: p + real(default), intent(in) :: p0 + real(default), intent(in), optional :: m + end subroutine phase_space_point_init_nonrel +<>= + pure module subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m) class(phase_space_point_t), intent(inout) :: ps_point real(default), intent(in) :: sqrts real(default), intent(in) :: p real(default), intent(in) :: p0 real(default), intent(in), optional :: m ps_point%sqrts = sqrts ps_point%p = p ps_point%p0 = p0 call nonrel_to_rel (sqrts, p, p0, ps_point%p2, ps_point%k2, ps_point%q2) ps_point%mpole = m1s_to_mpole (sqrts) ps_point%en = sqrts_to_en (sqrts, ps_point%mpole) ps_point%inside_grid = sqrts_within_range (sqrts) if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m) end subroutine phase_space_point_init_nonrel +@ %def phase_space_point_init_nonrel @ -<>= +<>= !!! convert squared 4-momenta into sqrts, p0 = E_top-sqrts/2 and abs. 3-momentum p pure subroutine rel_to_nonrel (p2, k2, q2, sqrts, p, p0) real(default), intent(in) :: p2 real(default), intent(in) :: k2 real(default), intent(in) :: q2 real(default), intent(out) :: sqrts real(default), intent(out) :: p real(default), intent(out) :: p0 sqrts = sqrt(q2) p0 = abs(p2 - k2) / (2. * sqrts) p = sqrt (0.5_default * (- p2 - k2 + sqrts**2/2. + 2.* p0**2)) end subroutine rel_to_nonrel +@ %def rel_to_nonrel @ -<>= +<>= !!! convert sqrts, p0 = E_top-sqrts/2 and abs. 3-momentum p into squared 4-momenta pure subroutine nonrel_to_rel (sqrts, p, p0, p2, k2, q2) real(default), intent(in) :: sqrts real(default), intent(in) :: p real(default), intent(in) :: p0 real(default), intent(out) :: p2 real(default), intent(out) :: k2 real(default), intent(out) :: q2 p2 = (sqrts/2.+p0)**2 - p**2 k2 = (sqrts/2.-p0)**2 - p**2 q2 = sqrts**2 end subroutine nonrel_to_rel +@ %def nonrel_to_rel @ -<>= +<>= pure function complex_m2 (m, w) result (m2c) real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: m2c m2c = m**2 - imago*m*w end function complex_m2 +@ %def complex_m2 @ -<>= +<>= procedure :: is_onshell => phase_space_point_is_onshell -<>= - pure function phase_space_point_is_onshell (ps_point, m) result (flag) +<>= + pure module function phase_space_point_is_onshell (ps_point, m) result (flag) + logical :: flag + class(phase_space_point_t), intent(in) :: ps_point + real(default), intent(in) :: m + end function phase_space_point_is_onshell +<>= + pure module function phase_space_point_is_onshell (ps_point, m) result (flag) logical :: flag class(phase_space_point_t), intent(in) :: ps_point real(default), intent(in) :: m flag = nearly_equal (ps_point%p2 , m**2, rel_smallness=1E-5_default) .and. & nearly_equal (ps_point%k2 , m**2, rel_smallness=1E-5_default) end function phase_space_point_is_onshell +@ %def phase_space_point_is_onshell @ -<>= +<>= procedure :: write => phase_space_point_write -<>= - subroutine phase_space_point_write (psp, unit) +<>= + module subroutine phase_space_point_write (psp, unit) + class(phase_space_point_t), intent(in) :: psp + integer, intent(in), optional :: unit + end subroutine phase_space_point_write +<>= + module subroutine phase_space_point_write (psp, unit) class(phase_space_point_t), intent(in) :: psp integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, '(A)') char ("p2 = " // str (psp%p2)) write (u, '(A)') char ("k2 = " // str (psp%k2)) write (u, '(A)') char ("q2 = " // str (psp%q2)) write (u, '(A)') char ("sqrts = " // str (psp%sqrts)) write (u, '(A)') char ("p = " // str (psp%p)) write (u, '(A)') char ("p0 = " // str (psp%p0)) write (u, '(A)') char ("mpole = " // str (psp%mpole)) write (u, '(A)') char ("en = " // str (psp%en)) write (u, '(A)') char ("inside_grid = " // str (psp%inside_grid)) write (u, '(A)') char ("onshell = " // str (psp%onshell)) end subroutine phase_space_point_write @ %def phase_space_point_write @ -<>= +<>= function set_nrqcd_order (nrqcd_order_in) result (nrqcdorder) integer :: nrqcdorder real(default), intent(in) :: nrqcd_order_in nrqcdorder = 1 if ( int(nrqcd_order_in) > nrqcdorder ) then call msg_warning ("reset to highest available NRQCD_ORDER = " // char(nrqcdorder)) else nrqcdorder = int(nrqcd_order_in) end if end function set_nrqcd_order @ %def set_nrqcd_order @ -<>= +<>= public :: init_parameters -<>= - subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, & +<>= + module subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, & + aemi, sw, az, mz, mw, mb, h_in, f_in, nrqcd_order_in, ff_in, & + offshell_strategy_in, v1_in, v2_in, scan_sqrts_min, & + scan_sqrts_max, scan_sqrts_stepsize, mpole_fixed, top_helicity_selection) + real(default), intent(out) :: mpole_out + real(default), intent(out) :: gam_out + real(default), intent(in) :: m1s_in + real(default), intent(in) :: Vtb + real(default), intent(in) :: gam_inv + real(default), intent(in) :: aemi + real(default), intent(in) :: sw + real(default), intent(in) :: az + real(default), intent(in) :: mz + real(default), intent(in) :: mw + real(default), intent(in) :: mb + real(default), intent(in) :: h_in + real(default), intent(in) :: f_in + real(default), intent(in) :: nrqcd_order_in + real(default), intent(in) :: ff_in + real(default), intent(in) :: offshell_strategy_in + real(default), intent(in) :: v1_in + real(default), intent(in) :: v2_in + real(default), intent(in) :: scan_sqrts_min + real(default), intent(in) :: scan_sqrts_max + real(default), intent(in) :: scan_sqrts_stepsize + logical, intent(in) :: mpole_fixed + real(default), intent(in) :: top_helicity_selection + end subroutine init_parameters +<>= + module subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, & aemi, sw, az, mz, mw, mb, h_in, f_in, nrqcd_order_in, ff_in, & offshell_strategy_in, v1_in, v2_in, scan_sqrts_min, & scan_sqrts_max, scan_sqrts_stepsize, mpole_fixed, top_helicity_selection) real(default), intent(out) :: mpole_out real(default), intent(out) :: gam_out real(default), intent(in) :: m1s_in real(default), intent(in) :: Vtb real(default), intent(in) :: gam_inv real(default), intent(in) :: aemi real(default), intent(in) :: sw real(default), intent(in) :: az real(default), intent(in) :: mz real(default), intent(in) :: mw real(default), intent(in) :: mb real(default), intent(in) :: h_in real(default), intent(in) :: f_in real(default), intent(in) :: nrqcd_order_in real(default), intent(in) :: ff_in real(default), intent(in) :: offshell_strategy_in real(default), intent(in) :: v1_in real(default), intent(in) :: v2_in real(default), intent(in) :: scan_sqrts_min real(default), intent(in) :: scan_sqrts_max real(default), intent(in) :: scan_sqrts_stepsize logical, intent(in) :: mpole_fixed real(default), intent(in) :: top_helicity_selection if (debug_active (D_THRESHOLD)) call show_input() threshold%settings%initialized_parameters = .false. M1S = m1s_in threshold%settings%mpole_dynamic = .not. mpole_fixed threshold%settings%offshell_strategy = int (offshell_strategy_in) call threshold%settings%setup_flags (int(ff_in), & threshold%settings%offshell_strategy, & int (top_helicity_selection)) NRQCD_ORDER = set_nrqcd_order (nrqcd_order_in) v1 = v1_in v2 = v2_in sqrts_min = scan_sqrts_min sqrts_max = scan_sqrts_max sqrts_it = scan_sqrts_stepsize !!! global hard parameters incl. hard alphas used in all form factors RESCALE_H = h_in MU_HARD = M1S * RESCALE_H AS_MZ = az MASS_Z = mz AS_HARD = running_as (MU_HARD, az, mz, 2, NF) call threshold%width%init (aemi, sw, mw, mb, vtb, gam_inv) GAM_M1S = threshold%width%compute (M1S, zero, initial=.true.) call compute_global_auxiliary_numbers () !!! soft parameters incl. mtpole !!! (depend on sqrts: initialize with sqrts ~ 2*M1S) NUSTAR_FIXED = - one NUSTAR_DYNAMIC = NUSTAR_FIXED < zero RESCALE_F = f_in call update_global_sqrts_dependent_variables (2. * M1S) mtpole_init = MTPOLE mpole_out = mtpole_init gam_out = GAM threshold%settings%initialized_parameters = .true. contains - <> + <> end subroutine init_parameters +@ %def init_parameters @ -<>= +<>= subroutine show_input() if (debug_on) call msg_debug (D_THRESHOLD, "init_parameters") if (debug_on) call msg_debug (D_THRESHOLD, "m1s_in", m1s_in) if (debug_on) call msg_debug (D_THRESHOLD, "Vtb", Vtb) if (debug_on) call msg_debug (D_THRESHOLD, "gam_inv", gam_inv) if (debug_on) call msg_debug (D_THRESHOLD, "aemi", aemi) if (debug_on) call msg_debug (D_THRESHOLD, "sw", sw) if (debug_on) call msg_debug (D_THRESHOLD, "az", az) if (debug_on) call msg_debug (D_THRESHOLD, "mz", mz) if (debug_on) call msg_debug (D_THRESHOLD, "mw", mw) if (debug_on) call msg_debug (D_THRESHOLD, "mb", mb) if (debug_on) call msg_debug (D_THRESHOLD, "h_in", h_in) if (debug_on) call msg_debug (D_THRESHOLD, "f_in", f_in) if (debug_on) call msg_debug (D_THRESHOLD, "nrqcd_order_in", nrqcd_order_in) if (debug_on) call msg_debug (D_THRESHOLD, "ff_in", ff_in) if (debug_on) call msg_debug (D_THRESHOLD, "offshell_strategy_in", offshell_strategy_in) if (debug_on) call msg_debug (D_THRESHOLD, "top_helicity_selection", top_helicity_selection) if (debug_on) call msg_debug (D_THRESHOLD, "v1_in", v1_in) if (debug_on) call msg_debug (D_THRESHOLD, "v2_in", v2_in) if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_min", scan_sqrts_min) if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_max", scan_sqrts_max) if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_stepsize", scan_sqrts_stepsize) if (debug_on) call msg_debug (D_THRESHOLD, "AS_HARD", AS_HARD) end subroutine show_input @ -<>= +<>= subroutine compute_global_auxiliary_numbers () !!! auxiliary numbers needed later !!! current coefficients Ai(S,L,J), cf. arXiv:hep-ph/0609151, Eqs. (63)-(64) !!! 3S1 coefficients (s-wave, vector current) B0 = coeff_b0(NF) * (4.*pi) B1 = coeff_b1(NF) * (4.*pi)**2 aa2(1) = (CF*(CA*CF*(9.*CA - 100.*CF) - & B0*(26.*CA**2 + 19.*CA*CF - 32.*CF**2)))/(26.*B0**2 *CA) aa3(1) = CF**2/( B0**2 *(6.*B0 - 13.*CA)*(B0 - 2.*CA)) * & (CA**2 *(9.*CA - 100.*CF) + B0*CA*(74.*CF - CA*16.) - & 6.*B0**2 *(2.*CF - CA)) aa4(1) = (24.*CF**2 * (11.*CA - 3.*B0)*(5.*CA + 8.*CF)) / & (13.*CA*(6.*B0 - 13.*CA)**2) aa5(1) = (CF**2 * (CA*(15.-28) + B0*5.))/(6.*(B0-2.*CA)**2) aa8(1) = zero aa0(1) = -((8.*CF*(CA + CF)*(CA + 2.*CF))/(3.*B0**2)) !!! 3P1 coefficients (p-wave, axial vector current) aa2(2) = -1./3. * (CF*(CA+2.*CF)/B0 - CF**2/(4.*B0) ) aa3(2) = zero aa4(2) = zero aa5(2) = 1./3. * CF**2/(4.*(B0-2.*CA)) aa8(2) = -1./3. * CF**2/(B0-CA) aa0(2) = -1./3. * 8.*CA*CF*(CA+4.*CF)/(3.*B0**2) end subroutine compute_global_auxiliary_numbers @ %def compute_global_auxiliary_numbers @ -<>= +<>= public :: init_threshold_grids -<>= - subroutine init_threshold_grids (test) +<>= + module subroutine init_threshold_grids (test) + real(default), intent(in) :: test + end subroutine init_threshold_grids +<>= + module subroutine init_threshold_grids (test) real(default), intent(in) :: test if (debug_active (D_THRESHOLD)) then call msg_debug (D_THRESHOLD, "init_threshold_grids") call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED) end if if (test > zero) then call msg_message ("TESTING ONLY: Skip threshold initialization and use tree-level SM.") return end if - if (.not. threshold%settings%initialized_parameters) call msg_fatal ("init_threshold_grid: parameters not initialized!") + if (.not. threshold%settings%initialized_parameters) & + call msg_fatal ("init_threshold_grid: parameters not initialized!") !!! !!! !!! MAC OS X and BSD don't load the global module with parameter values stored !!! if (parameters_ref == parameters_string ()) return call dealloc_grids () if (TOPPIK_RESUMMED) call init_formfactor_grid () parameters_ref = parameters_string () end subroutine init_threshold_grids +@ %def init_threshold_grids @ -<>= +<>= !!! LL/NLL resummation of nonrelativistic Coulomb potential pure function resummed_formfactor (ps, vec_type) result (c) type(phase_space_point_t), intent(in) :: ps integer, intent(in) :: vec_type complex(default) :: c c = one if (.not. threshold%settings%initialized_ff .or. .not. ps%inside_grid) return if (POINTS_SQ > 1) then call interpolate_linear (sq_grid, p_grid, ff_grid(:,:,1,vec_type), ps%sqrts, ps%p, c) else call interpolate_linear (p_grid, ff_grid(1,:,1,vec_type), ps%p, c) end if end function resummed_formfactor @ -<>= +<>= !!! leading nonrelativistic O(alphas^1) contribution (-> expansion of resummation) function expanded_formfactor (alphas_hard, alphas_soft, ps, vec_type) result (FF) complex(default) :: FF real(default), intent(in) :: alphas_hard, alphas_soft type(phase_space_point_t), intent(in) :: ps integer, intent(in) :: vec_type real(default) :: shift_from_hard_current complex(default) :: v, contrib_from_potential FF = one if (.not. threshold%settings%initialized_parameters) return call update_global_sqrts_dependent_variables (ps%sqrts) v = sqrts_to_v (ps%sqrts, GAM) if (NRQCD_ORDER == 1) then if (vec_type == AXIAL) then shift_from_hard_current = - CF / pi else shift_from_hard_current = - two * CF / pi end if else shift_from_hard_current = zero end if if (ps%onshell) then contrib_from_potential = CF * ps%mpole * Pi / (4 * ps%p) else if (vec_type == AXIAL) then contrib_from_potential = - CF * ps%mpole / (two * ps%p) * & (imago * ps%mpole * v / ps%p + & (ps%mpole**2 * v**2 + (ps%p)**2) / (4 *Pi * (ps%p)**2) * ( & (log (- ps%mpole * v - ps%p))**2 - & (log (- ps%mpole * v + ps%p))**2 + & (log (ps%mpole * v - ps%p))**2 - & (log (ps%mpole * v + ps%p))**2 )) else contrib_from_potential = imago * CF * ps%mpole * & log ((ps%p + ps%mpole * v) / & (-ps%p + ps%mpole * v) + ieps) / (two * ps%p) end if end if FF = one + alphas_soft * contrib_from_potential + & alphas_hard * shift_from_hard_current end function expanded_formfactor @ -<>= +<>= subroutine init_formfactor_grid () type(string_t) :: ff_file if (debug_on) call msg_debug (D_THRESHOLD, "init_formfactor_grid") threshold%settings%initialized_ff = .false. ff_file = "SM_tt_threshold.grid" call msg_message () call msg_message ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%") call msg_message (" Initialize e+e- => ttbar threshold resummation:") call msg_message (" Use analytic (LL) or TOPPIK (NLL) form factors for ttA/ttZ vector") call msg_message (" and axial vector couplings (S/P-wave) in the threshold region.") call msg_message (" Cf. threshold shapes from A. Hoang et al.: [arXiv:hep-ph/0107144],") call msg_message (" [arXiv:1309.6323].") if (NRQCD_ORDER > 0) then call msg_message (" Numerical NLL solutions calculated with TOPPIK [arXiv:hep-ph/9904468]") call msg_message (" by M. Jezabek, T. Teubner.") end if call msg_message ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%") call msg_message () call read_formfactor_grid (ff_file) if (.not. threshold%settings%initialized_ff) then if (.not. threshold%settings%initialized_ps) call init_threshold_phase_space_grid () call scan_formfactor_over_phase_space_grid () call write_formfactor_grid (ff_file) end if end subroutine init_formfactor_grid @ -<>= +<>= subroutine read_formfactor_grid (ff_file) type(string_t), intent(in) :: ff_file complex(single), dimension(:,:,:,:), allocatable :: ff_grid_sp character(len(parameters_ref)) :: parameters integer :: u, st logical :: ex integer, dimension(4) :: ff_shape if (debug_on) call msg_debug (D_THRESHOLD, "read_formfactor_grid") inquire (file=char(ff_file), exist=ex) if (.not. ex) return u = free_unit () call msg_message ("Opening grid file: " // char(ff_file)) open (unit=u, status='old', file=char(ff_file), form='unformatted', iostat=st) if (st /= 0) call msg_fatal ("iostat = " // char(st)) read (u) parameters read (u) ff_shape if (ff_shape(4) /= 2) call msg_fatal ("read_formfactor_grid: i = " // char(ff_shape(4))) if (parameters /= parameters_string ()) then call msg_message ("Threshold setup has changed: recalculate threshold grid.") close (unit=u, status='delete') return end if call msg_message ("Threshold setup unchanged: reusing existing threshold grid.") POINTS_SQ = ff_shape(1) POINTS_P = ff_shape(2) if (debug_active (D_THRESHOLD)) then call msg_debug (D_THRESHOLD, "ff_shape(1) (POINTS_SQ)", ff_shape(1)) call msg_debug (D_THRESHOLD, "ff_shape(2)", ff_shape(2)) call msg_debug (D_THRESHOLD, "ff_shape(3) (POINTS_P0)", ff_shape(3)) call msg_debug (D_THRESHOLD, "ff_shape(4) (==2)", ff_shape(4)) end if allocate (sq_grid(POINTS_SQ)) read (u) sq_grid allocate (p_grid(POINTS_P)) read (u) p_grid POINTS_P0 = ff_shape(3) allocate (ff_grid_sp(POINTS_SQ,POINTS_P,POINTS_P0,2)) read (u) ff_grid_sp allocate (ff_grid(POINTS_SQ,POINTS_P,POINTS_P0,2)) ff_grid = cmplx (ff_grid_sp, kind=default) close (u, iostat=st) if (st > 0) call msg_fatal ("close " // char(ff_file) // ": iostat = " // char(st)) threshold%settings%initialized_ps = .true. threshold%settings%initialized_ff = .true. end subroutine read_formfactor_grid +@ %def read_formfactor_grid @ -<>= +<>= subroutine write_formfactor_grid (ff_file) type(string_t), intent(in) :: ff_file integer :: u, st if (.not. threshold%settings%initialized_ff) then call msg_warning ("write_formfactor_grid: no grids initialized!") return end if u = free_unit () open (unit=u, status='replace', file=char(ff_file), form='unformatted', iostat=st) if (st /= 0) call msg_fatal ("open " // char(ff_file) // ": iostat = " // char(st)) write (u) parameters_string () write (u) shape(ff_grid) write (u) sq_grid write (u) p_grid write (u) cmplx(ff_grid, kind=single) close (u, iostat=st) if (st > 0) call msg_fatal ("close " // char(ff_file) // ": iostat = " // char(st)) end subroutine write_formfactor_grid +@ %def write_formfactor_grid @ -<>= +<>= pure function parameters_string () result (str) character(len(parameters_ref)) :: str - str = char(M1S) // " " // char(GAM_M1S) // " " // char(NRQCD_ORDER) & - // " " // char(RESCALE_H) & - // " " // char(RESCALE_F) & - // " " // char(sqrts_min) & - // " " // char(sqrts_max) // " " // char(sqrts_it) + str = char(M1S) // " " // char(GAM_M1S) & + // " " // char(NRQCD_ORDER) & + // " " // char(RESCALE_H) & + // " " // char(RESCALE_F) & + // " " // char(sqrts_min) & + // " " // char(sqrts_max) & + // " " // char(sqrts_it) end function parameters_string @ -<>= +<>= subroutine update_global_sqrts_dependent_variables (sqrts) real(default), intent(in) :: sqrts real(default) :: nu_soft, f logical :: only_once_for_fixed_nu, already_done real(default), save :: last_sqrts = - one if (debug_on) call msg_debug (D_THRESHOLD, "update_global_sqrts_dependent_variables") if (debug_on) call msg_debug (D_THRESHOLD, "sqrts", sqrts) if (debug_on) call msg_debug (D_THRESHOLD, "last_sqrts", last_sqrts) already_done = threshold%settings%initialized_parameters .and. & nearly_equal (sqrts, last_sqrts, rel_smallness=1E-6_default) if (debug_on) call msg_debug (D_THRESHOLD, "already_done", already_done) only_once_for_fixed_nu = .not. NUSTAR_DYNAMIC .and. MTPOLE > zero if (debug_on) call msg_debug (D_THRESHOLD, "only_once_for_fixed_nu", only_once_for_fixed_nu) if (only_once_for_fixed_nu .or. already_done) return last_sqrts = sqrts nu_soft = RESCALE_F * nustar (sqrts) MU_SOFT = M1S * RESCALE_H * nu_soft MU_USOFT = M1S * RESCALE_H * nu_soft**2 AS_SOFT = running_as (MU_SOFT, AS_HARD, MU_HARD, NRQCD_ORDER, NF) AS_LL_SOFT = running_as (MU_SOFT, AS_HARD, MU_HARD, 0, NF) AS_USOFT = running_as (MU_USOFT, AS_HARD, MU_HARD, 0, NF) !!! LL here if (SWITCHOFF_RESUMMED) then f = f_switch_off (v_matching (sqrts, GAM_M1S)) AS_SOFT = AS_SOFT * f AS_LL_SOFT = AS_LL_SOFT * f AS_USOFT = AS_USOFT * f end if MTPOLE = m1s_to_mpole (sqrts) GAM = threshold%width%compute (MTPOLE, sqrts) if (debug_on) call msg_debug (D_THRESHOLD, "GAM", GAM) if (debug_on) call msg_debug (D_THRESHOLD, "nu_soft", nu_soft) if (debug_on) call msg_debug (D_THRESHOLD, "MTPOLE", MTPOLE) if (debug_on) call msg_debug (D_THRESHOLD, "AS_SOFT", AS_SOFT) if (debug_on) call msg_debug (D_THRESHOLD, "AS_LL_SOFT", AS_LL_SOFT) if (debug_on) call msg_debug (D_THRESHOLD, "AS_USOFT", AS_USOFT) end subroutine update_global_sqrts_dependent_variables !!! Coulomb potential coefficients needed by TOPPIK pure function xc (a_soft, i_xc) result (xci) real(default), intent(in) :: a_soft integer, intent(in) :: i_xc real(default) :: xci xci = zero select case (i_xc) case (0) xci = one if ( NRQCD_ORDER>0 ) xci = xci + a_soft/(4.*pi) * A1 if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * A2 case (1) if ( NRQCD_ORDER>0 ) xci = xci + a_soft/(4.*pi) * B0 if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * (B1 + 2*B0*A1) case (2) if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * B0**2 case default return end select end function xc @ -<>= +<>= function current_coeff (a_hard, a_soft, a_usoft, i) result (coeff) real(default), intent(in) :: a_hard, a_soft, a_usoft integer, intent(in) :: i real(default) :: coeff real(default) :: matching_c, c1 real(default) :: z, w if (debug_on) call msg_debug (D_THRESHOLD, "current_coeff") coeff = one if (NRQCD_ORDER == 0) return z = a_soft / a_hard w = a_usoft / a_soft !!! hard s/p-wave 1-loop matching coefficients, cf. arXiv:hep-ph/0604072 select case (i) case (1) matching_c = one - 2.*(CF/pi) * a_hard case (2) matching_c = one - (CF/pi) * a_hard case default call msg_fatal ("current_coeff: unknown coeff i = " // char(i)) end select !!! current coefficient c1, cf. arXiv:hep-ph/0609151, Eq. (62) c1 = exp( a_hard * pi * ( aa2(i)*(1.-z) + aa3(i)*log(z) + & aa4(i)*(1.-z**(1.-13.*CA/(6.*B0))) + aa5(i)*(1.-z**(1.-2.*CA/B0)) + & aa8(i)*(1.-z**(1.-CA/B0)) + aa0(i)*(z-1.-log(w)/w) )) coeff = matching_c * c1 end function current_coeff @ -<>= +<>= public :: v_matching -<>= - pure function v_matching (sqrts, gamma) result (v) +<>= + pure module function v_matching (sqrts, gamma) result (v) + real(default) :: v + real(default), intent(in) :: sqrts, gamma + end function v_matching +<>= + pure module function v_matching (sqrts, gamma) result (v) real(default) :: v real(default), intent(in) :: sqrts, gamma v = abs (sqrts_to_v_1S (sqrts, gamma)) end function v_matching +@ %def v_matching @ Smooth transition from [[f1]] to [[f2]] between [[v1]] and [[v2]] (simplest polynom). -<>= +<>= public :: f_switch_off -<>= - pure function f_switch_off (v) result (fval) +<>= + pure module function f_switch_off (v) result (fval) + real(default), intent(in) :: v + real(default) :: fval + end function f_switch_off +<>= + pure module function f_switch_off (v) result (fval) real(default), intent(in) :: v real(default) :: fval real(default) :: vm, f1, f2, x f1 = one f2 = zero + tiny_10 vm = (v1+v2) / 2. if ( v < v1 ) then fval = f1 else if (v < v2) then x = (v - v1) / (v2 - v1) fval = 1 - x**2 * (3 - 2 * x) else fval = f2 end if end function f_switch_off +@ %def f_switch_off @ -<>= +<>= function formfactor_LL_analytic (a_soft, sqrts, p, vec_type) result (c) real(default), intent(in) :: a_soft real(default), intent(in) :: sqrts real(default), intent(in) :: p integer, intent(in) :: vec_type complex(default) :: c real(default) :: en c = one if (.not. threshold%settings%initialized_parameters) return call update_global_sqrts_dependent_variables (sqrts) en = sqrts_to_en (sqrts, MTPOLE) select case (vec_type) case (1) c = G0p (CF*a_soft, en, p, MTPOLE, GAM) / G0p_tree (en, p, MTPOLE, GAM) case (2) c = G0p_ax (CF*a_soft, en, p, MTPOLE, GAM) / G0p_tree (en, p, MTPOLE, GAM) case default call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type)) end select end function formfactor_LL_analytic @ -<>= +<>= !!! Max's LL nonrelativistic threshold Green's function function G0p (a, en, p, m, w) result (c) real(default), intent(in) :: a real(default), intent(in) :: en real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: c complex(default) :: k, ipk, la, z1, z2 complex(default) :: one, two, cc, dd k = sqrt( -m*en -imago*m*w ) ipk = imago * p / k la = a * m / 2. / k one = cmplx (1., kind=default) two = cmplx (2., kind=default) cc = 2. - la dd = ( 1. + ipk ) / 2. z1 = nr_hypgeo (two, one, cc, dd) dd = ( 1. - ipk ) / 2. z2 = nr_hypgeo (two, one, cc, dd) c = - imago * m / (4.*p*k) / (1.-la) * ( z1 - z2 ) end function G0p @ -<>= +<>= !!! tree level version: a_soft -> 0 pure function G0p_tree (en, p, m, w) result (c) real(default), intent(in) :: en real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: c c = m / (p**2 - m*(en+imago*w)) end function G0p_tree @ -<>= +<>= !!! Peter Poier's LL nonrelativistic axial threshold Green's function function G0p_ax (a, en, p, m, w) result (c) real(default), intent(in) :: a real(default), intent(in) :: en real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w complex(default) :: c complex(default) :: k, ipk, la, z1, z2, z3, z4 complex(default) :: zero, two, three, cc, ddp, ddm k = sqrt( -m*en -imago*m*w ) ipk = imago * p / k la = a * m / 2. / k zero = cmplx (0., kind=default) two = cmplx (2., kind=default) three = cmplx (3., kind=default) cc = 1. - la ddp = ( 1. + ipk ) / 2. ddm = ( 1. - ipk ) / 2. z1 = nr_hypgeo (zero, two, cc, ddp) z2 = nr_hypgeo (zero, two, cc, ddm) cc = 2. - la z3 = nr_hypgeo (zero, three, cc, ddm) z4 = nr_hypgeo (zero, three, cc, ddp) c = m / 2. / p**3 * ( 2.*p + imago*k*(1.-la)*(z1-z2) + imago*k*(z3-z4) ) end function G0p_ax @ -<>= +<>= pure function nustar (sqrts) result (nu) real(default), intent(in) :: sqrts real(default) :: nu real(default), parameter :: nustar_offset = 0.05_default complex(default) :: arg if (NUSTAR_DYNAMIC) then !!! from [arXiv:1309.6323], Eq. (3.2) (other definitions possible) arg = ( sqrts - 2.*M1S + imago*GAM_M1S ) / M1S nu = nustar_offset + abs(sqrt(arg)) else nu = NUSTAR_FIXED end if end function nustar @ We recompute [[alpha_soft]] for form factors that do not call [[update_global_parameters]] (it is called in the scan for the (N)LL grid). -<>= +<>= pure function alphas_soft (sqrts) result (a_soft) real(default) :: a_soft real(default), intent(in) :: sqrts real(default) :: mu_soft, nusoft nusoft = RESCALE_F * nustar (sqrts) mu_soft = RESCALE_H * M1S * nusoft a_soft = running_as (mu_soft, AS_HARD, MU_HARD, NRQCD_ORDER, NF) end function alphas_soft @ -<>= +<>= public :: alphas_notsohard -<>= - pure function alphas_notsohard (sqrts) result (a_soft) +<>= + pure module function alphas_notsohard (sqrts) result (a_soft) + real(default) :: a_soft + real(default), intent(in) :: sqrts + end function alphas_notsohard +<>= + pure module function alphas_notsohard (sqrts) result (a_soft) real(default) :: a_soft real(default), intent(in) :: sqrts real(default) :: mu_notsohard ! complex(default) :: v ! v = sqrts_to_v_1S (sqrts, GAM_M1S) ! mu_notsohard = RESCALE_H * M1S * sqrt(abs(v)) mu_notsohard = RESCALE_H * M1S * sqrt(nustar (sqrts)) a_soft = running_as (mu_notsohard, AS_MZ, MASS_Z, 2, NF) end function alphas_notsohard +@ %def alphas_notsohard @ -<>= - pure function m1s_to_mpole (sqrts) result (mpole) +<>= + pure module function m1s_to_mpole (sqrts) result (mpole) + real(default), intent(in) :: sqrts + real(default) :: mpole + end function m1s_to_mpole +<>= + pure module function m1s_to_mpole (sqrts) result (mpole) real(default), intent(in) :: sqrts real(default) :: mpole mpole = mtpole_init if (threshold%settings%mpole_dynamic) then mpole = M1S * ( 1. + deltaM(sqrts) ) else mpole = M1S end if end function m1s_to_mpole +@ %def m1s_to_mpole @ -<>= +<>= !pure !function mpole_to_M1S (mpole, sqrts, nl) result (m) !real(default), intent(in) :: mpole !real(default), intent(in) :: sqrts !integer, intent(in) :: nl !real(default) :: m !m = mpole * ( 1. - deltaM(sqrts, nl) ) !end function mpole_to_M1S @ -<>= +<>= pure function deltaM (sqrts) result (del) real(default), intent(in) :: sqrts real(default) :: del real(default) :: ac ac = CF * alphas_soft (sqrts) del = ac**2 / 8. if (NRQCD_ORDER > 0) then del = del + ac**3 / (8. * pi * CF) * & (B0 * (log (RESCALE_H * RESCALE_F * nustar (sqrts) / ac) + one) + A1 / 2.) end if end function deltaM @ -<>= +<>= pure function sqrts_within_range (sqrts) result (flag) real(default), intent(in) :: sqrts logical :: flag flag = ( sqrts >= sqrts_min - tiny_07 .and. sqrts <= sqrts_max + tiny_07 ) end function @ -<>= +<>= ! The mapping is such that even for min=max, we get three points: ! min - it , min, min + it pure function sqrts_iter (i_sq) result (sqrts) integer, intent(in) :: i_sq real(default) :: sqrts if (POINTS_SQ > 1) then sqrts = sqrts_min - sqrts_it + & (sqrts_max - sqrts_min + two * sqrts_it) * & real(i_sq - 1) / real(POINTS_SQ - 1) else sqrts = sqrts_min end if end function sqrts_iter @ -<>= +<>= function scan_formfactor_over_p_LL_analytic (a_soft, sqrts, vec_type) result (ff_analytic) real(default), intent(in) :: a_soft real(default), intent(in) :: sqrts integer, intent(in) :: vec_type complex(default), dimension(POINTS_P) :: ff_analytic integer :: i_p ff_analytic = [(formfactor_LL_analytic (a_soft, sqrts, p_grid(i_p), vec_type), i_p=1, POINTS_P)] end function scan_formfactor_over_p_LL_analytic @ -<>= +<>= !!! tttoppik wrapper subroutine scan_formfactor_over_p_TOPPIK (a_soft, sqrts, vec_type, p_grid_out, mpole_in, ff_toppik) real(default), intent(in) :: a_soft real(default), intent(in) :: sqrts integer, intent(in) :: vec_type real(default), dimension(POINTS_P), intent(out), optional :: p_grid_out real(default), intent(in), optional :: mpole_in complex(default), dimension(POINTS_P), optional :: ff_toppik integer :: i_p real(default) :: mpole, alphas_hard, f real(default), dimension(POINTS_P) :: p_toppik type(nr_spline_t) :: toppik_spline real*8 :: xenergy, xtm, xtg, xalphas, xscale, xc0, xc1, xc2, xim, xdi, & xcutn, xcutv, xkincm, xkinca, xkincv, xcdeltc, & xcdeltl, xcfullc, xcfulll, xcrm2 integer, parameter :: nmax=900 real*8 :: xdsdp(nmax), xpp(nmax), xww(nmax) complex*16 :: zff(nmax) integer :: np, jknflg, jgcflg, jvflg if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_p_TOPPIK") if (POINTS_P > nmax-40) call msg_fatal ("TOPPIK: POINTS_P must be <=" // char(nmax-40)) if (debug_on) call msg_debug (D_THRESHOLD, "POINTS_P", POINTS_P) if (present (ff_toppik)) ff_toppik = zero mpole = MTPOLE; if (present (mpole_in)) mpole = mpole_in xenergy = sqrts_to_en (sqrts, MTPOLE) xtm = mpole xtg = GAM xalphas = a_soft xscale = MU_SOFT xcutn = 175.E6 xcutv = 175.E6 xc0 = xc (a_soft, 0) xc1 = xc (a_soft, 1) xc2 = xc (a_soft, 2) xcdeltc = 0. xcdeltl = 0. xcfullc = 0. xcfulll = 0. xcrm2 = 0. xkincm = 0. xkinca = 0. jknflg = 0 jgcflg = 0 xkincv = 0. jvflg = 0 select case (vec_type) case (VECTOR) if (debug_on) call msg_debug (D_THRESHOLD, "calling tttoppik") call tttoppik & (xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,xc0,xc1,xc2, & xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,xkincm,xkinca,jknflg, & jgcflg, xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zff) case (AXIAL) if (debug_on) call msg_debug (D_THRESHOLD, "calling tttoppikaxial") call tttoppikaxial & (xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,xc0,xc1,xc2, & xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,xkincm,xkinca,jknflg, & jgcflg, xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zff) !!! 1st ~10 TOPPIK p-wave entries are ff_unstable: discard them zff(1:10) = [(zff(11), i_p=1, 10)] case default call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type)) end select if (present (p_grid_out)) p_grid_out = xpp(1:POINTS_P) if (.not. present (ff_toppik)) return !!! keep track of TOPPIK instabilities and try to repair later if (np < 0) then ff_toppik(1) = 2.d30 if (debug_active (D_THRESHOLD)) then call msg_warning ("caught TOPPIK instability at sqrts = " // char(sqrts)) end if return end if p_toppik = xpp(1:POINTS_P) ff_toppik = zff(1:POINTS_P) !!! TOPPIK output p-grid scales with en above ~ 4 GeV: !!! interpolate for global sqrts/p grid if (.not. nearly_equal (p_toppik(42), p_grid(42), rel_smallness=1E-6_default)) then call toppik_spline%init (p_toppik, ff_toppik) ff_toppik(2:POINTS_P) = [(toppik_spline%interpolate (p_grid(i_p)), i_p=2, POINTS_P)] call toppik_spline%dealloc () end if !!! TOPPIK output includes tree level ~ 1, a_soft @ LL in current coefficient! if (SWITCHOFF_RESUMMED) then f = f_switch_off (v_matching (sqrts, GAM_M1S)) alphas_hard = AS_HARD * f else alphas_hard = AS_HARD end if ff_toppik = ff_toppik * current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type) if (debug_on) call msg_debug (D_THRESHOLD, & "current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type)", & current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type)) end subroutine scan_formfactor_over_p_TOPPIK @ -<>= +<>= function scan_formfactor_over_p (sqrts, vec_type) result (ff) real(default), intent(in) :: sqrts integer, intent(in) :: vec_type complex(default), dimension(POINTS_P) :: ff if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_p") select case (NRQCD_ORDER) case (0) ! ff = scan_formfactor_over_p_LL_analytic (AS_SOFT, sqrts, vec_type) call scan_formfactor_over_p_TOPPIK (AS_SOFT, sqrts, vec_type, ff_toppik=ff) case (1) call scan_formfactor_over_p_TOPPIK (AS_SOFT, sqrts, vec_type, ff_toppik=ff) case default call msg_fatal ("NRQCD_ORDER = " // char(NRQCD_ORDER)) end select end function scan_formfactor_over_p @ -<>= +<>= subroutine scan_formfactor_over_phase_space_grid () integer :: i_sq, vec_type, unstable_loop logical, dimension(:,:), allocatable :: ff_unstable real(default) :: t1, t2, t3, t_toppik, t_p0_dep if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_phase_space_grid") allocate (ff_grid(POINTS_SQ,POINTS_P,POINTS_P0,2)) allocate (ff_unstable(POINTS_SQ,2)) t_toppik = zero t_p0_dep = zero write (msg_buffer, "(3(A,F7.3,1X),A)") "Scanning from ", & sqrts_min - sqrts_it, "GeV to ", & sqrts_max + sqrts_it, "GeV in steps of ", sqrts_it, "GeV" call msg_message () ENERGY_SCAN: do i_sq = 1, POINTS_SQ if (signal_is_pending ()) return call update_global_sqrts_dependent_variables (sq_grid(i_sq)) !!! vector and axial vector do vec_type = VECTOR, AXIAL call cpu_time (t1) unstable_loop = 0 UNTIL_STABLE: do ff_grid(i_sq,:,1,vec_type) = scan_formfactor_over_p (sq_grid(i_sq), vec_type) ff_unstable(i_sq,vec_type) = abs(ff_grid(i_sq,1,1,vec_type)) > 1.d30 unstable_loop = unstable_loop + 1 if (ff_unstable(i_sq,vec_type) .and. unstable_loop < 10) then cycle else exit end if end do UNTIL_STABLE call cpu_time (t2) !!! include p0 dependence by an integration over the p0-independent FF call cpu_time (t3) t_toppik = t_toppik + t2 - t1 t_p0_dep = t_p0_dep + t3 - t2 end do call msg_show_progress (i_sq, POINTS_SQ) end do ENERGY_SCAN if (debug_active (D_THRESHOLD)) then print *, "time for TOPPIK call: ", t2 - t1, " seconds." print *, "time for p0 dependence: ", t3 - t2, " seconds." end if if (any (ff_unstable)) call handle_TOPPIK_instabilities (ff_grid, ff_unstable) if (allocated(Vmatrix)) deallocate(Vmatrix) if (allocated(q_grid)) deallocate(q_grid) threshold%settings%initialized_ff = .true. end subroutine scan_formfactor_over_phase_space_grid @ -<>= +<>= subroutine init_threshold_phase_space_grid () integer :: i_sq if (debug_on) call msg_debug (D_THRESHOLD, "init_threshold_phase_space_grid") if (sqrts_it > tiny_07) then POINTS_SQ = int ((sqrts_max - sqrts_min) / sqrts_it + tiny_07) + 3 else POINTS_SQ = 1 end if if (debug_on) call msg_debug (D_THRESHOLD, "Number of sqrts grid points: POINTS_SQ", POINTS_SQ) if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_max", sqrts_max) if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_min", sqrts_min) if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_it", sqrts_it) allocate (sq_grid(POINTS_SQ)) sq_grid = [(sqrts_iter (i_sq), i_sq=1, POINTS_SQ)] POINTS_P = 600 allocate (p_grid(POINTS_P)) p_grid = p_grid_from_TOPPIK () POINTS_P0 = 1 threshold%settings%initialized_ps = .true. end subroutine init_threshold_phase_space_grid @ -<>= +<>= subroutine init_p0_grid (p_in, n) real(default), dimension(:), allocatable, intent(in) :: p_in integer, intent(in) :: n if (debug_on) call msg_debug (D_THRESHOLD, "init_p0_grid") if (debug_on) call msg_debug (D_THRESHOLD, "n", n) if (debug_on) call msg_debug (D_THRESHOLD, "size(p_in)", size(p_in)) if (.not. allocated (p_in)) call msg_fatal ("init_p0_grid: p_in not allocated!") if (allocated (p0_grid)) deallocate (p0_grid) allocate (p0_grid(n)) p0_grid(1) = zero p0_grid(2:n) = p_in(1:n-1) end subroutine init_p0_grid @ -<>= +<>= !!! Andre's procedure to refine an existing grid pure subroutine finer_grid (gr, fgr, n_in) real(default), dimension(:), intent(in) :: gr real(default), dimension(:), allocatable, intent(inout) :: fgr integer, intent(in), optional :: n_in integer :: n, i, j real(default), dimension(:), allocatable :: igr n = 4 if ( present(n_in) ) n = n_in allocate( igr(n) ) if ( allocated(fgr) ) deallocate( fgr ) allocate( fgr(n*(size(gr)-1)+1) ) do i=1, size(gr)-1 do j=0, n-1 igr(j+1) = gr(i) + real(j)*(gr(i+1)-gr(i))/real(n) end do fgr((i-1)*n+1:i*n) = igr end do fgr(size(fgr)) = gr(size(gr)) deallocate( igr ) end subroutine finer_grid @ -<>= +<>= subroutine dealloc_grids () if ( allocated(sq_grid) ) deallocate( sq_grid ) if ( allocated( p_grid) ) deallocate( p_grid ) if ( allocated(p0_grid) ) deallocate( p0_grid ) if ( allocated(ff_grid) ) deallocate( ff_grid ) threshold%settings%initialized_ps = .false. threshold%settings%initialized_ff = .false. end subroutine dealloc_grids @ -<>= +<>= subroutine trim_p_grid (n_p_new) integer, intent(in) :: n_p_new real(default), dimension(n_p_new) :: p_save complex(default), dimension(POINTS_SQ,n_p_new,POINTS_P0,2) :: ff_save if (n_p_new > POINTS_P) then call msg_fatal ("trim_p_grid: new size larger than old size.") return end if p_save = p_grid(1:n_p_new) ff_save = ff_grid(:,1:n_p_new,:,:) deallocate( p_grid, ff_grid ) allocate( p_grid(n_p_new), ff_grid(POINTS_SQ,n_p_new,POINTS_P0,2) ) p_grid = p_save ff_grid = ff_save end subroutine trim_p_grid @ -<>= +<>= !!! try to repair TOPPIK instabilities by interpolation of adjacent sq_grid points subroutine handle_TOPPIK_instabilities (ff, nan) complex(default), dimension(:,:,:,:), intent(inout) :: ff logical, dimension(:,:), intent(in) :: nan integer :: i, i_sq, n_nan logical :: interrupt n_nan = sum (merge ([(1, i=1, 2*POINTS_SQ)], & [(0, i=1, 2*POINTS_SQ)], reshape (nan, [2*POINTS_SQ])) ) interrupt = n_nan > 3 do i = 1, 2 if (interrupt ) exit if (.not. any (nan(:,i))) cycle do i_sq = 2, POINTS_SQ - 1 if (.not. nan(i_sq,i)) cycle if (nan(i_sq+1,i) .or. nan(i_sq-1,i)) then interrupt = .true. exit end if ff(i_sq,:,:,i) = (ff(i_sq-1,:,:,i) + ff(i_sq+1,:,:,i)) / two end do end do if (.not. interrupt) return call msg_fatal ("Too many TOPPIK instabilities! Check your parameter setup " & // "or slightly vary the scales sh and/or sf.") end subroutine handle_TOPPIK_instabilities @ -<>= +<>= pure function sqrts_to_v (sqrts, gamma) result (v) complex(default) :: v real(default), intent(in) :: sqrts, gamma real(default) :: m m = m1s_to_mpole (sqrts) v = sqrt ((sqrts - two * m + imago * gamma) / m) end function sqrts_to_v @ -<>= +<>= pure function sqrts_to_v_1S (sqrts, gamma) result (v) complex(default) :: v real(default), intent(in) :: sqrts, gamma v = sqrt ((sqrts - two * M1S + imago * gamma) / M1S) end function sqrts_to_v_1S @ -<>= +<>= pure function v_to_sqrts (v) result (sqrts) real(default), intent(in) :: v real(default) :: sqrts real(default) :: m m = mtpole_init sqrts = 2.*m + m*v**2 end function v_to_sqrts @ -<>= +<>= !!! -q^2 times the Coulomb potential V at LO resp. NLO function minus_q2_V (a, q, p, p0r, vec_type) result (v) real(default), intent(in) :: a real(default), intent(in) :: q real(default), intent(in) :: p real(default), intent(in) :: p0r integer, intent(in) :: vec_type complex(default) :: p0, log_mppp, log_mmpm, log_mu_s, v p0 = abs(p0r) + ieps log_mppp = log( (p-p0+q) * (p+p0+q) ) log_mmpm = log( (p-p0-q) * (p+p0-q) ) select case (vec_type) case (1) select case (NRQCD_ORDER) case (0) v = CF*a * 2.*pi*(log_mppp-log_mmpm) * q/p case (1) log_mu_s = 2.*log(MU_SOFT) v = CF*a * (2.*(4.*pi+A1*a)*(log_mppp-log_mmpm) & + B0*a*((log_mmpm-log_mu_s)**2-(log_mppp-log_mu_s)**2)) * q/(4.*p) case default call msg_fatal ("NRQCD_ORDER = " // char(NRQCD_ORDER)) end select case (2) !!! not implemented yet v = zero case default call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type)) end select end function minus_q2_V @ -<>= +<>= !!! compute support points (~> q-grid) for numerical integration: trim p-grid and !!! merge with singular points of integrand: q = p, |p-p0|, p+p0, sqrt(mpole*E) subroutine compute_support_points (en, i_p, i_p0, n_trim) real(default), intent(in) :: en integer, intent(in) :: i_p integer, intent(in) :: i_p0 integer, intent(in) :: n_trim real(default) :: p, p0 real(default), dimension(4) :: sing_vals integer :: n_sing, i_q if (mod (POINTS_P, n_trim) /= 0) call msg_fatal ("trim p-grid for q-integration: POINTS_P = " & // char(POINTS_P) // " and n_trim = " // char(n_trim)) n_q = POINTS_P / n_trim + merge(0,1,n_trim==1) p = p_grid(i_p) p0 = p0_grid(i_p0) n_sing = 0 if ( i_p /= 1 .and. mod(i_p,n_trim) /= 0 ) then n_sing = n_sing+1 sing_vals(n_sing) = p end if if ( i_p0 /= 1 ) then n_sing = n_sing+1 sing_vals(n_sing) = p0 + p if ( i_p0 /= i_p+1 ) then n_sing = n_sing+1 sing_vals(n_sing) = abs( p0 - p ) end if end if if ( en > 0. ) then n_sing = n_sing+1 sing_vals(n_sing) = sqrt( MTPOLE * en ) end if if ( allocated(q_grid) ) deallocate( q_grid ) allocate( q_grid(n_q+n_sing) ) q_grid(1) = p_grid(1) q_grid(2:n_q) = [(p_grid(i_q), i_q=max(n_trim,2), POINTS_P, n_trim)] if (n_sing > 0 ) q_grid(n_q+1:n_q+n_sing) = sing_vals(1:n_sing) call nr_sort (q_grid) end subroutine compute_support_points @ -<>= +<>= !!! cf. arXiv:hep-ph/9503238, validated against arXiv:hep-ph/0008171 pure function formfactor_ttv_relativistic_nlo (alphas, ps, J0) result (c) real(default), intent(in) :: alphas type(phase_space_point_t), intent(in) :: ps complex(default), intent(in) :: J0 complex(default) :: c real(default) :: p2, k2, q2, kp, pq, kq complex(default) :: D2, chi, ln1, ln2, L1, L2, z, S, m2, m complex(default) :: JA, JB, JC, JD, JE, IA, IB, IC, ID, IE complex(default) :: CCmsbar complex(default) :: dF1, dF2, dM1, dM2 complex(default), dimension(12) :: P1 complex(default), parameter :: ximo = zero p2 = ps%p2 k2 = ps%k2 q2 = ps%q2 m2 = complex_m2 (ps%mpole, GAM) !!! kinematic abbreviations kp = 0.5_default * (-q2 + p2 + k2) pq = 0.5_default * ( k2 - p2 - q2) kq = 0.5_default * (-p2 + k2 + q2) D2 = kp**2 - k2*p2 chi = p2*k2*q2 + 2.*m2*((p2 + k2)*kp - 2.*p2*k2) + m2**2 * q2 ln1 = log( (1. - p2/m2)*(1,0) + ieps ) ln2 = log( (1. - k2/m2)*(1,0) + ieps ) L1 = (1. - m2/p2) * ln1 L2 = (1. - m2/k2) * ln2 z = sqrt( (1.-4.*m2/q2)*(1,0) ) S = 0.5_default * z * log( (z+1.)/(z-1.) + ieps ) m = sqrt(m2) !!! loop integrals in terms of J0 JA = 1./D2 * (J0/2.*(-m2*pq - p2*kq) + kp*L2 - p2*L1 - 2.*pq*S) JB = 1./D2 * (J0/2.*( m2*kq + k2*pq) + kp*L1 - k2*L2 + 2.*kq*S) JC = 1/(4.*D2) * (2.*p2 + 2*kp*m2/k2 - 4.*kp*S + 2.*kp*(1. - m2/k2)*L2 + & (2.*kp*(p2 - m2) + 3.*p2*(m2 - k2))*JA + p2*(m2 - p2)*JB) JD = 1./(4.*D2) * (2.*kp*((k2 - m2)*JA + (p2 - m2)*JB - 1.) - k2*(2.*m2/k2 & - 2.*S + (1. - m2/k2)*L2 + (p2 - m2)*JA) - p2*(-2.*S + (1. - & m2/p2)*L1 + (k2 - m2)*JB)) JE = 1./(4.*D2) * (2.*k2 + 2*kp*m2/p2 - 4.*kp*S + 2.*kp*(1. - m2/p2)*L1 + & (2.*kp*(k2 - m2) + 3.*k2*(m2 - p2))*JB + k2*(m2 - k2)*JA) IA = 1./D2 * (-(kq/2.)*J0 - 2.*q2/chi *((m2 - p2)*k2 - (m2 - k2)*kp)*S + & 1./(m2 - p2)*(p2 - kp + p2*q2/chi *(k2 - m2)*(m2 + kp))*L1 + & k2*q2/chi *(m2 + kp)*L2) IB = 1./D2 * ( (pq/2.)*J0 - 2.*q2/chi *((m2 - k2)*p2 - (m2 - p2)*kp)*S + & 1./(m2 - k2)*(k2 - kp + k2*q2/chi *(p2 - m2)*(m2 + kp))*L2 + & p2*q2/chi *(m2 + kp)*L1) IC = 1./(4.*D2) * (2.*p2*J0 - 4.*kp/k2*(1. + m2/(k2 - m2)*L2) + (2.*kp - & 3.*p2)*JA - p2*JB + (-2.*kp*(m2 - p2) + 3.*p2*(m2 - k2))*IA + & p2*(m2 - p2)*IB) ID = 1./(4.*D2) * (-2.*kp*J0 + 2.*(1. + m2/(k2 - m2)*L2) + 2.*(1. + & m2/(p2 - m2)*L1) + (2.*kp - k2)*JA + (2.*kp - p2)*JB + (k2*(m2 - & p2) - 2.*kp*(m2 - k2))*IA + (p2*(m2 - k2) - 2.*kp*(m2 - p2))*IB) IE = 1./(4.*D2) * (2.*k2*J0 - 4.*kp/p2*(1. + m2/(p2 - m2)*L1) + (2.*kp - & 3.*k2)*JB - k2*JA + (-2.*kp*(m2 - k2) + 3.*k2*(m2 - p2))*IB + & k2*(m2 - k2)*IA) !!! divergent part ~ 1/epsilon: depends on subtraction scheme CCmsbar = -2.0_default * log(RESCALE_H) ! real top mass in the loop numerators ! m2 = cmplx(real(m2), kind=default) ! m = sqrt(m2) !!! quark self energies dF1 = - (ximo+1.) * (CCmsbar + (1.+m2/p2)*(1.-L1)) dF2 = - (ximo+1.) * (CCmsbar + (1.+m2/k2)*(1.-L2)) dM1 = m/p2 * ( (ximo+1.)*(1.+m2/p2*ln1) - 3.*ln1 ) dM2 = m/k2 * ( (ximo+1.)*(1.+m2/k2*ln2) - 3.*ln2 ) !!! coefficient list: vertex function Gamma_mu (k,p) = sum_i( Vi_mu * Pi ) P1(1) = 2.*JA - 2.*JC + ximo*(m2*IC + p2*ID) P1(2) = 2.*JB - 2.*JE + ximo*(k2*ID + m2*IE) P1(3) = -2.*J0 + 2.*JA + 2.*JB - 2.*JD + ximo*(-J0/2. - k2/2.*IC - & kp*ID + m2*ID + p2/2.*IE + JA) P1(4) = -2.*JD + ximo*(k2*IC + m2*ID - JA) P1(5) = J0 - JA - JB + ximo*(J0/4. + k2/4.*IC + kp/2.*ID + p2/4.*IE - & 1./2.*JA - 1./2.*JB) P1(6) = -m2*J0 - k2*JA - p2*JB + k2/2.*JC + kp*JD + p2/2.*JE + & (1./2. + CCmsbar - 2.*S) & + ximo*(-m2*J0/4. - m2/4.*k2*IC - m2/2.*kp*ID - m2/4.*p2*IE & - k2/2.*JA - p2/2.*JB + (CCmsbar + 2.)) P1(7) = 2.*m*J0 - 4.*m*JA + ximo*m*(J0/2. - 2.*kp*IC + k2/2.*IC - & p2*ID - kp*ID - p2/2.*IE - JA) P1(8) = 2.*m*J0 - 4.*m*JB + ximo*m*(J0/2. + k2/2.*IC - kp*ID + k2*ID - & p2/2.*IE - JB) P1(9) = ximo*m*(ID + IE) P1(10) = ximo*m*(ID + IC) P1(11) = ximo*m*( p2*ID + kp*IC + p2/2.*IE - k2/2.*IC) + dM2 !!! self energy contribution: ~ gamma_mu.k_slash = V11 P1(12) = ximo*m*(-k2*ID - kp*IE + p2/2.*IE - k2/2.*IC) + dM1 !!! self energy contribution: ~ gamma_mu.p_slash = V12 !!! leading form factor: V6 = gamma_mu, V5 = gamma_mu.k_slash.p_slash ~> -m^2*gamma_mu c = one + alphas * CF / (4.*pi) * ( P1(6) - m2*P1(5) & !!! self energy contributions ~ gamma^mu + dF1 + dF2 + m*( dM1 + dM2 ) ) !!! on-shell subtraction: UV divergence cancels ! + 0.5_default*( dF1 + dF2 + m*( dM1 + dM2 ) ) end function formfactor_ttv_relativistic_nlo @ -<>= +<>= pure function sqrts_to_en (sqrts, mpole_in) result (en) real(default), intent(in) :: sqrts real(default), intent(in), optional :: mpole_in real(default) :: mpole, en if (present (mpole_in)) then mpole = mpole_in else mpole = m1s_to_mpole (sqrts) end if en = sqrts - two * mpole end function sqrts_to_en @ -<>= +<>= function p_grid_from_TOPPIK (mpole_in) result (p_toppik) real(default), intent(in), optional :: mpole_in real(default), dimension(POINTS_P) :: p_toppik real(default) :: mpole if (debug_on) call msg_debug (D_THRESHOLD, "p_grid_from_TOPPIK") mpole = MTPOLE; if (present (mpole_in)) mpole = mpole_in call scan_formfactor_over_p_TOPPIK & (alphas_soft(2. * M1S), 2. * M1S, 1, p_toppik, mpole) if (.not. strictly_monotonous (p_toppik)) & call msg_fatal ("p_grid NOT strictly monotonous!") end function p_grid_from_TOPPIK @ -<>= - pure function int_to_char (i) result (c) +<>= + pure module function int_to_char (i) result (c) + integer, intent(in) :: i + character(len=len(trim(int2fixed(i)))) :: c + end function int_to_char +<>= + pure module function int_to_char (i) result (c) integer, intent(in) :: i character(len=len(trim(int2fixed(i)))) :: c c = int2char (i) end function int_to_char +@ %def int_to_char @ -<>= - pure function real_to_char (r) result (c) +<>= + pure module function real_to_char (r) result (c) + real(default), intent(in) :: r + character(len=len(trim(real2fixed(r)))) :: c + end function real_to_char +<>= + pure module function real_to_char (r) result (c) real(default), intent(in) :: r character(len=len(trim(real2fixed(r)))) :: c c = real2char (r) end function real_to_char +@ %def real_to_char @ -<>= - pure function complex_to_char (z) result (c) +<>= + pure module function complex_to_char (z) result (c) + complex(default), intent(in) :: z + character(len=len(trim(real2fixed(real(z))))+len(trim(real2fixed(aimag(z))))+5) :: c + end function complex_to_char +<>= + pure module function complex_to_char (z) result (c) complex(default), intent(in) :: z character(len=len(trim(real2fixed(real(z))))+len(trim(real2fixed(aimag(z))))+5) :: c character(len=len(trim(real2fixed(real(z))))) :: re character(len=len(trim(real2fixed(aimag(z))))) :: im re = real_to_char (real(z)) im = real_to_char (aimag(z)) if (nearly_equal (aimag(z), zero)) then c = re else c = re // " + " // im // "*I" end if end function complex_to_char +@ %def complex_to_char @ -<>= - pure function logical_to_char (l) result (c) +<>= + pure module function logical_to_char (l) result (c) + logical, intent(in) :: l + character(len=1) :: c + end function logical_to_char +<>= + pure module function logical_to_char (l) result (c) logical, intent(in) :: l character(len=1) :: c write (c, '(l1)') l end function logical_to_char +@ %def logical_to_char @ -<>= +<>= subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out) type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(out) :: p1_out, p2_out type(lorentz_transformation_t) :: L L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1)) p1_out = L * p1_in; p2_out = L * p2_in end subroutine get_rest_frame function shift_momentum (p_in, E, p) result (p_out) type(vector4_t) :: p_out type(vector4_t), intent(in) :: p_in real(default), intent(in) :: E, p type(vector3_t) :: vec vec = p_in%p(1:3) / space_part_norm (p_in) p_out = vector4_moving (E, p * vec) end function shift_momentum subroutine evaluate_one_to_two_splitting_threshold (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac type(lorentz_transformation_t) :: L type(vector4_t) :: p1_rest, p2_rest real(default) :: msq, msq1, msq2 real(default) :: m real(default) :: E1, E2, E_max real(default) :: p, lda real(default), parameter :: E_offset = 0.001_default !!! (TODO-cw-2016-10-13) Find a better way to get masses real(default), parameter :: mb = 4.2_default real(default), parameter :: mw = 80.419_default call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest) msq = p_origin**2; m = sqrt(msq) msq1 = p1_in**2 msq2 = m * (m - two * p1_rest%p(0)) E1 = (msq + msq1 - msq2) / (two * m) E_max = (msq - (mb + mw)**2) / (two * m) E_max = E_max - E_offset if (E1 > E_max) then E1 = E_max msq2 = m * (m - two * E_max) end if lda = lambda (msq, msq1, msq2) if (lda < zero) call msg_fatal & ("Threshold Splitting: lambda < 0 encountered! Use a higher offset.") p = sqrt(lda) / (two * m) E1 = sqrt (msq1 + p**2) E2 = sqrt (msq2 + p**2) p1_out = shift_momentum (p1_rest, E1, p) p2_out = shift_momentum (p2_rest, E2, p) L = boost (p_origin, p_origin**1) p1_out = L * p1_out p2_out = L * p2_out end subroutine evaluate_one_to_two_splitting_threshold @ %def evaluate_one_to_two_splitting_threshold @ -<>= +<>= public :: generate_on_shell_decay_threshold -<>= - subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell) +<>= + module subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell) + !!! Gluon must be on first position in this array + type(vector4_t), intent(in), dimension(:) :: p_decay + type(vector4_t), intent(inout) :: p_top + type(vector4_t), intent(inout), dimension(:) :: p_decay_onshell + end subroutine generate_on_shell_decay_threshold +<>= + module subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell) !!! Gluon must be on first position in this array type(vector4_t), intent(in), dimension(:) :: p_decay type(vector4_t), intent(inout) :: p_top type(vector4_t), intent(inout), dimension(:) :: p_decay_onshell procedure(evaluate_one_to_two_splitting_special), pointer :: ppointer ppointer => evaluate_one_to_two_splitting_threshold call generate_on_shell_decay (p_top, p_decay, p_decay_onshell, 1, & evaluate_special = ppointer) end subroutine generate_on_shell_decay_threshold @ %def generate_on_shell_decay_threshold @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[ttv_formfactors_ut.f90]]>>= <> module ttv_formfactors_ut use unit_tests use ttv_formfactors_uti <> -<> +<> contains -<> +<> end module ttv_formfactors_ut @ %def ttv_formfactors_ut @ <<[[ttv_formfactors_uti.f90]]>>= <> module ttv_formfactors_uti <> <> use constants use ttv_formfactors use diagnostics use sm_physics, only: running_as use numeric_utils <> -<> +<> contains -<> +<> end module ttv_formfactors_uti @ %def ttv_formfactors_ut @ API: driver for the unit tests below. -<>= +<>= public ::ttv_formfactors_test -<>= +<>= subroutine ttv_formfactors_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results - <> + <> end subroutine ttv_formfactors_test @ %def ttv_formfactors_test @ \subsubsection{Basic setup} -<>= +<>= call test(ttv_formfactors_1, "ttv_formfactors_1", & "Basic setup", u, results) -<>= +<>= public :: ttv_formfactors_1 -<>= +<>= subroutine ttv_formfactors_1 (u) integer, intent(in) :: u real(default) :: m1s, Vtb, wt_inv, alphaemi, sw, alphas_mz, mz, & mw, mb, sh, sf, NRQCD_ORDER, FF, offshell_strategy, v1, v2, & scan_sqrts_max, sqrts, scan_sqrts_min, scan_sqrts_stepsize, & test, gam_out, mpole type(formfactor_t) :: formfactor type(phase_space_point_t) :: ps logical :: mpole_fixed integer :: top_helicity_selection write (u, "(A)") "* Test output: ttv_formfactors_1" write (u, "(A)") "* Purpose: Basic setup" write (u, "(A)") m1s = 172.0_default Vtb = one wt_inv = zero alphaemi = 125.0_default alphas_mz = 0.118_default mz = 91.1876_default mw = 80.399_default sw = sqrt(one - mw**2 / mz**2) mb = 4.2_default sh = one sf = one NRQCD_ORDER = one FF = MATCHED offshell_strategy = 0 top_helicity_selection = -1 v1 = 0.3_default v2 = 0.5_default scan_sqrts_stepsize = 0.0_default test = - one write (u, "(A)") "Check high energy behavior" sqrts = 500.0_default scan_sqrts_min = sqrts scan_sqrts_max = sqrts write (u, "(A)") "Check that the mass is not fixed" mpole_fixed = .false. <<(re)start grid>> call threshold%formfactor%activate () call formfactor%activate () call assert (u, m1s_to_mpole (350.0_default) > m1s + 0.1_default, & "m1s_to_mpole (350.0_default) > m1s") write (u, "(A)") ! For simplicity we test on-shell back-to-back tops call ps%init (m1s**2, m1s**2, sqrts**2, mpole) call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), tiny_10, & "f_switch_off (v_matching (ps%sqrts, GAM_M1S))") call assert (u, & abs (formfactor%compute (ps, 1, EXPANDED_HARD)) > & abs (formfactor%compute (ps, 1, RESUMMED)), & "expansion with hard alphas should be larger " // & "than resummed (with switchoff)") call assert_equal (u, & abs (formfactor%compute (ps, 1, RESUMMED)), zero, & "resummed (with switchoff) should be zero", abs_smallness=tiny_10) call assert_equal (u, & abs (formfactor%compute (ps, 1, EXPANDED_SOFT_SWITCHOFF)), zero, & "expanded (with switchoff) should be zero", abs_smallness=tiny_10) write (u, "(A)") "" write (u, "(A)") "Check global variables" call assert_equal (u, AS_HARD, & running_as (m1s, alphas_mz, mz, 2, 5.0_default), "hard alphas") call assert_equal (u, AS_SOFT, zero, "soft alphas", abs_smallness=tiny_10) call assert_equal (u, AS_USOFT, zero, "ultrasoft alphas", abs_smallness=tiny_10) call assert_equal (u, AS_LL_SOFT, zero, "LL soft alphas", abs_smallness=tiny_10) !!! care: the formfactor contains the tree level that we usually subtract again write (u, "(A)") "Check low energy behavior" sqrts = 2 * m1s + 0.01_default scan_sqrts_min = sqrts scan_sqrts_max = sqrts write (u, "(A)") "Check that the mass is fixed" mpole_fixed = .true. <<(re)start grid>> call ps%init (m1s**2, m1s**2, sqrts**2, mpole) call assert_equal (u, m1s_to_mpole (350.0_default), m1s, & "m1s_to_mpole (350.0_default) == m1s") call assert_equal (u, m1s_to_mpole (550.0_default), m1s, & "m1s_to_mpole (550.0_default) == m1s") write (u, "(A)") "" - call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), one, "f_switch_off (v_matching (ps%sqrts, GAM_M1S))") + call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), & + one, "f_switch_off (v_matching (ps%sqrts, GAM_M1S))") call formfactor%disable () call assert_equal (u, & abs(formfactor%compute (ps, 1, 1)), & zero, & "disabled formfactor should return zero") call formfactor%activate () call assert_equal (u, & formfactor%compute (ps, 1, EXPANDED_SOFT_SWITCHOFF), & formfactor%compute (ps, 1, EXPANDED_SOFT), & "switchoff function should do nothing here") write (u, "(A)") "" write (u, "(A)") "* Test output end: ttv_formfactors_1" end subroutine ttv_formfactors_1 @ %def ttv_formfactors_1 <<(re)start grid>>= call init_parameters & (mpole, gam_out, m1s, Vtb, wt_inv, & alphaemi, sw, alphas_mz, mz, mw, & mb, sh, sf, NRQCD_ORDER, FF, offshell_strategy, & v1, v2, scan_sqrts_min, scan_sqrts_max, & scan_sqrts_stepsize, mpole_fixed, real(top_helicity_selection, default)) call init_threshold_grids (test) @ @ \subsubsection{Test flags} -<>= +<>= call test(ttv_formfactors_2, "ttv_formfactors_2", & "Test flags", u, results) -<>= +<>= public :: ttv_formfactors_2 -<>= +<>= subroutine ttv_formfactors_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: ttv_formfactors_2" write (u, "(A)") "* Purpose: Test flags" write (u, "(A)") write (u, "(A)") "RESUMMED_SWITCHOFF + NLO" call threshold%settings%setup_flags (-2, 1, -1) call assert (u, SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED") call assert (u, threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & ".not. threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, & ".not. threshold%settings%interference") call assert (u, .not. threshold%settings%no_nlo_width_in_signal_propagators, & ".not. threshold%settings%no_nlo_width_in_signal_propagators") write (u, "(A)") "MATCHED + FACTORIZATION" call threshold%settings%setup_flags (-1, 0+2, -1) call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo") call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") write (u, "(A)") "RESUMMED + INTERFERENCE" call threshold%settings%setup_flags (1, 0+0+4, -1) call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED") call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & ".not. threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, "threshold%settings%interference") write (u, "(A)") "EXPANDED_HARD" call threshold%settings%setup_flags (4, 0+2+4, -1) call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, "threshold%settings%interference") write (u, "(A)") "EXPANDED_SOFT" call threshold%settings%setup_flags (5, 1+2+4, -1) call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, threshold%settings%nlo, "threshold%settings%nlo") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, & "threshold%settings%interference") write (u, "(A)") "EXPANDED_SOFT_SWITCHOFF" call threshold%settings%setup_flags (6, 0+0+0+8, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, & "threshold%settings%interference") write (u, "(A)") "RESUMMED_ANALYTIC_LL" call threshold%settings%setup_flags (7, 0+0+4+8, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, threshold%settings%interference, "threshold%settings%interference") call assert (u, threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") write (u, "(A)") "EXPANDED_SOFT_HARD" call threshold%settings%setup_flags (8, 0+2+0+128, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo") call assert (u, threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, "threshold%settings%interference") call assert (u, .not. threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") call assert (u, threshold%settings%onshell_projection%decay, & "threshold%settings%onshell_projection%decay") write (u, "(A)") "EXTRA_TREE" call threshold%settings%setup_flags (9, 1+0+0+16+64, -1) call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED") call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED") call assert (u, threshold%settings%nlo, "threshold%settings%nlo") call assert (u, .not. threshold%settings%factorized_computation, & "threshold%settings%factorized_computation") call assert (u, .not. threshold%settings%interference, "threshold%settings%interference") call assert (u, threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") call assert (u, .not. threshold%settings%onshell_projection%decay, & "threshold%settings%onshell_projection%decay") call assert (u, threshold%settings%no_nlo_width_in_signal_propagators, & "threshold%settings%no_nlo_width_in_signal_propagators") write (u, "(A)") "test projection of width" call threshold%settings%setup_flags (9, 0+0+0+0+256, -1) call assert (u, .not. threshold%settings%onshell_projection%production, & "threshold%settings%onshell_projection%production") call assert (u, .not. threshold%settings%onshell_projection%decay, & "threshold%settings%onshell_projection%decay") call assert (u, .not. threshold%settings%onshell_projection%width, & "threshold%settings%onshell_projection%width") write (u, "(A)") "test boost of decay momenta" call threshold%settings%setup_flags (9, 512, -1) if (debug_on) call msg_debug (D_THRESHOLD, & "threshold%settings%onshell_projection%boost_decay", & threshold%settings%onshell_projection%boost_decay) call threshold%settings%setup_flags (9, 0, -1) if (debug_on) call msg_debug (D_THRESHOLD, & ".not. threshold%settings%onshell_projection%boost_decay", & .not. threshold%settings%onshell_projection%boost_decay) write (u, "(A)") "test helicity approximations" call threshold%settings%setup_flags (9, 32, -1) call assert (u, threshold%settings%helicity_approximation%simple, & "threshold%settings%helicity_approximation%simple") call assert (u, .not. threshold%settings%helicity_approximation%extra, & ".not. threshold%settings%helicity_approximation%extra") call assert (u, .not. threshold%settings%helicity_approximation%ultra, & ".not. threshold%settings%helicity_approximation%ultra") call threshold%settings%setup_flags (9, 1024, -1) call assert (u, .not. threshold%settings%helicity_approximation%simple, & ".not. threshold%settings%helicity_approximation%simple") call assert (u, threshold%settings%helicity_approximation%extra, & "threshold%settings%helicity_approximation%extra") write (u, "(A)") write (u, "(A)") "* Test output end: ttv_formfactors_2" end subroutine ttv_formfactors_2 @ %def ttv_formfactors_2 @ Index: trunk/src/threshold/Makefile.am =================================================================== --- trunk/src/threshold/Makefile.am (revision 8779) +++ trunk/src/threshold/Makefile.am (revision 8780) @@ -1,225 +1,239 @@ ## Makefile.am -- Makefile for model-parameter modules in WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## Build the objects required for the SM ttbar threshold model. noinst_LTLIBRARIES = libthreshold.la check_LTLIBRARIES = libthreshold_ut.la ## We need all in the distribution EXTRA_DIST = interpolation.f90 nr_tools.f90 \ toppik.f toppik_axial.f ttv_formfactors.f90 libthreshold_la_SOURCES = \ + $(THRESHOLD_MODULES) \ + $(THRESHOLD_SUBMODULES) + +THRESHOLD_MODULES = \ interpolation.f90 \ nr_tools.f90 \ toppik.f \ toppik_axial.f \ ttv_formfactors.f90 +THRESHOLD_SUBMODULES = \ + interpolation_sub.f90 \ + ttv_formfactors_sub.f90 + ## Omitting this would exclude it from the distribution dist_noinst_DATA = threshold.nw libthreshold_ut_la_SOURCES = \ ttv_formfactors_uti.f90 ttv_formfactors_ut.f90 # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ interpolation.$(FCMOD) \ nr_tools.$(FCMOD) \ ttv_formfactors.$(FCMOD) \ nr.$(FCMOD) \ nrtype.$(FCMOD) \ nrutil.$(FCMOD) \ hypgeo_info.$(FCMOD) \ ode_path.$(FCMOD) +# Submodules must not be included here # Dump module names into file Modules libthreshold_Modules = \ - ${libthreshold_la_SOURCES:.f90=} \ + ${THRESHOLD_MODULES:.f90=} \ ${libthreshold_ut_la_SOURCES:.f90=} Modules: Makefile @for module in $(libthreshold_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../testing/Modules \ ../utilities/Modules \ ../system/Modules \ ../physics/Modules \ ../combinatorics/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(libthreshold_la_SOURCES) \ $(libthreshold_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES = Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(libthreshold_la_SOURCES) \ $(libthreshold_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend nrtype.$(FCMOD) nr.$(FCMOD): nr_tools.$(FCMOD) SUFFIXES = .lo .$(FCMOD) # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: AM_FCFLAGS = -I../basics -I../testing -I../utilities -I../system -I../physics -I../combinatorics ######################################################################## +# For the moment, the submodule dependencies will be hard-coded +interpolation_sub.lo: interpolation.lo +ttv_formfactors_sub.lo: ttv_formfactors.lo + +######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw threshold.stamp: $(PRELUDE) $(srcdir)/threshold.nw $(POSTLUDE) @rm -f threshold.tmp @touch threshold.tmp for src in \ $(libthreshold_la_SOURCES) \ $(libthreshold_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f threshold.tmp threshold.stamp $(libthreshold_la_SOURCES) $(libthreshold_ut_la_SOURCES): threshold.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f threshold.stamp; \ $(MAKE) $(AM_MAKEFLAGS) threshold.stamp; \ fi endif ######################################################################## ## Explicit dependencies interpolation.$(FCMOD): interpolation.lo nr_tools.$(FCMOD): nr_tools.lo ttv_formfactors.$(FCMOD): ttv_formfactors.lo nr.$(FCMOD): nr_tools.lo nrtype.$(FCMOD): nr_tools.lo nrutil.$(FCMOD): nr_tools.lo hypgeo_info.$(FCMOD): nr_tools.lo ode_path.$(FCMOD): nr_tools.lo ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f *.f90 || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f *.stamp *.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES - -rm -f *.smod + -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-local: -rm -f *~ ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup