Page MenuHomeHEPForge
Files F10880978

threshold.nw
No OneTemporary
Actions

threshold.nw
View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
% -*- 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>>
<<Standard module head>>
save
<<Interpolation: public>>
public :: interpolate_linear, strictly_monotonous
<<Interpolation: interfaces>>
interface
<<Interpolation: sub interfaces>>
end interface
end module interpolation
@ %def interpolation
@
<<[[interpolation_sub.f90]]>>=
<<File header>>
submodule (interpolation) interpolation_s
implicit none
<<Interpolation: parameters>>
contains
<<Interpolation: procedures>>
end submodule interpolation_s
@ %def interpolation_s
@
<<Interpolation: interfaces>>=
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
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
complex(default), dimension(:), intent(in) :: ya
real(default), intent(in) :: x
complex(default), intent(out) :: y
end subroutine interpolate_linear_1D_complex_scalar
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
complex(default), dimension(:), intent(in) :: ya
real(default), intent(in) :: x
complex(default), intent(out) :: y
integer :: ixl
real(default) :: t
y = 0.0_default
!!! don't check this at runtime:
! if ( .not.monotonous(xa) ) return
if ( out_of_range(xa, x) ) return
ixl = 0
call find_nearest_left (xa, x, ixl)
t = ( x - xa(ixl) ) / ( xa(ixl+1) - xa(ixl) )
y = (1.-t)*ya(ixl) + t*ya(ixl+1)
end subroutine interpolate_linear_1D_complex_scalar
@ %def interpolate_linear_1D_complex_scalar
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
complex(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
complex(default), intent(out) :: y
end subroutine interpolate_linear_2D_complex_scalar
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
complex(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
complex(default), intent(out) :: y
integer :: ix1l, ix2l
real(default) :: t, u
y = 0.0_default
!!! don't check this at runtime:
! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return
if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) ) return
ix1l = 0
call find_nearest_left (x1a, x1, ix1l)
ix2l = 0
call find_nearest_left (x2a, x2, ix2l)
t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) )
u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) )
y = (1.-t)*(1.-u)*ya(ix1l ,ix2l ) &
+ t *(1.-u)*ya(ix1l+1,ix2l ) &
+ t * u *ya(ix1l+1,ix2l+1) &
+(1.-t)* u *ya(ix1l ,ix2l+1)
end subroutine interpolate_linear_2D_complex_scalar
@ %def interpolate_linear_2D_complex_scalar
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_3D_complex_scalar &
(x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
complex(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
complex(default), intent(out) :: y
end subroutine interpolate_linear_3D_complex_scalar
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_3D_complex_scalar &
(x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
complex(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
complex(default), intent(out) :: y
integer :: ix1l, ix2l, ix3l
real(default) :: t, u, v
y = 0.0_default
!!! don't check this at runtime:
! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return
if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) .or. out_of_range(x3a, x3) ) return
ix1l = 0
call find_nearest_left (x1a, x1, ix1l)
ix2l = 0
call find_nearest_left (x2a, x2, ix2l)
ix3l = 0
call find_nearest_left (x3a, x3, ix3l)
t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) )
u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) )
v = ( x3 - x3a(ix3l) ) / ( x3a(ix3l+1) - x3a(ix3l) )
y = (1.-t)*(1.-u)*(1.-v)*ya(ix1l ,ix2l ,ix3l ) &
+(1.-t)*(1.-u)* v *ya(ix1l ,ix2l ,ix3l+1) &
+(1.-t)* u *(1.-v)*ya(ix1l ,ix2l+1,ix3l ) &
+(1.-t)* u * v *ya(ix1l ,ix2l+1,ix3l+1) &
+ t *(1.-u)*(1.-v)*ya(ix1l+1,ix2l ,ix3l ) &
+ t *(1.-u)* v *ya(ix1l+1,ix2l ,ix3l+1) &
+ t * u *(1.-v)*ya(ix1l+1,ix2l+1,ix3l ) &
+ t * u * v *ya(ix1l+1,ix2l+1,ix3l+1)
end subroutine interpolate_linear_3D_complex_scalar
@ %def interpolate_linear_3D_complex_scalar
@
<<Interpolation: sub interfaces>>=
pure module subroutine find_nearest_left_loop (xa, x, ixl)
real(default), dimension(:), intent(in) :: xa
real(default), intent(in) :: x
integer, intent(out) :: ixl
end subroutine find_nearest_left_loop
<<Interpolation: procedures>>=
pure module subroutine find_nearest_left_loop (xa, x, ixl)
real(default), dimension(:), intent(in) :: xa
real(default), intent(in) :: x
integer, intent(out) :: ixl
integer :: ixm, ixr
ixl = 1
ixr = size(xa)
do
if ( ixr-ixl <= 1 ) return
ixm = (ixr+ixl) / 2
if ( x < xa(ixm) ) then
ixr = ixm
else
ixl = ixm
end if
end do
end subroutine find_nearest_left_loop
@ %def find_nearest_left_loop
@
<<Interpolation: procedures>>=
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
@ %def find_nearest_left_rec
@
<<Interpolation: sub interfaces>>=
pure module function monotonous (xa) result (flag)
real(default), dimension(:), intent(in) :: xa
logical :: flag
end function monotonous
<<Interpolation: procedures>>=
pure module function monotonous (xa) result (flag)
real(default), dimension(:), intent(in) :: xa
integer :: ix
logical :: flag
flag = .false.
do ix = 1, size(xa)-1
flag = ( xa(ix) < xa(ix+1) )
if ( .not. flag ) return
end do
end function monotonous
@ %def monotonous
@
<<Interpolation: procedures>>=
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
@ %def out_of_range
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_1D_complex_array (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
complex(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x
complex(default), dimension(size(ya(1,:))), intent(out) :: y
end subroutine interpolate_linear_1D_complex_array
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_1D_complex_array (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
complex(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x
complex(default), dimension(size(ya(1,:))), intent(out) :: y
integer :: iy
do iy=1, size(y)
call interpolate_linear_1D_complex_scalar (xa, ya(:,iy), x, y(iy))
end do
end subroutine interpolate_linear_1D_complex_array
@ %def interpolate_linear_1D_complex_array
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_1D_real_array (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
real(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x
real(default), dimension(:), intent(out) :: y
end subroutine interpolate_linear_1D_real_array
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_1D_real_array (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
real(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x
real(default), dimension(:), intent(out) :: y
complex(default), dimension(size(ya(1,:))) :: y_c
call interpolate_linear_1D_complex_array (xa, cmplx(ya,kind=default), x, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_1D_real_array
@ %def interpolate_linear_1D_real_array
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
real(default), dimension(:), intent(in) :: ya
real(default), intent(in) :: x
real(default), intent(out) :: y
complex(default), dimension(size(ya)) :: ya_c
end subroutine interpolate_linear_1D_real_scalar
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
real(default), dimension(:), intent(in) :: ya
real(default), intent(in) :: x
real(default), intent(out) :: y
complex(default), dimension(size(ya)) :: ya_c
complex(default) :: y_c
ya_c = cmplx(ya,kind=default)
call interpolate_linear_1D_complex_scalar (xa, ya_c, x, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_1D_real_scalar
@ %def interpolate_linear_1D_real_scalar
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
complex(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
complex(default), dimension(size(ya(1,1,:))), intent(out) :: y
end subroutine interpolate_linear_2D_complex_array
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
complex(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
complex(default), dimension(size(ya(1,1,:))), intent(out) :: y
integer :: iy
do iy=1, size(y)
call interpolate_linear_2D_complex_scalar (x1a, x2a, ya(:,:,iy), x1, x2, y(iy))
end do
end subroutine interpolate_linear_2D_complex_array
@ %def interpolate_linear_2D_complex_array
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), dimension(:), intent(out) :: y
end subroutine interpolate_linear_2D_real_array
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), dimension(:), intent(out) :: y
complex(default), dimension(size(ya(1,1,:))) :: y_c
call interpolate_linear_2D_complex_array (x1a, x2a, cmplx(ya,kind=default), x1, x2, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_2D_real_array
@ %def interpolate_linear_2D_real_array
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(out) :: y
end subroutine interpolate_linear_2D_real_scalar
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(out) :: y
complex(default), dimension(size(ya(:,1)),size(ya(1,:))) :: ya_c
complex(default) :: y_c
ya_c = reshape (ya_c, shape(ya))
ya_c = cmplx(ya,kind=default)
call interpolate_linear_2D_complex_scalar (x1a, x2a, ya_c, x1, x2, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_2D_real_scalar
@ %def interpolate_linear_2D_real_scalar
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_3D_complex_array &
(x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
complex(default), dimension(:,:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
complex(default), dimension(size(ya(1,1,1,:))), intent(out) :: y
end subroutine interpolate_linear_3D_complex_array
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_3D_complex_array &
(x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
complex(default), dimension(:,:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
complex(default), dimension(size(ya(1,1,1,:))), intent(out) :: y
integer :: iy
do iy=1, size(y)
call interpolate_linear_3D_complex_scalar &
(x1a, x2a, x3a, ya(:,:,:,iy), x1, x2, x3, y(iy))
end do
end subroutine interpolate_linear_3D_complex_array
@ %def interpolate_linear_3D_complex_array
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
real(default), dimension(:,:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
real(default), dimension(:), intent(out) :: y
end subroutine interpolate_linear_3D_real_array
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
real(default), dimension(:,:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
real(default), dimension(:), intent(out) :: y
complex(default), dimension(size(ya(1,1,1,:))) :: y_c
call interpolate_linear_3D_complex_array &
(x1a, x2a, x3a, cmplx(ya,kind=default), x1, x2, x3, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_3D_real_array
@ %def interpolate_linear_3D_real_array
@
<<Interpolation: sub interfaces>>=
pure module subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
real(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
real(default), intent(out) :: y
end subroutine interpolate_linear_3D_real_scalar
<<Interpolation: procedures>>=
pure module subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
real(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
real(default), intent(out) :: y
complex(default), dimension(size(ya(:,1,1)),size(ya(1,:,1)),size(ya(1,1,:))) :: ya_c
complex(default) :: y_c
ya_c = cmplx(ya,kind=default)
call interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya_c, x1, x2, x3, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_3D_real_scalar
@ %def interpolate_linear_3D_real_scalar
@
<<[[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 DILOGG
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
DATA PI/3.14159265/
F(X)= PI**2+2*DILOGG(X)-2*DILOGG(1-X)+( 4*X*(1-X-2*X**2)*LOG(X)+
$2*(1-X)**2*(5+4*X)*LOG(1-X) - (1-X)*(5+9*X-6*X**2) ) /
$(2*(1-X)**2*(1+2*X))
Y= (WMASS/TMASS)**2
cc alpha_s(M_t) corresponding to alpha_s(M_Z)=0.118:
cc alphas=0.107443d0
cc write(*,*) 'alphas=',alphas
c Usage of alpha_s as given as input for the potential.. better use
c alpha_s at a scale close to m_t..
TGAMMA= GFERMI*TMASS**3/(8*SQRT(2D0)*PI)*(1-Y)**2*(1+2*Y)*
$(1- 2D0/3*ALPHAS/PI*F(Y))
END
C
C
REAL*8 FUNCTION GAMTPE(P,ETOT)
C
C momentum dependent width of top quark in t-tbar system
C GAMTPE = TGAMMA*GTPCOR(P,E), where TGAMMA includes
C QCD corrections, see JKT, eq.(8), and
C GTPCOR - correction factor for bound t quark
C
IMPLICIT REAL*8(A-C,D-H,O-Z)
EXTERNAL GTPCOR
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
GAMTPE= TGAMMA*GTPCOR(P,ETOT)
END
C
C
C GTPCOR and GTPCOR1 should be merged (M.J.) !!!!
c
real*8 function gtpcor(topp,etot)
real*8 topp,etot,
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,hmass
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
c if (topp.ge.tmass/2.d0) then
c gtpcor1=0.001d0
c else
gtpcor=1.d0
c endif
end
c
c
c Correction function for non-constant (energy and momentum dependent) width:
FUNCTION GTPCOR1(TOPP,ETOT)
c
c TOPP - momentum of t quark = - momentum of tbar
c ETOT - total energy of t-tbar system
c calls: GENWDS, RAN2
c
c Evaluates a correction factor to the width of t-tbar system.
c in future has to be replaced by a function evaluating
c width including radiative corrections and GTPCOR.
c I include two factors reducing the width:
c a - time dilatation: for decay in flight lifetime
c increased accordingly to relativistic kinematics
c b - overall energy-momentum conservation: I assume that
c t and tbar decay in flight and in this decays energies
c of Ws follow from 2-body kinematics. Then I calculate
c effective mass squared of b-bar system (it may be
c negative!) from en-momentum conservation.
c If effective mass is < 2*Mb + 2 GeV configuration
c is rejected. The weight is acceptance.
c
IMPLICIT REAL*8(A-H,O-Z)
real ran2
external ran2
PARAMETER(NG=20,NC=4)
dimension gamma(0:NG),pw1(0:3),pw2(0:3),AIJ(NC,NC),BJ(NC),
$AI(NC),SIG2IN(0:NG),XIK(0:NG,NC),INDX(NC)
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
SAVE NUM,EOLD,TOLD,AI
data nevent/10000/, num/0/, eold/-1d5/, told/-1d0/
c
C for test runs!!
C nevent=1000
C
if(etot.ne.eold) num=0
if(tmass.ne.told) num=0
5 if(num.eq.0) then
c xdumm= ran2(-2)
do 10 itp=0,NG
tp=itp*tmass/NG*2
gamma(itp)=0
do 10 ix=1,nevent
call GENWDS(tp,etot,pw1,pw2,efmsq)
if(efmsq.gt.0d0) then
efms=sqrt(efmsq)
if(efms.ge. 2*bmass+2) gamma(itp)=gamma(itp)+1
endif
10 continue
do 15 ix=0,NG
15 SIG2IN(IX)= MAX(1D0,GAMMA(IX))
DO 17 JX=1,NC
IF(JX.EQ.1)THEN
XIK(0,JX)= .5D0
ELSE
XIK(0,JX)= 0D0
ENDIF
DO 17 IX=1,NG
tp= 2D0*ix/NG
17 XIK(IX,JX)= tp**(JX-1)/(1+EXP(tp*3))
DO 20 I=1,NC
BJ(I)=0
DO 20 J=1,NC
20 AIJ(I,J)=0
DO 30 I=1,NC
DO 25 IX=0,NG
25 BJ(I)= BJ(I)+GAMMA(IX)*XIK(IX,I)*SIG2IN(IX)
DO 30 J=1,I
DO 30 IX=0,NG
30 AIJ(I,J)= AIJ(I,J)+XIK(IX,I)*XIK(IX,J)*SIG2IN(IX)
DO 35 I=1,NC
DO 35 J=I,NC
35 AIJ(I,J)= AIJ(J,I)
CALL LUDCMP(AIJ,NC,NC,INDX,D)
CALL LUBKSB(AIJ,NC,NC,INDX,BJ)
DO 40 I=1,NC
40 AI(I)= BJ(I)/NEVENT
do 42 i=1,nc
42 write(*,*)'a(',i,')=',ai(i)
do 100 ix=0,NG
100 gamma(ix)= gamma(ix)/nevent
eold=etot
told=tmass
num= 1
endif
SUM=AI(1)
DO 110 I=2,NC
110 SUM= SUM+AI(I)*(TOPP/TMASS)**(I-1)
C CORRF2= SUM/(1+ EXP(TOPP/TMASS*3))
CORRF2= SUM/(1+ EXP(MIN(1d1,TOPP/TMASS*3)))
C if(topp.gt. 2d0*tmass) then
C corrf1= 0.001d0
C else
C ip= NG*topp/tmass/2
C corrf1= gamma(ip)
C endif
C write(*,*)'ratio=',corrf1/corrf2
C GTPCOR1 = CORRF2
GTPCOR1 = CORRF2*SQRT(1-TOPP**2/(TOPP**2+TMASS**2))
END
c
c Generator: only called by GTPCOR1
SUBROUTINE GENWDS(tp,etot,pw1,pw2,efm2)
c
c generates 4-momenta of W's and effective mass of b-bbar
c from t and tbar quarks decays at flight (tp = momentum of t
c = - momentum of tbar (in GeV) ) in Oz direction
c
implicit real*8(a-h,o-z)
c real ran2
real ranf
c external ran2
external ranf
dimension pw1(0:3),pw2(0:3)
save
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
data PI/3.141592653589793238D0/
real idum
c 3 s1= wmass**2+wmass*wgamma*TAN((2*ran2(idum)-1)*pi/2)
3 s1= wmass**2+wmass*wgamma*TAN((2*ranf(idum)-1)*pi/2)
if(s1.le.0d0) goto 3
wmass1= sqrt(s1)
if(abs(wmass1-wmass).ge.3*wgamma) goto 3
c 4 s2= wmass**2+wmass*wgamma*TAN((2*ran2(idum)-1)*pi/2)
4 s2= wmass**2+wmass*wgamma*TAN((2*ranf(idum)-1)*pi/2)
if(s2.le.0d0) goto 4
wmass2= sqrt(s2)
if(abs(wmass2-wmass).ge.3*wgamma) goto 4
ew1= (tmass**2+wmass1**2-bmass**2)/(2*tmass)
pwt1= sqrt(ew1**2-wmass1**2)
ew2= (tmass**2+wmass2**2-bmass**2)/(2*tmass)
pwt2= sqrt(ew2**2-wmass2**2)
5 p=tp
c u1= 2*ran2(idum)-1
u1= 2*ranf(idum)-1
pw1z= pwt1*u1
c u2= 2*ran2(idum)-1
u2= 2*ranf(idum)-1
pw2z= pwt2*u2
et= sqrt(tmass**2+p**2)
bet= p/et
gam= et/tmass
pw1(0)= gam*(ew1+bet*pw1z)
pw1(3)= gam*(pw1z+bet*ew1)
pw2(0)= gam*(ew2-bet*pw2z)
pw2(3)= gam*(pw2z-bet*ew2)
pw1tr= sqrt(pw1(0)**2-pw1(3)**2-wmass1**2)
pw2tr= sqrt(pw2(0)**2-pw2(3)**2-wmass2**2)
c phi1= 2*pi*ran2(idum)
phi1= 2*pi*ranf(idum)
c phi2= 2*pi*ran2(idum)
phi2= 2*pi*ranf(idum)
pw1(1)= pw1tr*cos(phi1)
pw1(2)= pw1tr*sin(phi1)
pw2(1)= pw2tr*cos(phi2)
pw2(2)= pw2tr*sin(phi2)
prec2= (pw1(1)+pw2(1))**2+(pw1(2)+pw2(2))**2+(pw1(3)+pw2(3))**2
erest=etot-pw1(0)-pw2(0)
c
efm2= erest*abs(erest)-prec2
END
c
c --- End of routines for Gamma_top ---
c
c --- Routines for solving linear equations and matrix inversion (complex) ---
c
subroutine sae(pp, w1, bb, a1, n)
c
implicit none
complex*16 vhat
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi, energy, vzero, eps,
u d, pp, w1, gtpcor,hmass,
u xp,xpmax,dcut,kincom,kincoa,kincov
complex*16 a, a1, bb, ff, cw, svw, g0, g0c
integer i, j, npot, n, nmax, indx,kinflg,gcflg,vflag
parameter (nmax=900)
dimension bb(nmax), ff(nmax,nmax), pp(nmax), w1(nmax),
u indx(nmax), cw(nmax), a1(nmax)
c
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
common/mom/ xp,xpmax,dcut
common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag
c
external a, vhat, gtpcor, g0, g0c
c
do 10 i=1,n*2/3
cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i))
c cw(i) = w1(i) / (4.d0*pi**2 *
c u (cmplx(energy-vzero, tgamma*
c u gtpcor(pp(i),2.d0*tmass+energy),
c u kind=kind(0d0))-pp(i)**2/tmass))
10 continue
do 20 i=n*2/3+1,n
cw(i) = w1(i) / (4.d0*pi**2) * g0c(pp(i)) * pp(i)**2
c cw(i) = w1(i) / (4.d0*pi**2 *
c u (cmplx(energy-vzero, tgamma*
c u gtpcor(pp(i),2.d0*tmass+energy),
c u kind=kind(0d0)) /
c u pp(i)**2 - 1.d0/tmass))
20 continue
c
do 30 i=1,n
cc bb(i) = a1(i)
cvv
if (pp(i).lt.dcut.and.vflag.eq.1) then
c bb(i) = cmplx(1.d0+kincov*(pp(i)/tmass)**2,0.d0,
c u kind=kind(0d0))
bb(i)=1.d0+kincov*
u g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i))
else
bb(i) = (1.d0,0.d0)
endif
svw = (0.d0,0.d0)
do 40 j=1,n
if (i.ne.j) then
ff(i,j) = - vhat(pp(i),pp(j)) * cw(j)
svw = svw + ff(i,j)
endif
40 continue
ff(i,i) = 1.d0 - a1(i) - svw
30 continue
c
call zldcmp(ff, n, nmax, indx, d)
call zlbksb(ff, n, nmax, indx, bb)
c
end
c
c
SUBROUTINE ZLBKSB(A,N,NP,INDX,B)
C complex version of lubksb
IMPLICIT NONE
INTEGER I, II, INDX, J, LL, N, NP
COMPLEX*16 A, B, SUM
DIMENSION A(NP,NP),INDX(N),B(N)
II=0
DO 12 I=1,N
LL=INDX(I)
SUM=B(LL)
B(LL)=B(I)
IF (II.NE.0)THEN
DO 11 J=II,I-1
SUM=SUM-A(I,J)*B(J)
11 CONTINUE
ELSE IF (SUM.NE.(0.D0,0.D0)) THEN
II=I
ENDIF
B(I)=SUM
12 CONTINUE
DO 14 I=N,1,-1
SUM=B(I)
IF(I.LT.N)THEN
DO 13 J=I+1,N
SUM=SUM-A(I,J)*B(J)
13 CONTINUE
ENDIF
B(I)=SUM/A(I,I)
14 CONTINUE
RETURN
END
c
SUBROUTINE ZLDCMP(A,N,NP,INDX,D)
C complex version of ludcmp
IMPLICIT NONE
INTEGER I, IMAX, INDX, J, K, N, NP, NMAX
REAL*8 AAMAX, D, TINY, VV
COMPLEX*16 A, DUM, SUM
PARAMETER (NMAX=900)
DIMENSION A(NP,NP), INDX(N), VV(NMAX)
c
tiny=1.d-5
c
D=1.D0
DO 12 I=1,N
AAMAX=0.D0
DO 11 J=1,N
IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
11 CONTINUE
c IF (AAMAX.EQ.0.D0) PAUSE 'Singular matrix.'
IF (AAMAX.EQ.0.D0) print *, "Singular matrix."
VV(I)=1.D0/AAMAX
12 CONTINUE
DO 19 J=1,N
IF (J.GT.1) THEN
DO 14 I=1,J-1
SUM=A(I,J)
IF (I.GT.1)THEN
DO 13 K=1,I-1
SUM=SUM-A(I,K)*A(K,J)
13 CONTINUE
A(I,J)=SUM
ENDIF
14 CONTINUE
ENDIF
AAMAX=0.D0
DO 16 I=J,N
SUM=A(I,J)
IF (J.GT.1)THEN
DO 15 K=1,J-1
SUM=SUM-A(I,K)*A(K,J)
15 CONTINUE
A(I,J)=SUM
ENDIF
DUM=VV(I)*ABS(SUM)
IF (ABS(DUM).GE.AAMAX) THEN
IMAX=I
AAMAX=DUM
ENDIF
16 CONTINUE
IF (J.NE.IMAX) THEN
DO 17 K=1,N
DUM=A(IMAX,K)
A(IMAX,K)=A(J,K)
A(J,K)=DUM
17 CONTINUE
D=-D
VV(IMAX)=VV(J)
ENDIF
INDX(J)=IMAX
IF (J.NE.N) THEN
IF (A(J,J).EQ.(0.D0,0.D0)) A(J,J)=cmplx(TINY, 0.d0,
u kind=kind(0d0))
DUM=1.D0/A(J,J)
DO 18 I=J+1,N
A(I,J)=A(I,J)*DUM
18 CONTINUE
ENDIF
19 CONTINUE
IF(A(N,N).EQ.(0.D0,0.D0)) A(N,N)=cmplx(TINY, 0.d0,
u kind=kind(0d0))
RETURN
END
C
C
C *** TOOLS ***
C
C
C ******* ROUTINES FOR GAUSSIAN INTEGRATIONS
C
C
SUBROUTINE GAULEG(X1,X2,X,W,N)
C
C Given the lower and upper limits of integration X1 and X2
C and given N, this routine returns arrays X(N) and W(N)
C containing the abscissas and weights of the Gauss-Legendre
C N-point quadrature formula
C
IMPLICIT REAL*8 (A-H,O-Z)
REAL*8 X1,X2,X(N),W(N)
PARAMETER (EPS=3.D-14)
save
M=(N+1)/2
XM=0.5D0*(X2+X1)
XL=0.5D0*(X2-X1)
DO 12 I=1,M
Z=DCOS(3.141592653589793238D0*(I-.25D0)/(N+.5D0))
1 CONTINUE
P1=1.D0
P2=0.D0
DO 11 J=1,N
P3=P2
P2=P1
P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J
11 CONTINUE
PP=N*(Z*P1-P2)/(Z*Z-1.D0)
Z1=Z
Z=Z1-P1/PP
IF(DABS(Z-Z1).GT.EPS)GO TO 1
X(I)=XM-XL*Z
X(N+1-I)=XM+XL*Z
W(I)=2.D0*XL/((1.D0-Z*Z)*PP*PP)
W(N+1-I)=W(I)
12 CONTINUE
RETURN
END
C
C
DOUBLE PRECISION FUNCTION AD8GLE(F,A,B,EPS)
implicit double precision (a-h,o-z)
EXTERNAL F
DIMENSION W(12),X(12)
c SAVE W, X
SAVE
C
C ******************************************************************
C
C ADAPTIVE GAUSSIAN QUADRATURE.
C
C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF
C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER
C EPS.
C
C ******************************************************************
C
DATA W / 0.10122 85362 90376 25915 25313 543D0,
$ 0.22238 10344 53374 47054 43559 944D0,
$ 0.31370 66458 77887 28733 79622 020D0,
$ 0.36268 37833 78361 98296 51504 493D0,
$ 0.27152 45941 17540 94851 78057 246D-1,
$ 0.62253 52393 86478 92862 84383 699D-1,
$ 0.95158 51168 24927 84809 92510 760D-1,
$ 0.12462 89712 55533 87205 24762 822D0,
$ 0.14959 59888 16576 73208 15017 305D0,
$ 0.16915 65193 95002 53818 93120 790D0,
$ 0.18260 34150 44923 58886 67636 680D0,
$ 0.18945 06104 55068 49628 53967 232D0/
C
DATA X / 0.96028 98564 97536 23168 35608 686D0,
$ 0.79666 64774 13626 73959 15539 365D0,
$ 0.52553 24099 16328 98581 77390 492D0,
$ 0.18343 46424 95649 80493 94761 424D0,
$ 0.98940 09349 91649 93259 61541 735D0,
$ 0.94457 50230 73232 57607 79884 155D0,
$ 0.86563 12023 87831 74388 04678 977D0,
$ 0.75540 44083 55003 03389 51011 948D0,
$ 0.61787 62444 02643 74844 66717 640D0,
$ 0.45801 67776 57227 38634 24194 430D0,
$ 0.28160 35507 79258 91323 04605 015D0,
$ 0.95012 50983 76374 40185 31933 543D-1/
C
C ******************************************************************
C
GAUSS=0.0D0
AD8GLE=GAUSS
IF(B.EQ.A) RETURN
CONST=EPS/(B-A)
BB=A
C
C COMPUTATIONAL LOOP.
1 AA=BB
BB=B
2 C1=0.5D0*(BB+AA)
C2=0.5D0*(BB-AA)
S8=0.0D0
DO 3 I=1,4
U=C2*X(I)
S8=S8+W(I)*(F(C1+U)+F(C1-U))
3 CONTINUE
S8=C2*S8
S16=0.0D0
DO 4 I=5,12
U=C2*X(I)
S16=S16+W(I)*(F(C1+U)+F(C1-U))
4 CONTINUE
S16=C2*S16
IF( ABS(S16-S8) .LE. EPS*(abs(s8)+ABS(S16))*0.5D0 ) GO TO 5
BB=C1
IF( 1.D0+ABS(CONST*C2) .NE. 1.D0) GO TO 2
AD8GLE=0.0D0
write(*,*)'too high accuracy required in function ad8gle!'
RETURN
5 GAUSS=GAUSS+S16
IF(BB.NE.B) GO TO 1
AD8GLE=GAUSS
RETURN
END
C
C
DOUBLE PRECISION FUNCTION ADGLG1(F,A,B,EPS)
IMPLICIT REAL*8 (A-H,O-Z)
EXTERNAL F,AD8GLE,adqua
DIMENSION W(6),X(6),xx(6)
c SAVE W, XX, NUM
SAVE
C
C ******************************************************************
C
C ADAPTIVE GAUSSIAN QUADRATURE.
C For x->b f(x) = O (ln^k (b-x) )
C A - lower limit, B - upper limit (integrable singularity)
C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF
C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER
C EPS.
C
C ******************************************************************
DATA W / 4.58964 673950d-1,
$ 4.17000 830772d-1,
$ 1.13373 382074d-1,
$ 1.03991 974531d-2,
$ 2.61017 202815d-4,
$ 8.98547 906430d-7/
C
DATA X / 0.22284 66041 79d0,
$ 1.18893 21016 73d0,
$ 2.99273 63260 59d0,
$ 5.77514 35691 05d0,
$ 9.83746 74183 83d0,
$ 15.98287 39806 02d0/
DATA NUM/0/
IF(NUM.eq.0d0) then
do 1 ix=1,6
1 xx(ix)= EXP(-x(ix))
ENDIF
num=num+1
sum=0d0
c=b-a
sum6=0d0
do 10 in=1,6
10 sum6= sum6+ w(in)*f(b-c*xx(in))
sum6=sum6*c
a1=a
15 a2= (a1+b)/2
c=b-a2
sumn=0d0
do 20 in=1,6
!!! FB: catch NaN
if ( c/b .lt. 1d-9 ) then
adglg1 = 1d15
return
endif
20 sumn= sumn+ w(in)*f(b-c*xx(in)) !!! FB: f(b) = NaN !
sumn=sumn*c
ctt
c call adqua(a1,a2,f,sum1,eps)
c sum1=sum1+sum
sum1=AD8GLE(F,A1,A2,eps)+sum
IF(ABS( (sum+sum6)/(sum1+sumn)-1d0 ).lt.EPS) THEN
ctt
c call adqua(a,a2,f,sum2,eps)
sum2=AD8GLE(F,A,A2,eps)
IF(ABS( (sum2+sumn)/(sum1+sumn)-1d0 ).gt.EPS) THEN
sum=sum2
a1=a2
sum6=sumn
goto 15
ENDIF
ADGLG1= SUM1+SUMN
RETURN
ELSE
sum=sum1
a1=a2
sum6=sumn
goto 15
ENDIF
END
C
DOUBLE PRECISION FUNCTION ADGLG2(F,A,B,EPS)
IMPLICIT REAL*8 (A-H,O-Z)
EXTERNAL F,AD8GLE
DIMENSION W(6),X(6),xx(6)
c SAVE W,XX,NUM
SAVE
C
C ******************************************************************
C
C ADAPTIVE GAUSSIAN QUADRATURE.
C For x->A f(x) = O (ln^k (x-a) )
C A - lower limit (integrable singularity), B - upper limit
C AD8GLE IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF
C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER
C EPS.
C
C ******************************************************************
DATA W / 4.58964 673950d-1,
$ 4.17000 830772d-1,
$ 1.13373 382074d-1,
$ 1.03991 974531d-2,
$ 2.61017 202815d-4,
$ 8.98547 906430d-7/
C
DATA X / 0.22284 66041 79d0,
$ 1.18893 21016 73d0,
$ 2.99273 63260 59d0,
$ 5.77514 35691 05d0,
$ 9.83746 74183 83d0,
$ 15.98287 39806 02d0/
DATA NUM/0/
IF(NUM.eq.0d0) then
do 1 ix=1,6
1 xx(ix)= EXP(-x(ix))
ENDIF
num=num+1
sum=0d0
c=b-a
sum6=0d0
do 10 in=1,6
10 sum6= sum6+ w(in)*f(A+c*xx(in))
sum6=sum6*c
b1=b
15 b2= (a+b1)/2
c=b2-a
sumn=0d0
do 20 in=1,6
!!! FB: catch NaN
if ( c/a .lt. 1d-9 ) then
adglg2 = 1d15
return
endif
20 sumn= sumn+ w(in)*f(a+c*xx(in)) !!! FB: f(a) = NaN !
sumn=sumn*c
sum1=AD8GLE(F,b2,b1,eps)+sum
IF(ABS( (sum+sum6)/(sum1+sumn)-1d0 ).lt.EPS) THEN
sum2=AD8GLE(F,b2,b,eps)
IF(ABS( (sum2+sumn)/(sum1+sumn)-1d0 ).gt.EPS) THEN
sum=sum2
b1=b2
sum6=sumn
goto 15
ENDIF
ADGLG2= SUM1+SUMN
RETURN
ELSE
sum=sum1
b1=b2
sum6=sumn
goto 15
ENDIF
END
C
C
C------------------------------------------------------------------
C INTEGRATION ROUTINE ADQUA written by M. Jezabek ------
C------------------------------------------------------------------
C
SUBROUTINE ADQUA(XL,XU,F,Y,ACC)
C
C ADAPTIVE GAUSS-LEGENDRE + SIMPSON'S RULE QUADRATURE
C XL - LOWER LIMIT, XU - UPPER LIMIT, F - FUNCTION TO INTEGRATE
C Y - INTEGRAL
C ACC - ACCURACY (IF .LE. 0. ACC=1.D-6)
c ****** new constants, 1 error removed, Oct '92
C
C CALLS: SIMPSA
C
C PARAMETERS: NSUB > NO OF SUBDIVISION LEVELS IN GAUSS INTEGRATION
C 100*2**IMAX > NO OF POINTS IN SIMPSON INTEGRATION
C
IMPLICIT REAL*8 (A-H,O-Z)
EXTERNAL F
DIMENSION VAL(25,2), BOUND(25,2,2), LEV(25),SING(25,3)
DIMENSION W8(4),X8(4)
DATA W8
$/0.101228536290376D0, 0.222381034453374D0, 0.313706645877887D0,
$ 0.362683783378362D0/
DATA X8
$/0.960289856497536D0, 0.796666477413627D0, 0.525532409916329D0,
$ 0.183434642495650D0/
save
C
IF(ACC.LE.0.D0) ACC=1.D-6
NSUB=24
NSG=25
NSC=0
A=XL
B=XU
C1=0.5d0*(A+B)
C2=C1-A
S8=0d0
DO 1 I=1,4
U=X8(I)*C2
1 S8=S8+W8(I)*(F(C1+U)+F(C1-U))
S8=S8*C2
XM=(XL+XU)/2.d0
BOUND(1,1,1)=XL
BOUND(1,1,2)=XM
BOUND(1,2,1)=XM
BOUND(1,2,2)=XU
NC=1
DO 3 IX=1,2
A=BOUND(NC,IX,1)
B=BOUND(NC,IX,2)
C1=0.5d0*(A+B)
C2=C1-A
VAL(NC,IX)=0.d0
DO 2 I=1,4
U=X8(I)*C2
2 VAL(NC,IX)=VAL(NC,IX)+W8(I)*(F(C1+U)+F(C1-U))
3 VAL(NC,IX)=VAL(NC,IX)*C2
S16=VAL(NC,1)+VAL(NC,2)
IF(DABS(S8-S16).GT.ACC*DABS(S16)) GOTO 4
Y=S16
RETURN
4 DO 5 I=1,NSUB
5 LEV(I)=0
NC1= NC+1
11 XM=(BOUND(NC,1,1)+BOUND(NC,1,2))/2.d0
BOUND(NC1,1,1)=BOUND(NC,1,1)
BOUND(NC1,1,2)=XM
BOUND(NC1,2,1)=XM
BOUND(NC1,2,2)=BOUND(NC,1,2)
DO 13 IX=1,2
A=BOUND(NC1,IX,1)
B=BOUND(NC1,IX,2)
C1=0.5d0*(A+B)
C2=C1-A
VAL(NC1,IX)=0.d0
DO 12 I=1,4
U=X8(I)*C2
12 VAL(NC1,IX)=VAL(NC1,IX)+W8(I)*(F(C1+U)+F(C1-U))
13 VAL(NC1,IX)=VAL(NC1,IX)*C2
S16=VAL(NC1,1)+VAL(NC1,2)
S8=VAL(NC,1)
IF(DABS(S8-S16).LE.ACC*DABS(S16)) GOTO 20
NC=NC1
NC1= NC+1
IF(NC1.LE.NSUB) GOTO 11
C NC=NSUB USE SIMPSON'S RULE
NSC=NSC+1
IF(NSC.LE.NSG) GOTO 15
WRITE(*,911)
911 FORMAT(1X,'ADQUA: TOO MANY SINGULARITIES')
STOP
15 SING(NSC,1)=BOUND(NC,1,1)
SING(NSC,2)=BOUND(NC,2,2)
SING(NSC,3)=S16
S16=0.d0
NC=NC-1
20 VAL(NC,1)= S16
121 LEV(NC)=1
21 XM=(BOUND(NC,2,1)+BOUND(NC,2,2))/2.d0
BOUND(NC1,1,1)=BOUND(NC,2,1)
BOUND(NC1,1,2)=XM
BOUND(NC1,2,1)=XM
BOUND(NC1,2,2)=BOUND(NC,2,2)
DO 23 IX=1,2
A=BOUND(NC1,IX,1)
B=BOUND(NC1,IX,2)
C1=0.5d0*(A+B)
C2=C1-A
VAL(NC1,IX)=0.d0
DO 22 I=1,4
U=X8(I)*C2
22 VAL(NC1,IX)=VAL(NC1,IX)+W8(I)*(F(C1+U)+F(C1-U))
23 VAL(NC1,IX)=VAL(NC1,IX)*C2
S16=VAL(NC1,1)+VAL(NC1,2)
S8=VAL(NC,2)
IF(DABS(S8-S16).LE.ACC*DABS(S16)) GOTO 40
NC=NC+1
NC1=NC+1
IF(NC1.LE.NSUB) GOTO 11
C NC=NSUB USE SIMPSON'S RULE
NSC=NSC+1
IF(NSC.LE.NSG) GOTO 35
WRITE(*,911)
STOP
35 SING(NSC,1)=BOUND(NC,1,1)
SING(NSC,2)=BOUND(NC,2,2)
SING(NSC,3)=S16
S16=0.d0
NC=NC-1
40 VAL(NC,2)= S16
45 IF(NC.GT.1) GOTO 50
Y1=VAL(1,1)+VAL(1,2)
GOTO 100
50 NC0=NC-1
IF(LEV(NC0).EQ.0) IX=1
IF(LEV(NC0).EQ.1) IX=2
LEV(NC)=0
NC1=NC
VAL(NC0,IX)=VAL(NC,1)+VAL(NC,2)
NC=NC0
IF(IX.EQ.1) GOTO 121
GOTO 45
100 CONTINUE
IF(NSC.GT.0) GOTO 101
Y=Y1
RETURN
101 FSUM=0.d0
DO 102 IK=1,NSC
102 FSUM=FSUM+DABS(SING(IK,3))
ACCR=ACC*DMAX1(FSUM,DABS(Y1))/FSUM/10.d0
DO 104 IK=1,NSC
104 CALL SIMPSA(SING(IK,1),SING(IK,2),F,SING(IK,3),ACCR)
DO 106 IK=1,NSC
106 Y1=Y1+SING(IK,3)
Y=Y1
RETURN
END
C
SUBROUTINE SIMPSA(A,B,F,F0,ACC)
C SIMPSON'S ADAPTIVE QUADRATURE
IMPLICIT REAL*8 (A-H,O-Z)
save
EXTERNAL F
IMAX=5
N0=100
H=(B-A)/N0
N02=N0/2
S2=0.d0
IC=1
S0=F(A)+F(B)
DO 5 K=1,N02
5 S2=S2+F(A+2.d0*K*H)
7 S1=0.d0
DO 10 K=1,N02
10 S1=S1+F(A+(2.d0*K-1.d0)*H)
Y=H/3.d0*(S0+4.d0*S1+2.d0*S2)
IF(DABS(F0/Y-1.d0).GT.ACC) GOTO 20
RETURN
20 N02=N0
N0=2*N0
S2=S1+S2
H=H/2.d0
IF(IC.GT.IMAX) GOTO 30
F0=Y
IC=IC+1
GOTO 7
30 ACC0=DABS(Y/F0-1.d0)
WRITE(*,900) A,B,ACC0
STOP
900 FORMAT(1H ,'SIMPSA: TOO HIGH ACCURACY REQUIRED'/
/1X, 29HSINGULARITY IN THE INTERVAL ,D20.12,1X,D20.12/
/1X, 29HACCURACY ACHIEVED ,D20.12)
END
C
C
C ******* matrix-inversion-routines
C
SUBROUTINE LUDCMP(A,N,NP,INDX,D)
IMPLICIT REAL*8(A-H,O-Z)
PARAMETER (NMAX=100,TINY=1.0E-20)
DIMENSION A(NP,NP),INDX(N),VV(NMAX)
D=1.
DO 12 I=1,N
AAMAX=0.
DO 11 J=1,N
IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
11 CONTINUE
! IF (AAMAX.EQ.0.) PAUSE 'Singular matrix.'
IF (AAMAX.EQ.0.) print *, 'Singular matrix.'
VV(I)=1./AAMAX
12 CONTINUE
DO 19 J=1,N
IF (J.GT.1) THEN
DO 14 I=1,J-1
SUM=A(I,J)
IF (I.GT.1)THEN
DO 13 K=1,I-1
SUM=SUM-A(I,K)*A(K,J)
13 CONTINUE
A(I,J)=SUM
ENDIF
14 CONTINUE
ENDIF
AAMAX=0.
DO 16 I=J,N
SUM=A(I,J)
IF (J.GT.1)THEN
DO 15 K=1,J-1
SUM=SUM-A(I,K)*A(K,J)
15 CONTINUE
A(I,J)=SUM
ENDIF
DUM=VV(I)*ABS(SUM)
IF (DUM.GE.AAMAX) THEN
IMAX=I
AAMAX=DUM
ENDIF
16 CONTINUE
IF (J.NE.IMAX)THEN
DO 17 K=1,N
DUM=A(IMAX,K)
A(IMAX,K)=A(J,K)
A(J,K)=DUM
17 CONTINUE
D=-D
VV(IMAX)=VV(J)
ENDIF
INDX(J)=IMAX
IF(J.NE.N)THEN
IF(A(J,J).EQ.0.)A(J,J)=TINY
DUM=1./A(J,J)
DO 18 I=J+1,N
A(I,J)=A(I,J)*DUM
18 CONTINUE
ENDIF
19 CONTINUE
IF(A(N,N).EQ.0.)A(N,N)=TINY
RETURN
END
c
SUBROUTINE LUBKSB(A,N,NP,INDX,B)
IMPLICIT REAL*8(A-H,O-Z)
DIMENSION A(NP,NP),INDX(N),B(N)
II=0
DO 12 I=1,N
LL=INDX(I)
SUM=B(LL)
B(LL)=B(I)
IF (II.NE.0)THEN
DO 11 J=II,I-1
SUM=SUM-A(I,J)*B(J)
11 CONTINUE
ELSE IF (SUM.NE.0.) THEN
II=I
ENDIF
B(I)=SUM
12 CONTINUE
DO 14 I=N,1,-1
SUM=B(I)
IF(I.LT.N)THEN
DO 13 J=I+1,N
SUM=SUM-A(I,J)*B(J)
13 CONTINUE
ENDIF
B(I)=SUM/A(I,I)
14 CONTINUE
RETURN
END
C
C
C ******* RANDOM NUMBER GENERATORS
C
C
FUNCTION RANF(DUMMY)
C
C RANDOM NUMBER FUNCTION TAKEN FROM KNUTH
C (SEMINUMERICAL ALGORITHMS).
C METHOD IS X(N)=MOD(X(N-55)-X(N-24),1/FMODUL)
C NO PROVISION YET FOR CONTROL OVER THE SEED NUMBER.
C
C RANF GIVES ONE RANDOM NUMBER BETWEEN 0 AND 1.
C IRN55 GENERATES 55 RANDOM NUMBERS BETWEEN 0 AND 1/FMODUL.
C IN55 INITIALIZES THE 55 NUMBERS AND WARMS UP THE SEQUENCE.
C
PARAMETER (FMODUL=1.E-09)
SAVE /CIRN55/
COMMON /CIRN55/NCALL,MCALL,IA(55)
INTEGER IA
CALL RANDAT
IF( NCALL.EQ.0 ) THEN
CALL IN55 ( IA,234612947 )
MCALL = 55
NCALL = 1
ENDIF
IF ( MCALL.EQ.0 ) THEN
CALL IRN55(IA)
MCALL=55
ENDIF
RANF=IA(MCALL)*FMODUL
MCALL=MCALL-1
RETURN
END
C
SUBROUTINE RANDAT
C
C INITIALISES THE NUMBER NCALL TO 0 TO FLAG THE FIRST CALL
C OF THE RANDOM NUMBER GENERATOR
C
C SAVE /CIRN55/
C SAVE FIRST
SAVE
COMMON /CIRN55/NCALL,MCALL,IA(55)
INTEGER IA
LOGICAL FIRST
DATA FIRST /.TRUE./
IF(FIRST)THEN
FIRST=.FALSE.
NCALL=0
ENDIF
RETURN
END
C
SUBROUTINE IN55(IA,IX)
PARAMETER (MODULO=1000000000)
INTEGER IA(55)
C
IA(55)=IX
J=IX
K=1
DO 10 I=1,54
II=MOD(21*I,55)
IA(II)=K
K=J-K
IF(K.LT.0)K=K+MODULO
J=IA(II)
10 CONTINUE
DO 20 I=1,10
CALL IRN55(IA)
20 CONTINUE
RETURN
END
C
SUBROUTINE IRN55(IA)
PARAMETER (MODULO=1000000000)
INTEGER IA(55)
DO 10 I=1,24
J=IA(I)-IA(I+31)
IF(J.LT.0)J=J+MODULO
IA(I)=J
10 CONTINUE
DO 20 I=25,55
J=IA(I)-IA(I-24)
IF(J.LT.0)J=J+MODULO
IA(I)=J
20 CONTINUE
RETURN
END
C
C
FUNCTION RAN2(IDUM)
C *******************
REAL RDM(31)
DATA IWARM/0/
C
IF (IDUM.LT.0.OR.IWARM.EQ.0) THEN
C INITIALIZATION OR REINITIALISATION
IWARM=1
IA1= 1279
IC1= 351762
M1= 1664557
IA2= 2011
IC2= 221592
M2= 1048583
IA3= 15091
IC3= 6171
M3= 29201
IX1=MOD(-IDUM,M1)
IX1=MOD(IA1*IX1+IC1,M1)
IX2=MOD(IX1,M2)
IX1=MOD(IA1*IX1+IC1,M1)
IX3=MOD(IX1,M3)
RM1=1./FLOAT(M1)
RM2=1./FLOAT(M2)
DO 10 J=1,31
IX1=MOD(IA1*IX1+IC1,M1)
IX2=MOD(IA2*IX2+IC2,M2)
10 RDM(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
ENDIF
C
C GENERATE NEXT NUMBER IN SEQUENCE
IF(IWARM.EQ.0) GOTO 901
IX1=MOD(IA1*IX1+IC1,M1)
IX2=MOD(IA2*IX2+IC2,M2)
IX3=MOD(IA3*IX3+IC3,M3)
J=1+(31*IX3)/M3
RAN2=RDM(J)
RDM(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
RETURN
901 PRINT 9010
9010 FORMAT(' RAN2: LACK OF ITINIALISATION')
STOP
END
C
C
C ******* SPECIAL FUNCTIONS
C
C
DOUBLE PRECISION FUNCTION DILOGG(X)
C
C SPENCE'S DILOGARITHM IN DOUBLE PRECISION
C
IMPLICIT REAL*8 (A-H,O-Z)
Z=-1.644934066848226
IF(X .LT.-1.0) GO TO 1
IF(X .LE. 0.5) GO TO 2
IF(X .EQ. 1.0) GO TO 3
IF(X .LE. 2.0) GO TO 4
Z=3.289868133696453
1 T=1.0/X
S=-0.5
Z=Z-0.5*DLOG(DABS(X))**2
GO TO 5
2 T=X
S=0.5
Z=0.
GO TO 5
3 DILOGG=1.644934066848226
RETURN
4 T=1.0-X
S=-0.5
Z=1.644934066848226-DLOG(X)*DLOG(DABS(T))
5 Y=2.666666666666667*T+0.666666666666667
B= 0.00000 00000 00001
A=Y*B +0.00000 00000 00004
B=Y*A-B+0.00000 00000 00011
A=Y*B-A+0.00000 00000 00037
B=Y*A-B+0.00000 00000 00121
A=Y*B-A+0.00000 00000 00398
B=Y*A-B+0.00000 00000 01312
A=Y*B-A+0.00000 00000 04342
B=Y*A-B+0.00000 00000 14437
A=Y*B-A+0.00000 00000 48274
B=Y*A-B+0.00000 00001 62421
A=Y*B-A+0.00000 00005 50291
B=Y*A-B+0.00000 00018 79117
A=Y*B-A+0.00000 00064 74338
B=Y*A-B+0.00000 00225 36705
A=Y*B-A+0.00000 00793 87055
B=Y*A-B+0.00000 02835 75385
A=Y*B-A+0.00000 10299 04264
B=Y*A-B+0.00000 38163 29463
A=Y*B-A+0.00001 44963 00557
B=Y*A-B+0.00005 68178 22718
A=Y*B-A+0.00023 20021 96094
B=Y*A-B+0.00100 16274 96164
A=Y*B-A+0.00468 63619 59447
B=Y*A-B+0.02487 93229 24228
A=Y*B-A+0.16607 30329 27855
A=Y*A-B+1.93506 43008 69969
DILOGG=S*T*(A-B)+Z
RETURN
END
c
SUBROUTINE pzext0(iest,xest,yest,yz,dy,nv)
implicit none
INTEGER iest,nv,IMAX,NMAX
REAL*8 xest,dy(nv),yest(nv),yz(nv)
PARAMETER (IMAX=13,NMAX=50)
INTEGER j,k1
REAL*8 delta,f1,f2,q,d(NMAX),qcol(NMAX,IMAX),x(IMAX)
SAVE qcol,x
x(iest)=xest
do 11 j=1,nv
dy(j)=yest(j)
yz(j)=yest(j)
11 continue
if(iest.eq.1) then
do 12 j=1,nv
qcol(j,1)=yest(j)
12 continue
else
do 13 j=1,nv
d(j)=yest(j)
13 continue
do 15 k1=1,iest-1
delta=1.d0/(x(iest-k1)-xest)
f1=xest*delta
f2=x(iest-k1)*delta
do 14 j=1,nv
q=qcol(j,k1)
qcol(j,k1)=dy(j)
delta=d(j)-q
dy(j)=f1*delta
d(j)=f2*delta
yz(j)=yz(j)+dy(j)
14 continue
15 continue
do 16 j=1,nv
qcol(j,iest)=dy(j)
16 continue
endif
return
END
c
c
complex*16 function zdigamma(z)
implicit none
complex*16 z,psi,psipr1,psipr2
call mkpsi(z,psi,psipr1,psipr2)
zdigamma=psi
end
c
subroutine mkpsi(z,psi,psipr1,psipr2)
implicit none
complex*16 tmp,tmps2,tmps3,tmp0,tmp1,tmp2,ser0,ser1,ser2,ser3,
. zz,z,psi,psipr1,psipr2,off0,off1,off2,zcf,ser02,ser12,
. z1,z2
real*8 cof(6),re1
integer i
data cof/76.18009173d0,-86.50532033d0,24.01409822d0,
. -1.231739516d0,.120858003d-2,-.536382d-5/
save
zz=z
off0=cmplx(0.d0,0.d0,kind=kind(0d0))
off1=cmplx(0.d0,0.d0,kind=kind(0d0))
off2=cmplx(0.d0,0.d0,kind=kind(0d0))
5 re1=real(zz)
if (re1.le.0.d0) then
off0=off0+1.d0/zz
z1=zz*zz
off1=off1-1.d0/z1
z2=z1*zz
off2=off2+2.d0/z2
zz=zz+(1.d0,0.d0)
goto 5
endif
tmp=zz+cmplx(4.5d0,0.d0,kind=kind(0d0))
tmps2=tmp*tmp
tmps3=tmp*tmps2
tmp0=(zz-cmplx(0.5d0,0.d0,kind=kind(0d0)))/tmp+log(tmp)
u -cmplx(1.d0,0.d0,kind=kind(0d0))
tmp1=(5.d0,0.d0)/tmps2+1.d0/tmp
tmp2=(-10.0d0,0.d0)/tmps3-1.d0/tmps2
ser0=cmplx(1.d0,0.d0,kind=kind(0d0))
ser1=cmplx(0.d0,0.d0,kind=kind(0d0))
ser2=cmplx(0.d0,0.d0,kind=kind(0d0))
ser3=cmplx(0.d0,0.d0,kind=kind(0d0))
do 10 i=1,6
zcf=cof(i)/zz
ser0=ser0+zcf
zcf=zcf/zz
ser1=ser1+zcf
zcf=zcf/zz
ser2=ser2+zcf
zcf=zcf/zz
ser3=ser3+zcf
zz=zz+(1.d0,0.d0)
10 continue
ser1=-ser1
ser2=2.d0*ser2
ser3=-6.d0*ser3
ser02=ser0*ser0
ser12=ser1*ser1
psi=tmp0+ser1/ser0-off0
psipr1=tmp1+(ser2*ser0-ser12)/ser02-off1
psipr2=tmp2+(ser3*ser02-3.d0*ser2*ser1*ser0+2.d0*ser12*ser1)
. /ser02/ser0-off2
return
end
@
<<[[toppik_axial.f]]>>=
! WHIZARD <<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
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Top threshold form factor code}
This module contains the infrastructure for the resummed form factors
for the top threshold simulation as well as the calculation of the top
mass and width etc.
<<[[ttv_formfactors.f90]]>>=
<<File header>>
module ttv_formfactors
use, intrinsic :: iso_fortran_env !NODEP!
use kinds
<<Use strings>>
<<Use debug>>
use constants
use sm_physics
use lorentz
use interpolation
use nr_tools
use diagnostics
<<Standard module head>>
save
<<TTV formfactors: public>>
<<TTV formfactors: public parameters>>
<<TTV formfactors: types>>
<<TTV formfactors: global variables>>
interface
<<TTV formfactors: sub interfaces>>
end interface
end module ttv_formfactors
@ %def ttv_formfactors
@
<<[[ttv_formfactors_sub.f90]]>>=
<<File header>>
submodule (ttv_formfactors) ttv_formfactors_s
use numeric_utils
use string_utils
use physics_defs, only: CF, CA, TR
use io_units
use system_dependencies
implicit none
<<TTV formfactors: parameters>>
<<TTV formfactors: interfaces>>
contains
<<TTV formfactors: procedures>>
end submodule ttv_formfactors_s
@ %def ttv_formfactors_s
@
<<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: sub interfaces>>=
module subroutine onshell_projection_debug_write (onshell_projection)
class(onshell_projection_t), intent(in) :: onshell_projection
end subroutine onshell_projection_debug_write
<<TTV formfactors: procedures>>=
module subroutine onshell_projection_debug_write (onshell_projection)
class(onshell_projection_t), intent(in) :: onshell_projection
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%production", &
onshell_projection%production)
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%decay", &
onshell_projection%decay)
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%width", &
onshell_projection%width)
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%boost_decay", &
onshell_projection%boost_decay)
end subroutine onshell_projection_debug_write
@ %def onshell_projection_debug_write
@
<<TTV formfactors: onshell projection: TBP>>=
procedure :: set_all => onshell_projection_set_all
<<TTV formfactors: sub interfaces>>=
pure module subroutine onshell_projection_set_all (onshell_projection, flag)
class(onshell_projection_t), intent(inout) :: onshell_projection
logical, intent(in) :: flag
end subroutine onshell_projection_set_all
<<TTV formfactors: procedures>>=
pure module subroutine onshell_projection_set_all (onshell_projection, flag)
class(onshell_projection_t), intent(inout) :: onshell_projection
logical, intent(in) :: flag
onshell_projection%production = flag
onshell_projection%decay = flag
end subroutine onshell_projection_set_all
@ %def onshell_projection_set_all
@
<<TTV formfactors: onshell projection: TBP>>=
procedure :: active => onshell_projection_active
<<TTV formfactors: sub interfaces>>=
pure module function onshell_projection_active (onshell_projection) result (active)
logical :: active
class(onshell_projection_t), intent(in) :: onshell_projection
end function onshell_projection_active
<<TTV formfactors: procedures>>=
pure module function onshell_projection_active (onshell_projection) result (active)
logical :: active
class(onshell_projection_t), intent(in) :: onshell_projection
active = onshell_projection%production .or. &
onshell_projection%decay
end function onshell_projection_active
@ %def onshell_projection_active
@
<<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: sub interfaces>>=
module subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, &
top_helicity_selection)
class(settings_t), intent(inout) :: settings
integer, intent(in) :: ff_in, offshell_strategy_in, top_helicity_selection
end subroutine settings_setup_flags
<<TTV formfactors: procedures>>=
! TODO: (bcn 2016-03-21) break this up into a part regarding the
! FF grid and a part regarding the settings
module subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, &
top_helicity_selection)
class(settings_t), intent(inout) :: settings
integer, intent(in) :: ff_in, offshell_strategy_in, top_helicity_selection
logical :: bit_top, bit_topbar
!!! RESUMMED_SWITCHOFF = - 2
!!! MATCHED = -1, &
SWITCHOFF_RESUMMED = ff_in < 0
TOPPIK_RESUMMED = ff_in <= 1
settings%nlo = btest(offshell_strategy_in, 0)
settings%factorized_computation = btest(offshell_strategy_in, 1)
settings%interference = btest(offshell_strategy_in, 2)
call settings%onshell_projection%set_all(btest(offshell_strategy_in, 3))
settings%no_nlo_width_in_signal_propagators = btest(offshell_strategy_in, 4)
settings%helicity_approximation%simple = btest(offshell_strategy_in, 5)
if (.not. settings%onshell_projection%active ()) then
settings%onshell_projection%production = btest(offshell_strategy_in, 6)
settings%onshell_projection%decay = btest(offshell_strategy_in, 7)
end if
settings%onshell_projection%width = .not. btest(offshell_strategy_in, 8)
settings%onshell_projection%boost_decay = btest(offshell_strategy_in, 9)
settings%helicity_approximation%extra = btest(offshell_strategy_in, 10)
settings%force_minus_one = btest(offshell_strategy_in, 11)
settings%flip_relative_sign = btest(offshell_strategy_in, 12)
if (top_helicity_selection > -1) then
settings%helicity_approximation%ultra = .true.
bit_top = btest (top_helicity_selection, 0)
bit_topbar = btest (top_helicity_selection, 1)
if (bit_top) then
settings%sel_hel_top = 1
else
settings%sel_hel_top = -1
end if
if (bit_topbar) then
settings%sel_hel_topbar = 1
else
settings%sel_hel_topbar = -1
end if
end if
settings%only_interference_term = btest(offshell_strategy_in, 14)
settings%Z_disabled = btest(offshell_strategy_in, 15)
if (ff_in == MATCHED .or. ff_in == MATCHED_NOTSOHARD) then
settings%onshell_projection%width = .true.
settings%onshell_projection%production = .true.
settings%onshell_projection%decay = .true.
settings%factorized_computation = .true.
settings%interference = .true.
settings%onshell_projection%boost_decay = .true.
end if
if (debug_on) call msg_debug (D_THRESHOLD, "SWITCHOFF_RESUMMED", SWITCHOFF_RESUMMED)
if (debug_on) call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED)
if (debug_active (D_THRESHOLD)) &
call settings%write ()
end subroutine settings_setup_flags
@ %def settings_setup_flags
@
<<TTV formfactors: settings: TBP>>=
procedure :: write => settings_write
<<TTV formfactors: sub interfaces>>=
module subroutine settings_write (settings, unit)
class(settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
end subroutine settings_write
<<TTV formfactors: procedures>>=
module subroutine settings_write (settings, unit)
class(settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, '(A,L1)') "settings%helicity_approximation%simple = ", &
settings%helicity_approximation%simple
write (u, '(A,L1)') "settings%helicity_approximation%extra = ", &
settings%helicity_approximation%extra
write (u, '(A,L1)') "settings%helicity_approximation%ultra = ", &
settings%helicity_approximation%ultra
write (u, '(A,L1)') "settings%initialized_parameters = ", &
settings%initialized_parameters
write (u, '(A,L1)') "settings%initialized_ps = ", &
settings%initialized_ps
write (u, '(A,L1)') "settings%initialized_ff = ", &
settings%initialized_ff
write (u, '(A,L1)') "settings%mpole_dynamic = ", &
settings%mpole_dynamic
write (u, '(A,I5)') "settings%offshell_strategy = ", &
settings%offshell_strategy
write (u, '(A,L1)') "settings%factorized_computation = ", &
settings%factorized_computation
write (u, '(A,L1)') "settings%interference = ", settings%interference
write (u, '(A,L1)') "settings%only_interference_term = ", &
settings%only_interference_term
write (u, '(A,L1)') "settings%Z_disabled = ", &
settings%Z_disabled
write (u, '(A,L1)') "settings%nlo = ", settings%nlo
write (u, '(A,L1)') "settings%no_nlo_width_in_signal_propagators = ", &
settings%no_nlo_width_in_signal_propagators
write (u, '(A,L1)') "settings%force_minus_one = ", settings%force_minus_one
write (u, '(A,L1)') "settings%flip_relative_sign = ", settings%flip_relative_sign
call settings%onshell_projection%debug_write ()
end subroutine settings_write
@ %def settings_write
@
<<TTV formfactors: settings: TBP>>=
procedure :: use_nlo_width => settings_use_nlo_width
<<TTV formfactors: sub interfaces>>=
pure module function settings_use_nlo_width (settings, ff) result (nlo)
logical :: nlo
class(settings_t), intent(in) :: settings
integer, intent(in) :: ff
end function settings_use_nlo_width
<<TTV formfactors: procedures>>=
pure module function settings_use_nlo_width (settings, ff) result (nlo)
logical :: nlo
class(settings_t), intent(in) :: settings
integer, intent(in) :: ff
nlo = settings%nlo
end function settings_use_nlo_width
@ %def settings_use_nlo_width
@
<<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: sub interfaces>>=
pure module subroutine formfactor_activate (formfactor)
class(formfactor_t), intent(inout) :: formfactor
end subroutine formfactor_activate
<<TTV formfactors: procedures>>=
pure module 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: sub interfaces>>=
pure module subroutine formfactor_disable (formfactor)
class(formfactor_t), intent(inout) :: formfactor
end subroutine formfactor_disable
<<TTV formfactors: procedures>>=
pure module subroutine formfactor_disable (formfactor)
class(formfactor_t), intent(inout) :: formfactor
formfactor%active = .false.
end subroutine formfactor_disable
@ %def formfactor_disable
@ This function actually returns $\tilde{F}$, i.e. $F-1$.
<<TTV formfactors: formfactor: TBP>>=
procedure :: compute => formfactor_compute
<<TTV formfactors: sub interfaces>>=
module function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF)
complex(default) :: FF
class(formfactor_t), intent(in) :: formfactor
type(phase_space_point_t), intent(in) :: ps
integer, intent(in) :: vec_type, FF_mode
end function formfactor_compute
<<TTV formfactors: procedures>>=
module function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF)
complex(default) :: FF
class(formfactor_t), intent(in) :: formfactor
type(phase_space_point_t), intent(in) :: ps
integer, intent(in) :: vec_type, FF_mode
real(default) :: f
if (threshold%settings%initialized_parameters .and. formfactor%active) then
select case (FF_mode)
case (MATCHED, MATCHED_NOTSOHARD, RESUMMED, RESUMMED_SWITCHOFF)
FF = resummed_formfactor (ps, vec_type) - one
case (MATCHED_EXPANDED)
f = f_switch_off (v_matching (ps%sqrts, GAM_M1S))
FF = - expanded_formfactor (f * AS_HARD, f * AS_HARD, ps, vec_type) &
+ resummed_formfactor (ps, vec_type)
case (MATCHED_EXPANDED_NOTSOHARD)
f = f_switch_off (v_matching (ps%sqrts, GAM_M1S))
FF = - expanded_formfactor (f * alphas_notsohard (ps%sqrts), f * &
alphas_notsohard (ps%sqrts), ps, vec_type) &
+ resummed_formfactor (ps, vec_type)
case (EXPANDED_HARD)
FF = expanded_formfactor (AS_HARD, AS_HARD, ps, vec_type) - one
case (EXPANDED_NOTSOHARD)
FF = expanded_formfactor (alphas_notsohard (ps%sqrts), &
alphas_notsohard (ps%sqrts), ps, vec_type) - one
case (EXPANDED_SOFT)
FF = expanded_formfactor (AS_HARD, alphas_soft (ps%sqrts), ps, &
vec_type) - one
case (EXPANDED_SOFT_SWITCHOFF)
f = f_switch_off (v_matching (ps%sqrts, GAM_M1S))
FF = expanded_formfactor (f * AS_HARD, &
f * alphas_soft (ps%sqrts), ps, vec_type) - one
case (RESUMMED_ANALYTIC_LL)
FF = formfactor_LL_analytic (alphas_soft (ps%sqrts), ps%sqrts, &
ps%p, vec_type) - one
case (TREE)
FF = zero
case default
FF = zero
end select
else
FF = zero
end if
if (debug2_active (D_THRESHOLD)) then
call update_global_sqrts_dependent_variables (ps%sqrts)
call msg_debug2 (D_THRESHOLD, "threshold%settings%initialized_parameters", &
threshold%settings%initialized_parameters)
call msg_debug2 (D_THRESHOLD, "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: sub interfaces>>=
pure module subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv)
class(width_t), intent(inout) :: width
real(default), intent(in) :: aemi, sw, mw, mb, vtb, gam_inv
end subroutine width_init
<<TTV formfactors: procedures>>=
pure module subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv)
class(width_t), intent(inout) :: width
real(default), intent(in) :: aemi, sw, mw, mb, vtb, gam_inv
width%aem = one / aemi
width%sw = sw
width%mw = mw
width%mb = mb
width%vtb = vtb
width%gam_inv = gam_inv
end subroutine width_init
@ %def width_init
@
<<TTV formfactors: width: TBP>>=
procedure :: compute => width_compute
<<TTV formfactors: sub interfaces>>=
pure module function width_compute (width, top_mass, sqrts, initial) result (gamma)
real(default) :: gamma
class(width_t), intent(in) :: width
real(default), intent(in) :: top_mass, sqrts
logical, intent(in), optional :: initial
end function width_compute
<<TTV formfactors: procedures>>=
pure module function width_compute (width, top_mass, sqrts, initial) result (gamma)
real(default) :: gamma
class(width_t), intent(in) :: width
real(default), intent(in) :: top_mass, sqrts
logical, intent(in), optional :: initial
real(default) :: alphas
logical :: ini
ini = .false.; if (present (initial)) ini = initial
if (ini) then
alphas = AS_HARD
else
alphas = alphas_notsohard (sqrts)
end if
if (threshold%settings%nlo) then
gamma = top_width_sm_qcd_nlo_jk (width%aem, width%sw, width%vtb, &
top_mass, width%mw, width%mb, alphas) + width%gam_inv
else
gamma = top_width_sm_lo (width%aem, width%sw, width%vtb, top_mass, &
width%mw, width%mb) + width%gam_inv
end if
end function width_compute
@ %def width_compute
@ Use singleton pattern instead of global variables. At least shows
where the variables are from.
<<TTV formfactors: public>>=
public :: threshold
<<TTV formfactors: public>>=
public :: threshold_t
<<TTV formfactors: global variables>>=
type(threshold_t) :: threshold
<<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: public parameters>>=
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
<<TTV formfactors: parameters>>=
integer, parameter :: VECTOR = 1
integer, parameter :: AXIAL = 2
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: public>>=
public :: phase_space_point_t
<<TTV formfactors: types>>=
type :: phase_space_point_t
real(default) :: p2 = 0, k2 = 0, q2 = 0
real(default) :: sqrts = 0, p = 0, p0 = 0
real(default) :: mpole = 0, en = 0
logical :: inside_grid = .false., onshell = .false.
contains
<<TTV formfactors: phase space point: TBP>>
end type phase_space_point_t
@ %def phase_space_point_t
@
<<TTV formfactors: phase space point: TBP>>=
procedure :: init => phase_space_point_init_rel
<<TTV formfactors: sub interfaces>>=
pure module subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m)
class(phase_space_point_t), intent(inout) :: ps_point
real(default), intent(in) :: p2
real(default), intent(in) :: k2
real(default), intent(in) :: q2
real(default), intent(in), optional :: m
end subroutine phase_space_point_init_rel
<<TTV formfactors: procedures>>=
pure module subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m)
class(phase_space_point_t), intent(inout) :: ps_point
real(default), intent(in) :: p2
real(default), intent(in) :: k2
real(default), intent(in) :: q2
real(default), intent(in), optional :: m
ps_point%p2 = p2
ps_point%k2 = k2
ps_point%q2 = q2
call rel_to_nonrel (p2, k2, q2, ps_point%sqrts, ps_point%p, ps_point%p0)
ps_point%mpole = m1s_to_mpole (ps_point%sqrts)
ps_point%en = sqrts_to_en (ps_point%sqrts)
ps_point%inside_grid = sqrts_within_range (ps_point%sqrts)
if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m)
end subroutine phase_space_point_init_rel
@ %def phase_space_point_init_rel
@
<<TTV formfactors: phase space point: TBP>>=
procedure :: init_nonrel => phase_space_point_init_nonrel
<<TTV formfactors: sub interfaces>>=
pure module subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m)
class(phase_space_point_t), intent(inout) :: ps_point
real(default), intent(in) :: sqrts
real(default), intent(in) :: p
real(default), intent(in) :: p0
real(default), intent(in), optional :: m
end subroutine phase_space_point_init_nonrel
<<TTV formfactors: procedures>>=
pure module subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m)
class(phase_space_point_t), intent(inout) :: ps_point
real(default), intent(in) :: sqrts
real(default), intent(in) :: p
real(default), intent(in) :: p0
real(default), intent(in), optional :: m
ps_point%sqrts = sqrts
ps_point%p = p
ps_point%p0 = p0
call nonrel_to_rel (sqrts, p, p0, ps_point%p2, ps_point%k2, ps_point%q2)
ps_point%mpole = m1s_to_mpole (sqrts)
ps_point%en = sqrts_to_en (sqrts, ps_point%mpole)
ps_point%inside_grid = sqrts_within_range (sqrts)
if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m)
end subroutine phase_space_point_init_nonrel
@ %def phase_space_point_init_nonrel
@
<<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
@ %def 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
@ %def 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
@ %def complex_m2
@
<<TTV formfactors: phase space point: TBP>>=
procedure :: is_onshell => phase_space_point_is_onshell
<<TTV formfactors: sub interfaces>>=
pure module function phase_space_point_is_onshell (ps_point, m) result (flag)
logical :: flag
class(phase_space_point_t), intent(in) :: ps_point
real(default), intent(in) :: m
end function phase_space_point_is_onshell
<<TTV formfactors: procedures>>=
pure module function phase_space_point_is_onshell (ps_point, m) result (flag)
logical :: flag
class(phase_space_point_t), intent(in) :: ps_point
real(default), intent(in) :: m
flag = nearly_equal (ps_point%p2 , m**2, rel_smallness=1E-5_default) .and. &
nearly_equal (ps_point%k2 , m**2, rel_smallness=1E-5_default)
end function phase_space_point_is_onshell
@ %def phase_space_point_is_onshell
@
<<TTV formfactors: phase space point: TBP>>=
procedure :: write => phase_space_point_write
<<TTV formfactors: sub interfaces>>=
module subroutine phase_space_point_write (psp, unit)
class(phase_space_point_t), intent(in) :: psp
integer, intent(in), optional :: unit
end subroutine phase_space_point_write
<<TTV formfactors: procedures>>=
module subroutine phase_space_point_write (psp, unit)
class(phase_space_point_t), intent(in) :: psp
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, '(A)') char ("p2 = " // str (psp%p2))
write (u, '(A)') char ("k2 = " // str (psp%k2))
write (u, '(A)') char ("q2 = " // str (psp%q2))
write (u, '(A)') char ("sqrts = " // str (psp%sqrts))
write (u, '(A)') char ("p = " // str (psp%p))
write (u, '(A)') char ("p0 = " // str (psp%p0))
write (u, '(A)') char ("mpole = " // str (psp%mpole))
write (u, '(A)') char ("en = " // str (psp%en))
write (u, '(A)') char ("inside_grid = " // str (psp%inside_grid))
write (u, '(A)') char ("onshell = " // str (psp%onshell))
end subroutine phase_space_point_write
@ %def phase_space_point_write
@
<<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: sub interfaces>>=
module subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, &
aemi, sw, az, mz, mw, mb, h_in, f_in, nrqcd_order_in, ff_in, &
offshell_strategy_in, v1_in, v2_in, scan_sqrts_min, &
scan_sqrts_max, scan_sqrts_stepsize, mpole_fixed, top_helicity_selection)
real(default), intent(out) :: mpole_out
real(default), intent(out) :: gam_out
real(default), intent(in) :: m1s_in
real(default), intent(in) :: Vtb
real(default), intent(in) :: gam_inv
real(default), intent(in) :: aemi
real(default), intent(in) :: sw
real(default), intent(in) :: az
real(default), intent(in) :: mz
real(default), intent(in) :: mw
real(default), intent(in) :: mb
real(default), intent(in) :: h_in
real(default), intent(in) :: f_in
real(default), intent(in) :: nrqcd_order_in
real(default), intent(in) :: ff_in
real(default), intent(in) :: offshell_strategy_in
real(default), intent(in) :: v1_in
real(default), intent(in) :: v2_in
real(default), intent(in) :: scan_sqrts_min
real(default), intent(in) :: scan_sqrts_max
real(default), intent(in) :: scan_sqrts_stepsize
logical, intent(in) :: mpole_fixed
real(default), intent(in) :: top_helicity_selection
end subroutine init_parameters
<<TTV formfactors: procedures>>=
module subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, &
aemi, sw, az, mz, mw, mb, h_in, f_in, nrqcd_order_in, ff_in, &
offshell_strategy_in, v1_in, v2_in, scan_sqrts_min, &
scan_sqrts_max, scan_sqrts_stepsize, mpole_fixed, top_helicity_selection)
real(default), intent(out) :: mpole_out
real(default), intent(out) :: gam_out
real(default), intent(in) :: m1s_in
real(default), intent(in) :: Vtb
real(default), intent(in) :: gam_inv
real(default), intent(in) :: aemi
real(default), intent(in) :: sw
real(default), intent(in) :: az
real(default), intent(in) :: mz
real(default), intent(in) :: mw
real(default), intent(in) :: mb
real(default), intent(in) :: h_in
real(default), intent(in) :: f_in
real(default), intent(in) :: nrqcd_order_in
real(default), intent(in) :: ff_in
real(default), intent(in) :: offshell_strategy_in
real(default), intent(in) :: v1_in
real(default), intent(in) :: v2_in
real(default), intent(in) :: scan_sqrts_min
real(default), intent(in) :: scan_sqrts_max
real(default), intent(in) :: scan_sqrts_stepsize
logical, intent(in) :: mpole_fixed
real(default), intent(in) :: top_helicity_selection
if (debug_active (D_THRESHOLD)) call show_input()
threshold%settings%initialized_parameters = .false.
M1S = m1s_in
threshold%settings%mpole_dynamic = .not. mpole_fixed
threshold%settings%offshell_strategy = int (offshell_strategy_in)
call threshold%settings%setup_flags (int(ff_in), &
threshold%settings%offshell_strategy, &
int (top_helicity_selection))
NRQCD_ORDER = set_nrqcd_order (nrqcd_order_in)
v1 = v1_in
v2 = v2_in
sqrts_min = scan_sqrts_min
sqrts_max = scan_sqrts_max
sqrts_it = scan_sqrts_stepsize
!!! global hard parameters incl. hard alphas used in all form factors
RESCALE_H = h_in
MU_HARD = M1S * RESCALE_H
AS_MZ = az
MASS_Z = mz
AS_HARD = running_as (MU_HARD, az, mz, 2, NF)
call threshold%width%init (aemi, sw, mw, mb, vtb, gam_inv)
GAM_M1S = threshold%width%compute (M1S, zero, initial=.true.)
call compute_global_auxiliary_numbers ()
!!! soft parameters incl. mtpole
!!! (depend on sqrts: initialize with sqrts ~ 2*M1S)
NUSTAR_FIXED = - one
NUSTAR_DYNAMIC = NUSTAR_FIXED < zero
RESCALE_F = f_in
call update_global_sqrts_dependent_variables (2. * M1S)
mtpole_init = MTPOLE
mpole_out = mtpole_init
gam_out = GAM
threshold%settings%initialized_parameters = .true.
contains
<<TTV formfactors: init parameters: subroutines>>
end subroutine init_parameters
@ %def 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: sub interfaces>>=
module subroutine init_threshold_grids (test)
real(default), intent(in) :: test
end subroutine init_threshold_grids
<<TTV formfactors: procedures>>=
module subroutine init_threshold_grids (test)
real(default), intent(in) :: test
if (debug_active (D_THRESHOLD)) then
call msg_debug (D_THRESHOLD, "init_threshold_grids")
call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED)
end if
if (test > zero) then
call msg_message ("TESTING ONLY: Skip threshold initialization and use tree-level SM.")
return
end if
if (.not. threshold%settings%initialized_parameters) &
call msg_fatal ("init_threshold_grid: parameters not initialized!")
!!! !!! !!! MAC OS X and BSD don't load the global module with parameter values stored
!!! if (parameters_ref == parameters_string ()) return
call dealloc_grids ()
if (TOPPIK_RESUMMED) call init_formfactor_grid ()
parameters_ref = parameters_string ()
end subroutine init_threshold_grids
@ %def init_threshold_grids
@
<<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) * ( &
(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
@ %def 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
@ %def 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: sub interfaces>>=
pure module function v_matching (sqrts, gamma) result (v)
real(default) :: v
real(default), intent(in) :: sqrts, gamma
end function v_matching
<<TTV formfactors: procedures>>=
pure module function v_matching (sqrts, gamma) result (v)
real(default) :: v
real(default), intent(in) :: sqrts, gamma
v = abs (sqrts_to_v_1S (sqrts, gamma))
end function v_matching
@ %def v_matching
@ Smooth transition from [[f1]] to [[f2]] between [[v1]] and [[v2]]
(simplest polynom).
<<TTV formfactors: public>>=
public :: f_switch_off
<<TTV formfactors: sub interfaces>>=
pure module function f_switch_off (v) result (fval)
real(default), intent(in) :: v
real(default) :: fval
end function f_switch_off
<<TTV formfactors: procedures>>=
pure module function f_switch_off (v) result (fval)
real(default), intent(in) :: v
real(default) :: fval
real(default) :: vm, f1, f2, x
f1 = one
f2 = zero + tiny_10
vm = (v1+v2) / 2.
if ( v < v1 ) then
fval = f1
else if (v < v2) then
x = (v - v1) / (v2 - v1)
fval = 1 - x**2 * (3 - 2 * x)
else
fval = f2
end if
end function f_switch_off
@ %def f_switch_off
@
<<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: sub interfaces>>=
pure module function alphas_notsohard (sqrts) result (a_soft)
real(default) :: a_soft
real(default), intent(in) :: sqrts
end function alphas_notsohard
<<TTV formfactors: procedures>>=
pure module function alphas_notsohard (sqrts) result (a_soft)
real(default) :: a_soft
real(default), intent(in) :: sqrts
real(default) :: mu_notsohard
! complex(default) :: v
! v = sqrts_to_v_1S (sqrts, GAM_M1S)
! mu_notsohard = RESCALE_H * M1S * sqrt(abs(v))
mu_notsohard = RESCALE_H * M1S * sqrt(nustar (sqrts))
a_soft = running_as (mu_notsohard, AS_MZ, MASS_Z, 2, NF)
end function alphas_notsohard
@ %def alphas_notsohard
@
<<TTV formfactors: sub interfaces>>=
pure module function m1s_to_mpole (sqrts) result (mpole)
real(default), intent(in) :: sqrts
real(default) :: mpole
end function m1s_to_mpole
<<TTV formfactors: procedures>>=
pure module function m1s_to_mpole (sqrts) result (mpole)
real(default), intent(in) :: sqrts
real(default) :: mpole
mpole = mtpole_init
if (threshold%settings%mpole_dynamic) then
mpole = M1S * ( 1. + deltaM(sqrts) )
else
mpole = M1S
end if
end function m1s_to_mpole
@ %def m1s_to_mpole
@
<<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: sub interfaces>>=
pure module function int_to_char (i) result (c)
integer, intent(in) :: i
character(len=len(trim(int2fixed(i)))) :: c
end function int_to_char
<<TTV formfactors: procedures>>=
pure module function int_to_char (i) result (c)
integer, intent(in) :: i
character(len=len(trim(int2fixed(i)))) :: c
c = int2char (i)
end function int_to_char
@ %def int_to_char
@
<<TTV formfactors: sub interfaces>>=
pure module function real_to_char (r) result (c)
real(default), intent(in) :: r
character(len=len(trim(real2fixed(r)))) :: c
end function real_to_char
<<TTV formfactors: procedures>>=
pure module function real_to_char (r) result (c)
real(default), intent(in) :: r
character(len=len(trim(real2fixed(r)))) :: c
c = real2char (r)
end function real_to_char
@ %def real_to_char
@
<<TTV formfactors: sub interfaces>>=
pure module function complex_to_char (z) result (c)
complex(default), intent(in) :: z
character(len=len(trim(real2fixed(real(z))))+len(trim(real2fixed(aimag(z))))+5) :: c
end function complex_to_char
<<TTV formfactors: procedures>>=
pure module function complex_to_char (z) result (c)
complex(default), intent(in) :: z
character(len=len(trim(real2fixed(real(z))))+len(trim(real2fixed(aimag(z))))+5) :: c
character(len=len(trim(real2fixed(real(z))))) :: re
character(len=len(trim(real2fixed(aimag(z))))) :: im
re = real_to_char (real(z))
im = real_to_char (aimag(z))
if (nearly_equal (aimag(z), zero)) then
c = re
else
c = re // " + " // im // "*I"
end if
end function complex_to_char
@ %def complex_to_char
@
<<TTV formfactors: sub interfaces>>=
pure module function logical_to_char (l) result (c)
logical, intent(in) :: l
character(len=1) :: c
end function logical_to_char
<<TTV formfactors: procedures>>=
pure module function logical_to_char (l) result (c)
logical, intent(in) :: l
character(len=1) :: c
write (c, '(l1)') l
end function logical_to_char
@ %def logical_to_char
@
<<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: sub interfaces>>=
module subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell)
!!! Gluon must be on first position in this array
type(vector4_t), intent(in), dimension(:) :: p_decay
type(vector4_t), intent(inout) :: p_top
type(vector4_t), intent(inout), dimension(:) :: p_decay_onshell
end subroutine generate_on_shell_decay_threshold
<<TTV formfactors: procedures>>=
module subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell)
!!! Gluon must be on first position in this array
type(vector4_t), intent(in), dimension(:) :: p_decay
type(vector4_t), intent(inout) :: p_top
type(vector4_t), intent(inout), dimension(:) :: p_decay_onshell
procedure(evaluate_one_to_two_splitting_special), pointer :: ppointer
ppointer => evaluate_one_to_two_splitting_threshold
call generate_on_shell_decay (p_top, p_decay, p_decay_onshell, 1, &
evaluate_special = ppointer)
end subroutine generate_on_shell_decay_threshold
@ %def generate_on_shell_decay_threshold
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[ttv_formfactors_ut.f90]]>>=
<<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
@

File Metadata

Mime Type
text/x-tex
Expires
Sat, May 3, 5:41 AM (5 h, 21 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
4982794
Default Alt Text
threshold.nw (357 KB)

Event Timeline