Index: trunk/src/threshold/threshold.nw
===================================================================
--- trunk/src/threshold/threshold.nw (revision 8477)
+++ trunk/src/threshold/threshold.nw (revision 8478)
@@ -1,11176 +1,11176 @@
% -*- 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]]>>=
<<File header>>
module interpolation
use kinds
implicit none
save
private
public :: interpolate_linear, strictly_monotonous
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)
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)
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)
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)
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
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)
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
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)
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)
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)
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)
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)
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)
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)
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)
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)
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
@
<<[[nr_tools.f90]]>>=
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! WHIZARD <<Version>> <<Date>>
! 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 <<Version>> <<Date>>
! 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 DILOG
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
DATA PI/3.14159265/
F(X)= PI**2+2*DILOG(X)-2*DILOG(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 DILOG(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 DILOG=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
DILOG=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 <<Version>> <<Date>>
! 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
@
<<[[ttv_formfactors.f90]]>>=
<<File header>>
module ttv_formfactors
use kinds
<<Use debug>>
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
<<Standard module head>>
save
<<ttv formfactors: public>>
<<ttv formfactors: parameters>>
<<ttv formfactors: types>>
<<ttv formfactors: global variables>>
<<ttv formfactors: interfaces>>
contains
<<ttv formfactors: procedures>>
end module ttv_formfactors
@ %def ttv_formfactors
@
<<ttv formfactors: public>>=
public :: onshell_projection_t
<<ttv formfactors: types>>=
type :: onshell_projection_t
logical :: production
logical :: decay
logical :: width
logical :: boost_decay
contains
<<ttv formfactors: onshell projection: TBP>>
end type onshell_projection_t
@ %def onshell_projection_t
@
<<ttv formfactors: onshell projection: TBP>>=
procedure :: debug_write => onshell_projection_debug_write
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: onshell projection: TBP>>=
procedure :: set_all => onshell_projection_set_all
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: onshell projection: TBP>>=
procedure :: active => onshell_projection_active
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: types>>=
type :: helicity_approximation_t
logical :: simple = .false.
logical :: extra = .false.
logical :: ultra = .false.
contains
<<ttv formfactors: helicity approximation: TBP>>
end type helicity_approximation_t
@ %def helicity_approximation_t
@
<<ttv formfactors: public>>=
public :: settings_t
<<ttv formfactors: types>>=
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
<<ttv formfactors: settings: TBP>>
end type settings_t
@ %def settings_t
@
<<ttv formfactors: settings: TBP>>=
procedure :: setup_flags => settings_setup_flags
<<ttv formfactors: procedures>>=
! 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, &
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
@
<<ttv formfactors: settings: TBP>>=
procedure :: write => settings_write
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: settings: TBP>>=
procedure :: use_nlo_width => settings_use_nlo_width
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: public>>=
public :: formfactor_t
<<ttv formfactors: types>>=
type :: formfactor_t
logical :: active
contains
<<ttv formfactors: formfactor: TBP>>
end type formfactor_t
@ %def formfactor_t
@
<<ttv formfactors: formfactor: TBP>>=
procedure :: activate => formfactor_activate
<<ttv formfactors: procedures>>=
pure subroutine formfactor_activate (formfactor)
class(formfactor_t), intent(inout) :: formfactor
formfactor%active = .true.
end subroutine formfactor_activate
@ %def formfactor_activate
@
<<ttv formfactors: formfactor: TBP>>=
procedure :: disable => formfactor_disable
<<ttv formfactors: procedures>>=
pure 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$.
<<ttv formfactors: formfactor: TBP>>=
procedure :: compute => formfactor_compute
<<ttv formfactors: procedures>>=
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, "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
@
<<ttv formfactors: public>>=
public :: width_t
<<ttv formfactors: types>>=
type :: width_t
real(default) :: aem
real(default) :: sw
real(default) :: mw
real(default) :: mb
real(default) :: vtb
real(default) :: gam_inv
contains
<<ttv formfactors: width: TBP>>
end type width_t
@ %def width_t
@
<<ttv formfactors: width: TBP>>=
procedure :: init => width_init
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: width: TBP>>=
procedure :: compute => width_compute
<<ttv formfactors: procedures>>=
pure 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.
<<ttv formfactors: public>>=
public :: threshold
<<ttv formfactors: global variables>>=
type(threshold_t) :: threshold
<<ttv formfactors: public>>=
public :: threshold_t
<<ttv formfactors: types>>=
type :: threshold_t
type(settings_t) :: settings
type(formfactor_t) :: formfactor
type(width_t) :: width
contains
<<ttv formfactors: threshold: TBP>>
end type threshold_t
@ %def threshold_t
@
<<ttv formfactors: parameters>>=
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
<<ttv formfactors: public>>=
public :: GAM, GAM_M1S
<<ttv formfactors: global variables>>=
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
<<ttv formfactors: public>>=
public :: AS_SOFT
public :: AS_LL_SOFT
public :: AS_USOFT
public :: AS_HARD
public :: SWITCHOFF_RESUMMED
public :: TOPPIK_RESUMMED
<<ttv formfactors: global variables>>=
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:
<<ttv formfactors: global variables>>=
real(default) :: sqrts_min, sqrts_max, sqrts_it
@
<<ttv formfactors: interfaces>>=
interface char
module procedure int_to_char, real_to_char, complex_to_char, logical_to_char
end interface char
<<ttv formfactors: public>>=
public :: m1s_to_mpole
@
<<ttv formfactors: types>>=
type, public :: 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
<<ttv formfactors: phase space point: TBP>>
end type phase_space_point_t
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: init => phase_space_point_init_rel
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: init_nonrel => phase_space_point_init_nonrel
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: is_onshell => phase_space_point_is_onshell
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: write => phase_space_point_write
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: public>>=
public :: init_parameters
<<ttv formfactors: procedures>>=
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
<<ttv formfactors: init parameters: subroutines>>
end subroutine init_parameters
@
<<ttv formfactors: init parameters: subroutines>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: public>>=
public :: init_threshold_grids
<<ttv formfactors: procedures>>=
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!")
!!! !!! !!! 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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
!!! 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) * ( &
+ (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 )))
+ (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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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)
end function parameters_string
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: public>>=
public :: v_matching
<<ttv formfactors: procedures>>=
pure 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
@ Smooth transition from [[f1]] to [[f2]] between [[v1]] and [[v2]]
(simplest polynom).
<<ttv formfactors: public>>=
public :: f_switch_off
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
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).
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: public>>=
public :: alphas_notsohard
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
!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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
! 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
!!! -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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
!!! 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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
pure 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
@
<<ttv formfactors: procedures>>=
pure function logical_to_char (l) result (c)
logical, intent(in) :: l
character(len=1) :: c
write (c, '(l1)') l
end function logical_to_char
@
<<ttv formfactors: procedures>>=
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
@
<<ttv formfactors: public>>=
public :: generate_on_shell_decay_threshold
<<ttv formfactors: procedures>>=
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]]>>=
<<File header>>
module ttv_formfactors_ut
use unit_tests
use ttv_formfactors_uti
<<Standard module head>>
<<ttv formfactors: public test>>
contains
<<ttv formfactors: test driver>>
end module ttv_formfactors_ut
@ %def ttv_formfactors_ut
@
<<[[ttv_formfactors_uti.f90]]>>=
<<File header>>
module ttv_formfactors_uti
<<Use kinds>>
<<Use debug>>
use constants
use ttv_formfactors
use diagnostics
use sm_physics, only: running_as
use numeric_utils
<<Standard module head>>
<<ttv formfactors: test declarations>>
contains
<<ttv formfactors: tests>>
end module ttv_formfactors_uti
@ %def ttv_formfactors_ut
@ API: driver for the unit tests below.
<<ttv formfactors: public test>>=
public ::ttv_formfactors_test
<<ttv formfactors: test driver>>=
subroutine ttv_formfactors_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<ttv formfactors: execute tests>>
end subroutine ttv_formfactors_test
@ %def ttv_formfactors_test
@
\subsubsection{Basic setup}
<<ttv formfactors: execute tests>>=
call test(ttv_formfactors_1, "ttv_formfactors_1", &
"Basic setup", u, results)
<<ttv formfactors: test declarations>>=
public :: ttv_formfactors_1
<<ttv formfactors: tests>>=
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 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}
<<ttv formfactors: execute tests>>=
call test(ttv_formfactors_2, "ttv_formfactors_2", &
"Test flags", u, results)
<<ttv formfactors: test declarations>>=
public :: ttv_formfactors_2
<<ttv formfactors: tests>>=
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/ChangeLog
===================================================================
--- trunk/ChangeLog (revision 8477)
+++ trunk/ChangeLog (revision 8478)
@@ -1,2166 +1,2169 @@
ChangeLog -- Summary of changes to the WHIZARD package
Use svn log to see detailed changes.
Version 3.0.0_beta+
+2020-12-08
+ Bug fix in expanded p-wave form factor for top threshold
+
2020-12-06
Patch for macOS Big Sur shared library handling due to libtool;
the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5
2020-12-04
O'Mega only inserts non-vanishing couplings from UFO models
2020-11-21
Bug fix for fractional hypercharges in UFO models
2020-11-11
Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)
2020-11-09
Correct flavor assignment for NLO fixed-order events
2020-11-05
Bug fix for ISR handler not working with unstable particles
2020-10-08
Bug fix in LHAPDF interface for photon PDFs
2020-10-07
Bug fix for structure function setup with asymmetric beams
2020-10-02
Python/Cython layer for WHIZARD API
2020-09-30
Allow mismatches of Python and name attributes in UFO models
2020-09-26
Support for negative PDG particles from certain UFO models
2020-09-24
Allow for QNUMBERS blocks in BSM SLHA files
2020-09-22
Full support for compilation with clang(++) on Darwin/macOS
More documentation in the manual
Minor clean-ups
2020-09-16
Bug fix enables reading LCIO events with LCIO v2.15+
##################################################################
2020-09-16
RELEASE: version 2.8.5
2020-09-11
Bug fix for H->tau tau transverse polarization with PYTHIA6
(thanks to Junping Tian / Akiya Miyamoto)
2020-09-09
Fix a long standing bug (since 2.0) in the calculation of color
factors when particles of different color were combined in a
particle class. NB: O'Mega never produced a wrong number,
it only declared all processes as invalid.
2020-09-08
Enable Openloops matrix element equivalences for optimization
2020-09-02
Compatibility fix for PYTHIA v8.301+ interface
2020-09-01
Support exclusive jet clustering in ee for Fastjet interface
##################################################################
2020-08-30
RELEASE: version 3.0.0_beta
2020-08-27
Major revision of NLO distributions and events for
processes with structure functions:
- Use parton momenta/flavors (instead of beams) for events
- Bug fix for Lorentz boosts and Lorentz frames of momenta
- Bug fix: apply cuts to virtual NLO component in correct frame
- Correctly assign ISR radiation momenta in data structures
- Refactoring on quantum numbers for NLO event data structures
- Functional tests for hadron collider NLO distributions
- many minor bug fixes regarding NLO hadron collider physics
2020-08-11
Bug fix for linking problem with OpenMPI
2020-08-07
New WHIZARD API: WHIZARD can be externally linked as a
library, added examples for Fortran, C, C++ programs
##################################################################
2020-07-08
RELEASE: version 2.8.4
2020-07-07
Bug fix: steering of UFO Majorana models from WHIZARD
##################################################################
2020-07-06
Combined integration also for hadron collider processes at NLO
2020-07-05
Bug fix: correctly steer e+e- FastJet clustering algorithms
Major revision of NLO differential distributions and events:
- Correctly assign quantum numbers to NLO fixed-order events
- Correctly assign weights to NLO fixed-order events for
combined simulation
- Cut all NLO fixed-order subevents in event groups individually
- Only allow "sigma" normalization for NLO fixed-order events
- Use correct PDF setup for NLO counter events
- Several technical fixes and updates of the NLO testsuite
##################################################################
2020-07-03
RELEASE: version 2.8.3
2020-07-02
Feature-complete UFO implementation for Majorana fermions
2020-06-22
Running width scheme supported for O'Mega matrix elements
2020-06-20
Adding H-s-s coupling to SM_Higgs(_CKM) models
2020-06-17
Completion of ILC 2->6 fermion extended test suite
2020-06-15
Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays
2020-06-09
Bug fix: correctly update calls for additional VAMP/2 iterations
Bug fix: correct assignment for tau spins from PYTHIA6 interface
2020-06-04
Bug fix: cascades2 tree merge with empty subtree(s)
2020-05-31
Switch $epa_mode for different EPA implementations
2020-05-26
Bug fix: spin information transferred for resonance histories
2020-04-13
HepMC: correct weighted events for non-xsec event normalizations
2020-04-04
Improved HepMC3 interface: HepMC3 Root/RootTree interface
2020-03-24
ISR: Fix on-shell kinematics for events with ?isr_handler=true
(set ?isr_handler_keep_mass=false for old behavior)
2020-03-11
Beam masses are correctly passed to hard matrix element for CIRCE2
EPA with polarized beams: double-counting corrected
##################################################################
2020-03-03
RELEASE: version 3.0.0_alpha
2020-02-25
Bug fix: Scale and alphas can be retrieved from internal event format to
external formats
2020-02-17
Bug fix: ?keep_failed_events now forces output of actual event data
Bug fix: particle-set reconstruction (rescanning events w/o radiation)
2020-01-28
Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)
2020-01-23
Bug fix for real components of NLO QCD 2->1 processes
2020-01-22
Bug fix: correct random number sequencing during parallel MPI event
generation with rng_stream
2020-01-21
Consistent distribution of events during parallel MPI event generation
2020-01-20
Bug fix for configure setup for automake v1.16+
2020-01-18
General SLHA parameter files for UFO models supported
2020-01-08
Bug fix: correctly register RECOLA processes with flavor sums
2019-12-19
Support for UFO customized propagators
O'Mega unit tests for fermion-number violating interactions
2019-12-10
For distribution building: check for graphviz/dot
version 2.40 or newer
2019-11-21
Bug fix: alternate setups now work correctly
Infrastructure for accessing alpha_QED event-by-event
Guard against tiny numbers that break ASCII event output
Enable inverse hyperbolic functions as SINDARIN observables
Remove old compiler bug workarounds
2019-11-20
Allow quoted -e argument, implemented -f option
2019-11-19
Bug fix: resonance histories now work also with UFO models
Fix in numerical precision of ASCII VAMP2 grids
2019-11-06
Add squared matrix elements to the LCIO event header
2019-11-05
Do not include RNG state in MD5 sum for CIRCE1/2
2019-11-04
Full CIRCE2 ILC 250 and 500 GeV beam spectra added
Minor update on LCIO event header information
2019-10-30
NLO QCD for final states completed
When using Openloops, v2.1.1+ mandatory
2019-10-25
Binary grid files for VAMP2 integrator
##################################################################
2019-10-24
RELEASE: version 2.8.2
2019-10-20
Bug fix for HepMC linker flags
2019-10-19
Support for spin-2 particles from UFO files
2019-09-27
LCIO event format allows rescan and alternate weights
2019-09-24
Compatibility fix for OCaml v4.08.0+
##################################################################
2019-09-21
RELEASE: version 2.8.1
2019-09-19
Carriage return characters in UFO models can be parsed
Mathematica symbols in UFO models possible
Unused/undefined parameters in UFO models handled
2019-09-13
New extended NLO test suite for ee and pp processes
2019-09-09
Photon isolation (separation of perturbative and fragmentation
part a la Frixione)
2019-09-05
Major progress on NLO QCD for hadron collisions:
- correctly assign flavor structures for alpha regions
- fix crossing of particles for initial state splittings
- correct assignment for PDF factors for real subtractions
- fix kinematics for collinear splittings
- bug fix for integrated virtual subtraction terms
2019-09-03
b and c jet selection in cuts and analysis
2019-08-27
Support for Intel MPI
2019-08-20
Complete (preliminary) HepMC3 support (incl.
backwards HepMC2 write/read mode)
2019-08-08
Bug fix: handle carriage returns in UFO files (non-Unix OS)
##################################################################
2019-08-07
RELEASE: version 2.8.0
2019-07-31
Complete WHIZARD UFO interface:
- general Lorentz structures
- matrix element support for general color factors
- missing features: Majorana fermions and SLHA
2019-07-20
Make WHIZARD compatible with OCaml 4.08.0+
2019-07-19
Fix version testing for LHAPDF 6.2.3 and newer
Minimal required OCaml version is now 4.02.3.
2019-04-18
Correctly generate ordered FKS tuples for alpha regions
from all possible underlying Born processes
2019-04-08
Extended O'Mega/Recola matrix element test suite
2019-03-29
Correct identical particle symmetry factors for FKS subtraction
2019-03-28
Correct assertion of spin-correlated matrix
elements for hadron collisions
2019-03-27
Bug fix for cut-off parameter delta_i for
collinear plus/minus regions
##################################################################
2019-03-27
RELEASE: version 2.7.1
2019-02-19
Further infrastructure for HepMC3 interface (v3.01.00)
2019-02-07
Explicit configure option for using debugging options
Bug fix for performance by removing unnecessary debug operations
2019-01-29
Bug fix for DGLAP remnants with cut-off parameter delta_i
2019-01-24
Radiative decay neu2 -> neu1 A added to MSSM_Hgg model
##################################################################
2019-01-21
RELEASE: version 2.7.0
2018-12-18
Support RECOLA for integrated und unintegrated subtractions
2018-12-11
FCNC top-up sector in model SM_top_anom
2018-12-05
Use libtirpc instead of SunRPC on Arch Linux etc.
2018-11-30
Display rescaling factor for weighted event samples with cuts
2018-11-29
Reintroduce check against different masses in flavor sums
Bug fix for wrong couplings in the Littlest Higgs model(s)
2018-11-22
Bug fix for rescanning events with beam structure
2018-11-09
Major refactoring of internal process data
2018-11-02
PYTHIA8 interface
2018-10-29
Flat phase space parametrization with RAMBO (on diet) implemented
2018-10-17
Revise extended test suite
2018-09-27
Process container for RECOLA processes
2018-09-15
Fixes by M. Berggren for PYTHIA6 interface
2018-09-14
First fixes after HepForge modernization
##################################################################
2018-08-23
RELEASE: version 2.6.4
2018-08-09
Infrastructure to check colored subevents
2018-07-10
Infrastructure for running WHIZARD in batch mode
2018-07-04
MPI available from distribution tarball
2018-06-03
Support Intel Fortran Compiler under MAC OS X
2018-05-07
FKS slicing parameter delta_i (initial state) implementend
2018-05-03
Refactor structure function assignment for NLO
2018-05-02
FKS slicing parameter xi_cut, delta_0 implemented
2018-04-20
Workspace subdirectory for process integration (grid/phs files)
Packing/unpacking of files at job end/start
Exporting integration results from scan loops
2018-04-13
Extended QCD NLO test suite
2018-04-09
Bug fix for Higgs Singlet Extension model
2018-04-06
Workspace subdirectory for process generation and compilation
--job-id option for creating job-specific names
2018-03-20
Bug fix for color flow matching in hadron collisions
with identical initial state quarks
2018-03-08
Structure functions quantum numbers correctly assigned for NLO
2018-02-24
Configure setup includes 'pgfortran' and 'flang'
2018-02-21
Include spin-correlated matrix elements in interactions
2018-02-15
Separate module for QED ISR structure functions
##################################################################
2018-02-10
RELEASE: version 2.6.3
2018-02-08
Improvements in memory management for PS generation
2018-01-31
Partial refactoring: quantum number assigment NLO
Initial-state QCD splittings for hadron collisions
2018-01-25
Bug fix for weighted events with VAMP2
2018-01-17
Generalized interface for Recola versions 1.3+ and 2.1+
2018-01-15
Channel equivalences also for VAMP2 integrator
2018-01-12
Fix for OCaml compiler 4.06 (and newer)
2017-12-19
RECOLA matrix elements with flavor sums can be integrated
2017-12-18
Bug fix for segmentation fault in empty resonance histories
2017-12-16
Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
from transferral between PYTHIA and WHIZARD event records
2017-12-15
Event index for multiple processes in event file correct
##################################################################
2017-12-13
RELEASE: version 2.6.2
2017-12-07
User can set offset in event numbers
2017-11-29
Possibility to have more than one RECOLA process in one file
2017-11-23
Transversal/mixed (and unitarized) dim-8 operators
2017-11-16
epa_q_max replaces epa_e_max (trivial factor 2)
2017-11-15
O'Mega matrix element compilation silent now
2017-11-14
Complete expanded P-wave form factor for top threshold
2017-11-10
Incoming particles can be accessed in SINDARIN
2017-11-08
Improved handling of resonance insertion, additional parameters
2017-11-04
Added Higgs-electron coupling (SM_Higgs)
##################################################################
2017-11-03
RELEASE: version 2.6.1
2017-10-20
More than 5 NLO components possible at same time
2017-10-19
Gaussian cutoff for shower resonance matching
2017-10-12
Alternative (more efficient) method to generate
phase space file
2017-10-11
Bug fix for shower resonance histories for processes
with multiple components
2017-09-25
Bug fix for process libraries in shower resonance histories
2017-09-21
Correctly generate pT distribution for EPA remnants
2017-09-20
Set branching ratios for unstable particles also by hand
2017-09-14
Correctly generate pT distribution for ISR photons
##################################################################
2017-09-08
RELEASE: version 2.6.0
2017-09-05
Bug fix for initial state NLO QCD flavor structures
Real and virtual NLO QCD hadron collider processes
work with internal interactions
2017-09-04
Fully validated MPI integration and event generation
2017-09-01
Resonance histories for shower: full support
Bug fix in O'Mega model constraints
O'Mega allows to output a parsable form of the DAG
2017-08-24
Resonance histories in events for transferral
to parton shower (e.g. in ee -> jjjj)
2017-08-01
Alpha version of HepMC v3 interface
(not yet really functional)
2017-07-31
Beta version for RECOLA OLP support
2017-07-06
Radiation generator fix for LHC processes
2017-06-30
Fix bug for NLO with structure
functions and/or polarization
2017-06-23
Collinear limit for QED corrections works
2017-06-17
POWHEG grids generated already during integration
2017-06-12
Soft limit for QED corrections works
2017-05-16
Beta version of full MPI parallelization (VAMP2)
Check consistency of POWHEG grid files
Logfile config-summary.log for configure summary
2017-05-12
Allow polarization in top threshold
2017-05-09
Minimal demand automake 1.12.2
Silent rules for make procedures
2017-05-07
Major fix for POWHEG damping
Correctly initialize FKS ISR phasespace
##################################################################
2017-05-06
RELEASE: version 2.5.0
2017-05-05
Full UFO support (SM-like models)
Fixed-beam ISR FKS phase space
2017-04-26
QED splittings in radiation generator
2017-04-10
Retire deprecated O'Mega vertex cache files
##################################################################
2017-03-24
RELEASE: version 2.4.1
2017-03-16
Distinguish resonance charge in phase space channels
Keep track of resonance histories in phase space
Complex mass scheme default for OpenLoops amplitudes
2017-03-13
Fix helicities for polarized OpenLoops calculations
2017-03-09
Possibility to advance RNG state in rng_stream
2017-03-04
General setup for partitioning real emission
phase space
2017-03-06
Bug fix on rescan command for converting event files
2017-02-27
Alternative multi-channel VEGAS implementation
VAMP2: serial backbone for MPI setup
Smoothstep top threshold matching
2017-02-25
Single-beam structure function with
s-channel mapping supported
Safeguard against invalid process libraries
2017-02-16
Radiation generator for photon emission
2017-02-10
Fixes for NLO QCD processes (color correlations)
2017-01-16
LCIO variable takes precedence over LCIO_DIR
2017-01-13
Alternative random number generator
rng_stream (cf. L'Ecuyer et al.)
2017-01-01
Fix for multi-flavor BLHA tree
matrix elements
2016-12-31
Grid path option for VAMP grids
2016-12-28
Alpha version of Recola OLP support
2016-12-27
Dalitz plots for FKS phase space
2016-12-14
NLO multi-flavor events possible
2016-12-09
LCIO event header information added
2016-12-02
Alpha version of RECOLA interface
Bug fix for generator status in LCIO
##################################################################
2016-11-28
RELEASE: version 2.4.0
2016-11-24
Bug fix for OpenLoops interface: EW scheme
is set by WHIZARD
Bug fixes for top threshold implementation
2016-11-11
Refactoring of dispatching
2016-10-18
Bug fix for LCIO output
2016-10-10
First implementation for collinear soft terms
2016-10-06
First full WHIZARD models from UFO files
2016-10-05
WHIZARD does not support legacy gcc 4.7.4 any longer
2016-09-30
Major refactoring of process core and NLO components
2016-09-23
WHIZARD homogeneous entity: discarding subconfigures
for CIRCE1/2, O'Mega, VAMP subpackages; these are
reconstructable by script projectors
2016-09-06
Introduce main configure summary
2016-08-26
Fix memory leak in event generation
##################################################################
2016-08-25
RELEASE: version 2.3.1
2016-08-19
Bug fix for EW-scheme dependence of gluino propagators
2016-08-01
Beta version of complex mass scheme support
2016-07-26
Fix bug in POWHEG damping for the matching
##################################################################
2016-07-21
RELEASE: version 2.3.0
2016-07-20
UFO file support (alpha version) in O'Mega
2016-07-13
New (more) stable of WHIZARD GUI
Support for EW schemes for OpenLoops
Factorized NLO top decays for threshold model
2016-06-15
Passing factorization scale to PYTHIA6
Adding charge and neutral observables
2016-06-14
Correcting angular distribution/tweaked kinematics in
non-collinear structure functions splittings
2016-05-10
Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
(backwards validation of LC CDR/TDR samples)
2016-04-27
Within OpenLoops virtuals: support for Collier library
2016-04-25
O'Mega vertex tables only loaded at first usage
2016-04-21
New CJ15 PDF parameterizations added
2016-04-21
Support for hadron collisions at NLO QCD
2016-04-05
Support for different (parameter) schemes in model files
2016-03-31
Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
into the event record
2016-03-21
New internal implementation of polarization
via Bloch vectors, remove pointer constructions
2016-03-13
Extension of cascade syntax for processes:
exclude propagators/vertices etc. possible
2016-02-24
Full support for OpenLoops QCD NLO matrix
elements, inclusion in test suite
2016-02-12
Substantial progress on QCD NLO support
2016-02-02
Automated resonance mapping for FKS subtraction
2015-12-17
New BSM model WZW for diphoton resonances
##################################################################
2015-11-22
RELEASE: version 2.2.8
2015-11-21
Bug fix for fixed-order NLO events
2015-11-20
Anomalous FCNC top-charm vertices
2015-11-19
StdHEP output via HEPEVT/HEPEV4 supported
2015-11-18
Full set of electroweak dim-6 operators included
2015-10-22
Polarized one-loop amplitudes supported
2015-10-21
Fixes for event formats for showered events
2015-10-14
Callback mechanism for event output
2015-09-22
Bypass matrix elements in pure event sample rescans
StdHep frozen final version v5.06.01 included internally
2015-09-21
configure option --with-precision to
demand 64bit, 80bit, or 128bit Fortran
and bind C precision types
2015-09-07
More extensive tests of NLO
infrastructure and POWHEG matching
2015-09-01
NLO decay infrastructure
User-defined squared matrix elements
Inclusive FastJet algorithm plugin
Numerical improvement for small boosts
##################################################################
2015-08-11
RELEASE: version 2.2.7
2015-08-10
Infrastructure for damped POWHEG
Massive emitters in POWHEG
Born matrix elements via BLHA
GoSam filters via SINDARIN
Minor running coupling bug fixes
Fixed-order NLO events
2015-08-06
CT14 PDFs included (LO, NLO, NNLL)
2015-07-07
Revalidation of ILC WHIZARD-PYTHIA event chain
Extended test suite for showered events
Alpha version of massive FSR for POWHEG
2015-06-09
Fix memory leak in interaction for long cascades
Catch mismatch between beam definition and CIRCE2 spectrum
2015-06-08
Automated POWHEG matching: beta version
Infrastructure for GKS matching
Alpha version of fixed-order NLO events
CIRCE2 polarization averaged spectra with
explicitly polarized beams
2015-05-12
Abstract matching type: OO structure for matching/merging
2015-05-07
Bug fix in event record WHIZARD-PYTHIA6 transferral
Gaussian beam spectra for lepton colliders
##################################################################
2015-05-02
RELEASE: version 2.2.6
2015-05-01
Models for (unitarized) tensor resonances in VBS
2015-04-28
Bug fix in channel weights for event generation.
2015-04-18
Improved event record transfer WHIZARD/PYTHIA6
2015-03-19
POWHEG matching: alpha version
##################################################################
2015-02-27
RELEASE: version 2.2.5
2015-02-26
Abstract types for quantum numbers
2015-02-25
Read-in of StdHEP events, self-tests
2015-02-22
Bug fix for mother-daughter relations in
showered/hadronized events
2015-02-20
Projection on polarization in intermediate states
2015-02-13
Correct treatment of beam remnants in
event formats (also LC remnants)
##################################################################
2015-02-06
RELEASE: version 2.2.4
2015-02-06
Bug fix in event output
2015-02-05
LCIO event format supported
2015-01-30
Including state matrices in WHIZARD's internal IO
Versioning for WHIZARD's internal IO
Libtool update from 2.4.3 to 2.4.5
LCIO event output (beta version)
2015-01-27
Progress on NLO integration
Fixing a bug for multiple processes in a single
event file when using beam event files
2015-01-19
Bug fix for spin correlations evaluated in the rest
frame of the mother particle
2015-01-17
Regression fix for statically linked processes
from SARAH and FeynRules
2015-01-10
NLO: massive FKS emitters supported (experimental)
2015-01-06
MMHT2014 PDF sets included
2015-01-05
Handling mass degeneracies in auto_decays
2014-12-19
Fixing bug in rescan of event files
##################################################################
2014-11-30
RELEASE: version 2.2.3
2014-11-29
Beta version of LO continuum/NLL-threshold
matched top threshold model for e+e- physics
2014-11-28
More internal refactoring: disentanglement of module
dependencies
2014-11-21
OVM: O'Mega Virtual Machine, bytecode instructions
instead of compiled Fortran code
2014-11-01
Higgs Singlet extension model included
2014-10-18
Internal restructuring of code; half-way
WHIZARD main code file disassembled
2014-07-09
Alpha version of NLO infrastructure
##################################################################
2014-07-06
RELEASE: version 2.2.2
2014-07-05
CIRCE2: correlated LC beam spectra and
GuineaPig Interface to LC machine parameters
2014-07-01
Reading LHEF for decayed/factorized/showered/
hadronized events
2014-06-25
Configure support for GoSAM/Ninja/Form/QGraf
2014-06-22
LHAPDF6 interface
2014-06-18
Module for automatic generation of
radiation and loop infrastructure code
2014-06-11
Improved internal directory structure
##################################################################
2014-06-03
RELEASE: version 2.2.1
2014-05-30
Extensions of internal PDG arrays
2014-05-26
FastJet interface
2014-05-24
CJ12 PDFs included
2014-05-20
Regression fix for external models (via SARAH
or FeynRules)
##################################################################
2014-05-18
RELEASE: version 2.2.0
2014-04-11
Multiple components: inclusive process definitions,
syntax: process A + B + ...
2014-03-13
Improved PS mappings for e+e- ISR
ILC TDR and CLIC spectra included in CIRCE1
2014-02-23
New models: AltH w\ Higgs for exclusion purposes,
SM_rx for Dim 6-/Dim-8 operators, SSC for
general strong interactions (w/ Higgs), and
NoH_rx (w\ Higgs)
2014-02-14
Improved s-channel mapping, new on-shell
production mapping (e.g. Drell-Yan)
2014-02-03
PRE-RELEASE: version 2.2.0_beta
2014-01-26
O'Mega: Feynman diagram generation possible (again)
2013-12-16
HOPPET interface for b parton matching
2013-11-15
PRE-RELEASE: version 2.2.0_alpha-4
2013-10-27
LHEF standards 1.0/2.0/3.0 implemented
2013-10-15
PRE-RELEASE: version 2.2.0_alpha-3
2013-10-02
PRE-RELEASE: version 2.2.0_alpha-2
2013-09-25
PRE-RELEASE: version 2.2.0_alpha-1
2013-09-12
PRE-RELEASE: version 2.2.0_alpha
2013-09-03
General 2HDM implemented
2013-08-18
Rescanning/recalculating events
2013-06-07
Reconstruction of complete event
from 4-momenta possible
2013-05-06
Process library stacks
2013-05-02
Process stacks
2013-04-29
Single-particle phase space module
2013-04-26
Abstract interface for random
number generator
2013-04-24
More object-orientation on modules
Midpoint-rule integrator
2013-04-05
Object-oriented integration and
event generation
2013-03-12
Processes recasted object-oriented:
MEs, scales, structure functions
First infrastructure for general Lorentz
structures
2013-01-17
Object-orientated reworking of library and
process core, more variable internal structure,
unit tests
2012-12-14
Update Pythia version to 6.4.27
2012-12-04
Fix the phase in HAZ vertices
2012-11-21
First O'Mega unit tests, some infrastructure
2012-11-13
Bug fix in anom. HVV Lorentz structures
##################################################################
2012-09-18
RELEASE: version 2.1.1
2012-09-11
Model MSSM_Hgg with Hgg and HAA vertices
2012-09-10
First version of implementation of multiple
interactions in WHIZARD
2012-09-05
Infrastructure for internal CKKW matching
2012-09-02
C, C++, Python API
2012-07-19
Fixing particle numbering in HepMC format
##################################################################
2012-06-15
RELEASE: version 2.1.0
2012-06-14
Analytical and kT-ordered shower officially
released
PYTHIA interface officially released
2012-05-09
Intrisince PDFs can be used for showering
2012-05-04
Anomalous Higgs couplings a la hep-ph/9902321
##################################################################
2012-03-19
RELEASE: version 2.0.7
2012-03-15
Run IDs are available now
More event variables in analysis
Modified raw event format (compatibility mode exists)
2012-03-12
Bug fix in decay-integration order
MLM matching steered completely internally now
2012-03-09
Special phase space mapping for narrow resonances
decaying to 4-particle final states with far off-shell
intermediate states
Running alphas from PDF collaborations with
builtin PDFs
2012-02-16
Bug fix in cascades decay infrastructure
2012-02-04
WHIZARD documentation compatible with TeXLive 2011
2012-02-01
Bug fix in FeynRules interface with --prefix flag
2012-01-29
Bug fix with name clash of O'Mega variable names
2012-01-27
Update internal PYTHIA to version 6.4.26
Bug fix in LHEF output
2012-01-21
Catching stricter automake 1.11.2 rules
2011-12-23
Bug fix in decay cascade setup
2011-12-20
Bug fix in helicity selection rules
2011-12-16
Accuracy goal reimplemented
2011-12-14
WHIZARD compatible with TeXLive 2011
2011-12-09
Option --user-target added
##################################################################
2011-12-07
RELEASE: version 2.0.6
2011-12-07
Bug fixes in SM_top_anom
Added missing entries to HepMC format
2011-12-06
Allow to pass options to O'Mega
Bug fix for HEPEVT block for showered/hadronized events
2011-12-01
Reenabled user plug-in for external code for
cuts, structure functions, routines etc.
2011-11-29
Changed model SM_Higgs for Higgs phenomenology
2011-11-25
Supporting a Y, (B-L) Z' model
2011-11-23
Make WHIZARD compatible for MAC OS X Lion/XCode 4
2011-09-25
WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742
2011-08-16
Model SM_QCD: QCD with one EW insertion
2011-07-19
Explicit output channel for dvips avoids printing
2011-07-10
Test suite for WHIZARD unit tests
2011-07-01
Commands for matrix element tests
More OpenMP parallelization of kinematics
Added unit tests
2011-06-23
Conversion of CIRCE2 from F77 to F90, major
clean-up
2011-06-14
Conversion of CIRCE1 from F77 to F90
2011-06-10
OpenMP parallelization of channel kinematics
(by Matthias Trudewind)
2011-05-31
RELEASE: version 1.97
2011-05-24
Minor bug fixes: update grids and elsif statement.
##################################################################
2011-05-10
RELEASE: version 2.0.5
2011-05-09
Fixed bug in final state flavor sums
Minor improvements on phase-space setup
2011-05-05
Minor bug fixes
2011-04-15
WHIZARD as a precompiled 64-bit binary available
2011-04-06
Wall clock instead of cpu time for time estimates
2011-04-05
Major improvement on the phase space setup
2011-04-02
OpenMP parallelization for helicity loop in O'Mega
matrix elements
2011-03-31
Tools for relocating WHIZARD and use in batch
environments
2011-03-29
Completely static builds possible, profiling options
2011-03-28
Visualization of integration history
2011-03-27
Fixed broken K-matrix implementation
2011-03-23
Including the GAMELAN manual in the distribution
2011-01-26
WHIZARD analysis can handle hadronized event files
2011-01-17
MSTW2008 and CT10 PDF sets included
2010-12-23
Inclusion of NMSSM with Hgg couplings
2010-12-21
Advanced options for integration passes
2010-11-16
WHIZARD supports CTEQ6 and possibly other PDFs
directly; data files included in the distribution
##################################################################
2010-10-26
RELEASE: version 2.0.4
2010-10-06
Bug fix in MSSM implementation
2010-10-01
Update to libtool 2.4
2010-09-29
Support for anomalous top couplings (form factors etc.)
Bug fix for running gauge Yukawa SUSY couplings
2010-09-28
RELEASE: version 1.96
2010-09-21
Beam remnants and pT spectra for lepton collider re-enabled
Restructuring subevt class
2010-09-16
Shower and matching are disabled by default
PYTHIA as a conditional on these two options
2010-09-14
Possibility to read in beam spectra re-enabled (e.g. Guinea
Pig)
2010-09-13
Energy scan as (pseudo-) structure functions re-implemented
2010-09-10
CIRCE2 included again in WHIZARD 2 and validated
2010-09-02
Re-implementation of asymmetric beam energies and collision
angles, e-p collisions work, inclusion of a HERA DIS test
case
##################################################################
2010-10-18
RELEASE: version 2.0.3
2010-08-08
Bug in CP-violating anomalous triple TGCs fixed
2010-08-06
Solving backwards compatibility problem with O'Caml 3.12.0
2010-07-12
Conserved quantum numbers speed up O'Mega code generation
2010-07-07
Attaching full ISR/FSR parton shower and MPI/ISR
module
Added SM model containing Hgg, HAA, HAZ vertices
2010-07-02
Matching output available as LHEF and STDHEP
2010-06-30
Various bug fixes, missing files, typos
2010-06-26
CIRCE1 completely re-enabled
Chaining structure functions supported
2010-06-25
Partial support for conserved quantum numbers in
O'Mega
2010-06-21
Major upgrade of the graphics package: error bars,
smarter SINDARIN steering, documentation, and all that...
2010-06-17
MLM matching with PYTHIA shower included
2010-06-16
Added full CIRCE1 and CIRCE2 versions including
full documentation and miscellanea to the trunk
2010-06-12
User file management supported, improved variable
and command structure
2010-05-24
Improved handling of variables in local command lists
2010-05-20
PYTHIA interface re-enabled
2010-05-19
ASCII file formats for interfacing ROOT and gnuplot in
data analysis
##################################################################
2010-05-18
RELEASE: version 2.0.2
2010-05-14
Reimplementation of visualization of phase space
channels
Minor bug fixes
2010-05-12
Improved phase space - elimination of redundancies
2010-05-08
Interface for polarization completed: polarized beams etc.
2010-05-06
Full quantum numbers appear in process log
Integration results are usable as user variables
Communication with external programs
2010-05-05
Split module commands into commands, integration,
simulation modules
2010-05-04
FSR+ISR for the first time connected to the WHIZARD 2 core
##################################################################
2010-04-25
RELEASE: version 2.0.1
2010-04-23
Automatic compile and integrate if simulate is called
Minor bug fixes in O'Mega
2010-04-21
Checkpointing for event generation
Flush statements to use WHIZARD inside a pipe
2010-04-20
Reimplementation of signal handling in WGIZARD 2.0
2010-04-19
VAMP is now a separately configurable and installable unit of
WHIZARD, included VAMP self-checks
Support again compilation in quadruple precision
2010-04-06
Allow for logarithmic plots in GAMELAN, reimplement the
possibility to set the number of bins
2010-04-15
Improvement on time estimates for event generation
##################################################################
2010-04-12
RELEASE: version 2.0.0
2010-04-09
Per default, the code for the amplitudes is subdivided to allow
faster compiler optimization
More advanced and unified and straightforward command language
syntax
Final bug fixes
2010-04-07
Improvement on SINDARIN syntax; printf, sprintf function
thorugh a C interface
2010-04-05
Colorizing DAGs instead of model vertices: speed boost
in colored code generation
2010-03-31
Generalized options for normalization of weighted and
unweighted events
Grid and weight histories added again to log files
Weights can be used in analyses
2010-03-28
Cascade decays completely implemented including color and
spin correlations
2010-03-07
Added new WHIZARD header with logo
2010-03-05
Removed conflict in O'Mega amplitudes between flavour sums
and cascades
StdHEP interface re-implemented
2010-03-03
RELEASE: version 2.0.0rc3
Several bug fixes for preventing abuse in input files
OpenMP support for amplitudes
Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
FeynRules interface successfully passed MSSM test
2010-02-26
Eliminating ghost gluons from multi-gluon amplitudes
2010-02-25
RELEASE: version 1.95
HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2
2010-02-23
Running alpha_s implemented in the FeynRules interface
2010-02-19
MSSM (semi-) automatized self-tests finalized
2010-02-17
RELEASE: version 1.94
2010-02-16
Closed memory corruption in WHIZARD 1
Fixed problems of old MadGraph and CompHep drivers
with modern compilers
Uncolored vertex selection rules for colored amplitudes in
O'Mega
2010-02-15
Infrastructure for color correlation computation in O'Mega
finished
Forbidden processes are warned about, but treated as non-fatal
2010-02-14
Color correlation computation in O'Mega finalized
2010-02-10
Improving phase space mappings for identical particles in
initial and final states
Introduction of more extended multi-line error message
2010-02-08
First O'Caml code for computation of color correlations in
O'Mega
2010-02-07
First MLM matching with e+ e- -> jets
##################################################################
2010-02-06
RELEASE: version 2.0.0rc2
2010-02-05
Reconsidered the Makefile structure and more extended tests
Catch a crash between WHIZARD and O'Mega for forbidden processes
Tensor products of arbitrary color structures in jet definitions
2010-02-04
Color correlation computation in O'Mega finalized
##################################################################
2010-02-03
RELEASE: version 2.0.0rc1
##################################################################
2010-01-31
Reimplemented numerical helicity selection rules
Phase space functionality of version 1 restored and improved
2009-12-05
NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)
2009-12-04
RELEASE: version 2.0.0alpha
##################################################################
2009-04-16
RELEASE: version 1.93
2009-04-15
Clean-up of Makefiles and configure scripts
Reconfiguration of BSM model implementation
extended supersymmetric models
2008-12-23
New model NMSSM (Felix Braam)
SLHA2 added
Bug in LHAPDF interface fixed
2008-08-16
Bug fixed in K matrix implementation
Gravitino option in the MSSM added
2008-03-20
Improved color and flavor sums
##################################################################
2008-03-12
RELEASE: version 1.92
LHEF (Les Houches Event File) format added
Fortran 2003 command-line interface (if supported by the compiler)
Automated interface to colored models
More bug fixes and workarounds for compiler compatibility
##################################################################
2008-03-06
RELEASE: version 1.91
New model K-matrix (resonances and anom. couplings in WW scattering)
EWA spectrum
Energy-scan pseudo spectrum
Preliminary parton shower module (only from final-state quarks)
Cleanup and improvements of configure process
Improvements for O'Mega parameter files
Quadruple precision works again
More plotting options: lines, symbols, errors
Documentation with PDF bookmarks enabled
Various bug fixes
2007-11-29
New model UED
##################################################################
2007-11-23
RELEASE: version 1.90
O'Mega now part of the WHIZARD tree
Madgraph/CompHEP disabled by default (but still usable)
Support for LHAPDF (preliminary)
Added new models: SMZprime, SM_km, Template
Improved compiler recognition and compatibility
Minor bug fixes
##################################################################
2006-06-15
RELEASE: version 1.51
Support for anomaly-type Higgs couplings (to gluon and photon/Z)
Support for spin 3/2 and spin 2
New models: Little Higgs (4 versions), toy models for extra dimensions
and gravitinos
Fixes to the whizard.nw source documentation to run through LaTeX
Intel 9.0 bug workaround (deallocation of some arrays)
2006-05-15
O'Mega RELEASE: version 0.11
merged JRR's O'Mega extensions
##################################################################
2006-02-07
RELEASE: version 1.50
To avoid confusion: Mention outdated manual example in BUGS file
O'Mega becomes part of the WHIZARD generator
2006-02-02 [bug fix update]
Bug fix: spurious error when writing event files for weighted events
Bug fix: 'r' option for omega produced garbage for some particle names
Workaround for ifort90 bug (crash when compiling whizard_event)
Workaround for ifort90 bug (crash when compiling hepevt_common)
2006-01-27
Added process definition files for MSSM 2->2 processes
Included beam recoil for EPA (T.Barklow)
Updated STDHEP byte counts (for STDHEP 5.04.02)
Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
Fixed issue with comphep requiring Xlibs on Opteron
Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
Fixed color-flow code: was broken for omega with option 'c' and 'w'
Workaround hacks for g95 compatibility
2005-11-07
O'Mega RELEASE: version 0.10
O'Mega, merged JRR's and WK's color hack for WHiZard
O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
a la JRR/WK)
O'Mega, make JRR's MSSM official
##################################################################
2005-10-25
RELEASE: version 1.43
Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
This should be final, since the MSSM results agree now completely
with Madgraph and Sherpa
User-defined lower and upper limits for split event file count
Allow for counters (events, bytes) exceeding $2^{31}$
Revised checksum treatment and implementation (now MD5)
Bug fix: missing process energy scale in raw event file
##################################################################
2005-09-30
RELEASE: version 1.42
Graphical display of integration history ('make history')
Allow for switching off signals even if supported (configure option)
2005-09-29
Revised phase space generation code, in particular for flavor sums
Negative cut and histogram codes use initial beams instead of
initial parton momenta. This allows for computing, e.g., E_miss
Support constant-width and zero-width options for O'Mega
Width options now denoted by w:X (X=f,c,z). f option obsolescent
Bug fix: colorized code: flipped indices could screw up result
Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
Bug fix: dvips on systems where dvips defaults to lpr
Bug fix: integer overflow if too many events are requested
2005-07-29
Allow for 2 -> 1 processes (if structure functions are on)
2005-07-26
Fixed and expanded the 'test' matrix element:
Unit matrix element with option 'u' / default: normalized phase space
##################################################################
2005-07-15
RELEASE: version 1.41
Bug fix: no result for particle decay processes with width=0
Bug fix: line breaks in O'Mega files with color decomposition
2005-06-02
New self-tests (make test-QED / test-QCD / test-SM)
check lists of 2->2 processes
Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)
2005-05-25
Revised Makefile structure
Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)
2005-05-19
Support for color in O'Mega (using color flow decomposition)
New model QCD
Parameter file changes that correspond to replaced SM module in O'Mega
Bug fixes in MSSM (O'Mega) parameter file
2005-05-18
New event file formats, useful for LHC applications:
ATHENA and Les Houches Accord (external fragmentation)
Naive (i.e., leading 1/N) color factor now implemented both for
incoming and outgoing partons
2005-01-26
include missing HELAS files for bundle
pgf90 compatibility issues [note: still internal error in pgf90]
##################################################################
2004-12-13
RELEASE: version 1.40
compatibility fix: preprocessor marks in helas code now commented out
minor bug fix: format string in madgraph source
2004-12-03
support for arbitray beam energies and directions
allow for pT kick in structure functions
bug fix: rounding error could result in zero cross section
(compiler-dependent)
2004-10-07
simulate decay processes
list fraction (of total width/cross section) instead of efficiency
in process summary
new cut/analysis parameters AA, AAD, CTA: absolute polar angle
2004-10-04
Replaced Madgraph I by Madgraph II. Main improvement: model no
longer hardcoded
introduced parameter reset_seed_each_process (useful for debugging)
bug fix: color initialization for some processes was undefined
2004-09-21
don't compile unix_args module if it is not required
##################################################################
2004-09-20
RELEASE: version 1.30
g95 compatibility issues resolved
some (irrelevant) memory leaks closed
removed obsolete warning in circe1
manual update (essentially) finished
2004-08-03
O'Mega RELEASE: version 0.9
O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
the O'Caml 3.08 library (remains compatible with older
versions). Implementation of unused functions still
incomplete.
2004-07-26
minor fixes and improvements in make process
2004-06-29
workarounds for new Intel compiler bugs ...
no rebuild of madgraph/comphep executables after 'make clean'
bug fix in phase space routine:
wrong energy for massive initial particles
bug fix in (new) model interface: name checks for antiparticles
pre-run checks for comphep improved
ww-strong model file extended
Model files particle name fixes, chep SM vertices included
2004-06-22
O'Mega RELEASE: version 0.8
O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings
2004-05-05
Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
NAG compiler: set number of continuation lines to 200 as default
Extended format for cross section summary; appears now in whizard.out
Fixed 'bundle' feature
2004-04-28
Fixed compatibility with revised O'Mega SM_ac model
Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
Fixed bug in comphep module: Vtb was overlooked
##################################################################
2004-04-15
RELEASE: version 1.28
Fixed bug: Color factor was missing for O'Mega processes with
four quarks and more
Manual partially updated
2004-04-08
Support for grid files in binary format
New default value show_histories=F (reduce output file size)
Revised phase space switches: removed annihilation_lines,
removed s_channel_resonance, changed meaning of
extra_off_shell_lines, added show_deleted_channels
Bug fixed which lead to omission of some phase space channels
Color flow guessed only if requested by guess_color_flow
2004-03-10
New model interface: Only one model name specified in whizard.prc
All model-dependent files reside in conf/models (modellib removed)
2004-03-03
Support for input/output in SUSY Les Houches Accord format
Split event files if requested
Support for overall time limit
Support for CIRCE and CIRCE2 generator mode
Support for reading beam events from file
2004-02-05
Fixed compiler problems with Intel Fortran 7.1 and 8.0
Support for catching signals
##################################################################
2003-08-06
RELEASE: version 1.27
User-defined PDF libraries as an alternative to the standard PDFLIB
2003-07-23
Revised phase space module: improved mappings for massless particles,
equivalences of phase space channels are exploited
Improved mapping for PDF (hadron colliders)
Madgraph module: increased max number of color flows from 250 to 1000
##################################################################
2003-06-23
RELEASE: version 1.26
CIRCE2 support
Fixed problem with 'TC' integer kind [Intel compiler complained]
2003-05-28
Support for drawing histograms of grids
Bug fixes for MSSM definitions
##################################################################
2003-05-22
RELEASE: version 1.25
Experimental MSSM support with ISAJET interface
Improved capabilities of generating/analyzing weighted events
Optional drawing phase space diagrams using FeynMF
##################################################################
2003-01-31
RELEASE: version 1.24
A few more fixes and workarounds (Intel and Lahey compiler)
2003-01-15
Fixes and workarounds needed for WHIZARD to run with Intel compiler
Command-line option interface for the Lahey compiler
Bug fix: problem with reading whizard.phs
##################################################################
2002-12-10
RELEASE: version 1.23
Command-line options (on some systems)
Allow for initial particles in the event record, ordered:
[beams, initials] - [remnants] - outgoing partons
Support for PYTHIA 6.2: Les Houches external process interface
String pythia_parameters can be up to 1000 characters long
Select color flow states in (internal) analysis
Bug fix in color flow content of raw event files
Support for transversal polarization of fermion beams
Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
'Test' matrix elements optionally respect polarization
User-defined code can be inserted for spectra, structure functions
and fragmentation
Time limits can be specified for adaptation and simulation
User-defined file names and file directory
Initial weights in input file no longer supported
Bug fix in MadGraph (wave function counter could overflow)
Bug fix: Gamelan (graphical analysis) was not built if noweb absent
##################################################################
2002-03-16
RELEASE: version 1.22
Allow for beam remnants in the event record
2002-03-01
Handling of aliases in whizard.prc fixed (aliases are whole tokens)
2002-02-28
Optimized phase space handling routines
(total execution time reduced by 20-60%, depending on process)
##################################################################
2002-02-26
RELEASE: version 1.21
Fixed ISR formula (ISR was underestimated in previous versions).
New version includes ISR in leading-log approximation up to
third order. Parameter ISR_sqrts renamed to ISR_scale.
##################################################################
2002-02-19
RELEASE: version 1.20
New process-generating method 'test' (dummy matrix element)
Compatibility with autoconf 2.50 and current O'Mega version
2002-02-05
Prevent integration channels from being dropped (optionally)
New internal mapping for structure functions improves performance
Old whizard.phx file deleted after recompiling (could cause trouble)
2002-01-24
Support for user-defined cuts and matrix element reweighting
STDHEP output now written by write_events_format=20 (was 3)
2002-01-16
Improved structure function handling; small changes in user interface:
new parameter structured_beams in &process_input
parameter fixed_energy in &beam_input removed
Support for multiple initial states
Eta-phi (cone) cut possible (hadron collider applications)
Fixed bug: Whizard library was not always recompiled when necessary
Fixed bug: Default cuts were insufficient in some cases
Fixed bug: Unusable phase space mappings generated in some cases
2001-12-06
Reorganized document source
2001-12-05
Preliminary CIRCE2 support (no functionality yet)
2001-11-27
Intel compiler support (does not yet work because of compiler bugs)
New cut and analysis mode cos-theta* and related
Fixed circular jetset_interface dependency warning
Some broadcast routines removed (parallel support disabled anyway)
Minor shifts in cleanup targets (Makefiles)
Modified library search, check for pdflib8*
2001-08-06
Fixed bug: I/O unit number could be undefined when reading phase space
Fixed bug: Unitialized variable could cause segfault when
event generation was disabled
Fixed bug: Undefined subroutine in CIRCE replacement module
Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
(CompHEP model sm-GF #5, O'Mega model SM_ac)
Fixed portability issue: Makefile did rely on PWD environment variable
Fixed portability issue: PYTHIA library search ambiguity resolved
2001-08-01
Default whizard.prc and whizard.in depend on activated modules
Fixed bug: TEX=latex was not properly enabled when making plots
2001-07-20
Fixed output settings in PERL script calls
Cache enabled in various configure checks
2001-07-13
Support for multiple processes in a single WHIZARD run. The
integrations are kept separate, but the generated events are mixed
The whizard.evx format has changed (incompatible), including now
the color flow information for PYTHIA fragmentation
Output files are now process-specific, except for the event file
Phase space file whizard.phs (if present) is used only as input,
program-generated phase space is now in whizard.phx
2001-07-10
Bug fix: Undefined parameters in parameters_SM_ac.f90 removed
2001-07-04
Bug fix: Compiler options for the case OMEGA is disabled
Small inconsistencies in whizard.out format fixed
2001-07-01
Workaround for missing PDFLIB dummy routines in PYTHIA library
##################################################################
2001-06-30
RELEASE: version 1.13
Default path /cern/pro/lib in configure script
2001-06-20
New fragmentation option: Interface for PYTHIA with full color flow
information, beam remnants etc.
2001-06-18
Severe bug fixed in madgraph interface: 3-gluon coupling was missing
Enabled color flow information in madgraph
2001-06-11
VAMP interface module rewritten
Revised output format: Multiple VAMP iterations count as one WHIZARD
iteration in integration passes 1 and 3
Improved message and error handling
Bug fix in VAMP: handle exceptional cases in rebinning_weights
2001-05-31
new parameters for grid adaptation: accuracy_goal and efficiency_goal
##################################################################
2001-05-29
RELEASE: version 1.12
bug fixes (compilation problems): deleted/modified unused functions
2001-05-16
diagram selection improved and documented
2001-05-06
allow for disabling packages during configuration
2001-05-03
slight changes in whizard.out format; manual extended
##################################################################
2001-04-20
RELEASE: version 1.11
fixed some configuration and compilation problems (PDFLIB etc.)
2001-04-18
linked PDFLIB: support for quark/gluon structure functions
2001-04-05
parameter interface written by PERL script
SM_ac model file: fixed error in continuation line
2001-03-13
O'Mega, O'Caml 3.01: incompatible changes
O'Mega, src/trie.mli: add covariance annotation to T.t
This breaks O'Caml 3.00, but is required for O'Caml 3.01.
O'Mega, many instances: replace `sig include Module.T end' by
`Module.T', since the bug is fixed in O'Caml 3.01
2001-02-28
O'Mega, src/model.mli:
new field Model.vertices required for model functors, will
retire Model.fuse2, Model.fuse3, Model.fusen soon.
##################################################################
2001-03-27
RELEASE: version 1.10
reorganized the modules as libraries
linked PYTHIA: support for parton fragmentation
2000-12-14
fixed some configuration problems (if noweb etc. are absent)
##################################################################
2000-12-01
RELEASE of first public version: version 1.00beta