Page MenuHomeHEPForge
Files F7879882

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/src/qed_pdf/Makefile.am
===================================================================
--- trunk/src/qed_pdf/Makefile.am (revision 8768)
+++ trunk/src/qed_pdf/Makefile.am (revision 8769)
@@ -1,184 +1,195 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory handle unit tests in Fortran.
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libqed_pdf.la
libqed_pdf_la_SOURCES = \
+ $(QED_MODULES) \
+ $(QED_SUBMODULES)
+
+QED_MODULES = \
electron_pdfs.f90
+QED_SUBMODULES = \
+ electron_pdfs_sub.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = qed_pdf.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
+# For the moment this only installs module .mod files, not submodule files
nodist_execmod_HEADERS = \
- ${libqed_pdf_la_SOURCES:.f90=.$(FCMOD)}
+ ${QED_MODULES:.f90=.$(FCMOD)}
-libqed_pdf_Modules = ${libqed_pdf_la_SOURCES:.f90=}
+# Submodules must not be included here
+libqed_pdf_Modules = ${QED_MODULES:.f90=}
Modules: Makefile
@for module in $(libqed_pdf_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../utilities/Modules \
../physics/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libqed_pdf_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES = Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(libqed_pdf_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
-AM_FCFLAGS = -I../basics -I../utilities -I../system -I../physics
+AM_FCFLAGS = -I../basics -I../utilities -I../system -I../combinatorics -I../physics
+########################################################################
+# For the moment, the submodule dependencies will be hard-coded
+electron_pdfs_sub.lo: electron_pdfs.lo
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
## MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
qed_pdf.stamp: $(PRELUDE) $(srcdir)/qed_pdf.nw $(POSTLUDE)
@rm -f qed_pdf.tmp
@touch qed_pdf.tmp
for src in $(libqed_pdf_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
@mv -f qed_pdf.tmp qed_pdf.stamp
$(libqed_pdf_la_SOURCES): qed_pdf.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f qed_pdf.stamp; \
$(MAKE) $(AM_MAKEFLAGS) qed_pdf.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f qed_pdf.stamp qed_pdf.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/qed_pdf/qed_pdf.nw
===================================================================
--- trunk/src/qed_pdf/qed_pdf.nw (revision 8768)
+++ trunk/src/qed_pdf/qed_pdf.nw (revision 8769)
@@ -1,258 +1,299 @@
%% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: QED ISR structure functions ("PDFs")
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{QED Parton Distribution Functions}
\label{chap:qed_pdf}
\includemodulegraph{qed_pdf}
We start with a module that gives access to the ISR structure function:
\begin{description}
\item[electron\_pdfs]
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Electron PDFs}
This module contains the formulae for the numerical evaluation of
different incarnations of the QED initial-state radiation (ISR)
structure functions (a.k.a. electron PDFs).
<<[[electron_pdfs.f90]]>>=
<<File header>>
module electron_pdfs
<<Use kinds>>
<<Use strings>>
- use io_units
- use constants, only: pi
- use format_defs, only: FMT_19
- use numeric_utils
- use sm_physics, only: Li2
+<<electron pdfs use>>
<<Standard module head>>
<<Electron PDFs: public>>
<<Electron PDFs: types>>
-contains
-
-<<Electron PDFs: procedures>>
+ interface
+<<Electron PDFs: sub interfaces>>
+ end interface
end module electron_pdfs
@ %def electron_pdfs
@
-\subsection{The physics for electron beam structure functions}
+<<electron pdfs use>>=
+ use io_units
+@ %def electron_pdfs use
+@
+<<[[electron_pdfs_sub.f90]]>>=
+<<File header>>
+
+submodule (electron_pdfs) electron_pdfs_s
+
+<<Use kinds>>
+<<Use strings>>
+<<electron pdfs use>>
+ use constants, only: pi
+ use format_defs, only: FMT_19
+ use numeric_utils
+ use sm_physics, only: Li2, zeta2, zeta3
+
+contains
+
+<<Electron PDFs: procedures>>
+
+end submodule electron_pdfs_s
+@
+\subsection{The physics for electron beam PDFs (structure functions)}
The ISR structure function is in the most crude approximation (LLA
without $\alpha$ corrections, i.e. $\epsilon^0$)
\begin{equation}
f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad
\epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2},
\end{equation}
where $m$ is the mass of the incoming (and outgoing) particle, which
is initially assumed on-shell.
Here, the form of $\epsilon$ results from the kinematical bounds for
the momentum squared of the outgoing particle, which in the limit
$m^2\ll s$ are given by
\begin{align}
t_0 &= -2\bar xE(E+p) + m^2 \approx -\bar x s,
\\
t_1 &= -2\bar xE(E-p) + m^2 \approx x m^2,
\end{align}
so the integration over the propagator $1/(t-m^2)$ yields
\begin{equation}
\ln\frac{t_0-m^2}{t_1-m^2} = \ln\frac{s}{m^2}.
\end{equation}
The structure function has three parameters: $\alpha$, $m_{\rm in}$ of
the incoming particle and $s$, the hard scale. Internally, we store
the exponent $\epsilon$ which is the relevant parameter. (In
conventional notation, $\epsilon=\beta/2$.) As defaults, we take the
actual values of $\alpha$ (which is probably $\alpha(s)$), the actual
mass $m_{\rm in}$ and the squared total c.m. energy $s$.
Including $\epsilon$, $\epsilon^2$, and $\epsilon^3$ corrections, the
successive approximation of the ISR structure function read
\begin{align}
f_0(x) &= \epsilon(1-x)^{-1+\epsilon} \\
f_1(x) &= g_1(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\
\begin{split}
f_2(x) &= g_2(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\
&\quad - \frac{\epsilon^2}{8}\left(
\frac{1+3x^2}{1-x}\ln x + 4(1+x) \ln(1-x) + 5 + x \right)
\end{split} \\
\begin{split}
f_3(x) &= g_3(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\
&\quad - \frac{\epsilon^2}{8}\left(
\frac{1+3x^2}{1-x}\ln x + 4(1+x) \ln(1-x) + 5 + x \right) \\
&\quad - \frac{\epsilon^3}{48}\left( \vphantom{\frac{1}{1-x}}
(1+x)\left[6\mathop{\rm Li_2}(x) + 12\ln^2(1-x) - 3\pi^2\right]\right.
+ 6(x+5)\ln(1-x) \\
&\qquad\qquad + \frac{1}{1-x}\left[\frac32(1+8x+3x^2)\ln x
+ 12(1+x^2)\ln x\ln(1-x) \right. \\
&\qquad\qquad\qquad\qquad
\left.\left. - \frac12(1+7x^2)\ln^2x + \frac14(39-24x-15x^2)\right]
\vphantom{\frac{1}{1-x}} \right)
\end{split}
\end{align}
where the successive approximations to the prefactor of the leading
singularity
\begin{equation}
g(\epsilon) = \frac{\exp\left(\epsilon(-\gamma_E + \tfrac34)\right)}
{\Gamma(1 + \epsilon)},
\end{equation}
are given by
\begin{align}
g_0(\epsilon) &= 1 \\
g_1(\epsilon) &= 1 + \frac34\epsilon \\
g_2(\epsilon) &= 1 + \frac34\epsilon
+ \frac{27 - 8\pi^2}{96}\epsilon^2 \\
g_3(\epsilon) &= 1 + \frac34\epsilon
+ \frac{27 - 8\pi^2}{96}\epsilon^2
+ \frac{27 - 24\pi^2 + 128 \zeta(3)}{384}\epsilon^3,
\end{align}
where, numerically
\begin{equation}
\zeta(3) = 1.20205690315959428539973816151\ldots
\end{equation}
Although one could calculate the function $g(\epsilon)$ exactly,
truncating its Taylor expansion ensures the exact normalization of the
truncated structure function at each given order:
\begin{equation}
\int_0^1 dx\,f_i(x) = 1 \qquad\text{for all $i$.}
\end{equation}
Effectively, the $O(\epsilon)$ correction reduces the low-$x$ tail of
the structure function by $50\%$ while increasing the coefficient of
the singularity by $O(\epsilon)$. Relative to this, the
$O(\epsilon^2)$ correction slightly enhances $x>\frac12$ compared to
$x<\frac12$. At $x=0$, $f_2(x)$ introduces a logarithmic singularity
which should be cut off at $x_0=O(e^{-1/\epsilon})$: for lower $x$ the
perturbative series breaks down. The $f_3$ correction is slightly
positive for low $x$ values and negative near $x=1$, where the
$\mathop{\rm Li_2}$ piece slightly softens the singularity at $x=1$.
Instead of the definition for $\epsilon$ given above, it is customary
to include a universal nonlogarithmic piece:
\begin{equation}
\epsilon = \frac{\alpha}{\pi}q_e^2\left(\ln\tfrac{s}{m^2} - 1\right)
\end{equation}
\subsection{Implementation}
The basic type for lepton beam (QED) structure functions:
<<Electron PDFs: public>>=
public :: qed_pdf_t
<<Electron PDFs: types>>=
type :: qed_pdf_t
private
integer :: flv = 0
real(default) :: mass = 0
real(default) :: q_max = 0
real(default) :: alpha = 0
real(default) :: eps = 0
integer :: order
contains
<<Electron PDFs: QED PDF: TBP>>
end type qed_pdf_t
@ %def qed_pdf_t
@
<<Electron PDFs: QED PDF: TBP>>=
procedure :: init => qed_pdf_init
+<<Electron PDFs: sub interfaces>>=
+ module subroutine qed_pdf_init &
+ (qed_pdf, mass, alpha, charge, q_max, order)
+ class(qed_pdf_t), intent(out) :: qed_pdf
+ real(default), intent(in) :: mass, alpha, q_max, charge
+ integer, intent(in) :: order
+ end subroutine qed_pdf_init
<<Electron PDFs: procedures>>=
- subroutine qed_pdf_init &
+ module subroutine qed_pdf_init &
(qed_pdf, mass, alpha, charge, q_max, order)
class(qed_pdf_t), intent(out) :: qed_pdf
real(default), intent(in) :: mass, alpha, q_max, charge
integer, intent(in) :: order
qed_pdf%mass = mass
qed_pdf%q_max = q_max
qed_pdf%alpha = alpha
qed_pdf%order = order
qed_pdf%eps = alpha/pi * charge**2 &
* (2 * log (q_max / mass) - 1)
end subroutine qed_pdf_init
@ %def qed_pdf_init
@ Write routine.
<<Electron PDFs: QED PDF: TBP>>=
procedure :: write => qed_pdf_write
+<<Electron PDFs: sub interfaces>>=
+ module subroutine qed_pdf_write (qed_pdf, unit)
+ class(qed_pdf_t), intent(in) :: qed_pdf
+ integer, intent(in), optional :: unit
+ integer :: u
+ end subroutine qed_pdf_write
<<Electron PDFs: procedures>>=
- subroutine qed_pdf_write (qed_pdf, unit)
+ module subroutine qed_pdf_write (qed_pdf, unit)
class(qed_pdf_t), intent(in) :: qed_pdf
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(3x,A)") "QED structure function (PDF):"
write (u, "(5x,A,I0)") "Flavor = ", qed_pdf%flv
write (u, "(5x,A," // FMT_19 // ")") "Mass = ", qed_pdf%mass
write (u, "(5x,A," // FMT_19 // ")") "q_max = ", qed_pdf%q_max
write (u, "(5x,A," // FMT_19 // ")") "alpha = ", qed_pdf%alpha
write (u, "(5x,A,I0)") "Order = ", qed_pdf%order
write (u, "(5x,A," // FMT_19 // ")") "epsilon = ", qed_pdf%eps
end subroutine qed_pdf_write
@ %def qed_pdf_write
@ For some unit tests, the order has to be set explicitly.
<<Electron PDFs: QED PDF: TBP>>=
procedure :: set_order => qed_pdf_set_order
+<<Electron PDFs: sub interfaces>>=
+ module subroutine qed_pdf_set_order (qed_pdf, order)
+ class(qed_pdf_t), intent(inout) :: qed_pdf
+ integer, intent(in) :: order
+ end subroutine qed_pdf_set_order
<<Electron PDFs: procedures>>=
- subroutine qed_pdf_set_order (qed_pdf, order)
+ module subroutine qed_pdf_set_order (qed_pdf, order)
class(qed_pdf_t), intent(inout) :: qed_pdf
integer, intent(in) :: order
qed_pdf%order = order
end subroutine qed_pdf_set_order
@ %def qed_pdf_set_order
@ Calculate the actual value depending on the order and a possible
mapping parameter.
<<Electron PDFs: QED PDF: TBP>>=
procedure :: evolve_qed_pdf => qed_pdf_evolve_qed_pdf
+<<Electron PDFs: sub interfaces>>=
+ module subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff)
+ class(qed_pdf_t), intent(inout) :: qed_pdf
+ real(default), intent(in) :: x, xb, rb
+ real(default), intent(inout) :: ff
+ end subroutine qed_pdf_evolve_qed_pdf
<<Electron PDFs: procedures>>=
- subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff)
+ module subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff)
class(qed_pdf_t), intent(inout) :: qed_pdf
real(default), intent(in) :: x, xb, rb
real(default), intent(inout) :: ff
real(default), parameter :: &
& xmin = 0.00714053329734592839549879772019_default
real(default), parameter :: &
- & zeta3 = 1.20205690315959428539973816151_default
- real(default), parameter :: &
g1 = 3._default / 4._default, &
g2 = (27 - 8 * pi**2) / 96._default, &
g3 = (27 - 24 * pi**2 + 128 * zeta3) / 384._default
real(default) :: x_2, log_x, log_xb
if (ff > 0 .and. qed_pdf%order > 0) then
ff = ff * (1 + g1 * qed_pdf%eps)
x_2 = x * x
if (rb > 0) ff = ff * (1 - (1-x_2) / (2 * rb))
if (qed_pdf%order > 1) then
ff = ff * (1 + g2 * qed_pdf%eps**2)
if (rb > 0 .and. xb > 0 .and. x > xmin) then
log_x = log_prec (x, xb)
log_xb = log_prec (xb, x)
ff = ff * (1 - ((1 + 3 * x_2) * log_x + xb * (4 * (1 + x) * &
log_xb + 5 + x)) / (8 * rb) * qed_pdf%eps)
end if
if (qed_pdf%order > 2) then
ff = ff * (1 + g3 * qed_pdf%eps**3)
if (rb > 0 .and. xb > 0 .and. x > xmin) then
ff = ff * (1 - ((1 + x) * xb &
* (6 * Li2(x) + 12 * log_xb**2 - 3 * pi**2) &
+ 1.5_default * (1 + 8 * x + 3 * x_2) * log_x &
+ 6 * (x + 5) * xb * log_xb &
+ 12 * (1 + x_2) * log_x * log_xb &
- (1 + 7 * x_2) * log_x**2 / 2 &
+ (39 - 24 * x - 15 * x_2) / 4) &
/ (48 * rb) * qed_pdf%eps**2)
end if
end if
end if
end if
end subroutine qed_pdf_evolve_qed_pdf
@ %def qed_pdf_evolve_qed_pdf
@
Index: trunk/src/basics/Makefile.am
===================================================================
--- trunk/src/basics/Makefile.am (revision 8768)
+++ trunk/src/basics/Makefile.am (revision 8769)
@@ -1,107 +1,107 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory end up in an auxiliary libtool library.
noinst_LTLIBRARIES = libbasics.la
nodist_libbasics_la_SOURCES = \
kinds.f90
libbasics_la_SOURCES = \
iso_varying_string.f90 \
io_units.f90 \
constants.f90
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
${nodist_libbasics_la_SOURCES:.f90=.$(FCMOD)} \
${libbasics_la_SOURCES:.f90=.$(FCMOD)}
libbasics_Modules = \
${nodist_libbasics_la_SOURCES:.f90=} \
${libbasics_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libbasics_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
SUFFIXES = .lo .$(FCMOD)
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
# Explicit dependencies
constants.lo: kinds.lo
AM_FCFLAGS =
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
.PHONY: clean-noweb
clean-local: clean-noweb
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
DISTCLEANFILES = kinds.f90
## Remove backup files
maintainer-clean-local:
-rm -f *~
Index: trunk/src/combinatorics/Makefile.am
===================================================================
--- trunk/src/combinatorics/Makefile.am (revision 8768)
+++ trunk/src/combinatorics/Makefile.am (revision 8769)
@@ -1,233 +1,233 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory implement standard algorithms for WHIZARD
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libcombinatorics.la
check_LTLIBRARIES = libcombinatorics_ut.la
COMMON_F90 = \
bytes.f90 \
hashes.f90 \
md5.f90 \
permutations.f90 \
sorting.f90 \
solver.f90
MPI_F90 = \
grids.f90_mpi
SERIAL_F90 = \
grids.f90_serial
EXTRA_DIST = \
$(COMMON_F90) \
$(SERIAL_F90) \
$(MPI_F90)
nodist_libcombinatorics_la_SOURCES = \
$(COMMON_F90) \
grids.f90
DISTCLEANFILES = grids.f90
if FC_USE_MPI
grids.f90: grids.f90_mpi
-cp -f $< $@
else
grids.f90: grids.f90_serial
-cp -f $< $@
endif
libcombinatorics_ut_la_SOURCES = \
md5_uti.f90 md5_ut.f90 \
sorting_uti.f90 sorting_ut.f90 \
grids_uti.f90 grids_ut.f90 \
solver_uti.f90 solver_ut.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = combinatorics.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
${nodist_libcombinatorics_la_SOURCES:.f90=.$(FCMOD)}
libcombinatorics_Modules = \
${nodist_libcombinatorics_la_SOURCES:.f90=} \
${libcombinatorics_ut_la_SOURCES:.f90=}
Modules: Makefile
@for module in \
$(libcombinatorics_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../testing/Modules \
../system/Modules \
../utilities/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(nodist_libcombinatorics_la_SOURCES) \
$(libcombinatorics_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES += Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(nodist_libcombinatorics_la_SOURCES) \
$(libcombinatorics_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../testing -I../system -I../utilities
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
FILTER = -filter "sed 's/defn MPI:/defn/'"
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
combinatorics.stamp: $(PRELUDE) $(srcdir)/combinatorics.nw $(POSTLUDE)
@rm -f combinatorics.tmp
@touch combinatorics.tmp
for src in $(COMMON_F90) $(libcombinatorics_ut_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
for src in $(SERIAL_F90:.f90_serial=.f90); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \
done
for src in $(MPI_F90:.f90_mpi=.f90); do \
$(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \
done
@mv -f combinatorics.tmp combinatorics.stamp
$(COMMON_F90) $(SERIAL_F90) $(MPI_F90) $(libcombinatorics_ut_la_SOURCES): combinatorics.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f combinatorics.stamp; \
$(MAKE) $(AM_MAKEFLAGS) combinatorics.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.f90_serial *.f90_mpi *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.f90_serial *.f90_mpi *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f combinatorics.stamp combinatorics.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/combinatorics/combinatorics.nw
===================================================================
--- trunk/src/combinatorics/combinatorics.nw (revision 8768)
+++ trunk/src/combinatorics/combinatorics.nw (revision 8769)
@@ -1,3444 +1,3444 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: combinatorics and such
\chapter{Combinatorics}
\includemodulegraph{combinatorics}
These modules implement standard algorithms (sorting, hashing, etc.)
that are not available in Fortran.
Fortran doesn't support generic programming, therefore the algorithms
are implemented only for specific data types.
\begin{description}
\item[bytes]
Derived types for bytes and words.
\item[hashes]
Types and tools for setting up hashtables.
\item[md5]
The MD5 algorithm for message digest.
\item[permutations]
Permuting an array of integers.
\item[sorting]
Sorting integer and real values.
\item[grids]
$d$-dimensional grids can be saved to disk and used for interpolation,
maximum finding, etc.
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Bytes and such}
In a few instances we will need the notion of a byte (8-bit) and a word
(32 bit), even a 64-bit word. A block of 512 bit is also needed (for
MD5).
We rely on integers up to 64 bit being supported by the processor.
The main difference to standard integers is the interpretation as
unsigned integers.
<<[[bytes.f90]]>>=
<<File header>>
module bytes
use kinds, only: i8, i32, i64
use io_units
<<Standard module head>>
<<Bytes: public>>
<<Bytes: types>>
<<Bytes: parameters>>
<<Bytes: interfaces>>
contains
<<Bytes: procedures>>
end module bytes
@ %def bytes
@
\subsection{8-bit words: bytes}
This is essentially a wrapper around 8-bit integers. The wrapper
emphasises their special interpretation as a sequence of bits.
However, we interpret bytes as unsigned integers.
<<Bytes: public>>=
public :: byte_t
<<Bytes: types>>=
type :: byte_t
private
integer(i8) :: i
end type byte_t
@ %def byte
<<Bytes: public>>=
public :: byte_zero
<<Bytes: parameters>>=
type(byte_t), parameter :: byte_zero = byte_t (0_i8)
@ %def byte_zero
@ Set a byte from 8-bit integer:
<<Bytes: public>>=
public :: assignment(=)
<<Bytes: interfaces>>=
interface assignment(=)
module procedure set_byte_from_i8
end interface
@ %def =
<<Bytes: procedures>>=
subroutine set_byte_from_i8 (b, i)
type(byte_t), intent(out) :: b
integer(i8), intent(in) :: i
b%i = i
end subroutine set_byte_from_i8
@ %def set_byte_from_i8
@ Write a byte in one of two formats: either as a hexadecimal number
(two digits, default) or as a decimal number (one to three digits).
The decimal version is nontrivial because bytes are unsigned integers.
Optionally append a newline.
<<Bytes: public>>=
public :: byte_write
<<Bytes: interfaces>>=
interface byte_write
module procedure byte_write_unit, byte_write_string
end interface
<<Bytes: procedures>>=
subroutine byte_write_unit (b, unit, decimal, newline)
type(byte_t), intent(in), optional :: b
integer, intent(in), optional :: unit
logical, intent(in), optional :: decimal, newline
logical :: dc, nl
type(word32_t) :: w
integer :: u
u = given_output_unit (unit); if (u < 0) return
dc = .false.; if (present (decimal)) dc = decimal
nl = .false.; if (present (newline)) nl = newline
if (dc) then
w = b
write (u, '(I3)', advance='no') w%i
else
write (u, '(z2.2)', advance='no') b%i
end if
if (nl) write (u, *)
end subroutine byte_write_unit
@ %def byte_write_unit
@ The string version is hex-only
<<Bytes: procedures>>=
subroutine byte_write_string (b, s)
type(byte_t), intent(in) :: b
character(len=2), intent(inout) :: s
write (s, '(z2.2)') b%i
end subroutine byte_write_string
@ %def byte_write_string
@
\subsection{32-bit words}
This is not exactly a 32-bit integer. A word is to be filled with
bytes, and it may be partially filled. The filling is done lowest-byte
first, highest-byte last. We count the bits, so [[fill]] should be
either 0, 8, 16, 24, or 32.
In printing words, we correspondingly
distinguish between printing zeros and printing blanks.
<<Bytes: public>>=
public :: word32_t
<<Bytes: types>>=
type :: word32_t
private
integer(i32) :: i
integer :: fill = 0
end type word32_t
@ %def word32
@ Assignment: the word is filled by inserting a 32-bit integer
<<Bytes: interfaces>>=
interface assignment(=)
module procedure word32_set_from_i32
module procedure word32_set_from_byte
end interface
@ %def =
<<Bytes: procedures>>=
subroutine word32_set_from_i32 (w, i)
type(word32_t), intent(out) :: w
integer(i32), intent(in) :: i
w%i = i
w%fill = 32
end subroutine word32_set_from_i32
@ %def word32_set_from_i32
@ Reverse assignment to a 32-bit integer. We do not check the fill
status.
<<Bytes: interfaces>>=
interface assignment(=)
module procedure i32_from_word32
end interface
@ %def =
<<Bytes: procedures>>=
subroutine i32_from_word32 (i, w)
integer(i32), intent(out) :: i
type(word32_t), intent(in) :: w
i = w%i
end subroutine i32_from_word32
@ %def i32_from_word32
@ Filling with a 8-bit integer is slightly tricky, because in this
interpretation integers are unsigned.
<<Bytes: procedures>>=
subroutine word32_set_from_byte (w, b)
type(word32_t), intent(out) :: w
type(byte_t), intent(in) :: b
if (b%i >= 0_i8) then
w%i = b%i
else
w%i = 2_i32*(huge(0_i8)+1_i32) + b%i
end if
w%fill = 32
end subroutine word32_set_from_byte
@ %def word32_set_from_byte
@ Check the fill status
<<Bytes: public>>=
public :: word32_empty, word32_filled, word32_fill
<<Bytes: procedures>>=
function word32_empty (w)
type(word32_t), intent(in) :: w
logical :: word32_empty
word32_empty = (w%fill == 0)
end function word32_empty
function word32_filled (w)
type(word32_t), intent(in) :: w
logical :: word32_filled
word32_filled = (w%fill == 32)
end function word32_filled
function word32_fill (w)
type(word32_t), intent(in) :: w
integer :: word32_fill
word32_fill = w%fill
end function word32_fill
@ %def word32_empty word32_filled word32_fill
@ Partial assignment: append a byte to a partially filled word.
(Note: no assignment if the word is filled, so check this before if
necessary.)
<<Bytes: public>>=
public :: word32_append_byte
<<Bytes: procedures>>=
subroutine word32_append_byte (w, b)
type(word32_t), intent(inout) :: w
type(byte_t), intent(in) :: b
type(word32_t) :: w1
if (.not. word32_filled (w)) then
w1 = b
call mvbits (w1%i, 0, 8, w%i, w%fill)
w%fill = w%fill + 8
end if
end subroutine word32_append_byte
@ %def word32_append_byte
@ Extract a byte from a word. The argument [[i]] is the position,
which may be 0, 1, 2, or 3.
For the final assignment, we set the highest bit separately.
Otherwise, we might trigger an overflow condition for a compiler with
strict checking turned on.
<<Bytes: public>>=
public :: byte_from_word32
<<Bytes: procedures>>=
function byte_from_word32 (w, i) result (b)
type(word32_t), intent(in) :: w
integer, intent(in) :: i
type(byte_t) :: b
integer(i32) :: j
j = 0
if (i >= 0 .and. i*8 < w%fill) then
call mvbits (w%i, i*8, 8, j, 0)
end if
b%i = int (ibclr (j, 7), kind=i8)
if (btest (j, 7)) b%i = ibset (b%i, 7)
end function byte_from_word32
@ %def byte_from_word32
@ Write a word to file or STDOUT. We understand words as unsigned
integers, therefore we cannot use the built-in routine unchanged.
However, we can make use of the existence of 64-bit integers and their
output routine.
In hexadecimal format, the default version prints eight hex
characters, highest-first. The [[bytes]] version prints four bytes
(two-hex characters), lowest first, with spaces in-between. The
decimal bytes version is analogous. In the [[bytes]] version, missing
bytes are printed as whitespace.
<<Bytes: public>>=
public :: word32_write
<<Bytes: interfaces>>=
interface word32_write
module procedure word32_write_unit
end interface
<<Bytes: procedures>>=
subroutine word32_write_unit (w, unit, bytes, decimal, newline)
type(word32_t), intent(in) :: w
integer, intent(in), optional :: unit
logical, intent(in), optional :: bytes, decimal, newline
logical :: dc, by, nl
type(word64_t) :: ww
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
by = .false.; if (present (bytes)) by = bytes
dc = .false.; if (present (decimal)) dc = decimal
nl = .false.; if (present (newline)) nl = newline
if (by) then
do i = 0, 3
if (i>0) write (u, '(1x)', advance='no')
if (8*i < w%fill) then
call byte_write (byte_from_word32 (w, i), unit, decimal=decimal)
else if (dc) then
write (u, '(3x)', advance='no')
else
write (u, '(2x)', advance='no')
end if
end do
else if (dc) then
ww = w
write (u, '(I10)', advance='no') ww%i
else
select case (w%fill)
case ( 0)
case ( 8); write (6, '(1x,z8.2)', advance='no') ibits (w%i, 0, 8)
case (16); write (6, '(1x,z8.4)', advance='no') ibits (w%i, 0,16)
case (24); write (6, '(1x,z8.6)', advance='no') ibits (w%i, 0,24)
case (32); write (6, '(1x,z8.8)', advance='no') ibits (w%i, 0,32)
end select
end if
if (nl) write (u, *)
end subroutine word32_write_unit
@ %def word32_write_unit
@
\subsection{Operations on 32-bit words}
Define the usual logical operations, as well as addition (mod
$2^{32}$). We assume that all operands are completely filled.
<<Bytes: public>>=
public :: not, ior, ieor, iand, ishft, ishftc
<<Bytes: interfaces>>=
interface not
module procedure word_not
end interface
interface ior
module procedure word_or
end interface
interface ieor
module procedure word_eor
end interface
interface iand
module procedure word_and
end interface
interface ishft
module procedure word_shft
end interface
interface ishftc
module procedure word_shftc
end interface
@ %def not, ior, ieor, iand, ishftc
<<Bytes: procedures>>=
function word_not (w1) result (w2)
type(word32_t), intent(in) :: w1
type(word32_t) :: w2
w2 = not (w1%i)
end function word_not
function word_or (w1, w2) result (w3)
type(word32_t), intent(in) :: w1, w2
type(word32_t) :: w3
w3 = ior (w1%i, w2%i)
end function word_or
function word_eor (w1, w2) result (w3)
type(word32_t), intent(in) :: w1, w2
type(word32_t) :: w3
w3 = ieor (w1%i, w2%i)
end function word_eor
function word_and (w1, w2) result (w3)
type(word32_t), intent(in) :: w1, w2
type(word32_t) :: w3
w3 = iand (w1%i, w2%i)
end function word_and
function word_shft (w1, s) result (w2)
type(word32_t), intent(in) :: w1
integer, intent(in) :: s
type(word32_t) :: w2
w2 = ishft (w1%i, s)
end function word_shft
function word_shftc (w1, s) result (w2)
type(word32_t), intent(in) :: w1
integer, intent(in) :: s
type(word32_t) :: w2
w2 = ishftc (w1%i, s, 32)
end function word_shftc
@ %def word_not word_or word_eor word_and word_shft word_shftc
@ Addition is defined mod $2^{32}$, i.e., without overflow checking.
This means that we have to work around a possible overflow check enforced by
the compiler.
<<Bytes: public>>=
public :: operator(+)
<<Bytes: interfaces>>=
interface operator(+)
module procedure word_add
module procedure word_add_i8
module procedure word_add_i32
end interface
@ %def +
@
<<Bytes: procedures>>=
function word_add (w1, w2) result (w3)
type(word32_t), intent(in) :: w1, w2
type(word32_t) :: w3
integer(i64) :: j
j = int (ibclr (w1%i, 31), i64) + int (ibclr (w2%i, 31), i64)
w3 = int (ibclr (j, 31), kind=i32)
if (btest (j, 31)) then
if (btest (w1%i, 31) .eqv. btest (w2%i, 31)) w3 = ibset (w3%i, 31)
else
if (btest (w1%i, 31) .neqv. btest (w2%i, 31)) w3 = ibset (w3%i, 31)
end if
end function word_add
function word_add_i8 (w1, i) result (w3)
type(word32_t), intent(in) :: w1
integer(i8), intent(in) :: i
type(word32_t) :: w3
integer(i64) :: j
j = int (ibclr (w1%i, 31), i64) + int (ibclr (i, 7), i64)
if (btest (i, 7)) j = j + 128
w3 = int (ibclr (j, 31), kind=i32)
if (btest (j, 31) .neqv. btest (w1%i, 31)) w3 = ibset (w3%i, 31)
end function word_add_i8
function word_add_i32 (w1, i) result (w3)
type(word32_t), intent(in) :: w1
integer(i32), intent(in) :: i
type(word32_t) :: w3
integer(i64) :: j
j = int (ibclr (w1%i, 31), i64) + int (ibclr (i, 31), i64)
w3 = int (ibclr (j, 31), kind=i32)
if (btest (j, 31)) then
if (btest (w1%i, 31) .eqv. btest (i, 31)) w3 = ibset (w3%i, 31)
else
if (btest (w1%i, 31) .neqv. btest (i, 31)) w3 = ibset (w3%i, 31)
end if
end function word_add_i32
@ %def word_add word_add_i32
@
\subsection{64-bit words}
These objects consist of two 32-bit words. They thus can hold integer
numbers larger than $2^{32}$ (to be exact, $2^{31}$ since FORTRAN
integers are signed). The order is low-word, high-word.
<<Bytes: public>>=
public :: word64_t
<<Bytes: types>>=
type :: word64_t
private
integer(i64) :: i
end type word64_t
@ %def word64
@ Set a 64 bit word:
<<Bytes: interfaces>>=
interface assignment(=)
module procedure word64_set_from_i64
module procedure word64_set_from_word32
end interface
@ %def =
<<Bytes: procedures>>=
subroutine word64_set_from_i64 (ww, i)
type(word64_t), intent(out) :: ww
integer(i64), intent(in) :: i
ww%i = i
end subroutine word64_set_from_i64
@ %def word64_set_from_i64
@ Filling with a 32-bit word:
<<Bytes: procedures>>=
subroutine word64_set_from_word32 (ww, w)
type(word64_t), intent(out) :: ww
type(word32_t), intent(in) :: w
if (w%i >= 0_i32) then
ww%i = w%i
else
ww%i = 2_i64*(huge(0_i32)+1_i64) + w%i
end if
end subroutine word64_set_from_word32
@ %def word64_set_from_word32
@ Extract a byte from a word. The argument [[i]] is the position,
which may be between 0 and 7.
For the final assignment, we set the highest bit separately.
Otherwise, we might trigger an overflow condition for a compiler with
strict checking turned on.
<<Bytes: public>>=
public :: byte_from_word64, word32_from_word64
<<Bytes: procedures>>=
function byte_from_word64 (ww, i) result (b)
type(word64_t), intent(in) :: ww
integer, intent(in) :: i
type(byte_t) :: b
integer(i64) :: j
j = 0
if (i >= 0 .and. i*8 < 64) then
call mvbits (ww%i, i*8, 8, j, 0)
end if
b%i = int (ibclr (j, 7), kind=i8)
if (btest (j, 7)) b%i = ibset (b%i, 7)
end function byte_from_word64
@ %def byte_from_word64
@ Extract a 32-bit word from a 64-bit word. The position is either 0
or 1.
<<Bytes: procedures>>=
function word32_from_word64 (ww, i) result (w)
type(word64_t), intent(in) :: ww
integer, intent(in) :: i
type(word32_t) :: w
integer(i64) :: j
j = 0
select case (i)
case (0); call mvbits (ww%i, 0, 32, j, 0)
case (1); call mvbits (ww%i, 32, 32, j, 0)
end select
w = int (ibclr (j, 31), kind=i32)
if (btest (j, 31)) w = ibset (w%i, 31)
end function word32_from_word64
@ %def word32_from_word64
@ Print a 64-bit word. Decimal version works up to $2^{63}$.
The [[words]] version uses the 'word32' printout, separated by two
spaces. The low-word is printed first. The [[bytes]] version also
uses the 'word32' printout. This implies that the lowest byte is
first. The default version prints a hexadecimal
number without spaces, highest byte first.
<<Bytes: public>>=
public :: word64_write
<<Bytes: interfaces>>=
interface word64_write
module procedure word64_write_unit
end interface
<<Bytes: procedures>>=
subroutine word64_write_unit (ww, unit, words, bytes, decimal, newline)
type(word64_t), intent(in) :: ww
integer, intent(in), optional :: unit
logical, intent(in), optional :: words, bytes, decimal, newline
logical :: wo, by, dc, nl
integer :: u
u = given_output_unit (unit); if (u < 0) return
wo = .false.; if (present (words)) wo = words
by = .false.; if (present (bytes)) by = bytes
dc = .false.; if (present (decimal)) dc = decimal
nl = .false.; if (present (newline)) nl = newline
if (wo .or. by) then
call word32_write_unit (word32_from_word64 (ww, 0), unit, by, dc)
write (u, '(2x)', advance='no')
call word32_write_unit (word32_from_word64 (ww, 1), unit, by, dc)
else if (dc) then
write (u, '(I19)', advance='no') ww%i
else
write (u, '(Z16)', advance='no') ww%i
end if
if (nl) write (u, *)
end subroutine word64_write_unit
@ %def word64_write_unit
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Hashtables}
Hash tables, like lists, are not part of Fortran and must be defined
on a per-case basis. In this section we define a module that contains
a hash function.
Furthermore, for reference there is a complete framework of hashtable
type definitions and access functions. This code is to be replicated
where hash tables are used, mutatis mutandis.
<<[[hashes.f90]]>>=
<<File header>>
module hashes
use kinds, only: i8, i32
use bytes
<<Standard module head>>
<<Hashes: public>>
contains
<<Hashes: procedures>>
end module hashes
@ %def hashes
@
\subsection{The hash function}
This is the one-at-a-time hash function by Bob Jenkins (from
Wikipedia), re-implemented in Fortran. The function works on an array
of bytes (8-bit integers), as could be produced by, e.g., the
[[transfer]] function, and returns a single 32-bit integer. For
determining the position in a hashtable, one can pick the lower bits
of the result as appropriate to the hashtable size (which should be a
power of 2). Note that we are working on signed integers, so the
interpretation of values differs from the C version. This should not
matter in practice, however.
<<Hashes: public>>=
public :: hash
<<Hashes: procedures>>=
function hash (key) result (hashval)
integer(i32) :: hashval
integer(i8), dimension(:), intent(in) :: key
type(word32_t) :: w
integer :: i
w = 0_i32
do i = 1, size (key)
w = w + key(i)
w = w + ishft (w, 10)
w = ieor (w, ishft (w, -6))
end do
w = w + ishft (w, 3)
w = ieor (w, ishft (w, -11))
w = w + ishft (w, 15)
hashval = w
end function hash
@ %def hash
@
\subsection{The hash table}
We define a generic hashtable type (that depends on the
[[hash_data_t]] type) together with associated methods.
This is a template:
<<Hashtables: types>>=
type :: hash_data_t
integer :: i
end type hash_data_t
@ %def hash_data_t
@ Associated methods:
<<Hashtables: procedures>>=
subroutine hash_data_final (data)
type(hash_data_t), intent(inout) :: data
end subroutine hash_data_final
subroutine hash_data_write (data, unit)
type(hash_data_t), intent(in) :: data
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, *) data%i
end subroutine hash_data_write
@ %def hash_data_final hash_data_write
@ Each hash entry stores the unmasked hash value, the key, and points to
actual data if present. Note that this could be an allocatable scalar
in principle, but making it a pointer avoids deep copy when expanding
the hashtable.
<<Hashtables: types>>=
type :: hash_entry_t
integer(i32) :: hashval = 0
integer(i8), dimension(:), allocatable :: key
type(hash_data_t), pointer :: data => null ()
end type hash_entry_t
@ %def hash_entry_t
@ The hashtable object holds the actual table, the number of filled
entries and the number of entries after which the size should be
doubled. The mask is equal to the table size minus one and thus
coincides with the upper bound of the table index, which starts at zero.
<<Hashtables: types>>=
type :: hashtable_t
integer :: n_entries = 0
real :: fill_ratio = 0
integer :: n_entries_max = 0
integer(i32) :: mask = 0
type(hash_entry_t), dimension(:), allocatable :: entry
end type hashtable_t
@ %def hashtable_t
@ Initializer: The size has to be a power of two, the fill ratio is a
real (machine-default!) number between 0 and 1.
<<Hashtables: procedures>>=
subroutine hashtable_init (hashtable, size, fill_ratio)
type(hashtable_t), intent(out) :: hashtable
integer, intent(in) :: size
real, intent(in) :: fill_ratio
hashtable%fill_ratio = fill_ratio
hashtable%n_entries_max = size * fill_ratio
hashtable%mask = size - 1
allocate (hashtable%entry (0:hashtable%mask))
end subroutine hashtable_init
@ %def hashtable_init
@ Finalizer: This calls a [[hash_data_final]] subroutine which must
exist.
<<Hashtables: procedures>>=
subroutine hashtable_final (hashtable)
type(hashtable_t), intent(inout) :: hashtable
integer :: i
do i = 0, hashtable%mask
if (associated (hashtable%entry(i)%data)) then
call hash_data_final (hashtable%entry(i)%data)
deallocate (hashtable%entry(i)%data)
end if
end do
deallocate (hashtable%entry)
end subroutine hashtable_final
@ %def hashtable_final
@ Output. Here, we refer to a [[hash_data_write]] subroutine.
<<Hashtables: procedures>>=
subroutine hashtable_write (hashtable, unit)
type(hashtable_t), intent(in) :: hashtable
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
do i = 0, hashtable%mask
if (associated (hashtable%entry(i)%data)) then
write (u, *) i, "(hash =", hashtable%entry(i)%hashval, ")", &
hashtable%entry(i)%key
call hash_data_write (hashtable%entry(i)%data, unit)
end if
end do
end subroutine hashtable_write
@ %def hashtable_write
@
\subsection{Hashtable insertion}
Insert a single entry with the hash value as trial place. If the
table is filled, first expand it.
<<Hashtables: procedures>>=
subroutine hashtable_insert (hashtable, key, data)
type(hashtable_t), intent(inout) :: hashtable
integer(i8), dimension(:), intent(in) :: key
type(hash_data_t), intent(in), target :: data
integer(i32) :: h
if (hashtable%n_entries >= hashtable%n_entries_max) &
call hashtable_expand (hashtable)
h = hash (key)
call hashtable_insert_rec (hashtable, h, h, key, data)
end subroutine hashtable_insert
@ %def hashtable_insert
@ We need this auxiliary routine for doubling the size of the
hashtable. We rely on the fact that default assignment copies
the data pointer, not the data themselves. The temporary array must
not be finalized; it is deallocated automatically together with its
allocatable components.
<<Hashtables: procedures>>=
subroutine hashtable_expand (hashtable)
type(hashtable_t), intent(inout) :: hashtable
type(hash_entry_t), dimension(:), allocatable :: table_tmp
integer :: i, s
allocate (table_tmp (0:hashtable%mask))
table_tmp = hashtable%entry
deallocate (hashtable%entry)
s = 2 * size (table_tmp)
hashtable%n_entries = 0
hashtable%n_entries_max = s * hashtable%fill_ratio
hashtable%mask = s - 1
allocate (hashtable%entry (0:hashtable%mask))
do i = 0, ubound (table_tmp, 1)
if (associated (table_tmp(i)%data)) then
call hashtable_insert_rec (hashtable, table_tmp(i)%hashval, &
table_tmp(i)%hashval, table_tmp(i)%key, table_tmp(i)%data)
end if
end do
end subroutine hashtable_expand
@ %def hashtable_expand
@ Insert a single entry at a trial place [[h]], reduced to the table
size. Collision resolution is done simply by choosing the next
element, recursively until the place is empty. For bookkeeping, we
preserve the original hash value. For a good hash function, there
should be no clustering.
Note that if the new key exactly matches an existing key, nothing is done.
<<Hashtables: procedures>>=
recursive subroutine hashtable_insert_rec (hashtable, h, hashval, key, data)
type(hashtable_t), intent(inout) :: hashtable
integer(i32), intent(in) :: h, hashval
integer(i8), dimension(:), intent(in) :: key
type(hash_data_t), intent(in), target :: data
integer(i32) :: i
i = iand (h, hashtable%mask)
if (associated (hashtable%entry(i)%data)) then
if (size (hashtable%entry(i)%key) /= size (key)) then
call hashtable_insert_rec (hashtable, h + 1, hashval, key, data)
else if (any (hashtable%entry(i)%key /= key)) then
call hashtable_insert_rec (hashtable, h + 1, hashval, key, data)
end if
else
hashtable%entry(i)%hashval = hashval
allocate (hashtable%entry(i)%key (size (key)))
hashtable%entry(i)%key = key
hashtable%entry(i)%data => data
hashtable%n_entries = hashtable%n_entries + 1
end if
end subroutine hashtable_insert_rec
@ %def hashtable_insert_rec
@
\subsection{Hashtable lookup}
The lookup function has to parallel the insert function. If the place
is filled, check if the key matches. Yes: return the pointer; no:
increment the hash value and check again.
<<Hashtables: procedures>>=
function hashtable_lookup (hashtable, key) result (ptr)
type(hash_data_t), pointer :: ptr
type(hashtable_t), intent(in) :: hashtable
integer(i8), dimension(:), intent(in) :: key
ptr => hashtable_lookup_rec (hashtable, hash (key), key)
end function hashtable_lookup
@ %def hashtable_get_data_ptr
<<Hashtables: procedures>>=
recursive function hashtable_lookup_rec (hashtable, h, key) result (ptr)
type(hash_data_t), pointer :: ptr
type(hashtable_t), intent(in) :: hashtable
integer(i32), intent(in) :: h
integer(i8), dimension(:), intent(in) :: key
integer(i32) :: i
i = iand (h, hashtable%mask)
if (associated (hashtable%entry(i)%data)) then
if (size (hashtable%entry(i)%key) == size (key)) then
if (all (hashtable%entry(i)%key == key)) then
ptr => hashtable%entry(i)%data
else
ptr => hashtable_lookup_rec (hashtable, h + 1, key)
end if
else
ptr => hashtable_lookup_rec (hashtable, h + 1, key)
end if
else
ptr => null ()
end if
end function hashtable_lookup_rec
@ %def hashtable_lookup_rec
<<Hashtables: public>>=
public :: hashtable_test
<<Hashtables: procedures>>=
subroutine hashtable_test ()
type(hash_data_t), pointer :: data
type(hashtable_t) :: hashtable
integer(i8) :: i
call hashtable_init (hashtable, 16, 0.25)
do i = 1, 10
allocate (data)
data%i = i*i
call hashtable_insert (hashtable, [i, i+i], data)
end do
call hashtable_insert (hashtable, [2_i8, 4_i8], data)
call hashtable_write (hashtable)
data => hashtable_lookup (hashtable, [5_i8, 10_i8])
if (associated (data)) then
print *, "lookup:", data%i
else
print *, "lookup: --"
end if
data => hashtable_lookup (hashtable, [6_i8, 12_i8])
if (associated (data)) then
print *, "lookup:", data%i
else
print *, "lookup: --"
end if
data => hashtable_lookup (hashtable, [4_i8, 9_i8])
if (associated (data)) then
print *, "lookup:", data%i
else
print *, "lookup: --"
end if
call hashtable_final (hashtable)
end subroutine hashtable_test
@ %def hashtable_test
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{MD5 Checksums}
Implementing MD5 checksums allows us
to check input/file integrity on the basis of a well-known standard.
The building blocks have been introduced in the [[bytes]] module.
<<[[md5.f90]]>>=
<<File header>>
module md5
use kinds, only: i8, i32, i64
use io_units
use system_defs, only: BUFFER_SIZE
use system_defs, only: LF, EOR, EOF
use diagnostics
use bytes
<<Standard module head>>
<<MD5: public>>
<<MD5: types>>
<<MD5: variables>>
<<MD5: interfaces>>
contains
<<MD5: procedures>>
end module md5
@ %def md5
@
\subsection{Blocks}
A block is a sequence of 16 words (64 bytes or 512 bits). We
anticipate that blocks will be linked, so include a pointer to the
next block. There is a fill status (word counter), as there is one
for each word. The fill status is equal to the number of bytes that
are in, so it may be between 0 and 64.
<<MD5: types>>=
type :: block_t
private
type(word32_t), dimension(0:15) :: w
type(block_t), pointer :: next => null ()
integer :: fill = 0
end type block_t
@ %def block
@ Check if a block is completely filled or empty:
<<MD5: procedures>>=
function block_is_empty (b)
type(block_t), intent(in) :: b
logical :: block_is_empty
block_is_empty = (b%fill == 0 .and. word32_empty (b%w(0)))
end function block_is_empty
function block_is_filled (b)
type(block_t), intent(in) :: b
logical :: block_is_filled
block_is_filled = (b%fill == 64)
end function block_is_filled
@ %def block_is_empty block_is_filled
@ Append a single byte to a block. Works only if the block is not yet
filled.
<<MD5: procedures>>=
subroutine block_append_byte (bl, by)
type(block_t), intent(inout) :: bl
type(byte_t), intent(in) :: by
if (.not. block_is_filled (bl)) then
call word32_append_byte (bl%w(bl%fill/4), by)
bl%fill = bl%fill + 1
end if
end subroutine block_append_byte
@ %def block_append_byte
@ The printing routine allows for printing as sequences of words or
bytes, decimal or hex.
<<MD5: interfaces>>=
interface block_write
module procedure block_write_unit
end interface
<<MD5: procedures>>=
subroutine block_write_unit (b, unit, bytes, decimal)
type(block_t), intent(in) :: b
integer, intent(in), optional :: unit
logical, intent(in), optional :: bytes, decimal
logical :: by, dc
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
by = .false.; if (present (bytes)) by = bytes
dc = .false.; if (present (decimal)) dc = decimal
do i = 0, b%fill/4 - 1
call newline_or_blank (u, i, by, dc)
call word32_write (b%w(i), unit, bytes, decimal)
end do
if (.not. block_is_filled (b)) then
i = b%fill/4
if (.not. word32_empty (b%w(i))) then
call newline_or_blank (u, i, by, dc)
call word32_write (b%w(i), unit, bytes, decimal)
end if
end if
write (u, *)
contains
subroutine newline_or_blank (u, i, bytes, decimal)
integer, intent(in) :: u, i
logical, intent(in) :: bytes, decimal
if (decimal) then
select case (i)
case (0)
case (2,4,6,8,10,12,14); write (u, *)
case default
write (u, '(2x)', advance='no')
end select
else if (bytes) then
select case (i)
case (0)
case (4,8,12); write (u, *)
case default
write (u, '(2x)', advance='no')
end select
else
if (i == 8) write (u, *)
end if
end subroutine newline_or_blank
end subroutine block_write_unit
@ %def block_write_unit
@
\subsection{Messages}
A message (within this module) is a linked list of blocks.
<<MD5: types>>=
type :: message_t
private
type(block_t), pointer :: first => null ()
type(block_t), pointer :: last => null ()
integer :: n_blocks = 0
end type message_t
@ %def message_t
@ Clear the message list
<<MD5: procedures>>=
subroutine message_clear (m)
type(message_t), intent(inout) :: m
type(block_t), pointer :: b
nullify (m%last)
do
b => m%first
if (.not.(associated (b))) exit
m%first => b%next
deallocate (b)
end do
m%n_blocks = 0
end subroutine message_clear
@ %def message_clear
@ Append an empty block to the message list
<<MD5: procedures>>=
subroutine message_append_new_block (m)
type(message_t), intent(inout) :: m
if (associated (m%last)) then
allocate (m%last%next)
m%last => m%last%next
m%n_blocks = m%n_blocks + 1
else
allocate (m%first)
m%last => m%first
m%n_blocks = 1
end if
end subroutine message_append_new_block
@ %def message_append_new_block
@ Initialize: clear and allocate the first (empty) block.
<<MD5: procedures>>=
subroutine message_init (m)
type(message_t), intent(inout) :: m
call message_clear (m)
call message_append_new_block (m)
end subroutine message_init
@ %def message_init
@ Append a single byte to a message. If necessary, allocate a new
block. If the message is empty, initialize it.
<<MD5: procedures>>=
subroutine message_append_byte (m, b)
type(message_t), intent(inout) :: m
type(byte_t), intent(in) :: b
if (.not. associated (m%last)) then
call message_init (m)
else if (block_is_filled (m%last)) then
call message_append_new_block (m)
end if
call block_append_byte (m%last, b)
end subroutine message_append_byte
@ %def message_append_byte
@ Append zero bytes until the current block is filled up to the required
position. If we are already beyond that, append a new block and fill
that one.
<<MD5: procedures>>=
subroutine message_pad_zero (m, i)
type(message_t), intent(inout) :: m
integer, intent(in) :: i
type(block_t), pointer :: b
integer :: j
if (associated (m%last)) then
b => m%last
if (b%fill > i) then
do j = b%fill + 1, 64 + i
call message_append_byte (m, byte_zero)
end do
else
do j = b%fill + 1, i
call message_append_byte (m, byte_zero)
end do
end if
end if
end subroutine message_pad_zero
@ %def message_pad_zero
@ This returns the number of bits within a message. We need a 64-bit
word for the result since it may be more than $2^{31}$. This is also
required by the MD5 standard.
<<MD5: procedures>>=
function message_bits (m) result (length)
type(message_t), intent(in) :: m
type(word64_t) :: length
type(block_t), pointer :: b
integer(i64) :: n_blocks_filled, n_bytes_extra
if (m%n_blocks > 0) then
b => m%last
if (block_is_filled (b)) then
n_blocks_filled = m%n_blocks
n_bytes_extra = 0
else
n_blocks_filled = m%n_blocks - 1
n_bytes_extra = b%fill
end if
length = n_blocks_filled * 512 + n_bytes_extra * 8
else
length = 0_i64
end if
end function message_bits
@ %def message_bits
@
\subsection{Message I/O}
Append the contents of a string to a message. We first cast the
character string into a 8-bit integer array and the append this byte
by byte.
<<MD5: procedures>>=
subroutine message_append_string (m, s)
type(message_t), intent(inout) :: m
character(len=*), intent(in) :: s
integer(i64) :: i, n_bytes
integer(i8), dimension(:), allocatable :: buffer
integer(i8), dimension(1) :: mold
type(byte_t) :: b
n_bytes = size (transfer (s, mold))
allocate (buffer (n_bytes))
buffer = transfer (s, mold)
do i = 1, size (buffer)
b = buffer(i)
call message_append_byte (m, b)
end do
deallocate (buffer)
end subroutine message_append_string
@ %def message_append_string
@ Append the contents of a 32-bit integer to a message. We first cast the
32-bit integer into a 8-bit integer array and the append this byte
by byte.
<<MD5: procedures>>=
subroutine message_append_i32 (m, x)
type(message_t), intent(inout) :: m
integer(i32), intent(in) :: x
integer(i8), dimension(4) :: buffer
type(byte_t) :: b
integer :: i
buffer = transfer (x, buffer, size(buffer))
do i = 1, size (buffer)
b = buffer(i)
call message_append_byte (m, b)
end do
end subroutine message_append_i32
@ %def message_append_i32
@ Append one line from file to a message. Include the newline character.
<<MD5: procedures>>=
subroutine message_append_from_unit (m, u, iostat)
type(message_t), intent(inout) :: m
integer, intent(in) :: u
integer, intent(out) :: iostat
character(len=BUFFER_SIZE) :: buffer
read (u, *, iostat=iostat) buffer
call message_append_string (m, trim (buffer))
call message_append_string (m, LF)
end subroutine message_append_from_unit
@ %def message_append_from_unit
@ Fill a message from file. (Each line counts as a string.)
<<MD5: procedures>>=
subroutine message_read_from_file (m, f)
type(message_t), intent(inout) :: m
character(len=*), intent(in) :: f
integer :: u, iostat
u = free_unit ()
open (file=f, unit=u, action='read')
do
call message_append_from_unit (m, u, iostat=iostat)
if (iostat < 0) exit
end do
close (u)
end subroutine message_read_from_file
@ %def message_read_from_file
@ Write a message. After each block, insert an empty line.
<<MD5: interfaces>>=
interface message_write
module procedure message_write_unit
end interface
<<MD5: procedures>>=
subroutine message_write_unit (m, unit, bytes, decimal)
type(message_t), intent(in) :: m
integer, intent(in), optional :: unit
logical, intent(in), optional :: bytes, decimal
type(block_t), pointer :: b
integer :: u
u = given_output_unit (unit); if (u < 0) return
b => m%first
if (associated (b)) then
do
call block_write_unit (b, unit, bytes, decimal)
b => b%next
if (.not. associated (b)) exit
write (u, *)
end do
end if
end subroutine message_write_unit
@ %def message_write_unit
@
\subsection{Auxiliary functions}
These four functions on three words are defined in the MD5 standard:
<<MD5: procedures>>=
function ff (x, y, z)
type(word32_t), intent(in) :: x, y, z
type(word32_t) :: ff
ff = ior (iand (x, y), iand (not (x), z))
end function ff
function fg (x, y, z)
type(word32_t), intent(in) :: x, y, z
type(word32_t) :: fg
fg = ior (iand (x, z), iand (y, not (z)))
end function fg
function fh (x, y, z)
type(word32_t), intent(in) :: x, y, z
type(word32_t) :: fh
fh = ieor (ieor (x, y), z)
end function fh
function fi (x, y, z)
type(word32_t), intent(in) :: x, y, z
type(word32_t) :: fi
fi = ieor (y, ior (x, not (z)))
end function fi
@ %def ff fg fh fi
@
\subsection{Auxiliary stuff}
This defines and initializes the table of transformation constants:
<<MD5: variables>>=
type(word32_t), dimension(64), save :: t
logical, save :: table_initialized = .false.
@ %def t table_initialized
<<MD5: procedures>>=
subroutine table_init
type(word64_t) :: ww
integer :: i
if (.not.table_initialized) then
do i = 1, 64
ww = int (4294967296d0 * abs (sin (i * 1d0)), kind=i64)
t(i) = word32_from_word64 (ww, 0)
end do
table_initialized = .true.
end if
end subroutine table_init
@ %def table_init
@ This encodes the message digest (4 words) into a 32-character
string.
<<MD5: procedures>>=
function digest_string (aa) result (s)
type(word32_t), dimension (0:3), intent(in) :: aa
character(len=32) :: s
integer :: i, j
do i = 0, 3
do j = 0, 3
call byte_write (byte_from_word32 (aa(i), j), s(i*8+j*2+1:i*8+j*2+2))
end do
end do
end function digest_string
@ %def digest_string
@
\subsection{MD5 algorithm}
Pad the message with a byte [[x80]] and then pad zeros up to a full
block minus two words; in these words, insert the message length
(before padding) as a 64-bit word, low-word first.
<<MD5: procedures>>=
subroutine message_pad (m)
type(message_t), intent(inout) :: m
type(word64_t) :: length
integer(i8), parameter :: ipad = -128 ! z'80'
type(byte_t) :: b
integer :: i
length = message_bits (m)
b = ipad
call message_append_byte (m, b)
call message_pad_zero (m, 56)
do i = 0, 7
call message_append_byte (m, byte_from_word64 (length, i))
end do
end subroutine message_pad
@ %def message_pad
@ Apply a series of transformations onto a state [[a,b,c,d]], where
the transform function uses each word of the message together with the
predefined words. Finally, encode the state as a 32-character string.
<<MD5: procedures>>=
subroutine message_digest (m, s)
type(message_t), intent(in) :: m
character(len=32), intent(out) :: s
integer(i32), parameter :: ia = 1732584193 ! z'67452301'
integer(i32), parameter :: ib = -271733879 ! z'efcdab89'
integer(i32), parameter :: ic = -1732584194 ! z'98badcfe'
integer(i32), parameter :: id = 271733878 ! z'10325476'
type(word32_t) :: a, b, c, d
type(word32_t) :: aa, bb, cc, dd
type(word32_t), dimension(0:15) :: x
type(block_t), pointer :: bl
call table_init
a = ia; b = ib; c = ic; d = id
bl => m%first
do
if (.not.associated (bl)) exit
x = bl%w
aa = a; bb = b; cc = c; dd = d
call transform (ff, a, b, c, d, 0, 7, 1)
call transform (ff, d, a, b, c, 1, 12, 2)
call transform (ff, c, d, a, b, 2, 17, 3)
call transform (ff, b, c, d, a, 3, 22, 4)
call transform (ff, a, b, c, d, 4, 7, 5)
call transform (ff, d, a, b, c, 5, 12, 6)
call transform (ff, c, d, a, b, 6, 17, 7)
call transform (ff, b, c, d, a, 7, 22, 8)
call transform (ff, a, b, c, d, 8, 7, 9)
call transform (ff, d, a, b, c, 9, 12, 10)
call transform (ff, c, d, a, b, 10, 17, 11)
call transform (ff, b, c, d, a, 11, 22, 12)
call transform (ff, a, b, c, d, 12, 7, 13)
call transform (ff, d, a, b, c, 13, 12, 14)
call transform (ff, c, d, a, b, 14, 17, 15)
call transform (ff, b, c, d, a, 15, 22, 16)
call transform (fg, a, b, c, d, 1, 5, 17)
call transform (fg, d, a, b, c, 6, 9, 18)
call transform (fg, c, d, a, b, 11, 14, 19)
call transform (fg, b, c, d, a, 0, 20, 20)
call transform (fg, a, b, c, d, 5, 5, 21)
call transform (fg, d, a, b, c, 10, 9, 22)
call transform (fg, c, d, a, b, 15, 14, 23)
call transform (fg, b, c, d, a, 4, 20, 24)
call transform (fg, a, b, c, d, 9, 5, 25)
call transform (fg, d, a, b, c, 14, 9, 26)
call transform (fg, c, d, a, b, 3, 14, 27)
call transform (fg, b, c, d, a, 8, 20, 28)
call transform (fg, a, b, c, d, 13, 5, 29)
call transform (fg, d, a, b, c, 2, 9, 30)
call transform (fg, c, d, a, b, 7, 14, 31)
call transform (fg, b, c, d, a, 12, 20, 32)
call transform (fh, a, b, c, d, 5, 4, 33)
call transform (fh, d, a, b, c, 8, 11, 34)
call transform (fh, c, d, a, b, 11, 16, 35)
call transform (fh, b, c, d, a, 14, 23, 36)
call transform (fh, a, b, c, d, 1, 4, 37)
call transform (fh, d, a, b, c, 4, 11, 38)
call transform (fh, c, d, a, b, 7, 16, 39)
call transform (fh, b, c, d, a, 10, 23, 40)
call transform (fh, a, b, c, d, 13, 4, 41)
call transform (fh, d, a, b, c, 0, 11, 42)
call transform (fh, c, d, a, b, 3, 16, 43)
call transform (fh, b, c, d, a, 6, 23, 44)
call transform (fh, a, b, c, d, 9, 4, 45)
call transform (fh, d, a, b, c, 12, 11, 46)
call transform (fh, c, d, a, b, 15, 16, 47)
call transform (fh, b, c, d, a, 2, 23, 48)
call transform (fi, a, b, c, d, 0, 6, 49)
call transform (fi, d, a, b, c, 7, 10, 50)
call transform (fi, c, d, a, b, 14, 15, 51)
call transform (fi, b, c, d, a, 5, 21, 52)
call transform (fi, a, b, c, d, 12, 6, 53)
call transform (fi, d, a, b, c, 3, 10, 54)
call transform (fi, c, d, a, b, 10, 15, 55)
call transform (fi, b, c, d, a, 1, 21, 56)
call transform (fi, a, b, c, d, 8, 6, 57)
call transform (fi, d, a, b, c, 15, 10, 58)
call transform (fi, c, d, a, b, 6, 15, 59)
call transform (fi, b, c, d, a, 13, 21, 60)
call transform (fi, a, b, c, d, 4, 6, 61)
call transform (fi, d, a, b, c, 11, 10, 62)
call transform (fi, c, d, a, b, 2, 15, 63)
call transform (fi, b, c, d, a, 9, 21, 64)
a = a + aa
b = b + bb
c = c + cc
d = d + dd
bl => bl%next
end do
s = digest_string ([a, b, c, d])
contains
<<MD5: Internal subroutine transform>>
end subroutine message_digest
@ %def message_digest
@ And this is the actual transformation that depends on one of the
previous functions, four words, and three integers. The implicit
arguments are [[x]], the word from the message to digest, and [[t]],
the entry in the predefined table.
<<MD5: Internal subroutine transform>>=
subroutine transform (f, a, b, c, d, k, s, i)
interface
function f (x, y, z)
import word32_t
type(word32_t), intent(in) :: x, y, z
type(word32_t) :: f
end function f
end interface
type(word32_t), intent(inout) :: a
type(word32_t), intent(in) :: b, c, d
integer, intent(in) :: k, s, i
a = b + ishftc (a + f(b, c, d) + x(k) + t(i), s)
end subroutine transform
@ %def transform
@
\subsection{User interface}
<<MD5: public>>=
public :: md5sum
<<MD5: interfaces>>=
interface md5sum
module procedure md5sum_from_string
module procedure md5sum_from_unit
end interface
@ %def md5sum
@ This function computes the MD5 sum of the input string and returns it
as a 32-character string
<<MD5: procedures>>=
function md5sum_from_string (s) result (digest)
character(len=*), intent(in) :: s
character(len=32) :: digest
type(message_t) :: m
call message_append_string (m, s)
call message_pad (m)
call message_digest (m, digest)
call message_clear (m)
end function md5sum_from_string
@ %def md5sum_from_string
@ This funct. reads from unit u (an unformmated sequence of
integers) and computes the MD5 sum.
<<MD5: procedures>>=
function md5sum_from_unit (u) result (digest)
integer, intent(in) :: u
character(len=32) :: digest
type(message_t) :: m
character :: char
integer :: iostat
READ_CHARS: do
read (u, "(A)", advance="no", iostat=iostat) char
select case (iostat)
case (0)
call message_append_string (m, char)
case (EOR)
call message_append_string (m, LF)
case (EOF)
exit READ_CHARS
case default
call msg_fatal &
("Computing MD5 sum: I/O error while reading from scratch file")
end select
end do READ_CHARS
call message_pad (m)
call message_digest (m, digest)
call message_clear (m)
end function md5sum_from_unit
@ %def md5sum_from_unit
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[md5_ut.f90]]>>=
<<File header>>
module md5_ut
use unit_tests
use md5_uti
<<Standard module head>>
<<MD5: public test>>
contains
<<MD5: test driver>>
end module md5_ut
@ %def md5_ut
@
<<[[md5_uti.f90]]>>=
<<File header>>
module md5_uti
use diagnostics
use md5
<<Standard module head>>
<<MD5: test declarations>>
contains
<<MD5: tests>>
end module md5_uti
@ %def md5_ut
@ API: driver for the unit tests below.
<<MD5: public test>>=
public :: md5_test
<<MD5: test driver>>=
subroutine md5_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<MD5: execute tests>>
end subroutine md5_test
@ %def md5_test
@ This function checks the implementation by computing the checksum of
certain strings and comparing them with the known values.
<<MD5: execute tests>>=
call test (md5_1, "md5_1", &
"check MD5 sums", &
u, results)
<<MD5: test declarations>>=
public :: md5_1
<<MD5: tests>>=
subroutine md5_1 (u)
integer, intent(in) :: u
character(32) :: s
integer, parameter :: n = 7
integer :: i
character(80), dimension(n) :: teststring
data teststring(1) /""/
data teststring(2) /"a"/
data teststring(3) /"abc"/
data teststring(4) /"message digest"/
data teststring(5) /"abcdefghijklmnopqrstuvwxyz"/
data teststring(6) /"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"/
data teststring(7) /"12345678901234567890123456789012345678901234567890123456789012345678901234567890"/
character(32), dimension(n) :: result
data result(1) /"D41D8CD98F00B204E9800998ECF8427E"/
data result(2) /"0CC175B9C0F1B6A831C399E269772661"/
data result(3) /"900150983CD24FB0D6963F7D28E17F72"/
data result(4) /"F96B697D7CB7938D525A2F31AAF161D0"/
data result(5) /"C3FCD3D76192E4007DFB496CCA67E13B"/
data result(6) /"D174AB98D277D9F5A5611C2C9F419D9F"/
data result(7) /"57EDF4A22BE3C955AC49DA2E2107B67A"/
write (u, "(A)") "* Test output: MD5"
write (u, "(A)") "* Purpose: test MD5 sums"
write (u, "(A)")
do i = 1, n
write (u, "(A)") "MD5 test string = " // '"'// &
trim (teststring(i)) // '"'
s = md5sum (trim (teststring(i)))
write (u, "(A)") "MD5 check sum = " // trim (s)
write (u, "(A)") "Ref check sum = " // result(i)
if (s == result(i)) then
call msg_message ("=> ok", u)
else
call msg_message ("=> MD5 sum self-test failed", u)
end if
end do
call msg_message ("=============================================================================|", unit=u)
end subroutine md5_1
@ %def md5_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Permutations}
Permute arrays of integers (of specific kind).
<<[[permutations.f90]]>>=
<<File header>>
module permutations
use kinds, only: TC
<<Standard module head>>
<<Permutations: public>>
<<Permutations: types>>
<<Permutations: interfaces>>
contains
<<Permutations: procedures>>
end module permutations
@ %def permutations
@
\subsection{Permutations}
A permutation is an array of integers. Each integer between one and
[[size]] should occur exactly once.
<<Permutations: public>>=
public :: permutation_t
<<Permutations: types>>=
type :: permutation_t
private
integer, dimension(:), allocatable :: p
end type permutation_t
@ %def permutation
@
Initialize with the identity permutation.
<<Permutations: public>>=
public :: permutation_init
public :: permutation_final
<<Permutations: procedures>>=
elemental subroutine permutation_init (p, size)
type(permutation_t), intent(inout) :: p
integer, intent(in) :: size
integer :: i
allocate (p%p (size))
forall (i = 1:size)
p%p(i) = i
end forall
end subroutine permutation_init
elemental subroutine permutation_final (p)
type(permutation_t), intent(inout) :: p
deallocate (p%p)
end subroutine permutation_final
@ %def permutation_init permutation_final
@ I/O:
<<Permutations: public>>=
public :: permutation_write
<<Permutations: procedures>>=
subroutine permutation_write (p, u)
type(permutation_t), intent (in) :: p
integer, intent(in) :: u
integer :: i
do i = 1, size (p%p)
if (size (p%p) < 10) then
write (u,"(1x,I1)", advance="no") p%p(i)
else
write (u,"(1x,I3)", advance="no") p%p(i)
end if
end do
write (u, *)
end subroutine permutation_write
@ %def permutation_write
@
Administration:
<<Permutations: public>>=
public :: permutation_size
<<Permutations: procedures>>=
elemental function permutation_size (perm) result (s)
type(permutation_t), intent(in) :: perm
integer :: s
s = size (perm%p)
end function permutation_size
@ %def permutation_size
@ Extract an entry in a permutation.
<<Permutations: public>>=
public :: permute
<<Permutations: procedures>>=
elemental function permute (i, p) result (j)
integer, intent(in) :: i
type(permutation_t), intent(in) :: p
integer :: j
if (i > 0 .and. i <= size (p%p)) then
j = p%p(i)
else
j = 0
end if
end function permute
@ %def permute
@
Check whether a permutation is valid: Each integer in the range occurs
exactly once.
<<Permutations: public>>=
public :: permutation_ok
<<Permutations: procedures>>=
elemental function permutation_ok (perm) result (ok)
type(permutation_t), intent(in) :: perm
logical :: ok
integer :: i
logical, dimension(:), allocatable :: set
ok = .true.
allocate (set (size (perm%p)))
set = .false.
do i = 1, size (perm%p)
ok = (perm%p(i) > 0 .and. perm%p(i) <= size (perm%p))
if (.not.ok) return
set(perm%p(i)) = .true.
end do
ok = all (set)
end function permutation_ok
@ %def permutation_ok
@ Find the permutation that transforms the second array into the first
one. We assume that this is possible and unique and all bounds are
set correctly.
This cannot be elemental.
<<Permutations: public>>=
public :: permutation_find
<<Permutations: procedures>>=
subroutine permutation_find (perm, a1, a2)
type(permutation_t), intent(inout) :: perm
integer, dimension(:), intent(in) :: a1, a2
integer :: i, j
if (allocated (perm%p)) deallocate (perm%p)
allocate (perm%p (size (a1)))
do i = 1, size (a1)
do j = 1, size (a2)
if (a1(i) == a2(j)) then
perm%p(i) = j
exit
end if
perm%p(i) = 0
end do
end do
end subroutine permutation_find
@ %def permutation_find
@
Find all permutations that transform an array of integers into
itself. The resulting permutation list is allocated with the correct
length and filled.
The first step is to count the number of different entries in
[[code]]. Next, we scan [[code]] again and assign a mask to each
different entry, true for all identical entries. Finally, we
recursively permute the identity for each possible mask.
The permutation is done as follows: A list of all permutations of the
initial one with respect to the current mask is generated, then the
permutations are generated in turn for each permutation in this list
with the next mask. The result is always stored back into the main
list, starting from the end of the current list.
<<Permutations: public>>=
public :: permutation_array_make
<<Permutations: procedures>>=
subroutine permutation_array_make (pa, code)
type(permutation_t), dimension(:), allocatable, intent(out) :: pa
integer, dimension(:), intent(in) :: code
logical, dimension(size(code)) :: mask
logical, dimension(:,:), allocatable :: imask
integer, dimension(:), allocatable :: n_i
type(permutation_t) :: p_init
type(permutation_t), dimension(:), allocatable :: p_tmp
integer :: psize, i, j, k, n_different, n, nn_k
psize = size (code)
mask = .true.
n_different = 0
do i=1, psize
if (mask(i)) then
n_different = n_different + 1
mask = mask .and. (code /= code(i))
end if
end do
allocate (imask(psize, n_different), n_i(n_different))
mask = .true.
k = 0
do i=1, psize
if (mask(i)) then
k = k + 1
imask(:,k) = (code == code(i))
n_i(k) = factorial (count(imask(:,k)))
mask = mask .and. (code /= code(i))
end if
end do
n = product (n_i)
allocate (pa (n))
call permutation_init (p_init, psize)
pa(1) = p_init
nn_k = 1
do k = 1, n_different
allocate (p_tmp (n_i(k)))
do i = nn_k, 1, -1
call permutation_array_with_mask (p_tmp, imask(:,k), pa(i))
do j = n_i(k), 1, -1
pa((i-1)*n_i(k) + j) = p_tmp(j)
end do
end do
deallocate (p_tmp)
nn_k = nn_k * n_i(k)
end do
call permutation_final (p_init)
deallocate (imask, n_i)
end subroutine permutation_array_make
@ %def permutation_array_make
@ Make a list of permutations of the elements marked true in the
[[mask]] array. The final permutation list must be allocated with the
correct length ($n!$). The third argument is the initial
permutation to start with, which must have the same length as the
[[mask]] array (this is not checked).
<<Permutations: procedures>>=
subroutine permutation_array_with_mask (pa, mask, p_init)
type(permutation_t), dimension(:), intent(inout) :: pa
logical, dimension(:), intent(in) :: mask
type(permutation_t), intent(in) :: p_init
integer :: plen
integer :: i, ii, j, fac_i, k, x
integer, dimension(:), allocatable :: index
plen = size (pa)
allocate (index(count(mask)))
ii = 0
do i = 1, size (mask)
if (mask(i)) then
ii = ii + 1
index(ii) = i
end if
end do
pa = p_init
ii = 0
fac_i = 1
do i = 1, size (mask)
if (mask(i)) then
ii = ii + 1
fac_i = fac_i * ii
x = permute (i, p_init)
do j = 1, plen
k = ii - mod (((j-1)*fac_i)/plen, ii)
call insert (pa(j), x, k, ii, index)
end do
end if
end do
deallocate (index)
contains
subroutine insert (p, x, k, n, index)
type(permutation_t), intent(inout) :: p
integer, intent(in) :: x, k, n
integer, dimension(:), intent(in) :: index
integer :: i
do i = n, k+1, -1
p%p(index(i)) = p%p(index(i-1))
end do
p%p(index(k)) = x
end subroutine insert
end subroutine permutation_array_with_mask
@ %def permutation_array_with_mask
@ The factorial function is needed for pre-determining the number of
permutations that will be generated:
<<Permutations: public>>=
public :: factorial
<<Permutations: procedures>>=
- function factorial (n) result (f)
+ elemental function factorial (n) result (f)
integer, intent(in) :: n
integer :: f
integer :: i
f = 1
do i=2, abs(n)
f = f*i
end do
end function factorial
@ %def factorial
@
\subsection{Operations on binary codes}
Binary codes are needed for phase-space trees. Since the permutation
function uses permutations, and no other special type is involved, we
put the functions here.
This is needed for phase space trees: permute bits in a tree binary
code. If no permutation is given, leave as is. (We may want to
access the permutation directly here if this is efficiency-critical.)
<<Permutations: public>>=
public :: tc_permute
<<Permutations: procedures>>=
function tc_permute (k, perm, mask_in) result (pk)
integer(TC), intent(in) :: k, mask_in
type(permutation_t), intent(in) :: perm
integer(TC) :: pk
integer :: i
pk = iand (k, mask_in)
do i = 1, size (perm%p)
if (btest(k,i-1)) pk = ibset (pk, perm%p(i)-1)
end do
end function tc_permute
@ %def tc_permute
@
This routine returns the number of set bits in the tree code value
[[k]]. Hence, it is the number of externals connected to the current
line. If [[mask]] is present, the complement of the tree code is also
considered, and the smaller number is returned. This gives the true
distance from the external states, taking into account the initial
particles. The complement number is increased by one, since for a
scattering diagram the vertex with the sum of all final-state codes is
still one point apart from the initial particles.
<<Permutations: public>>=
public :: tc_decay_level
<<Permutations: interfaces>>=
interface tc_decay_level
module procedure decay_level_simple
module procedure decay_level_complement
end interface
@ %def decay_level
<<Permutations: procedures>>=
function decay_level_complement (k, mask) result (l)
integer(TC), intent(in) :: k, mask
integer :: l
l = min (decay_level_simple (k), &
& decay_level_simple (ieor (k, mask)) + 1)
end function decay_level_complement
function decay_level_simple (k) result(l)
integer(TC), intent(in) :: k
integer :: l
integer :: i
l = 0
do i=0, bit_size(k)-1
if (btest(k,i)) l = l+1
end do
end function decay_level_simple
@ %def decay_level_simple decay_level_complement
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Sorting}
This small module provides functions for sorting integer or real
arrays.
<<[[sorting.f90]]>>=
<<File header>>
module sorting
<<Use kinds>>
use diagnostics
<<Standard module head>>
<<Sorting: public>>
<<Sorting: interfaces>>
contains
<<Sorting: procedures>>
end module sorting
@ %def sorting
@
\subsection{Implementation}
The [[sort]] function returns, for a given integer or real array, the
array sorted by increasing value. The current implementation is
\emph{mergesort}, which has $O(n\ln n)$ behavior in all cases, and is
stable for elements of equal value.
The [[sort_abs]] variant sorts by increasing absolute value, where for
identical absolute value, the positive number comes first.
<<Sorting: public>>=
public :: sort
public :: sort_abs
<<Sorting: interfaces>>=
interface sort
module procedure sort_int
module procedure sort_real
end interface
interface sort_abs
module procedure sort_int_abs
end interface
@ %def sort sort_abs
@ This variant of integer sort returns
@ The body is identical, just the interface differs.
<<Sorting: procedures>>=
function sort_int (val_in) result (val)
integer, dimension(:), intent(in) :: val_in
integer, dimension(size(val_in)) :: val
<<Sorting: sort>>
end function sort_int
function sort_real (val_in) result (val)
real(default), dimension(:), intent(in) :: val_in
real(default), dimension(size(val_in)) :: val
<<Sorting: sort>>
end function sort_real
function sort_int_abs (val_in) result (val)
integer, dimension(:), intent(in) :: val_in
integer, dimension(size(val_in)) :: val
<<Sorting: sort abs>>
end function sort_int_abs
@ %def sort_int sort_real sort_int_abs
<<Sorting: sort>>=
val = val_in( order (val_in) )
<<Sorting: sort abs>>=
val = val_in( order_abs (val_in) )
@ The [[order]] function returns, for a given integer or real array, the
array of indices of the elements sorted by increasing value.
<<Sorting: public>>=
public :: order
public :: order_abs
<<Sorting: interfaces>>=
interface order
module procedure order_int
module procedure order_real
end interface
interface order_abs
module procedure order_int_abs
end interface
@ %def order order_abs
<<Sorting: procedures>>=
function order_int (val) result (idx)
integer, dimension(:), intent(in) :: val
integer, dimension(size(val)) :: idx
<<Sorting: order>>
end function order_int
function order_real (val) result (idx)
real(default), dimension(:), intent(in) :: val
integer, dimension(size(val)) :: idx
<<Sorting: order>>
end function order_real
function order_int_abs (val) result (idx)
integer, dimension(:), intent(in) :: val
integer, dimension(size(val)) :: idx
<<Sorting: order abs>>
end function order_int_abs
@ %def order_int order_real order_int_abs
@ We start by individual elements, merge them to pairs, merge those to
four-element subarrays, and so on. The last subarray can extend only
up to the original array bound, of course, and the second of the
subarrays to merge should contain at least one element.
<<Sorting: order>>=
<<Sorting: order1>>
call merge (idx(b1:e2), idx(b1:e1), idx(b2:e2), val)
<<Sorting: order2>>
@
<<Sorting: order abs>>=
<<Sorting: order1>>
call merge_abs (idx(b1:e2), idx(b1:e1), idx(b2:e2), val)
<<Sorting: order2>>
@
<<Sorting: order1>>=
integer :: n, i, s, b1, b2, e1, e2
n = size (idx)
do i = 1, n
idx(i) = i
end do
s = 1
do while (s < n)
do b1 = 1, n-s, 2*s
b2 = b1 + s
e1 = b2 - 1
e2 = min (e1 + s, n)
@
<<Sorting: order2>>=
end do
s = 2 * s
end do
@ The merging step does the actual sorting. We take two sorted array
sections and merge them to a sorted result array. We are working on
the indices, and comparing is done by taking the associated [[val]]
which is real or integer.
<<Sorting: interfaces>>=
interface merge
module procedure merge_int
module procedure merge_real
end interface
interface merge_abs
module procedure merge_int_abs
end interface
@ %def merge merge_abs
<<Sorting: procedures>>=
subroutine merge_int (res, src1, src2, val)
integer, dimension(:), intent(out) :: res
integer, dimension(:), intent(in) :: src1, src2
integer, dimension(:), intent(in) :: val
integer, dimension(size(res)) :: tmp
<<Sorting: merge>>
end subroutine merge_int
subroutine merge_real (res, src1, src2, val)
integer, dimension(:), intent(out) :: res
integer, dimension(:), intent(in) :: src1, src2
real(default), dimension(:), intent(in) :: val
integer, dimension(size(res)) :: tmp
<<Sorting: merge>>
end subroutine merge_real
subroutine merge_int_abs (res, src1, src2, val)
integer, dimension(:), intent(out) :: res
integer, dimension(:), intent(in) :: src1, src2
integer, dimension(:), intent(in) :: val
integer, dimension(size(res)) :: tmp
<<Sorting: merge abs>>
end subroutine merge_int_abs
@ %def merge_int merge_real merge_int_abs
<<Sorting: merge>>=
<<Sorting: merge1>>
if (val(src1(i1)) <= val(src2(i2))) then
<<Sorting: merge2>>
@ We keep the elements if the absolute values are strictly ordered.
If they are equal in magnitude, we keep them if the larger value
comes first, or if they are equal.
<<Sorting: merge abs>>=
<<Sorting: merge1>>
if (abs (val(src1(i1))) < abs (val(src2(i2))) .or. &
(abs (val(src1(i1))) == abs (val(src2(i2))) .and. &
val(src1(i1)) >= val(src2(i2)))) then
<<Sorting: merge2>>
@
<<Sorting: merge1>>=
integer :: i1, i2, i
i1 = 1
i2 = 1
do i = 1, size (tmp)
@
<<Sorting: merge2>>=
tmp(i) = src1(i1); i1 = i1 + 1
if (i1 > size (src1)) then
tmp(i+1:) = src2(i2:)
exit
end if
else
tmp(i) = src2(i2); i2 = i2 + 1
if (i2 > size (src2)) then
tmp(i+1:) = src1(i1:)
exit
end if
end if
end do
res = tmp
@
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[sorting_ut.f90]]>>=
<<File header>>
module sorting_ut
use unit_tests
use sorting_uti
<<Standard module head>>
<<Sorting: public test>>
contains
<<Sorting: test driver>>
end module sorting_ut
@ %def sorting_ut
@
<<[[sorting_uti.f90]]>>=
<<File header>>
module sorting_uti
<<Use kinds>>
use sorting
<<Standard module head>>
<<Sorting: test declarations>>
contains
<<Sorting: tests>>
end module sorting_uti
@ %def sorting_ut
@ API: driver for the unit tests below.
<<Sorting: public test>>=
public :: sorting_test
<<Sorting: test driver>>=
subroutine sorting_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Sorting: execute tests>>
end subroutine sorting_test
@ %def sorting_test
@ This checks whether the sorting routine works correctly.
<<Sorting: execute tests>>=
call test (sorting_1, "sorting_1", &
"check sorting routines", &
u, results)
<<Sorting: test declarations>>=
public :: sorting_1
<<Sorting: tests>>=
subroutine sorting_1 (u)
integer, intent(in) :: u
integer, parameter :: NMAX = 10
real(default), dimension(NMAX) :: rval
integer, dimension(NMAX) :: ival
real, dimension(NMAX,NMAX) :: harvest_r
integer, dimension(NMAX,NMAX) :: harvest_i
integer, dimension(NMAX,NMAX) :: harvest_a
integer :: i, j
harvest_r(:, 1) = [0.9976, 0., 0., 0., 0., 0., 0., 0., 0., 0.]
harvest_r(:, 2) = [0.5668, 0.9659, 0., 0., 0., 0., 0., 0., 0., 0.]
harvest_r(:, 3) = [0.7479, 0.3674, 0.4806, 0., 0., 0., 0., 0., 0., &
0.]
harvest_r(:, 4) = [0.0738, 0.0054, 0.3471, 0.3422, 0., 0., 0., 0., &
0., 0.]
harvest_r(:, 5) = [0.2180, 0.1332, 0.9005, 0.3868, 0.4455, 0., 0., &
0., 0., 0.]
harvest_r(:, 6) = [0.6619, 0.0161, 0.6509, 0.6464, 0.3230, &
0.8557, 0., 0., 0., 0.]
harvest_r(:, 7) = [0.4013, 0.2069, 0.9685, 0.5984, 0.6730, &
0.4569, 0.3300, 0., 0., 0.]
harvest_r(:, 8) = [0.1004, 0.7555, 0.6057, 0.7190, 0.8973, &
0.6582, 0.1507, 0.6123, 0., 0.]
harvest_r(:, 9) = [0.9787, 0.9991, 0.2568, 0.5509, 0.6590, &
0.5540, 0.9778, 0.9019, 0.6579, 0.]
harvest_r(:,10) = [0.7289, 0.4025, 0.9286, 0.1478, 0.6745, &
0.7696, 0.3393, 0.1158, 0.6144, 0.8206]
harvest_i(:, 1) = [18, 0, 0, 0, 0, 0, 0, 0, 0, 0]
harvest_i(:, 2) = [14, 9, 0, 0, 0, 0, 0, 0, 0, 0]
harvest_i(:, 3) = [ 7, 8,11, 0, 0, 0, 0, 0, 0, 0]
harvest_i(:, 4) = [19,19,14,19, 0, 0, 0, 0, 0, 0]
harvest_i(:, 5) = [ 1,14,15,18,14, 0, 0, 0, 0, 0]
harvest_i(:, 6) = [16,11, 1, 9,11, 2, 0, 0, 0, 0]
harvest_i(:, 7) = [11,10,17, 6,13,13,10, 0, 0, 0]
harvest_i(:, 8) = [ 5, 1, 2,10, 7, 0,15,12, 0, 0]
harvest_i(:, 9) = [15,19, 2, 6,11, 0, 2, 4, 2, 0]
harvest_i(:,10) = [ 1, 4, 8, 4,11, 0, 8, 7,19,13]
harvest_a(:, 1) = [-6, 0, 0, 0, 0, 0, 0, 0, 0, 0]
harvest_a(:, 2) = [-8, -9, 0, 0, 0, 0, 0, 0, 0, 0]
harvest_a(:, 3) = [ 4, -3, 3, 0, 0, 0, 0, 0, 0, 0]
harvest_a(:, 4) = [-6, 6, 2, -2, 0, 0, 0, 0, 0, 0]
harvest_a(:, 5) = [ 1, -2, 0, -6, 8, 0, 0, 0, 0, 0]
harvest_a(:, 6) = [-2, -1, -8, -5, 8, -5, 0, 0, 0, 0]
harvest_a(:, 7) = [-9, 0, -6, 2, 5, 3, 2, 0, 0, 0]
harvest_a(:, 8) = [-5, -7, 6, 7, -3, 0, -7, 4, 0, 0]
harvest_a(:, 9) = [ 5, 0, -1, -7, 5, 2, 7, -3, 3, 0]
harvest_a(:,10) = [-9, 2, -6, 3, -9, 5, 5, 7, 5, -9]
write (u, "(A)") "* Test output: Sorting"
write (u, "(A)") "* Purpose: test sorting routines"
write (u, "(A)")
write (u, "(A)") "* Sorting real values:"
do i = 1, NMAX
write (u, "(A)")
rval(:i) = harvest_r(:i,i)
write (u, "(10(1x,F7.4))") rval(:i)
rval(:i) = sort (rval(:i))
write (u, "(10(1x,F7.4))") rval(:i)
do j = i, 2, -1
if (rval(j)-rval(j-1) < 0) &
write (u, "(A)") "*** Sorting failure. ***"
end do
end do
write (u, "(A)")
write (u, "(A)") "* Sorting integer values:"
do i = 1, NMAX
write (u, "(A)")
ival(:i) = harvest_i(:i,i)
write (u, "(10(1x,I2))") ival(:i)
ival(:i) = sort (ival(:i))
write (u, "(10(1x,I2))") ival(:i)
do j = i, 2, -1
if (ival(j)-ival(j-1) < 0) &
write (u, "(A)") "*** Sorting failure. ***"
end do
end do
write (u, "(A)")
write (u, "(A)") "* Sorting integer values by absolute value:"
do i = 1, NMAX
write (u, "(A)")
ival(:i) = harvest_a(:i,i)
write (u, "(10(1x,I2))") ival(:i)
ival(:i) = sort_abs (ival(:i))
write (u, "(10(1x,I2))") ival(:i)
do j = i, 2, -1
if (abs(ival(j))-abs(ival(j-1)) < 0 .or. &
(abs(ival(j))==abs(ival(j-1))) .and. ival(j)>ival(j-1)) &
write (u, "(A)") "*** Sorting failure. ***"
end do
end do
write (u, "(A)")
write (u, "(A)") "* Test output end: sorting_1"
end subroutine sorting_1
@ %def sorting_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Grids}
\emph{This is not really a combinatorics module but this directory is the
closest I could find. Maybe this will be moved to a seperate directory
or combined with related stuff.}
<<[[grids.f90]]>>=
<<File header>>
module grids
<<Use kinds>>
use constants, only: zero, one, tiny_07
use io_units
use format_defs, only: FMT_16
use diagnostics
<<Use mpi f08>>
<<Standard module head>>
<<Grids: public>>
<<Grids: parameters>>
<<Grids: types>>
contains
<<Grids: procedures>>
end module grids
@ %def grids
@ Grids are used in many applications and a general implementation seems
useful. The relevant properties implemented so far are
\begin{itemize}
\item Segments of the hypercube are represented by an integer array
with size $d$ corresponding to the dimension.
\item There is a mapping from the indices to the location in the
continuous memory block of values.
\item Given a point in the hypercube, find the corresponding
segment and the value of the grid therein.
\item Update the grid sequentially to represent the maximum
of a function over the unit hypercube.
\item The grid can be saved to and recovered from disk.
\end{itemize}
The following might be implemented in the future
\begin{itemize}
\item Generate a random point in the hypercube by interpreting the
grid as probability distribution.
\emph{This would most likely be solved by using projections and the
[[selector_t]], which would make a move of this module higher up in
the dependency tree necessary.}
\item Update the grid sequentially to represent the \emph{minimum}
of a function over the unit hypercube.
\end{itemize}
<<Grids: public>>=
public :: grid_t
<<Grids: types>>=
type :: grid_t
private
real(default), dimension(:), allocatable :: values
integer, dimension(:), allocatable :: points
contains
<<Grids: grid: TBP>>
end type grid_t
@ %def grid_t
@
\subsection{Initializer and finalizer}
For initialization, we expect the number of points for each dimension
as an array or the the number of dimensions as a scalar whereby the
default number of points is used then for each dimension.
<<Grids: grid: TBP>>=
generic :: init => init_base, init_simple
procedure :: init_base => grid_init_base
procedure :: init_simple => grid_init_simple
<<Grids: procedures>>=
pure subroutine grid_init_base (grid, points)
class(grid_t), intent(inout) :: grid
integer, dimension(:), intent(in) :: points
allocate (grid%points (size (points)))
allocate (grid%values (product (points)))
grid%points = points
grid%values = zero
end subroutine grid_init_base
@ %def grid_init_base
<<Grids: procedures>>=
pure subroutine grid_init_simple (grid, dimensions)
class(grid_t), intent(inout) :: grid
integer, intent(in) :: dimensions
allocate (grid%points (dimensions))
allocate (grid%values (DEFAULT_POINTS_PER_DIMENSION ** dimensions))
grid%points = DEFAULT_POINTS_PER_DIMENSION
grid%values = zero
end subroutine grid_init_simple
@ %def grid_init_simple
@ Manual assignment (tests)
<<Grids: grid: TBP>>=
procedure :: set_values => grid_set_values
<<Grids: procedures>>=
subroutine grid_set_values (grid, values)
class(grid_t), intent(inout) :: grid
real(default), dimension(:), intent(in) :: values
grid%values = values
end subroutine grid_set_values
@ %def grid_set_values
@ A reasonable default
<<Grids: parameters>>=
integer, parameter :: DEFAULT_POINTS_PER_DIMENSION = 100
@ %def DEFAULT_POINTS_PER_DIMENSION
@ Calling this is not mandatory, when an instance of [[grid_t]] goes out
of scope as it will be done by Fortran automatically.
<<Grids: grid: TBP>>=
procedure :: final => grid_final
<<Grids: procedures>>=
pure subroutine grid_final (grid)
class(grid_t), intent(inout) :: grid
if (allocated (grid%values)) then
deallocate (grid%values)
end if
if (allocated (grid%points)) then
deallocate (grid%points)
end if
end subroutine grid_final
@ %def grid_final
@
\subsection{Segment finding and memory mapping}
The [[indices]] array is expected to go from 1 to $d$ whereby the
entries for the different $\text{dim}$s are from 1 to
$n_\text{points}(\text{dim})$.
@ We get the value of the grid either from given [[indices]] or from a
point [[x]] in the hypercube. In the latter case, we have to find the
segment first.
<<Grids: grid: TBP>>=
generic :: get_value => get_value_from_x, get_value_from_indices
procedure :: get_value_from_x => grid_get_value_from_x
procedure :: get_value_from_indices => grid_get_value_from_indices
<<Grids: procedures>>=
function grid_get_value_from_indices (grid, indices)
real(default) :: grid_get_value_from_indices
class(grid_t), intent(in) :: grid
integer, dimension(:), intent(in) :: indices
grid_get_value_from_indices = grid%values(grid%get_index(indices))
end function grid_get_value_from_indices
@ %def grid_get_value_from_indices
<<Grids: procedures>>=
function grid_get_value_from_x (grid, x)
real(default) :: grid_get_value_from_x
class(grid_t), intent(in) :: grid
real(default), dimension(:), intent(in) :: x
grid_get_value_from_x = grid_get_value_from_indices &
(grid, grid_get_segment (grid, x))
end function grid_get_value_from_x
@ %def grid_get_value_from_x
@ The segment is the part of the grid that contains the point [[x]] and
is identified by a tupel of [[indices]]. This is just a brute force
search, for fine grids one could also implement a binary search for
$\mathcal{O}(\log{N})$ behavior instead of $\mathcal{O}({N})$.
<<Grids: grid: TBP>>=
procedure :: get_segment => grid_get_segment
<<Grids: procedures>>=
function grid_get_segment (grid, x, unit)
class(grid_t), intent(in) :: grid
real(default), dimension(:), intent(in) :: x
integer, intent(in), optional :: unit
integer, dimension(1:size (x)) :: grid_get_segment
integer :: dim, i
real(default) :: segment_width
grid_get_segment = 0
do dim = 1, size (grid%points)
segment_width = one / grid%points (dim)
SEARCH: do i = 1, grid%points (dim)
if (x (dim) <= i * segment_width + tiny_07) then
grid_get_segment (dim) = i
exit SEARCH
end if
end do SEARCH
if (grid_get_segment (dim) == 0) then
do i = 1, size(x)
write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") &
"x[i] = ", x(i)
call msg_message ()
end do
call msg_error ("grid_get_segment: Did not find x in [0,1]^d", &
unit=unit)
end if
end do
end function grid_get_segment
@ %def grid_get_segment
@ This is a simple storage mapping function but more sophisticated ideas
like hashing could be implemented.
\begin{align}
\text{index} = &\text{indices}(1) + \notag\\
&\text{indices}(2) * \text{size}(1) + \notag\\
&\text{indices}(3) * \text{size}(1) * \text{size}(2) +
\dots
\end{align}
<<Grids: grid: TBP>>=
procedure :: get_index => grid_get_index
<<Grids: procedures>>=
pure function grid_get_index (grid, indices) result (grid_index)
integer :: grid_index
class(grid_t), intent(in) :: grid
integer, dimension(:), intent(in) :: indices
integer :: dim_innerloop, dim_outerloop, multiplier
grid_index = 1
do dim_outerloop = 1, size(indices)
multiplier = 1
do dim_innerloop = 1, dim_outerloop - 1
multiplier = multiplier * grid%points (dim_innerloop)
end do
grid_index = grid_index + (indices(dim_outerloop) - 1) * multiplier
end do
end function grid_get_index
@ %def grid_get_index
@
\subsection{Grid manipulations}
Given a point in the hypercube [[x]] and its value [[y]], we update
the grids, such that the stepwise function $f$ defined by the grid is
$f(x_i)\geq y_i\;\forall \{x_i, y_i\}$.
<<Grids: grid: TBP>>=
procedure :: update_maxima => grid_update_maxima
<<Grids: procedures>>=
subroutine grid_update_maxima (grid, x, y)
class(grid_t), intent(inout) :: grid
real(default), dimension(:), intent(in) :: x
real(default), intent(in) :: y
integer, dimension(1:size(x)) :: indices
indices = grid%get_segment (x)
if (grid%get_value (indices) < y) then
grid%values (grid%get_index (indices)) = y
end if
end subroutine grid_update_maxima
@ %def grid_update_maxima
@ More general cases have to be thought through when they are needed.
\emph{This is inefficient and non-general}.
<<Grids: grid: TBP>>=
procedure :: get_maximum_in_3d => grid_get_maximum_in_3d
<<Grids: procedures>>=
function grid_get_maximum_in_3d (grid, projected_index) result (maximum)
real(default) :: maximum
class(grid_t), intent(in) :: grid
integer, intent(in) :: projected_index
real(default) :: val
integer :: i, j
maximum = zero
do i = 1, grid%points(1)
do j = 1, grid%points(2)
val = grid%get_value ([i, j, projected_index])
if (val > maximum) then
maximum = val
end if
end do
end do
end function grid_get_maximum_in_3d
@ %def grid_get_maximum_in_3d
@
<<Grids: grid: TBP>>=
procedure :: is_non_zero_everywhere => grid_is_non_zero_everywhere
<<Grids: procedures>>=
pure function grid_is_non_zero_everywhere (grid) result (yorn)
logical :: yorn
class(grid_t), intent(in) :: grid
yorn = all (abs (grid%values) > zero)
end function grid_is_non_zero_everywhere
@ %def grid_is_non_zero_everywhere
@ Returns true if any value of the grid is non-zero.
We need this to determine whether the grid has been filled during integration.
<<Grids: grid: TBP>>=
procedure :: has_non_zero_entries => grid_has_non_zero_entries
<<Grids: procedures>>=
pure function grid_has_non_zero_entries (grid) result (non_zero)
logical :: non_zero
class(grid_t), intent(in) :: grid
non_zero = any (abs (grid%values) > zero)
end function grid_has_non_zero_entries
@ %def grid_has_non_zero_entries
@ MPI: We allow for several grids in a parallelized run to be combined with [[MPI_reduce]].
The operator has to be specified. We do not check on any specifications.
<<MPI: Grids: grid: TBP>>=
procedure :: mpi_reduce => grid_mpi_reduce
<<MPI: Grids: procedures>>=
subroutine grid_mpi_reduce (grid, operator)
class(grid_t), intent(inout) :: grid
type(MPI_op), intent(in) :: operator
real(default), dimension(size (grid%values)) :: root_values
integer :: rank
call MPI_Comm_rank (MPI_COMM_WORLD, rank)
call MPI_Reduce (grid%values, root_values, size (grid%values),&
& MPI_DOUBLE_PRECISION, operator, 0, MPI_COMM_WORLD)
if (rank == 0) then
grid%values = root_values
end if
end subroutine grid_mpi_reduce
@ %def grid_mpi_reduce
\subsection{Input and Output to screen and disk}
<<Grids: grid: TBP>>=
procedure :: write => grid_write
<<Grids: procedures>>=
subroutine grid_write (grid, unit)
class(grid_t), intent(in) :: grid
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(1X,A)") "Grid"
write (u, "(2X,A,2X)", advance='no') "Number of points per dimension:"
if (allocated (grid%points)) then
do i = 1, size (grid%points)
write (u, "(I12,1X)", advance='no') &
grid%points (i)
end do
end if
write (u, *)
write (u, "(2X,A)") "Values of the grid:"
if (allocated (grid%values)) then
do i = 1, size (grid%values)
write (u, "(" // DEFAULT_OUTPUT_PRECISION // ",1X)") &
grid%values (i)
end do
end if
call grid%compute_and_write_mean_and_max (u)
end subroutine grid_write
@ %def grid_write
@
<<Grids: grid: TBP>>=
procedure :: compute_and_write_mean_and_max => &
grid_compute_and_write_mean_and_max
<<Grids: procedures>>=
subroutine grid_compute_and_write_mean_and_max (grid, unit)
class(grid_t), intent(in) :: grid
integer, intent(in), optional :: unit
integer :: u, i, n_values
real(default) :: mean, val, maximum
u = given_output_unit (unit); if (u < 0) return
mean = zero
maximum = zero
if (allocated (grid%values)) then
n_values = size (grid%values)
do i = 1, n_values
val = grid%values (i)
mean = mean + val / n_values
if (val > maximum) then
maximum = val
end if
end do
write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") &
"Grid: Mean value of the grid: ", mean
call msg_message ()
write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") &
"Grid: Max value of the grid: ", maximum
call msg_message ()
if (maximum > zero) then
write (msg_buffer, "(A," // DEFAULT_OUTPUT_PRECISION // ")") &
"Grid: Mean/Max value of the grid: ", mean / maximum
call msg_message ()
end if
else
call msg_warning ("Grid: Grid is not allocated!")
end if
end subroutine grid_compute_and_write_mean_and_max
@ %def grid_compute_and_write_mean_and_max
@
<<Grids: grid: TBP>>=
procedure :: save_to_file => grid_save_to_file
<<Grids: procedures>>=
subroutine grid_save_to_file (grid, file)
class(grid_t), intent(in) :: grid
character(len=*), intent(in) :: file
integer :: iostat, u, i
u = free_unit ()
open (file=file, unit=u, action='write')
if (allocated (grid%points)) then
write (u, "(I12)") size (grid%points)
do i = 1, size (grid%points)
write (u, "(I12,1X)", advance='no', iostat=iostat) &
grid%points (i)
end do
end if
write (u, *)
if (allocated (grid%values)) then
do i = 1, size (grid%values)
write (u, "(" // DEFAULT_OUTPUT_PRECISION // ",1X)", &
advance='no', iostat=iostat) grid%values (i)
end do
end if
if (iostat /= 0) then
call msg_warning &
('grid_save_to_file: Could not save grid to file')
end if
close (u)
end subroutine grid_save_to_file
@ %def grid_save_to_file
@
<<Grids: parameters>>=
character(len=*), parameter :: DEFAULT_OUTPUT_PRECISION = FMT_16
@ %def DEFAULT_OUTPUT_PRECISION
@
<<Grids: public>>=
public :: verify_points_for_grid
<<Grids: procedures>>=
function verify_points_for_grid (file, points) result (valid)
logical :: valid
character(len=*), intent(in) :: file
integer, dimension(:), intent(in) :: points
integer, dimension(:), allocatable :: points_from_file
integer :: u
call load_points_from_file (file, u, points_from_file)
close (u)
if (allocated (points_from_file)) then
valid = all (points == points_from_file)
else
valid = .false.
end if
end function verify_points_for_grid
@ %def verify_points_for_grid
@ Returns the [[unit]] that has opened the input [[file]] and read the
first two lines. The caller has to close it. Furthermore, we return
[[points]] containing the number of points in each dimension.
<<Grids: procedures>>=
subroutine load_points_from_file (file, unit, points)
character(len=*), intent(in) :: file
integer, intent(out) :: unit
integer, dimension(:), allocatable :: points
integer :: iostat, n_dimensions, i_dim
unit = free_unit ()
open (file=file, unit=unit, action='read', iostat=iostat)
if (iostat /= 0) return
read (unit, "(I12)", iostat=iostat) n_dimensions
if (iostat /= 0) return
allocate (points (n_dimensions))
do i_dim = 1, size (points)
read (unit, "(I12,1X)", advance='no', iostat=iostat) &
points (i_dim)
end do
if (iostat /= 0) return
read (unit, *)
if (iostat /= 0) return
end subroutine load_points_from_file
@ %def procedure
@
<<Grids: grid: TBP>>=
procedure :: load_from_file => grid_load_from_file
<<Grids: procedures>>=
subroutine grid_load_from_file (grid, file)
class(grid_t), intent(out) :: grid
character(len=*), intent(in) :: file
integer :: iostat, u, i
integer, dimension(:), allocatable :: points
call load_points_from_file (file, u, points)
if (.not. allocated (points)) return
call grid%init (points)
do i = 1, size (grid%values)
read (u, "(" // DEFAULT_OUTPUT_PRECISION // ",1X)", advance='no', iostat=iostat) &
grid%values (i)
end do
if (iostat /= 0) then
call msg_warning ('grid_load_from_file: Could not load grid from file')
end if
close (u)
end subroutine grid_load_from_file
@ %def grid_load_from_file
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[grids_ut.f90]]>>=
<<File header>>
module grids_ut
use unit_tests
use grids_uti
<<Standard module head>>
<<Grids: public test>>
contains
<<Grids: test driver>>
end module grids_ut
@ %def grids_ut
@
<<[[grids_uti.f90]]>>=
<<File header>>
module grids_uti
<<Use kinds>>
use constants, only: zero, one, two, three, four, tiny_07
use file_utils, only: delete_file
use numeric_utils
use grids
<<Standard module head>>
<<Grids: test declarations>>
contains
<<Grids: tests>>
end module grids_uti
@ %def grids_ut
@ API: driver for the unit tests below.
<<Grids: public test>>=
public :: grids_test
<<Grids: test driver>>=
subroutine grids_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Grids: execute tests>>
end subroutine grids_test
@ %def grids_test
@
\subsubsection{Test Index Function}
<<Grids: execute tests>>=
call test(grids_1, "grids_1", &
"Test Index Function", u, results)
<<Grids: test declarations>>=
public :: grids_1
<<Grids: tests>>=
subroutine grids_1 (u)
integer, intent(in) :: u
type(grid_t) :: grid
write (u, "(A)") "* Test output: grids_1"
write (u, "(A)") "* Purpose: Test Index Function"
write (u, "(A)")
call grid%init ([3])
call grid%write(u)
call assert (u, grid%get_index([1]) == 1, "grid%get_index(1) == 1")
call assert (u, grid%get_index([2]) == 2, "grid%get_index(2) == 2")
call assert (u, grid%get_index([3]) == 3, "grid%get_index(3) == 3")
call grid%final ()
call grid%init ([3,3])
call grid%write(u)
call assert (u, grid%get_index([1,1]) == 1, "grid%get_index(1,1) == 1")
call assert (u, grid%get_index([2,1]) == 2, "grid%get_index(2,1) == 2")
call assert (u, grid%get_index([3,1]) == 3, "grid%get_index(3,1) == 3")
call assert (u, grid%get_index([1,2]) == 4, "grid%get_index(1,2) == 4")
call assert (u, grid%get_index([2,2]) == 5, "grid%get_index(2,2) == 5")
call assert (u, grid%get_index([3,2]) == 6, "grid%get_index(3,2) == 6")
call assert (u, grid%get_index([1,3]) == 7, "grid%get_index(1,3) == 7")
call assert (u, grid%get_index([2,3]) == 8, "grid%get_index(2,3) == 8")
call assert (u, grid%get_index([3,3]) == 9, "grid%get_index(3,3) == 9")
call grid%final ()
call grid%init ([3,3,2])
call grid%write(u)
call assert (u, grid%get_index([1,1,1]) == 1, "grid%get_index(1,1,1) == 1")
call assert (u, grid%get_index([2,1,2]) == 2+9, "grid%get_index(2,1,2) == 2+9")
call assert (u, grid%get_index([3,3,1]) == 9, "grid%get_index(3,3,1) == 3")
call assert (u, grid%get_index([3,1,2]) == 3+9, "grid%get_index(3,1,2) == 4+9")
call assert (u, grid%get_index([2,2,1]) == 5, "grid%get_index(2,2,1) == 5")
call assert (u, grid%get_index([3,2,2]) == 6+9, "grid%get_index(3,2,2) == 6+9")
call assert (u, grid%get_index([1,3,1]) == 7, "grid%get_index(1,3,1) == 7")
call assert (u, grid%get_index([2,3,2]) == 8+9, "grid%get_index(2,3,2) == 8+9")
call assert (u, grid%get_index([3,3,2]) == 9+9, "grid%get_index(3,3,2) == 9+9")
call grid%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: grids_1"
end subroutine grids_1
@ %def grids_1
@
\subsubsection{Saving and Loading}
<<Grids: execute tests>>=
call test(grids_2, "grids_2", &
"Saving and Loading", u, results)
<<Grids: test declarations>>=
public :: grids_2
<<Grids: tests>>=
subroutine grids_2 (u)
integer, intent(in) :: u
type(grid_t) :: grid
write (u, "(A)") "* Test output: grids_2"
write (u, "(A)") "* Purpose: Saving and Loading"
write (u, "(A)")
call grid%init ([3])
call grid%set_values ([one, two, three])
call grid%save_to_file ('grids_2_test')
call grid%final ()
call assert (u, verify_points_for_grid('grids_2_test', [3]), &
"verify_points_for_grid")
call grid%load_from_file ('grids_2_test')
call grid%write (u)
call assert (u, nearly_equal (grid%get_value([1]), one), "grid%get_value(1) == 1")
call assert (u, nearly_equal (grid%get_value([2]), two), "grid%get_value(2) == 2")
call assert (u, nearly_equal (grid%get_value([3]), three), "grid%get_value(3) == 3")
call grid%final ()
call grid%init ([3,3])
call grid%set_values ([one, two, three, four, zero, zero, zero, zero, zero])
call grid%save_to_file ('grids_2_test')
call grid%final ()
call assert (u, verify_points_for_grid('grids_2_test', [3,3]), &
"verify_points_for_grid")
call grid%load_from_file ('grids_2_test')
call grid%write (u)
call assert (u, nearly_equal (grid%get_value([1,1]), one), "grid%get_value(1,1) == 1")
call assert (u, nearly_equal (grid%get_value([2,1]), two), "grid%get_value(2,1) == 2")
call assert (u, nearly_equal (grid%get_value([3,1]), three), "grid%get_value(3,1) == 3")
call assert (u, nearly_equal (grid%get_value([1,2]), four), "grid%get_value(1,2) == 4")
call delete_file ('grids_2_test')
call grid%load_from_file ('grids_2_test')
call assert (u, .not. verify_points_for_grid('grids_2_test', [3,3]), &
"verify_points_for_grid")
call grid%write (u)
write (u, "(A)")
write (u, "(A)") "* Test output end: grids_2"
end subroutine grids_2
@ %def grids_2
@
\subsubsection{Get Segments}
<<Grids: execute tests>>=
call test(grids_3, "grids_3", &
"Get Segments", u, results)
<<Grids: test declarations>>=
public :: grids_3
<<Grids: tests>>=
subroutine grids_3 (u)
integer, intent(in) :: u
type(grid_t) :: grid
integer, dimension(2) :: fail
write (u, "(A)") "* Test output: grids_3"
write (u, "(A)") "* Purpose: Get Segments"
write (u, "(A)")
call grid%init ([3])
call assert (u, all(grid%get_segment([0.00_default]) == [1]), &
"all(grid%get_segment([0.00_default]) == [1])")
call assert (u, all(grid%get_segment([0.32_default]) == [1]), &
"all(grid%get_segment([0.32_default]) == [1])")
call assert (u, all(grid%get_segment([0.52_default]) == [2]), &
"all(grid%get_segment([0.52_default]) == [2])")
call assert (u, all(grid%get_segment([1.00_default]) == [3]), &
"all(grid%get_segment([1.00_default]) == [3])")
call grid%final ()
call grid%init ([3,3])
call assert (u, all(grid%get_segment([0.00_default,0.00_default]) == [1,1]), &
"all(grid%get_segment([0.00_default,0.00_default]) == [1,1])")
call assert (u, all(grid%get_segment([0.32_default,0.32_default]) == [1,1]), &
"all(grid%get_segment([0.32_default,0.32_default]) == [1,1])")
call assert (u, all(grid%get_segment([0.52_default,0.52_default]) == [2,2]), &
"all(grid%get_segment([0.52_default,0.52_default]) == [2,2])")
call assert (u, all(grid%get_segment([1.00_default,1.00_default]) == [3,3]), &
"all(grid%get_segment([1.00_default,1.00_default]) == [3,3])")
write (u, "(A)") "* A double error is expected"
fail = grid%get_segment([1.10_default,1.10_default], u)
call grid%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: grids_3"
end subroutine grids_3
@ %def grids_3
@
\subsubsection{Update Maxima}
<<Grids: execute tests>>=
call test(grids_4, "grids_4", &
"Update Maxima", u, results)
<<Grids: test declarations>>=
public :: grids_4
<<Grids: tests>>=
subroutine grids_4 (u)
integer, intent(in) :: u
type(grid_t) :: grid
write (u, "(A)") "* Test output: grids_4"
write (u, "(A)") "* Purpose: Update Maxima"
write (u, "(A)")
call grid%init ([4,4])
call grid%update_maxima ([0.1_default, 0.0_default], 0.3_default)
call grid%update_maxima ([0.9_default, 0.95_default], 1.7_default)
call grid%write (u)
call assert_equal (u, grid%get_value([1,1]), 0.3_default, &
"grid%get_value([1,1]")
call assert_equal (u, grid%get_value([2,2]), 0.0_default, &
"grid%get_value([2,2]")
call assert_equal (u, grid%get_value([4,4]), 1.7_default, &
"grid%get_value([4,4]")
write (u, "(A)")
write (u, "(A)") "* Test output end: grids_4"
end subroutine grids_4
@ %def grids_4
@
\subsubsection{Finding and checking}
<<Grids: execute tests>>=
call test(grids_5, "grids_5", &
"Finding and checking", u, results)
<<Grids: test declarations>>=
public :: grids_5
<<Grids: tests>>=
subroutine grids_5 (u)
integer, intent(in) :: u
type(grid_t) :: grid
real(default) :: first, second
write (u, "(A)") "* Test output: grids_5"
write (u, "(A)") "* Purpose: Finding and checking"
write (u, "(A)")
call grid%init ([2,2,2])
first = one / two - tiny_07
second = two / two - tiny_07
call grid%update_maxima ([0.1_default, 0.0_default, first], 0.3_default)
call grid%update_maxima ([0.9_default, 0.95_default, second], 1.7_default)
call grid%write (u)
call assert (u, .not. grid%is_non_zero_everywhere (), &
".not. grid%is_non_zero_everywhere (")
call assert_equal (u, grid%get_maximum_in_3d (1), 0.3_default, &
"grid%get_maximum_in_3d (1)")
call assert_equal (u, grid%get_maximum_in_3d (2), 1.7_default, &
"grid%get_maximum_in_3d (2)")
call grid%update_maxima ([0.9_default, 0.95_default, first], 1.8_default)
call grid%update_maxima ([0.1_default, 0.95_default, first], 1.5_default)
call grid%update_maxima ([0.9_default, 0.15_default, first], 1.5_default)
call grid%update_maxima ([0.1_default, 0.0_default, second], 0.2_default)
call grid%update_maxima ([0.1_default, 0.9_default, second], 0.2_default)
call grid%update_maxima ([0.9_default, 0.0_default, second], 0.2_default)
call grid%write (u)
call assert (u, grid%is_non_zero_everywhere (), &
"grid%is_non_zero_everywhere (")
call assert_equal (u, grid%get_maximum_in_3d (1), 1.8_default, &
"grid%get_maximum_in_3d (1)")
call assert_equal (u, grid%get_maximum_in_3d (2), 1.7_default, &
"grid%get_maximum_in_3d (2)")
write (u, "(A)")
write (u, "(A)") "* Test output end: grids_5"
end subroutine grids_5
@ %def grids_5
@ One could think of multiple implementations of a generic type.
<<[[solver.f90]]>>=
<<File header>>
module solver
<<Use kinds>>
use constants, only: tiny_10
use numeric_utils
use diagnostics
<<Standard module head>>
<<solver: public>>
<<solver: parameters>>
<<solver: types>>
<<solver: interfaces>>
contains
<<solver: procedures>>
end module solver
@ %def solver
@
<<solver: public>>=
public :: solver_function_t
<<solver: types>>=
type, abstract :: solver_function_t
contains
procedure(solver_function_evaluate), deferred :: evaluate
end type solver_function_t
@ %def solver_function_t
@
<<solver: interfaces>>=
abstract interface
function solver_function_evaluate (solver_f, x) result (f)
import
complex(default) :: f
class(solver_function_t), intent(in) :: solver_f
real(default), intent(in) :: x
end function
end interface
@ %def solver_function_evaluate
@
<<solver: public>>=
public :: solve_secant
<<solver: procedures>>=
function solve_secant (func, lower_start, upper_start, success, precision) result (x0)
class(solver_function_t), intent(in) :: func
real(default) :: x0
real(default), intent(in) :: lower_start, upper_start
real(default), intent(in), optional :: precision
logical, intent(out) :: success
real(default) :: desired, x_curr, x_next, f_curr, f_next, x_new
integer :: n_iter
desired = DEFAULT_PRECISION; if (present(precision)) desired = precision
x_curr = lower_start
x_next = upper_start
n_iter = 0
success = .false.
SEARCH: do
n_iter = n_iter + 1
f_curr = real( func%evaluate (x_curr) )
f_next = real( func%evaluate (x_next) )
<<Exit if close to zero and handle exceptions>>
x_new = x_next - (x_next - x_curr) / (f_next - f_curr) * f_next
x_curr = x_next
x_next = x_new
end do SEARCH
if (x0 < lower_start .or. x0 > upper_start) then
call msg_warning ("solve: The root of the function is not in boundaries")
return
end if
success = .true.
end function solve_secant
@ %def solve_secant
<<Exit if close to zero and handle exceptions>>=
if (abs (f_next) < desired) then
x0 = x_next
exit
end if
if (n_iter > MAX_TRIES) then
call msg_warning ("solve: Couldn't find root of function")
return
end if
if (vanishes (f_next - f_curr)) then
x_next = x_next + (x_next - x_curr) / 10
cycle
end if
@
@ Implements the bisection root-finding method to find a root of [[func]]
between [[lower_start]] and [[upper_start]] with tolerance [[precision]].
<<solver: public>>=
public :: solve_interval
<<solver: procedures>>=
function solve_interval (func, lower_start, upper_start, success, precision) &
result (x0)
class(solver_function_t), intent(in) :: func
real(default) :: x0
real(default), intent(in) :: lower_start, upper_start
real(default), intent(in), optional :: precision
logical, intent(out) :: success
real(default) :: desired
real(default) :: x_low, x_high, x_half
real(default) :: f_low, f_high, f_half
integer :: n_iter
success = .false.
desired = DEFAULT_PRECISION; if (present(precision)) desired = precision
x0 = lower_start
x_low = lower_start
x_high = upper_start
f_low = real( func%evaluate (x_low) )
f_high = real( func%evaluate (x_high) )
if (f_low * f_high > 0) return
if (x_low > x_high) then
call display_solver_status()
call msg_fatal ("Interval solver: Upper bound must be &
&greater than lower bound")
end if
n_iter = 0
do n_iter = 1, MAX_TRIES
x_half = (x_high + x_low)/2
f_half = real( func%evaluate (x_half) )
if (abs (f_half) <= desired) then
x0 = x_half
exit
end if
if (f_low * f_half > 0._default) then
x_low = x_half
f_low = f_half
else
x_high = x_half
f_high = f_half
end if
end do
if (x0 < lower_start .or. x0 > upper_start) then
call msg_warning ("Interval solver: The root of the function&
& is out of boundaries")
return
end if
success = .true.
contains
subroutine display_solver_status ()
print *, '================='
print *, 'Status of interval solver: '
print *, 'initial values: ', lower_start, upper_start
print *, 'iteration: ', n_iter
print *, 'x_low: ', x_low, 'f_low: ', f_low
print *, 'x_high: ', x_high, 'f_high: ', f_high
print *, 'x_half: ', x_half, 'f_half: ', f_half
end subroutine display_solver_status
end function solve_interval
@ %def solve_interval
@
<<solver: public>>=
public :: solve_qgaus
<<solver: procedures>>=
function solve_qgaus (integrand, grid) result (integral)
class(solver_function_t), intent(in) :: integrand
complex(default) :: integral
real(default), dimension(:), intent(in) :: grid
integer :: i, j
real(default) :: xm, xr
real(default), dimension(5) :: dx, &
w = (/ 0.2955242247_default, 0.2692667193_default, &
0.2190863625_default, 0.1494513491_default, 0.0666713443_default /), &
x = (/ 0.1488743389_default, 0.4333953941_default, 0.6794095682_default, &
0.8650633666_default, 0.9739065285_default /)
integral = 0.0_default
if ( size(grid) < 2 ) then
call msg_warning ("solve_qgaus: size of integration grid smaller than 2.")
return
end if
do i=1, size(grid)-1
xm = 0.5_default * ( grid(i+1) + grid(i) )
xr = 0.5_default * ( grid(i+1) - grid(i) )
do j=1, 5
dx(j) = xr * x(j)
integral = integral + xr * w(j) * &
( integrand%evaluate (xm+dx(j)) + integrand%evaluate (xm-dx(j)) )
end do
end do
end function solve_qgaus
@ %def solve_qgaus
@
<<solver: parameters>>=
real(default), parameter, public :: DEFAULT_PRECISION = tiny_10
@ %def name
@
<<solver: parameters>>=
integer, parameter :: MAX_TRIES = 10000
@ %def MAX_TRIES
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[solver_ut.f90]]>>=
<<File header>>
module solver_ut
use unit_tests
use solver_uti
<<Standard module head>>
<<solver: public test>>
contains
<<solver: test driver>>
end module solver_ut
@ %def solver_ut
@
<<[[solver_uti.f90]]>>=
<<File header>>
module solver_uti
<<Use kinds>>
use constants, only: zero, one, two
use numeric_utils
use solver
<<Standard module head>>
<<solver: test declarations>>
<<solver: test types>>
contains
<<solver: tests>>
<<solver: test auxiliary>>
end module solver_uti
@ %def solver_ut
@ API: driver for the unit tests below.
<<solver: public test>>=
public :: solver_test
<<solver: test driver>>=
subroutine solver_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<solver: execute tests>>
end subroutine solver_test
@ %def solver_test
@
\subsubsection{Test functions}
<<solver: test types>>=
type, extends (solver_function_t) :: test_function_1_t
contains
procedure :: evaluate => test_func_1
end type test_function_1_t
@ %def test_function_1_t
@
<<solver: test types>>=
type, extends (solver_function_t) :: test_function_2_t
contains
procedure :: evaluate => test_func_2
end type test_function_2_t
@ %def test_function_2_t
@
<<solver: test types>>=
type, extends (solver_function_t) :: test_function_3_t
contains
procedure :: evaluate => test_func_3
end type test_function_3_t
@ %def test_function_3_t
@
<<solver: test types>>=
type, extends (solver_function_t) :: test_function_4_t
contains
procedure :: evaluate => test_func_4
end type test_function_4_t
@ %def test_function_4_t
@
<<solver: test auxiliary>>=
function test_func_1 (solver_f, x) result (f)
complex(default) :: f
class(test_function_1_t), intent(in) :: solver_f
real(default), intent(in) :: x
f = x
end function test_func_1
function test_func_2 (solver_f, x) result (f)
complex(default) :: f
class(test_function_2_t), intent(in) :: solver_f
real(default), intent(in) :: x
f = x ** 2
end function test_func_2
function test_func_3 (solver_f, x) result (f)
complex(default) :: f
class(test_function_3_t), intent(in) :: solver_f
real(default), intent(in) :: x
f = x ** 3
end function test_func_3
function test_func_4 (solver_f, x) result (f)
complex(default) :: f
class(test_function_4_t), intent(in) :: solver_f
real(default), intent(in) :: x
real(default) :: s, cutoff
s = 100.0_default
cutoff = 1.01_default
if (x < cutoff) then
f = - (log (s) * log (log (s) / log(cutoff**2)) - log (s / cutoff**2)) - &
log (one/two)
else
f = - (log (s) * log (log (s) / log(x**2)) - log (s / x**2)) - &
log (one/two)
end if
end function test_func_4
@ %def test_func_1
@
\subsubsection{Solve trivial functions}
<<solver: execute tests>>=
call test(solver_1, "solver_1", &
"Solve trivial functions", u, results)
<<solver: test declarations>>=
public :: solver_1
<<solver: tests>>=
subroutine solver_1 (u)
integer, intent(in) :: u
real(default) :: zero_position
logical :: success
type(test_function_1_t) :: test_func_1
type(test_function_2_t) :: test_func_2
type(test_function_3_t) :: test_func_3
type(test_function_4_t) :: test_func_4
write (u, "(A)") "* Test output: solver_1"
write (u, "(A)") "* Purpose: Solve trivial functions"
write (u, "(A)")
zero_position = solve_interval (test_func_1, -one, one, success)
call assert (u, success, "success")
call assert_equal (u, zero_position, zero, "test_func_1: zero_position")
zero_position = solve_interval (test_func_4, two, 10.0_default, success)
call assert (u, success, "success")
call assert_equal (u, zero_position, &
3.5216674011865940283397224_default, &
"test_func_4: zero_position", rel_smallness=1000*DEFAULT_PRECISION)
write (u, "(A)")
write (u, "(A)") "* Test output end: solver_1"
end subroutine solver_1
@ %def solver_1
@
Index: trunk/src/threshold/threshold.nw
===================================================================
--- trunk/src/threshold/threshold.nw (revision 8768)
+++ trunk/src/threshold/threshold.nw (revision 8769)
@@ -1,11176 +1,11176 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD threshold code as NOWEB source: threshold
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Infrastructure for threshold processes}
\includemodulegraph{threshold}
<<[[interpolation.f90]]>>=
<<File header>>
module interpolation
use kinds
implicit none
save
private
public :: interpolate_linear, strictly_monotonous
interface interpolate_linear
module procedure interpolate_linear_1D_complex_array, &
interpolate_linear_1D_complex_scalar, &
interpolate_linear_1D_real_array, &
interpolate_linear_1D_real_scalar, &
interpolate_linear_2D_complex_array, &
interpolate_linear_2D_complex_scalar, &
interpolate_linear_2D_real_array, &
interpolate_linear_2D_real_scalar, &
interpolate_linear_3D_complex_array, &
interpolate_linear_3D_complex_scalar, &
interpolate_linear_3D_real_array, &
interpolate_linear_3D_real_scalar
end interface
interface strictly_monotonous
module procedure monotonous
end interface strictly_monotonous
interface find_nearest_left
!!! recursive bisection is slower
module procedure find_nearest_left_loop
end interface find_nearest_left
contains
pure subroutine interpolate_linear_1D_complex_scalar (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
complex(default), dimension(:), intent(in) :: ya
real(default), intent(in) :: x
complex(default), intent(out) :: y
integer :: ixl
real(default) :: t
y = 0.0_default
!!! don't check this at runtime:
! if ( .not.monotonous(xa) ) return
if ( out_of_range(xa, x) ) return
ixl = 0
call find_nearest_left (xa, x, ixl)
t = ( x - xa(ixl) ) / ( xa(ixl+1) - xa(ixl) )
y = (1.-t)*ya(ixl) + t*ya(ixl+1)
end subroutine interpolate_linear_1D_complex_scalar
pure subroutine interpolate_linear_2D_complex_scalar (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
complex(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
complex(default), intent(out) :: y
integer :: ix1l, ix2l
real(default) :: t, u
y = 0.0_default
!!! don't check this at runtime:
! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return
if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) ) return
ix1l = 0
call find_nearest_left (x1a, x1, ix1l)
ix2l = 0
call find_nearest_left (x2a, x2, ix2l)
t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) )
u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) )
y = (1.-t)*(1.-u)*ya(ix1l ,ix2l ) &
+ t *(1.-u)*ya(ix1l+1,ix2l ) &
+ t * u *ya(ix1l+1,ix2l+1) &
+(1.-t)* u *ya(ix1l ,ix2l+1)
end subroutine interpolate_linear_2D_complex_scalar
pure subroutine interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
complex(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
complex(default), intent(out) :: y
integer :: ix1l, ix2l, ix3l
real(default) :: t, u, v
y = 0.0_default
!!! don't check this at runtime:
! if ( (.not.monotonous(x1a)) .or. (.not.monotonous(x2a)) ) return
if ( out_of_range(x1a, x1) .or. out_of_range(x2a, x2) .or. out_of_range(x3a, x3) ) return
ix1l = 0
call find_nearest_left (x1a, x1, ix1l)
ix2l = 0
call find_nearest_left (x2a, x2, ix2l)
ix3l = 0
call find_nearest_left (x3a, x3, ix3l)
t = ( x1 - x1a(ix1l) ) / ( x1a(ix1l+1) - x1a(ix1l) )
u = ( x2 - x2a(ix2l) ) / ( x2a(ix2l+1) - x2a(ix2l) )
v = ( x3 - x3a(ix3l) ) / ( x3a(ix3l+1) - x3a(ix3l) )
y = (1.-t)*(1.-u)*(1.-v)*ya(ix1l ,ix2l ,ix3l ) &
+(1.-t)*(1.-u)* v *ya(ix1l ,ix2l ,ix3l+1) &
+(1.-t)* u *(1.-v)*ya(ix1l ,ix2l+1,ix3l ) &
+(1.-t)* u * v *ya(ix1l ,ix2l+1,ix3l+1) &
+ t *(1.-u)*(1.-v)*ya(ix1l+1,ix2l ,ix3l ) &
+ t *(1.-u)* v *ya(ix1l+1,ix2l ,ix3l+1) &
+ t * u *(1.-v)*ya(ix1l+1,ix2l+1,ix3l ) &
+ t * u * v *ya(ix1l+1,ix2l+1,ix3l+1)
end subroutine interpolate_linear_3D_complex_scalar
pure subroutine find_nearest_left_loop (xa, x, ixl)
real(default), dimension(:), intent(in) :: xa
real(default), intent(in) :: x
integer, intent(out) :: ixl
integer :: ixm, ixr
ixl = 1
ixr = size(xa)
do
if ( ixr-ixl <= 1 ) return
ixm = (ixr+ixl) / 2
if ( x < xa(ixm) ) then
ixr = ixm
else
ixl = ixm
end if
end do
end subroutine find_nearest_left_loop
pure recursive subroutine find_nearest_left_rec (xa, x, ixl)
real(default), dimension(:), intent(in) :: xa
real(default), intent(in) :: x
integer, intent(inout) :: ixl
integer :: nx, bs
real(default), dimension(:), allocatable :: xa_new
nx = size(xa)
bs = nx/2 + 1
if ( nx < 3 ) then
ixl = ixl + bs - 1
return
else
if ( x < xa(bs) ) then
allocate( xa_new(1:bs) )
xa_new = xa(1:bs)
else
ixl = ixl + bs - 1
allocate( xa_new(bs:nx) )
xa_new = xa(bs:nx)
end if
call find_nearest_left_rec (xa_new, x, ixl)
deallocate( xa_new )
end if
end subroutine find_nearest_left_rec
pure function monotonous (xa) result (flag)
real(default), dimension(:), intent(in) :: xa
integer :: ix
logical :: flag
flag = .false.
do ix = 1, size(xa)-1
flag = ( xa(ix) < xa(ix+1) )
if ( .not. flag ) return
end do
end function monotonous
pure function out_of_range (xa, x) result (flag)
real(default), dimension(:), intent(in) :: xa
real(default), intent(in) :: x
logical :: flag
flag = ( x < xa(1) .or. x > xa(size(xa)) )
end function out_of_range
pure subroutine interpolate_linear_1D_complex_array (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
complex(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x
complex(default), dimension(size(ya(1,:))), intent(out) :: y
integer :: iy
do iy=1, size(y)
call interpolate_linear_1D_complex_scalar (xa, ya(:,iy), x, y(iy))
end do
end subroutine interpolate_linear_1D_complex_array
pure subroutine interpolate_linear_1D_real_array (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
real(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x
real(default), dimension(:), intent(out) :: y
complex(default), dimension(size(ya(1,:))) :: y_c
call interpolate_linear_1D_complex_array (xa, cmplx(ya,kind=default), x, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_1D_real_array
pure subroutine interpolate_linear_1D_real_scalar (xa, ya, x, y)
real(default), dimension(:), intent(in) :: xa
real(default), dimension(:), intent(in) :: ya
real(default), intent(in) :: x
real(default), intent(out) :: y
complex(default), dimension(size(ya)) :: ya_c
complex(default) :: y_c
ya_c = cmplx(ya,kind=default)
call interpolate_linear_1D_complex_scalar (xa, ya_c, x, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_1D_real_scalar
pure subroutine interpolate_linear_2D_complex_array (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
complex(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
complex(default), dimension(size(ya(1,1,:))), intent(out) :: y
integer :: iy
do iy=1, size(y)
call interpolate_linear_2D_complex_scalar (x1a, x2a, ya(:,:,iy), x1, x2, y(iy))
end do
end subroutine interpolate_linear_2D_complex_array
pure subroutine interpolate_linear_2D_real_array (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), dimension(:), intent(out) :: y
complex(default), dimension(size(ya(1,1,:))) :: y_c
call interpolate_linear_2D_complex_array (x1a, x2a, cmplx(ya,kind=default), x1, x2, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_2D_real_array
pure subroutine interpolate_linear_2D_real_scalar (x1a, x2a, ya, x1, x2, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(out) :: y
complex(default), dimension(size(ya(:,1)),size(ya(1,:))) :: ya_c
complex(default) :: y_c
ya_c = reshape (ya_c, shape(ya))
ya_c = cmplx(ya,kind=default)
call interpolate_linear_2D_complex_scalar (x1a, x2a, ya_c, x1, x2, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_2D_real_scalar
pure subroutine interpolate_linear_3D_complex_array (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
complex(default), dimension(:,:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
complex(default), dimension(size(ya(1,1,1,:))), intent(out) :: y
integer :: iy
do iy=1, size(y)
call interpolate_linear_3D_complex_scalar &
(x1a, x2a, x3a, ya(:,:,:,iy), x1, x2, x3, y(iy))
end do
end subroutine interpolate_linear_3D_complex_array
pure subroutine interpolate_linear_3D_real_array (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
real(default), dimension(:,:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
real(default), dimension(:), intent(out) :: y
complex(default), dimension(size(ya(1,1,1,:))) :: y_c
call interpolate_linear_3D_complex_array &
(x1a, x2a, x3a, cmplx(ya,kind=default), x1, x2, x3, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_3D_real_array
pure subroutine interpolate_linear_3D_real_scalar (x1a, x2a, x3a, ya, x1, x2, x3, y)
real(default), dimension(:), intent(in) :: x1a
real(default), dimension(:), intent(in) :: x2a
real(default), dimension(:), intent(in) :: x3a
real(default), dimension(:,:,:), intent(in) :: ya
real(default), intent(in) :: x1
real(default), intent(in) :: x2
real(default), intent(in) :: x3
real(default), intent(out) :: y
complex(default), dimension(size(ya(:,1,1)),size(ya(1,:,1)),size(ya(1,1,:))) :: ya_c
complex(default) :: y_c
ya_c = cmplx(ya,kind=default)
call interpolate_linear_3D_complex_scalar (x1a, x2a, x3a, ya_c, x1, x2, x3, y_c)
y = real(y_c,kind=default)
end subroutine interpolate_linear_3D_real_scalar
end module interpolation
@
<<[[nr_tools.f90]]>>=
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! WHIZARD <<Version>> <<Date>>
! routine hypgeo and other useful procedures from:
!
! Numerical Recipes in Fortran 77 and 90 (Second Edition)
!
! Book and code Copyright (c) 1986-2001,
! William H. Press, Saul A. Teukolsky,
! William T. Verrerling, Brian P. Flannery.
!
! Information at http://www.nr.com
!
!
!
! FB: -replaced tabs by 2 whitespaces
! -reduced hardcoded default stepsize for subroutine 'odeint'
! called by hypgeo, cf. line 4751
! -added explicit interface for function 'qgaus' to main module 'nr'
! -renamed function 'locate' to 'locatenr' to avoid segfault (???)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE nrtype
INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
INTEGER, PARAMETER :: SP = KIND(1.0)
INTEGER, PARAMETER :: DP = KIND(1.0D0)
INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
INTEGER, PARAMETER :: LGT = KIND(.true.)
REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp
REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp
REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp
REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp
REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp
REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp
REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp
REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp
TYPE sprs2_sp
INTEGER(I4B) :: n,len
REAL(SP), DIMENSION(:), POINTER :: val
INTEGER(I4B), DIMENSION(:), POINTER :: irow
INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_sp
TYPE sprs2_dp
INTEGER(I4B) :: n,len
REAL(DP), DIMENSION(:), POINTER :: val
INTEGER(I4B), DIMENSION(:), POINTER :: irow
INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_dp
END MODULE nrtype
MODULE nrutil
USE nrtype
IMPLICIT NONE
INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8
INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2
INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16
INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8
INTEGER(I4B), PARAMETER :: NPAR_POLY=8
INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8
INTERFACE array_copy
MODULE PROCEDURE array_copy_r, array_copy_d, array_copy_i
END INTERFACE
INTERFACE swap
MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, &
swap_cv,swap_cm,swap_z,swap_zv,swap_zm, &
masked_swap_rs,masked_swap_rv,masked_swap_rm
END INTERFACE
INTERFACE reallocate
MODULE PROCEDURE reallocate_rv,reallocate_rm,&
reallocate_iv,reallocate_im,reallocate_hv
END INTERFACE
INTERFACE imaxloc
MODULE PROCEDURE imaxloc_r,imaxloc_i
END INTERFACE
INTERFACE assert
MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v
END INTERFACE
INTERFACE assert_eq
MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
END INTERFACE
INTERFACE arth
MODULE PROCEDURE arth_r, arth_d, arth_i
END INTERFACE
INTERFACE geop
MODULE PROCEDURE geop_r, geop_d, geop_i, geop_c, geop_dv
END INTERFACE
INTERFACE cumsum
MODULE PROCEDURE cumsum_r,cumsum_i
END INTERFACE
INTERFACE poly
MODULE PROCEDURE poly_rr,poly_rrv,poly_dd,poly_ddv,&
poly_rc,poly_cc,poly_msk_rrv,poly_msk_ddv
END INTERFACE
INTERFACE poly_term
MODULE PROCEDURE poly_term_rr,poly_term_cc
END INTERFACE
INTERFACE outerprod
MODULE PROCEDURE outerprod_r,outerprod_d
END INTERFACE
INTERFACE outerdiff
MODULE PROCEDURE outerdiff_r,outerdiff_d,outerdiff_i
END INTERFACE
INTERFACE scatter_add
MODULE PROCEDURE scatter_add_r,scatter_add_d
END INTERFACE
INTERFACE scatter_max
MODULE PROCEDURE scatter_max_r,scatter_max_d
END INTERFACE
INTERFACE diagadd
MODULE PROCEDURE diagadd_rv,diagadd_r
END INTERFACE
INTERFACE diagmult
MODULE PROCEDURE diagmult_rv,diagmult_r
END INTERFACE
INTERFACE get_diag
MODULE PROCEDURE get_diag_rv, get_diag_dv
END INTERFACE
INTERFACE put_diag
MODULE PROCEDURE put_diag_rv, put_diag_r
END INTERFACE
CONTAINS
!BL
SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied)
REAL(SP), DIMENSION(:), INTENT(IN) :: src
REAL(SP), DIMENSION(:), INTENT(OUT) :: dest
INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied
n_copied=min(size(src),size(dest))
n_not_copied=size(src)-n_copied
dest(1:n_copied)=src(1:n_copied)
END SUBROUTINE array_copy_r
!BL
SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied)
REAL(DP), DIMENSION(:), INTENT(IN) :: src
REAL(DP), DIMENSION(:), INTENT(OUT) :: dest
INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied
n_copied=min(size(src),size(dest))
n_not_copied=size(src)-n_copied
dest(1:n_copied)=src(1:n_copied)
END SUBROUTINE array_copy_d
!BL
SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied)
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest
INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied
n_copied=min(size(src),size(dest))
n_not_copied=size(src)-n_copied
dest(1:n_copied)=src(1:n_copied)
END SUBROUTINE array_copy_i
!BL
!BL
SUBROUTINE swap_i(a,b)
INTEGER(I4B), INTENT(INOUT) :: a,b
INTEGER(I4B) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_i
!BL
SUBROUTINE swap_r(a,b)
REAL(SP), INTENT(INOUT) :: a,b
REAL(SP) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_r
!BL
SUBROUTINE swap_rv(a,b)
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b
REAL(SP), DIMENSION(SIZE(a)) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_rv
!BL
SUBROUTINE swap_c(a,b)
COMPLEX(SPC), INTENT(INOUT) :: a,b
COMPLEX(SPC) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_c
!BL
SUBROUTINE swap_cv(a,b)
COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b
COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_cv
!BL
SUBROUTINE swap_cm(a,b)
COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b
COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_cm
!BL
SUBROUTINE swap_z(a,b)
COMPLEX(DPC), INTENT(INOUT) :: a,b
COMPLEX(DPC) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_z
!BL
SUBROUTINE swap_zv(a,b)
COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: a,b
COMPLEX(DPC), DIMENSION(SIZE(a)) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_zv
!BL
SUBROUTINE swap_zm(a,b)
COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: a,b
COMPLEX(DPC), DIMENSION(size(a,1),size(a,2)) :: dum
dum=a
a=b
b=dum
END SUBROUTINE swap_zm
!BL
SUBROUTINE masked_swap_rs(a,b,mask)
REAL(SP), INTENT(INOUT) :: a,b
LOGICAL(LGT), INTENT(IN) :: mask
REAL(SP) :: swp
if (mask) then
swp=a
a=b
b=swp
end if
END SUBROUTINE masked_swap_rs
!BL
SUBROUTINE masked_swap_rv(a,b,mask)
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
REAL(SP), DIMENSION(size(a)) :: swp
where (mask)
swp=a
a=b
b=swp
end where
END SUBROUTINE masked_swap_rv
!BL
SUBROUTINE masked_swap_rm(a,b,mask)
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b
LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask
REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp
where (mask)
swp=a
a=b
b=swp
end where
END SUBROUTINE masked_swap_rm
!BL
!BL
FUNCTION reallocate_rv(p,n)
REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B) :: nold,ierr
allocate(reallocate_rv(n),stat=ierr)
if (ierr /= 0) call &
nrerror('reallocate_rv: problem in attempt to allocate memory')
if (.not. associated(p)) RETURN
nold=size(p)
reallocate_rv(1:min(nold,n))=p(1:min(nold,n))
deallocate(p)
END FUNCTION reallocate_rv
!BL
FUNCTION reallocate_iv(p,n)
INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B) :: nold,ierr
allocate(reallocate_iv(n),stat=ierr)
if (ierr /= 0) call &
nrerror('reallocate_iv: problem in attempt to allocate memory')
if (.not. associated(p)) RETURN
nold=size(p)
reallocate_iv(1:min(nold,n))=p(1:min(nold,n))
deallocate(p)
END FUNCTION reallocate_iv
!BL
FUNCTION reallocate_hv(p,n)
CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B) :: nold,ierr
allocate(reallocate_hv(n),stat=ierr)
if (ierr /= 0) call &
nrerror('reallocate_hv: problem in attempt to allocate memory')
if (.not. associated(p)) RETURN
nold=size(p)
reallocate_hv(1:min(nold,n))=p(1:min(nold,n))
deallocate(p)
END FUNCTION reallocate_hv
!BL
FUNCTION reallocate_rm(p,n,m)
REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm
INTEGER(I4B), INTENT(IN) :: n,m
INTEGER(I4B) :: nold,mold,ierr
allocate(reallocate_rm(n,m),stat=ierr)
if (ierr /= 0) call &
nrerror('reallocate_rm: problem in attempt to allocate memory')
if (.not. associated(p)) RETURN
nold=size(p,1)
mold=size(p,2)
reallocate_rm(1:min(nold,n),1:min(mold,m))=&
p(1:min(nold,n),1:min(mold,m))
deallocate(p)
END FUNCTION reallocate_rm
!BL
FUNCTION reallocate_im(p,n,m)
INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im
INTEGER(I4B), INTENT(IN) :: n,m
INTEGER(I4B) :: nold,mold,ierr
allocate(reallocate_im(n,m),stat=ierr)
if (ierr /= 0) call &
nrerror('reallocate_im: problem in attempt to allocate memory')
if (.not. associated(p)) RETURN
nold=size(p,1)
mold=size(p,2)
reallocate_im(1:min(nold,n),1:min(mold,m))=&
p(1:min(nold,n),1:min(mold,m))
deallocate(p)
END FUNCTION reallocate_im
!BL
FUNCTION ifirstloc(mask)
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
INTEGER(I4B) :: ifirstloc
INTEGER(I4B), DIMENSION(1) :: loc
loc=maxloc(merge(1,0,mask))
ifirstloc=loc(1)
if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1
END FUNCTION ifirstloc
!BL
FUNCTION imaxloc_r(arr)
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
INTEGER(I4B) :: imaxloc_r
INTEGER(I4B), DIMENSION(1) :: imax
imax=maxloc(arr(:))
imaxloc_r=imax(1)
END FUNCTION imaxloc_r
!BL
FUNCTION imaxloc_i(iarr)
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr
INTEGER(I4B), DIMENSION(1) :: imax
INTEGER(I4B) :: imaxloc_i
imax=maxloc(iarr(:))
imaxloc_i=imax(1)
END FUNCTION imaxloc_i
!BL
FUNCTION iminloc(arr)
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
INTEGER(I4B), DIMENSION(1) :: imin
INTEGER(I4B) :: iminloc
imin=minloc(arr(:))
iminloc=imin(1)
END FUNCTION iminloc
!BL
SUBROUTINE assert1(n1,string)
CHARACTER(LEN=*), INTENT(IN) :: string
LOGICAL, INTENT(IN) :: n1
if (.not. n1) then
write (*,*) 'nrerror: an assertion failed with this tag:', &
string
STOP 'program terminated by assert1'
end if
END SUBROUTINE assert1
!BL
SUBROUTINE assert2(n1,n2,string)
CHARACTER(LEN=*), INTENT(IN) :: string
LOGICAL, INTENT(IN) :: n1,n2
if (.not. (n1 .and. n2)) then
write (*,*) 'nrerror: an assertion failed with this tag:', &
string
STOP 'program terminated by assert2'
end if
END SUBROUTINE assert2
!BL
SUBROUTINE assert3(n1,n2,n3,string)
CHARACTER(LEN=*), INTENT(IN) :: string
LOGICAL, INTENT(IN) :: n1,n2,n3
if (.not. (n1 .and. n2 .and. n3)) then
write (*,*) 'nrerror: an assertion failed with this tag:', &
string
STOP 'program terminated by assert3'
end if
END SUBROUTINE assert3
!BL
SUBROUTINE assert4(n1,n2,n3,n4,string)
CHARACTER(LEN=*), INTENT(IN) :: string
LOGICAL, INTENT(IN) :: n1,n2,n3,n4
if (.not. (n1 .and. n2 .and. n3 .and. n4)) then
write (*,*) 'nrerror: an assertion failed with this tag:', &
string
STOP 'program terminated by assert4'
end if
END SUBROUTINE assert4
!BL
SUBROUTINE assert_v(n,string)
CHARACTER(LEN=*), INTENT(IN) :: string
LOGICAL, DIMENSION(:), INTENT(IN) :: n
if (.not. all(n)) then
write (*,*) 'nrerror: an assertion failed with this tag:', &
string
STOP 'program terminated by assert_v'
end if
END SUBROUTINE assert_v
!BL
FUNCTION assert_eq2(n1,n2,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, INTENT(IN) :: n1,n2
INTEGER :: assert_eq2
if (n1 == n2) then
assert_eq2=n1
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eq2'
end if
END FUNCTION assert_eq2
!BL
FUNCTION assert_eq3(n1,n2,n3,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, INTENT(IN) :: n1,n2,n3
INTEGER :: assert_eq3
if (n1 == n2 .and. n2 == n3) then
assert_eq3=n1
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eq3'
end if
END FUNCTION assert_eq3
!BL
FUNCTION assert_eq4(n1,n2,n3,n4,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, INTENT(IN) :: n1,n2,n3,n4
INTEGER :: assert_eq4
if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
assert_eq4=n1
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eq4'
end if
END FUNCTION assert_eq4
!BL
FUNCTION assert_eqn(nn,string)
CHARACTER(LEN=*), INTENT(IN) :: string
INTEGER, DIMENSION(:), INTENT(IN) :: nn
INTEGER :: assert_eqn
if (all(nn(2:) == nn(1))) then
assert_eqn=nn(1)
else
write (*,*) 'nrerror: an assert_eq failed with this tag:', &
string
STOP 'program terminated by assert_eqn'
end if
END FUNCTION assert_eqn
!BL
SUBROUTINE nrerror(string)
CHARACTER(LEN=*), INTENT(IN) :: string
write (*,*) 'nrerror: ',string
STOP 'program terminated by nrerror'
END SUBROUTINE nrerror
!BL
FUNCTION arth_r(first,increment,n)
REAL(SP), INTENT(IN) :: first,increment
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(n) :: arth_r
INTEGER(I4B) :: k,k2
REAL(SP) :: temp
if (n > 0) arth_r(1)=first
if (n <= NPAR_ARTH) then
do k=2,n
arth_r(k)=arth_r(k-1)+increment
end do
else
do k=2,NPAR2_ARTH
arth_r(k)=arth_r(k-1)+increment
end do
temp=increment*NPAR2_ARTH
k=NPAR2_ARTH
do
if (k >= n) exit
k2=k+k
arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k))
temp=temp+temp
k=k2
end do
end if
END FUNCTION arth_r
!BL
FUNCTION arth_d(first,increment,n)
REAL(DP), INTENT(IN) :: first,increment
INTEGER(I4B), INTENT(IN) :: n
REAL(DP), DIMENSION(n) :: arth_d
INTEGER(I4B) :: k,k2
REAL(DP) :: temp
if (n > 0) arth_d(1)=first
if (n <= NPAR_ARTH) then
do k=2,n
arth_d(k)=arth_d(k-1)+increment
end do
else
do k=2,NPAR2_ARTH
arth_d(k)=arth_d(k-1)+increment
end do
temp=increment*NPAR2_ARTH
k=NPAR2_ARTH
do
if (k >= n) exit
k2=k+k
arth_d(k+1:min(k2,n))=temp+arth_d(1:min(k,n-k))
temp=temp+temp
k=k2
end do
end if
END FUNCTION arth_d
!BL
FUNCTION arth_i(first,increment,n)
INTEGER(I4B), INTENT(IN) :: first,increment,n
INTEGER(I4B), DIMENSION(n) :: arth_i
INTEGER(I4B) :: k,k2,temp
if (n > 0) arth_i(1)=first
if (n <= NPAR_ARTH) then
do k=2,n
arth_i(k)=arth_i(k-1)+increment
end do
else
do k=2,NPAR2_ARTH
arth_i(k)=arth_i(k-1)+increment
end do
temp=increment*NPAR2_ARTH
k=NPAR2_ARTH
do
if (k >= n) exit
k2=k+k
arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k))
temp=temp+temp
k=k2
end do
end if
END FUNCTION arth_i
!BL
!BL
FUNCTION geop_r(first,factor,n)
REAL(SP), INTENT(IN) :: first,factor
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(n) :: geop_r
INTEGER(I4B) :: k,k2
REAL(SP) :: temp
if (n > 0) geop_r(1)=first
if (n <= NPAR_GEOP) then
do k=2,n
geop_r(k)=geop_r(k-1)*factor
end do
else
do k=2,NPAR2_GEOP
geop_r(k)=geop_r(k-1)*factor
end do
temp=factor**NPAR2_GEOP
k=NPAR2_GEOP
do
if (k >= n) exit
k2=k+k
geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k))
temp=temp*temp
k=k2
end do
end if
END FUNCTION geop_r
!BL
FUNCTION geop_d(first,factor,n)
REAL(DP), INTENT(IN) :: first,factor
INTEGER(I4B), INTENT(IN) :: n
REAL(DP), DIMENSION(n) :: geop_d
INTEGER(I4B) :: k,k2
REAL(DP) :: temp
if (n > 0) geop_d(1)=first
if (n <= NPAR_GEOP) then
do k=2,n
geop_d(k)=geop_d(k-1)*factor
end do
else
do k=2,NPAR2_GEOP
geop_d(k)=geop_d(k-1)*factor
end do
temp=factor**NPAR2_GEOP
k=NPAR2_GEOP
do
if (k >= n) exit
k2=k+k
geop_d(k+1:min(k2,n))=temp*geop_d(1:min(k,n-k))
temp=temp*temp
k=k2
end do
end if
END FUNCTION geop_d
!BL
FUNCTION geop_i(first,factor,n)
INTEGER(I4B), INTENT(IN) :: first,factor,n
INTEGER(I4B), DIMENSION(n) :: geop_i
INTEGER(I4B) :: k,k2,temp
if (n > 0) geop_i(1)=first
if (n <= NPAR_GEOP) then
do k=2,n
geop_i(k)=geop_i(k-1)*factor
end do
else
do k=2,NPAR2_GEOP
geop_i(k)=geop_i(k-1)*factor
end do
temp=factor**NPAR2_GEOP
k=NPAR2_GEOP
do
if (k >= n) exit
k2=k+k
geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k))
temp=temp*temp
k=k2
end do
end if
END FUNCTION geop_i
!BL
FUNCTION geop_c(first,factor,n)
COMPLEX(SP), INTENT(IN) :: first,factor
INTEGER(I4B), INTENT(IN) :: n
COMPLEX(SP), DIMENSION(n) :: geop_c
INTEGER(I4B) :: k,k2
COMPLEX(SP) :: temp
if (n > 0) geop_c(1)=first
if (n <= NPAR_GEOP) then
do k=2,n
geop_c(k)=geop_c(k-1)*factor
end do
else
do k=2,NPAR2_GEOP
geop_c(k)=geop_c(k-1)*factor
end do
temp=factor**NPAR2_GEOP
k=NPAR2_GEOP
do
if (k >= n) exit
k2=k+k
geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k))
temp=temp*temp
k=k2
end do
end if
END FUNCTION geop_c
!BL
FUNCTION geop_dv(first,factor,n)
REAL(DP), DIMENSION(:), INTENT(IN) :: first,factor
INTEGER(I4B), INTENT(IN) :: n
REAL(DP), DIMENSION(size(first),n) :: geop_dv
INTEGER(I4B) :: k,k2
REAL(DP), DIMENSION(size(first)) :: temp
if (n > 0) geop_dv(:,1)=first(:)
if (n <= NPAR_GEOP) then
do k=2,n
geop_dv(:,k)=geop_dv(:,k-1)*factor(:)
end do
else
do k=2,NPAR2_GEOP
geop_dv(:,k)=geop_dv(:,k-1)*factor(:)
end do
temp=factor**NPAR2_GEOP
k=NPAR2_GEOP
do
if (k >= n) exit
k2=k+k
geop_dv(:,k+1:min(k2,n))=geop_dv(:,1:min(k,n-k))*&
spread(temp,2,size(geop_dv(:,1:min(k,n-k)),2))
temp=temp*temp
k=k2
end do
end if
END FUNCTION geop_dv
!BL
!BL
RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans)
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
REAL(SP), OPTIONAL, INTENT(IN) :: seed
REAL(SP), DIMENSION(size(arr)) :: ans
INTEGER(I4B) :: n,j
REAL(SP) :: sd
n=size(arr)
if (n == 0_i4b) RETURN
sd=0.0_sp
if (present(seed)) sd=seed
ans(1)=arr(1)+sd
if (n < NPAR_CUMSUM) then
do j=2,n
ans(j)=ans(j-1)+arr(j)
end do
else
ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd)
ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2)
end if
END FUNCTION cumsum_r
!BL
RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans)
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr
INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed
INTEGER(I4B), DIMENSION(size(arr)) :: ans
INTEGER(I4B) :: n,j,sd
n=size(arr)
if (n == 0_i4b) RETURN
sd=0_i4b
if (present(seed)) sd=seed
ans(1)=arr(1)+sd
if (n < NPAR_CUMSUM) then
do j=2,n
ans(j)=ans(j-1)+arr(j)
end do
else
ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd)
ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2)
end if
END FUNCTION cumsum_i
!BL
!BL
RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans)
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
REAL(SP), OPTIONAL, INTENT(IN) :: seed
REAL(SP), DIMENSION(size(arr)) :: ans
INTEGER(I4B) :: n,j
REAL(SP) :: sd
n=size(arr)
if (n == 0_i4b) RETURN
sd=1.0_sp
if (present(seed)) sd=seed
ans(1)=arr(1)*sd
if (n < NPAR_CUMPROD) then
do j=2,n
ans(j)=ans(j-1)*arr(j)
end do
else
ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd)
ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2)
end if
END FUNCTION cumprod
!BL
!BL
FUNCTION poly_rr(x,coeffs)
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs
REAL(SP) :: poly_rr
REAL(SP) :: pow
REAL(SP), DIMENSION(:), ALLOCATABLE :: vec
INTEGER(I4B) :: i,n,nn
n=size(coeffs)
if (n <= 0) then
poly_rr=0.0_sp
else if (n < NPAR_POLY) then
poly_rr=coeffs(n)
do i=n-1,1,-1
poly_rr=x*poly_rr+coeffs(i)
end do
else
allocate(vec(n+1))
pow=x
vec(1:n)=coeffs
do
vec(n+1)=0.0_sp
nn=ishft(n+1,-1)
vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
if (nn == 1) exit
pow=pow*pow
n=nn
end do
poly_rr=vec(1)
deallocate(vec)
end if
END FUNCTION poly_rr
!BL
FUNCTION poly_dd(x,coeffs)
REAL(DP), INTENT(IN) :: x
REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs
REAL(DP) :: poly_dd
REAL(DP) :: pow
REAL(DP), DIMENSION(:), ALLOCATABLE :: vec
INTEGER(I4B) :: i,n,nn
n=size(coeffs)
if (n <= 0) then
poly_dd=0.0_dp
else if (n < NPAR_POLY) then
poly_dd=coeffs(n)
do i=n-1,1,-1
poly_dd=x*poly_dd+coeffs(i)
end do
else
allocate(vec(n+1))
pow=x
vec(1:n)=coeffs
do
vec(n+1)=0.0_dp
nn=ishft(n+1,-1)
vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
if (nn == 1) exit
pow=pow*pow
n=nn
end do
poly_dd=vec(1)
deallocate(vec)
end if
END FUNCTION poly_dd
!BL
FUNCTION poly_rc(x,coeffs)
COMPLEX(SPC), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs
COMPLEX(SPC) :: poly_rc
COMPLEX(SPC) :: pow
COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec
INTEGER(I4B) :: i,n,nn
n=size(coeffs)
if (n <= 0) then
poly_rc=0.0_sp
else if (n < NPAR_POLY) then
poly_rc=coeffs(n)
do i=n-1,1,-1
poly_rc=x*poly_rc+coeffs(i)
end do
else
allocate(vec(n+1))
pow=x
vec(1:n)=coeffs
do
vec(n+1)=0.0_sp
nn=ishft(n+1,-1)
vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
if (nn == 1) exit
pow=pow*pow
n=nn
end do
poly_rc=vec(1)
deallocate(vec)
end if
END FUNCTION poly_rc
!BL
FUNCTION poly_cc(x,coeffs)
COMPLEX(SPC), INTENT(IN) :: x
COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs
COMPLEX(SPC) :: poly_cc
COMPLEX(SPC) :: pow
COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec
INTEGER(I4B) :: i,n,nn
n=size(coeffs)
if (n <= 0) then
poly_cc=0.0_sp
else if (n < NPAR_POLY) then
poly_cc=coeffs(n)
do i=n-1,1,-1
poly_cc=x*poly_cc+coeffs(i)
end do
else
allocate(vec(n+1))
pow=x
vec(1:n)=coeffs
do
vec(n+1)=0.0_sp
nn=ishft(n+1,-1)
vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
if (nn == 1) exit
pow=pow*pow
n=nn
end do
poly_cc=vec(1)
deallocate(vec)
end if
END FUNCTION poly_cc
!BL
FUNCTION poly_rrv(x,coeffs)
REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x
REAL(SP), DIMENSION(size(x)) :: poly_rrv
INTEGER(I4B) :: i,n,m
m=size(coeffs)
n=size(x)
if (m <= 0) then
poly_rrv=0.0_sp
else if (m < n .or. m < NPAR_POLY) then
poly_rrv=coeffs(m)
do i=m-1,1,-1
poly_rrv=x*poly_rrv+coeffs(i)
end do
else
do i=1,n
poly_rrv(i)=poly_rr(x(i),coeffs)
end do
end if
END FUNCTION poly_rrv
!BL
FUNCTION poly_ddv(x,coeffs)
REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x
REAL(DP), DIMENSION(size(x)) :: poly_ddv
INTEGER(I4B) :: i,n,m
m=size(coeffs)
n=size(x)
if (m <= 0) then
poly_ddv=0.0_dp
else if (m < n .or. m < NPAR_POLY) then
poly_ddv=coeffs(m)
do i=m-1,1,-1
poly_ddv=x*poly_ddv+coeffs(i)
end do
else
do i=1,n
poly_ddv(i)=poly_dd(x(i),coeffs)
end do
end if
END FUNCTION poly_ddv
!BL
FUNCTION poly_msk_rrv(x,coeffs,mask)
REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv
poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp)
END FUNCTION poly_msk_rrv
!BL
FUNCTION poly_msk_ddv(x,coeffs,mask)
REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
REAL(DP), DIMENSION(size(x)) :: poly_msk_ddv
poly_msk_ddv=unpack(poly_ddv(pack(x,mask),coeffs),mask,0.0_dp)
END FUNCTION poly_msk_ddv
!BL
!BL
RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u)
REAL(SP), DIMENSION(:), INTENT(IN) :: a
REAL(SP), INTENT(IN) :: b
REAL(SP), DIMENSION(size(a)) :: u
INTEGER(I4B) :: n,j
n=size(a)
if (n <= 0) RETURN
u(1)=a(1)
if (n < NPAR_POLYTERM) then
do j=2,n
u(j)=a(j)+b*u(j-1)
end do
else
u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b)
u(3:n:2)=a(3:n:2)+b*u(2:n-1:2)
end if
END FUNCTION poly_term_rr
!BL
RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u)
COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a
COMPLEX(SPC), INTENT(IN) :: b
COMPLEX(SPC), DIMENSION(size(a)) :: u
INTEGER(I4B) :: n,j
n=size(a)
if (n <= 0) RETURN
u(1)=a(1)
if (n < NPAR_POLYTERM) then
do j=2,n
u(j)=a(j)+b*u(j-1)
end do
else
u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b)
u(3:n:2)=a(3:n:2)+b*u(2:n-1:2)
end if
END FUNCTION poly_term_cc
!BL
!BL
FUNCTION zroots_unity(n,nn)
INTEGER(I4B), INTENT(IN) :: n,nn
COMPLEX(SPC), DIMENSION(nn) :: zroots_unity
INTEGER(I4B) :: k
REAL(SP) :: theta
zroots_unity(1)=1.0
theta=TWOPI/n
k=1
do
if (k >= nn) exit
zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC)
zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*&
zroots_unity(2:min(k,nn-k))
k=2*k
end do
END FUNCTION zroots_unity
!BL
FUNCTION outerprod_r(a,b)
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r
outerprod_r = spread(a,dim=2,ncopies=size(b)) * &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerprod_r
!BL
FUNCTION outerprod_d(a,b)
REAL(DP), DIMENSION(:), INTENT(IN) :: a,b
REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d
outerprod_d = spread(a,dim=2,ncopies=size(b)) * &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerprod_d
!BL
FUNCTION outerdiv(a,b)
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv
outerdiv = spread(a,dim=2,ncopies=size(b)) / &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerdiv
!BL
FUNCTION outersum(a,b)
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(SP), DIMENSION(size(a),size(b)) :: outersum
outersum = spread(a,dim=2,ncopies=size(b)) + &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outersum
!BL
FUNCTION outerdiff_r(a,b)
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r
outerdiff_r = spread(a,dim=2,ncopies=size(b)) - &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerdiff_r
!BL
FUNCTION outerdiff_d(a,b)
REAL(DP), DIMENSION(:), INTENT(IN) :: a,b
REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d
outerdiff_d = spread(a,dim=2,ncopies=size(b)) - &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerdiff_d
!BL
FUNCTION outerdiff_i(a,b)
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b
INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i
outerdiff_i = spread(a,dim=2,ncopies=size(b)) - &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerdiff_i
!BL
FUNCTION outerand(a,b)
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b
LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand
outerand = spread(a,dim=2,ncopies=size(b)) .and. &
spread(b,dim=1,ncopies=size(a))
END FUNCTION outerand
!BL
SUBROUTINE scatter_add_r(dest,source,dest_index)
REAL(SP), DIMENSION(:), INTENT(OUT) :: dest
REAL(SP), DIMENSION(:), INTENT(IN) :: source
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
INTEGER(I4B) :: m,n,j,i
n=assert_eq2(size(source),size(dest_index),'scatter_add_r')
m=size(dest)
do j=1,n
i=dest_index(j)
if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j)
end do
END SUBROUTINE scatter_add_r
SUBROUTINE scatter_add_d(dest,source,dest_index)
REAL(DP), DIMENSION(:), INTENT(OUT) :: dest
REAL(DP), DIMENSION(:), INTENT(IN) :: source
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
INTEGER(I4B) :: m,n,j,i
n=assert_eq2(size(source),size(dest_index),'scatter_add_d')
m=size(dest)
do j=1,n
i=dest_index(j)
if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j)
end do
END SUBROUTINE scatter_add_d
SUBROUTINE scatter_max_r(dest,source,dest_index)
REAL(SP), DIMENSION(:), INTENT(OUT) :: dest
REAL(SP), DIMENSION(:), INTENT(IN) :: source
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
INTEGER(I4B) :: m,n,j,i
n=assert_eq2(size(source),size(dest_index),'scatter_max_r')
m=size(dest)
do j=1,n
i=dest_index(j)
if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j))
end do
END SUBROUTINE scatter_max_r
SUBROUTINE scatter_max_d(dest,source,dest_index)
REAL(DP), DIMENSION(:), INTENT(OUT) :: dest
REAL(DP), DIMENSION(:), INTENT(IN) :: source
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
INTEGER(I4B) :: m,n,j,i
n=assert_eq2(size(source),size(dest_index),'scatter_max_d')
m=size(dest)
do j=1,n
i=dest_index(j)
if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j))
end do
END SUBROUTINE scatter_max_d
!BL
SUBROUTINE diagadd_rv(mat,diag)
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
REAL(SP), DIMENSION(:), INTENT(IN) :: diag
INTEGER(I4B) :: j,n
n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv')
do j=1,n
mat(j,j)=mat(j,j)+diag(j)
end do
END SUBROUTINE diagadd_rv
!BL
SUBROUTINE diagadd_r(mat,diag)
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
REAL(SP), INTENT(IN) :: diag
INTEGER(I4B) :: j,n
n = min(size(mat,1),size(mat,2))
do j=1,n
mat(j,j)=mat(j,j)+diag
end do
END SUBROUTINE diagadd_r
!BL
SUBROUTINE diagmult_rv(mat,diag)
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
REAL(SP), DIMENSION(:), INTENT(IN) :: diag
INTEGER(I4B) :: j,n
n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv')
do j=1,n
mat(j,j)=mat(j,j)*diag(j)
end do
END SUBROUTINE diagmult_rv
!BL
SUBROUTINE diagmult_r(mat,diag)
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
REAL(SP), INTENT(IN) :: diag
INTEGER(I4B) :: j,n
n = min(size(mat,1),size(mat,2))
do j=1,n
mat(j,j)=mat(j,j)*diag
end do
END SUBROUTINE diagmult_r
!BL
FUNCTION get_diag_rv(mat)
REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat
REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv
INTEGER(I4B) :: j
j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv')
do j=1,size(mat,1)
get_diag_rv(j)=mat(j,j)
end do
END FUNCTION get_diag_rv
!BL
FUNCTION get_diag_dv(mat)
REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat
REAL(DP), DIMENSION(size(mat,1)) :: get_diag_dv
INTEGER(I4B) :: j
j=assert_eq2(size(mat,1),size(mat,2),'get_diag_dv')
do j=1,size(mat,1)
get_diag_dv(j)=mat(j,j)
end do
END FUNCTION get_diag_dv
!BL
SUBROUTINE put_diag_rv(diagv,mat)
REAL(SP), DIMENSION(:), INTENT(IN) :: diagv
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
INTEGER(I4B) :: j,n
n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv')
do j=1,n
mat(j,j)=diagv(j)
end do
END SUBROUTINE put_diag_rv
!BL
SUBROUTINE put_diag_r(scal,mat)
REAL(SP), INTENT(IN) :: scal
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
INTEGER(I4B) :: j,n
n = min(size(mat,1),size(mat,2))
do j=1,n
mat(j,j)=scal
end do
END SUBROUTINE put_diag_r
!BL
SUBROUTINE unit_matrix(mat)
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat
INTEGER(I4B) :: i,n
n=min(size(mat,1),size(mat,2))
mat(:,:)=0.0_sp
do i=1,n
mat(i,i)=1.0_sp
end do
END SUBROUTINE unit_matrix
!BL
FUNCTION upper_triangle(j,k,extra)
INTEGER(I4B), INTENT(IN) :: j,k
INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra
LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle
INTEGER(I4B) :: n
n=0
if (present(extra)) n=extra
upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n)
END FUNCTION upper_triangle
!BL
FUNCTION lower_triangle(j,k,extra)
INTEGER(I4B), INTENT(IN) :: j,k
INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra
LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle
INTEGER(I4B) :: n
n=0
if (present(extra)) n=extra
lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n)
END FUNCTION lower_triangle
!BL
FUNCTION vabs(v)
REAL(SP), DIMENSION(:), INTENT(IN) :: v
REAL(SP) :: vabs
vabs=sqrt(dot_product(v,v))
END FUNCTION vabs
!BL
END MODULE nrutil
MODULE ode_path
USE nrtype
INTEGER(I4B) :: nok,nbad,kount
LOGICAL(LGT), SAVE :: save_steps=.false.
REAL(SP) :: dxsav
REAL(SP), DIMENSION(:), POINTER :: xp
REAL(SP), DIMENSION(:,:), POINTER :: yp
END MODULE ode_path
MODULE hypgeo_info
USE nrtype
COMPLEX(SPC) :: hypgeo_aa,hypgeo_bb,hypgeo_cc,hypgeo_dz,hypgeo_z0
END MODULE hypgeo_info
MODULE nr
INTERFACE
SUBROUTINE airy(x,ai,bi,aip,bip)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: ai,bi,aip,bip
END SUBROUTINE airy
END INTERFACE
INTERFACE
SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr)
USE nrtype
INTEGER(I4B), INTENT(INOUT) :: iter
REAL(SP), INTENT(INOUT) :: yb
REAL(SP), INTENT(IN) :: ftol,temptr
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE amebsa
END INTERFACE
INTERFACE
SUBROUTINE amoeba(p,y,ftol,func,iter)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: iter
REAL(SP), INTENT(IN) :: ftol
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE amoeba
END INTERFACE
INTERFACE
SUBROUTINE anneal(x,y,iorder)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: iorder
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
END SUBROUTINE anneal
END INTERFACE
INTERFACE
SUBROUTINE asolve(b,x,itrnsp)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: b
REAL(DP), DIMENSION(:), INTENT(OUT) :: x
INTEGER(I4B), INTENT(IN) :: itrnsp
END SUBROUTINE asolve
END INTERFACE
INTERFACE
SUBROUTINE atimes(x,r,itrnsp)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: x
REAL(DP), DIMENSION(:), INTENT(OUT) :: r
INTEGER(I4B), INTENT(IN) :: itrnsp
END SUBROUTINE atimes
END INTERFACE
INTERFACE
SUBROUTINE avevar(data,ave,var)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data
REAL(SP), INTENT(OUT) :: ave,var
END SUBROUTINE avevar
END INTERFACE
INTERFACE
SUBROUTINE balanc(a)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
END SUBROUTINE balanc
END INTERFACE
INTERFACE
SUBROUTINE banbks(a,m1,m2,al,indx,b)
USE nrtype
INTEGER(I4B), INTENT(IN) :: m1,m2
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,al
REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
END SUBROUTINE banbks
END INTERFACE
INTERFACE
SUBROUTINE bandec(a,m1,m2,al,indx,d)
USE nrtype
INTEGER(I4B), INTENT(IN) :: m1,m2
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
REAL(SP), INTENT(OUT) :: d
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al
END SUBROUTINE bandec
END INTERFACE
INTERFACE
SUBROUTINE banmul(a,m1,m2,x,b)
USE nrtype
INTEGER(I4B), INTENT(IN) :: m1,m2
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(OUT) :: b
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
END SUBROUTINE banmul
END INTERFACE
INTERFACE
SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c)
USE nrtype
REAL(SP), INTENT(IN) :: d1,d2
REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12
REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c
END SUBROUTINE bcucof
END INTERFACE
INTERFACE
SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,&
ansy1,ansy2)
USE nrtype
REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12
REAL(SP), INTENT(IN) :: x1l,x1u,x2l,x2u,x1,x2
REAL(SP), INTENT(OUT) :: ansy,ansy1,ansy2
END SUBROUTINE bcuint
END INTERFACE
INTERFACE beschb
SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi)
USE nrtype
REAL(DP), INTENT(IN) :: x
REAL(DP), INTENT(OUT) :: gam1,gam2,gampl,gammi
END SUBROUTINE beschb_s
!BL
SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: x
REAL(DP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi
END SUBROUTINE beschb_v
END INTERFACE
INTERFACE bessi
FUNCTION bessi_s(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessi_s
END FUNCTION bessi_s
!BL
FUNCTION bessi_v(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessi_v
END FUNCTION bessi_v
END INTERFACE
INTERFACE bessi0
FUNCTION bessi0_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessi0_s
END FUNCTION bessi0_s
!BL
FUNCTION bessi0_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessi0_v
END FUNCTION bessi0_v
END INTERFACE
INTERFACE bessi1
FUNCTION bessi1_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessi1_s
END FUNCTION bessi1_s
!BL
FUNCTION bessi1_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessi1_v
END FUNCTION bessi1_v
END INTERFACE
INTERFACE
SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp)
USE nrtype
REAL(SP), INTENT(IN) :: x,xnu
REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp
END SUBROUTINE bessik
END INTERFACE
INTERFACE bessj
FUNCTION bessj_s(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessj_s
END FUNCTION bessj_s
!BL
FUNCTION bessj_v(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessj_v
END FUNCTION bessj_v
END INTERFACE
INTERFACE bessj0
FUNCTION bessj0_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessj0_s
END FUNCTION bessj0_s
!BL
FUNCTION bessj0_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessj0_v
END FUNCTION bessj0_v
END INTERFACE
INTERFACE bessj1
FUNCTION bessj1_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessj1_s
END FUNCTION bessj1_s
!BL
FUNCTION bessj1_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessj1_v
END FUNCTION bessj1_v
END INTERFACE
INTERFACE bessjy
SUBROUTINE bessjy_s(x,xnu,rj,ry,rjp,ryp)
USE nrtype
REAL(SP), INTENT(IN) :: x,xnu
REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp
END SUBROUTINE bessjy_s
!BL
SUBROUTINE bessjy_v(x,xnu,rj,ry,rjp,ryp)
USE nrtype
REAL(SP), INTENT(IN) :: xnu
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(OUT) :: rj,rjp,ry,ryp
END SUBROUTINE bessjy_v
END INTERFACE
INTERFACE bessk
FUNCTION bessk_s(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessk_s
END FUNCTION bessk_s
!BL
FUNCTION bessk_v(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessk_v
END FUNCTION bessk_v
END INTERFACE
INTERFACE bessk0
FUNCTION bessk0_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessk0_s
END FUNCTION bessk0_s
!BL
FUNCTION bessk0_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessk0_v
END FUNCTION bessk0_v
END INTERFACE
INTERFACE bessk1
FUNCTION bessk1_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessk1_s
END FUNCTION bessk1_s
!BL
FUNCTION bessk1_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessk1_v
END FUNCTION bessk1_v
END INTERFACE
INTERFACE bessy
FUNCTION bessy_s(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessy_s
END FUNCTION bessy_s
!BL
FUNCTION bessy_v(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessy_v
END FUNCTION bessy_v
END INTERFACE
INTERFACE bessy0
FUNCTION bessy0_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessy0_s
END FUNCTION bessy0_s
!BL
FUNCTION bessy0_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessy0_v
END FUNCTION bessy0_v
END INTERFACE
INTERFACE bessy1
FUNCTION bessy1_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: bessy1_s
END FUNCTION bessy1_s
!BL
FUNCTION bessy1_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: bessy1_v
END FUNCTION bessy1_v
END INTERFACE
INTERFACE beta
FUNCTION beta_s(z,w)
USE nrtype
REAL(SP), INTENT(IN) :: z,w
REAL(SP) :: beta_s
END FUNCTION beta_s
!BL
FUNCTION beta_v(z,w)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: z,w
REAL(SP), DIMENSION(size(z)) :: beta_v
END FUNCTION beta_v
END INTERFACE
INTERFACE betacf
FUNCTION betacf_s(a,b,x)
USE nrtype
REAL(SP), INTENT(IN) :: a,b,x
REAL(SP) :: betacf_s
END FUNCTION betacf_s
!BL
FUNCTION betacf_v(a,b,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x
REAL(SP), DIMENSION(size(x)) :: betacf_v
END FUNCTION betacf_v
END INTERFACE
INTERFACE betai
FUNCTION betai_s(a,b,x)
USE nrtype
REAL(SP), INTENT(IN) :: a,b,x
REAL(SP) :: betai_s
END FUNCTION betai_s
!BL
FUNCTION betai_v(a,b,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x
REAL(SP), DIMENSION(size(a)) :: betai_v
END FUNCTION betai_v
END INTERFACE
INTERFACE bico
FUNCTION bico_s(n,k)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n,k
REAL(SP) :: bico_s
END FUNCTION bico_s
!BL
FUNCTION bico_v(n,k)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k
REAL(SP), DIMENSION(size(n)) :: bico_v
END FUNCTION bico_v
END INTERFACE
INTERFACE
FUNCTION bnldev(pp,n)
USE nrtype
REAL(SP), INTENT(IN) :: pp
INTEGER(I4B), INTENT(IN) :: n
REAL(SP) :: bnldev
END FUNCTION bnldev
END INTERFACE
INTERFACE
FUNCTION brent(ax,bx,cx,func,tol,xmin)
USE nrtype
REAL(SP), INTENT(IN) :: ax,bx,cx,tol
REAL(SP), INTENT(OUT) :: xmin
REAL(SP) :: brent
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION brent
END INTERFACE
INTERFACE
SUBROUTINE broydn(x,check)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
LOGICAL(LGT), INTENT(OUT) :: check
END SUBROUTINE broydn
END INTERFACE
INTERFACE
SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE bsstep
END INTERFACE
INTERFACE
SUBROUTINE caldat(julian,mm,id,iyyy)
USE nrtype
INTEGER(I4B), INTENT(IN) :: julian
INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy
END SUBROUTINE caldat
END INTERFACE
INTERFACE
FUNCTION chder(a,b,c)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), DIMENSION(:), INTENT(IN) :: c
REAL(SP), DIMENSION(size(c)) :: chder
END FUNCTION chder
END INTERFACE
INTERFACE chebev
FUNCTION chebev_s(a,b,c,x)
USE nrtype
REAL(SP), INTENT(IN) :: a,b,x
REAL(SP), DIMENSION(:), INTENT(IN) :: c
REAL(SP) :: chebev_s
END FUNCTION chebev_s
!BL
FUNCTION chebev_v(a,b,c,x)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), DIMENSION(:), INTENT(IN) :: c,x
REAL(SP), DIMENSION(size(x)) :: chebev_v
END FUNCTION chebev_v
END INTERFACE
INTERFACE
FUNCTION chebft(a,b,n,func)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(n) :: chebft
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END FUNCTION chebft
END INTERFACE
INTERFACE
FUNCTION chebpc(c)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: c
REAL(SP), DIMENSION(size(c)) :: chebpc
END FUNCTION chebpc
END INTERFACE
INTERFACE
FUNCTION chint(a,b,c)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), DIMENSION(:), INTENT(IN) :: c
REAL(SP), DIMENSION(size(c)) :: chint
END FUNCTION chint
END INTERFACE
INTERFACE
SUBROUTINE choldc(a,p)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:), INTENT(OUT) :: p
END SUBROUTINE choldc
END INTERFACE
INTERFACE
SUBROUTINE cholsl(a,p,b,x)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
REAL(SP), DIMENSION(:), INTENT(IN) :: p,b
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
END SUBROUTINE cholsl
END INTERFACE
INTERFACE
SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob)
USE nrtype
INTEGER(I4B), INTENT(IN) :: knstrn
REAL(SP), INTENT(OUT) :: df,chsq,prob
REAL(SP), DIMENSION(:), INTENT(IN) :: bins,ebins
END SUBROUTINE chsone
END INTERFACE
INTERFACE
SUBROUTINE chstwo(bins1,bins2,knstrn,df,chsq,prob)
USE nrtype
INTEGER(I4B), INTENT(IN) :: knstrn
REAL(SP), INTENT(OUT) :: df,chsq,prob
REAL(SP), DIMENSION(:), INTENT(IN) :: bins1,bins2
END SUBROUTINE chstwo
END INTERFACE
INTERFACE
SUBROUTINE cisi(x,ci,si)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: ci,si
END SUBROUTINE cisi
END INTERFACE
INTERFACE
SUBROUTINE cntab1(nn,chisq,df,prob,cramrv,ccc)
USE nrtype
INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn
REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc
END SUBROUTINE cntab1
END INTERFACE
INTERFACE
SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy)
USE nrtype
INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn
REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy
END SUBROUTINE cntab2
END INTERFACE
INTERFACE
FUNCTION convlv(data,respns,isign)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data
REAL(SP), DIMENSION(:), INTENT(IN) :: respns
INTEGER(I4B), INTENT(IN) :: isign
REAL(SP), DIMENSION(size(data)) :: convlv
END FUNCTION convlv
END INTERFACE
INTERFACE
FUNCTION correl(data1,data2)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
REAL(SP), DIMENSION(size(data1)) :: correl
END FUNCTION correl
END INTERFACE
INTERFACE
SUBROUTINE cosft1(y)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
END SUBROUTINE cosft1
END INTERFACE
INTERFACE
SUBROUTINE cosft2(y,isign)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE cosft2
END INTERFACE
INTERFACE
SUBROUTINE covsrt(covar,maska)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
END SUBROUTINE covsrt
END INTERFACE
INTERFACE
SUBROUTINE cyclic(a,b,c,alpha,beta,r,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN):: a,b,c,r
REAL(SP), INTENT(IN) :: alpha,beta
REAL(SP), DIMENSION(:), INTENT(OUT):: x
END SUBROUTINE cyclic
END INTERFACE
INTERFACE
SUBROUTINE daub4(a,isign)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE daub4
END INTERFACE
INTERFACE dawson
FUNCTION dawson_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: dawson_s
END FUNCTION dawson_s
!BL
FUNCTION dawson_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: dawson_v
END FUNCTION dawson_v
END INTERFACE
INTERFACE
FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin)
USE nrtype
REAL(SP), INTENT(IN) :: ax,bx,cx,tol
REAL(SP), INTENT(OUT) :: xmin
REAL(SP) :: dbrent
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
!BL
FUNCTION dbrent_dfunc(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: dbrent_dfunc
END FUNCTION dbrent_dfunc
END INTERFACE
END FUNCTION dbrent
END INTERFACE
INTERFACE
SUBROUTINE ddpoly(c,x,pd)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: c
REAL(SP), DIMENSION(:), INTENT(OUT) :: pd
END SUBROUTINE ddpoly
END INTERFACE
INTERFACE
FUNCTION decchk(string,ch)
USE nrtype
CHARACTER(1), DIMENSION(:), INTENT(IN) :: string
CHARACTER(1), INTENT(OUT) :: ch
LOGICAL(LGT) :: decchk
END FUNCTION decchk
END INTERFACE
INTERFACE
SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: iter
REAL(SP), INTENT(IN) :: gtol
REAL(SP), INTENT(OUT) :: fret
REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
INTERFACE
FUNCTION func(p)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: p
REAL(SP) :: func
END FUNCTION func
!BL
FUNCTION dfunc(p)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: p
REAL(SP), DIMENSION(size(p)) :: dfunc
END FUNCTION dfunc
END INTERFACE
END SUBROUTINE dfpmin
END INTERFACE
INTERFACE
FUNCTION dfridr(func,x,h,err)
USE nrtype
REAL(SP), INTENT(IN) :: x,h
REAL(SP), INTENT(OUT) :: err
REAL(SP) :: dfridr
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION dfridr
END INTERFACE
INTERFACE
SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac)
USE nrtype
REAL(SP), INTENT(IN) :: w,delta,a,b
REAL(SP), INTENT(OUT) :: corre,corim,corfac
REAL(SP), DIMENSION(:), INTENT(IN) :: endpts
END SUBROUTINE dftcor
END INTERFACE
INTERFACE
SUBROUTINE dftint(func,a,b,w,cosint,sinint)
USE nrtype
REAL(SP), INTENT(IN) :: a,b,w
REAL(SP), INTENT(OUT) :: cosint,sinint
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE dftint
END INTERFACE
INTERFACE
SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,s,y)
USE nrtype
INTEGER(I4B), INTENT(IN) :: is1,isf,jsf,k,k1,k2
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: s
REAL(SP), DIMENSION(:,:), INTENT(IN) :: y
END SUBROUTINE difeq
END INTERFACE
INTERFACE
FUNCTION eclass(lista,listb,n)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: lista,listb
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B), DIMENSION(n) :: eclass
END FUNCTION eclass
END INTERFACE
INTERFACE
FUNCTION eclazz(equiv,n)
USE nrtype
INTERFACE
FUNCTION equiv(i,j)
USE nrtype
LOGICAL(LGT) :: equiv
INTEGER(I4B), INTENT(IN) :: i,j
END FUNCTION equiv
END INTERFACE
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B), DIMENSION(n) :: eclazz
END FUNCTION eclazz
END INTERFACE
INTERFACE
FUNCTION ei(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: ei
END FUNCTION ei
END INTERFACE
INTERFACE
SUBROUTINE eigsrt(d,v)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: d
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: v
END SUBROUTINE eigsrt
END INTERFACE
INTERFACE elle
FUNCTION elle_s(phi,ak)
USE nrtype
REAL(SP), INTENT(IN) :: phi,ak
REAL(SP) :: elle_s
END FUNCTION elle_s
!BL
FUNCTION elle_v(phi,ak)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak
REAL(SP), DIMENSION(size(phi)) :: elle_v
END FUNCTION elle_v
END INTERFACE
INTERFACE ellf
FUNCTION ellf_s(phi,ak)
USE nrtype
REAL(SP), INTENT(IN) :: phi,ak
REAL(SP) :: ellf_s
END FUNCTION ellf_s
!BL
FUNCTION ellf_v(phi,ak)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak
REAL(SP), DIMENSION(size(phi)) :: ellf_v
END FUNCTION ellf_v
END INTERFACE
INTERFACE ellpi
FUNCTION ellpi_s(phi,en,ak)
USE nrtype
REAL(SP), INTENT(IN) :: phi,en,ak
REAL(SP) :: ellpi_s
END FUNCTION ellpi_s
!BL
FUNCTION ellpi_v(phi,en,ak)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: phi,en,ak
REAL(SP), DIMENSION(size(phi)) :: ellpi_v
END FUNCTION ellpi_v
END INTERFACE
INTERFACE
SUBROUTINE elmhes(a)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
END SUBROUTINE elmhes
END INTERFACE
INTERFACE erf
FUNCTION erf_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: erf_s
END FUNCTION erf_s
!BL
FUNCTION erf_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: erf_v
END FUNCTION erf_v
END INTERFACE
INTERFACE erfc
FUNCTION erfc_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: erfc_s
END FUNCTION erfc_s
!BL
FUNCTION erfc_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: erfc_v
END FUNCTION erfc_v
END INTERFACE
INTERFACE erfcc
FUNCTION erfcc_s(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: erfcc_s
END FUNCTION erfcc_s
!BL
FUNCTION erfcc_v(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: erfcc_v
END FUNCTION erfcc_v
END INTERFACE
INTERFACE
SUBROUTINE eulsum(sum,term,jterm)
USE nrtype
REAL(SP), INTENT(INOUT) :: sum
REAL(SP), INTENT(IN) :: term
INTEGER(I4B), INTENT(IN) :: jterm
END SUBROUTINE eulsum
END INTERFACE
INTERFACE
FUNCTION evlmem(fdt,d,xms)
USE nrtype
REAL(SP), INTENT(IN) :: fdt,xms
REAL(SP), DIMENSION(:), INTENT(IN) :: d
REAL(SP) :: evlmem
END FUNCTION evlmem
END INTERFACE
INTERFACE expdev
SUBROUTINE expdev_s(harvest)
USE nrtype
REAL(SP), INTENT(OUT) :: harvest
END SUBROUTINE expdev_s
!BL
SUBROUTINE expdev_v(harvest)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
END SUBROUTINE expdev_v
END INTERFACE
INTERFACE
FUNCTION expint(n,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: x
REAL(SP) :: expint
END FUNCTION expint
END INTERFACE
INTERFACE factln
FUNCTION factln_s(n)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP) :: factln_s
END FUNCTION factln_s
!BL
FUNCTION factln_v(n)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n
REAL(SP), DIMENSION(size(n)) :: factln_v
END FUNCTION factln_v
END INTERFACE
INTERFACE factrl
FUNCTION factrl_s(n)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP) :: factrl_s
END FUNCTION factrl_s
!BL
FUNCTION factrl_v(n)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n
REAL(SP), DIMENSION(size(n)) :: factrl_v
END FUNCTION factrl_v
END INTERFACE
INTERFACE
SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), INTENT(IN) :: ofac,hifac
INTEGER(I4B), INTENT(OUT) :: jmax
REAL(SP), INTENT(OUT) :: prob
REAL(SP), DIMENSION(:), POINTER :: px,py
END SUBROUTINE fasper
END INTERFACE
INTERFACE
SUBROUTINE fdjac(x,fvec,df)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: fvec
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df
END SUBROUTINE fdjac
END INTERFACE
INTERFACE
SUBROUTINE fgauss(x,a,y,dyda)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
REAL(SP), DIMENSION(:), INTENT(OUT) :: y
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
END SUBROUTINE fgauss
END INTERFACE
INTERFACE
SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q
REAL(SP), DIMENSION(:), OPTIONAL, INTENT(IN) :: sig
END SUBROUTINE fit
END INTERFACE
INTERFACE
SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sigx,sigy
REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q
END SUBROUTINE fitexy
END INTERFACE
INTERFACE
SUBROUTINE fixrts(d)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: d
END SUBROUTINE fixrts
END INTERFACE
INTERFACE
FUNCTION fleg(x,n)
USE nrtype
REAL(SP), INTENT(IN) :: x
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(n) :: fleg
END FUNCTION fleg
END INTERFACE
INTERFACE
SUBROUTINE flmoon(n,nph,jd,frac)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n,nph
INTEGER(I4B), INTENT(OUT) :: jd
REAL(SP), INTENT(OUT) :: frac
END SUBROUTINE flmoon
END INTERFACE
INTERFACE four1
SUBROUTINE four1_dp(data,isign)
USE nrtype
COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE four1_dp
!BL
SUBROUTINE four1_sp(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE four1_sp
END INTERFACE
INTERFACE
SUBROUTINE four1_alt(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE four1_alt
END INTERFACE
INTERFACE
SUBROUTINE four1_gather(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE four1_gather
END INTERFACE
INTERFACE
SUBROUTINE four2(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
INTEGER(I4B),INTENT(IN) :: isign
END SUBROUTINE four2
END INTERFACE
INTERFACE
SUBROUTINE four2_alt(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE four2_alt
END INTERFACE
INTERFACE
SUBROUTINE four3(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
INTEGER(I4B),INTENT(IN) :: isign
END SUBROUTINE four3
END INTERFACE
INTERFACE
SUBROUTINE four3_alt(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE four3_alt
END INTERFACE
INTERFACE
SUBROUTINE fourcol(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE fourcol
END INTERFACE
INTERFACE
SUBROUTINE fourcol_3d(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE fourcol_3d
END INTERFACE
INTERFACE
SUBROUTINE fourn_gather(data,nn,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE fourn_gather
END INTERFACE
INTERFACE fourrow
SUBROUTINE fourrow_dp(data,isign)
USE nrtype
COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE fourrow_dp
!BL
SUBROUTINE fourrow_sp(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE fourrow_sp
END INTERFACE
INTERFACE
SUBROUTINE fourrow_3d(data,isign)
USE nrtype
COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE fourrow_3d
END INTERFACE
INTERFACE
FUNCTION fpoly(x,n)
USE nrtype
REAL(SP), INTENT(IN) :: x
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(n) :: fpoly
END FUNCTION fpoly
END INTERFACE
INTERFACE
SUBROUTINE fred2(a,b,t,f,w,g,ak)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w
INTERFACE
FUNCTION g(t)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: t
REAL(SP), DIMENSION(size(t)) :: g
END FUNCTION g
!BL
FUNCTION ak(t,s)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: t,s
REAL(SP), DIMENSION(size(t),size(s)) :: ak
END FUNCTION ak
END INTERFACE
END SUBROUTINE fred2
END INTERFACE
INTERFACE
FUNCTION fredin(x,a,b,t,f,w,g,ak)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), DIMENSION(:), INTENT(IN) :: x,t,f,w
REAL(SP), DIMENSION(size(x)) :: fredin
INTERFACE
FUNCTION g(t)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: t
REAL(SP), DIMENSION(size(t)) :: g
END FUNCTION g
!BL
FUNCTION ak(t,s)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: t,s
REAL(SP), DIMENSION(size(t),size(s)) :: ak
END FUNCTION ak
END INTERFACE
END FUNCTION fredin
END INTERFACE
INTERFACE
SUBROUTINE frenel(x,s,c)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: s,c
END SUBROUTINE frenel
END INTERFACE
INTERFACE
SUBROUTINE frprmn(p,ftol,iter,fret)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: iter
REAL(SP), INTENT(IN) :: ftol
REAL(SP), INTENT(OUT) :: fret
REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
END SUBROUTINE frprmn
END INTERFACE
INTERFACE
SUBROUTINE ftest(data1,data2,f,prob)
USE nrtype
REAL(SP), INTENT(OUT) :: f,prob
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
END SUBROUTINE ftest
END INTERFACE
INTERFACE
FUNCTION gamdev(ia)
USE nrtype
INTEGER(I4B), INTENT(IN) :: ia
REAL(SP) :: gamdev
END FUNCTION gamdev
END INTERFACE
INTERFACE gammln
FUNCTION gammln_s(xx)
USE nrtype
REAL(SP), INTENT(IN) :: xx
REAL(SP) :: gammln_s
END FUNCTION gammln_s
!BL
FUNCTION gammln_v(xx)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xx
REAL(SP), DIMENSION(size(xx)) :: gammln_v
END FUNCTION gammln_v
END INTERFACE
INTERFACE gammp
FUNCTION gammp_s(a,x)
USE nrtype
REAL(SP), INTENT(IN) :: a,x
REAL(SP) :: gammp_s
END FUNCTION gammp_s
!BL
FUNCTION gammp_v(a,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
REAL(SP), DIMENSION(size(a)) :: gammp_v
END FUNCTION gammp_v
END INTERFACE
INTERFACE gammq
FUNCTION gammq_s(a,x)
USE nrtype
REAL(SP), INTENT(IN) :: a,x
REAL(SP) :: gammq_s
END FUNCTION gammq_s
!BL
FUNCTION gammq_v(a,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
REAL(SP), DIMENSION(size(a)) :: gammq_v
END FUNCTION gammq_v
END INTERFACE
INTERFACE gasdev
SUBROUTINE gasdev_s(harvest)
USE nrtype
REAL(SP), INTENT(OUT) :: harvest
END SUBROUTINE gasdev_s
!BL
SUBROUTINE gasdev_v(harvest)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
END SUBROUTINE gasdev_v
END INTERFACE
INTERFACE
SUBROUTINE gaucof(a,b,amu0,x,w)
USE nrtype
REAL(SP), INTENT(IN) :: amu0
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b
REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
END SUBROUTINE gaucof
END INTERFACE
INTERFACE
SUBROUTINE gauher(x,w)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
END SUBROUTINE gauher
END INTERFACE
INTERFACE
SUBROUTINE gaujac(x,w,alf,bet)
USE nrtype
REAL(SP), INTENT(IN) :: alf,bet
REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
END SUBROUTINE gaujac
END INTERFACE
INTERFACE
SUBROUTINE gaulag(x,w,alf)
USE nrtype
REAL(SP), INTENT(IN) :: alf
REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
END SUBROUTINE gaulag
END INTERFACE
INTERFACE
SUBROUTINE gauleg(x1,x2,x,w)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2
REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
END SUBROUTINE gauleg
END INTERFACE
INTERFACE
SUBROUTINE gaussj(a,b)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b
END SUBROUTINE gaussj
END INTERFACE
INTERFACE gcf
FUNCTION gcf_s(a,x,gln)
USE nrtype
REAL(SP), INTENT(IN) :: a,x
REAL(SP), OPTIONAL, INTENT(OUT) :: gln
REAL(SP) :: gcf_s
END FUNCTION gcf_s
!BL
FUNCTION gcf_v(a,x,gln)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
REAL(SP), DIMENSION(size(a)) :: gcf_v
END FUNCTION gcf_v
END INTERFACE
INTERFACE
FUNCTION golden(ax,bx,cx,func,tol,xmin)
USE nrtype
REAL(SP), INTENT(IN) :: ax,bx,cx,tol
REAL(SP), INTENT(OUT) :: xmin
REAL(SP) :: golden
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION golden
END INTERFACE
INTERFACE gser
FUNCTION gser_s(a,x,gln)
USE nrtype
REAL(SP), INTENT(IN) :: a,x
REAL(SP), OPTIONAL, INTENT(OUT) :: gln
REAL(SP) :: gser_s
END FUNCTION gser_s
!BL
FUNCTION gser_v(a,x,gln)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
REAL(SP), DIMENSION(size(a)) :: gser_v
END FUNCTION gser_v
END INTERFACE
INTERFACE
SUBROUTINE hqr(a,wr,wi)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: wr,wi
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
END SUBROUTINE hqr
END INTERFACE
INTERFACE
SUBROUTINE hunt(xx,x,jlo)
USE nrtype
INTEGER(I4B), INTENT(INOUT) :: jlo
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: xx
END SUBROUTINE hunt
END INTERFACE
INTERFACE
SUBROUTINE hypdrv(s,ry,rdyds)
USE nrtype
REAL(SP), INTENT(IN) :: s
REAL(SP), DIMENSION(:), INTENT(IN) :: ry
REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds
END SUBROUTINE hypdrv
END INTERFACE
INTERFACE
FUNCTION hypgeo(a,b,c,z)
USE nrtype
COMPLEX(SPC), INTENT(IN) :: a,b,c,z
COMPLEX(SPC) :: hypgeo
END FUNCTION hypgeo
END INTERFACE
INTERFACE
SUBROUTINE hypser(a,b,c,z,series,deriv)
USE nrtype
COMPLEX(SPC), INTENT(IN) :: a,b,c,z
COMPLEX(SPC), INTENT(OUT) :: series,deriv
END SUBROUTINE hypser
END INTERFACE
INTERFACE
FUNCTION icrc(crc,buf,jinit,jrev)
USE nrtype
CHARACTER(1), DIMENSION(:), INTENT(IN) :: buf
INTEGER(I2B), INTENT(IN) :: crc,jinit
INTEGER(I4B), INTENT(IN) :: jrev
INTEGER(I2B) :: icrc
END FUNCTION icrc
END INTERFACE
INTERFACE
FUNCTION igray(n,is)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n,is
INTEGER(I4B) :: igray
END FUNCTION igray
END INTERFACE
INTERFACE
RECURSIVE SUBROUTINE index_bypack(arr,index,partial)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: index
INTEGER, OPTIONAL, INTENT(IN) :: partial
END SUBROUTINE index_bypack
END INTERFACE
INTERFACE indexx
SUBROUTINE indexx_sp(arr,index)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index
END SUBROUTINE indexx_sp
SUBROUTINE indexx_i4b(iarr,index)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index
END SUBROUTINE indexx_i4b
END INTERFACE
INTERFACE
FUNCTION interp(uc)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: uc
REAL(DP), DIMENSION(2*size(uc,1)-1,2*size(uc,1)-1) :: interp
END FUNCTION interp
END INTERFACE
INTERFACE
FUNCTION rank(indx)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
INTEGER(I4B), DIMENSION(size(indx)) :: rank
END FUNCTION rank
END INTERFACE
INTERFACE
FUNCTION irbit1(iseed)
USE nrtype
INTEGER(I4B), INTENT(INOUT) :: iseed
INTEGER(I4B) :: irbit1
END FUNCTION irbit1
END INTERFACE
INTERFACE
FUNCTION irbit2(iseed)
USE nrtype
INTEGER(I4B), INTENT(INOUT) :: iseed
INTEGER(I4B) :: irbit2
END FUNCTION irbit2
END INTERFACE
INTERFACE
SUBROUTINE jacobi(a,d,v,nrot)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: nrot
REAL(SP), DIMENSION(:), INTENT(OUT) :: d
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
END SUBROUTINE jacobi
END INTERFACE
INTERFACE
SUBROUTINE jacobn(x,y,dfdx,dfdy)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dfdx
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dfdy
END SUBROUTINE jacobn
END INTERFACE
INTERFACE
FUNCTION julday(mm,id,iyyy)
USE nrtype
INTEGER(I4B), INTENT(IN) :: mm,id,iyyy
INTEGER(I4B) :: julday
END FUNCTION julday
END INTERFACE
INTERFACE
SUBROUTINE kendl1(data1,data2,tau,z,prob)
USE nrtype
REAL(SP), INTENT(OUT) :: tau,z,prob
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
END SUBROUTINE kendl1
END INTERFACE
INTERFACE
SUBROUTINE kendl2(tab,tau,z,prob)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: tab
REAL(SP), INTENT(OUT) :: tau,z,prob
END SUBROUTINE kendl2
END INTERFACE
INTERFACE
FUNCTION kermom(y,m)
USE nrtype
REAL(DP), INTENT(IN) :: y
INTEGER(I4B), INTENT(IN) :: m
REAL(DP), DIMENSION(m) :: kermom
END FUNCTION kermom
END INTERFACE
INTERFACE
SUBROUTINE ks2d1s(x1,y1,quadvl,d1,prob)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1
REAL(SP), INTENT(OUT) :: d1,prob
INTERFACE
SUBROUTINE quadvl(x,y,fa,fb,fc,fd)
USE nrtype
REAL(SP), INTENT(IN) :: x,y
REAL(SP), INTENT(OUT) :: fa,fb,fc,fd
END SUBROUTINE quadvl
END INTERFACE
END SUBROUTINE ks2d1s
END INTERFACE
INTERFACE
SUBROUTINE ks2d2s(x1,y1,x2,y2,d,prob)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1,x2,y2
REAL(SP), INTENT(OUT) :: d,prob
END SUBROUTINE ks2d2s
END INTERFACE
INTERFACE
SUBROUTINE ksone(data,func,d,prob)
USE nrtype
REAL(SP), INTENT(OUT) :: d,prob
REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE ksone
END INTERFACE
INTERFACE
SUBROUTINE kstwo(data1,data2,d,prob)
USE nrtype
REAL(SP), INTENT(OUT) :: d,prob
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
END SUBROUTINE kstwo
END INTERFACE
INTERFACE
SUBROUTINE laguer(a,x,its)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: its
COMPLEX(SPC), INTENT(INOUT) :: x
COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a
END SUBROUTINE laguer
END INTERFACE
INTERFACE
SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar
REAL(SP), INTENT(OUT) :: chisq
INTERFACE
SUBROUTINE funcs(x,arr)
USE nrtype
REAL(SP),INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(OUT) :: arr
END SUBROUTINE funcs
END INTERFACE
END SUBROUTINE lfit
END INTERFACE
INTERFACE
SUBROUTINE linbcg(b,x,itol,tol,itmax,iter,err)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: b
REAL(DP), DIMENSION(:), INTENT(INOUT) :: x
INTEGER(I4B), INTENT(IN) :: itol,itmax
REAL(DP), INTENT(IN) :: tol
INTEGER(I4B), INTENT(OUT) :: iter
REAL(DP), INTENT(OUT) :: err
END SUBROUTINE linbcg
END INTERFACE
INTERFACE
SUBROUTINE linmin(p,xi,fret)
USE nrtype
REAL(SP), INTENT(OUT) :: fret
REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi
END SUBROUTINE linmin
END INTERFACE
INTERFACE
SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g
REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
REAL(SP), INTENT(IN) :: fold,stpmax
REAL(SP), DIMENSION(:), INTENT(OUT) :: x
REAL(SP), INTENT(OUT) :: f
LOGICAL(LGT), INTENT(OUT) :: check
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP) :: func
REAL(SP), DIMENSION(:), INTENT(IN) :: x
END FUNCTION func
END INTERFACE
END SUBROUTINE lnsrch
END INTERFACE
INTERFACE
FUNCTION locatenr(xx,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xx
REAL(SP), INTENT(IN) :: x
INTEGER(I4B) :: locatenr
END FUNCTION locatenr
END INTERFACE
INTERFACE
FUNCTION lop(u)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: u
REAL(DP), DIMENSION(size(u,1),size(u,1)) :: lop
END FUNCTION lop
END INTERFACE
INTERFACE
SUBROUTINE lubksb(a,indx,b)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
END SUBROUTINE lubksb
END INTERFACE
INTERFACE
SUBROUTINE ludcmp(a,indx,d)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
REAL(SP), INTENT(OUT) :: d
END SUBROUTINE ludcmp
END INTERFACE
INTERFACE
SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,&
maxexp,eps,epsneg,xmin,xmax)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,irnd,it,machep,maxexp,&
minexp,negep,ngrd
REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin
END SUBROUTINE machar
END INTERFACE
INTERFACE
SUBROUTINE medfit(x,y,a,b,abdev)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), INTENT(OUT) :: a,b,abdev
END SUBROUTINE medfit
END INTERFACE
INTERFACE
SUBROUTINE memcof(data,xms,d)
USE nrtype
REAL(SP), INTENT(OUT) :: xms
REAL(SP), DIMENSION(:), INTENT(IN) :: data
REAL(SP), DIMENSION(:), INTENT(OUT) :: d
END SUBROUTINE memcof
END INTERFACE
INTERFACE
SUBROUTINE mgfas(u,maxcyc)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u
INTEGER(I4B), INTENT(IN) :: maxcyc
END SUBROUTINE mgfas
END INTERFACE
INTERFACE
SUBROUTINE mglin(u,ncycle)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u
INTEGER(I4B), INTENT(IN) :: ncycle
END SUBROUTINE mglin
END INTERFACE
INTERFACE
SUBROUTINE midexp(funk,aa,bb,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: aa,bb
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION funk(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: funk
END FUNCTION funk
END INTERFACE
END SUBROUTINE midexp
END INTERFACE
INTERFACE
SUBROUTINE midinf(funk,aa,bb,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: aa,bb
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION funk(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: funk
END FUNCTION funk
END INTERFACE
END SUBROUTINE midinf
END INTERFACE
INTERFACE
SUBROUTINE midpnt(func,a,b,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE midpnt
END INTERFACE
INTERFACE
SUBROUTINE midsql(funk,aa,bb,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: aa,bb
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION funk(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: funk
END FUNCTION funk
END INTERFACE
END SUBROUTINE midsql
END INTERFACE
INTERFACE
SUBROUTINE midsqu(funk,aa,bb,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: aa,bb
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION funk(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: funk
END FUNCTION funk
END INTERFACE
END SUBROUTINE midsqu
END INTERFACE
INTERFACE
RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var)
USE nrtype
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP) :: func
REAL(SP), DIMENSION(:), INTENT(IN) :: x
END FUNCTION func
END INTERFACE
REAL(SP), DIMENSION(:), INTENT(IN) :: regn
INTEGER(I4B), INTENT(IN) :: ndim,npts
REAL(SP), INTENT(IN) :: dith
REAL(SP), INTENT(OUT) :: ave,var
END SUBROUTINE miser
END INTERFACE
INTERFACE
SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs)
USE nrtype
INTEGER(I4B), INTENT(IN) :: nstep
REAL(SP), INTENT(IN) :: xs,htot
REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE mmid
END INTERFACE
INTERFACE
SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func)
USE nrtype
REAL(SP), INTENT(INOUT) :: ax,bx
REAL(SP), INTENT(OUT) :: cx,fa,fb,fc
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE mnbrak
END INTERFACE
INTERFACE
SUBROUTINE mnewt(ntrial,x,tolx,tolf,usrfun)
USE nrtype
INTEGER(I4B), INTENT(IN) :: ntrial
REAL(SP), INTENT(IN) :: tolx,tolf
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
INTERFACE
SUBROUTINE usrfun(x,fvec,fjac)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: fjac
END SUBROUTINE usrfun
END INTERFACE
END SUBROUTINE mnewt
END INTERFACE
INTERFACE
SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt)
USE nrtype
REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt
REAL(SP), DIMENSION(:), INTENT(IN) :: data
END SUBROUTINE moment
END INTERFACE
INTERFACE
SUBROUTINE mp2dfr(a,s,n,m)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B), INTENT(OUT) :: m
CHARACTER(1), DIMENSION(:), INTENT(INOUT) :: a
CHARACTER(1), DIMENSION(:), INTENT(OUT) :: s
END SUBROUTINE mp2dfr
END INTERFACE
INTERFACE
SUBROUTINE mpdiv(q,r,u,v,n,m)
USE nrtype
CHARACTER(1), DIMENSION(:), INTENT(OUT) :: q,r
CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v
INTEGER(I4B), INTENT(IN) :: n,m
END SUBROUTINE mpdiv
END INTERFACE
INTERFACE
SUBROUTINE mpinv(u,v,n,m)
USE nrtype
CHARACTER(1), DIMENSION(:), INTENT(OUT) :: u
CHARACTER(1), DIMENSION(:), INTENT(IN) :: v
INTEGER(I4B), INTENT(IN) :: n,m
END SUBROUTINE mpinv
END INTERFACE
INTERFACE
SUBROUTINE mpmul(w,u,v,n,m)
USE nrtype
CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v
CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w
INTEGER(I4B), INTENT(IN) :: n,m
END SUBROUTINE mpmul
END INTERFACE
INTERFACE
SUBROUTINE mppi(n)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
END SUBROUTINE mppi
END INTERFACE
INTERFACE
SUBROUTINE mprove(a,alud,indx,b,x)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,alud
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
REAL(SP), DIMENSION(:), INTENT(IN) :: b
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
END SUBROUTINE mprove
END INTERFACE
INTERFACE
SUBROUTINE mpsqrt(w,u,v,n,m)
USE nrtype
CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w,u
CHARACTER(1), DIMENSION(:), INTENT(IN) :: v
INTEGER(I4B), INTENT(IN) :: n,m
END SUBROUTINE mpsqrt
END INTERFACE
INTERFACE
SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,chisq,funcs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig
REAL(SP), DIMENSION(:), INTENT(OUT) :: beta
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha
REAL(SP), INTENT(OUT) :: chisq
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
INTERFACE
SUBROUTINE funcs(x,a,yfit,dyda)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
END SUBROUTINE funcs
END INTERFACE
END SUBROUTINE mrqcof
END INTERFACE
INTERFACE
SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha
REAL(SP), INTENT(OUT) :: chisq
REAL(SP), INTENT(INOUT) :: alamda
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
INTERFACE
SUBROUTINE funcs(x,a,yfit,dyda)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
END SUBROUTINE funcs
END INTERFACE
END SUBROUTINE mrqmin
END INTERFACE
INTERFACE
SUBROUTINE newt(x,check)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
LOGICAL(LGT), INTENT(OUT) :: check
END SUBROUTINE newt
END INTERFACE
INTERFACE
SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart
REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
!BL
SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE rkqs
END INTERFACE
END SUBROUTINE odeint
END INTERFACE
INTERFACE
SUBROUTINE orthog(anu,alpha,beta,a,b)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: anu,alpha,beta
REAL(SP), DIMENSION(:), INTENT(OUT) :: a,b
END SUBROUTINE orthog
END INTERFACE
INTERFACE
SUBROUTINE pade(cof,resid)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(INOUT) :: cof
REAL(SP), INTENT(OUT) :: resid
END SUBROUTINE pade
END INTERFACE
INTERFACE
FUNCTION pccheb(d)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: d
REAL(SP), DIMENSION(size(d)) :: pccheb
END FUNCTION pccheb
END INTERFACE
INTERFACE
SUBROUTINE pcshft(a,b,d)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), DIMENSION(:), INTENT(INOUT) :: d
END SUBROUTINE pcshft
END INTERFACE
INTERFACE
SUBROUTINE pearsn(x,y,r,prob,z)
USE nrtype
REAL(SP), INTENT(OUT) :: r,prob,z
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
END SUBROUTINE pearsn
END INTERFACE
INTERFACE
SUBROUTINE period(x,y,ofac,hifac,px,py,jmax,prob)
USE nrtype
INTEGER(I4B), INTENT(OUT) :: jmax
REAL(SP), INTENT(IN) :: ofac,hifac
REAL(SP), INTENT(OUT) :: prob
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), DIMENSION(:), POINTER :: px,py
END SUBROUTINE period
END INTERFACE
INTERFACE plgndr
FUNCTION plgndr_s(l,m,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: l,m
REAL(SP), INTENT(IN) :: x
REAL(SP) :: plgndr_s
END FUNCTION plgndr_s
!BL
FUNCTION plgndr_v(l,m,x)
USE nrtype
INTEGER(I4B), INTENT(IN) :: l,m
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: plgndr_v
END FUNCTION plgndr_v
END INTERFACE
INTERFACE
FUNCTION poidev(xm)
USE nrtype
REAL(SP), INTENT(IN) :: xm
REAL(SP) :: poidev
END FUNCTION poidev
END INTERFACE
INTERFACE
FUNCTION polcoe(x,y)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), DIMENSION(size(x)) :: polcoe
END FUNCTION polcoe
END INTERFACE
INTERFACE
FUNCTION polcof(xa,ya)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
REAL(SP), DIMENSION(size(xa)) :: polcof
END FUNCTION polcof
END INTERFACE
INTERFACE
SUBROUTINE poldiv(u,v,q,r)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: u,v
REAL(SP), DIMENSION(:), INTENT(OUT) :: q,r
END SUBROUTINE poldiv
END INTERFACE
INTERFACE
SUBROUTINE polin2(x1a,x2a,ya,x1,x2,y,dy)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a
REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya
REAL(SP), INTENT(IN) :: x1,x2
REAL(SP), INTENT(OUT) :: y,dy
END SUBROUTINE polin2
END INTERFACE
INTERFACE
SUBROUTINE polint(xa,ya,x,y,dy)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: y,dy
END SUBROUTINE polint
END INTERFACE
INTERFACE
SUBROUTINE powell(p,xi,ftol,iter,fret)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: xi
INTEGER(I4B), INTENT(OUT) :: iter
REAL(SP), INTENT(IN) :: ftol
REAL(SP), INTENT(OUT) :: fret
END SUBROUTINE powell
END INTERFACE
INTERFACE
FUNCTION predic(data,d,nfut)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data,d
INTEGER(I4B), INTENT(IN) :: nfut
REAL(SP), DIMENSION(nfut) :: predic
END FUNCTION predic
END INTERFACE
INTERFACE
FUNCTION probks(alam)
USE nrtype
REAL(SP), INTENT(IN) :: alam
REAL(SP) :: probks
END FUNCTION probks
END INTERFACE
INTERFACE psdes
SUBROUTINE psdes_s(lword,rword)
USE nrtype
INTEGER(I4B), INTENT(INOUT) :: lword,rword
END SUBROUTINE psdes_s
!BL
SUBROUTINE psdes_v(lword,rword)
USE nrtype
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: lword,rword
END SUBROUTINE psdes_v
END INTERFACE
INTERFACE
SUBROUTINE pwt(a,isign)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE pwt
END INTERFACE
INTERFACE
SUBROUTINE pwtset(n)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
END SUBROUTINE pwtset
END INTERFACE
INTERFACE pythag
FUNCTION pythag_dp(a,b)
USE nrtype
REAL(DP), INTENT(IN) :: a,b
REAL(DP) :: pythag_dp
END FUNCTION pythag_dp
!BL
FUNCTION pythag_sp(a,b)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: pythag_sp
END FUNCTION pythag_sp
END INTERFACE
INTERFACE
SUBROUTINE pzextr(iest,xest,yest,yz,dy)
USE nrtype
INTEGER(I4B), INTENT(IN) :: iest
REAL(SP), INTENT(IN) :: xest
REAL(SP), DIMENSION(:), INTENT(IN) :: yest
REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy
END SUBROUTINE pzextr
END INTERFACE
!!! FB:
! INTERFACE
! FUNCTION qgaus(func,a,b)
! USE nrtype
! REAL(SP), INTENT(IN) :: a,b
! REAL(SP) :: qgaus
! INTERFACE
! FUNCTION func(x)
! USE nrtype
! REAL(SP), DIMENSION(:), INTENT(IN) :: x
! REAL(SP), DIMENSION(size(x)) :: func
! END FUNCTION func
! END INTERFACE
! END FUNCTION qgaus
! END INTERFACE
!!! /FB
INTERFACE
SUBROUTINE qrdcmp(a,c,d,sing)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:), INTENT(OUT) :: c,d
LOGICAL(LGT), INTENT(OUT) :: sing
END SUBROUTINE qrdcmp
END INTERFACE
INTERFACE
FUNCTION qromb(func,a,b)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: qromb
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END FUNCTION qromb
END INTERFACE
INTERFACE
FUNCTION qromo(func,a,b,choose)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: qromo
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
INTERFACE
SUBROUTINE choose(funk,aa,bb,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: aa,bb
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION funk(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: funk
END FUNCTION funk
END INTERFACE
END SUBROUTINE choose
END INTERFACE
END FUNCTION qromo
END INTERFACE
INTERFACE
SUBROUTINE qroot(p,b,c,eps)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: p
REAL(SP), INTENT(INOUT) :: b,c
REAL(SP), INTENT(IN) :: eps
END SUBROUTINE qroot
END INTERFACE
INTERFACE
SUBROUTINE qrsolv(a,c,d,b)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
REAL(SP), DIMENSION(:), INTENT(IN) :: c,d
REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
END SUBROUTINE qrsolv
END INTERFACE
INTERFACE
SUBROUTINE qrupdt(r,qt,u,v)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: r,qt
REAL(SP), DIMENSION(:), INTENT(INOUT) :: u
REAL(SP), DIMENSION(:), INTENT(IN) :: v
END SUBROUTINE qrupdt
END INTERFACE
INTERFACE
FUNCTION qsimp(func,a,b)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: qsimp
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END FUNCTION qsimp
END INTERFACE
INTERFACE
FUNCTION qtrap(func,a,b)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP) :: qtrap
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END FUNCTION qtrap
END INTERFACE
INTERFACE
SUBROUTINE quadct(x,y,xx,yy,fa,fb,fc,fd)
USE nrtype
REAL(SP), INTENT(IN) :: x,y
REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy
REAL(SP), INTENT(OUT) :: fa,fb,fc,fd
END SUBROUTINE quadct
END INTERFACE
INTERFACE
SUBROUTINE quadmx(a)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: a
END SUBROUTINE quadmx
END INTERFACE
INTERFACE
SUBROUTINE quadvl(x,y,fa,fb,fc,fd)
USE nrtype
REAL(SP), INTENT(IN) :: x,y
REAL(SP), INTENT(OUT) :: fa,fb,fc,fd
END SUBROUTINE quadvl
END INTERFACE
INTERFACE
FUNCTION ran(idum)
INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum
REAL :: ran
END FUNCTION ran
END INTERFACE
INTERFACE ran0
SUBROUTINE ran0_s(harvest)
USE nrtype
REAL(SP), INTENT(OUT) :: harvest
END SUBROUTINE ran0_s
!BL
SUBROUTINE ran0_v(harvest)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
END SUBROUTINE ran0_v
END INTERFACE
INTERFACE ran1
SUBROUTINE ran1_s(harvest)
USE nrtype
REAL(SP), INTENT(OUT) :: harvest
END SUBROUTINE ran1_s
!BL
SUBROUTINE ran1_v(harvest)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
END SUBROUTINE ran1_v
END INTERFACE
INTERFACE ran2
SUBROUTINE ran2_s(harvest)
USE nrtype
REAL(SP), INTENT(OUT) :: harvest
END SUBROUTINE ran2_s
!BL
SUBROUTINE ran2_v(harvest)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
END SUBROUTINE ran2_v
END INTERFACE
INTERFACE ran3
SUBROUTINE ran3_s(harvest)
USE nrtype
REAL(SP), INTENT(OUT) :: harvest
END SUBROUTINE ran3_s
!BL
SUBROUTINE ran3_v(harvest)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
END SUBROUTINE ran3_v
END INTERFACE
INTERFACE
SUBROUTINE ratint(xa,ya,x,y,dy)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: y,dy
END SUBROUTINE ratint
END INTERFACE
INTERFACE
SUBROUTINE ratlsq(func,a,b,mm,kk,cof,dev)
USE nrtype
REAL(DP), INTENT(IN) :: a,b
INTEGER(I4B), INTENT(IN) :: mm,kk
REAL(DP), DIMENSION(:), INTENT(OUT) :: cof
REAL(DP), INTENT(OUT) :: dev
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: x
REAL(DP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE ratlsq
END INTERFACE
INTERFACE ratval
FUNCTION ratval_s(x,cof,mm,kk)
USE nrtype
REAL(DP), INTENT(IN) :: x
INTEGER(I4B), INTENT(IN) :: mm,kk
REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof
REAL(DP) :: ratval_s
END FUNCTION ratval_s
!BL
FUNCTION ratval_v(x,cof,mm,kk)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: x
INTEGER(I4B), INTENT(IN) :: mm,kk
REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof
REAL(DP), DIMENSION(size(x)) :: ratval_v
END FUNCTION ratval_v
END INTERFACE
INTERFACE rc
FUNCTION rc_s(x,y)
USE nrtype
REAL(SP), INTENT(IN) :: x,y
REAL(SP) :: rc_s
END FUNCTION rc_s
!BL
FUNCTION rc_v(x,y)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), DIMENSION(size(x)) :: rc_v
END FUNCTION rc_v
END INTERFACE
INTERFACE rd
FUNCTION rd_s(x,y,z)
USE nrtype
REAL(SP), INTENT(IN) :: x,y,z
REAL(SP) :: rd_s
END FUNCTION rd_s
!BL
FUNCTION rd_v(x,y,z)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z
REAL(SP), DIMENSION(size(x)) :: rd_v
END FUNCTION rd_v
END INTERFACE
INTERFACE realft
SUBROUTINE realft_dp(data,isign,zdata)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
COMPLEX(DPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
END SUBROUTINE realft_dp
!BL
SUBROUTINE realft_sp(data,isign,zdata)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
INTEGER(I4B), INTENT(IN) :: isign
COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
END SUBROUTINE realft_sp
END INTERFACE
INTERFACE
RECURSIVE FUNCTION recur1(a,b) RESULT(u)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
REAL(SP), DIMENSION(size(a)) :: u
END FUNCTION recur1
END INTERFACE
INTERFACE
FUNCTION recur2(a,b,c)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c
REAL(SP), DIMENSION(size(a)) :: recur2
END FUNCTION recur2
END INTERFACE
INTERFACE
SUBROUTINE relax(u,rhs)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u
REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs
END SUBROUTINE relax
END INTERFACE
INTERFACE
SUBROUTINE relax2(u,rhs)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u
REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs
END SUBROUTINE relax2
END INTERFACE
INTERFACE
FUNCTION resid(u,rhs)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,rhs
REAL(DP), DIMENSION(size(u,1),size(u,1)) :: resid
END FUNCTION resid
END INTERFACE
INTERFACE rf
FUNCTION rf_s(x,y,z)
USE nrtype
REAL(SP), INTENT(IN) :: x,y,z
REAL(SP) :: rf_s
END FUNCTION rf_s
!BL
FUNCTION rf_v(x,y,z)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z
REAL(SP), DIMENSION(size(x)) :: rf_v
END FUNCTION rf_v
END INTERFACE
INTERFACE rj
FUNCTION rj_s(x,y,z,p)
USE nrtype
REAL(SP), INTENT(IN) :: x,y,z,p
REAL(SP) :: rj_s
END FUNCTION rj_s
!BL
FUNCTION rj_v(x,y,z,p)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z,p
REAL(SP), DIMENSION(size(x)) :: rj_v
END FUNCTION rj_v
END INTERFACE
INTERFACE
SUBROUTINE rk4(y,dydx,x,h,yout,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
REAL(SP), INTENT(IN) :: x,h
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE rk4
END INTERFACE
INTERFACE
SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
REAL(SP), INTENT(IN) :: x,h
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE rkck
END INTERFACE
INTERFACE
SUBROUTINE rkdumb(vstart,x1,x2,nstep,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: vstart
REAL(SP), INTENT(IN) :: x1,x2
INTEGER(I4B), INTENT(IN) :: nstep
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE rkdumb
END INTERFACE
INTERFACE
SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE rkqs
END INTERFACE
INTERFACE
SUBROUTINE rlft2(data,spec,speq,isign)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data
COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: spec
COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE rlft2
END INTERFACE
INTERFACE
SUBROUTINE rlft3(data,spec,speq,isign)
USE nrtype
REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data
COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec
COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: speq
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE rlft3
END INTERFACE
INTERFACE
SUBROUTINE rotate(r,qt,i,a,b)
USE nrtype
REAL(SP), DIMENSION(:,:), TARGET, INTENT(INOUT) :: r,qt
INTEGER(I4B), INTENT(IN) :: i
REAL(SP), INTENT(IN) :: a,b
END SUBROUTINE rotate
END INTERFACE
INTERFACE
SUBROUTINE rsolv(a,d,b)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
REAL(SP), DIMENSION(:), INTENT(IN) :: d
REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
END SUBROUTINE rsolv
END INTERFACE
INTERFACE
FUNCTION rstrct(uf)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: uf
REAL(DP), DIMENSION((size(uf,1)+1)/2,(size(uf,1)+1)/2) :: rstrct
END FUNCTION rstrct
END INTERFACE
INTERFACE
FUNCTION rtbis(func,x1,x2,xacc)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,xacc
REAL(SP) :: rtbis
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION rtbis
END INTERFACE
INTERFACE
FUNCTION rtflsp(func,x1,x2,xacc)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,xacc
REAL(SP) :: rtflsp
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION rtflsp
END INTERFACE
INTERFACE
FUNCTION rtnewt(funcd,x1,x2,xacc)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,xacc
REAL(SP) :: rtnewt
INTERFACE
SUBROUTINE funcd(x,fval,fderiv)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: fval,fderiv
END SUBROUTINE funcd
END INTERFACE
END FUNCTION rtnewt
END INTERFACE
INTERFACE
FUNCTION rtsafe(funcd,x1,x2,xacc)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,xacc
REAL(SP) :: rtsafe
INTERFACE
SUBROUTINE funcd(x,fval,fderiv)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: fval,fderiv
END SUBROUTINE funcd
END INTERFACE
END FUNCTION rtsafe
END INTERFACE
INTERFACE
FUNCTION rtsec(func,x1,x2,xacc)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,xacc
REAL(SP) :: rtsec
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION rtsec
END INTERFACE
INTERFACE
SUBROUTINE rzextr(iest,xest,yest,yz,dy)
USE nrtype
INTEGER(I4B), INTENT(IN) :: iest
REAL(SP), INTENT(IN) :: xest
REAL(SP), DIMENSION(:), INTENT(IN) :: yest
REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy
END SUBROUTINE rzextr
END INTERFACE
INTERFACE
FUNCTION savgol(nl,nrr,ld,m)
USE nrtype
INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m
REAL(SP), DIMENSION(nl+nrr+1) :: savgol
END FUNCTION savgol
END INTERFACE
INTERFACE
SUBROUTINE scrsho(func)
USE nrtype
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE scrsho
END INTERFACE
INTERFACE
FUNCTION select(k,arr)
USE nrtype
INTEGER(I4B), INTENT(IN) :: k
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
REAL(SP) :: select
END FUNCTION select
END INTERFACE
INTERFACE
FUNCTION select_bypack(k,arr)
USE nrtype
INTEGER(I4B), INTENT(IN) :: k
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
REAL(SP) :: select_bypack
END FUNCTION select_bypack
END INTERFACE
INTERFACE
SUBROUTINE select_heap(arr,heap)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
REAL(SP), DIMENSION(:), INTENT(OUT) :: heap
END SUBROUTINE select_heap
END INTERFACE
INTERFACE
FUNCTION select_inplace(k,arr)
USE nrtype
INTEGER(I4B), INTENT(IN) :: k
REAL(SP), DIMENSION(:), INTENT(IN) :: arr
REAL(SP) :: select_inplace
END FUNCTION select_inplace
END INTERFACE
INTERFACE
SUBROUTINE simplx(a,m1,m2,m3,icase,izrov,iposv)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
INTEGER(I4B), INTENT(IN) :: m1,m2,m3
INTEGER(I4B), INTENT(OUT) :: icase
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv
END SUBROUTINE simplx
END INTERFACE
INTERFACE
SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs)
USE nrtype
REAL(SP), INTENT(IN) :: xs,htot
REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx,dfdx
REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy
INTEGER(I4B), INTENT(IN) :: nstep
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE simpr
END INTERFACE
INTERFACE
SUBROUTINE sinft(y)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
END SUBROUTINE sinft
END INTERFACE
INTERFACE
SUBROUTINE slvsm2(u,rhs)
USE nrtype
REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u
REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs
END SUBROUTINE slvsm2
END INTERFACE
INTERFACE
SUBROUTINE slvsml(u,rhs)
USE nrtype
REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u
REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs
END SUBROUTINE slvsml
END INTERFACE
INTERFACE
SUBROUTINE sncndn(uu,emmc,sn,cn,dn)
USE nrtype
REAL(SP), INTENT(IN) :: uu,emmc
REAL(SP), INTENT(OUT) :: sn,cn,dn
END SUBROUTINE sncndn
END INTERFACE
INTERFACE
FUNCTION snrm(sx,itol)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: sx
INTEGER(I4B), INTENT(IN) :: itol
REAL(DP) :: snrm
END FUNCTION snrm
END INTERFACE
INTERFACE
SUBROUTINE sobseq(x,init)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: x
INTEGER(I4B), OPTIONAL, INTENT(IN) :: init
END SUBROUTINE sobseq
END INTERFACE
INTERFACE
SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y)
USE nrtype
INTEGER(I4B), INTENT(IN) :: itmax,nb
REAL(SP), INTENT(IN) :: conv,slowc
REAL(SP), DIMENSION(:), INTENT(IN) :: scalv
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: y
END SUBROUTINE solvde
END INTERFACE
INTERFACE
SUBROUTINE sor(a,b,c,d,e,f,u,rjac)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: a,b,c,d,e,f
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u
REAL(DP), INTENT(IN) :: rjac
END SUBROUTINE sor
END INTERFACE
INTERFACE
SUBROUTINE sort(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort
END INTERFACE
INTERFACE
SUBROUTINE sort2(arr,slave)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave
END SUBROUTINE sort2
END INTERFACE
INTERFACE
SUBROUTINE sort3(arr,slave1,slave2)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave1,slave2
END SUBROUTINE sort3
END INTERFACE
INTERFACE
SUBROUTINE sort_bypack(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort_bypack
END INTERFACE
INTERFACE
SUBROUTINE sort_byreshape(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort_byreshape
END INTERFACE
INTERFACE
SUBROUTINE sort_heap(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort_heap
END INTERFACE
INTERFACE
SUBROUTINE sort_pick(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort_pick
END INTERFACE
INTERFACE
SUBROUTINE sort_radix(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort_radix
END INTERFACE
INTERFACE
SUBROUTINE sort_shell(arr)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
END SUBROUTINE sort_shell
END INTERFACE
INTERFACE
SUBROUTINE spctrm(p,k,ovrlap,unit,n_window)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(OUT) :: p
INTEGER(I4B), INTENT(IN) :: k
LOGICAL(LGT), INTENT(IN) :: ovrlap
INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit
END SUBROUTINE spctrm
END INTERFACE
INTERFACE
SUBROUTINE spear(data1,data2,d,zd,probd,rs,probrs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs
END SUBROUTINE spear
END INTERFACE
INTERFACE sphbes
SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: x
REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp
END SUBROUTINE sphbes_s
!BL
SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp
END SUBROUTINE sphbes_v
END INTERFACE
INTERFACE
SUBROUTINE splie2(x1a,x2a,ya,y2a)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a
REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a
END SUBROUTINE splie2
END INTERFACE
INTERFACE
FUNCTION splin2(x1a,x2a,ya,y2a,x1,x2)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a
REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a
REAL(SP), INTENT(IN) :: x1,x2
REAL(SP) :: splin2
END FUNCTION splin2
END INTERFACE
INTERFACE
SUBROUTINE spline(x,y,yp1,ypn,y2)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), INTENT(IN) :: yp1,ypn
REAL(SP), DIMENSION(:), INTENT(OUT) :: y2
END SUBROUTINE spline
END INTERFACE
INTERFACE
FUNCTION splint(xa,ya,y2a,x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a
REAL(SP), INTENT(IN) :: x
REAL(SP) :: splint
END FUNCTION splint
END INTERFACE
INTERFACE sprsax
SUBROUTINE sprsax_dp(sa,x,b)
USE nrtype
TYPE(sprs2_dp), INTENT(IN) :: sa
REAL(DP), DIMENSION (:), INTENT(IN) :: x
REAL(DP), DIMENSION (:), INTENT(OUT) :: b
END SUBROUTINE sprsax_dp
!BL
SUBROUTINE sprsax_sp(sa,x,b)
USE nrtype
TYPE(sprs2_sp), INTENT(IN) :: sa
REAL(SP), DIMENSION (:), INTENT(IN) :: x
REAL(SP), DIMENSION (:), INTENT(OUT) :: b
END SUBROUTINE sprsax_sp
END INTERFACE
INTERFACE sprsdiag
SUBROUTINE sprsdiag_dp(sa,b)
USE nrtype
TYPE(sprs2_dp), INTENT(IN) :: sa
REAL(DP), DIMENSION(:), INTENT(OUT) :: b
END SUBROUTINE sprsdiag_dp
!BL
SUBROUTINE sprsdiag_sp(sa,b)
USE nrtype
TYPE(sprs2_sp), INTENT(IN) :: sa
REAL(SP), DIMENSION(:), INTENT(OUT) :: b
END SUBROUTINE sprsdiag_sp
END INTERFACE
INTERFACE sprsin
SUBROUTINE sprsin_sp(a,thresh,sa)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
REAL(SP), INTENT(IN) :: thresh
TYPE(sprs2_sp), INTENT(OUT) :: sa
END SUBROUTINE sprsin_sp
!BL
SUBROUTINE sprsin_dp(a,thresh,sa)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: a
REAL(DP), INTENT(IN) :: thresh
TYPE(sprs2_dp), INTENT(OUT) :: sa
END SUBROUTINE sprsin_dp
END INTERFACE
INTERFACE
SUBROUTINE sprstp(sa)
USE nrtype
TYPE(sprs2_sp), INTENT(INOUT) :: sa
END SUBROUTINE sprstp
END INTERFACE
INTERFACE sprstx
SUBROUTINE sprstx_dp(sa,x,b)
USE nrtype
TYPE(sprs2_dp), INTENT(IN) :: sa
REAL(DP), DIMENSION (:), INTENT(IN) :: x
REAL(DP), DIMENSION (:), INTENT(OUT) :: b
END SUBROUTINE sprstx_dp
!BL
SUBROUTINE sprstx_sp(sa,x,b)
USE nrtype
TYPE(sprs2_sp), INTENT(IN) :: sa
REAL(SP), DIMENSION (:), INTENT(IN) :: x
REAL(SP), DIMENSION (:), INTENT(OUT) :: b
END SUBROUTINE sprstx_sp
END INTERFACE
INTERFACE
SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE stifbs
END INTERFACE
INTERFACE
SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE stiff
END INTERFACE
INTERFACE
SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: y,d2y
REAL(SP), INTENT(IN) :: xs,htot
INTEGER(I4B), INTENT(IN) :: nstep
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE stoerm
END INTERFACE
INTERFACE svbksb
SUBROUTINE svbksb_dp(u,w,v,b,x)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,v
REAL(DP), DIMENSION(:), INTENT(IN) :: w,b
REAL(DP), DIMENSION(:), INTENT(OUT) :: x
END SUBROUTINE svbksb_dp
!BL
SUBROUTINE svbksb_sp(u,w,v,b,x)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v
REAL(SP), DIMENSION(:), INTENT(IN) :: w,b
REAL(SP), DIMENSION(:), INTENT(OUT) :: x
END SUBROUTINE svbksb_sp
END INTERFACE
INTERFACE svdcmp
SUBROUTINE svdcmp_dp(a,w,v)
USE nrtype
REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(DP), DIMENSION(:), INTENT(OUT) :: w
REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v
END SUBROUTINE svdcmp_dp
!BL
SUBROUTINE svdcmp_sp(a,w,v)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:), INTENT(OUT) :: w
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
END SUBROUTINE svdcmp_sp
END INTERFACE
INTERFACE
SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
REAL(SP), INTENT(OUT) :: chisq
INTERFACE
FUNCTION funcs(x,n)
USE nrtype
REAL(SP), INTENT(IN) :: x
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), DIMENSION(n) :: funcs
END FUNCTION funcs
END INTERFACE
END SUBROUTINE svdfit
END INTERFACE
INTERFACE
SUBROUTINE svdvar(v,w,cvm)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(IN) :: v
REAL(SP), DIMENSION(:), INTENT(IN) :: w
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm
END SUBROUTINE svdvar
END INTERFACE
INTERFACE
FUNCTION toeplz(r,y)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: r,y
REAL(SP), DIMENSION(size(y)) :: toeplz
END FUNCTION toeplz
END INTERFACE
INTERFACE
SUBROUTINE tptest(data1,data2,t,prob)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
REAL(SP), INTENT(OUT) :: t,prob
END SUBROUTINE tptest
END INTERFACE
INTERFACE
SUBROUTINE tqli(d,e,z)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e
REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z
END SUBROUTINE tqli
END INTERFACE
INTERFACE
SUBROUTINE trapzd(func,a,b,s,n)
USE nrtype
REAL(SP), INTENT(IN) :: a,b
REAL(SP), INTENT(INOUT) :: s
INTEGER(I4B), INTENT(IN) :: n
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: x
REAL(SP), DIMENSION(size(x)) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE trapzd
END INTERFACE
INTERFACE
SUBROUTINE tred2(a,d,e,novectors)
USE nrtype
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(SP), DIMENSION(:), INTENT(OUT) :: d,e
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors
END SUBROUTINE tred2
END INTERFACE
! On a purely serial machine, for greater efficiency, remove
! the generic name tridag from the following interface,
! and put it on the next one after that.
INTERFACE tridag
RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
REAL(SP), DIMENSION(:), INTENT(OUT) :: u
END SUBROUTINE tridag_par
END INTERFACE
INTERFACE
SUBROUTINE tridag_ser(a,b,c,r,u)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
REAL(SP), DIMENSION(:), INTENT(OUT) :: u
END SUBROUTINE tridag_ser
END INTERFACE
INTERFACE
SUBROUTINE ttest(data1,data2,t,prob)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
REAL(SP), INTENT(OUT) :: t,prob
END SUBROUTINE ttest
END INTERFACE
INTERFACE
SUBROUTINE tutest(data1,data2,t,prob)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
REAL(SP), INTENT(OUT) :: t,prob
END SUBROUTINE tutest
END INTERFACE
INTERFACE
SUBROUTINE twofft(data1,data2,fft1,fft2)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2
END SUBROUTINE twofft
END INTERFACE
INTERFACE
FUNCTION vander(x,q)
USE nrtype
REAL(DP), DIMENSION(:), INTENT(IN) :: x,q
REAL(DP), DIMENSION(size(x)) :: vander
END FUNCTION vander
END INTERFACE
INTERFACE
SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: region
INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn
REAL(SP), INTENT(OUT) :: tgral,sd,chi2a
INTERFACE
FUNCTION func(pt,wgt)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: pt
REAL(SP), INTENT(IN) :: wgt
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE vegas
END INTERFACE
INTERFACE
SUBROUTINE voltra(t0,h,t,f,g,ak)
USE nrtype
REAL(SP), INTENT(IN) :: t0,h
REAL(SP), DIMENSION(:), INTENT(OUT) :: t
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: f
INTERFACE
FUNCTION g(t)
USE nrtype
REAL(SP), INTENT(IN) :: t
REAL(SP), DIMENSION(:), POINTER :: g
END FUNCTION g
!BL
FUNCTION ak(t,s)
USE nrtype
REAL(SP), INTENT(IN) :: t,s
REAL(SP), DIMENSION(:,:), POINTER :: ak
END FUNCTION ak
END INTERFACE
END SUBROUTINE voltra
END INTERFACE
INTERFACE
SUBROUTINE wt1(a,isign,wtstep)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
INTEGER(I4B), INTENT(IN) :: isign
INTERFACE
SUBROUTINE wtstep(a,isign)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE wtstep
END INTERFACE
END SUBROUTINE wt1
END INTERFACE
INTERFACE
SUBROUTINE wtn(a,nn,isign,wtstep)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn
INTEGER(I4B), INTENT(IN) :: isign
INTERFACE
SUBROUTINE wtstep(a,isign)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
INTEGER(I4B), INTENT(IN) :: isign
END SUBROUTINE wtstep
END INTERFACE
END SUBROUTINE wtn
END INTERFACE
INTERFACE
FUNCTION wwghts(n,h,kermom)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
REAL(SP), INTENT(IN) :: h
REAL(SP), DIMENSION(n) :: wwghts
INTERFACE
FUNCTION kermom(y,m)
USE nrtype
REAL(DP), INTENT(IN) :: y
INTEGER(I4B), INTENT(IN) :: m
REAL(DP), DIMENSION(m) :: kermom
END FUNCTION kermom
END INTERFACE
END FUNCTION wwghts
END INTERFACE
INTERFACE
SUBROUTINE zbrac(func,x1,x2,succes)
USE nrtype
REAL(SP), INTENT(INOUT) :: x1,x2
LOGICAL(LGT), INTENT(OUT) :: succes
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE zbrac
END INTERFACE
INTERFACE
SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,nb)
USE nrtype
INTEGER(I4B), INTENT(IN) :: n
INTEGER(I4B), INTENT(OUT) :: nb
REAL(SP), INTENT(IN) :: x1,x2
REAL(SP), DIMENSION(:), POINTER :: xb1,xb2
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END SUBROUTINE zbrak
END INTERFACE
INTERFACE
FUNCTION zbrent(func,x1,x2,tol)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,tol
REAL(SP) :: zbrent
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION zbrent
END INTERFACE
INTERFACE
SUBROUTINE zrhqr(a,rtr,rti)
USE nrtype
REAL(SP), DIMENSION(:), INTENT(IN) :: a
REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti
END SUBROUTINE zrhqr
END INTERFACE
INTERFACE
FUNCTION zriddr(func,x1,x2,xacc)
USE nrtype
REAL(SP), INTENT(IN) :: x1,x2,xacc
REAL(SP) :: zriddr
INTERFACE
FUNCTION func(x)
USE nrtype
REAL(SP), INTENT(IN) :: x
REAL(SP) :: func
END FUNCTION func
END INTERFACE
END FUNCTION zriddr
END INTERFACE
INTERFACE
SUBROUTINE zroots(a,roots,polish)
USE nrtype
COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a
COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots
LOGICAL(LGT), INTENT(IN) :: polish
END SUBROUTINE zroots
END INTERFACE
END MODULE nr
SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs)
USE nrtype; USE nrutil, ONLY : assert_eq
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
REAL(SP), INTENT(IN) :: x,h
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
INTEGER(I4B) :: ndum
REAL(SP), DIMENSION(size(y)) :: ak2,ak3,ak4,ak5,ak6,ytemp
REAL(SP), PARAMETER :: A2=0.2_sp,A3=0.3_sp,A4=0.6_sp,A5=1.0_sp,&
A6=0.875_sp,B21=0.2_sp,B31=3.0_sp/40.0_sp,B32=9.0_sp/40.0_sp,&
B41=0.3_sp,B42=-0.9_sp,B43=1.2_sp,B51=-11.0_sp/54.0_sp,&
B52=2.5_sp,B53=-70.0_sp/27.0_sp,B54=35.0_sp/27.0_sp,&
B61=1631.0_sp/55296.0_sp,B62=175.0_sp/512.0_sp,&
B63=575.0_sp/13824.0_sp,B64=44275.0_sp/110592.0_sp,&
B65=253.0_sp/4096.0_sp,C1=37.0_sp/378.0_sp,&
C3=250.0_sp/621.0_sp,C4=125.0_sp/594.0_sp,&
C6=512.0_sp/1771.0_sp,DC1=C1-2825.0_sp/27648.0_sp,&
DC3=C3-18575.0_sp/48384.0_sp,DC4=C4-13525.0_sp/55296.0_sp,&
DC5=-277.0_sp/14336.0_sp,DC6=C6-0.25_sp
ndum=assert_eq(size(y),size(dydx),size(yout),size(yerr),'rkck')
ytemp=y+B21*h*dydx
call derivs(x+A2*h,ytemp,ak2)
ytemp=y+h*(B31*dydx+B32*ak2)
call derivs(x+A3*h,ytemp,ak3)
ytemp=y+h*(B41*dydx+B42*ak2+B43*ak3)
call derivs(x+A4*h,ytemp,ak4)
ytemp=y+h*(B51*dydx+B52*ak2+B53*ak3+B54*ak4)
call derivs(x+A5*h,ytemp,ak5)
ytemp=y+h*(B61*dydx+B62*ak2+B63*ak3+B64*ak4+B65*ak5)
call derivs(x+A6*h,ytemp,ak6)
yout=y+h*(C1*dydx+C3*ak3+C4*ak4+C6*ak6)
yerr=h*(DC1*dydx+DC3*ak3+DC4*ak4+DC5*ak5+DC6*ak6)
END SUBROUTINE rkck
SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror
USE nr, ONLY : rkck
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
INTEGER(I4B) :: ndum
REAL(SP) :: errmax,h,htemp,xnew
REAL(SP), DIMENSION(size(y)) :: yerr,ytemp
REAL(SP), PARAMETER :: SAFETY=0.9_sp,PGROW=-0.2_sp,PSHRNK=-0.25_sp,&
ERRCON=1.89e-4
ndum=assert_eq(size(y),size(dydx),size(yscal),'rkqs')
h=htry
do
call rkck(y,dydx,x,h,ytemp,yerr,derivs)
errmax=maxval(abs(yerr(:)/yscal(:)))/eps
if (errmax <= 1.0) exit
htemp=SAFETY*h*(errmax**PSHRNK)
h=sign(max(abs(htemp),0.1_sp*abs(h)),h)
xnew=x+h
if (xnew == x) call nrerror('stepsize underflow in rkqs')
end do
if (errmax > ERRCON) then
hnext=SAFETY*h*(errmax**PGROW)
else
hnext=5.0_sp*h
end if
hdid=h
x=x+h
y(:)=ytemp(:)
END SUBROUTINE rkqs
SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs)
USE nrtype; USE nrutil, ONLY : assert_eq,swap
IMPLICIT NONE
INTEGER(I4B), INTENT(IN) :: nstep
REAL(SP), INTENT(IN) :: xs,htot
REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
INTEGER(I4B) :: n,ndum
REAL(SP) :: h,h2,x
REAL(SP), DIMENSION(size(y)) :: ym,yn
ndum=assert_eq(size(y),size(dydx),size(yout),'mmid')
h=htot/nstep
ym=y
yn=y+h*dydx
x=xs+h
call derivs(x,yn,yout)
h2=2.0_sp*h
do n=2,nstep
call swap(ym,yn)
yn=yn+h2*yout
x=x+h
call derivs(x,yn,yout)
end do
yout=0.5_sp*(ym+yn+h*yout)
END SUBROUTINE mmid
SUBROUTINE pzextr(iest,xest,yest,yz,dy)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror
IMPLICIT NONE
INTEGER(I4B), INTENT(IN) :: iest
REAL(SP), INTENT(IN) :: xest
REAL(SP), DIMENSION(:), INTENT(IN) :: yest
REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy
INTEGER(I4B), PARAMETER :: IEST_MAX=16
INTEGER(I4B) :: j,nv
INTEGER(I4B), SAVE :: nvold=-1
REAL(SP) :: delta,f1,f2
REAL(SP), DIMENSION(size(yz)) :: d,tmp,q
REAL(SP), DIMENSION(IEST_MAX), SAVE :: x
REAL(SP), DIMENSION(:,:), ALLOCATABLE, SAVE :: qcol
nv=assert_eq(size(yz),size(yest),size(dy),'pzextr')
if (iest > IEST_MAX) call &
nrerror('pzextr: probable misuse, too much extrapolation')
if (nv /= nvold) then
if (allocated(qcol)) deallocate(qcol)
allocate(qcol(nv,IEST_MAX))
nvold=nv
end if
x(iest)=xest
dy(:)=yest(:)
yz(:)=yest(:)
if (iest == 1) then
qcol(:,1)=yest(:)
else
d(:)=yest(:)
do j=1,iest-1
delta=1.0_sp/(x(iest-j)-xest)
f1=xest*delta
f2=x(iest-j)*delta
q(:)=qcol(:,j)
qcol(:,j)=dy(:)
tmp(:)=d(:)-q(:)
dy(:)=f1*tmp(:)
d(:)=f2*tmp(:)
yz(:)=yz(:)+dy(:)
end do
qcol(:,iest)=dy(:)
end if
END SUBROUTINE pzextr
SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype; USE nrutil, ONLY : arth,assert_eq,cumsum,iminloc,nrerror,&
outerdiff,outerprod,upper_triangle
USE nr, ONLY : mmid,pzextr
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
INTEGER(I4B), PARAMETER :: IMAX=9, KMAXX=IMAX-1
REAL(SP), PARAMETER :: SAFE1=0.25_sp,SAFE2=0.7_sp,REDMAX=1.0e-5_sp,&
REDMIN=0.7_sp,TINY=1.0e-30_sp,SCALMX=0.1_sp
INTEGER(I4B) :: k,km,ndum
INTEGER(I4B), DIMENSION(IMAX) :: nseq = (/ 2,4,6,8,10,12,14,16,18 /)
INTEGER(I4B), SAVE :: kopt,kmax
REAL(SP), DIMENSION(KMAXX,KMAXX), SAVE :: alf
REAL(SP), DIMENSION(KMAXX) :: err
REAL(SP), DIMENSION(IMAX), SAVE :: a
REAL(SP), SAVE :: epsold = -1.0_sp,xnew
REAL(SP) :: eps1,errmax,fact,h,red,scale,wrkmin,xest
REAL(SP), DIMENSION(size(y)) :: yerr,ysav,yseq
LOGICAL(LGT) :: reduct
LOGICAL(LGT), SAVE :: first=.true.
ndum=assert_eq(size(y),size(dydx),size(yscal),'bsstep')
if (eps /= epsold) then
hnext=-1.0e29_sp
xnew=-1.0e29_sp
eps1=SAFE1*eps
a(:)=cumsum(nseq,1)
where (upper_triangle(KMAXX,KMAXX)) alf=eps1** &
(outerdiff(a(2:),a(2:))/outerprod(arth( &
3.0_sp,2.0_sp,KMAXX),(a(2:)-a(1)+1.0_sp)))
epsold=eps
do kopt=2,KMAXX-1
if (a(kopt+1) > a(kopt)*alf(kopt-1,kopt)) exit
end do
kmax=kopt
end if
h=htry
ysav(:)=y(:)
if (h /= hnext .or. x /= xnew) then
first=.true.
kopt=kmax
end if
reduct=.false.
main_loop: do
do k=1,kmax
xnew=x+h
if (xnew == x) call nrerror('step size underflow in bsstep')
call mmid(ysav,dydx,x,h,nseq(k),yseq,derivs)
xest=(h/nseq(k))**2
call pzextr(k,xest,yseq,y,yerr)
if (k /= 1) then
errmax=maxval(abs(yerr(:)/yscal(:)))
errmax=max(TINY,errmax)/eps
km=k-1
err(km)=(errmax/SAFE1)**(1.0_sp/(2*km+1))
end if
if (k /= 1 .and. (k >= kopt-1 .or. first)) then
if (errmax < 1.0) exit main_loop
if (k == kmax .or. k == kopt+1) then
red=SAFE2/err(km)
exit
else if (k == kopt) then
if (alf(kopt-1,kopt) < err(km)) then
red=1.0_sp/err(km)
exit
end if
else if (kopt == kmax) then
if (alf(km,kmax-1) < err(km)) then
red=alf(km,kmax-1)*SAFE2/err(km)
exit
end if
else if (alf(km,kopt) < err(km)) then
red=alf(km,kopt-1)/err(km)
exit
end if
end if
end do
red=max(min(red,REDMIN),REDMAX)
h=h*red
reduct=.true.
end do main_loop
x=xnew
hdid=h
first=.false.
kopt=1+iminloc(a(2:km+1)*max(err(1:km),SCALMX))
scale=max(err(kopt-1),SCALMX)
wrkmin=scale*a(kopt)
hnext=h/scale
if (kopt >= k .and. kopt /= kmax .and. .not. reduct) then
fact=max(scale/alf(kopt-1,kopt),SCALMX)
if (a(kopt+1)*fact <= wrkmin) then
hnext=h/fact
kopt=kopt+1
end if
end if
END SUBROUTINE bsstep
FUNCTION hypgeo(a,b,c,z)
USE nrtype
USE hypgeo_info
USE nr, ONLY : bsstep,hypdrv,hypser,odeint
IMPLICIT NONE
COMPLEX(SPC), INTENT(IN) :: a,b,c,z
COMPLEX(SPC) :: hypgeo
REAL(SP), PARAMETER :: EPS=1.0e-6_sp
COMPLEX(SPC), DIMENSION(2) :: y
REAL(SP), DIMENSION(4) :: ry
if (real(z)**2+aimag(z)**2 <= 0.25) then
call hypser(a,b,c,z,hypgeo,y(2))
RETURN
else if (real(z) < 0.0) then
hypgeo_z0=cmplx(-0.5_sp,0.0_sp,kind=spc)
else if (real(z) <= 1.0) then
hypgeo_z0=cmplx(0.5_sp,0.0_sp,kind=spc)
else
hypgeo_z0=cmplx(0.0_sp,sign(0.5_sp,aimag(z)),kind=spc)
end if
hypgeo_aa=a
hypgeo_bb=b
hypgeo_cc=c
hypgeo_dz=z-hypgeo_z0
call hypser(hypgeo_aa,hypgeo_bb,hypgeo_cc,hypgeo_z0,y(1),y(2))
ry(1:4:2)=real(y)
ry(2:4:2)=aimag(y)
! call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.0001_sp,hypdrv,bsstep)
call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.000001_sp,hypdrv,bsstep) !!! FB
y=cmplx(ry(1:4:2),ry(2:4:2),kind=spc)
hypgeo=y(1)
END FUNCTION hypgeo
SUBROUTINE hypdrv(s,ry,rdyds)
USE nrtype
USE hypgeo_info
IMPLICIT NONE
REAL(SP), INTENT(IN) :: s
REAL(SP), DIMENSION(:), INTENT(IN) :: ry
REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds
COMPLEX(SPC), DIMENSION(2) :: y,dyds
COMPLEX(SPC) :: z
y=cmplx(ry(1:4:2),ry(2:4:2),kind=spc)
z=hypgeo_z0+s*hypgeo_dz
dyds(1)=y(2)*hypgeo_dz
dyds(2)=((hypgeo_aa*hypgeo_bb)*y(1)-(hypgeo_cc-&
((hypgeo_aa+hypgeo_bb)+1.0_sp)*z)*y(2))*hypgeo_dz/(z*(1.0_sp-z))
rdyds(1:4:2)=real(dyds)
rdyds(2:4:2)=aimag(dyds)
END SUBROUTINE hypdrv
SUBROUTINE hypser(a,b,c,z,series,deriv)
USE nrtype; USE nrutil, ONLY : nrerror
IMPLICIT NONE
COMPLEX(SPC), INTENT(IN) :: a,b,c,z
COMPLEX(SPC), INTENT(OUT) :: series,deriv
INTEGER(I4B) :: n
INTEGER(I4B), PARAMETER :: MAXIT=1000
COMPLEX(SPC) :: aa,bb,cc,fac,temp
deriv=cmplx(0.0_sp,0.0_sp,kind=spc)
fac=cmplx(1.0_sp,0.0_sp,kind=spc)
temp=fac
aa=a
bb=b
cc=c
do n=1,MAXIT
fac=((aa*bb)/cc)*fac
deriv=deriv+fac
fac=fac*z/n
series=temp+fac
if (series == temp) RETURN
temp=series
aa=aa+1.0
bb=bb+1.0
cc=cc+1.0
end do
call nrerror('hypser: convergence failure')
END SUBROUTINE hypser
SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs)
USE nrtype; USE nrutil, ONLY : nrerror,reallocate
USE ode_path
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart
REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
!BL
SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
USE nrtype
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
REAL(SP), INTENT(INOUT) :: x
REAL(SP), INTENT(IN) :: htry,eps
REAL(SP), INTENT(OUT) :: hdid,hnext
INTERFACE
SUBROUTINE derivs(x,y,dydx)
USE nrtype
IMPLICIT NONE
REAL(SP), INTENT(IN) :: x
REAL(SP), DIMENSION(:), INTENT(IN) :: y
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
END SUBROUTINE derivs
END INTERFACE
END SUBROUTINE rkqs
END INTERFACE
REAL(SP), PARAMETER :: TINY=1.0e-30_sp
INTEGER(I4B), PARAMETER :: MAXSTP=10000
INTEGER(I4B) :: nstp
REAL(SP) :: h,hdid,hnext,x,xsav
REAL(SP), DIMENSION(size(ystart)) :: dydx,y,yscal
x=x1
h=sign(h1,x2-x1)
nok=0
nbad=0
kount=0
y(:)=ystart(:)
nullify(xp,yp)
if (save_steps) then
xsav=x-2.0_sp*dxsav
allocate(xp(256))
allocate(yp(size(ystart),size(xp)))
end if
do nstp=1,MAXSTP
call derivs(x,y,dydx)
yscal(:)=abs(y(:))+abs(h*dydx(:))+TINY
if (save_steps .and. (abs(x-xsav) > abs(dxsav))) &
call save_a_step
if ((x+h-x2)*(x+h-x1) > 0.0) h=x2-x
call rkqs(y,dydx,x,h,eps,yscal,hdid,hnext,derivs)
if (hdid == h) then
nok=nok+1
else
nbad=nbad+1
end if
if ((x-x2)*(x2-x1) >= 0.0) then
ystart(:)=y(:)
if (save_steps) call save_a_step
RETURN
end if
if (abs(hnext) < hmin) then
print *, "abs(hnext) = ", abs(hnext)
print *, "hmin = ", hmin
call nrerror('stepsize smaller than minimum in odeint')
end if
h=hnext
end do
call nrerror('too many steps in odeint')
CONTAINS
!BL
SUBROUTINE save_a_step
kount=kount+1
if (kount > size(xp)) then
xp=>reallocate(xp,2*size(xp))
yp=>reallocate(yp,size(yp,1),size(xp))
end if
xp(kount)=x
yp(:,kount)=y(:)
xsav=x
END SUBROUTINE save_a_step
END SUBROUTINE odeint
FUNCTION gammln_s(xx)
USE nrtype; USE nrutil, ONLY : arth,assert
IMPLICIT NONE
REAL(SP), INTENT(IN) :: xx
REAL(SP) :: gammln_s
REAL(DP) :: tmp,x
REAL(DP) :: stp = 2.5066282746310005_dp
REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,&
-86.50532032941677_dp,24.01409824083091_dp,&
-1.231739572450155_dp,0.1208650973866179e-2_dp,&
-0.5395239384953e-5_dp/)
call assert(xx > 0.0, 'gammln_s arg')
x=xx
tmp=x+5.5_dp
tmp=(x+0.5_dp)*log(tmp)-tmp
gammln_s=tmp+log(stp*(1.000000000190015_dp+&
sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x)
END FUNCTION gammln_s
FUNCTION gammln_v(xx)
USE nrtype; USE nrutil, ONLY: assert
IMPLICIT NONE
INTEGER(I4B) :: i
REAL(SP), DIMENSION(:), INTENT(IN) :: xx
REAL(SP), DIMENSION(size(xx)) :: gammln_v
REAL(DP), DIMENSION(size(xx)) :: ser,tmp,x,y
REAL(DP) :: stp = 2.5066282746310005_dp
REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,&
-86.50532032941677_dp,24.01409824083091_dp,&
-1.231739572450155_dp,0.1208650973866179e-2_dp,&
-0.5395239384953e-5_dp/)
if (size(xx) == 0) RETURN
call assert(all(xx > 0.0), 'gammln_v arg')
x=xx
tmp=x+5.5_dp
tmp=(x+0.5_dp)*log(tmp)-tmp
ser=1.000000000190015_dp
y=x
do i=1,size(coef)
y=y+1.0_dp
ser=ser+coef(i)/y
end do
gammln_v=tmp+log(stp*ser/x)
END FUNCTION gammln_v
! FUNCTION qgaus(func,a,b)
! USE nrtype
! REAL(SP), INTENT(IN) :: a,b
! REAL(SP) :: qgaus
! INTERFACE
! FUNCTION func(x)
! USE nrtype
! REAL(SP), DIMENSION(:), INTENT(IN) :: x
! REAL(SP), DIMENSION(size(x)) :: func
! END FUNCTION func
! END INTERFACE
! REAL(SP) :: xm,xr
! REAL(SP), DIMENSION(5) :: dx, w = (/ 0.2955242247_sp,0.2692667193_sp,&
! 0.2190863625_sp,0.1494513491_sp,0.0666713443_sp /),&
! x = (/ 0.1488743389_sp,0.4333953941_sp,0.6794095682_sp,&
! 0.8650633666_sp,0.9739065285_sp /)
! xm=0.5_sp*(b+a)
! xr=0.5_sp*(b-a)
! dx(:)=xr*x(:)
! qgaus=xr*sum(w(:)*(func(xm+dx)+func(xm-dx)))
! END FUNCTION qgaus
FUNCTION locatenr(xx,x)
USE nrtype
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(IN) :: xx
REAL(SP), INTENT(IN) :: x
INTEGER(I4B) :: locatenr
INTEGER(I4B) :: n,jl,jm,ju
LOGICAL :: ascnd
n=size(xx)
ascnd = (xx(n) >= xx(1))
jl=0
ju=n+1
do
if (ju-jl <= 1) exit
jm=(ju+jl)/2
if (ascnd .eqv. (x >= xx(jm))) then
jl=jm
else
ju=jm
end if
end do
if (x == xx(1)) then
locatenr=1
else if (x == xx(n)) then
locatenr=n-1
else
locatenr=jl
end if
END FUNCTION locatenr
SUBROUTINE tridag_ser(a,b,c,r,u)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
REAL(SP), DIMENSION(:), INTENT(OUT) :: u
REAL(SP), DIMENSION(size(b)) :: gam
INTEGER(I4B) :: n,j
REAL(SP) :: bet
n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_ser')
bet=b(1)
if (bet == 0.0) call nrerror('tridag_ser: Error at code stage 1')
u(1)=r(1)/bet
do j=2,n
gam(j)=c(j-1)/bet
bet=b(j)-a(j-1)*gam(j)
if (bet == 0.0) &
call nrerror('tridag_ser: Error at code stage 2')
u(j)=(r(j)-a(j-1)*u(j-1))/bet
end do
do j=n-1,1,-1
u(j)=u(j)-gam(j+1)*u(j+1)
end do
END SUBROUTINE tridag_ser
RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror
USE nr, ONLY : tridag_ser
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
REAL(SP), DIMENSION(:), INTENT(OUT) :: u
INTEGER(I4B), PARAMETER :: NPAR_TRIDAG=4
INTEGER(I4B) :: n,n2,nm,nx
REAL(SP), DIMENSION(size(b)/2) :: y,q,piva
REAL(SP), DIMENSION(size(b)/2-1) :: x,z
REAL(SP), DIMENSION(size(a)/2) :: pivc
n=assert_eq((/size(a)+1,size(b),size(c)+1,size(r),size(u)/),'tridag_par')
if (n < NPAR_TRIDAG) then
call tridag_ser(a,b,c,r,u)
else
if (maxval(abs(b(1:n))) == 0.0) &
call nrerror('tridag_par: possible singular matrix')
n2=size(y)
nm=size(pivc)
nx=size(x)
piva = a(1:n-1:2)/b(1:n-1:2)
pivc = c(2:n-1:2)/b(3:n:2)
y(1:nm) = b(2:n-1:2)-piva(1:nm)*c(1:n-2:2)-pivc*a(2:n-1:2)
q(1:nm) = r(2:n-1:2)-piva(1:nm)*r(1:n-2:2)-pivc*r(3:n:2)
if (nm < n2) then
y(n2) = b(n)-piva(n2)*c(n-1)
q(n2) = r(n)-piva(n2)*r(n-1)
end if
x = -piva(2:n2)*a(2:n-2:2)
z = -pivc(1:nx)*c(3:n-1:2)
call tridag_par(x,y,z,q,u(2:n:2))
u(1) = (r(1)-c(1)*u(2))/b(1)
u(3:n-1:2) = (r(3:n-1:2)-a(2:n-2:2)*u(2:n-2:2) &
-c(3:n-1:2)*u(4:n:2))/b(3:n-1:2)
if (nm == n2) u(n)=(r(n)-a(n-1)*u(n-1))/b(n)
end if
END SUBROUTINE tridag_par
SUBROUTINE spline(x,y,yp1,ypn,y2)
USE nrtype; USE nrutil, ONLY : assert_eq
USE nr, ONLY : tridag
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
REAL(SP), INTENT(IN) :: yp1,ypn
REAL(SP), DIMENSION(:), INTENT(OUT) :: y2
INTEGER(I4B) :: n
REAL(SP), DIMENSION(size(x)) :: a,b,c,r
n=assert_eq(size(x),size(y),size(y2),'spline')
c(1:n-1)=x(2:n)-x(1:n-1)
r(1:n-1)=6.0_sp*((y(2:n)-y(1:n-1))/c(1:n-1))
r(2:n-1)=r(2:n-1)-r(1:n-2)
a(2:n-1)=c(1:n-2)
b(2:n-1)=2.0_sp*(c(2:n-1)+a(2:n-1))
b(1)=1.0
b(n)=1.0
if (yp1 > 0.99e30_sp) then
r(1)=0.0
c(1)=0.0
else
r(1)=(3.0_sp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
c(1)=0.5
end if
if (ypn > 0.99e30_sp) then
r(n)=0.0
a(n)=0.0
else
r(n)=(-3.0_sp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn)
a(n)=0.5
end if
call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n))
END SUBROUTINE spline
FUNCTION splint(xa,ya,y2a,x)
USE nrtype; USE nrutil, ONLY : assert_eq,nrerror
USE nr, ONLY: locatenr
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a
REAL(SP), INTENT(IN) :: x
REAL(SP) :: splint
INTEGER(I4B) :: khi,klo,n
REAL(SP) :: a,b,h
n=assert_eq(size(xa),size(ya),size(y2a),'splint')
klo=max(min(locatenr(xa,x),n-1),1)
khi=klo+1
h=xa(khi)-xa(klo)
if (h == 0.0) call nrerror('bad xa input in splint')
a=(xa(khi)-x)/h
b=(x-xa(klo))/h
splint=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_sp
END FUNCTION splint
SUBROUTINE sort(arr)
USE nrtype; USE nrutil, ONLY : swap,nrerror
IMPLICIT NONE
REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50
REAL(SP) :: a
INTEGER(I4B) :: n,k,i,j,jstack,l,r
INTEGER(I4B), DIMENSION(NSTACK) :: istack
n=size(arr)
jstack=0
l=1
r=n
do
if (r-l < NN) then
do j=l+1,r
a=arr(j)
do i=j-1,l,-1
if (arr(i) <= a) exit
arr(i+1)=arr(i)
end do
arr(i+1)=a
end do
if (jstack == 0) RETURN
r=istack(jstack)
l=istack(jstack-1)
jstack=jstack-2
else
k=(l+r)/2
call swap(arr(k),arr(l+1))
call swap(arr(l),arr(r),arr(l)>arr(r))
call swap(arr(l+1),arr(r),arr(l+1)>arr(r))
call swap(arr(l),arr(l+1),arr(l)>arr(l+1))
i=l+1
j=r
a=arr(l+1)
do
do
i=i+1
if (arr(i) >= a) exit
end do
do
j=j-1
if (arr(j) <= a) exit
end do
if (j < i) exit
call swap(arr(i),arr(j))
end do
arr(l+1)=arr(j)
arr(j)=a
jstack=jstack+2
if (jstack > NSTACK) call nrerror('sort: NSTACK too small')
if (r-i+1 >= j-l) then
istack(jstack)=r
istack(jstack-1)=i
r=j-1
else
istack(jstack)=j-1
istack(jstack-1)=l
l=i
end if
end if
end do
END SUBROUTINE sort
!!! Whizard wrapper for NR tools
module nr_tools
use kinds, only: default !NODEP!
use nrtype, only: i4b, sp, spc !NODEP!
use nr, only: gammln, hypgeo, locatenr, sort, spline, splint !NODEP!
implicit none
save
private
public :: nr_hypgeo, nr_gamma, nr_locate, nr_sort, nr_spline_t
type :: nr_spline_t
real(sp), dimension(:), allocatable :: xa, ya_re, ya_im, y2a_re, y2a_im
contains
procedure :: init => nr_spline_init
procedure :: interpolate => nr_spline_interpolate
procedure :: dealloc => nr_spline_dealloc
end type nr_spline_t
contains
function nr_hypgeo (a, b, c, d) result (h)
complex(default), intent(in) :: a, b, c, d
complex(default) :: h
complex(spc) :: a_sp, b_sp, c_sp, d_sp
a_sp = cmplx(a,kind=sp)
b_sp = cmplx(b,kind=sp)
c_sp = cmplx(c,kind=sp)
d_sp = cmplx(d,kind=sp)
h = cmplx( hypgeo (a_sp, b_sp, c_sp, d_sp) , kind=default )
end function nr_hypgeo
function nr_gamma (x) result (y)
real(default), intent(in) :: x
real(default) :: y
y = real( exp(gammln(real(x,kind=sp))) , kind=default )
end function nr_gamma
function nr_locate (xa, x) result (pos)
real(default), dimension(:), intent(in) :: xa
real(default), intent(in) :: x
integer :: pos
pos = locatenr (real(xa,kind=sp), real(x,kind=sp))
end function
! function nr_qgaus (fun, pts) result (res)
! real(default), dimension(:), intent(in) :: pts
! complex(default) :: res
! integer :: i_pts
! real(sp) :: lo, hi, re, im
! interface
! function fun (x)
! use kinds, only: default !NODEP!
! real(default), intent(in) :: x
! complex(default) :: fun
! end function fun
! end interface
! res = 0.0_default
! if ( size(pts) < 2 ) return
! do i_pts=1, size(pts)-1
! lo = real(pts(i_pts ),kind=sp)
! hi = real(pts(i_pts+1),kind=sp)
! re = qgaus (fun_re, lo, hi)
! im = qgaus (fun_im, lo, hi)
! res = res + cmplx(re,im,kind=default)
! end do
! contains
! function fun_re (xa_sp)
! use kinds, only: default !NODEP!
! use nrtype, only: sp !NODEP!
! real(sp), dimension(:), intent(in) :: xa_sp
! real(sp), dimension(size(xa_sp)) :: fun_re
! real(default), dimension(size(xa_sp)) :: xa
! integer :: ix
! xa = real(xa_sp,kind=default)
! fun_re = (/ (real(fun(xa(ix)),kind=sp), ix=1, size(xa)) /)
! end function fun_re
! function fun_im (xa_sp)
! use kinds, only: default !NODEP!
! use nrtype, only: sp !NODEP!
! real(sp), dimension(:), intent(in) :: xa_sp
! real(sp), dimension(size(xa_sp)) :: fun_im
! real(default), dimension(size(xa_sp)) :: xa
! integer :: ix
! xa = real(xa_sp,kind=default)
! fun_im = (/ (real(aimag(fun(xa(ix))),kind=sp), ix=1, size(xa)) /)
! end function fun_im
! end function nr_qgaus
subroutine nr_sort (array)
real(default), dimension(:), intent(inout) :: array
real(sp), dimension(size(array)) :: array_sp
array_sp = real(array,kind=sp)
call sort (array_sp)
array = real(array_sp,kind=default)
end subroutine nr_sort
subroutine nr_spline_init (spl, xa_in, ya_in)
class(nr_spline_t), intent(inout) :: spl
real(default), dimension(:), intent(in) :: xa_in
complex(default), dimension(:), intent(in) :: ya_in
integer :: n
if ( allocated(spl%xa) ) then
print *, "ERROR: nr_spline: init: already initialized!"
stop
end if
n = size(xa_in)
allocate( spl%xa(n) )
allocate( spl%ya_re(n) )
allocate( spl%ya_im(n) )
allocate( spl%y2a_re(n) )
allocate( spl%y2a_im(n) )
spl%xa = real(xa_in,kind=sp)
spl%ya_re = real(ya_in,kind=sp)
spl%ya_im = real(aimag(ya_in),kind=sp)
call spline (spl%xa, spl%ya_re, 1.e30, 1.e30, spl%y2a_re)
call spline (spl%xa, spl%ya_im, 1.e30, 1.e30, spl%y2a_im)
end subroutine nr_spline_init
function nr_spline_interpolate (spl, x) result (y)
complex(default) :: y
class(nr_spline_t), intent(in) :: spl
real(default), intent(in) :: x
real(sp) :: y_re, y_im
if ( .not.allocated(spl%xa) ) then
print *, "ERROR: nr_spline: interpolate: not initialized!"
stop
end if
y_re = splint (spl%xa, spl%ya_re, spl%y2a_re, real(x,kind=sp))
y_im = splint (spl%xa, spl%ya_im, spl%y2a_im, real(x,kind=sp))
y = cmplx(y_re,y_im,kind=default)
end function nr_spline_interpolate
subroutine nr_spline_dealloc (spl)
class(nr_spline_t), intent(inout) :: spl
if ( .not.allocated(spl%xa) ) then
print *, "ERROR: nr_spline: dealloc: not initialized!"
stop
end if
deallocate( spl%xa )
deallocate( spl%ya_re )
deallocate( spl%ya_im )
deallocate( spl%y2a_re )
deallocate( spl%y2a_im )
end subroutine nr_spline_dealloc
end module nr_tools
@
<<[[toppik.f]]>>=
! WHIZARD <<Version>> <<Date>>
! TOPPIK code by M. Jezabek, T. Teubner (v1.1, 1992), T. Teubner (1998)
!
! FB: -commented out numerical recipes code for hypergeometric 2F1
! included in hypgeo.f90;
! -commented out unused function 'ZAPVQ1';
! -replaced function 'cdabs' by 'abs';
! -replaced function 'dimag' by 'aimag';
! -replaced function 'dcmplx(,)' by 'cmplx(,,kind=kind(0d0))';
! -replaced function 'dreal' by 'real';
! -replaced function 'cdlog' by 'log';
! -replaced PAUSE by PRINT statement to avoid compiler warning;
! -initialized 'idum' explicitly as real to avoid compiler warning.
! -modified 'adglg1', 'adglg2' and 'tttoppik' to catch unstable runs.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c *********************************************************************
c
c Working version with all the different original potentials
c like (p^2+q^2)/|p-q|^2, not transformed in terms of delta and 1/r^2;
c accuracy eps=1.d-3 possible (only), but should be save, 13.8.'98, tt.
c
c *********************************************************************
c
subroutine tttoppik(xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,
u xc0,xc1,xc2,xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,
u xkincm,xkinca,jknflg,jgcflg,
u xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zvfct)
c
c *********************************************************************
c
c !! THIS IS NOT A PUBLIC VERSION !!
c
c -- Calculation of the Green function in momentum space by solving the
c Lippmann-Schwinger equation
c G(p) = G_0(p) + G_0(p) int_0^xcutn V(p,q) G(q) dq
c
c -- Written by Thomas Teubner, Hamburg, November 1998
c * Based on TOPPIK Version 1.1
c from M. Jezabek and TT, Karlsruhe, June 1992
c * Version originally for non-constant top-width
c * Constant width supplied here
c * No generator included
c
c -- Use of double precision everywhere
c
c -- All masses, momenta, energies, widths in GeV
c
c -- Input parameters:
c
c xenergy : E=Sqrt[s]-2*topmass
c xtm : topmass (in the Pole scheme)
c xtg : top-width
c xalphas : alpha_s^{MSbar,n_f=5}(xscale)
c xscale : soft scale mu_{soft}
c xcutn : numerical UV cutoff on all momenta
c (UV cutoff of the Gauss-Legendre grid)
c xcutv : renormalization cutoff on the
c delta-, the (p^2+q^2)/(p-q)^2-, and the
c 1/r^2-[1/|p-q|]-potential:
c if (max(p,q).ge.xcutv) then the three potentials
c are set to zero in the Lippmann-Schwinger equation
c xc0 : 0th order coefficient for the Coulomb potential,
c see calling example above
c xc1 : 1st order coefficient for the Coulomb potential
c xc2 : 2nd order coefficient for the Coulomb potential
c xcdeltc : constant of the delta(r)-
c [= constant in momentum space-] potential
c xcdeltl : constant for the additional log(q^2/mu^2)-part of the
c delta-potential:
c xcdeltc*1 + xcdeltl*log(q^2/mu^2)
c xcfullc : constant of the (p^2+q^2)/(p-q)^2-potential
c xcfulll : constant for the additional log(q^2/mu^2)-part of the
c (p^2+q^2)/(p-q)^2-potential
c xcrm2 : constant of the 1/r^2-[1/|p-q|]-potential
c xkincm : } kinetic corrections in the 0th order Green-function:
c xkinca : } G_0(p):=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca
c !!! WATCH THE SIGN IN G_0 !!!
c jknflg : flag for these kinetic corrections:
c 0 : no kinetic corrections applied
c 1 : kinetic corrections applied with cutoff xcutv
c for xkinca only
c 2 : kinetic corrections applied with cutoff xcutv
c for xkinca AND xkincm
c jgcflg : flag for G_0(p) in the LS equation:
c 0 (standard choice) : G_0(p) as given above
c 1 (for TIPT) : G_0(p) = G_c^{0}(p) the 0th
c order Coulomb-Green-function
c in analytical form; not for
c momenta p > 1000*topmass
c xkincv : additional kinematic vertexcorrection in G_0, see below:
c jvflg : flag for the additional vertexcorrection xkincv in the
c ``zeroth order'' G_0(p) in the LS-equation:
c 0 : no correction, means G = G_0 + G_0 int V G
c with G_0=1/[E+iGamma_t-p^2/m_t]*(1+xkincm)+xkinca
c 1 : apply the correction in the LS equation as
c G = G_0 + xkincv*p^2/m_t^2/[E+iGamma_t-p^2/m_t] +
c G_0 int V G
c and correct the integral over Im[G(p)] to get sigma_tot
c from the optical theorem by the same factor.
c The cutoff xcutv is applied for these corrections.
c
c -- Output:
c
c xim : R_{ttbar} from the imaginary part of the green
c function
c xdi : R_{ttbar} form the integral over the momentum
c distribution (no cutoff but the numerical one here!!)
c np : number of points used for the grid; fixed in tttoppik
c xpp : 1-dim array (max. 900 elements) giving the momenta of
c the Gauss-Legendre grid (pp(i) in the code)
c xww : 1-dim array (max. 900 elements) giving the corresponding
c Gauss-Legendre weights for the grid
c xdsdp : 1-dim array (max. 900 elements) giving the
c momentum distribution of top: d\sigma/dp,
c normalized to R,
c at the momenta of the Gauss-Legendre grid xpp(i)
c zvfct : 1-dim array (max. 900 elements) of COMPLEX*16 numbers
c giving the vertex function K(p), G(p)=K(p)*G_0(p)
c at the momenta of the grid
c
c *********************************************************************
c
c
implicit none
real*8
u pi,energy,vzero,eps,
u pp,
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u xx,critp,consde,
u w1,w2,sig1,sig2,const,
u gtpcor,etot,
u xenergy,xtm,xtg,xalphas,xscale,xc0,xc1,xc2,xim,xdi,
u xdsdp,xpp,xww,
u cplas,scale,c0,c1,c2,cdeltc,cdeltl,cfullc,cfulll,crm2,
u xcutn,dcut,xcutv,
u xp,xpmax,hmass,
u kincom,kincoa,kincov,xkincm,xkinca,xkincv,
u xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,chiggs
complex*16 bb,gg,a1,a,g0,g0c,zvfct
integer i,n,nmax,npot,np,gcflg,kinflg,jknflg,jgcflg,
u jvflg,vflag
parameter (nmax=900)
dimension pp(nmax), bb(nmax), xx(nmax), gg(nmax),
u w1(nmax), w2(nmax), a1(nmax),
u xdsdp(nmax),xpp(nmax),xww(nmax),zvfct(nmax)
c
external a,gtpcor,g0,g0c
c
common/ovalco/ pi, energy, vzero, eps, npot
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/cplcns/cplas,scale,c0,c1,c2,
u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs
common/mom/ xp,xpmax,dcut
common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag
c
pi=3.141592653589793238d0
c
c Number of points to evaluate on the integral equation
c (<=900 and n mod 3 = 0 !!):
c n=66
n=600
np=n
c
c For second order potential with free parameters:
c
npot=5
c Internal accuracy for TOPPIK, the reachable limit may be smaller,
c depending on the parameters. But increase in real accuracy only
c in combination with large number of points.
eps=1.d-3
c Some physical parameters:
wgamma=2.07d0
zmass=91.187d0
wmass=80.33d0
bmass=4.7d0
c
c Input:
energy=xenergy
tmass=xtm
tgamma=xtg
cplas=xalphas
scale=xscale
c0=xc0
c1=xc1
c2=xc2
cdeltc=xcdeltc
cdeltl=xcdeltl
cfullc=xcfullc
cfulll=xcfulll
crm2=xcrm2
kincom=xkincm
kincoa=xkinca
kincov=xkincv
kinflg=jknflg
gcflg=jgcflg
vflag=jvflg
c
alphas=xalphas
c
c Cut for divergent potential-terms for large momenta in the function vhat
c and in the integrals a(p):
dcut=xcutv
c
c Numerical Cutoff of all momenta (maximal momenta of the grid):
xpmax=xcutn
if (dcut.gt.xpmax) then
write(*,*) ' dcut > xpmax makes no sense! Stop.'
stop
endif
c
c Not needed for the fixed order potentials:
alamb5=0.2d0
c
c WRITE(*,*) 'INPUT TGAMMA=',TGAMMA
c Needed in subroutine GAMMAT:
GFERMI=1.16637d-5
c CALL GAMMAT
c WRITE(*,*) 'CALCULATED TGAMMA=',TGAMMA
c
etot=2.d0*tmass+energy
c
if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or.
u (npot.eq.5)) then
c For pure coulomb and fixed order potentials there is no delta-part:
consde = 0.d0
else if (npot.eq.2) then
c Initialize QCD-potential common-blocks and calculate constant multiplying
c the delta-part of the 'qcutted' potential in momentum-space:
call iniphc(1)
call vqdelt(consde)
else
write (*,*) ' Potential not implemented! Stop.'
stop
endif
c Delta-part of potential is absorbed by subtracting vzero from the
c original energy (shift from the potential to the free Hamiltonian):
vzero = consde / (2.d0*pi)**3
c write (*,*) 'vzero=', vzero
c
c Find x-values pp(i) and weigths w1(i) for the gaussian quadrature;
c care about large number of points in the important intervals:
c if (energy-vzero.le.0.d0) then
cc call gauleg(0.d0, 1.d0, pp, w1, n/3)
cc call gauleg(1.d0, 5.d0, pp(n/3+1), w1(n/3+1), n/3)
cc call gauleg(0.d0, 0.2d0, pp(2*n/3+1), w1(2*n/3+1), n/3)
c call gauleg(0.d0, 5.d0, pp, w1, n/3)
c call gauleg(5.d0, 20.d0, pp(n/3+1), w1(n/3+1), n/3)
c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3)
c else
cc Avoid numerical singular points in the inner of the intervals:
c critp = dsqrt((energy-vzero)*tmass)
c if (critp.le.1.d0) then
cc Gauss-Legendre is symmetric => automatically principal-value prescription:
c call gauleg(0.d0, 2.d0*critp, pp, w1, n/3)
c call gauleg(2.d0*critp, 20.d0, pp(n/3+1),
c u w1(n/3+1), n/3)
c call gauleg(0.d0, 0.05d0, pp(2*n/3+1), w1(2*n/3+1), n/3)
c else
cc Better behaviour at the border of the intervals:
c call gauleg(0.d0, critp, pp, w1, n/3)
c call gauleg(critp, 2.d0*critp, pp(n/3+1),
c u w1(n/3+1), n/3)
c call gauleg(0.d0, 1.d0/(2.d0*critp), pp(2*n/3+1),
c u w1(2*n/3+1), n/3)
c endif
c endif
c
c Or different (simpler) method, good for V_JKT:
if (energy.le.0.d0) then
critp=tmass/3.d0
else
critp=max(tmass/3.d0,2.d0*dsqrt(energy*tmass))
endif
call gauleg(0.d0, critp, pp, w1, 2*n/3)
call gauleg(1.d0/xpmax, 1.d0/critp, pp(2*n/3+1),
u w1(2*n/3+1), n/3)
c
c Do substitution p => 1/p for the last interval explicitly:
do 10 i=2*n/3+1,n
pp(i) = 1.d0/pp(i)
10 continue
c
c Reorder the arrays for the third interval:
do 20 i=1,n/3
xx(i) = pp(2*n/3+i)
w2(i) = w1(2*n/3+i)
20 continue
do 30 i=1,n/3
pp(n-i+1) = xx(i)
w1(n-i+1) = w2(i)
30 continue
c
c Calculate the integrals a(p) for the given momenta pp(i)
c and store weights and momenta for the output arrays:
do 40 i=1,n
a1(i) = a(pp(i)) !!! FB: can get stuck in original Toppik!
!!! FB: abuse 'np' as a flag to communicate unstable runs
if ( abs(a1(i)) .gt. 1d10 ) then
np = -1
return
endif
xpp(i)=pp(i)
xww(i)=w1(i)
40 continue
do 41 i=n+1,nmax
xpp(i)=0.d0
xww(i)=0.d0
41 continue
c
c Solve the integral-equation by solving a system of algebraic equations:
call sae(pp, w1, bb, a1, n)
c
c (The substitution for the integration to infinity pp => 1/pp
c is done already.)
do 50 i=1,n
zvfct(i)=bb(i)
gg(i) = bb(i)*g0c(pp(i))
cc gg(i) = (1.d0 + bb(i))*g0c(pp(i))
cc Urspruenglich anderes (Minus) VZ hier, dafuer kein Minus mehr bei der
cc Definition des WQs ueber Im G, 2.6.1998, tt.
cc gg(i) = - (1.d0 + bb(i))*g0c(pp(i))
50 continue
c
c Normalisation on R:
const = 8.d0*pi/tmass**2
c
c Proove of the optical theorem for the output values of sae:
c Simply check if sig1 = sig2.
sig1 = 0.d0
sig2 = 0.d0
do 60 i=1,n*2/3
c write(*,*) 'check! p(',i,') = ',pp(i)
cvv
if (pp(i).lt.dcut.and.vflag.eq.1) then
sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i)
cc u *(1.d0+kincov*(pp(i)/tmass)**2)
u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i)))
u )
else
sig1 = sig1 + w1(i)*pp(i)**2*aimag(gg(i))
endif
if (pp(i).lt.dcut.and.kinflg.ne.0) then
sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
u *(1.d0-pp(i)**2/2.d0/tmass**2)
cc u *tmass/dsqrt(tmass**2+pp(i)**2)
xdsdp(i)=pp(i)**2*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
u *(1.d0-pp(i)**2/2.d0/tmass**2)
u /(2.d0*pi**2)*const
else
sig2 = sig2 + w1(i)*pp(i)**2*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
xdsdp(i)=pp(i)**2*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
u /(2.d0*pi**2)*const
endif
c write(*,*) 'xdsdp = ',xdsdp(i)
c write(*,*) 'zvfct = ',zvfct(i)
60 continue
c '*p**2' because of substitution p => 1/p in the integration of p**2*G(p)
c to infinity
do 70 i=n*2/3+1,n
c write(*,*) 'check! p(',i,') = ',pp(i)
cvv
if (pp(i).lt.dcut.and.vflag.eq.1) then
sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i)
cc u *(1.d0+kincov*(pp(i)/tmass)**2)
u *(1.d0+kincov*g0(pp(i))*(pp(i)/tmass)**2/g0c(pp(i)))
u )
else
sig1 = sig1 + w1(i)*pp(i)**4*aimag(gg(i))
endif
if (pp(i).lt.dcut.and.kinflg.ne.0) then
sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
u *(1.d0-pp(i)**2/2.d0/tmass**2)
cc u *tmass/dsqrt(tmass**2+pp(i)**2)
xdsdp(i)=pp(i)**2*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
u *(1.d0-pp(i)**2/2.d0/tmass**2)
u /(2.d0*pi**2)*const
else
sig2 = sig2 + w1(i)*pp(i)**4*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
xdsdp(i)=pp(i)**2*abs(gg(i))**2 *
u tgamma*gtpcor(pp(i),etot)
u /(2.d0*pi**2)*const
endif
c
c write(*,*) 'xdsdp = ',xdsdp(i)
c write(*,*) 'zvfct = ',zvfct(i)
70 continue
do 71 i=n+1,nmax
xdsdp(i)=0.d0
zvfct(i)=(0.d0,0.d0)
71 continue
c
c Normalisation on R:
sig1 = sig1 / (2.d0*pi**2) * const
sig2 = sig2 / (2.d0*pi**2) * const
c
c The results from the momentum space approach finally are:
cc Jetzt Minus hier, 2.6.98, tt.
xim=-sig1
xdi=sig2
c
end
c
c
complex*16 function g0(p)
c
implicit none
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi,energy,vzero,eps,
u p,gtpcor,hmass
integer npot
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
external gtpcor
save
g0=1.d0/cmplx(energy-vzero-p**2/tmass,
u tgamma*gtpcor(p,2.d0*tmass+energy),
u kind=kind(0d0))
end
c
complex*16 function g0c(p)
c
implicit none
complex*16 hypgeo,green,zk,zi,amd2k,aa,bb,cc,zzp,zzm,
u hypp,hypm,g0
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi,energy,vzero,eps,
u p,gtpcor,hmass,
u kincom,kincoa,kincov,xp,xpmax,dcut
integer npot,kinflg,gcflg,vflag
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag
common/mom/ xp,xpmax,dcut
external hypgeo,gtpcor,g0
save
c
if (gcflg.eq.0) then
if (kinflg.eq.0) then
g0c=g0(p)
else if (kinflg.eq.1.and.p.lt.dcut) then
g0c=g0(p)*(1.d0+kincom)+kincoa
else if (kinflg.eq.1.and.p.ge.dcut) then
g0c=g0(p)*(1.d0+kincom)
else if (kinflg.eq.2.and.p.lt.dcut) then
g0c=g0(p)*(1.d0+kincom)+kincoa
else if (kinflg.eq.2.and.p.ge.dcut) then
g0c=g0(p)
else
write(*,*) ' kinflg wrong! Stop.'
stop
endif
else if (gcflg.eq.1) then
zi=(0.d0,1.d0)
zk=-tmass*cmplx(energy,tgamma
u *gtpcor(p,2.d0*tmass+energy),
u kind=kind(0d0))
zk=sqrt(zk)
amd2k=4.d0/3.d0*alphas*tmass/2.d0/zk
aa=(2.d0,0.d0)
bb=(1.d0,0.d0)
cc=2.d0-amd2k
zzp=(1.d0+zi*p/zk)/2.d0
zzm=(1.d0-zi*p/zk)/2.d0
if (abs(zzp).gt.20.d0) then
hypp=(1.d0-zzp)**(-aa)*
u hypgeo(aa,cc-bb,cc,zzp/(zzp-1.d0))
else
hypp=hypgeo(aa,bb,cc,zzp)
endif
if (abs(zzm).gt.20.d0) then
hypm=(1.d0-zzm)**(-aa)*
u hypgeo(aa,cc-bb,cc,zzm/(zzm-1.d0))
else
hypm=hypgeo(aa,bb,cc,zzm)
endif
green=-zi*tmass/(4.d0*p*zk)/(1.d0-amd2k)*(hypp-hypm)
c VZ anders herum als in Andres Konvention, da bei ihm G_0=1/[-E-i G+p^2/m]:
g0c=-green
if (p.gt.1.d3*tmass) then
write(*,*) ' g0cana = ',g0c,' not reliable. Stop.'
stop
endif
else
write(*,*) ' gcflg wrong! Stop.'
stop
endif
c
end
c
c
complex*16 function a(p)
c
implicit none
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi, energy,ETOT,vzero, eps,
$ QCUT,QMAT1,ALR,PCUT,
u p,
u xp,xpmax, xb1,xb2,dcut,ddcut,
u a1, a2, a3, a4,a5,a6,
u adglg1, fretil1, fretil2, fimtil1, fimtil2,
u ALEFVQ, gtpcor, ad8gle, buf,adglg2,
c u xerg,
u kincom,kincoa,kincov,hmass
! complex*16 zapvq1,ZAPVGP
complex*16 ZAPVGP !!! FB
c u ,acomp
integer npot,ILFLAG,kinflg,gcflg,vflag
c
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG
common/ovalco/ pi, energy, vzero, eps, npot
common/mom/ xp,xpmax,dcut
common/g0inf/kincom,kincoa,kincov,kinflg,gcflg,vflag
c
external adglg1, fretil1, fretil2, fimtil1, fimtil2,
! u zapvq1, ALEFVQ, gtpcor,ZAPVGP,ad8gle,adglg2
u ALEFVQ, gtpcor,ZAPVGP,ad8gle,adglg2 !!! FB
c
if ((npot.eq.1).or.(npot.eq.3).or.(npot.eq.4).or.
u (npot.eq.5)) then
c
xp=p
buf=0.d0
c
a1=0.d0
a2=0.d0
a3=0.d0
a4=0.d0
a5=0.d0
a6=0.d0
if (gcflg.eq.0) then
ddcut=xpmax
else if (gcflg.eq.1) then
ddcut=dcut
else
write(*,*) ' gcflg wrong! Stop.'
stop
endif
c
if (2.d0*xp.lt.ddcut) then
xb1=xp
xb2=2.d0*xp
c
c More stable for logarithmically divergent fixed order potentials:
c
a1=adglg1(fretil1, buf, xb1, eps) !!! FB: can get stuck!
a2=adglg1(fimtil1, buf, xb1, eps)
c Slightly unstable:
a3=adglg2(fretil1,xb1,xb2,eps) !!! FB: can get stuck!
c No good:
c a3=adglg1(fretil1,xb1,xb2,eps)
c Not better:
c call adqua(xb1,xb2,fretil1,xerg,eps)
c a3=xerg
c Also not better:
c a1=adglg1(fretil1, buf, xb2, eps)
c
a4=adglg2(fimtil1,xb1,xb2,eps)
c a5 = adglg2(fretil1, xb2, ddcut, eps)
c a6 = adglg2(fimtil1, xb2, ddcut, eps)
a5 = adglg2(fretil2, 1.d0/ddcut, 1.d0/xb2, eps)
a6 = adglg2(fimtil2, 1.d0/ddcut, 1.d0/xb2, eps)
else if (xp.lt.ddcut) then
xb1=xp
xb2=ddcut
a1=adglg1(fretil1, buf, xb1, eps)
a2=adglg1(fimtil1, buf, xb1, eps)
a3=adglg2(fretil1,xb1,xb2,eps)
a4=adglg2(fimtil1,xb1,xb2,eps)
else if (ddcut.le.xp) then
else
write(*,*) ' Constellation not possible! Stop.'
stop
endif
c
a = 1.d0/(4.d0*pi**2)*cmplx(a1+a3+a5,a2+a4+a6,
u kind=kind(0d0))
c
else if (npot.eq.2) then
PCUT=QCUT
ETOT=ENERGY+2*TMASS
a = ZAPVGP(P,ETOT,VZERO-ENERGY,PCUT,EPS)
c acomp = zapvq1(ALEFVQ, p, vzero-energy, gtpcor, eps)
c a = zapvq1(ALEFVQ, p, vzero-energy, gtpcor, eps)
c acomp = acomp/a
c if (abs(acomp-1.d0).gt.1.d-3) then
c write (*,*) 'p=', p
c write (*,*) 'acomp/a=', acomp
c endif
else
write (*,*) ' Potential not implemented! Stop.'
stop
endif
c
end
c
real*8 function fretil1(xk)
implicit none
real*8 xk, freal
external freal
fretil1 = freal(xk)
end
c
real*8 function fretil2(xk)
implicit none
real*8 xk, freal
external freal
fretil2 = freal(1.d0/xk) * xk**(-2)
end
c
real*8 function fimtil1(xk)
implicit none
real*8 xk, fim
external fim
fimtil1 = fim(xk)
end
c
real*8 function fimtil2(xk)
implicit none
real*8 xk, fim
external fim
fimtil2 = fim(1.d0/xk) * xk**(-2)
end
c
real*8 function freal(xk)
implicit none
complex*16 vhat
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi, energy, vzero, eps,
u p,pmax, xk, gtpcor,dcut,hmass
complex*16 g0,g0c
integer npot
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
common/mom/ p,pmax,dcut
external vhat, g0, g0c, gtpcor
c
freal = real(g0c(xk)*vhat(p, xk)) !!! FB: NaN?
end
c
real*8 function fim(xk)
implicit none
complex*16 vhat
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi, energy, vzero, eps,
u p,pmax, xk, gtpcor,dcut,hmass
complex*16 g0,g0c
integer npot
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
common/mom/ p,pmax,dcut
external vhat, g0, g0c, gtpcor
fim = aimag(g0c(xk)*vhat(p, xk))
end
c
c
complex*16 function vhat(p, xk)
c
implicit none
complex*16 zi
real*8
u tmass,tgamma,zmass,alphas,alamb5,
u wmass,wgamma,bmass,GFERMI,
u pi, energy, vzero, eps,
u p, xk,
u cnspot, phiint, phfqcd, AD8GLE,
u pm, xkm, ALPHEF,
u zeta3,cf,ca,tf,xnf,a1,a2,b0,b1,
u cplas,scale,c0,c1,c2,
u cdeltc,cdeltl,cfullc,cfulll,crm2,
u xkpln1st,xkpln2nd,xkpln3rd,
u pp,pmax,dcut,hmass,chiggs
integer npot
parameter(zi=(0.d0,1.d0))
parameter(zeta3=1.20205690316d0,
u cf=4.d0/3.d0,ca=3.d0,tf=1.d0/2.d0,
u xnf=5.d0)
c
external AD8GLE, phfqcd, ALPHEF
c
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
common/pmaxkm/ pm, xkm
common/mom/ pp,pmax,dcut
common/cplcns/cplas,scale,c0,c1,c2,
u cdeltc,cdeltl,cfullc,cfulll,crm2,chiggs
c
b0=11.d0-2.d0/3.d0*xnf
b1=102.d0-38.d0/3.d0*xnf
c
a1=31.d0/9.d0*ca-20.d0/9.d0*tf*xnf
a2=(4343.d0/162.d0+4.d0*pi**2-pi**4/4.d0+
u 22.d0/3.d0*zeta3)*ca**2-
u (1798.d0/81.d0+56.d0/3.d0*zeta3)*ca*tf*xnf-
u (55.d0/3.d0-16.d0*zeta3)*cf*tf*xnf+
u (20.d0/9.d0*tf*xnf)**2
c
pm=p
xkm=xk
cnspot=-4.d0/3.d0*4.d0*pi
c
if (p/xk.le.1.d-5.and.p.le.1.d-5) then
xkpln1st=2.d0
xkpln2nd=-4.d0*dlog(scale/xk)
xkpln3rd=-6.d0*dlog(scale/xk)**2
else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then
xkpln1st=2.d0*(xk/p)**2
xkpln2nd=-4.d0*(xk/p)**2*dlog(scale/p)
xkpln3rd=-6.d0*(xk/p)**2*dlog(scale/p)**2
else
c xkpln1st=xk/p*dlog(dabs((p+xk)/(p-xk)))
xkpln1st=xk/p*(dlog(p+xk)-dlog(dabs(p-xk)))
xkpln2nd=xk/p*(-1.d0)*(dlog(scale/(p+xk))**2-
u dlog(scale/dabs(p-xk))**2)
xkpln3rd=xk/p*(-4.d0/3.d0)*(dlog(scale/(p+xk))**3-
u dlog(scale/dabs(p-xk))**3)
endif
c
if (npot.eq.2) then
if (p/xk.le.1.d-5.and.p.le.1.d-5) then
vhat = 2.d0 * cnspot * ALPHEF(xk)
else if (xk/p.le.1.d-5.and.xk.le.1.d-5) then
vhat = 2.d0 * cnspot * xk**2 / p**2 * ALPHEF(p)
else
phiint = cnspot * (AD8GLE(phfqcd, 0.d0, 0.3d0, 1.d-5)
u +AD8GLE(phfqcd, 0.3d0, 1.d0, 1.d-5))
vhat = xk / p * dlog(dabs((p+xk)/(p-xk))) * phiint
endif
else
if (npot.eq.1) then
c0=1.d0
c1=0.d0
c2=0.d0
else if (npot.eq.3) then
c0=1.d0+alphas/(4.d0*pi)*a1
c1=alphas/(4.d0*pi)*b0
c2=0
else if (npot.eq.4) then
c0=1.d0+alphas/(4.d0*pi)*a1+(alphas/(4.d0*pi))**2*a2
c1=alphas/(4.d0*pi)*b0+
u (alphas/(4.d0*pi))**2*(b1+2.d0*b0*a1)
c2=(alphas/(4.d0*pi))**2*b0**2
else if (npot.eq.5) then
else
write (*,*) ' Potential not implemented! Stop.'
stop
endif
phiint=cnspot*alphas
c
c if ((xk+p).le.dcut) then
c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd)
c u -1.d0/2.d0*(1.d0+2.d0*ca/cf)
c u *(pi*cf*alphas)**2/tmass
c u *xk/p*(p+xk-dabs(xk-p))
c else if (dabs(xk-p).lt.dcut) then
c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd)
c u -1.d0/2.d0*(1.d0+2.d0*ca/cf)
c u *(pi*cf*alphas)**2/tmass
c u *xk/p*(dcut-dabs(xk-p))
c else if (dcut.le.dabs(xk-p)) then
c vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd)
c else
c write(*,*) ' Not possible! Stop.'
c stop
c endif
c
if (max(xk,p).lt.dcut) then
c Coulomb + first + second order corrections:
vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd)
c All other potentials:
u +cdeltc*2.d0*xk**2
u +cdeltl*xk/p/2.d0*(
u (p+xk)**2*(dlog(((p+xk)/scale)**2)-1.d0)-
u (p-xk)**2*(dlog(((p-xk)/scale)**2)-1.d0))
u +cfullc*(p**2+xk**2)*xkpln1st
u +cfulll*(p**2+xk**2)*xk/p/4.d0*
u (dlog(((p+xk)/scale)**2)**2-
u dlog(((p-xk)/scale)**2)**2)
u +crm2*xk/p*(p+xk-dabs(xk-p))
else
vhat=phiint*(c0*xkpln1st+c1*xkpln2nd+c2*xkpln3rd)
endif
endif
c
end
c
c
c
c --- Routines needed for use of phenomenological potentials ---
c
SUBROUTINE INIPHC(INIFLG)
implicit real*8(a-h,o-z)
save
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
common/ovalco/ pi, energy, vzero, eps, npot
COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG
CHARACTER QCTCHR,QMTCHR,ALFCHR
DATA QCUT0/.100d0/,QMT1S/5.0d0/
c
zmass= 91.187d0
if(INIFLG.eq.0) then
c standard set of parameters
ilflag= 1
alphas=.12d0
qcut= qcut0
qmat1= qmt1s
else
c Parameters of QCD potential specified by USER
5 write(*,*) 'QCD coupling at M_z: ALPHAS or LAMBDA ?'
write(*,*) 'A/L :'
read(*,895) ALFCHR
if(ALFCHR.eq.'A'.or.ALFCHR.eq.'a') then
ilflag= 1
write(*,*) 'alpha_s(M_z)= ?'
read(*,*) alphas
elseif(ALFCHR.eq.'L'.or.ALFCHR.eq.'l') then
write(*,*) 'Lambda(nf=5) =?'
read(*,*) alamb5
ilflag= 0
else
write(*,*) '!!! PLEASE TYPE: A OR L !!!'
goto 5
endif
10 write(*,896) qcut0
read(*,895) QCTCHR
if(QCTCHR.eq.'Y'.or.QCTCHR.eq.'y') then
qcut=qcut0
elseif(QCTCHR.eq.'N'.or.QCTCHR.eq.'n') then
write(*,*) 'QCUT (GeV) = ?'
read(*,*) qcut
else
write(*,*) '!!! PLEASE TYPE: Y OR N !!!'
goto 10
endif
15 write(*,902) qmt1s
read(*,895) QMTCHR
if(QMTCHR.eq.'Y'.or.QMTCHR.eq.'y') then
qmat1=qmt1s
elseif(QMTCHR.eq.'N'.or.QMTCHR.eq.'n') then
write(*,*) 'QMAT1 (GeV) = ?'
read(*,*) qmat1
else
write(*,*) '!!! PLEASE TYPE: Y OR N !!!'
goto 15
endif
endif
895 format(1A)
896 format(1x,'Long distance cut off for QCD potential'/
$ 1x,'QCUT = ',f5.4,' GeV. OK ? Y/N')
902 format(1x,
$ 'Matching QCD for NF=5 and Richardson for NF=3 at QMAT1 =',
$ f5.2,' GeV.'/1x,' OK ? Y/N')
end
c
c
real*8 function phfqcd(x)
c integrand over k ?
real*8 pm, xkm, x, ALPHEF
external ALPHEF
common/pmaxkm/ pm, xkm
phfqcd = ALPHEF((pm+xkm)*(dabs(pm-xkm)/(pm+xkm))**x)
end
c
c
FUNCTION ALEFVQ(x)
implicit real*8(a-h,o-z)
external ALPHEF
common/xtr101/ p0
data pi/3.1415926535897930d0/
q= p0*x
ALEFVQ= - 4d0/3* 4*pi*ALPHEF(q)
return
end
C
C
C
C
COMPLEX*16 FUNCTION ZAPVGP(P,ETOT,VME,PCUT,ACC)
C
C A(p,E)= ZAPVGP(P,ETOT,VME,PCUT,ACC)
C for QCD potential VQQBAR(q) and GAMTPE(P,E) - momentum
C dependent width of top quark in t-tbar system.
C 2-dimensional integration
C P - intrinsic momentum of t quark, ETOT - total energy of t-tbar,
C VME=V0-E, where V0-potential at spatial infinity, E=ETOT-2*TMASS,
C PCUT - cut off in momentum space; e.g. for QCD potential
C given by ALPHEF PCUT=QCUT in COMMON/parflg/,
C ACC - accuracy
C external functions: VQQBAR,GAMTPE,ADQUA,AD8GLE,ADGLG1,ADGLG2
C
IMPLICIT REAL*8(A-Z)
EXTERNAL FIN01P,FIN02P,FIN03P,FIN04P,AD8GLE,ADGLG1,ADGLG2
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
COMMON/XTR102/ P0,E0,VMEM,TM,ACC0
DATA PI/3.14159265/,BUF/1D-10/,SMALL/1D-2/
C For Testing only
small = 1.d-1
C
CONST= -TMASS/(8*PI**2*P)
TM= TMASS
ACC0=ACC*SMALL
P0=P
E0=ETOT
VMEM=VME*TMASS
IF(PCUT.LE.P) THEN
XXRE=AD8GLE(FIN01P,BUF,PCUT,ACC)+ADGLG1(FIN01P,PCUT,P,ACC)+
$ ADGLG1(FIN02P,BUF,1/P,ACC)
XXIM=AD8GLE(FIN03P,BUF,PCUT,ACC)+ADGLG1(FIN03P,PCUT,P,ACC)+
$ ADGLG1(FIN04P,BUF,1/P,ACC)
ELSE
XXRE=ADGLG1(FIN01P,BUF,P,ACC)+ADGLG2(FIN01P,P,PCUT,ACC)+
$ AD8GLE(FIN02P,BUF,1/PCUT,ACC)
XXIM=ADGLG1(FIN03P,BUF,P,ACC)+ADGLG2(FIN03P,P,PCUT,ACC)+
$ AD8GLE(FIN04P,BUF,1/PCUT,ACC)
ENDIF
ZAPVGP=CONST*CMPLX(XXRE,XXIM,KIND=KIND(0d0))
END
C
REAL*8 FUNCTION FIN01P(Q)
C this segment contains FIN01P,FIN02P,FIN03P,FIN04P
IMPLICIT REAL*8(A-C,D-H,O-Z)
EXTERNAL VQQBAR,FIN11P, FIN12P
COMMON/XTR102/ P0,E0,VMEM,TM,ACC0
DATA PI/3.14159265/,BUF/1d-10/
Q0=Q
XL=(P0-Q0)**2
XU=(P0+Q0)**2
CALL ADQUA(XL,XU,FIN11P,Y,ACC0)
FIN01P= VQQBAR(Q0)*Q0*Y
RETURN
ENTRY FIN02P(Q)
Q0=1/Q
XL=(P0-Q0)**2
XU=(P0+Q0)**2
CALL ADQUA(XL,XU,FIN11P,Y,ACC0)
FIN02P= VQQBAR(Q0)*Q0**3*Y
RETURN
ENTRY FIN03P(Q)
Q0=Q
XL=(P0-Q0)**2
XU=(P0+Q0)**2
CALL ADQUA(XL,XU,FIN12P,Y,ACC0)
FIN03P= VQQBAR(Q0)*Q0*Y
RETURN
ENTRY FIN04P(Q)
Q0=1/Q
XL=(P0-Q0)**2
XU=(P0+Q0)**2
CALL ADQUA(XL,XU,FIN12P,Y,ACC0)
FIN04P= VQQBAR(Q0)*Q0**3*Y
END
REAL*8 FUNCTION FIN11P(T)
C this segment contains FIN11P,FIN12P
IMPLICIT REAL*8(A-C,D-H,O-Z)
EXTERNAL GAMTPE
COMMON/XTR102/ P0,E0,VMEM,TM,ACC0
T1= T+VMEM
TSQRT= SQRT(T)
GAMMA= TM*GAMTPE(TSQRT,E0)
FIN11P= T1/(T1**2+GAMMA**2)
RETURN
ENTRY FIN12P(T)
T1= T+VMEM
TSQRT= SQRT(T)
GAMMA= TM*GAMTPE(TSQRT,E0)
FIN12P= GAMMA/(T1**2+GAMMA**2)
END
C
c
SUBROUTINE VQDELT(VQ)
c
c evaluates constants multiplying Dirac delta in potentials VQCUT
c calls: ADQUA
c
implicit real*8(a-h,o-z)
external alphef,fncqct
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG
data pi/3.141592653589793238D0/
c
call adqua(1d-8,1d4,fncqct,y,1d-4)
v=-4d0/3*2/pi*y
VQ=(-.25-v)*(2*pi)**3
end
c
function fncqct(q)
implicit real*8(a-h,o-z)
fncqct=sin(q)/q*alphef(q)
end
c
C
REAL*8 FUNCTION VQQBAR(P)
C
C interquark potential for q- qbar singlet state
C
IMPLICIT REAL*8(A-C,D-H,O-Z)
EXTERNAL ALPHEF
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
DATA PI/3.14159265/
VQQBAR = -4D0/3*4*PI*ALPHEF(P)/P**2
END
C
FUNCTION ALPHEF(q)
c
c V(q) = -4/3 * 4*pi*ALPHEF(q)/q**2
c input: alphas or alamb5 in COMMON/PHCONS/. If:
c ILFLAG.EQ.0 alamb5= \Lambda_\{\bar MS}^{(5)} at M_z
c ILFLAG.EQ.1 alphas = alpha_{strong} at M_z (91.161)
c
c effective coupling ALPHEF is defined as follows:
c for q > qmat1=m_b:
c alphas*( 1 +(31/3-10*nf/9)*alphas/(4*pi) )
c where alphas=\alpha_\bar{MS} for nf=5, i.e.
c alpha=4*pi/( b0(nf=5)*x + b1(5)/b0(5)*ln(x) )
c and x = ln(q**2/alamb5**2)
c for qmat1 > q > qcut:
c 4*pi/b0(nefr=3)*(alfmt+1/log(1+q**2/alr**2))
c where alr=.4 GeV, nefr=3, and continuity --> alfmt
c below qcut: alphrc*2*q**2/(q**2+qcut**2) (cont.-->alphrc)
c
implicit real*8(a-h,o-z)
SAVE
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG
common/parpot/ a5,b5,c5,alfmt,d,alphrc
data pi/3.141592653589793238D0/,
$ zold/-1d0/,qctold/-1d0/,alfold/-1d0/,
$olmbd/-1d0/
c
if(zmass.le.0d0 .or. qcut.le.0d0) STOP 10001
if(zold.ne.zmass .or. qcut.ne.qctold) num=0
if(ilflag.eq.0 .and. olmbd.ne.alamb5) num=0
if(ilflag.eq.1 .and. alfold.ne.alphas) num=0
if(num.eq.0)then
num=num+1
zold=zmass
qctold=qcut
call potpar
alfold= alphas
olmbd= alamb5
endif
if(q.le.qcut) then
alphef=alphrc*(2*q**2)/(qcut**2+q**2)
elseif(q.le.qmat1) then
alphef=alfmt+d/log(1+q**2/alr**2)
else
x=2*log(q/alamb5)
alfas5=1/(a5*x+b5*log(x))
alphef=alfas5*(1+c5*alfas5)
endif
end
c
c Only called by ALPHEF:
SUBROUTINE POTPAR
implicit real*8(a-h,o-z)
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
COMMON/PARFLG/ QCUT,QMAT1,ALR,ILFLAG
common/parpot/ a5,b5,c5,alfmt,d,alphrc
data pi/3.141592653589793238D0/,nefr/3/
b0(nf)=11-2./3*nf
b1(nf)=102-38./3*nf
cn(nf)=31./3-10./9*nf
alr=400d-3
a5=b0(5)/(4*pi)
b5=b1(5)/b0(5)/(4*pi)
c5=cn(5)/(4*pi)
d=4*pi/b0(nefr)
if(ilflag.eq.0) then
if(alamb5.le.0d0) STOP 10002
xa=2*log(zmass/alamb5)
alphas= 1/(a5*xa + b5*log(xa))
else
if(alphas.le.0d0) STOP 10003
t0=0
t1=max(1d0,alphas*a5)
10 tm=(t0+t1)/2
fm=tm/alphas+b5*tm*log(tm)-a5
if(fm.lt.-1d-10) then
t0=tm
goto 10
elseif(fm.gt.1d-10) then
t1=tm
goto 10
endif
alamb5=zmass*exp(-5d-1/tm)
endif
x=2*log(qmat1/alamb5)
alfas=1/(a5*x+b5*log(x))
alfmt=alfas*(1+c5*alfas)-d/log(1+qmat1**2/alr**2)
alphrc=alfmt+ d/log(1+qcut**2/alr**2)
return
end
c
c --- End of routines for phenomenological potentials ---
c
c
c --- Routines for Gamma_top ---
C
SUBROUTINE GAMMAT
C
C on shell width of top quark including QCD corrections, c.f.
C M.Jezabek and J.H. Kuhn, Nucl. Phys. B314(1989)1
C
IMPLICIT REAL*8(A-C,D-H,O-Z)
- EXTERNAL DILOG
+ EXTERNAL DILOGG
COMMON/PHCONS/TMASS,TGAMMA,ZMASS,ALPHAS,ALAMB5,
$ WMASS,WGAMMA,BMASS,GFERMI,hmass
DATA PI/3.14159265/
- F(X)= PI**2+2*DILOG(X)-2*DILOG(1-X)+( 4*X*(1-X-2*X**2)*LOG(X)+
+ 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 DILOG(X)
+ 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 DILOG=1.644934066848226
+ 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
- DILOG=S*T*(A-B)+Z
+ 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
@
<<[[ttv_formfactors.f90]]>>=
<<File header>>
module ttv_formfactors
use kinds
<<Use debug>>
use constants
use numeric_utils
use physics_defs, only: CF, CA, TR
use sm_physics
use lorentz
use interpolation
use nr_tools
use io_units, only: free_unit, given_output_unit
use string_utils
use iso_varying_string, string_t => varying_string
use system_dependencies
use, intrinsic :: iso_fortran_env !NODEP!
use diagnostics
<<Standard module head>>
save
<<ttv formfactors: public>>
<<ttv formfactors: parameters>>
<<ttv formfactors: types>>
<<ttv formfactors: global variables>>
<<ttv formfactors: interfaces>>
contains
<<ttv formfactors: procedures>>
end module ttv_formfactors
@ %def ttv_formfactors
@
<<ttv formfactors: public>>=
public :: onshell_projection_t
<<ttv formfactors: types>>=
type :: onshell_projection_t
logical :: production
logical :: decay
logical :: width
logical :: boost_decay
contains
<<ttv formfactors: onshell projection: TBP>>
end type onshell_projection_t
@ %def onshell_projection_t
@
<<ttv formfactors: onshell projection: TBP>>=
procedure :: debug_write => onshell_projection_debug_write
<<ttv formfactors: procedures>>=
subroutine onshell_projection_debug_write (onshell_projection)
class(onshell_projection_t), intent(in) :: onshell_projection
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%production", &
onshell_projection%production)
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%decay", &
onshell_projection%decay)
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%width", &
onshell_projection%width)
if (debug_on) call msg_debug (D_THRESHOLD, "onshell_projection%boost_decay", &
onshell_projection%boost_decay)
end subroutine onshell_projection_debug_write
@ %def onshell_projection_debug_write
@
<<ttv formfactors: onshell projection: TBP>>=
procedure :: set_all => onshell_projection_set_all
<<ttv formfactors: procedures>>=
pure subroutine onshell_projection_set_all (onshell_projection, flag)
class(onshell_projection_t), intent(inout) :: onshell_projection
logical, intent(in) :: flag
onshell_projection%production = flag
onshell_projection%decay = flag
end subroutine onshell_projection_set_all
@ %def onshell_projection_set_all
@
<<ttv formfactors: onshell projection: TBP>>=
procedure :: active => onshell_projection_active
<<ttv formfactors: procedures>>=
pure function onshell_projection_active (onshell_projection) result (active)
logical :: active
class(onshell_projection_t), intent(in) :: onshell_projection
active = onshell_projection%production .or. &
onshell_projection%decay
end function onshell_projection_active
@ %def onshell_projection_active
@
<<ttv formfactors: types>>=
type :: helicity_approximation_t
logical :: simple = .false.
logical :: extra = .false.
logical :: ultra = .false.
contains
<<ttv formfactors: helicity approximation: TBP>>
end type helicity_approximation_t
@ %def helicity_approximation_t
@
<<ttv formfactors: public>>=
public :: settings_t
<<ttv formfactors: types>>=
type :: settings_t
! look what is set by initialized_parameters, bundle them in a class and rename to initialized
logical :: initialized_parameters
! this belongs to init_threshold_phase_space_grid in phase_space_grid_t
logical :: initialized_ps
! this belongs to the ff_grid_t, its usefulness is doubtful
logical :: initialized_ff
logical :: mpole_dynamic
integer :: offshell_strategy
logical :: factorized_computation
logical :: interference
logical :: only_interference_term
logical :: nlo
logical :: no_nlo_width_in_signal_propagators
logical :: force_minus_one
logical :: flip_relative_sign
integer :: sel_hel_top = 0
integer :: sel_hel_topbar = 0
logical :: Z_disabled
type(onshell_projection_t) :: onshell_projection
type(helicity_approximation_t) :: helicity_approximation
contains
<<ttv formfactors: settings: TBP>>
end type settings_t
@ %def settings_t
@
<<ttv formfactors: settings: TBP>>=
procedure :: setup_flags => settings_setup_flags
<<ttv formfactors: procedures>>=
! TODO: (bcn 2016-03-21) break this up into a part regarding the
! FF grid and a part regarding the settings
subroutine settings_setup_flags (settings, ff_in, offshell_strategy_in, &
top_helicity_selection)
class(settings_t), intent(inout) :: settings
integer, intent(in) :: ff_in, offshell_strategy_in, top_helicity_selection
logical :: bit_top, bit_topbar
!!! RESUMMED_SWITCHOFF = - 2
!!! MATCHED = -1, &
SWITCHOFF_RESUMMED = ff_in < 0
TOPPIK_RESUMMED = ff_in <= 1
settings%nlo = btest(offshell_strategy_in, 0)
settings%factorized_computation = btest(offshell_strategy_in, 1)
settings%interference = btest(offshell_strategy_in, 2)
call settings%onshell_projection%set_all(btest(offshell_strategy_in, 3))
settings%no_nlo_width_in_signal_propagators = btest(offshell_strategy_in, 4)
settings%helicity_approximation%simple = btest(offshell_strategy_in, 5)
if (.not. settings%onshell_projection%active ()) then
settings%onshell_projection%production = btest(offshell_strategy_in, 6)
settings%onshell_projection%decay = btest(offshell_strategy_in, 7)
end if
settings%onshell_projection%width = .not. btest(offshell_strategy_in, 8)
settings%onshell_projection%boost_decay = btest(offshell_strategy_in, 9)
settings%helicity_approximation%extra = btest(offshell_strategy_in, 10)
settings%force_minus_one = btest(offshell_strategy_in, 11)
settings%flip_relative_sign = btest(offshell_strategy_in, 12)
if (top_helicity_selection > -1) then
settings%helicity_approximation%ultra = .true.
bit_top = btest (top_helicity_selection, 0)
bit_topbar = btest (top_helicity_selection, 1)
if (bit_top) then
settings%sel_hel_top = 1
else
settings%sel_hel_top = -1
end if
if (bit_topbar) then
settings%sel_hel_topbar = 1
else
settings%sel_hel_topbar = -1
end if
end if
settings%only_interference_term = btest(offshell_strategy_in, 14)
settings%Z_disabled = btest(offshell_strategy_in, 15)
if (ff_in == MATCHED .or. ff_in == MATCHED_NOTSOHARD) then
settings%onshell_projection%width = .true.
settings%onshell_projection%production = .true.
settings%onshell_projection%decay = .true.
settings%factorized_computation = .true.
settings%interference = .true.
settings%onshell_projection%boost_decay = .true.
end if
if (debug_on) call msg_debug (D_THRESHOLD, "SWITCHOFF_RESUMMED", SWITCHOFF_RESUMMED)
if (debug_on) call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED)
if (debug_active (D_THRESHOLD)) &
call settings%write ()
end subroutine settings_setup_flags
@ %def settings_setup_flags
@
<<ttv formfactors: settings: TBP>>=
procedure :: write => settings_write
<<ttv formfactors: procedures>>=
subroutine settings_write (settings, unit)
class(settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, '(A,L1)') "settings%helicity_approximation%simple = ", &
settings%helicity_approximation%simple
write (u, '(A,L1)') "settings%helicity_approximation%extra = ", &
settings%helicity_approximation%extra
write (u, '(A,L1)') "settings%helicity_approximation%ultra = ", &
settings%helicity_approximation%ultra
write (u, '(A,L1)') "settings%initialized_parameters = ", &
settings%initialized_parameters
write (u, '(A,L1)') "settings%initialized_ps = ", &
settings%initialized_ps
write (u, '(A,L1)') "settings%initialized_ff = ", &
settings%initialized_ff
write (u, '(A,L1)') "settings%mpole_dynamic = ", &
settings%mpole_dynamic
write (u, '(A,I5)') "settings%offshell_strategy = ", &
settings%offshell_strategy
write (u, '(A,L1)') "settings%factorized_computation = ", &
settings%factorized_computation
write (u, '(A,L1)') "settings%interference = ", settings%interference
write (u, '(A,L1)') "settings%only_interference_term = ", &
settings%only_interference_term
write (u, '(A,L1)') "settings%Z_disabled = ", &
settings%Z_disabled
write (u, '(A,L1)') "settings%nlo = ", settings%nlo
write (u, '(A,L1)') "settings%no_nlo_width_in_signal_propagators = ", &
settings%no_nlo_width_in_signal_propagators
write (u, '(A,L1)') "settings%force_minus_one = ", settings%force_minus_one
write (u, '(A,L1)') "settings%flip_relative_sign = ", settings%flip_relative_sign
call settings%onshell_projection%debug_write ()
end subroutine settings_write
@ %def settings_write
@
<<ttv formfactors: settings: TBP>>=
procedure :: use_nlo_width => settings_use_nlo_width
<<ttv formfactors: procedures>>=
pure function settings_use_nlo_width (settings, ff) result (nlo)
logical :: nlo
class(settings_t), intent(in) :: settings
integer, intent(in) :: ff
nlo = settings%nlo
end function settings_use_nlo_width
@ %def settings_use_nlo_width
@
<<ttv formfactors: public>>=
public :: formfactor_t
<<ttv formfactors: types>>=
type :: formfactor_t
logical :: active
contains
<<ttv formfactors: formfactor: TBP>>
end type formfactor_t
@ %def formfactor_t
@
<<ttv formfactors: formfactor: TBP>>=
procedure :: activate => formfactor_activate
<<ttv formfactors: procedures>>=
pure subroutine formfactor_activate (formfactor)
class(formfactor_t), intent(inout) :: formfactor
formfactor%active = .true.
end subroutine formfactor_activate
@ %def formfactor_activate
@
<<ttv formfactors: formfactor: TBP>>=
procedure :: disable => formfactor_disable
<<ttv formfactors: procedures>>=
pure subroutine formfactor_disable (formfactor)
class(formfactor_t), intent(inout) :: formfactor
formfactor%active = .false.
end subroutine formfactor_disable
@ %def formfactor_disable
@ This function actually returns $\tilde{F}$, i.e. $F-1$.
<<ttv formfactors: formfactor: TBP>>=
procedure :: compute => formfactor_compute
<<ttv formfactors: procedures>>=
function formfactor_compute (formfactor, ps, vec_type, FF_mode) result (FF)
complex(default) :: FF
class(formfactor_t), intent(in) :: formfactor
type(phase_space_point_t), intent(in) :: ps
integer, intent(in) :: vec_type, FF_mode
real(default) :: f
if (threshold%settings%initialized_parameters .and. formfactor%active) then
select case (FF_mode)
case (MATCHED, MATCHED_NOTSOHARD, RESUMMED, RESUMMED_SWITCHOFF)
FF = resummed_formfactor (ps, vec_type) - one
case (MATCHED_EXPANDED)
f = f_switch_off (v_matching (ps%sqrts, GAM_M1S))
FF = - expanded_formfactor (f * AS_HARD, f * AS_HARD, ps, vec_type) &
+ resummed_formfactor (ps, vec_type)
case (MATCHED_EXPANDED_NOTSOHARD)
f = f_switch_off (v_matching (ps%sqrts, GAM_M1S))
FF = - expanded_formfactor (f * alphas_notsohard (ps%sqrts), f * &
alphas_notsohard (ps%sqrts), ps, vec_type) &
+ resummed_formfactor (ps, vec_type)
case (EXPANDED_HARD)
FF = expanded_formfactor (AS_HARD, AS_HARD, ps, vec_type) - one
case (EXPANDED_NOTSOHARD)
FF = expanded_formfactor (alphas_notsohard (ps%sqrts), &
alphas_notsohard (ps%sqrts), ps, vec_type) - one
case (EXPANDED_SOFT)
FF = expanded_formfactor (AS_HARD, alphas_soft (ps%sqrts), ps, &
vec_type) - one
case (EXPANDED_SOFT_SWITCHOFF)
f = f_switch_off (v_matching (ps%sqrts, GAM_M1S))
FF = expanded_formfactor (f * AS_HARD, &
f * alphas_soft (ps%sqrts), ps, vec_type) - one
case (RESUMMED_ANALYTIC_LL)
FF = formfactor_LL_analytic (alphas_soft (ps%sqrts), ps%sqrts, &
ps%p, vec_type) - one
case (TREE)
FF = zero
case default
FF = zero
end select
else
FF = zero
end if
if (debug2_active (D_THRESHOLD)) then
call update_global_sqrts_dependent_variables (ps%sqrts)
call msg_debug2 (D_THRESHOLD, "threshold%settings%initialized_parameters", threshold%settings%initialized_parameters)
call msg_debug2 (D_THRESHOLD, "formfactor%active", formfactor%active)
call msg_debug2 (D_THRESHOLD, "FF_mode", FF_mode)
call msg_debug2 (D_THRESHOLD, "FF", FF)
call msg_debug2 (D_THRESHOLD, "v", sqrts_to_v (ps%sqrts, GAM))
call msg_debug2 (D_THRESHOLD, "vec_type", vec_type)
call ps%write ()
end if
end function formfactor_compute
@ %def formfactor_compute
@
<<ttv formfactors: public>>=
public :: width_t
<<ttv formfactors: types>>=
type :: width_t
real(default) :: aem
real(default) :: sw
real(default) :: mw
real(default) :: mb
real(default) :: vtb
real(default) :: gam_inv
contains
<<ttv formfactors: width: TBP>>
end type width_t
@ %def width_t
@
<<ttv formfactors: width: TBP>>=
procedure :: init => width_init
<<ttv formfactors: procedures>>=
pure subroutine width_init (width, aemi, sw, mw, mb, vtb, gam_inv)
class(width_t), intent(inout) :: width
real(default), intent(in) :: aemi, sw, mw, mb, vtb, gam_inv
width%aem = one / aemi
width%sw = sw
width%mw = mw
width%mb = mb
width%vtb = vtb
width%gam_inv = gam_inv
end subroutine width_init
@ %def width_init
@
<<ttv formfactors: width: TBP>>=
procedure :: compute => width_compute
<<ttv formfactors: procedures>>=
pure function width_compute (width, top_mass, sqrts, initial) result (gamma)
real(default) :: gamma
class(width_t), intent(in) :: width
real(default), intent(in) :: top_mass, sqrts
logical, intent(in), optional :: initial
real(default) :: alphas
logical :: ini
ini = .false.; if (present (initial)) ini = initial
if (ini) then
alphas = AS_HARD
else
alphas = alphas_notsohard (sqrts)
end if
if (threshold%settings%nlo) then
gamma = top_width_sm_qcd_nlo_jk (width%aem, width%sw, width%vtb, &
top_mass, width%mw, width%mb, alphas) + width%gam_inv
else
gamma = top_width_sm_lo (width%aem, width%sw, width%vtb, top_mass, &
width%mw, width%mb) + width%gam_inv
end if
end function width_compute
@ %def width_compute
@ Use singleton pattern instead of global variables. At least shows
where the variables are from.
<<ttv formfactors: public>>=
public :: threshold
<<ttv formfactors: global variables>>=
type(threshold_t) :: threshold
<<ttv formfactors: public>>=
public :: threshold_t
<<ttv formfactors: types>>=
type :: threshold_t
type(settings_t) :: settings
type(formfactor_t) :: formfactor
type(width_t) :: width
contains
<<ttv formfactors: threshold: TBP>>
end type threshold_t
@ %def threshold_t
@
<<ttv formfactors: parameters>>=
integer, parameter :: VECTOR = 1
integer, parameter :: AXIAL = 2
integer, parameter, public :: MATCHED_EXPANDED_NOTSOHARD = -5, &
MATCHED_NOTSOHARD = -4, &
MATCHED_EXPANDED = - 3, &
RESUMMED_SWITCHOFF = - 2, &
MATCHED = -1, &
RESUMMED = 1, &
EXPANDED_HARD = 4, &
EXPANDED_SOFT = 5, &
EXPANDED_SOFT_SWITCHOFF = 6, &
RESUMMED_ANALYTIC_LL = 7, &
EXPANDED_NOTSOHARD = 8, &
TREE = 9
real(default), parameter :: NF = 5.0_default
real(default), parameter :: z3 = 1.20205690315959428539973816151_default
real(default), parameter :: A1 = 31./9.*CA - 20./9.*TR*NF
real(default), parameter :: A2 = (4343./162. + 4.*pi**2 - pi**4/4. + &
22./3.*z3)*CA**2 - (1798./81. + 56./3.*z3)*CA*TR*NF - &
(55./3. - 16.*z3)*CF*TR*NF + (20./9.*TR*NF)**2
complex(default), parameter :: ieps = imago*tiny_10
@ [[gam_m1s]] is only used for the scale nustar
<<ttv formfactors: public>>=
public :: GAM, GAM_M1S
<<ttv formfactors: global variables>>=
real(default) :: M1S, GAM, GAM_M1S
integer :: NRQCD_ORDER
real(default) :: MTPOLE = - one
real(default) :: mtpole_init
real(default) :: RESCALE_H, MU_HARD, AS_HARD
real(default) :: AS_MZ, MASS_Z
real(default) :: MU_USOFT, AS_USOFT
@ [[NUSTAR_FIXED]] is normally not used
<<ttv formfactors: public>>=
public :: AS_SOFT
public :: AS_LL_SOFT
public :: AS_USOFT
public :: AS_HARD
public :: SWITCHOFF_RESUMMED
public :: TOPPIK_RESUMMED
<<ttv formfactors: global variables>>=
real(default) :: RESCALE_F, MU_SOFT, AS_SOFT, AS_LL_SOFT, NUSTAR_FIXED
logical :: NUSTAR_DYNAMIC, SWITCHOFF_RESUMMED, TOPPIK_RESUMMED
real(default) :: B0
real(default) :: B1
real(default), dimension(2) :: aa2, aa3, aa4, aa5, aa8, aa0
character(len=200) :: parameters_ref
type(nr_spline_t) :: ff_p_spline
real(default) :: v1, v2
integer :: POINTS_SQ, POINTS_P, POINTS_P0, n_q
real(default), dimension(:), allocatable :: sq_grid, p_grid, p0_grid, q_grid
complex(default), dimension(:,:,:,:), allocatable :: ff_grid
complex(single), dimension(:,:,:,:,:), allocatable :: Vmatrix
@ Explicit range and step size of the sqrts-grid relative to 2*M1S:
<<ttv formfactors: global variables>>=
real(default) :: sqrts_min, sqrts_max, sqrts_it
@
<<ttv formfactors: interfaces>>=
interface char
module procedure int_to_char, real_to_char, complex_to_char, logical_to_char
end interface char
<<ttv formfactors: public>>=
public :: m1s_to_mpole
@
<<ttv formfactors: types>>=
type, public :: phase_space_point_t
real(default) :: p2 = 0, k2 = 0, q2 = 0
real(default) :: sqrts = 0, p = 0, p0 = 0
real(default) :: mpole = 0, en = 0
logical :: inside_grid = .false., onshell = .false.
contains
<<ttv formfactors: phase space point: TBP>>
end type phase_space_point_t
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: init => phase_space_point_init_rel
<<ttv formfactors: procedures>>=
pure subroutine phase_space_point_init_rel (ps_point, p2, k2, q2, m)
class(phase_space_point_t), intent(inout) :: ps_point
real(default), intent(in) :: p2
real(default), intent(in) :: k2
real(default), intent(in) :: q2
real(default), intent(in), optional :: m
ps_point%p2 = p2
ps_point%k2 = k2
ps_point%q2 = q2
call rel_to_nonrel (p2, k2, q2, ps_point%sqrts, ps_point%p, ps_point%p0)
ps_point%mpole = m1s_to_mpole (ps_point%sqrts)
ps_point%en = sqrts_to_en (ps_point%sqrts)
ps_point%inside_grid = sqrts_within_range (ps_point%sqrts)
if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m)
end subroutine phase_space_point_init_rel
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: init_nonrel => phase_space_point_init_nonrel
<<ttv formfactors: procedures>>=
pure subroutine phase_space_point_init_nonrel (ps_point, sqrts, p, p0, m)
class(phase_space_point_t), intent(inout) :: ps_point
real(default), intent(in) :: sqrts
real(default), intent(in) :: p
real(default), intent(in) :: p0
real(default), intent(in), optional :: m
ps_point%sqrts = sqrts
ps_point%p = p
ps_point%p0 = p0
call nonrel_to_rel (sqrts, p, p0, ps_point%p2, ps_point%k2, ps_point%q2)
ps_point%mpole = m1s_to_mpole (sqrts)
ps_point%en = sqrts_to_en (sqrts, ps_point%mpole)
ps_point%inside_grid = sqrts_within_range (sqrts)
if ( present(m) ) ps_point%onshell = ps_point%is_onshell (m)
end subroutine phase_space_point_init_nonrel
@
<<ttv formfactors: procedures>>=
!!! convert squared 4-momenta into sqrts, p0 = E_top-sqrts/2 and abs. 3-momentum p
pure subroutine rel_to_nonrel (p2, k2, q2, sqrts, p, p0)
real(default), intent(in) :: p2
real(default), intent(in) :: k2
real(default), intent(in) :: q2
real(default), intent(out) :: sqrts
real(default), intent(out) :: p
real(default), intent(out) :: p0
sqrts = sqrt(q2)
p0 = abs(p2 - k2) / (2. * sqrts)
p = sqrt (0.5_default * (- p2 - k2 + sqrts**2/2. + 2.* p0**2))
end subroutine rel_to_nonrel
@
<<ttv formfactors: procedures>>=
!!! convert sqrts, p0 = E_top-sqrts/2 and abs. 3-momentum p into squared 4-momenta
pure subroutine nonrel_to_rel (sqrts, p, p0, p2, k2, q2)
real(default), intent(in) :: sqrts
real(default), intent(in) :: p
real(default), intent(in) :: p0
real(default), intent(out) :: p2
real(default), intent(out) :: k2
real(default), intent(out) :: q2
p2 = (sqrts/2.+p0)**2 - p**2
k2 = (sqrts/2.-p0)**2 - p**2
q2 = sqrts**2
end subroutine nonrel_to_rel
@
<<ttv formfactors: procedures>>=
pure function complex_m2 (m, w) result (m2c)
real(default), intent(in) :: m
real(default), intent(in) :: w
complex(default) :: m2c
m2c = m**2 - imago*m*w
end function complex_m2
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: is_onshell => phase_space_point_is_onshell
<<ttv formfactors: procedures>>=
pure function phase_space_point_is_onshell (ps_point, m) result (flag)
logical :: flag
class(phase_space_point_t), intent(in) :: ps_point
real(default), intent(in) :: m
flag = nearly_equal (ps_point%p2 , m**2, rel_smallness=1E-5_default) .and. &
nearly_equal (ps_point%k2 , m**2, rel_smallness=1E-5_default)
end function phase_space_point_is_onshell
@
<<ttv formfactors: phase space point: TBP>>=
procedure :: write => phase_space_point_write
<<ttv formfactors: procedures>>=
subroutine phase_space_point_write (psp, unit)
class(phase_space_point_t), intent(in) :: psp
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, '(A)') char ("p2 = " // str (psp%p2))
write (u, '(A)') char ("k2 = " // str (psp%k2))
write (u, '(A)') char ("q2 = " // str (psp%q2))
write (u, '(A)') char ("sqrts = " // str (psp%sqrts))
write (u, '(A)') char ("p = " // str (psp%p))
write (u, '(A)') char ("p0 = " // str (psp%p0))
write (u, '(A)') char ("mpole = " // str (psp%mpole))
write (u, '(A)') char ("en = " // str (psp%en))
write (u, '(A)') char ("inside_grid = " // str (psp%inside_grid))
write (u, '(A)') char ("onshell = " // str (psp%onshell))
end subroutine phase_space_point_write
@ %def phase_space_point_write
@
<<ttv formfactors: procedures>>=
function set_nrqcd_order (nrqcd_order_in) result (nrqcdorder)
integer :: nrqcdorder
real(default), intent(in) :: nrqcd_order_in
nrqcdorder = 1
if ( int(nrqcd_order_in) > nrqcdorder ) then
call msg_warning ("reset to highest available NRQCD_ORDER = " // char(nrqcdorder))
else
nrqcdorder = int(nrqcd_order_in)
end if
end function set_nrqcd_order
@ %def set_nrqcd_order
@
<<ttv formfactors: public>>=
public :: init_parameters
<<ttv formfactors: procedures>>=
subroutine init_parameters (mpole_out, gam_out, m1s_in, Vtb, gam_inv, &
aemi, sw, az, mz, mw, mb, h_in, f_in, nrqcd_order_in, ff_in, &
offshell_strategy_in, v1_in, v2_in, scan_sqrts_min, &
scan_sqrts_max, scan_sqrts_stepsize, mpole_fixed, top_helicity_selection)
real(default), intent(out) :: mpole_out
real(default), intent(out) :: gam_out
real(default), intent(in) :: m1s_in
real(default), intent(in) :: Vtb
real(default), intent(in) :: gam_inv
real(default), intent(in) :: aemi
real(default), intent(in) :: sw
real(default), intent(in) :: az
real(default), intent(in) :: mz
real(default), intent(in) :: mw
real(default), intent(in) :: mb
real(default), intent(in) :: h_in
real(default), intent(in) :: f_in
real(default), intent(in) :: nrqcd_order_in
real(default), intent(in) :: ff_in
real(default), intent(in) :: offshell_strategy_in
real(default), intent(in) :: v1_in
real(default), intent(in) :: v2_in
real(default), intent(in) :: scan_sqrts_min
real(default), intent(in) :: scan_sqrts_max
real(default), intent(in) :: scan_sqrts_stepsize
logical, intent(in) :: mpole_fixed
real(default), intent(in) :: top_helicity_selection
if (debug_active (D_THRESHOLD)) call show_input()
threshold%settings%initialized_parameters = .false.
M1S = m1s_in
threshold%settings%mpole_dynamic = .not. mpole_fixed
threshold%settings%offshell_strategy = int (offshell_strategy_in)
call threshold%settings%setup_flags (int(ff_in), &
threshold%settings%offshell_strategy, &
int (top_helicity_selection))
NRQCD_ORDER = set_nrqcd_order (nrqcd_order_in)
v1 = v1_in
v2 = v2_in
sqrts_min = scan_sqrts_min
sqrts_max = scan_sqrts_max
sqrts_it = scan_sqrts_stepsize
!!! global hard parameters incl. hard alphas used in all form factors
RESCALE_H = h_in
MU_HARD = M1S * RESCALE_H
AS_MZ = az
MASS_Z = mz
AS_HARD = running_as (MU_HARD, az, mz, 2, NF)
call threshold%width%init (aemi, sw, mw, mb, vtb, gam_inv)
GAM_M1S = threshold%width%compute (M1S, zero, initial=.true.)
call compute_global_auxiliary_numbers ()
!!! soft parameters incl. mtpole
!!! (depend on sqrts: initialize with sqrts ~ 2*M1S)
NUSTAR_FIXED = - one
NUSTAR_DYNAMIC = NUSTAR_FIXED < zero
RESCALE_F = f_in
call update_global_sqrts_dependent_variables (2. * M1S)
mtpole_init = MTPOLE
mpole_out = mtpole_init
gam_out = GAM
threshold%settings%initialized_parameters = .true.
contains
<<ttv formfactors: init parameters: subroutines>>
end subroutine init_parameters
@
<<ttv formfactors: init parameters: subroutines>>=
subroutine show_input()
if (debug_on) call msg_debug (D_THRESHOLD, "init_parameters")
if (debug_on) call msg_debug (D_THRESHOLD, "m1s_in", m1s_in)
if (debug_on) call msg_debug (D_THRESHOLD, "Vtb", Vtb)
if (debug_on) call msg_debug (D_THRESHOLD, "gam_inv", gam_inv)
if (debug_on) call msg_debug (D_THRESHOLD, "aemi", aemi)
if (debug_on) call msg_debug (D_THRESHOLD, "sw", sw)
if (debug_on) call msg_debug (D_THRESHOLD, "az", az)
if (debug_on) call msg_debug (D_THRESHOLD, "mz", mz)
if (debug_on) call msg_debug (D_THRESHOLD, "mw", mw)
if (debug_on) call msg_debug (D_THRESHOLD, "mb", mb)
if (debug_on) call msg_debug (D_THRESHOLD, "h_in", h_in)
if (debug_on) call msg_debug (D_THRESHOLD, "f_in", f_in)
if (debug_on) call msg_debug (D_THRESHOLD, "nrqcd_order_in", nrqcd_order_in)
if (debug_on) call msg_debug (D_THRESHOLD, "ff_in", ff_in)
if (debug_on) call msg_debug (D_THRESHOLD, "offshell_strategy_in", offshell_strategy_in)
if (debug_on) call msg_debug (D_THRESHOLD, "top_helicity_selection", top_helicity_selection)
if (debug_on) call msg_debug (D_THRESHOLD, "v1_in", v1_in)
if (debug_on) call msg_debug (D_THRESHOLD, "v2_in", v2_in)
if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_min", scan_sqrts_min)
if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_max", scan_sqrts_max)
if (debug_on) call msg_debug (D_THRESHOLD, "scan_sqrts_stepsize", scan_sqrts_stepsize)
if (debug_on) call msg_debug (D_THRESHOLD, "AS_HARD", AS_HARD)
end subroutine show_input
@
<<ttv formfactors: procedures>>=
subroutine compute_global_auxiliary_numbers ()
!!! auxiliary numbers needed later
!!! current coefficients Ai(S,L,J), cf. arXiv:hep-ph/0609151, Eqs. (63)-(64)
!!! 3S1 coefficients (s-wave, vector current)
B0 = coeff_b0(NF) * (4.*pi)
B1 = coeff_b1(NF) * (4.*pi)**2
aa2(1) = (CF*(CA*CF*(9.*CA - 100.*CF) - &
B0*(26.*CA**2 + 19.*CA*CF - 32.*CF**2)))/(26.*B0**2 *CA)
aa3(1) = CF**2/( B0**2 *(6.*B0 - 13.*CA)*(B0 - 2.*CA)) * &
(CA**2 *(9.*CA - 100.*CF) + B0*CA*(74.*CF - CA*16.) - &
6.*B0**2 *(2.*CF - CA))
aa4(1) = (24.*CF**2 * (11.*CA - 3.*B0)*(5.*CA + 8.*CF)) / &
(13.*CA*(6.*B0 - 13.*CA)**2)
aa5(1) = (CF**2 * (CA*(15.-28) + B0*5.))/(6.*(B0-2.*CA)**2)
aa8(1) = zero
aa0(1) = -((8.*CF*(CA + CF)*(CA + 2.*CF))/(3.*B0**2))
!!! 3P1 coefficients (p-wave, axial vector current)
aa2(2) = -1./3. * (CF*(CA+2.*CF)/B0 - CF**2/(4.*B0) )
aa3(2) = zero
aa4(2) = zero
aa5(2) = 1./3. * CF**2/(4.*(B0-2.*CA))
aa8(2) = -1./3. * CF**2/(B0-CA)
aa0(2) = -1./3. * 8.*CA*CF*(CA+4.*CF)/(3.*B0**2)
end subroutine compute_global_auxiliary_numbers
@ %def compute_global_auxiliary_numbers
@
<<ttv formfactors: public>>=
public :: init_threshold_grids
<<ttv formfactors: procedures>>=
subroutine init_threshold_grids (test)
real(default), intent(in) :: test
if (debug_active (D_THRESHOLD)) then
call msg_debug (D_THRESHOLD, "init_threshold_grids")
call msg_debug (D_THRESHOLD, "TOPPIK_RESUMMED", TOPPIK_RESUMMED)
end if
if (test > zero) then
call msg_message ("TESTING ONLY: Skip threshold initialization and use tree-level SM.")
return
end if
if (.not. threshold%settings%initialized_parameters) call msg_fatal ("init_threshold_grid: parameters not initialized!")
!!! !!! !!! MAC OS X and BSD don't load the global module with parameter values stored
!!! if (parameters_ref == parameters_string ()) return
call dealloc_grids ()
if (TOPPIK_RESUMMED) call init_formfactor_grid ()
parameters_ref = parameters_string ()
end subroutine init_threshold_grids
@
<<ttv formfactors: procedures>>=
!!! LL/NLL resummation of nonrelativistic Coulomb potential
pure function resummed_formfactor (ps, vec_type) result (c)
type(phase_space_point_t), intent(in) :: ps
integer, intent(in) :: vec_type
complex(default) :: c
c = one
if (.not. threshold%settings%initialized_ff .or. .not. ps%inside_grid) return
if (POINTS_SQ > 1) then
call interpolate_linear (sq_grid, p_grid, ff_grid(:,:,1,vec_type), ps%sqrts, ps%p, c)
else
call interpolate_linear (p_grid, ff_grid(1,:,1,vec_type), ps%p, c)
end if
end function resummed_formfactor
@
<<ttv formfactors: procedures>>=
!!! leading nonrelativistic O(alphas^1) contribution (-> expansion of resummation)
function expanded_formfactor (alphas_hard, alphas_soft, ps, vec_type) result (FF)
complex(default) :: FF
real(default), intent(in) :: alphas_hard, alphas_soft
type(phase_space_point_t), intent(in) :: ps
integer, intent(in) :: vec_type
real(default) :: shift_from_hard_current
complex(default) :: v, contrib_from_potential
FF = one
if (.not. threshold%settings%initialized_parameters) return
call update_global_sqrts_dependent_variables (ps%sqrts)
v = sqrts_to_v (ps%sqrts, GAM)
if (NRQCD_ORDER == 1) then
if (vec_type == AXIAL) then
shift_from_hard_current = - CF / pi
else
shift_from_hard_current = - two * CF / pi
end if
else
shift_from_hard_current = zero
end if
if (ps%onshell) then
contrib_from_potential = CF * ps%mpole * Pi / (4 * ps%p)
else
if (vec_type == AXIAL) then
contrib_from_potential = - CF * ps%mpole / (two * ps%p) * &
(imago * ps%mpole * v / ps%p + &
(ps%mpole**2 * v**2 + (ps%p)**2) / (4 *Pi * (ps%p)**2) * ( &
(log (- ps%mpole * v - ps%p))**2 - &
(log (- ps%mpole * v + ps%p))**2 + &
(log (ps%mpole * v - ps%p))**2 - &
(log (ps%mpole * v + ps%p))**2 ))
else
contrib_from_potential = imago * CF * ps%mpole * &
log ((ps%p + ps%mpole * v) / &
(-ps%p + ps%mpole * v) + ieps) / (two * ps%p)
end if
end if
FF = one + alphas_soft * contrib_from_potential + &
alphas_hard * shift_from_hard_current
end function expanded_formfactor
@
<<ttv formfactors: procedures>>=
subroutine init_formfactor_grid ()
type(string_t) :: ff_file
if (debug_on) call msg_debug (D_THRESHOLD, "init_formfactor_grid")
threshold%settings%initialized_ff = .false.
ff_file = "SM_tt_threshold.grid"
call msg_message ()
call msg_message ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%")
call msg_message (" Initialize e+e- => ttbar threshold resummation:")
call msg_message (" Use analytic (LL) or TOPPIK (NLL) form factors for ttA/ttZ vector")
call msg_message (" and axial vector couplings (S/P-wave) in the threshold region.")
call msg_message (" Cf. threshold shapes from A. Hoang et al.: [arXiv:hep-ph/0107144],")
call msg_message (" [arXiv:1309.6323].")
if (NRQCD_ORDER > 0) then
call msg_message (" Numerical NLL solutions calculated with TOPPIK [arXiv:hep-ph/9904468]")
call msg_message (" by M. Jezabek, T. Teubner.")
end if
call msg_message ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%")
call msg_message ()
call read_formfactor_grid (ff_file)
if (.not. threshold%settings%initialized_ff) then
if (.not. threshold%settings%initialized_ps) call init_threshold_phase_space_grid ()
call scan_formfactor_over_phase_space_grid ()
call write_formfactor_grid (ff_file)
end if
end subroutine init_formfactor_grid
@
<<ttv formfactors: procedures>>=
subroutine read_formfactor_grid (ff_file)
type(string_t), intent(in) :: ff_file
complex(single), dimension(:,:,:,:), allocatable :: ff_grid_sp
character(len(parameters_ref)) :: parameters
integer :: u, st
logical :: ex
integer, dimension(4) :: ff_shape
if (debug_on) call msg_debug (D_THRESHOLD, "read_formfactor_grid")
inquire (file=char(ff_file), exist=ex)
if (.not. ex) return
u = free_unit ()
call msg_message ("Opening grid file: " // char(ff_file))
open (unit=u, status='old', file=char(ff_file), form='unformatted', iostat=st)
if (st /= 0) call msg_fatal ("iostat = " // char(st))
read (u) parameters
read (u) ff_shape
if (ff_shape(4) /= 2) call msg_fatal ("read_formfactor_grid: i = " // char(ff_shape(4)))
if (parameters /= parameters_string ()) then
call msg_message ("Threshold setup has changed: recalculate threshold grid.")
close (unit=u, status='delete')
return
end if
call msg_message ("Threshold setup unchanged: reusing existing threshold grid.")
POINTS_SQ = ff_shape(1)
POINTS_P = ff_shape(2)
if (debug_active (D_THRESHOLD)) then
call msg_debug (D_THRESHOLD, "ff_shape(1) (POINTS_SQ)", ff_shape(1))
call msg_debug (D_THRESHOLD, "ff_shape(2)", ff_shape(2))
call msg_debug (D_THRESHOLD, "ff_shape(3) (POINTS_P0)", ff_shape(3))
call msg_debug (D_THRESHOLD, "ff_shape(4) (==2)", ff_shape(4))
end if
allocate (sq_grid(POINTS_SQ))
read (u) sq_grid
allocate (p_grid(POINTS_P))
read (u) p_grid
POINTS_P0 = ff_shape(3)
allocate (ff_grid_sp(POINTS_SQ,POINTS_P,POINTS_P0,2))
read (u) ff_grid_sp
allocate (ff_grid(POINTS_SQ,POINTS_P,POINTS_P0,2))
ff_grid = cmplx (ff_grid_sp, kind=default)
close (u, iostat=st)
if (st > 0) call msg_fatal ("close " // char(ff_file) // ": iostat = " // char(st))
threshold%settings%initialized_ps = .true.
threshold%settings%initialized_ff = .true.
end subroutine read_formfactor_grid
@
<<ttv formfactors: procedures>>=
subroutine write_formfactor_grid (ff_file)
type(string_t), intent(in) :: ff_file
integer :: u, st
if (.not. threshold%settings%initialized_ff) then
call msg_warning ("write_formfactor_grid: no grids initialized!")
return
end if
u = free_unit ()
open (unit=u, status='replace', file=char(ff_file), form='unformatted', iostat=st)
if (st /= 0) call msg_fatal ("open " // char(ff_file) // ": iostat = " // char(st))
write (u) parameters_string ()
write (u) shape(ff_grid)
write (u) sq_grid
write (u) p_grid
write (u) cmplx(ff_grid, kind=single)
close (u, iostat=st)
if (st > 0) call msg_fatal ("close " // char(ff_file) // ": iostat = " // char(st))
end subroutine write_formfactor_grid
@
<<ttv formfactors: procedures>>=
pure function parameters_string () result (str)
character(len(parameters_ref)) :: str
str = char(M1S) // " " // char(GAM_M1S) // " " // char(NRQCD_ORDER) &
// " " // char(RESCALE_H) &
// " " // char(RESCALE_F) &
// " " // char(sqrts_min) &
// " " // char(sqrts_max) // " " // char(sqrts_it)
end function parameters_string
@
<<ttv formfactors: procedures>>=
subroutine update_global_sqrts_dependent_variables (sqrts)
real(default), intent(in) :: sqrts
real(default) :: nu_soft, f
logical :: only_once_for_fixed_nu, already_done
real(default), save :: last_sqrts = - one
if (debug_on) call msg_debug (D_THRESHOLD, "update_global_sqrts_dependent_variables")
if (debug_on) call msg_debug (D_THRESHOLD, "sqrts", sqrts)
if (debug_on) call msg_debug (D_THRESHOLD, "last_sqrts", last_sqrts)
already_done = threshold%settings%initialized_parameters .and. &
nearly_equal (sqrts, last_sqrts, rel_smallness=1E-6_default)
if (debug_on) call msg_debug (D_THRESHOLD, "already_done", already_done)
only_once_for_fixed_nu = .not. NUSTAR_DYNAMIC .and. MTPOLE > zero
if (debug_on) call msg_debug (D_THRESHOLD, "only_once_for_fixed_nu", only_once_for_fixed_nu)
if (only_once_for_fixed_nu .or. already_done) return
last_sqrts = sqrts
nu_soft = RESCALE_F * nustar (sqrts)
MU_SOFT = M1S * RESCALE_H * nu_soft
MU_USOFT = M1S * RESCALE_H * nu_soft**2
AS_SOFT = running_as (MU_SOFT, AS_HARD, MU_HARD, NRQCD_ORDER, NF)
AS_LL_SOFT = running_as (MU_SOFT, AS_HARD, MU_HARD, 0, NF)
AS_USOFT = running_as (MU_USOFT, AS_HARD, MU_HARD, 0, NF) !!! LL here
if (SWITCHOFF_RESUMMED) then
f = f_switch_off (v_matching (sqrts, GAM_M1S))
AS_SOFT = AS_SOFT * f
AS_LL_SOFT = AS_LL_SOFT * f
AS_USOFT = AS_USOFT * f
end if
MTPOLE = m1s_to_mpole (sqrts)
GAM = threshold%width%compute (MTPOLE, sqrts)
if (debug_on) call msg_debug (D_THRESHOLD, "GAM", GAM)
if (debug_on) call msg_debug (D_THRESHOLD, "nu_soft", nu_soft)
if (debug_on) call msg_debug (D_THRESHOLD, "MTPOLE", MTPOLE)
if (debug_on) call msg_debug (D_THRESHOLD, "AS_SOFT", AS_SOFT)
if (debug_on) call msg_debug (D_THRESHOLD, "AS_LL_SOFT", AS_LL_SOFT)
if (debug_on) call msg_debug (D_THRESHOLD, "AS_USOFT", AS_USOFT)
end subroutine update_global_sqrts_dependent_variables
!!! Coulomb potential coefficients needed by TOPPIK
pure function xc (a_soft, i_xc) result (xci)
real(default), intent(in) :: a_soft
integer, intent(in) :: i_xc
real(default) :: xci
xci = zero
select case (i_xc)
case (0)
xci = one
if ( NRQCD_ORDER>0 ) xci = xci + a_soft/(4.*pi) * A1
if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * A2
case (1)
if ( NRQCD_ORDER>0 ) xci = xci + a_soft/(4.*pi) * B0
if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * (B1 + 2*B0*A1)
case (2)
if ( NRQCD_ORDER>1 ) xci = xci + (a_soft/(4.*pi))**2 * B0**2
case default
return
end select
end function xc
@
<<ttv formfactors: procedures>>=
function current_coeff (a_hard, a_soft, a_usoft, i) result (coeff)
real(default), intent(in) :: a_hard, a_soft, a_usoft
integer, intent(in) :: i
real(default) :: coeff
real(default) :: matching_c, c1
real(default) :: z, w
if (debug_on) call msg_debug (D_THRESHOLD, "current_coeff")
coeff = one
if (NRQCD_ORDER == 0) return
z = a_soft / a_hard
w = a_usoft / a_soft
!!! hard s/p-wave 1-loop matching coefficients, cf. arXiv:hep-ph/0604072
select case (i)
case (1)
matching_c = one - 2.*(CF/pi) * a_hard
case (2)
matching_c = one - (CF/pi) * a_hard
case default
call msg_fatal ("current_coeff: unknown coeff i = " // char(i))
end select
!!! current coefficient c1, cf. arXiv:hep-ph/0609151, Eq. (62)
c1 = exp( a_hard * pi * ( aa2(i)*(1.-z) + aa3(i)*log(z) + &
aa4(i)*(1.-z**(1.-13.*CA/(6.*B0))) + aa5(i)*(1.-z**(1.-2.*CA/B0)) + &
aa8(i)*(1.-z**(1.-CA/B0)) + aa0(i)*(z-1.-log(w)/w) ))
coeff = matching_c * c1
end function current_coeff
@
<<ttv formfactors: public>>=
public :: v_matching
<<ttv formfactors: procedures>>=
pure function v_matching (sqrts, gamma) result (v)
real(default) :: v
real(default), intent(in) :: sqrts, gamma
v = abs (sqrts_to_v_1S (sqrts, gamma))
end function v_matching
@ Smooth transition from [[f1]] to [[f2]] between [[v1]] and [[v2]]
(simplest polynom).
<<ttv formfactors: public>>=
public :: f_switch_off
<<ttv formfactors: procedures>>=
pure function f_switch_off (v) result (fval)
real(default), intent(in) :: v
real(default) :: fval
real(default) :: vm, f1, f2, x
f1 = one
f2 = zero + tiny_10
vm = (v1+v2) / 2.
if ( v < v1 ) then
fval = f1
else if (v < v2) then
x = (v - v1) / (v2 - v1)
fval = 1 - x**2 * (3 - 2 * x)
else
fval = f2
end if
end function f_switch_off
@
<<ttv formfactors: procedures>>=
function formfactor_LL_analytic (a_soft, sqrts, p, vec_type) result (c)
real(default), intent(in) :: a_soft
real(default), intent(in) :: sqrts
real(default), intent(in) :: p
integer, intent(in) :: vec_type
complex(default) :: c
real(default) :: en
c = one
if (.not. threshold%settings%initialized_parameters) return
call update_global_sqrts_dependent_variables (sqrts)
en = sqrts_to_en (sqrts, MTPOLE)
select case (vec_type)
case (1)
c = G0p (CF*a_soft, en, p, MTPOLE, GAM) / G0p_tree (en, p, MTPOLE, GAM)
case (2)
c = G0p_ax (CF*a_soft, en, p, MTPOLE, GAM) / G0p_tree (en, p, MTPOLE, GAM)
case default
call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type))
end select
end function formfactor_LL_analytic
@
<<ttv formfactors: procedures>>=
!!! Max's LL nonrelativistic threshold Green's function
function G0p (a, en, p, m, w) result (c)
real(default), intent(in) :: a
real(default), intent(in) :: en
real(default), intent(in) :: p
real(default), intent(in) :: m
real(default), intent(in) :: w
complex(default) :: c
complex(default) :: k, ipk, la, z1, z2
complex(default) :: one, two, cc, dd
k = sqrt( -m*en -imago*m*w )
ipk = imago * p / k
la = a * m / 2. / k
one = cmplx (1., kind=default)
two = cmplx (2., kind=default)
cc = 2. - la
dd = ( 1. + ipk ) / 2.
z1 = nr_hypgeo (two, one, cc, dd)
dd = ( 1. - ipk ) / 2.
z2 = nr_hypgeo (two, one, cc, dd)
c = - imago * m / (4.*p*k) / (1.-la) * ( z1 - z2 )
end function G0p
@
<<ttv formfactors: procedures>>=
!!! tree level version: a_soft -> 0
pure function G0p_tree (en, p, m, w) result (c)
real(default), intent(in) :: en
real(default), intent(in) :: p
real(default), intent(in) :: m
real(default), intent(in) :: w
complex(default) :: c
c = m / (p**2 - m*(en+imago*w))
end function G0p_tree
@
<<ttv formfactors: procedures>>=
!!! Peter Poier's LL nonrelativistic axial threshold Green's function
function G0p_ax (a, en, p, m, w) result (c)
real(default), intent(in) :: a
real(default), intent(in) :: en
real(default), intent(in) :: p
real(default), intent(in) :: m
real(default), intent(in) :: w
complex(default) :: c
complex(default) :: k, ipk, la, z1, z2, z3, z4
complex(default) :: zero, two, three, cc, ddp, ddm
k = sqrt( -m*en -imago*m*w )
ipk = imago * p / k
la = a * m / 2. / k
zero = cmplx (0., kind=default)
two = cmplx (2., kind=default)
three = cmplx (3., kind=default)
cc = 1. - la
ddp = ( 1. + ipk ) / 2.
ddm = ( 1. - ipk ) / 2.
z1 = nr_hypgeo (zero, two, cc, ddp)
z2 = nr_hypgeo (zero, two, cc, ddm)
cc = 2. - la
z3 = nr_hypgeo (zero, three, cc, ddm)
z4 = nr_hypgeo (zero, three, cc, ddp)
c = m / 2. / p**3 * ( 2.*p + imago*k*(1.-la)*(z1-z2) + imago*k*(z3-z4) )
end function G0p_ax
@
<<ttv formfactors: procedures>>=
pure function nustar (sqrts) result (nu)
real(default), intent(in) :: sqrts
real(default) :: nu
real(default), parameter :: nustar_offset = 0.05_default
complex(default) :: arg
if (NUSTAR_DYNAMIC) then
!!! from [arXiv:1309.6323], Eq. (3.2) (other definitions possible)
arg = ( sqrts - 2.*M1S + imago*GAM_M1S ) / M1S
nu = nustar_offset + abs(sqrt(arg))
else
nu = NUSTAR_FIXED
end if
end function nustar
@ We recompute [[alpha_soft]] for form factors that do not call
[[update_global_parameters]] (it is called in the scan for the (N)LL
grid).
<<ttv formfactors: procedures>>=
pure function alphas_soft (sqrts) result (a_soft)
real(default) :: a_soft
real(default), intent(in) :: sqrts
real(default) :: mu_soft, nusoft
nusoft = RESCALE_F * nustar (sqrts)
mu_soft = RESCALE_H * M1S * nusoft
a_soft = running_as (mu_soft, AS_HARD, MU_HARD, NRQCD_ORDER, NF)
end function alphas_soft
@
<<ttv formfactors: public>>=
public :: alphas_notsohard
<<ttv formfactors: procedures>>=
pure function alphas_notsohard (sqrts) result (a_soft)
real(default) :: a_soft
real(default), intent(in) :: sqrts
real(default) :: mu_notsohard
! complex(default) :: v
! v = sqrts_to_v_1S (sqrts, GAM_M1S)
! mu_notsohard = RESCALE_H * M1S * sqrt(abs(v))
mu_notsohard = RESCALE_H * M1S * sqrt(nustar (sqrts))
a_soft = running_as (mu_notsohard, AS_MZ, MASS_Z, 2, NF)
end function alphas_notsohard
@
<<ttv formfactors: procedures>>=
pure function m1s_to_mpole (sqrts) result (mpole)
real(default), intent(in) :: sqrts
real(default) :: mpole
mpole = mtpole_init
if (threshold%settings%mpole_dynamic) then
mpole = M1S * ( 1. + deltaM(sqrts) )
else
mpole = M1S
end if
end function m1s_to_mpole
@
<<ttv formfactors: procedures>>=
!pure
!function mpole_to_M1S (mpole, sqrts, nl) result (m)
!real(default), intent(in) :: mpole
!real(default), intent(in) :: sqrts
!integer, intent(in) :: nl
!real(default) :: m
!m = mpole * ( 1. - deltaM(sqrts, nl) )
!end function mpole_to_M1S
@
<<ttv formfactors: procedures>>=
pure function deltaM (sqrts) result (del)
real(default), intent(in) :: sqrts
real(default) :: del
real(default) :: ac
ac = CF * alphas_soft (sqrts)
del = ac**2 / 8.
if (NRQCD_ORDER > 0) then
del = del + ac**3 / (8. * pi * CF) * &
(B0 * (log (RESCALE_H * RESCALE_F * nustar (sqrts) / ac) + one) + A1 / 2.)
end if
end function deltaM
@
<<ttv formfactors: procedures>>=
pure function sqrts_within_range (sqrts) result (flag)
real(default), intent(in) :: sqrts
logical :: flag
flag = ( sqrts >= sqrts_min - tiny_07 .and. sqrts <= sqrts_max + tiny_07 )
end function
@
<<ttv formfactors: procedures>>=
! The mapping is such that even for min=max, we get three points:
! min - it , min, min + it
pure function sqrts_iter (i_sq) result (sqrts)
integer, intent(in) :: i_sq
real(default) :: sqrts
if (POINTS_SQ > 1) then
sqrts = sqrts_min - sqrts_it + &
(sqrts_max - sqrts_min + two * sqrts_it) * &
real(i_sq - 1) / real(POINTS_SQ - 1)
else
sqrts = sqrts_min
end if
end function sqrts_iter
@
<<ttv formfactors: procedures>>=
function scan_formfactor_over_p_LL_analytic (a_soft, sqrts, vec_type) result (ff_analytic)
real(default), intent(in) :: a_soft
real(default), intent(in) :: sqrts
integer, intent(in) :: vec_type
complex(default), dimension(POINTS_P) :: ff_analytic
integer :: i_p
ff_analytic = [(formfactor_LL_analytic (a_soft, sqrts, p_grid(i_p), vec_type), i_p=1, POINTS_P)]
end function scan_formfactor_over_p_LL_analytic
@
<<ttv formfactors: procedures>>=
!!! tttoppik wrapper
subroutine scan_formfactor_over_p_TOPPIK (a_soft, sqrts, vec_type, p_grid_out, mpole_in, ff_toppik)
real(default), intent(in) :: a_soft
real(default), intent(in) :: sqrts
integer, intent(in) :: vec_type
real(default), dimension(POINTS_P), intent(out), optional :: p_grid_out
real(default), intent(in), optional :: mpole_in
complex(default), dimension(POINTS_P), optional :: ff_toppik
integer :: i_p
real(default) :: mpole, alphas_hard, f
real(default), dimension(POINTS_P) :: p_toppik
type(nr_spline_t) :: toppik_spline
real*8 :: xenergy, xtm, xtg, xalphas, xscale, xc0, xc1, xc2, xim, xdi, &
xcutn, xcutv, xkincm, xkinca, xkincv, xcdeltc, &
xcdeltl, xcfullc, xcfulll, xcrm2
integer, parameter :: nmax=900
real*8 :: xdsdp(nmax), xpp(nmax), xww(nmax)
complex*16 :: zff(nmax)
integer :: np, jknflg, jgcflg, jvflg
if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_p_TOPPIK")
if (POINTS_P > nmax-40) call msg_fatal ("TOPPIK: POINTS_P must be <=" // char(nmax-40))
if (debug_on) call msg_debug (D_THRESHOLD, "POINTS_P", POINTS_P)
if (present (ff_toppik)) ff_toppik = zero
mpole = MTPOLE; if (present (mpole_in)) mpole = mpole_in
xenergy = sqrts_to_en (sqrts, MTPOLE)
xtm = mpole
xtg = GAM
xalphas = a_soft
xscale = MU_SOFT
xcutn = 175.E6
xcutv = 175.E6
xc0 = xc (a_soft, 0)
xc1 = xc (a_soft, 1)
xc2 = xc (a_soft, 2)
xcdeltc = 0.
xcdeltl = 0.
xcfullc = 0.
xcfulll = 0.
xcrm2 = 0.
xkincm = 0.
xkinca = 0.
jknflg = 0
jgcflg = 0
xkincv = 0.
jvflg = 0
select case (vec_type)
case (VECTOR)
if (debug_on) call msg_debug (D_THRESHOLD, "calling tttoppik")
call tttoppik &
(xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,xc0,xc1,xc2, &
xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,xkincm,xkinca,jknflg, &
jgcflg, xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zff)
case (AXIAL)
if (debug_on) call msg_debug (D_THRESHOLD, "calling tttoppikaxial")
call tttoppikaxial &
(xenergy,xtm,xtg,xalphas,xscale,xcutn,xcutv,xc0,xc1,xc2, &
xcdeltc,xcdeltl,xcfullc,xcfulll,xcrm2,xkincm,xkinca,jknflg, &
jgcflg, xkincv,jvflg,xim,xdi,np,xpp,xww,xdsdp,zff)
!!! 1st ~10 TOPPIK p-wave entries are ff_unstable: discard them
zff(1:10) = [(zff(11), i_p=1, 10)]
case default
call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type))
end select
if (present (p_grid_out)) p_grid_out = xpp(1:POINTS_P)
if (.not. present (ff_toppik)) return
!!! keep track of TOPPIK instabilities and try to repair later
if (np < 0) then
ff_toppik(1) = 2.d30
if (debug_active (D_THRESHOLD)) then
call msg_warning ("caught TOPPIK instability at sqrts = " // char(sqrts))
end if
return
end if
p_toppik = xpp(1:POINTS_P)
ff_toppik = zff(1:POINTS_P)
!!! TOPPIK output p-grid scales with en above ~ 4 GeV:
!!! interpolate for global sqrts/p grid
if (.not. nearly_equal (p_toppik(42), p_grid(42), rel_smallness=1E-6_default)) then
call toppik_spline%init (p_toppik, ff_toppik)
ff_toppik(2:POINTS_P) = [(toppik_spline%interpolate (p_grid(i_p)), i_p=2, POINTS_P)]
call toppik_spline%dealloc ()
end if
!!! TOPPIK output includes tree level ~ 1, a_soft @ LL in current coefficient!
if (SWITCHOFF_RESUMMED) then
f = f_switch_off (v_matching (sqrts, GAM_M1S))
alphas_hard = AS_HARD * f
else
alphas_hard = AS_HARD
end if
ff_toppik = ff_toppik * current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type)
if (debug_on) call msg_debug (D_THRESHOLD, &
"current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type)", &
current_coeff (alphas_hard, AS_LL_SOFT, AS_USOFT, vec_type))
end subroutine scan_formfactor_over_p_TOPPIK
@
<<ttv formfactors: procedures>>=
function scan_formfactor_over_p (sqrts, vec_type) result (ff)
real(default), intent(in) :: sqrts
integer, intent(in) :: vec_type
complex(default), dimension(POINTS_P) :: ff
if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_p")
select case (NRQCD_ORDER)
case (0)
! ff = scan_formfactor_over_p_LL_analytic (AS_SOFT, sqrts, vec_type)
call scan_formfactor_over_p_TOPPIK (AS_SOFT, sqrts, vec_type, ff_toppik=ff)
case (1)
call scan_formfactor_over_p_TOPPIK (AS_SOFT, sqrts, vec_type, ff_toppik=ff)
case default
call msg_fatal ("NRQCD_ORDER = " // char(NRQCD_ORDER))
end select
end function scan_formfactor_over_p
@
<<ttv formfactors: procedures>>=
subroutine scan_formfactor_over_phase_space_grid ()
integer :: i_sq, vec_type, unstable_loop
logical, dimension(:,:), allocatable :: ff_unstable
real(default) :: t1, t2, t3, t_toppik, t_p0_dep
if (debug_on) call msg_debug (D_THRESHOLD, "scan_formfactor_over_phase_space_grid")
allocate (ff_grid(POINTS_SQ,POINTS_P,POINTS_P0,2))
allocate (ff_unstable(POINTS_SQ,2))
t_toppik = zero
t_p0_dep = zero
write (msg_buffer, "(3(A,F7.3,1X),A)") "Scanning from ", &
sqrts_min - sqrts_it, "GeV to ", &
sqrts_max + sqrts_it, "GeV in steps of ", sqrts_it, "GeV"
call msg_message ()
ENERGY_SCAN: do i_sq = 1, POINTS_SQ
if (signal_is_pending ()) return
call update_global_sqrts_dependent_variables (sq_grid(i_sq))
!!! vector and axial vector
do vec_type = VECTOR, AXIAL
call cpu_time (t1)
unstable_loop = 0
UNTIL_STABLE: do
ff_grid(i_sq,:,1,vec_type) = scan_formfactor_over_p (sq_grid(i_sq), vec_type)
ff_unstable(i_sq,vec_type) = abs(ff_grid(i_sq,1,1,vec_type)) > 1.d30
unstable_loop = unstable_loop + 1
if (ff_unstable(i_sq,vec_type) .and. unstable_loop < 10) then
cycle
else
exit
end if
end do UNTIL_STABLE
call cpu_time (t2)
!!! include p0 dependence by an integration over the p0-independent FF
call cpu_time (t3)
t_toppik = t_toppik + t2 - t1
t_p0_dep = t_p0_dep + t3 - t2
end do
call msg_show_progress (i_sq, POINTS_SQ)
end do ENERGY_SCAN
if (debug_active (D_THRESHOLD)) then
print *, "time for TOPPIK call: ", t2 - t1, " seconds."
print *, "time for p0 dependence: ", t3 - t2, " seconds."
end if
if (any (ff_unstable)) call handle_TOPPIK_instabilities (ff_grid, ff_unstable)
if (allocated(Vmatrix)) deallocate(Vmatrix)
if (allocated(q_grid)) deallocate(q_grid)
threshold%settings%initialized_ff = .true.
end subroutine scan_formfactor_over_phase_space_grid
@
<<ttv formfactors: procedures>>=
subroutine init_threshold_phase_space_grid ()
integer :: i_sq
if (debug_on) call msg_debug (D_THRESHOLD, "init_threshold_phase_space_grid")
if (sqrts_it > tiny_07) then
POINTS_SQ = int ((sqrts_max - sqrts_min) / sqrts_it + tiny_07) + 3
else
POINTS_SQ = 1
end if
if (debug_on) call msg_debug (D_THRESHOLD, "Number of sqrts grid points: POINTS_SQ", POINTS_SQ)
if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_max", sqrts_max)
if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_min", sqrts_min)
if (debug_on) call msg_debug (D_THRESHOLD, "sqrts_it", sqrts_it)
allocate (sq_grid(POINTS_SQ))
sq_grid = [(sqrts_iter (i_sq), i_sq=1, POINTS_SQ)]
POINTS_P = 600
allocate (p_grid(POINTS_P))
p_grid = p_grid_from_TOPPIK ()
POINTS_P0 = 1
threshold%settings%initialized_ps = .true.
end subroutine init_threshold_phase_space_grid
@
<<ttv formfactors: procedures>>=
subroutine init_p0_grid (p_in, n)
real(default), dimension(:), allocatable, intent(in) :: p_in
integer, intent(in) :: n
if (debug_on) call msg_debug (D_THRESHOLD, "init_p0_grid")
if (debug_on) call msg_debug (D_THRESHOLD, "n", n)
if (debug_on) call msg_debug (D_THRESHOLD, "size(p_in)", size(p_in))
if (.not. allocated (p_in)) call msg_fatal ("init_p0_grid: p_in not allocated!")
if (allocated (p0_grid)) deallocate (p0_grid)
allocate (p0_grid(n))
p0_grid(1) = zero
p0_grid(2:n) = p_in(1:n-1)
end subroutine init_p0_grid
@
<<ttv formfactors: procedures>>=
!!! Andre's procedure to refine an existing grid
pure subroutine finer_grid (gr, fgr, n_in)
real(default), dimension(:), intent(in) :: gr
real(default), dimension(:), allocatable, intent(inout) :: fgr
integer, intent(in), optional :: n_in
integer :: n, i, j
real(default), dimension(:), allocatable :: igr
n = 4
if ( present(n_in) ) n = n_in
allocate( igr(n) )
if ( allocated(fgr) ) deallocate( fgr )
allocate( fgr(n*(size(gr)-1)+1) )
do i=1, size(gr)-1
do j=0, n-1
igr(j+1) = gr(i) + real(j)*(gr(i+1)-gr(i))/real(n)
end do
fgr((i-1)*n+1:i*n) = igr
end do
fgr(size(fgr)) = gr(size(gr))
deallocate( igr )
end subroutine finer_grid
@
<<ttv formfactors: procedures>>=
subroutine dealloc_grids ()
if ( allocated(sq_grid) ) deallocate( sq_grid )
if ( allocated( p_grid) ) deallocate( p_grid )
if ( allocated(p0_grid) ) deallocate( p0_grid )
if ( allocated(ff_grid) ) deallocate( ff_grid )
threshold%settings%initialized_ps = .false.
threshold%settings%initialized_ff = .false.
end subroutine dealloc_grids
@
<<ttv formfactors: procedures>>=
subroutine trim_p_grid (n_p_new)
integer, intent(in) :: n_p_new
real(default), dimension(n_p_new) :: p_save
complex(default), dimension(POINTS_SQ,n_p_new,POINTS_P0,2) :: ff_save
if (n_p_new > POINTS_P) then
call msg_fatal ("trim_p_grid: new size larger than old size.")
return
end if
p_save = p_grid(1:n_p_new)
ff_save = ff_grid(:,1:n_p_new,:,:)
deallocate( p_grid, ff_grid )
allocate( p_grid(n_p_new), ff_grid(POINTS_SQ,n_p_new,POINTS_P0,2) )
p_grid = p_save
ff_grid = ff_save
end subroutine trim_p_grid
@
<<ttv formfactors: procedures>>=
!!! try to repair TOPPIK instabilities by interpolation of adjacent sq_grid points
subroutine handle_TOPPIK_instabilities (ff, nan)
complex(default), dimension(:,:,:,:), intent(inout) :: ff
logical, dimension(:,:), intent(in) :: nan
integer :: i, i_sq, n_nan
logical :: interrupt
n_nan = sum (merge ([(1, i=1, 2*POINTS_SQ)], &
[(0, i=1, 2*POINTS_SQ)], reshape (nan, [2*POINTS_SQ])) )
interrupt = n_nan > 3
do i = 1, 2
if (interrupt ) exit
if (.not. any (nan(:,i))) cycle
do i_sq = 2, POINTS_SQ - 1
if (.not. nan(i_sq,i)) cycle
if (nan(i_sq+1,i) .or. nan(i_sq-1,i)) then
interrupt = .true.
exit
end if
ff(i_sq,:,:,i) = (ff(i_sq-1,:,:,i) + ff(i_sq+1,:,:,i)) / two
end do
end do
if (.not. interrupt) return
call msg_fatal ("Too many TOPPIK instabilities! Check your parameter setup " &
// "or slightly vary the scales sh and/or sf.")
end subroutine handle_TOPPIK_instabilities
@
<<ttv formfactors: procedures>>=
pure function sqrts_to_v (sqrts, gamma) result (v)
complex(default) :: v
real(default), intent(in) :: sqrts, gamma
real(default) :: m
m = m1s_to_mpole (sqrts)
v = sqrt ((sqrts - two * m + imago * gamma) / m)
end function sqrts_to_v
@
<<ttv formfactors: procedures>>=
pure function sqrts_to_v_1S (sqrts, gamma) result (v)
complex(default) :: v
real(default), intent(in) :: sqrts, gamma
v = sqrt ((sqrts - two * M1S + imago * gamma) / M1S)
end function sqrts_to_v_1S
@
<<ttv formfactors: procedures>>=
pure function v_to_sqrts (v) result (sqrts)
real(default), intent(in) :: v
real(default) :: sqrts
real(default) :: m
m = mtpole_init
sqrts = 2.*m + m*v**2
end function v_to_sqrts
@
<<ttv formfactors: procedures>>=
!!! -q^2 times the Coulomb potential V at LO resp. NLO
function minus_q2_V (a, q, p, p0r, vec_type) result (v)
real(default), intent(in) :: a
real(default), intent(in) :: q
real(default), intent(in) :: p
real(default), intent(in) :: p0r
integer, intent(in) :: vec_type
complex(default) :: p0, log_mppp, log_mmpm, log_mu_s, v
p0 = abs(p0r) + ieps
log_mppp = log( (p-p0+q) * (p+p0+q) )
log_mmpm = log( (p-p0-q) * (p+p0-q) )
select case (vec_type)
case (1)
select case (NRQCD_ORDER)
case (0)
v = CF*a * 2.*pi*(log_mppp-log_mmpm) * q/p
case (1)
log_mu_s = 2.*log(MU_SOFT)
v = CF*a * (2.*(4.*pi+A1*a)*(log_mppp-log_mmpm) &
+ B0*a*((log_mmpm-log_mu_s)**2-(log_mppp-log_mu_s)**2)) * q/(4.*p)
case default
call msg_fatal ("NRQCD_ORDER = " // char(NRQCD_ORDER))
end select
case (2)
!!! not implemented yet
v = zero
case default
call msg_fatal ("unknown ttZ/ttA vertex component, vec_type = " // char(vec_type))
end select
end function minus_q2_V
@
<<ttv formfactors: procedures>>=
!!! compute support points (~> q-grid) for numerical integration: trim p-grid and
!!! merge with singular points of integrand: q = p, |p-p0|, p+p0, sqrt(mpole*E)
subroutine compute_support_points (en, i_p, i_p0, n_trim)
real(default), intent(in) :: en
integer, intent(in) :: i_p
integer, intent(in) :: i_p0
integer, intent(in) :: n_trim
real(default) :: p, p0
real(default), dimension(4) :: sing_vals
integer :: n_sing, i_q
if (mod (POINTS_P, n_trim) /= 0) call msg_fatal ("trim p-grid for q-integration: POINTS_P = " &
// char(POINTS_P) // " and n_trim = " // char(n_trim))
n_q = POINTS_P / n_trim + merge(0,1,n_trim==1)
p = p_grid(i_p)
p0 = p0_grid(i_p0)
n_sing = 0
if ( i_p /= 1 .and. mod(i_p,n_trim) /= 0 ) then
n_sing = n_sing+1
sing_vals(n_sing) = p
end if
if ( i_p0 /= 1 ) then
n_sing = n_sing+1
sing_vals(n_sing) = p0 + p
if ( i_p0 /= i_p+1 ) then
n_sing = n_sing+1
sing_vals(n_sing) = abs( p0 - p )
end if
end if
if ( en > 0. ) then
n_sing = n_sing+1
sing_vals(n_sing) = sqrt( MTPOLE * en )
end if
if ( allocated(q_grid) ) deallocate( q_grid )
allocate( q_grid(n_q+n_sing) )
q_grid(1) = p_grid(1)
q_grid(2:n_q) = [(p_grid(i_q), i_q=max(n_trim,2), POINTS_P, n_trim)]
if (n_sing > 0 ) q_grid(n_q+1:n_q+n_sing) = sing_vals(1:n_sing)
call nr_sort (q_grid)
end subroutine compute_support_points
@
<<ttv formfactors: procedures>>=
!!! cf. arXiv:hep-ph/9503238, validated against arXiv:hep-ph/0008171
pure function formfactor_ttv_relativistic_nlo (alphas, ps, J0) result (c)
real(default), intent(in) :: alphas
type(phase_space_point_t), intent(in) :: ps
complex(default), intent(in) :: J0
complex(default) :: c
real(default) :: p2, k2, q2, kp, pq, kq
complex(default) :: D2, chi, ln1, ln2, L1, L2, z, S, m2, m
complex(default) :: JA, JB, JC, JD, JE, IA, IB, IC, ID, IE
complex(default) :: CCmsbar
complex(default) :: dF1, dF2, dM1, dM2
complex(default), dimension(12) :: P1
complex(default), parameter :: ximo = zero
p2 = ps%p2
k2 = ps%k2
q2 = ps%q2
m2 = complex_m2 (ps%mpole, GAM)
!!! kinematic abbreviations
kp = 0.5_default * (-q2 + p2 + k2)
pq = 0.5_default * ( k2 - p2 - q2)
kq = 0.5_default * (-p2 + k2 + q2)
D2 = kp**2 - k2*p2
chi = p2*k2*q2 + 2.*m2*((p2 + k2)*kp - 2.*p2*k2) + m2**2 * q2
ln1 = log( (1. - p2/m2)*(1,0) + ieps )
ln2 = log( (1. - k2/m2)*(1,0) + ieps )
L1 = (1. - m2/p2) * ln1
L2 = (1. - m2/k2) * ln2
z = sqrt( (1.-4.*m2/q2)*(1,0) )
S = 0.5_default * z * log( (z+1.)/(z-1.) + ieps )
m = sqrt(m2)
!!! loop integrals in terms of J0
JA = 1./D2 * (J0/2.*(-m2*pq - p2*kq) + kp*L2 - p2*L1 - 2.*pq*S)
JB = 1./D2 * (J0/2.*( m2*kq + k2*pq) + kp*L1 - k2*L2 + 2.*kq*S)
JC = 1/(4.*D2) * (2.*p2 + 2*kp*m2/k2 - 4.*kp*S + 2.*kp*(1. - m2/k2)*L2 + &
(2.*kp*(p2 - m2) + 3.*p2*(m2 - k2))*JA + p2*(m2 - p2)*JB)
JD = 1./(4.*D2) * (2.*kp*((k2 - m2)*JA + (p2 - m2)*JB - 1.) - k2*(2.*m2/k2 &
- 2.*S + (1. - m2/k2)*L2 + (p2 - m2)*JA) - p2*(-2.*S + (1. - &
m2/p2)*L1 + (k2 - m2)*JB))
JE = 1./(4.*D2) * (2.*k2 + 2*kp*m2/p2 - 4.*kp*S + 2.*kp*(1. - m2/p2)*L1 + &
(2.*kp*(k2 - m2) + 3.*k2*(m2 - p2))*JB + k2*(m2 - k2)*JA)
IA = 1./D2 * (-(kq/2.)*J0 - 2.*q2/chi *((m2 - p2)*k2 - (m2 - k2)*kp)*S + &
1./(m2 - p2)*(p2 - kp + p2*q2/chi *(k2 - m2)*(m2 + kp))*L1 + &
k2*q2/chi *(m2 + kp)*L2)
IB = 1./D2 * ( (pq/2.)*J0 - 2.*q2/chi *((m2 - k2)*p2 - (m2 - p2)*kp)*S + &
1./(m2 - k2)*(k2 - kp + k2*q2/chi *(p2 - m2)*(m2 + kp))*L2 + &
p2*q2/chi *(m2 + kp)*L1)
IC = 1./(4.*D2) * (2.*p2*J0 - 4.*kp/k2*(1. + m2/(k2 - m2)*L2) + (2.*kp - &
3.*p2)*JA - p2*JB + (-2.*kp*(m2 - p2) + 3.*p2*(m2 - k2))*IA + &
p2*(m2 - p2)*IB)
ID = 1./(4.*D2) * (-2.*kp*J0 + 2.*(1. + m2/(k2 - m2)*L2) + 2.*(1. + &
m2/(p2 - m2)*L1) + (2.*kp - k2)*JA + (2.*kp - p2)*JB + (k2*(m2 - &
p2) - 2.*kp*(m2 - k2))*IA + (p2*(m2 - k2) - 2.*kp*(m2 - p2))*IB)
IE = 1./(4.*D2) * (2.*k2*J0 - 4.*kp/p2*(1. + m2/(p2 - m2)*L1) + (2.*kp - &
3.*k2)*JB - k2*JA + (-2.*kp*(m2 - k2) + 3.*k2*(m2 - p2))*IB + &
k2*(m2 - k2)*IA)
!!! divergent part ~ 1/epsilon: depends on subtraction scheme
CCmsbar = -2.0_default * log(RESCALE_H)
! real top mass in the loop numerators
! m2 = cmplx(real(m2), kind=default)
! m = sqrt(m2)
!!! quark self energies
dF1 = - (ximo+1.) * (CCmsbar + (1.+m2/p2)*(1.-L1))
dF2 = - (ximo+1.) * (CCmsbar + (1.+m2/k2)*(1.-L2))
dM1 = m/p2 * ( (ximo+1.)*(1.+m2/p2*ln1) - 3.*ln1 )
dM2 = m/k2 * ( (ximo+1.)*(1.+m2/k2*ln2) - 3.*ln2 )
!!! coefficient list: vertex function Gamma_mu (k,p) = sum_i( Vi_mu * Pi )
P1(1) = 2.*JA - 2.*JC + ximo*(m2*IC + p2*ID)
P1(2) = 2.*JB - 2.*JE + ximo*(k2*ID + m2*IE)
P1(3) = -2.*J0 + 2.*JA + 2.*JB - 2.*JD + ximo*(-J0/2. - k2/2.*IC - &
kp*ID + m2*ID + p2/2.*IE + JA)
P1(4) = -2.*JD + ximo*(k2*IC + m2*ID - JA)
P1(5) = J0 - JA - JB + ximo*(J0/4. + k2/4.*IC + kp/2.*ID + p2/4.*IE - &
1./2.*JA - 1./2.*JB)
P1(6) = -m2*J0 - k2*JA - p2*JB + k2/2.*JC + kp*JD + p2/2.*JE + &
(1./2. + CCmsbar - 2.*S) &
+ ximo*(-m2*J0/4. - m2/4.*k2*IC - m2/2.*kp*ID - m2/4.*p2*IE &
- k2/2.*JA - p2/2.*JB + (CCmsbar + 2.))
P1(7) = 2.*m*J0 - 4.*m*JA + ximo*m*(J0/2. - 2.*kp*IC + k2/2.*IC - &
p2*ID - kp*ID - p2/2.*IE - JA)
P1(8) = 2.*m*J0 - 4.*m*JB + ximo*m*(J0/2. + k2/2.*IC - kp*ID + k2*ID - &
p2/2.*IE - JB)
P1(9) = ximo*m*(ID + IE)
P1(10) = ximo*m*(ID + IC)
P1(11) = ximo*m*( p2*ID + kp*IC + p2/2.*IE - k2/2.*IC) + dM2
!!! self energy contribution: ~ gamma_mu.k_slash = V11
P1(12) = ximo*m*(-k2*ID - kp*IE + p2/2.*IE - k2/2.*IC) + dM1
!!! self energy contribution: ~ gamma_mu.p_slash = V12
!!! leading form factor: V6 = gamma_mu, V5 = gamma_mu.k_slash.p_slash ~> -m^2*gamma_mu
c = one + alphas * CF / (4.*pi) * ( P1(6) - m2*P1(5) &
!!! self energy contributions ~ gamma^mu
+ dF1 + dF2 + m*( dM1 + dM2 ) )
!!! on-shell subtraction: UV divergence cancels
! + 0.5_default*( dF1 + dF2 + m*( dM1 + dM2 ) )
end function formfactor_ttv_relativistic_nlo
@
<<ttv formfactors: procedures>>=
pure function sqrts_to_en (sqrts, mpole_in) result (en)
real(default), intent(in) :: sqrts
real(default), intent(in), optional :: mpole_in
real(default) :: mpole, en
if (present (mpole_in)) then
mpole = mpole_in
else
mpole = m1s_to_mpole (sqrts)
end if
en = sqrts - two * mpole
end function sqrts_to_en
@
<<ttv formfactors: procedures>>=
function p_grid_from_TOPPIK (mpole_in) result (p_toppik)
real(default), intent(in), optional :: mpole_in
real(default), dimension(POINTS_P) :: p_toppik
real(default) :: mpole
if (debug_on) call msg_debug (D_THRESHOLD, "p_grid_from_TOPPIK")
mpole = MTPOLE; if (present (mpole_in)) mpole = mpole_in
call scan_formfactor_over_p_TOPPIK &
(alphas_soft(2. * M1S), 2. * M1S, 1, p_toppik, mpole)
if (.not. strictly_monotonous (p_toppik)) &
call msg_fatal ("p_grid NOT strictly monotonous!")
end function p_grid_from_TOPPIK
@
<<ttv formfactors: procedures>>=
pure function int_to_char (i) result (c)
integer, intent(in) :: i
character(len=len(trim(int2fixed(i)))) :: c
c = int2char (i)
end function int_to_char
@
<<ttv formfactors: procedures>>=
pure function real_to_char (r) result (c)
real(default), intent(in) :: r
character(len=len(trim(real2fixed(r)))) :: c
c = real2char (r)
end function real_to_char
@
<<ttv formfactors: procedures>>=
pure function complex_to_char (z) result (c)
complex(default), intent(in) :: z
character(len=len(trim(real2fixed(real(z))))+len(trim(real2fixed(aimag(z))))+5) :: c
character(len=len(trim(real2fixed(real(z))))) :: re
character(len=len(trim(real2fixed(aimag(z))))) :: im
re = real_to_char (real(z))
im = real_to_char (aimag(z))
if (nearly_equal (aimag(z), zero)) then
c = re
else
c = re // " + " // im // "*I"
end if
end function complex_to_char
@
<<ttv formfactors: procedures>>=
pure function logical_to_char (l) result (c)
logical, intent(in) :: l
character(len=1) :: c
write (c, '(l1)') l
end function logical_to_char
@
<<ttv formfactors: procedures>>=
subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out)
type(vector4_t), intent(in) :: p1_in, p2_in
type(vector4_t), intent(out) :: p1_out, p2_out
type(lorentz_transformation_t) :: L
L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1))
p1_out = L * p1_in; p2_out = L * p2_in
end subroutine get_rest_frame
function shift_momentum (p_in, E, p) result (p_out)
type(vector4_t) :: p_out
type(vector4_t), intent(in) :: p_in
real(default), intent(in) :: E, p
type(vector3_t) :: vec
vec = p_in%p(1:3) / space_part_norm (p_in)
p_out = vector4_moving (E, p * vec)
end function shift_momentum
subroutine evaluate_one_to_two_splitting_threshold (p_origin, &
p1_in, p2_in, p1_out, p2_out, msq_in, jac)
type(vector4_t), intent(in) :: p_origin
type(vector4_t), intent(in) :: p1_in, p2_in
type(vector4_t), intent(inout) :: p1_out, p2_out
real(default), intent(in), optional :: msq_in
real(default), intent(inout), optional :: jac
type(lorentz_transformation_t) :: L
type(vector4_t) :: p1_rest, p2_rest
real(default) :: msq, msq1, msq2
real(default) :: m
real(default) :: E1, E2, E_max
real(default) :: p, lda
real(default), parameter :: E_offset = 0.001_default
!!! (TODO-cw-2016-10-13) Find a better way to get masses
real(default), parameter :: mb = 4.2_default
real(default), parameter :: mw = 80.419_default
call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest)
msq = p_origin**2; m = sqrt(msq)
msq1 = p1_in**2
msq2 = m * (m - two * p1_rest%p(0))
E1 = (msq + msq1 - msq2) / (two * m)
E_max = (msq - (mb + mw)**2) / (two * m)
E_max = E_max - E_offset
if (E1 > E_max) then
E1 = E_max
msq2 = m * (m - two * E_max)
end if
lda = lambda (msq, msq1, msq2)
if (lda < zero) call msg_fatal &
("Threshold Splitting: lambda < 0 encountered! Use a higher offset.")
p = sqrt(lda) / (two * m)
E1 = sqrt (msq1 + p**2)
E2 = sqrt (msq2 + p**2)
p1_out = shift_momentum (p1_rest, E1, p)
p2_out = shift_momentum (p2_rest, E2, p)
L = boost (p_origin, p_origin**1)
p1_out = L * p1_out
p2_out = L * p2_out
end subroutine evaluate_one_to_two_splitting_threshold
@ %def evaluate_one_to_two_splitting_threshold
@
<<ttv formfactors: public>>=
public :: generate_on_shell_decay_threshold
<<ttv formfactors: procedures>>=
subroutine generate_on_shell_decay_threshold (p_decay, p_top, p_decay_onshell)
!!! Gluon must be on first position in this array
type(vector4_t), intent(in), dimension(:) :: p_decay
type(vector4_t), intent(inout) :: p_top
type(vector4_t), intent(inout), dimension(:) :: p_decay_onshell
procedure(evaluate_one_to_two_splitting_special), pointer :: ppointer
ppointer => evaluate_one_to_two_splitting_threshold
call generate_on_shell_decay (p_top, p_decay, p_decay_onshell, 1, &
evaluate_special = ppointer)
end subroutine generate_on_shell_decay_threshold
@ %def generate_on_shell_decay_threshold
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[ttv_formfactors_ut.f90]]>>=
<<File header>>
module ttv_formfactors_ut
use unit_tests
use ttv_formfactors_uti
<<Standard module head>>
<<ttv formfactors: public test>>
contains
<<ttv formfactors: test driver>>
end module ttv_formfactors_ut
@ %def ttv_formfactors_ut
@
<<[[ttv_formfactors_uti.f90]]>>=
<<File header>>
module ttv_formfactors_uti
<<Use kinds>>
<<Use debug>>
use constants
use ttv_formfactors
use diagnostics
use sm_physics, only: running_as
use numeric_utils
<<Standard module head>>
<<ttv formfactors: test declarations>>
contains
<<ttv formfactors: tests>>
end module ttv_formfactors_uti
@ %def ttv_formfactors_ut
@ API: driver for the unit tests below.
<<ttv formfactors: public test>>=
public ::ttv_formfactors_test
<<ttv formfactors: test driver>>=
subroutine ttv_formfactors_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<ttv formfactors: execute tests>>
end subroutine ttv_formfactors_test
@ %def ttv_formfactors_test
@
\subsubsection{Basic setup}
<<ttv formfactors: execute tests>>=
call test(ttv_formfactors_1, "ttv_formfactors_1", &
"Basic setup", u, results)
<<ttv formfactors: test declarations>>=
public :: ttv_formfactors_1
<<ttv formfactors: tests>>=
subroutine ttv_formfactors_1 (u)
integer, intent(in) :: u
real(default) :: m1s, Vtb, wt_inv, alphaemi, sw, alphas_mz, mz, &
mw, mb, sh, sf, NRQCD_ORDER, FF, offshell_strategy, v1, v2, &
scan_sqrts_max, sqrts, scan_sqrts_min, scan_sqrts_stepsize, &
test, gam_out, mpole
type(formfactor_t) :: formfactor
type(phase_space_point_t) :: ps
logical :: mpole_fixed
integer :: top_helicity_selection
write (u, "(A)") "* Test output: ttv_formfactors_1"
write (u, "(A)") "* Purpose: Basic setup"
write (u, "(A)")
m1s = 172.0_default
Vtb = one
wt_inv = zero
alphaemi = 125.0_default
alphas_mz = 0.118_default
mz = 91.1876_default
mw = 80.399_default
sw = sqrt(one - mw**2 / mz**2)
mb = 4.2_default
sh = one
sf = one
NRQCD_ORDER = one
FF = MATCHED
offshell_strategy = 0
top_helicity_selection = -1
v1 = 0.3_default
v2 = 0.5_default
scan_sqrts_stepsize = 0.0_default
test = - one
write (u, "(A)") "Check high energy behavior"
sqrts = 500.0_default
scan_sqrts_min = sqrts
scan_sqrts_max = sqrts
write (u, "(A)") "Check that the mass is not fixed"
mpole_fixed = .false.
<<(re)start grid>>
call threshold%formfactor%activate ()
call formfactor%activate ()
call assert (u, m1s_to_mpole (350.0_default) > m1s + 0.1_default, &
"m1s_to_mpole (350.0_default) > m1s")
write (u, "(A)")
! For simplicity we test on-shell back-to-back tops
call ps%init (m1s**2, m1s**2, sqrts**2, mpole)
call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), tiny_10, &
"f_switch_off (v_matching (ps%sqrts, GAM_M1S))")
call assert (u, &
abs (formfactor%compute (ps, 1, EXPANDED_HARD)) > &
abs (formfactor%compute (ps, 1, RESUMMED)), &
"expansion with hard alphas should be larger " // &
"than resummed (with switchoff)")
call assert_equal (u, &
abs (formfactor%compute (ps, 1, RESUMMED)), zero, &
"resummed (with switchoff) should be zero", abs_smallness=tiny_10)
call assert_equal (u, &
abs (formfactor%compute (ps, 1, EXPANDED_SOFT_SWITCHOFF)), zero, &
"expanded (with switchoff) should be zero", abs_smallness=tiny_10)
write (u, "(A)") ""
write (u, "(A)") "Check global variables"
call assert_equal (u, AS_HARD, &
running_as (m1s, alphas_mz, mz, 2, 5.0_default), "hard alphas")
call assert_equal (u, AS_SOFT, zero, "soft alphas", abs_smallness=tiny_10)
call assert_equal (u, AS_USOFT, zero, "ultrasoft alphas", abs_smallness=tiny_10)
call assert_equal (u, AS_LL_SOFT, zero, "LL soft alphas", abs_smallness=tiny_10)
!!! care: the formfactor contains the tree level that we usually subtract again
write (u, "(A)") "Check low energy behavior"
sqrts = 2 * m1s + 0.01_default
scan_sqrts_min = sqrts
scan_sqrts_max = sqrts
write (u, "(A)") "Check that the mass is fixed"
mpole_fixed = .true.
<<(re)start grid>>
call ps%init (m1s**2, m1s**2, sqrts**2, mpole)
call assert_equal (u, m1s_to_mpole (350.0_default), m1s, &
"m1s_to_mpole (350.0_default) == m1s")
call assert_equal (u, m1s_to_mpole (550.0_default), m1s, &
"m1s_to_mpole (550.0_default) == m1s")
write (u, "(A)") ""
call assert_equal (u, f_switch_off (v_matching (ps%sqrts, GAM_M1S)), one, "f_switch_off (v_matching (ps%sqrts, GAM_M1S))")
call formfactor%disable ()
call assert_equal (u, &
abs(formfactor%compute (ps, 1, 1)), &
zero, &
"disabled formfactor should return zero")
call formfactor%activate ()
call assert_equal (u, &
formfactor%compute (ps, 1, EXPANDED_SOFT_SWITCHOFF), &
formfactor%compute (ps, 1, EXPANDED_SOFT), &
"switchoff function should do nothing here")
write (u, "(A)") ""
write (u, "(A)") "* Test output end: ttv_formfactors_1"
end subroutine ttv_formfactors_1
@ %def ttv_formfactors_1
<<(re)start grid>>=
call init_parameters &
(mpole, gam_out, m1s, Vtb, wt_inv, &
alphaemi, sw, alphas_mz, mz, mw, &
mb, sh, sf, NRQCD_ORDER, FF, offshell_strategy, &
v1, v2, scan_sqrts_min, scan_sqrts_max, &
scan_sqrts_stepsize, mpole_fixed, real(top_helicity_selection, default))
call init_threshold_grids (test)
@
@
\subsubsection{Test flags}
<<ttv formfactors: execute tests>>=
call test(ttv_formfactors_2, "ttv_formfactors_2", &
"Test flags", u, results)
<<ttv formfactors: test declarations>>=
public :: ttv_formfactors_2
<<ttv formfactors: tests>>=
subroutine ttv_formfactors_2 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: ttv_formfactors_2"
write (u, "(A)") "* Purpose: Test flags"
write (u, "(A)")
write (u, "(A)") "RESUMMED_SWITCHOFF + NLO"
call threshold%settings%setup_flags (-2, 1, -1)
call assert (u, SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED")
call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED")
call assert (u, threshold%settings%nlo, "threshold%settings%nlo")
call assert (u, .not. threshold%settings%factorized_computation, &
".not. threshold%settings%factorized_computation")
call assert (u, .not. threshold%settings%interference, &
".not. threshold%settings%interference")
call assert (u, .not. threshold%settings%no_nlo_width_in_signal_propagators, &
".not. threshold%settings%no_nlo_width_in_signal_propagators")
write (u, "(A)") "MATCHED + FACTORIZATION"
call threshold%settings%setup_flags (-1, 0+2, -1)
call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo")
call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED")
call assert (u, threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
write (u, "(A)") "RESUMMED + INTERFERENCE"
call threshold%settings%setup_flags (1, 0+0+4, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED")
call assert (u, TOPPIK_RESUMMED, "TOPPIK_RESUMMED")
call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo")
call assert (u, .not. threshold%settings%factorized_computation, &
".not. threshold%settings%factorized_computation")
call assert (u, threshold%settings%interference, "threshold%settings%interference")
write (u, "(A)") "EXPANDED_HARD"
call threshold%settings%setup_flags (4, 0+2+4, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED")
call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED")
call assert (u, .not. threshold%settings%nlo, ".not. threshold%settings%nlo")
call assert (u, threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
call assert (u, threshold%settings%interference, "threshold%settings%interference")
write (u, "(A)") "EXPANDED_SOFT"
call threshold%settings%setup_flags (5, 1+2+4, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, ".not. SWITCHOFF_RESUMMED")
call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED")
call assert (u, threshold%settings%nlo, "threshold%settings%nlo")
call assert (u, threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
call assert (u, threshold%settings%interference, &
"threshold%settings%interference")
write (u, "(A)") "EXPANDED_SOFT_SWITCHOFF"
call threshold%settings%setup_flags (6, 0+0+0+8, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED")
call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED")
call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo")
call assert (u, .not. threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
call assert (u, .not. threshold%settings%interference, &
"threshold%settings%interference")
write (u, "(A)") "RESUMMED_ANALYTIC_LL"
call threshold%settings%setup_flags (7, 0+0+4+8, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED")
call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED")
call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo")
call assert (u, .not. threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
call assert (u, threshold%settings%interference, "threshold%settings%interference")
call assert (u, threshold%settings%onshell_projection%production, &
"threshold%settings%onshell_projection%production")
write (u, "(A)") "EXPANDED_SOFT_HARD"
call threshold%settings%setup_flags (8, 0+2+0+128, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED")
call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED")
call assert (u, .not. threshold%settings%nlo, "threshold%settings%nlo")
call assert (u, threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
call assert (u, .not. threshold%settings%interference, "threshold%settings%interference")
call assert (u, .not. threshold%settings%onshell_projection%production, &
"threshold%settings%onshell_projection%production")
call assert (u, threshold%settings%onshell_projection%decay, &
"threshold%settings%onshell_projection%decay")
write (u, "(A)") "EXTRA_TREE"
call threshold%settings%setup_flags (9, 1+0+0+16+64, -1)
call assert (u, .not. SWITCHOFF_RESUMMED, "SWITCHOFF_RESUMMED")
call assert (u, .not. TOPPIK_RESUMMED, ".not. TOPPIK_RESUMMED")
call assert (u, threshold%settings%nlo, "threshold%settings%nlo")
call assert (u, .not. threshold%settings%factorized_computation, &
"threshold%settings%factorized_computation")
call assert (u, .not. threshold%settings%interference, "threshold%settings%interference")
call assert (u, threshold%settings%onshell_projection%production, &
"threshold%settings%onshell_projection%production")
call assert (u, .not. threshold%settings%onshell_projection%decay, &
"threshold%settings%onshell_projection%decay")
call assert (u, threshold%settings%no_nlo_width_in_signal_propagators, &
"threshold%settings%no_nlo_width_in_signal_propagators")
write (u, "(A)") "test projection of width"
call threshold%settings%setup_flags (9, 0+0+0+0+256, -1)
call assert (u, .not. threshold%settings%onshell_projection%production, &
"threshold%settings%onshell_projection%production")
call assert (u, .not. threshold%settings%onshell_projection%decay, &
"threshold%settings%onshell_projection%decay")
call assert (u, .not. threshold%settings%onshell_projection%width, &
"threshold%settings%onshell_projection%width")
write (u, "(A)") "test boost of decay momenta"
call threshold%settings%setup_flags (9, 512, -1)
if (debug_on) call msg_debug (D_THRESHOLD, &
"threshold%settings%onshell_projection%boost_decay", &
threshold%settings%onshell_projection%boost_decay)
call threshold%settings%setup_flags (9, 0, -1)
if (debug_on) call msg_debug (D_THRESHOLD, &
".not. threshold%settings%onshell_projection%boost_decay", &
.not. threshold%settings%onshell_projection%boost_decay)
write (u, "(A)") "test helicity approximations"
call threshold%settings%setup_flags (9, 32, -1)
call assert (u, threshold%settings%helicity_approximation%simple, &
"threshold%settings%helicity_approximation%simple")
call assert (u, .not. threshold%settings%helicity_approximation%extra, &
".not. threshold%settings%helicity_approximation%extra")
call assert (u, .not. threshold%settings%helicity_approximation%ultra, &
".not. threshold%settings%helicity_approximation%ultra")
call threshold%settings%setup_flags (9, 1024, -1)
call assert (u, .not. threshold%settings%helicity_approximation%simple, &
".not. threshold%settings%helicity_approximation%simple")
call assert (u, threshold%settings%helicity_approximation%extra, &
"threshold%settings%helicity_approximation%extra")
write (u, "(A)")
write (u, "(A)") "* Test output end: ttv_formfactors_2"
end subroutine ttv_formfactors_2
@ %def ttv_formfactors_2
@
Index: trunk/src/events/Makefile.am
===================================================================
--- trunk/src/events/Makefile.am (revision 8768)
+++ trunk/src/events/Makefile.am (revision 8769)
@@ -1,232 +1,232 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory implement quantum field theory concepts
## such as model representation and quantum numbers.
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libevents.la
check_LTLIBRARIES = libevents_ut.la
libevents_la_SOURCES = \
event_base.f90 \
event_handles.f90 \
eio_data.f90 \
eio_base.f90 \
eio_direct.f90 \
eio_checkpoints.f90 \
eio_callback.f90 \
eio_weights.f90 \
eio_dump.f90 \
hep_common.f90 \
hepmc_interface.f90 \
lcio_interface.f90 \
hep_events.f90 \
eio_ascii.f90 \
eio_lhef.f90 \
eio_stdhep.f90 \
eio_hepmc.f90 \
eio_lcio.f90
libevents_ut_la_SOURCES = \
eio_data_uti.f90 eio_data_ut.f90 \
eio_base_uti.f90 eio_base_ut.f90 \
eio_direct_uti.f90 eio_direct_ut.f90 \
eio_checkpoints_uti.f90 eio_checkpoints_ut.f90 \
eio_weights_uti.f90 eio_weights_ut.f90 \
eio_dump_uti.f90 eio_dump_ut.f90 \
hepmc_interface_uti.f90 hepmc_interface_ut.f90 \
lcio_interface_uti.f90 lcio_interface_ut.f90 \
hep_events_uti.f90 hep_events_ut.f90 \
eio_ascii_uti.f90 eio_ascii_ut.f90 \
eio_lhef_uti.f90 eio_lhef_ut.f90 \
eio_stdhep_uti.f90 eio_stdhep_ut.f90 \
eio_hepmc_uti.f90 eio_hepmc_ut.f90 \
eio_lcio_uti.f90 eio_lcio_ut.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = events.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
${libevents_la_SOURCES:.f90=.$(FCMOD)}
libevents_Modules = \
${libevents_la_SOURCES:.f90=} \
${libevents_ut_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libevents_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../utilities/Modules \
../testing/Modules \
../system/Modules \
../parsing/Modules \
../physics/Modules \
../qft/Modules \
../types/Modules \
../particles/Modules \
../xdr/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libevents_la_SOURCES) $(libevents_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES = Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(libevents_la_SOURCES) $(libevents_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
libevents_la_LIBADD = \
../../mcfio/libwo_mcfio.la \
../../stdhep/libwo_stdhep.la
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../parsing -I../physics -I../qft -I../expr_base -I../types -I../fastjet -I../particles -I../xdr
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
events.stamp: $(PRELUDE) $(srcdir)/events.nw $(POSTLUDE)
@rm -f events.tmp
@touch events.tmp
for src in $(libevents_la_SOURCES) $(libevents_ut_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
@mv -f events.tmp events.stamp
$(libevents_la_SOURCES) $(libevents_ut_la_SOURCES): events.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f events.stamp; \
$(MAKE) $(AM_MAKEFLAGS) events.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f events.stamp events.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/blha/Makefile.am
===================================================================
--- trunk/src/blha/Makefile.am (revision 8768)
+++ trunk/src/blha/Makefile.am (revision 8769)
@@ -1,237 +1,237 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory interface the BLHA amplitude calculator
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libblha.la
check_LTLIBRARIES = libblha_ut.la
COMMON_F90 = \
blha_olp_interfaces.f90
MPI_F90 = \
blha_config.f90_mpi
SERIAL_F90 = \
blha_config.f90_serial
EXTRA_DIST = \
$(COMMON_F90) \
$(SERIAL_F90) \
$(MPI_F90)
nodist_libblha_la_SOURCES = \
blha_config.f90 \
$(COMMON_F90)
DISTCLEANFILES = blha_config.f90
if FC_USE_MPI
blha_config.f90: blha_config.f90_mpi
-cp -f $< $@
else
blha_config.f90: blha_config.f90_serial
-cp -f $< $@
endif
libblha_ut_la_SOURCES = \
blha_uti.f90 blha_ut.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = blha.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
${libblha_la_SOURCES:.f90=.$(FCMOD)} \
blha_olp_interfaces.$(FCMOD) \
blha_config.$(FCMOD)
libblha_Modules = $(nodist_libblha_la_SOURCES:.f90=) $(libblha_ut_la_SOURCES:.f90=)
Modules: Makefile
@for module in $(libblha_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../utilities/Modules \
../testing/Modules \
../system/Modules \
../combinatorics/Modules \
../parsing/Modules \
../physics/Modules \
../qft/Modules \
../expr_base/Modules \
../types/Modules \
../variables/Modules \
../model_features/Modules \
../matrix_elements/Modules \
../particles/Modules \
../threshold/Modules \
../beams/Modules \
../me_methods/Modules
include_modules_bare = ${module_lists:/Modules=}
include_modules = ${include_modules_bare:../%=-I../%}
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(nodist_libblha_la_SOURCES) $(libblha_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES += Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(nodist_libblha_la_SOURCES) $(libblha_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = $(include_modules) -I../fastjet -I../pdf_builtin -I../lhapdf
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
FILTER = -filter "sed 's/defn MPI:/defn/'"
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
blha.stamp: $(PRELUDE) $(srcdir)/blha.nw $(POSTLUDE)
@rm -f blha.tmp
@touch blha.tmp
for src in $(COMMON_F90) $(libblha_ut_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
for src in $(SERIAL_F90:.f90_serial=.f90); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \
done
for src in $(MPI_F90:.f90_mpi=.f90); do \
$(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \
done
@mv -f blha.tmp blha.stamp
$(COMMON_F90) $(SERIAL_F90) $(MPI_F90) $(libblha_ut_la_SOURCES): blha.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f blha.stamp; \
$(MAKE) $(AM_MAKEFLAGS) blha.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.f90_serial *.f90_mpi *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.f90_serial *.f90_mpi *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f blha.stamp blha.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/api/Makefile.am
===================================================================
--- trunk/src/api/Makefile.am (revision 8768)
+++ trunk/src/api/Makefile.am (revision 8769)
@@ -1,337 +1,337 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory make up the WHIZARD core
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libapi.la
check_LTLIBRARIES = libapi_ut.la
check_LTLIBRARIES += libapi_ut_c.la
check_LTLIBRARIES += libapi_ut_cc.la
COMMON_F90 = \
api.f90 \
api_c.f90
COMMON_C =
MPI_C =
SERIAL_C =
COMMON_CC = \
api_cc.cc
MPI_CC =
SERIAL_CC =
EXTRA_DIST = \
$(COMMON_C) \
$(SERIAL_C) \
$(MPI_C) \
$(COMMON_CC) \
$(SERIAL_CC) \
$(MPI_CC)
libapi_la_SOURCES = \
$(COMMON_F90) \
api_cc.cc
DISTCLEANFILES = api.f90
libapi_ut_la_SOURCES = \
api_uti.f90 api_ut.f90 \
api_hepmc_uti.f90 api_hepmc_ut.f90 \
api_lcio_uti.f90 api_lcio_ut.f90
nodist_libapi_ut_c_la_SOURCES = \
api_ut_c.c
DISTCLEANFILES += api_ut_c.c
MPI_C += api_ut_c.c_mpi
SERIAL_C += api_ut_c.c_serial
if FC_USE_MPI
api_ut_c.c: api_ut_c.c_mpi
-cp -f $< $@
else
api_ut_c.c: api_ut_c.c_serial
-cp -f $< $@
endif
nodist_libapi_ut_cc_la_SOURCES = \
whizard_ut.cc \
api_ut_cc.cc
DISTCLEANFILES += \
whizard_ut.cc \
api_ut_cc.cc
COMMON_CC += whizard_ut.cc
MPI_CC += api_ut_cc.cc_mpi
SERIAL_CC += api_ut_cc.cc_serial
if FC_USE_MPI
api_ut_cc.cc: api_ut_cc.cc_mpi
-cp -f $< $@
else
api_ut_cc.cc: api_ut_cc.cc_serial
-cp -f $< $@
endif
libapi_la_CPPFLAGS =
libapi_ut_cc_la_CPPFLAGS =
if HEPMC3_AVAILABLE
libapi_la_CPPFLAGS += -DWHIZARD_WITH_HEPMC3 $(HEPMC_INCLUDES)
libapi_ut_cc_la_CPPFLAGS += -DWHIZARD_WITH_HEPMC3 $(HEPMC_INCLUDES)
endif
if HEPMC2_AVAILABLE
libapi_la_CPPFLAGS += -DWHIZARD_WITH_HEPMC2 $(HEPMC_INCLUDES)
libapi_ut_cc_la_CPPFLAGS += -DWHIZARD_WITH_HEPMC2 $(HEPMC_INCLUDES)
endif
if LCIO_AVAILABLE
libapi_la_CPPFLAGS += -DWHIZARD_WITH_LCIO $(LCIO_INCLUDES)
libapi_ut_cc_la_CPPFLAGS += -DWHIZARD_WITH_LCIO $(LCIO_INCLUDES)
endif
include_HEADERS = \
whizard.h
dist_noinst_HEADERS = \
whizard_ut.h
## Omitting this would exclude it from the distribution
dist_noinst_DATA = api.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
api.$(FCMOD)
# Dump module names into file Modules
libapi_Modules = \
${libapi_la_SOURCES:.f90=} \
${libapi_ut_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libapi_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../utilities/Modules \
../testing/Modules \
../system/Modules \
../combinatorics/Modules \
../parsing/Modules \
../rng/Modules \
../physics/Modules \
../qft/Modules \
../expr_base/Modules \
../types/Modules \
../matrix_elements/Modules \
../particles/Modules \
../beams/Modules \
../me_methods/Modules \
../pythia8/Modules \
../events/Modules \
../phase_space/Modules \
../mci/Modules \
../vegas/Modules \
../blha/Modules \
../gosam/Modules \
../openloops/Modules \
../recola/Modules \
../fks/Modules \
../variables/Modules \
../model_features/Modules \
../muli/Modules \
../shower/Modules \
../matching/Modules \
../process_integration/Modules \
../transforms/Modules \
../threshold/Modules \
../whizard-core/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libapi_la_SOURCES) \
$(libapi_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES += Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: \
$(libapi_la_SOURCES) \
$(libapi_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
SUFFIXES = .lo .$(FCMOD)
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../parsing -I../rng -I../physics -I../qed_pdf -I../qft -I../expr_base -I../types -I../matrix_elements -I../particles -I../beams -I../me_methods -I../events -I../phase_space -I../mci -I../vegas -I../blha -I../gosam -I../openloops -I../fks -I../variables -I../model_features -I../muli -I../pythia8 -I../shower -I../matching -I../process_integration -I../transforms -I../xdr -I../../vamp/src -I../pdf_builtin -I../../circe1/src -I../../circe2/src -I../lhapdf -I../fastjet -I../threshold -I../tauola -I../recola -I../whizard-core
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
## MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
if RECOLA_AVAILABLE
AM_FCFLAGS += $(RECOLA_INCLUDES)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
FILTER = -filter "sed 's/defn MPI:/defn/'"
COMMON_SRC = \
$(COMMON_F90) \
$(COMMON_CC) \
$(libapi_ut_la_SOURCES) \
$(libapi_ut_cc_la_SOURCES) \
$(include_HEADERS) \
$(dist_noinst_HEADERS)
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
api.stamp: $(PRELUDE) $(srcdir)/api.nw $(POSTLUDE)
@rm -f api.tmp
@touch api.tmp
for src in $(COMMON_SRC); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
for src in $(MPI_C:.c_mpi=.c); do \
$(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \
done
for src in $(SERIAL_C:.c_serial=.c); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \
done
for src in $(MPI_CC:.cc_mpi=.cc); do \
$(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \
done
for src in $(SERIAL_CC:.cc_serial=.cc); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \
done
@mv -f api.tmp api.stamp
$(COMMON_SRC) $(MPI_C) $(SERIAL_C) $(MPI_CC) $(SERIAL_CC): api.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f api.stamp; \
$(MAKE) $(AM_MAKEFLAGS) api.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.f90_mpi *.f90_serial *.c *.cc *.h *.cpp
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.f90_mpi *.f90_serial \
*.c_mpi *.c_serial *.cc_mpi *.cc_serial *.c *.cc *.h *.cpp || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f api.stamp api.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/utilities/Makefile.am
===================================================================
--- trunk/src/utilities/Makefile.am (revision 8768)
+++ trunk/src/utilities/Makefile.am (revision 8769)
@@ -1,200 +1,226 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory are simple utilities used by WHIZARD
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libutilities.la
check_LTLIBRARIES = libutilities_ut.la
libutilities_la_SOURCES = \
- file_utils.f90 \
- file_registries.f90 \
- string_utils.f90 \
- format_utils.f90 \
- format_defs.f90 \
- numeric_utils.f90 \
- binary_tree.f90 \
- array_list.f90 \
- queue.f90 \
- iterator.f90
+ $(UTILITIES_MODULES) \
+ $(UTILITIES_SUBMODULES)
+
+UTILITIES_MODULES = \
+ file_utils.f90 \
+ file_registries.f90 \
+ string_utils.f90 \
+ format_utils.f90 \
+ format_defs.f90 \
+ numeric_utils.f90 \
+ binary_tree.f90 \
+ array_list.f90 \
+ queue.f90 \
+ iterator.f90
+UTILITIES_SUBMODULES = \
+ file_utils_sub.f90 \
+ file_registries_sub.f90 \
+ string_utils_sub.f90 \
+ format_utils_sub.f90 \
+ numeric_utils_sub.f90 \
+ binary_tree_sub.f90 \
+ array_list_sub.f90 \
+ queue_sub.f90 \
+ iterator_sub.f90
libutilities_ut_la_SOURCES = \
binary_tree_ut.f90 binary_tree_uti.f90 \
array_list_ut.f90 array_list_uti.f90 \
iterator_ut.f90 iterator_uti.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = utilities.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
- ${libutilities_la_SOURCES:.f90=.$(FCMOD)}
+ ${UTILITIES_MODULES:.f90=.$(FCMOD)}
+#Submodules must not be included here
# Dump module names into file Modules
-libutilities_Modules = ${libutilities_la_SOURCES:.f90=} ${libutilities_ut_la_SOURCES:.f90=}
+libutilities_Modules = ${UTILITIES_MODULES:.f90=} ${libutilities_ut_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libutilities_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../testing/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libutilities_la_SOURCES) \
$(libutilities_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES = Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(libutilities_la_SOURCES) $(libutilities_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../testing
+########################################################################
+# For the moment, the submodule dependencies will be hard-coded
+file_utils_sub.lo: file_utils.lo
+file_registries_sub.lo: file_registries.lo
+string_utils_sub.lo: string_utils.lo
+format_utils_sub.lo: format_utils.lo
+numeric_utils_sub.lo: numeric_utils.lo
+binary_tree_sub.lo: binary_tree.lo
+array_list_sub.lo: array_list.lo
+queue_sub.lo: queue.lo
+iterator_sub.lo: iterator.lo
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
## MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
utilities.stamp: $(PRELUDE) $(srcdir)/utilities.nw $(POSTLUDE)
@rm -f utilities.tmp
@touch utilities.tmp
for src in $(libutilities_la_SOURCES) $(libutilities_ut_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
@mv -f utilities.tmp utilities.stamp
$(libutilities_la_SOURCES) $(libutilities_ut_la_SOURCES): utilities.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f utilities.stamp; \
$(MAKE) $(AM_MAKEFLAGS) utilities.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f utilities.stamp utilities.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/utilities/utilities.nw
===================================================================
--- trunk/src/utilities/utilities.nw (revision 8768)
+++ trunk/src/utilities/utilities.nw (revision 8769)
@@ -1,2631 +1,3653 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode -*-
% WHIZARD code as NOWEB source: Utilities
\chapter{Utilities}
\includemodulegraph{utilities}
These modules are intended as part of WHIZARD, but in fact they are
generic and could be useful for any purpose.
The modules depend only on modules from the [[basics]] set.
\begin{description}
\item[file\_utils]
Procedures that deal with external files, if not covered by Fortran
built-ins.
\item[file\_registries]
Manage files that are accessed by their name.
\item[string\_utils]
Some string-handling utilities. Includes conversion to C string.
\item[format\_utils]
Utilities for pretty-printing.
\item[format\_defs]
Predefined format strings.
\item[numeric\_utils]
Utilities for comparing numerical values.
\item[data\_utils]
Utitilies for data structures, i.e. a fixed size queue, polymorphic binary tree and dynamic array list.
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{File Utilities}
This module provides miscellaneous tools associated with named
external files. Currently only:
\begin{itemize}
\item
Delete a named file
\end{itemize}
<<[[file_utils.f90]]>>=
<<File header>>
module file_utils
- use io_units
-
<<Standard module head>>
<<File utils: public>>
+ interface
+<<File utils: sub interfaces>>
+ end interface
+
+end module file_utils
+@ %def file_utils
+<<[[file_utils_sub.f90]]>>=
+<<File header>>
+
+submodule (file_utils) file_utils_s
+
+ use io_units
+
contains
<<File utils: procedures>>
-end module file_utils
-@ %def file_utils
+end submodule file_utils_s
+
+@ %def file_utils_s
@
\subsection{Deleting a file}
Fortran does not contain a command for deleting a file. Here, we
provide a subroutine that deletes a file if it exists. We do not
handle the subtleties, so we assume that it is writable if it exists.
<<File utils: public>>=
public :: delete_file
+<<File utils: sub interfaces>>=
+ module subroutine delete_file (name)
+ character(*), intent(in) :: name
+ end subroutine delete_file
<<File utils: procedures>>=
- subroutine delete_file (name)
+ module subroutine delete_file (name)
character(*), intent(in) :: name
logical :: exist
integer :: u
inquire (file = name, exist = exist)
if (exist) then
u = free_unit ()
open (unit = u, file = name)
close (u, status = "delete")
end if
end subroutine delete_file
@ %def delete_file
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{File Registries}
This module provides a file-registry facility. We can open and close
files multiple times without inadvertedly accessing a single file by two
different I/O unit numbers. Opening a file the first time enters it
into the registry. Opening again just returns the associated I/O
unit. The registry maintains a reference count, so closing a file
does not actually complete until the last reference is released.
File access will always be sequential, however. The file can't be
opened at different positions simultaneously.
<<[[file_registries.f90]]>>=
<<File header>>
module file_registries
<<Use strings>>
- use io_units
<<Standard module head>>
<<File registries: public>>
<<File registries: types>>
+ interface
+<<File registries: sub interfaces>>
+ end interface
+
+end module file_registries
+@ %def file_registries
+@
+<<[[file_registries_sub.f90]]>>=
+<<File header>>
+
+submodule (file_registries) file_registries_s
+
+<<Use strings>>
+ use io_units
+
contains
<<File registries: procedures>>
-end module file_registries
-@ %def file_registries
+end submodule file_registries_s
@
\subsection{File handle}
This object holds a filename (fully qualified), the associated
unit, and a reference count. The idea is that the object should be
deleted when the reference count drops to zero.
<<File registries: types>>=
type :: file_handle_t
type(string_t) :: file
integer :: unit = 0
integer :: refcount = 0
contains
<<File registries: file handle: TBP>>
end type file_handle_t
@ %def file_handle_t
@ Debugging output:
<<File registries: file handle: TBP>>=
procedure :: write => file_handle_write
+<<File registries: sub interfaces>>=
+ module subroutine file_handle_write (handle, u, show_unit)
+ class(file_handle_t), intent(in) :: handle
+ integer, intent(in) :: u
+ logical, intent(in), optional :: show_unit
+ end subroutine file_handle_write
<<File registries: procedures>>=
- subroutine file_handle_write (handle, u, show_unit)
+ module subroutine file_handle_write (handle, u, show_unit)
class(file_handle_t), intent(in) :: handle
integer, intent(in) :: u
logical, intent(in), optional :: show_unit
logical :: show_u
show_u = .false.; if (present (show_unit)) show_u = show_unit
if (show_u) then
write (u, "(3x,A,1x,I0,1x,'(',I0,')')") &
char (handle%file), handle%unit, handle%refcount
else
write (u, "(3x,A,1x,'(',I0,')')") &
char (handle%file), handle%refcount
end if
end subroutine file_handle_write
@ %def file_handle_write
@ Initialize with a file name, don't open the file yet:
<<File registries: file handle: TBP>>=
procedure :: init => file_handle_init
+<<File registries: sub interfaces>>=
+ module subroutine file_handle_init (handle, file)
+ class(file_handle_t), intent(out) :: handle
+ type(string_t), intent(in) :: file
+ end subroutine file_handle_init
<<File registries: procedures>>=
- subroutine file_handle_init (handle, file)
+ module subroutine file_handle_init (handle, file)
class(file_handle_t), intent(out) :: handle
type(string_t), intent(in) :: file
handle%file = file
end subroutine file_handle_init
@ %def file_handle_init
@ We check the [[refcount]] before actually opening the file.
<<File registries: file handle: TBP>>=
procedure :: open => file_handle_open
+<<File registries: sub interfaces>>=
+ module subroutine file_handle_open (handle)
+ class(file_handle_t), intent(inout) :: handle
+ end subroutine file_handle_open
<<File registries: procedures>>=
- subroutine file_handle_open (handle)
+ module subroutine file_handle_open (handle)
class(file_handle_t), intent(inout) :: handle
if (handle%refcount == 0) then
handle%unit = free_unit ()
open (unit = handle%unit, file = char (handle%file), action = "read", &
status = "old")
end if
handle%refcount = handle%refcount + 1
end subroutine file_handle_open
@ %def file_handle_open
@ Analogously, close if the refcount drops to zero. The caller may
then delete the object.
<<File registries: file handle: TBP>>=
procedure :: close => file_handle_close
+<<File registries: sub interfaces>>=
+ module subroutine file_handle_close (handle)
+ class(file_handle_t), intent(inout) :: handle
+ end subroutine file_handle_close
<<File registries: procedures>>=
- subroutine file_handle_close (handle)
+ module subroutine file_handle_close (handle)
class(file_handle_t), intent(inout) :: handle
handle%refcount = handle%refcount - 1
if (handle%refcount == 0) then
close (handle%unit)
handle%unit = 0
end if
end subroutine file_handle_close
@ %def file_handle_close
@ The I/O unit will be nonzero when the file is open.
<<File registries: file handle: TBP>>=
procedure :: is_open => file_handle_is_open
+<<File registries: sub interfaces>>=
+ module function file_handle_is_open (handle) result (flag)
+ class(file_handle_t), intent(in) :: handle
+ logical :: flag
+ end function file_handle_is_open
<<File registries: procedures>>=
- function file_handle_is_open (handle) result (flag)
+ module function file_handle_is_open (handle) result (flag)
class(file_handle_t), intent(in) :: handle
logical :: flag
flag = handle%unit /= 0
end function file_handle_is_open
@ %def file_handle_is_open
@ Return the filename, so we can identify the entry.
<<File registries: file handle: TBP>>=
procedure :: get_file => file_handle_get_file
+<<File registries: sub interfaces>>=
+ module function file_handle_get_file (handle) result (file)
+ class(file_handle_t), intent(in) :: handle
+ type(string_t) :: file
+ end function file_handle_get_file
<<File registries: procedures>>=
- function file_handle_get_file (handle) result (file)
+ module function file_handle_get_file (handle) result (file)
class(file_handle_t), intent(in) :: handle
type(string_t) :: file
file = handle%file
end function file_handle_get_file
@ %def file_handle_get_file
@ For debugging, return the I/O unit number.
<<File registries: file handle: TBP>>=
procedure :: get_unit => file_handle_get_unit
+<<File registries: sub interfaces>>=
+ module function file_handle_get_unit (handle) result (unit)
+ class(file_handle_t), intent(in) :: handle
+ integer :: unit
+ end function file_handle_get_unit
<<File registries: procedures>>=
- function file_handle_get_unit (handle) result (unit)
+ module function file_handle_get_unit (handle) result (unit)
class(file_handle_t), intent(in) :: handle
integer :: unit
unit = handle%unit
end function file_handle_get_unit
@ %def file_handle_get_unit
@
\subsection{File handles registry}
This is implemented as a doubly-linked list. The list exists only
once in the program, as a private module variable.
Extend the handle type to become a list entry:
<<File registries: types>>=
type, extends (file_handle_t) :: file_entry_t
type(file_entry_t), pointer :: prev => null ()
type(file_entry_t), pointer :: next => null ()
end type file_entry_t
@ %def file_entry_t
@ The actual registry. We need only the pointer to the first entry.
<<File registries: public>>=
public :: file_registry_t
<<File registries: types>>=
type :: file_registry_t
type(file_entry_t), pointer :: first => null ()
contains
<<File registries: file registry: TBP>>
end type file_registry_t
@ %def file_registry_t
@ Debugging output.
<<File registries: file registry: TBP>>=
procedure :: write => file_registry_write
+<<File registries: sub interfaces>>=
+ module subroutine file_registry_write (registry, unit, show_unit)
+ class(file_registry_t), intent(in) :: registry
+ integer, intent(in), optional :: unit
+ logical, intent(in), optional :: show_unit
+ end subroutine file_registry_write
<<File registries: procedures>>=
- subroutine file_registry_write (registry, unit, show_unit)
+ module subroutine file_registry_write (registry, unit, show_unit)
class(file_registry_t), intent(in) :: registry
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_unit
type(file_entry_t), pointer :: entry
integer :: u
u = given_output_unit (unit)
if (associated (registry%first)) then
write (u, "(1x,A)") "File registry:"
entry => registry%first
do while (associated (entry))
call entry%write (u, show_unit)
entry => entry%next
end do
else
write (u, "(1x,A)") "File registry: [empty]"
end if
end subroutine file_registry_write
@ %def file_registry_write
@ Open a file: find the appropriate entry. Create a new entry and add
to the list if necessary. The list is extended at the beginning.
Return the I/O unit number for the records.
<<File registries: file registry: TBP>>=
procedure :: open => file_registry_open
+<<File registries: sub interfaces>>=
+ module subroutine file_registry_open (registry, file, unit)
+ class(file_registry_t), intent(inout) :: registry
+ type(string_t), intent(in) :: file
+ integer, intent(out), optional :: unit
+ end subroutine file_registry_open
<<File registries: procedures>>=
- subroutine file_registry_open (registry, file, unit)
+ module subroutine file_registry_open (registry, file, unit)
class(file_registry_t), intent(inout) :: registry
type(string_t), intent(in) :: file
integer, intent(out), optional :: unit
type(file_entry_t), pointer :: entry
entry => registry%first
FIND_ENTRY: do while (associated (entry))
if (entry%get_file () == file) exit FIND_ENTRY
entry => entry%next
end do FIND_ENTRY
if (.not. associated (entry)) then
allocate (entry)
call entry%init (file)
if (associated (registry%first)) then
registry%first%prev => entry
entry%next => registry%first
end if
registry%first => entry
end if
call entry%open ()
if (present (unit)) unit = entry%get_unit ()
end subroutine file_registry_open
@ %def file_registry_open
@ Close a file: find the appropriate entry. Delete the entry if there
is no file connected to it anymore.
<<File registries: file registry: TBP>>=
procedure :: close => file_registry_close
+<<File registries: sub interfaces>>=
+ module subroutine file_registry_close (registry, file)
+ class(file_registry_t), intent(inout) :: registry
+ type(string_t), intent(in) :: file
+ end subroutine file_registry_close
<<File registries: procedures>>=
- subroutine file_registry_close (registry, file)
+ module subroutine file_registry_close (registry, file)
class(file_registry_t), intent(inout) :: registry
type(string_t), intent(in) :: file
type(file_entry_t), pointer :: entry
entry => registry%first
FIND_ENTRY: do while (associated (entry))
if (entry%get_file () == file) exit FIND_ENTRY
entry => entry%next
end do FIND_ENTRY
if (associated (entry)) then
call entry%close ()
if (.not. entry%is_open ()) then
if (associated (entry%prev)) then
entry%prev%next => entry%next
else
registry%first => entry%next
end if
if (associated (entry%next)) then
entry%next%prev => entry%prev
end if
deallocate (entry)
end if
end if
end subroutine file_registry_close
@ %def file_registry_close
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{String Utilities}
This module provides tools associated with strings
(built-in and variable). Currently:
\begin{itemize}
\item
Upper and lower case for strings
\item
Convert to null-terminated C string
\end{itemize}
<<[[string_utils.f90]]>>=
<<File header>>
module string_utils
use, intrinsic :: iso_c_binding
<<Use kinds>>
<<Use strings>>
<<Standard module head>>
<<String utils: public>>
<<String utils: interfaces>>
+ interface
+<<String utils: sub interfaces>>
+ end interface
+
+end module string_utils
+@ %def string_utils
+@
+<<[[string_utils_sub.f90]]>>=
+<<File header>>
+
+submodule (string_utils) string_utils_s
+
contains
<<String utils: procedures>>
-end module string_utils
-@ %def string_utils
+end submodule string_utils_s
+
+@ %def string_utils_s
@
\subsection{Upper and Lower Case}
These are, unfortunately, not part of Fortran.
<<String utils: public>>=
public :: upper_case
public :: lower_case
<<String utils: interfaces>>=
interface upper_case
module procedure upper_case_char, upper_case_string
end interface
interface lower_case
module procedure lower_case_char, lower_case_string
end interface
+<<String utils: sub interfaces>>=
+ module function upper_case_char (string) result (new_string)
+ character(*), intent(in) :: string
+ character(len(string)) :: new_string
+ end function upper_case_char
+ module function lower_case_char (string) result (new_string)
+ character(*), intent(in) :: string
+ character(len(string)) :: new_string
+ end function lower_case_char
+ module function upper_case_string (string) result (new_string)
+ type(string_t), intent(in) :: string
+ type(string_t) :: new_string
+ end function upper_case_string
+ module function lower_case_string (string) result (new_string)
+ type(string_t), intent(in) :: string
+ type(string_t) :: new_string
+ end function lower_case_string
<<String utils: procedures>>=
- function upper_case_char (string) result (new_string)
+ module function upper_case_char (string) result (new_string)
character(*), intent(in) :: string
character(len(string)) :: new_string
integer :: pos, code
integer, parameter :: offset = ichar('A')-ichar('a')
do pos = 1, len (string)
code = ichar (string(pos:pos))
select case (code)
case (ichar('a'):ichar('z'))
new_string(pos:pos) = char (code + offset)
case default
new_string(pos:pos) = string(pos:pos)
end select
end do
end function upper_case_char
- function lower_case_char (string) result (new_string)
+ module function lower_case_char (string) result (new_string)
character(*), intent(in) :: string
character(len(string)) :: new_string
integer :: pos, code
integer, parameter :: offset = ichar('a')-ichar('A')
do pos = 1, len (string)
code = ichar (string(pos:pos))
select case (code)
case (ichar('A'):ichar('Z'))
new_string(pos:pos) = char (code + offset)
case default
new_string(pos:pos) = string(pos:pos)
end select
end do
end function lower_case_char
- function upper_case_string (string) result (new_string)
+ module function upper_case_string (string) result (new_string)
type(string_t), intent(in) :: string
type(string_t) :: new_string
new_string = upper_case_char (char (string))
end function upper_case_string
- function lower_case_string (string) result (new_string)
+ module function lower_case_string (string) result (new_string)
type(string_t), intent(in) :: string
type(string_t) :: new_string
new_string = lower_case_char (char (string))
end function lower_case_string
@ %def upper_case lower_case
@
\subsection{C-Fortran String Conversion}
Convert a FORTRAN string to a null-terminated C string.
<<String utils: public>>=
public :: string_f2c
<<String utils: interfaces>>=
interface string_f2c
module procedure string_f2c_char, string_f2c_var_str
end interface string_f2c
+<<String utils: sub interfaces>>=
+ pure module function string_f2c_char (i) result (o)
+ character(*), intent(in) :: i
+ character(kind=c_char, len=len (i) + 1) :: o
+ end function string_f2c_char
+ pure module function string_f2c_var_str (i) result (o)
+ type(string_t), intent(in) :: i
+ character(kind=c_char, len=len (i) + 1) :: o
+ end function string_f2c_var_str
<<String utils: procedures>>=
- pure function string_f2c_char (i) result (o)
+ pure module function string_f2c_char (i) result (o)
character(*), intent(in) :: i
character(kind=c_char, len=len (i) + 1) :: o
o = i // c_null_char
end function string_f2c_char
- pure function string_f2c_var_str (i) result (o)
+ pure module function string_f2c_var_str (i) result (o)
type(string_t), intent(in) :: i
character(kind=c_char, len=len (i) + 1) :: o
o = char (i) // c_null_char
end function string_f2c_var_str
@ %def string_f2c
@ The same task done by a subroutine, analogous to the C [[strcpy]] function.
We append a null char and copy the characters to the output string, given by a
character array -- which is equal to a [[c_char]] character string by the rule
of sequence association.
Note: Just like with the [[strcpy]] function, there is no bounds check.
<<String utils: public>>=
public :: strcpy_f2c
+<<String utils: sub interfaces>>=
+ module subroutine strcpy_f2c (fstring, cstring)
+ character(*), intent(in) :: fstring
+ character(c_char), dimension(*), intent(inout) :: cstring
+ end subroutine strcpy_f2c
<<String utils: procedures>>=
- subroutine strcpy_f2c (fstring, cstring)
+ module subroutine strcpy_f2c (fstring, cstring)
character(*), intent(in) :: fstring
character(c_char), dimension(*), intent(inout) :: cstring
integer :: i
do i = 1, len (fstring)
cstring(i) = fstring(i:i)
end do
cstring(len(fstring)+1) = c_null_char
end subroutine strcpy_f2c
@ %def strcpy_f2c
@ Convert a null-terminated C string to a Fortran string. The C-string
argument is sequence-associated to a one-dimensional array of C characters,
where we do not know the dimension.
To convert this to a [[string_t]] object, we need to assign it or to wrap it
by another [[var_str]] conversion.
<<String utils: public>>=
public :: string_c2f
+<<String utils: sub interfaces>>=
+ module function string_c2f (cstring) result (fstring)
+ character(c_char), dimension(*), intent(in) :: cstring
+ character(:), allocatable :: fstring
+ end function string_c2f
<<String utils: procedures>>=
- function string_c2f (cstring) result (fstring)
+ module function string_c2f (cstring) result (fstring)
character(c_char), dimension(*), intent(in) :: cstring
character(:), allocatable :: fstring
integer :: i, n
n = 0
do while (cstring(n+1) /= c_null_char)
n = n + 1
end do
allocate (character(n) :: fstring)
do i = 1, n
fstring(i:i) = cstring(i)
end do
end function string_c2f
@ %def string_c2f
@
\subsection{Number Conversion}
Create a string from a number. We use fixed format for the reals
and variable format for integers.
<<String utils: public>>=
public :: str
<<String utils: interfaces>>=
interface str
module procedure str_log, str_logs, str_int, str_ints, &
str_real, str_reals, str_complex, str_complexs
end interface
+<<String utils: sub interfaces>>=
+ module function str_log (l) result (s)
+ logical, intent(in) :: l
+ type(string_t) :: s
+ end function str_log
+ module function str_logs (x) result (s)
+ logical, dimension(:), intent(in) :: x
+ type(string_t) :: s
+ end function str_logs
+ module function str_int (i) result (s)
+ integer, intent(in) :: i
+ type(string_t) :: s
+ end function str_int
+ module function str_ints (x) result (s)
+ integer, dimension(:), intent(in) :: x
+ type(string_t) :: s
+ end function str_ints
+ module function str_real (x) result (s)
+ real(default), intent(in) :: x
+ type(string_t) :: s
+ end function str_real
+ module function str_reals (x) result (s)
+ real(default), dimension(:), intent(in) :: x
+ type(string_t) :: s
+ end function str_reals
+ module function str_complex (x) result (s)
+ complex(default), intent(in) :: x
+ type(string_t) :: s
+ end function str_complex
+ module function str_complexs (x) result (s)
+ complex(default), dimension(:), intent(in) :: x
+ type(string_t) :: s
+ end function str_complexs
<<String utils: procedures>>=
- function str_log (l) result (s)
+ module function str_log (l) result (s)
logical, intent(in) :: l
type(string_t) :: s
if (l) then
s = "True"
else
s = "False"
end if
end function str_log
- function str_logs (x) result (s)
+ module function str_logs (x) result (s)
logical, dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_logs
- function str_int (i) result (s)
+ module function str_int (i) result (s)
integer, intent(in) :: i
type(string_t) :: s
character(32) :: buffer
write (buffer, "(I0)") i
s = var_str (trim (adjustl (buffer)))
end function str_int
- function str_ints (x) result (s)
+ module function str_ints (x) result (s)
integer, dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_ints
- function str_real (x) result (s)
+ module function str_real (x) result (s)
real(default), intent(in) :: x
type(string_t) :: s
character(32) :: buffer
write (buffer, "(ES17.10)") x
s = var_str (trim (adjustl (buffer)))
end function str_real
- function str_reals (x) result (s)
+ module function str_reals (x) result (s)
real(default), dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_reals
- function str_complex (x) result (s)
+ module function str_complex (x) result (s)
complex(default), intent(in) :: x
type(string_t) :: s
s = str_real (real (x)) // " + i " // str_real (aimag (x))
end function str_complex
- function str_complexs (x) result (s)
+ module function str_complexs (x) result (s)
complex(default), dimension(:), intent(in) :: x
<<concatenate strings>>
end function str_complexs
@ %def str
<<concatenate strings>>=
type(string_t) :: s
integer :: i
s = '['
do i = 1, size(x) - 1
s = s // str(x(i)) // ', '
end do
s = s // str(x(size(x))) // ']'
@
@ Auxiliary: Read real, integer, string value.
<<String utils: public>>=
public :: read_rval
public :: read_ival
+<<String utils: sub interfaces>>=
+ module function read_rval (s) result (rval)
+ real(default) :: rval
+ type(string_t), intent(in) :: s
+ end function read_rval
+ module function read_ival (s) result (ival)
+ integer :: ival
+ type(string_t), intent(in) :: s
+ end function read_ival
<<String utils: procedures>>=
- function read_rval (s) result (rval)
+ module function read_rval (s) result (rval)
real(default) :: rval
type(string_t), intent(in) :: s
character(80) :: buffer
buffer = s
read (buffer, *) rval
end function read_rval
- function read_ival (s) result (ival)
+ module function read_ival (s) result (ival)
integer :: ival
type(string_t), intent(in) :: s
character(80) :: buffer
buffer = s
read (buffer, *) ival
end function read_ival
@ %def read_rval read_ival
@
\subsection{String splitting}
<<String utils: public>>=
public :: string_contains_word
+<<String utils: sub interfaces>>=
+ pure module function string_contains_word &
+ (str, word, include_identical) result (val)
+ logical :: val
+ type(string_t), intent(in) :: str, word
+ logical, intent(in), optional :: include_identical
+ end function string_contains_word
<<String utils: procedures>>=
- pure function string_contains_word (str, word, include_identical) result (val)
+ pure module function string_contains_word &
+ (str, word, include_identical) result (val)
logical :: val
type(string_t), intent(in) :: str, word
type(string_t) :: str_tmp, str_out
logical, intent(in), optional :: include_identical
logical :: yorn
str_tmp = str
val = .false.
yorn = .false.; if (present (include_identical)) yorn = include_identical
if (yorn) val = str == word
call split (str_tmp, str_out, word)
val = val .or. (str_out /= "")
end function string_contains_word
@ %def string_contains_word
@ Create an array of strings using a separator.
<<String utils: public>>=
public :: split_string
+<<String utils: sub interfaces>>=
+ pure module subroutine split_string (str, separator, str_array)
+ type(string_t), dimension(:), allocatable, intent(out) :: str_array
+ type(string_t), intent(in) :: str, separator
+ end subroutine split_string
<<String utils: procedures>>=
- pure subroutine split_string (str, separator, str_array)
+ pure module subroutine split_string (str, separator, str_array)
type(string_t), dimension(:), allocatable, intent(out) :: str_array
type(string_t), intent(in) :: str, separator
type(string_t) :: str_tmp, str_out
integer :: n_str
n_str = 0; str_tmp = str
do while (string_contains_word (str_tmp, separator))
n_str = n_str + 1
call split (str_tmp, str_out, separator)
end do
allocate (str_array (n_str))
n_str = 1; str_tmp = str
do while (string_contains_word (str_tmp, separator))
call split (str_tmp, str_array (n_str), separator)
n_str = n_str + 1
end do
end subroutine split_string
@ %def split_string
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Format Utilities}
This module provides miscellaneous tools associated with formatting and
pretty-printing.
\begin{itemize}
\item
Horizontal separator lines in output
\item
Indenting an output line
\item
Formatting a number for \TeX\ output.
\item
Formatting a number for MetaPost output.
\item
Alternate numeric formats.
\end{itemize}
<<[[format_utils.f90]]>>=
<<File header>>
module format_utils
<<Use kinds>>
<<Use strings>>
- use string_utils, only: lower_case
- use io_units, only: given_output_unit
<<Standard module head>>
<<Format utils: public>>
+ interface
+<<Format utils: sub interfaces>>
+ end interface
+
+end module format_utils
+@ %def format_utils
+@
+<<[[format_utils_sub.f90]]>>=
+<<File header>>
+
+submodule (format_utils) format_utils_s
+
+ use string_utils, only: lower_case
+ use io_units, only: given_output_unit
+
contains
<<Format utils: procedures>>
-end module format_utils
-@ %def format_utils
+end submodule format_utils_s
+
+@ %def format_utils_s
@
\subsection{Line Output}
Write a separator line.
<<Format utils: public>>=
public :: write_separator
+<<Format utils: sub interfaces>>=
+ module subroutine write_separator (u, mode)
+ integer, intent(in) :: u
+ integer, intent(in), optional :: mode
+ end subroutine write_separator
<<Format utils: procedures>>=
- subroutine write_separator (u, mode)
+ module subroutine write_separator (u, mode)
integer, intent(in) :: u
integer, intent(in), optional :: mode
integer :: m
m = 1; if (present (mode)) m = mode
select case (m)
case default
write (u, "(A)") repeat ("-", 72)
case (1)
write (u, "(A)") repeat ("-", 72)
case (2)
write (u, "(A)") repeat ("=", 72)
end select
end subroutine write_separator
@ %def write_separator
@
Indent the line with given number of blanks.
<<Format utils: public>>=
public :: write_indent
+<<Format utils: sub interfaces>>=
+ module subroutine write_indent (unit, indent)
+ integer, intent(in) :: unit
+ integer, intent(in), optional :: indent
+ end subroutine write_indent
<<Format utils: procedures>>=
- subroutine write_indent (unit, indent)
+ module subroutine write_indent (unit, indent)
integer, intent(in) :: unit
integer, intent(in), optional :: indent
if (present (indent)) then
write (unit, "(1x,A)", advance="no") repeat (" ", indent)
end if
end subroutine write_indent
@ %def write_indent
@
\subsection{Array Output}
Write an array of integers.
<<Format utils: public>>=
public :: write_integer_array
+<<Format utils: sub interfaces>>=
+ module subroutine write_integer_array (array, unit, n_max, no_skip)
+ integer, intent(in), dimension(:) :: array
+ integer, intent(in), optional :: unit
+ integer, intent(in), optional :: n_max
+ logical, intent(in), optional :: no_skip
+ end subroutine write_integer_array
<<Format utils: procedures>>=
- subroutine write_integer_array (array, unit, n_max, no_skip)
+ module subroutine write_integer_array (array, unit, n_max, no_skip)
integer, intent(in), dimension(:) :: array
integer, intent(in), optional :: unit
integer, intent(in), optional :: n_max
logical, intent(in), optional :: no_skip
integer :: u, i, n
logical :: yorn
u = given_output_unit (unit)
yorn = .false.; if (present (no_skip)) yorn = no_skip
if (present (n_max)) then
n = n_max
else
n = size (array)
end if
do i = 1, n
if (i < n .or. yorn) then
write (u, "(I0, A)", advance = "no") array(i), ", "
else
write (u, "(I0)") array(i)
end if
end do
end subroutine write_integer_array
@ %def write_integer_array
@
\subsection{\TeX-compatible Output}
Quote underscore characters for use in \TeX\ output.
<<Format utils: public>>=
public :: quote_underscore
+<<Format utils: sub interfaces>>=
+ module function quote_underscore (string) result (quoted)
+ type(string_t) :: quoted
+ type(string_t), intent(in) :: string
+ end function quote_underscore
<<Format utils: procedures>>=
- function quote_underscore (string) result (quoted)
+ module function quote_underscore (string) result (quoted)
type(string_t) :: quoted
type(string_t), intent(in) :: string
type(string_t) :: part
type(string_t) :: buffer
buffer = string
quoted = ""
do
call split (part, buffer, "_")
quoted = quoted // part
if (buffer == "") exit
quoted = quoted // "\_"
end do
end function quote_underscore
@ %def quote_underscore
@ Format a number with $n$ significant digits for use in \TeX\ documents.
<<Format utils: public>>=
public :: tex_format
+<<Format utils: sub interfaces>>=
+ module function tex_format (rval, n_digits) result (string)
+ type(string_t) :: string
+ real(default), intent(in) :: rval
+ integer, intent(in) :: n_digits
+ end function tex_format
<<Format utils: procedures>>=
- function tex_format (rval, n_digits) result (string)
+ module function tex_format (rval, n_digits) result (string)
type(string_t) :: string
real(default), intent(in) :: rval
integer, intent(in) :: n_digits
integer :: e, n, w, d
real(default) :: absval
real(default) :: mantissa
character :: sign
character(20) :: format
character(80) :: cstr
n = min (abs (n_digits), 16)
if (rval == 0) then
string = "0"
else
absval = abs (rval)
e = int (log10 (absval))
if (rval < 0) then
sign = "-"
else
sign = ""
end if
select case (e)
case (:-3)
d = max (n - 1, 0)
w = max (d + 2, 2)
write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d
mantissa = absval * 10._default ** (1 - e)
write (cstr, fmt=format) mantissa, "\times 10^{", e - 1, "}"
case (-2:0)
d = max (n - e, 1 - e)
w = max (d + e + 2, d + 2)
write (format, "('(F',I0,'.',I0,')')") w, d
write (cstr, fmt=format) absval
case (1:2)
d = max (n - e - 1, -e, 0)
w = max (d + e + 2, d + 2, e + 2)
write (format, "('(F',I0,'.',I0,')')") w, d
write (cstr, fmt=format) absval
case default
d = max (n - 1, 0)
w = max (d + 2, 2)
write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d
mantissa = absval * 10._default ** (- e)
write (cstr, fmt=format) mantissa, "\times 10^{", e, "}"
end select
string = sign // trim (cstr)
end if
end function tex_format
@ %def tex_format
@
\subsection{Metapost-compatible Output}
Write a number for use in Metapost code:
<<Format utils: public>>=
public :: mp_format
+<<Format utils: sub interfaces>>=
+ module function mp_format (rval) result (string)
+ type(string_t) :: string
+ real(default), intent(in) :: rval
+ end function mp_format
<<Format utils: procedures>>=
- function mp_format (rval) result (string)
+ module function mp_format (rval) result (string)
type(string_t) :: string
real(default), intent(in) :: rval
character(16) :: tmp
write (tmp, "(G16.8)") rval
string = lower_case (trim (adjustl (trim (tmp))))
end function mp_format
@ %def mp_format
@
\subsection{Conditional Formatting}
Conditional format string, intended for switchable numeric precision.
<<Format utils: public>>=
public :: pac_fmt
+<<Format utils: sub interfaces>>=
+ module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify)
+ character(*), intent(in) :: fmt_orig, fmt_pac
+ character(*), intent(out) :: fmt
+ logical, intent(in), optional :: pacify
+ end subroutine pac_fmt
<<Format utils: procedures>>=
- subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify)
+ module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify)
character(*), intent(in) :: fmt_orig, fmt_pac
character(*), intent(out) :: fmt
logical, intent(in), optional :: pacify
logical :: pacified
pacified = .false.
if (present (pacify)) pacified = pacify
if (pacified) then
fmt = fmt_pac
else
fmt = fmt_orig
end if
end subroutine pac_fmt
@ %def pac_fmt
@
\subsection{Guard tiny values}
This function can be applied if values smaller than $10^{-99}$ would cause an
underflow in the output format. We know that Fortran fixed-format can handle
this by omitting the exponent letter, but we should expect non-Fortran or
Fortran list-directed input, which would fail. We reset such values to $\pm
10^{-99}$, assuming that such tiny values would not matter, except for being
non-zero.
<<Format utils: public>>=
public :: refmt_tiny
+<<Format utils: sub interfaces>>=
+ elemental module function refmt_tiny (val) result (trunc_val)
+ real(default), intent(in) :: val
+ real(default) :: trunc_val
+ end function refmt_tiny
<<Format utils: procedures>>=
- elemental function refmt_tiny (val) result (trunc_val)
+ elemental module function refmt_tiny (val) result (trunc_val)
real(default), intent(in) :: val
real(default) :: trunc_val
real(default), parameter :: tiny_val = 1.e-99_default
if (val /= 0) then
if (abs (val) < tiny_val) then
trunc_val = sign (tiny_val, val)
else
trunc_val = val
end if
else
trunc_val = val
end if
end function refmt_tiny
@ %def refmt_tiny
@
\subsection{Compressed output of integer arrays}
<<Format utils: public>>=
public :: write_compressed_integer_array
+<<Format utils: sub interfaces>>=
+ module subroutine write_compressed_integer_array (chars, array)
+ character(len=*), intent(out) :: chars
+ integer, intent(in), allocatable, dimension(:) :: array
+ end subroutine write_compressed_integer_array
<<Format utils: procedures>>=
- subroutine write_compressed_integer_array (chars, array)
+ module subroutine write_compressed_integer_array (chars, array)
character(len=*), intent(out) :: chars
integer, intent(in), allocatable, dimension(:) :: array
logical, dimension(:), allocatable :: used
character(len=16) :: tmp
type(string_t) :: string
integer :: i, j, start_chain, end_chain
chars = '[none]'
string = ""
if (allocated (array)) then
if (size (array) > 0) then
allocate (used (size (array)))
used = .false.
do i = 1, size (array)
if (.not. used(i)) then
start_chain = array(i)
end_chain = array(i)
used(i) = .true.
EXTEND: do
do j = 1, size (array)
if (array(j) == end_chain + 1) then
end_chain = array(j)
used(j) = .true.
cycle EXTEND
end if
if (array(j) == start_chain - 1) then
start_chain = array(j)
used(j) = .true.
cycle EXTEND
end if
end do
exit
end do EXTEND
if (end_chain - start_chain > 0) then
write (tmp, "(I0,A,I0)") start_chain, "-", end_chain
else
write (tmp, "(I0)") start_chain
end if
string = string // trim (tmp)
if (any (.not. used)) then
string = string // ','
end if
end if
end do
chars = string
end if
end if
chars = adjustr (chars)
end subroutine write_compressed_integer_array
@ %def write_compressed_integer_array
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Format Definitions}
This module provides named integer parameters that specify certain
format strings, used for numerical output.
<<[[format_defs.f90]]>>=
<<File header>>
module format_defs
<<Standard module head>>
<<Format defs: public parameters>>
end module format_defs
@ %def format_defs
@ We collect format strings for various numerical output formats here.
<<Format defs: public parameters>>=
character(*), parameter, public :: FMT_19 = "ES19.12"
character(*), parameter, public :: FMT_18 = "ES18.11"
character(*), parameter, public :: FMT_17 = "ES17.10"
character(*), parameter, public :: FMT_16 = "ES16.9"
character(*), parameter, public :: FMT_15 = "ES15.8"
character(*), parameter, public :: FMT_14 = "ES14.7"
character(*), parameter, public :: FMT_13 = "ES13.6"
character(*), parameter, public :: FMT_12 = "ES12.5"
character(*), parameter, public :: FMT_11 = "ES11.4"
character(*), parameter, public :: FMT_10 = "ES10.3"
@ %def FMT_10 FMT_11 FMT_12 FMT_13 FMT_14
@ %def FMT_15 FMT_16 FMT_17 FMT_18 FMT_19
@ Fixed-point formats for better readability, where appropriate.
<<Format defs: public parameters>>=
character(*), parameter, public :: FMF_12 = "F12.9"
@ %def FMF_12
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Numeric Utilities}
<<[[numeric_utils.f90]]>>=
<<File header>>
module numeric_utils
<<Use kinds>>
<<Use strings>>
- use string_utils
- use constants
- use format_defs
<<Standard module head>>
<<Numeric utils: public>>
<<Numeric utils: parameters>>
<<Numeric utils: types>>
<<Numeric utils: interfaces>>
+ interface
+<<Numeric utils: sub interfaces>>
+ end interface
+
+end module numeric_utils
+@ %def numeric_utils
+@
+<<[[numeric_utils_sub.f90]]>>=
+<<File header>>
+
+submodule (numeric_utils) numeric_utils_s
+
+ use string_utils
+ use constants
+ use format_defs
+
contains
<<Numeric utils: procedures>>
-end module numeric_utils
-@ %def numeric_utils
+end submodule numeric_utils_s
+
+@ %def numeric_utils_s
@
<<Numeric utils: public>>=
public :: assert
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert (unit, ok, description, exit_on_fail)
+ integer, intent(in) :: unit
+ logical, intent(in) :: ok
+ character(*), intent(in), optional :: description
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert
<<Numeric utils: procedures>>=
- subroutine assert (unit, ok, description, exit_on_fail)
+ module subroutine assert (unit, ok, description, exit_on_fail)
integer, intent(in) :: unit
logical, intent(in) :: ok
character(*), intent(in), optional :: description
logical, intent(in), optional :: exit_on_fail
logical :: ef
ef = .false.; if (present (exit_on_fail)) ef = exit_on_fail
if (.not. ok) then
if (present(description)) then
write (unit, "(A)") "* FAIL: " // description
else
write (unit, "(A)") "* FAIL: Assertion error"
end if
if (ef) stop 1
end if
end subroutine assert
@ %def assert
@ Compare numbers and output error message if not equal.
<<Numeric utils: public>>=
public:: assert_equal
interface assert_equal
module procedure assert_equal_integer, assert_equal_integers, &
assert_equal_real, assert_equal_reals, &
assert_equal_complex, assert_equal_complexs
end interface
@
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail)
+ integer, intent(in) :: unit
+ integer, intent(in) :: lhs, rhs
+ character(*), intent(in), optional :: description
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert_equal_integer
<<Numeric utils: procedures>>=
- subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail)
+ module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail)
integer, intent(in) :: unit
integer, intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = lhs == rhs
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_integer
@ %def assert_equal_integer
@
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail)
+ integer, intent(in) :: unit
+ integer, dimension(:), intent(in) :: lhs, rhs
+ character(*), intent(in), optional :: description
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert_equal_integers
<<Numeric utils: procedures>>=
- subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail)
+ module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail)
integer, intent(in) :: unit
integer, dimension(:), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = all(lhs == rhs)
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_integers
@ %def assert_equal_integers
@
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert_equal_real (unit, lhs, rhs, description, &
+ abs_smallness, rel_smallness, exit_on_fail)
+ integer, intent(in) :: unit
+ real(default), intent(in) :: lhs, rhs
+ character(*), intent(in), optional :: description
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert_equal_real
<<Numeric utils: procedures>>=
- subroutine assert_equal_real (unit, lhs, rhs, description, &
+ module subroutine assert_equal_real (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
real(default), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = nearly_equal (lhs, rhs, abs_smallness, rel_smallness)
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_real
@ %def assert_equal_real
@
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert_equal_reals (unit, lhs, rhs, description, &
+ abs_smallness, rel_smallness, exit_on_fail)
+ integer, intent(in) :: unit
+ real(default), dimension(:), intent(in) :: lhs, rhs
+ character(*), intent(in), optional :: description
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert_equal_reals
<<Numeric utils: procedures>>=
- subroutine assert_equal_reals (unit, lhs, rhs, description, &
+ module subroutine assert_equal_reals (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
real(default), dimension(:), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = all(nearly_equal (lhs, rhs, abs_smallness, rel_smallness))
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_reals
@ %def assert_equal_reals
@
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert_equal_complex (unit, lhs, rhs, description, &
+ abs_smallness, rel_smallness, exit_on_fail)
+ integer, intent(in) :: unit
+ complex(default), intent(in) :: lhs, rhs
+ character(*), intent(in), optional :: description
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert_equal_complex
<<Numeric utils: procedures>>=
- subroutine assert_equal_complex (unit, lhs, rhs, description, &
+ module subroutine assert_equal_complex (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
complex(default), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness) &
.and. nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness)
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_complex
@ %def assert_equal_complex
@
+<<Numeric utils: sub interfaces>>=
+ module subroutine assert_equal_complexs (unit, lhs, rhs, description, &
+ abs_smallness, rel_smallness, exit_on_fail)
+ integer, intent(in) :: unit
+ complex(default), dimension(:), intent(in) :: lhs, rhs
+ character(*), intent(in), optional :: description
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ logical, intent(in), optional :: exit_on_fail
+ end subroutine assert_equal_complexs
<<Numeric utils: procedures>>=
- subroutine assert_equal_complexs (unit, lhs, rhs, description, &
+ module subroutine assert_equal_complexs (unit, lhs, rhs, description, &
abs_smallness, rel_smallness, exit_on_fail)
integer, intent(in) :: unit
complex(default), dimension(:), intent(in) :: lhs, rhs
character(*), intent(in), optional :: description
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: exit_on_fail
type(string_t) :: desc
logical :: ok
ok = all (nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness)) &
.and. all (nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness))
desc = ''; if (present (description)) desc = var_str(description) // ": "
call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail)
end subroutine assert_equal_complexs
@ %def assert_equal_complexs
@ Note that this poor man's check will be disabled if someone compiles
with [[-ffast-math]] or similar optimizations.
<<Numeric utils: procedures>>=
elemental function ieee_is_nan (x) result (yorn)
logical :: yorn
real(default), intent(in) :: x
yorn = (x /= x)
end function ieee_is_nan
@ %def ieee_is_nan
@ This is still not perfect but should work in most cases. Usually one
wants to compare to a relative epsilon [[rel_smallness]], except for
numbers close to zero defined by [[abs_smallness]]. Both might need
adaption to specific use cases but have reasonable defaults.
<<Numeric utils: public>>=
public :: nearly_equal
<<Numeric utils: interfaces>>=
interface nearly_equal
module procedure nearly_equal_real
module procedure nearly_equal_complex
end interface nearly_equal
+<<Numeric utils: sub interfaces>>=
+ elemental module function nearly_equal_real &
+ (a, b, abs_smallness, rel_smallness) result (r)
+ logical :: r
+ real(default), intent(in) :: a, b
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ end function nearly_equal_real
<<Numeric utils: procedures>>=
- elemental function nearly_equal_real (a, b, abs_smallness, rel_smallness) result (r)
+ elemental module function nearly_equal_real &
+ (a, b, abs_smallness, rel_smallness) result (r)
logical :: r
real(default), intent(in) :: a, b
real(default), intent(in), optional :: abs_smallness, rel_smallness
real(default) :: abs_a, abs_b, diff, abs_small, rel_small
abs_a = abs (a)
abs_b = abs (b)
diff = abs (a - b)
! shortcut, handles infinities and nans
if (a == b) then
r = .true.
return
else if (ieee_is_nan (a) .or. ieee_is_nan (b) .or. ieee_is_nan (diff)) then
r = .false.
return
end if
abs_small = tiny_13; if (present (abs_smallness)) abs_small = abs_smallness
rel_small = tiny_10; if (present (rel_smallness)) rel_small = rel_smallness
if (abs_a < abs_small .and. abs_b < abs_small) then
r = diff < abs_small
else
r = diff / max (abs_a, abs_b) < rel_small
end if
end function nearly_equal_real
@ %def nearly_equal_real
+<<Numeric utils: sub interfaces>>=
+ elemental module function nearly_equal_complex &
+ (a, b, abs_smallness, rel_smallness) result (r)
+ logical :: r
+ complex(default), intent(in) :: a, b
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ end function nearly_equal_complex
<<Numeric utils: procedures>>=
- elemental function nearly_equal_complex (a, b, abs_smallness, rel_smallness) result (r)
+ elemental module function nearly_equal_complex &
+ (a, b, abs_smallness, rel_smallness) result (r)
logical :: r
complex(default), intent(in) :: a, b
real(default), intent(in), optional :: abs_smallness, rel_smallness
r = nearly_equal_real (real (a), real (b), abs_smallness, rel_smallness) .and. &
nearly_equal_real (aimag (a), aimag(b), abs_smallness, rel_smallness)
end function nearly_equal_complex
@ %def neary_equal_complex
@ Often we will need to check whether floats vanish:
<<Numeric utils: public>>=
public:: vanishes
interface vanishes
module procedure vanishes_real, vanishes_complex
end interface
@
+<<Numeric utils: sub interfaces>>=
+ elemental module function vanishes_real &
+ (x, abs_smallness, rel_smallness) result (r)
+ logical :: r
+ real(default), intent(in) :: x
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ end function vanishes_real
+ elemental module function vanishes_complex &
+ (x, abs_smallness, rel_smallness) result (r)
+ logical :: r
+ complex(default), intent(in) :: x
+ real(default), intent(in), optional :: abs_smallness, rel_smallness
+ end function vanishes_complex
<<Numeric utils: procedures>>=
- elemental function vanishes_real (x, abs_smallness, rel_smallness) result (r)
+ elemental module function vanishes_real &
+ (x, abs_smallness, rel_smallness) result (r)
logical :: r
real(default), intent(in) :: x
real(default), intent(in), optional :: abs_smallness, rel_smallness
r = nearly_equal (x, zero, abs_smallness, rel_smallness)
end function vanishes_real
- elemental function vanishes_complex (x, abs_smallness, rel_smallness) result (r)
+ elemental module function vanishes_complex &
+ (x, abs_smallness, rel_smallness) result (r)
logical :: r
complex(default), intent(in) :: x
real(default), intent(in), optional :: abs_smallness, rel_smallness
r = vanishes_real (abs (x), abs_smallness, rel_smallness)
end function vanishes_complex
@ %def vanishes
@
<<Numeric utils: public>>=
public :: expanded_amp2
+<<Numeric utils: sub interfaces>>=
+ pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2)
+ real(default) :: amp2
+ complex(default), dimension(:), intent(in) :: amp_tree, amp_blob
+ end function expanded_amp2
<<Numeric utils: procedures>>=
- pure function expanded_amp2 (amp_tree, amp_blob) result (amp2)
+ pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2)
real(default) :: amp2
complex(default), dimension(:), intent(in) :: amp_tree, amp_blob
amp2 = sum (amp_tree * conjg (amp_tree) + &
amp_tree * conjg (amp_blob) + &
amp_blob * conjg (amp_tree))
end function expanded_amp2
@ %def expanded_amp2
@
<<Numeric utils: public>>=
public :: abs2
+<<Numeric utils: sub interfaces>>=
+ elemental module function abs2 (c) result (c2)
+ real(default) :: c2
+ complex(default), intent(in) :: c
+ end function abs2
<<Numeric utils: procedures>>=
- elemental function abs2 (c) result (c2)
+ elemental module function abs2 (c) result (c2)
real(default) :: c2
complex(default), intent(in) :: c
c2 = real (c * conjg(c))
end function abs2
@ %def abs2
@ Remove element with [[index]] from array
<<Numeric utils: public>>=
public:: remove_array_element
interface remove_array_element
module procedure remove_array_element_logical
end interface
@
+<<Numeric utils: sub interfaces>>=
+ module function remove_array_element_logical &
+ (array, index) result (array_reduced)
+ logical, intent(in), dimension(:) :: array
+ integer, intent(in) :: index
+ logical, dimension(:), allocatable :: array_reduced
+ end function remove_array_element_logical
<<Numeric utils: procedures>>=
- function remove_array_element_logical (array, index) result (array_reduced)
+ module function remove_array_element_logical &
+ (array, index) result (array_reduced)
logical, intent(in), dimension(:) :: array
integer, intent(in) :: index
logical, dimension(:), allocatable :: array_reduced
integer :: i
allocate (array_reduced(0))
do i = 1, size (array)
if (i /= index) then
array_reduced = [array_reduced, [array(i)]]
end if
end do
end function remove_array_element_logical
@ %def remove_array_element
@ Remove all duplicates from an array of signed integers and returns an
unordered array of remaining elements.
This method does not really fit into this module. It could be part of a
larger module which deals with array manipulations.
<<Numeric utils: public>>=
public :: remove_duplicates_from_int_array
+<<Numeric utils: sub interfaces>>=
+ module function remove_duplicates_from_int_array &
+ (array) result (array_unique)
+ integer, intent(in), dimension(:) :: array
+ integer, dimension(:), allocatable :: array_unique
+ end function remove_duplicates_from_int_array
<<Numeric utils: procedures>>=
- function remove_duplicates_from_int_array (array) result (array_unique)
+ module function remove_duplicates_from_int_array &
+ (array) result (array_unique)
integer, intent(in), dimension(:) :: array
integer, dimension(:), allocatable :: array_unique
integer :: i
allocate (array_unique(0))
do i = 1, size (array)
if (any (array_unique == array(i))) cycle
array_unique = [array_unique, [array(i)]]
end do
end function remove_duplicates_from_int_array
@ %def remove_duplicates_from_int_array
@
<<Numeric utils: public>>=
public :: extend_integer_array
+<<Numeric utils: sub interfaces>>=
+ module subroutine extend_integer_array (list, incr, initial_value)
+ integer, intent(inout), dimension(:), allocatable :: list
+ integer, intent(in) :: incr
+ integer, intent(in), optional :: initial_value
+ end subroutine extend_integer_array
<<Numeric utils: procedures>>=
- subroutine extend_integer_array (list, incr, initial_value)
+ module subroutine extend_integer_array (list, incr, initial_value)
integer, intent(inout), dimension(:), allocatable :: list
integer, intent(in) :: incr
integer, intent(in), optional :: initial_value
integer, dimension(:), allocatable :: list_store
integer :: n, ini
ini = 0; if (present (initial_value)) ini = initial_value
n = size (list)
allocate (list_store (n))
list_store = list
deallocate (list)
allocate (list (n+incr))
list(1:n) = list_store
list(1+n : n+incr) = ini
deallocate (list_store)
end subroutine extend_integer_array
@ %def extend_integer_array
@
<<Numeric utils: public>>=
public :: crop_integer_array
+<<Numeric utils: sub interfaces>>=
+ module subroutine crop_integer_array (list, i_crop)
+ integer, intent(inout), dimension(:), allocatable :: list
+ integer, intent(in) :: i_crop
+ end subroutine crop_integer_array
<<Numeric utils: procedures>>=
- subroutine crop_integer_array (list, i_crop)
+ module subroutine crop_integer_array (list, i_crop)
integer, intent(inout), dimension(:), allocatable :: list
integer, intent(in) :: i_crop
integer, dimension(:), allocatable :: list_store
allocate (list_store (i_crop))
list_store = list(1:i_crop)
deallocate (list)
allocate (list (i_crop))
list = list_store
deallocate (list_store)
end subroutine crop_integer_array
@ %def crop_integer_array
@ We also need an evaluation of $\log x$ which is stable near $x=1$.
<<Numeric utils: public>>=
public :: log_prec
+<<Numeric utils: sub interfaces>>=
+ module function log_prec (x, xb) result (lx)
+ real(default), intent(in) :: x, xb
+ real(default) :: lx
+ end function log_prec
<<Numeric utils: procedures>>=
- function log_prec (x, xb) result (lx)
+ module function log_prec (x, xb) result (lx)
real(default), intent(in) :: x, xb
real(default) :: a1, a2, a3, lx
a1 = xb
a2 = a1 * xb / two
a3 = a2 * xb * two / three
if (abs (a3) < epsilon (a3)) then
lx = - a1 - a2 - a3
else
lx = log (x)
end if
end function log_prec
@ %def log_prec
@
<<Numeric utils: public>>=
public :: split_array
<<Numeric utils: interfaces>>=
interface split_array
module procedure split_integer_array
module procedure split_real_array
end interface
+<<Numeric utils: sub interfaces>>=
+ module subroutine split_integer_array (list1, list2)
+ integer, intent(inout), dimension(:), allocatable :: list1, list2
+ integer, dimension(:), allocatable :: list_store
+ end subroutine split_integer_array
+ module subroutine split_real_array (list1, list2)
+ real(default), intent(inout), dimension(:), allocatable :: list1, list2
+ real(default), dimension(:), allocatable :: list_store
+ end subroutine split_real_array
<<Numeric utils: procedures>>=
- subroutine split_integer_array (list1, list2)
+ module subroutine split_integer_array (list1, list2)
integer, intent(inout), dimension(:), allocatable :: list1, list2
integer, dimension(:), allocatable :: list_store
allocate (list_store (size (list1) - size (list2)))
list2 = list1(:size (list2))
list_store = list1 (size (list2) + 1:)
deallocate (list1)
allocate (list1 (size (list_store)))
list1 = list_store
deallocate (list_store)
end subroutine split_integer_array
- subroutine split_real_array (list1, list2)
+ module subroutine split_real_array (list1, list2)
real(default), intent(inout), dimension(:), allocatable :: list1, list2
real(default), dimension(:), allocatable :: list_store
allocate (list_store (size (list1) - size (list2)))
list2 = list1(:size (list2))
list_store = list1 (size (list2) + 1:)
deallocate (list1)
allocate (list1 (size (list_store)))
list1 = list_store
deallocate (list_store)
end subroutine split_real_array
@ %def split_array
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Binary Tree}
<<[[binary_tree.f90]]>>=
<<File header>>
module binary_tree
- use io_units
implicit none
private
+<<Binary trees: public>>
+
+<<Binary trees: types>>
+
+ interface
+<<Binary trees: sub interfaces>>
+ end interface
+
+contains
+
+<<Binary trees: module procedures>>
+
+end module binary_tree
+@ %def binary_tree
+@
+<<[[binary_tree_sub.f90]]>>=
+<<File header>>
+
+submodule (binary_tree) binary_tree_s
+
+ use io_units
+
+contains
+
+<<Binary trees: procedures>>
+
+end submodule binary_tree_s
+
+@ %def binary_tree_s
+@
+<<Binary trees: public>>=
+ public :: binary_tree_iterator_t
+<<Binary trees: types>>=
type :: binary_tree_iterator_t
integer, dimension(:), allocatable :: key
integer :: current
!! current \in {1, N}.
contains
- procedure :: init => binary_tree_iterator_init
- procedure :: is_iterable => binary_tree_iterator_is_iterable
- procedure :: next => binary_tree_iterator_next
+ <<Binary trees: iterator: TBP>>
end type binary_tree_iterator_t
+@ %def binary_tree_iterator_t
+@
+<<Binary trees: types>>=
type :: binary_tree_node_t
integer :: height = 0
type(binary_tree_node_t), pointer :: left => null ()
type(binary_tree_node_t), pointer :: right => null ()
!!
integer :: key = 0
class(*), pointer :: obj => null ()
contains
- procedure :: init => binary_tree_node_init
- procedure :: write => binary_tree_node_write
- procedure :: get_balance => binary_tree_node_get_balance
- procedure :: increment_height => binary_tree_node_increment_height
- final :: binary_tree_node_final
+ <<Binary trees: node: TBP>>
end type binary_tree_node_t
+@ %def binary_tree_node_t
+@
+<<Binary trees: public>>=
+ public :: binary_tree_t
+<<Binary trees: types>>=
type :: binary_tree_t
integer :: n_elements = 0
type(binary_tree_node_t), pointer :: root => null ()
contains
- procedure :: write => binary_tree_write
- procedure :: get_n_elements => binary_tree_get_n_elements
- procedure :: insert => binary_tree_insert
- procedure, private :: insert_node => binary_tree_insert_node
- procedure, private :: balance => binary_tree_balance
- procedure :: search => binary_tree_search
- procedure :: has_key => binary_tree_has_key
- procedure, private :: rotate_left => binary_tree_rotate_left
- procedure, private :: rotate_right => binary_tree_rotate_right
- procedure :: clear => binary_tree_clear
- final :: binary_tree_final
+ <<Binary trees: tree: TBP>>
end type binary_tree_t
- public :: binary_tree_t, binary_tree_iterator_t
-contains
+@ %def binary_tree_t
+@
+<<Binary trees: iterator: TBP>>=
+ procedure :: init => binary_tree_iterator_init
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_iterator_init (iterator, btree)
+ class(binary_tree_iterator_t), intent(inout) :: iterator
+ type(binary_tree_t), target :: btree
+ end subroutine binary_tree_iterator_init
+<<Binary trees: procedures>>=
!! We store all keys of the binary tree in an index array.
!! Flatten the tree O(log n), each access is then O(1).
!! However, accessing the corresponding object costs one O(log n).
- subroutine binary_tree_iterator_init (iterator, btree)
+ module subroutine binary_tree_iterator_init (iterator, btree)
class(binary_tree_iterator_t), intent(inout) :: iterator
type(binary_tree_t), target :: btree
type(binary_tree_node_t), pointer :: node
integer :: idx
iterator%current = 1
allocate (iterator%key(btree%get_n_elements ()), source = 0)
if (.not. btree%get_n_elements () > 0) return
idx = 1; call fill_key (idx, iterator%key, btree%root)
contains
recursive subroutine fill_key (idx, key, node)
integer, intent(inout) :: idx
integer, dimension(:), intent(inout) :: key
type(binary_tree_node_t), pointer :: node
if (associated (node%left)) &
call fill_key (idx, key, node%left)
key(idx) = node%key
idx = idx + 1
if (associated (node%right)) &
call fill_key (idx, key, node%right)
end subroutine fill_key
end subroutine binary_tree_iterator_init
- function binary_tree_iterator_is_iterable (iterator) result (flag)
+@ %def binary_tree_iterator_init
+@
+<<Binary trees: iterator: TBP>>=
+ procedure :: is_iterable => binary_tree_iterator_is_iterable
+<<Binary trees: sub interfaces>>=
+ module function binary_tree_iterator_is_iterable (iterator) result (flag)
+ class(binary_tree_iterator_t), intent(in) :: iterator
+ logical :: flag
+ end function binary_tree_iterator_is_iterable
+<<Binary trees: procedures>>=
+ module function binary_tree_iterator_is_iterable (iterator) result (flag)
class(binary_tree_iterator_t), intent(in) :: iterator
logical :: flag
flag = iterator%current <= size (iterator%key)
end function binary_tree_iterator_is_iterable
- subroutine binary_tree_iterator_next (iterator, key)
+@ %def binary_tree_iterator_is_handle
+@
+<<Binary trees: iterator: TBP>>=
+ procedure :: next => binary_tree_iterator_next
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_iterator_next (iterator, key)
+ class(binary_tree_iterator_t), intent(inout) :: iterator
+ integer, intent(out) :: key
+ end subroutine binary_tree_iterator_next
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_iterator_next (iterator, key)
class(binary_tree_iterator_t), intent(inout) :: iterator
integer, intent(out) :: key
if (.not. iterator%is_iterable ()) then
key = 0
else
key = iterator%key(iterator%current)
iterator%current = iterator%current + 1
end if
end subroutine binary_tree_iterator_next
- subroutine binary_tree_node_init (btree_node, key, obj)
+@ %def binary_tree_iterator_next
+@
+<<Binary trees: node: TBP>>=
+ procedure :: init => binary_tree_node_init
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_node_init (btree_node, key, obj)
+ class(binary_tree_node_t), intent(inout) :: btree_node
+ integer, intent(in) :: key
+ class(*), pointer :: obj
+ end subroutine binary_tree_node_init
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_node_init (btree_node, key, obj)
class(binary_tree_node_t), intent(inout) :: btree_node
integer, intent(in) :: key
class(*), pointer :: obj
btree_node%height = 1
btree_node%left => null ()
btree_node%right => null ()
btree_node%key = key
btree_node%obj => obj
end subroutine binary_tree_node_init
- recursive subroutine binary_tree_node_write (btree_node, unit, level, mode)
+@ %def binary_tree_node_init
+@
+<<Binary trees: node: TBP>>=
+ procedure :: write => binary_tree_node_write
+<<Binary trees: sub interfaces>>=
+ recursive module subroutine binary_tree_node_write &
+ (btree_node, unit, level, mode)
+ class(binary_tree_node_t), intent(in) :: btree_node
+ integer, intent(in) :: unit
+ integer, intent(in) :: level
+ character(len=*), intent(in) :: mode
+ end subroutine binary_tree_node_write
+<<Binary trees: procedures>>=
+ recursive module subroutine binary_tree_node_write &
+ (btree_node, unit, level, mode)
class(binary_tree_node_t), intent(in) :: btree_node
integer, intent(in) :: unit
integer, intent(in) :: level
character(len=*), intent(in) :: mode
character(len=24) :: fmt
if (level > 0) then
write (fmt, "(A,I3,A)") "(", 3 * level, "X,A,1X,I3,1X,I3,A)"
else
fmt = "(A,1X,I3,1X,I3,1X)"
end if
write (unit, fmt) mode, btree_node%key, btree_node%height
! write (unit, fmt) btree_node%key, btree_node%get_balance ()
if (associated (btree_node%right)) &
call btree_node%right%write (unit, level = level + 1, mode = ">")
if (associated (btree_node%left)) &
call btree_node%left%write (unit, level = level + 1, mode = "<")
end subroutine binary_tree_node_write
- integer function binary_tree_node_get_balance (btree_node) result (balance)
+@ %def binary_tree_node_write
+@
+<<Binary trees: node: TBP>>=
+ procedure :: get_balance => binary_tree_node_get_balance
+<<Binary trees: sub interfaces>>=
+ module function binary_tree_node_get_balance (btree_node) result (balance)
+ class(binary_tree_node_t), intent(in) :: btree_node
+ integer :: balance
+ end function binary_tree_node_get_balance
+<<Binary trees: procedures>>=
+ module function binary_tree_node_get_balance (btree_node) result (balance)
class(binary_tree_node_t), intent(in) :: btree_node
+ integer :: balance
integer :: leftHeight, rightHeight
leftHeight = 0
rightHeight = 0
if (associated (btree_node%left)) leftHeight = btree_node%left%height
if (associated (btree_node%right)) rightHeight = btree_node%right%height
balance = leftHeight - rightHeight
end function binary_tree_node_get_balance
- subroutine binary_tree_node_increment_height (btree_node)
+@ %def binary_tree_node_get_balance
+@
+<<Binary trees: node: TBP>>=
+ procedure :: increment_height => binary_tree_node_increment_height
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_node_increment_height (btree_node)
+ class(binary_tree_node_t), intent(inout) :: btree_node
+ end subroutine binary_tree_node_increment_height
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_node_increment_height (btree_node)
class(binary_tree_node_t), intent(inout) :: btree_node
integer :: leftHeight, rightHeight
leftHeight = 0
rightHeight = 0
if (associated (btree_node%left)) leftHeight = btree_node%left%height
if (associated (btree_node%right)) rightHeight = btree_node%right%height
btree_node%height = max (leftHeight, rightHeight) + 1
end subroutine binary_tree_node_increment_height
+@ %def binary_tree_node_increment_height
+@
+<<Binary trees: node: TBP>>=
+ final :: binary_tree_node_final
+<<Binary trees: sub interfaces>>=
+ !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism
+ !!! module subroutine binary_tree_node_final (btree_node)
+ !!! type(binary_tree_node_t), intent(inout) :: btree_node
+ !!! end subroutine binary_tree_node_final
+<<Binary trees: module procedures>>=
recursive subroutine binary_tree_node_final (btree_node)
type(binary_tree_node_t), intent(inout) :: btree_node
if (associated (btree_node%left)) deallocate (btree_node%left)
if (associated (btree_node%right)) deallocate (btree_node%right)
deallocate (btree_node%obj)
end subroutine binary_tree_node_final
- subroutine binary_tree_write (btree, unit)
+@ %def binary_tree_node_final
+@
+<<Binary trees: tree: TBP>>=
+ procedure :: write => binary_tree_write
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_write (btree, unit)
+ class(binary_tree_t), intent(in) :: btree
+ integer, intent(in), optional :: unit
+ end subroutine binary_tree_write
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_write (btree, unit)
class(binary_tree_t), intent(in) :: btree
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit(unit=unit)
write (u, "(A,1X,I3)") "Number of elements", btree%n_elements
if (associated (btree%root)) then
call btree%root%write (u, level = 0, mode = "*")
else
write (u, "(A)") "Binary tree is empty."
end if
end subroutine binary_tree_write
+@ %def binary_tree_write
+@
+<<Binary trees: tree: TBP>>=
+ final :: binary_tree_final
+<<Binary trees: sub interfaces>>=
+ !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism
+ !!! module subroutine binary_tree_final (btree)
+ !!! type(binary_tree_t), intent(inout) :: btree
+ !!! end subroutine binary_tree_final
+<<Binary trees: module procedures>>=
subroutine binary_tree_final (btree)
type(binary_tree_t), intent(inout) :: btree
btree%n_elements = 0
if (associated (btree%root)) then
deallocate (btree%root)
end if
end subroutine binary_tree_final
- subroutine binary_tree_clear (btree)
+@ %def binary_tree_final
+@
+<<Binary trees: tree: TBP>>=
+ procedure :: clear => binary_tree_clear
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_clear (btree)
+ class(binary_tree_t), intent(inout) :: btree
+ end subroutine binary_tree_clear
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_clear (btree)
class(binary_tree_t), intent(inout) :: btree
call binary_tree_final (btree)
end subroutine binary_tree_clear
- integer function binary_tree_get_n_elements (btree) result (n)
+@ %def binary_tree_clear
+@
+<<Binary trees: tree: TBP>>=
+ procedure :: get_n_elements => binary_tree_get_n_elements
+<<Binary trees: sub interfaces>>=
+ module function binary_tree_get_n_elements (btree) result (n)
+ class(binary_tree_t), intent(in) :: btree
+ integer :: n
+ end function binary_tree_get_n_elements
+<<Binary trees: procedures>>=
+ module function binary_tree_get_n_elements (btree) result (n)
class(binary_tree_t), intent(in) :: btree
+ integer :: n
n = btree%n_elements
end function binary_tree_get_n_elements
- subroutine binary_tree_insert (btree, key, obj)
+@ %def binary_tree_get_n_elements
+@
+<<Binary trees: tree: TBP>>=
+ procedure :: insert => binary_tree_insert
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_insert (btree, key, obj)
+ class(binary_tree_t), intent(inout) :: btree
+ integer, intent(in) :: key
+ class(*), pointer, intent(in) :: obj
+ end subroutine binary_tree_insert
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_insert (btree, key, obj)
class(binary_tree_t), intent(inout) :: btree
integer, intent(in) :: key
class(*), pointer, intent(in) :: obj
type(binary_tree_node_t), pointer :: node
allocate (node)
call node%init (key, obj)
btree%n_elements = btree%n_elements + 1
if (.not. associated (btree%root)) then
btree%root => node
else
call btree%insert_node (btree%root, node)
end if
end subroutine binary_tree_insert
- recursive subroutine binary_tree_insert_node (btree, parent, node)
+@ %def binary_tree_import
+@
+<<Binary trees: tree: TBP>>=
+ procedure, private :: insert_node => binary_tree_insert_node
+<<Binary trees: sub interfaces>>=
+ recursive module subroutine binary_tree_insert_node (btree, parent, node)
+ class(binary_tree_t), intent(in) :: btree
+ type(binary_tree_node_t), intent(inout), pointer :: parent
+ type(binary_tree_node_t), intent(in), pointer :: node
+ end subroutine binary_tree_insert_node
+<<Binary trees: procedures>>=
+ recursive module subroutine binary_tree_insert_node (btree, parent, node)
class(binary_tree_t), intent(in) :: btree
type(binary_tree_node_t), intent(inout), pointer :: parent
type(binary_tree_node_t), intent(in), pointer :: node
!! Choose left or right, if associated descend recursively into subtree,
!! else insert node.
if (node%key > parent%key) then
if (associated (parent%right)) then
call btree%insert_node (parent%right, node)
else
parent%right => node
end if
else if (node%key < parent%key) then
if (associated (parent%left)) then
call btree%insert_node (parent%left, node)
else
parent%left => node
end if
else
write (*, "(A,1X,I0)") "Error: MUST not insert duplicate key", node%key
stop 1
end if
call parent%increment_height ()
call btree%balance (parent, node%key)
end subroutine binary_tree_insert_node
+@ %def binary_tree_insert_node
+@
+<<Binary trees: tree: TBP>>=
+ procedure, private :: balance => binary_tree_balance
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_balance (btree, subtree, key)
+ class(binary_tree_t), intent(in) :: btree
+ type(binary_tree_node_t), intent(inout), pointer :: subtree
+ integer, intent(in) :: key
+ end subroutine binary_tree_balance
+<<Binary trees: procedures>>=
!! Subtree: root of subtree (which is unbalance, refer to A in diagrams.)
- subroutine binary_tree_balance (btree, subtree, key)
+ module subroutine binary_tree_balance (btree, subtree, key)
class(binary_tree_t), intent(in) :: btree
type(binary_tree_node_t), intent(inout), pointer :: subtree
integer, intent(in) :: key
type(binary_tree_node_t), pointer :: node, newNode
integer :: balance
balance = subtree%get_balance ()
node => subtree
newNode => null ()
!! balance := h_left - h_right.
!! Proof: balance > 0 => too many elements on the left side of the subtree.
!! Proof: balance < 0 => too many elements on the right side of the subtree.
if (balance > 1) then
!! => left-side of subtree
!! A3(2) B2(1)
!! / / \
!! B2(1) C1(0) A1(0)
!! /
!! C1(0)
!!
!! A3(3) A1(2) C2(1)
!! / / / \
!! B1(1) LEFT C2(1) RIGHT B1(0) A3(0)
!! \ /
!! C2(0) B1(0)
if (subtree%left%key > key) then !! rotate right
call btree%rotate_right (node, newNode)
else !! subtree%left%key < key, rotate left, then right.
call btree%rotate_left (node%left, newNode)
node%left => newNode
call btree%rotate_right (node, newNode)
end if
else if (balance < -1) then
!! => right-side of subtree
!! A0(2) B1(1)
!! \ / \
!! B1(1) A1(0) C3(0)
!! \
!! C3(0)*
!!
!! A1(2) A1(2) C2(1)
!! \ \ / \
!! B3(1) RIGHT C2(1) LEFT A1(0) B3(0)
!! / \
!! C2(0) B3(0)
if (subtree%right%key < key) then !! rotate left
call btree%rotate_left (node, newNode)
else !! subtree%right%key > key, rotate right, then left.
call btree%rotate_right (node%right, newNode)
node%right => newNode
call btree%rotate_left (node, newNode)
end if
end if
if (associated (newNode)) subtree => newNode
end subroutine binary_tree_balance
- subroutine binary_tree_search (btree, key, obj)
+@ %def binary_tree_balance
+@
+<<Binary trees: tree: TBP>>=
+ procedure :: search => binary_tree_search
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_search (btree, key, obj)
+ class(binary_tree_t), intent(in) :: btree
+ integer, intent(in) :: key
+ class(*), pointer, intent(out) :: obj
+ end subroutine binary_tree_search
+<<Binary trees: procedures>>=
+ module subroutine binary_tree_search (btree, key, obj)
class(binary_tree_t), intent(in) :: btree
integer, intent(in) :: key
class(*), pointer, intent(out) :: obj
type(binary_tree_node_t), pointer :: current
current => btree%root
obj => null ()
if (.not. associated (current)) return
do while (current%key /= key)
if (current%key > key) then
current => current%left
else
current => current%right
end if
if (.not. associated (current)) then
!! Key not found.
exit
end if
end do
if (associated (current)) obj => current%obj
end subroutine binary_tree_search
- function binary_tree_has_key (btree, key) result (flag)
+@ %def binary_tree_search
+@
+<<Binary trees: tree: TBP>>=
+ procedure :: has_key => binary_tree_has_key
+<<Binary trees: sub interfaces>>=
+ module function binary_tree_has_key (btree, key) result (flag)
+ class(binary_tree_t), intent(in) :: btree
+ integer, intent(in) :: key
+ logical :: flag
+ end function binary_tree_has_key
+<<Binary trees: procedures>>=
+ module function binary_tree_has_key (btree, key) result (flag)
class(binary_tree_t), intent(in) :: btree
integer, intent(in) :: key
logical :: flag
type(binary_tree_node_t), pointer :: current
current => btree%root
flag = .false.
if (.not. associated (current)) return
do while (current%key /= key)
if (current%key > key) then
current => current%left
else
current => current%right
end if
if (.not. associated (current)) then
!! Key not found.
return
end if
end do
flag = .true.
end function binary_tree_has_key
+@ %def binary_tree_has_key
+@
+<<Binary trees: tree: TBP>>=
+ procedure, private :: rotate_right => binary_tree_rotate_right
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_rotate_right (btree, root, new_root)
+ class(binary_tree_t), intent(in) :: btree
+ type(binary_tree_node_t), pointer, intent(inout) :: root
+ type(binary_tree_node_t), pointer, intent(out) :: new_root
+ end subroutine binary_tree_rotate_right
+<<Binary trees: procedures>>=
!! A Move B to A.
!! / \
!! B E 1. Split B from A%left.
!! / \ 2. Temporarily pointer to D.
!! C D 3. Replace pointer to D by pointer to A - E.
!! 4. Set temporary pointer to D to A%left.
!!
!! 1.+2. B T => D A
!! / \
!! C E
!!
!! 3. B T => D
!! / \
!! C A
!! \
!! E
!!
!! 4. B
!! / \
!! C A
!! / \
!! D E
!!
!! \param[inout] root Root/parent root (A).
!! \param[out] new_root New root/parent root (B).
- subroutine binary_tree_rotate_right (btree, root, new_root)
+ module subroutine binary_tree_rotate_right (btree, root, new_root)
class(binary_tree_t), intent(in) :: btree
type(binary_tree_node_t), pointer, intent(inout) :: root
type(binary_tree_node_t), pointer, intent(out) :: new_root
type(binary_tree_node_t), pointer :: tmp
new_root => root%left
tmp => new_root%right
new_root%right => root
root%left => tmp
call root%increment_height ()
call new_root%increment_height ()
end subroutine binary_tree_rotate_right
+@ %def binary_tree_rotate_right
+@
+<<Binary trees: tree: TBP>>=
+ procedure, private :: rotate_left => binary_tree_rotate_left
+<<Binary trees: sub interfaces>>=
+ module subroutine binary_tree_rotate_left (btree, root, new_root)
+ class(binary_tree_t), intent(in) :: btree
+ type(binary_tree_node_t), pointer, intent(inout) :: root
+ type(binary_tree_node_t), pointer, intent(out) :: new_root
+ end subroutine binary_tree_rotate_left
+<<Binary trees: procedures>>=
!! A Move B to A.
!! / \
!! E B 1. Split B from A%left.
!! / \ 2. Temporarily pointer to C.
!! C D 3. Replace pointer to C by pointer to A - E.
!! 4. Set temporary pointer to C to A%right.
!!
!! 1.+2. B T => C A
!! \ /
!! D E
!!
!! 3. B T => C
!! / \
!! A D
!! /
!! E
!!
!! 4. B
!! / \
!! A D
!! / \
!! E C
- subroutine binary_tree_rotate_left (btree, root, new_root)
+ module subroutine binary_tree_rotate_left (btree, root, new_root)
class(binary_tree_t), intent(in) :: btree
type(binary_tree_node_t), pointer, intent(inout) :: root
type(binary_tree_node_t), pointer, intent(out) :: new_root
type(binary_tree_node_t), pointer :: tmp
new_root => root%right
tmp => new_root%left
new_root%left => root
root%right => tmp
call root%increment_height ()
call new_root%increment_height ()
end subroutine binary_tree_rotate_left
-end module binary_tree
-@ %def binary_tree
+
+@ %def binary_tree_rotate_left
@
\subsection{Unit tests}
\label{sec:unit-tests}
<<[[binary_tree_ut.f90]]>>=
<<File header>>
module binary_tree_ut
use unit_tests
use binary_tree_uti
<<Standard module head>>
<<Binary tree: public test>>
contains
<<Binary tree: test driver>>
+
end module binary_tree_ut
@ %def binary_tree_ut
@
<<[[binary_tree_uti.f90]]>>=
<<File header>>
module binary_tree_uti
use binary_tree
<<Standard module head>>
type :: btree_obj_t
integer :: i = 0
end type btree_obj_t
<<Binary tree: test declarations>>
contains
<<Binary tree: tests>>
end module binary_tree_uti
@ %def binary_tree_uti
@
<<Binary tree: public test>>=
public :: binary_tree_test
<<Binary tree: test driver>>=
subroutine binary_tree_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Binary tree: execute tests>>
end subroutine binary_tree_test
@ %def binary_tree_test
@ Provide testing for interface stability and correct implementation for the
binary tree and its iterator.
<<Binary tree: execute tests>>=
call test (binary_tree_1, "binary_tree_1", &
"check interface and implementation", &
u, results)
<<Binary tree: test declarations>>=
public :: binary_tree_1
<<Binary tree: tests>>=
subroutine binary_tree_1 (u)
integer, intent(in) :: u
integer, dimension(10) :: ndx = [1, 2, 5, 7, 19, 23, 97, -1, -6, 0]
class(*), pointer :: obj
type(binary_tree_t) :: btree
type(binary_tree_iterator_t) :: iterator
integer :: i, key
write (u, "(A)") "* Test outout: Binary tree"
write (u, "(A)") "* Purpose: test interface and implementation of binary tree " // &
"and its iterator using polymorph objects."
write (u, "(A)")
write (u, "(A)") "* Insert fixed number of object into tree..."
do i = 1, size (ndx)
call allocate_obj (i, obj)
call btree%insert (ndx(i), obj)
end do
write (u, "(A)") "* Search for all added objects in tree..."
do i = size (ndx), 1, -1
write (u, "(A,1X,I3,1X,L1)") "- Has key", ndx(i), btree%has_key (ndx(i))
call btree%search (ndx(i), obj)
select type (obj)
type is (btree_obj_t)
write (u, "(2(A,1X,I3,1X))") "- NDX", ndx(i), "OBJ", obj%i
end select
end do
write (u, "(A)") "* Output binary tree in preorder..."
call btree%write (u)
write (u, "(A)") "* Clear binary tree..."
call btree%clear ()
call btree%write (u)
write (u, "(A)") "* Insert fixed number of object into tree (reversed order)..."
do i = size (ndx), 1, -1
call allocate_obj (i, obj)
call btree%insert (ndx(i), obj)
end do
write (u, "(A)") "* Iterate over binary tree..."
call iterator%init (btree)
do while (iterator%is_iterable ())
call iterator%next (key)
call btree%search (key, obj)
select type (obj)
type is (btree_obj_t)
write (u, "(2(A,1X,I3,1X))") "- KEY", key, "OBJ", obj%i
end select
end do
write (u, "(A)") "* Search for a non-existing key..."
write (u, "(A,1X,I3,1X,L1)") "- Has key", 123, btree%has_key (123)
call btree%search (123, obj)
write (u, "(A,1X,L1)") "- Object found", associated (obj)
!! Do not test against a duplicate entry as the it will forcibly stop the program.
contains
subroutine allocate_obj (num, obj)
integer, intent(in) :: num
class(*), pointer, intent(out) :: obj
allocate (btree_obj_t :: obj)
select type (obj)
type is (btree_obj_t)
obj%i = num
end select
end subroutine allocate_obj
end subroutine binary_tree_1
@ %def binary_tree_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Array List}
<<[[array_list.f90]]>>=
<<File header>>
module array_list
<<Use kinds>>
- use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
implicit none
private
+<<Array list: public>>
+
+<<Array list: parameters>>
+
+<<Array list: types>>
+
+ interface
+<<Array list: sub interfaces>>
+ end interface
+
+end module array_list
+@ %def array_list
+@
+<<[[array_list_sub.f90]]>>=
+<<File header>>
+
+submodule (array_list) array_list_s
+
+ use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
+ use io_units
+
+contains
+
+<<Array list: procedures>>
+
+end submodule array_list_s
+
+@ %def array_list_s
+@
+<<Array list: parameters>>=
integer, parameter :: ARRAY_LIST_START_SIZE = 10
real(default), parameter :: ARRAY_LIST_GROW_FACTOR = 1.5_default, &
ARRAY_LIST_SHRINK_THRESHOLD = 0.3_default
+@ %def array_list_start_size array_list_grow_factor
+@ %def array_list_shrink_threshold
+@
+<<Array list: public>>=
+ public :: array_list_t
+<<Array list: types>>=
type :: array_list_t
private
integer, dimension(:), allocatable :: array
!! Track the index to *current* item, to be stored.
!! Must fulfill: 0 <= count <= size.
integer :: count = 0
!! size \in N.
integer :: size = 0
contains
- procedure :: write => array_list_write
- procedure :: init => array_list_init
- procedure :: add => array_list_add
- procedure :: add_at => array_list_add_at
- procedure :: remove => array_list_remove
- procedure :: remove_at => array_list_remove_at
- procedure :: get => array_list_get
- procedure :: get_size => array_list_get_size
- procedure :: get_count => array_list_get_count
- procedure :: grow_size => array_list_grow_size
- procedure :: shrink_size => array_list_shrink_size
- procedure :: reverse_order => array_list_reverse_order
- procedure :: sort => array_list_sort
- procedure :: is_element => array_list_is_element
- procedure :: find => array_list_find
- procedure :: clear => array_list_clear
- procedure :: is_full => array_list_is_full
- procedure :: is_empty => array_list_is_empty
- procedure :: is_index => array_list_is_index
+ <<Array list: array list: TBP>>
end type array_list_t
- public :: array_list_t
-contains
- subroutine array_list_write (list, unit)
+@ %def array_list_t
+@
+<<Array list: array list: TBP>>=
+ procedure :: write => array_list_write
+<<Array list: sub interfaces>>=
+ module subroutine array_list_write (list, unit)
+ class(array_list_t), intent(in) :: list
+ integer, intent(in), optional :: unit
+ end subroutine array_list_write
+<<Array list: procedures>>=
+ module subroutine array_list_write (list, unit)
class(array_list_t), intent(in) :: list
integer, intent(in), optional :: unit
integer :: u
u = ERROR_UNIT; if (present (unit)) u = unit
write (u, "(A,2(1X,I3))") "COUNT / SIZE", list%count, list%size
write (u, "(999(1X,I4))") list%array
end subroutine array_list_write
- subroutine array_list_init (list)
+@ %def array_list_write
+@
+<<Array list: array list: TBP>>=
+ procedure :: init => array_list_init
+<<Array list: sub interfaces>>=
+ module subroutine array_list_init (list)
+ class(array_list_t), intent(out) :: list
+ end subroutine array_list_init
+<<Array list: procedures>>=
+ module subroutine array_list_init (list)
class(array_list_t), intent(out) :: list
allocate (list%array(ARRAY_LIST_START_SIZE), source = 0)
list%count = 0
list%size = ARRAY_LIST_START_SIZE
end subroutine array_list_init
- elemental function array_list_get (list, index) result (data)
+@ %def array_list_init
+@
+<<Array list: array list: TBP>>=
+ procedure :: get => array_list_get
+<<Array list: sub interfaces>>=
+ elemental module function array_list_get (list, index) result (data)
+ class(array_list_t), intent(in) :: list
+ integer, intent(in) :: index
+ integer :: data
+ end function array_list_get
+<<Array list: procedures>>=
+ elemental module function array_list_get (list, index) result (data)
class(array_list_t), intent(in) :: list
integer, intent(in) :: index
integer :: data
if (list%is_index (index)) then
data = list%array(index)
else
data = 0
end if
end function array_list_get
- pure function array_list_get_count (list) result (count)
+@ %def array_list_get
+@
+<<Array list: array list: TBP>>=
+ procedure :: get_count => array_list_get_count
+<<Array list: sub interfaces>>=
+ pure module function array_list_get_count (list) result (count)
+ class(array_list_t), intent(in) :: list
+ integer :: count
+ end function array_list_get_count
+<<Array list: procedures>>=
+ pure module function array_list_get_count (list) result (count)
class(array_list_t), intent(in) :: list
integer :: count
count = list%count
end function array_list_get_count
- pure function array_list_get_size (list) result (size)
+@ %def array_list_get_count
+@
+<<Array list: array list: TBP>>=
+ procedure :: get_size => array_list_get_size
+<<Array list: sub interfaces>>=
+ pure module function array_list_get_size (list) result (size)
+ class(array_list_t), intent(in) :: list
+ integer :: size
+ end function array_list_get_size
+<<Array list: procedures>>=
+ pure module function array_list_get_size (list) result (size)
class(array_list_t), intent(in) :: list
integer :: size
size = list%size
end function array_list_get_size
- pure function array_list_is_full (list) result (flag)
+@ %def array_list_get_size
+@
+<<Array list: array list: TBP>>=
+ procedure :: is_full => array_list_is_full
+<<Array list: sub interfaces>>=
+ pure module function array_list_is_full (list) result (flag)
+ class(array_list_t), intent(in) :: list
+ logical :: flag
+ end function array_list_is_full
+<<Array list: procedures>>=
+ pure module function array_list_is_full (list) result (flag)
class(array_list_t), intent(in) :: list
logical :: flag
flag = list%count >= list%size
end function array_list_is_full
- pure function array_list_is_empty (list) result (flag)
+@ %def array_list_is_full
+@
+<<Array list: array list: TBP>>=
+ procedure :: is_empty => array_list_is_empty
+<<Array list: sub interfaces>>=
+ pure module function array_list_is_empty (list) result (flag)
+ class(array_list_t), intent(in) :: list
+ logical :: flag
+ end function array_list_is_empty
+<<Array list: procedures>>=
+ pure module function array_list_is_empty (list) result (flag)
class(array_list_t), intent(in) :: list
logical :: flag
flag = .not. list%count > 0
end function array_list_is_empty
- pure function array_list_is_index (list, index) result (flag)
+@ %def array_list_is_empty
+@
+<<Array list: array list: TBP>>=
+ procedure :: is_index => array_list_is_index
+<<Array list: sub interfaces>>=
+ pure module function array_list_is_index (list, index) result (flag)
+ class(array_list_t), intent(in) :: list
+ integer, intent(in) :: index
+ logical :: flag
+ end function array_list_is_index
+<<Array list: procedures>>=
+ pure module function array_list_is_index (list, index) result (flag)
class(array_list_t), intent(in) :: list
integer, intent(in) :: index
logical :: flag
flag = 0 < index .and. index <= list%count
end function array_list_is_index
- subroutine array_list_clear (list)
+@ %def array_list_is_index
+@
+<<Array list: array list: TBP>>=
+ procedure :: clear => array_list_clear
+<<Array list: sub interfaces>>=
+ module subroutine array_list_clear (list)
+ class(array_list_t), intent(inout) :: list
+ end subroutine array_list_clear
+<<Array list: procedures>>=
+ module subroutine array_list_clear (list)
class(array_list_t), intent(inout) :: list
list%array = 0
list%count = 0
call list%shrink_size ()
end subroutine array_list_clear
- subroutine array_list_add (list, data)
+@ %def array_list_clear
+@
+<<Array list: array list: TBP>>=
+ procedure :: add => array_list_add
+<<Array list: sub interfaces>>=
+ module subroutine array_list_add (list, data)
+ class(array_list_t), intent(inout) :: list
+ integer, intent(in) :: data
+ end subroutine array_list_add
+<<Array list: procedures>>=
+ module subroutine array_list_add (list, data)
class(array_list_t), intent(inout) :: list
integer, intent(in) :: data
list%count = list%count + 1
if (list%is_full ()) then
call list%grow_size ()
end if
list%array(list%count) = data
end subroutine array_list_add
- subroutine array_list_grow_size (list)
+@ %def array_list_add
+@
+<<Array list: array list: TBP>>=
+ procedure :: grow_size => array_list_grow_size
+<<Array list: sub interfaces>>=
+ module subroutine array_list_grow_size (list)
+ class(array_list_t), intent(inout) :: list
+ end subroutine array_list_grow_size
+<<Array list: procedures>>=
+ module subroutine array_list_grow_size (list)
class(array_list_t), intent(inout) :: list
integer, dimension(:), allocatable :: array
integer :: new_size
if (.not. list%is_full ()) return
new_size = int (list%size * ARRAY_LIST_GROW_FACTOR)
allocate (array(new_size), source = 0)
array(:list%size) = list%array
call move_alloc (array, list%array)
list%size = size (list%array)
end subroutine array_list_grow_size
- subroutine array_list_shrink_size (list)
+@ %def array_list_grow_size
+@
+<<Array list: array list: TBP>>=
+ procedure :: shrink_size => array_list_shrink_size
+<<Array list: sub interfaces>>=
+ module subroutine array_list_shrink_size (list)
+ class(array_list_t), intent(inout) :: list
+ integer, dimension(:), allocatable :: array
+ end subroutine array_list_shrink_size
+<<Array list: procedures>>=
+ module subroutine array_list_shrink_size (list)
class(array_list_t), intent(inout) :: list
integer, dimension(:), allocatable :: array
integer :: new_size
!! Apply shrink threshold on count.
! if (.not. list%count > 0) return
new_size = max (list%count, ARRAY_LIST_START_SIZE)
allocate (array(new_size), source = 0)
!! \note We have to circumvent the allocate-on-assignment,
!! hence, we explicitly set the array boundaries.
array(:list%count) = list%array(:list%count)
call move_alloc (array, list%array)
list%size = new_size
end subroutine array_list_shrink_size
- subroutine array_list_reverse_order (list)
+@ %def array_list_shrink_size
+@
+<<Array list: array list: TBP>>=
+ procedure :: reverse_order => array_list_reverse_order
+<<Array list: sub interfaces>>=
+ module subroutine array_list_reverse_order (list)
+ class(array_list_t), intent(inout) :: list
+ end subroutine array_list_reverse_order
+<<Array list: procedures>>=
+ module subroutine array_list_reverse_order (list)
class(array_list_t), intent(inout) :: list
list%array(:list%count) = list%array(list%count:1:-1)
end subroutine array_list_reverse_order
- pure subroutine array_list_sort (list)
+@ %def array_list_reverse_order
+@
+<<Array list: array list: TBP>>=
+ procedure :: sort => array_list_sort
+<<Array list: sub interfaces>>=
+ pure module subroutine array_list_sort (list)
+ class(array_list_t), intent(inout) :: list
+ end subroutine array_list_sort
+<<Array list: procedures>>=
+ pure module subroutine array_list_sort (list)
class(array_list_t), intent(inout) :: list
if (list%is_empty ()) return
call quick_sort (list%array(:list%count))
contains
pure recursive subroutine quick_sort (array)
integer, dimension(:), intent(inout) :: array
integer :: pivot, tmp
integer :: first, last
integer i, j
first = 1
last = size(array)
pivot = array(int ((first+last) / 2.))
i = first
j = last
do
do while (array(i) < pivot)
i = i + 1
end do
do while (pivot < array(j))
j = j - 1
end do
if (i >= j) exit
tmp = array(i)
array(i) = array(j)
array(j) = tmp
i = i + 1
j = j - 1
end do
if (first < i - 1) call quick_sort(array(first:i - 1))
if (j + 1 < last) call quick_sort(array(j + 1:last))
end subroutine quick_sort
end subroutine array_list_sort
- pure function array_list_is_element (list, data) result (flag)
+@ %def array_list_sort
+@
+<<Array list: array list: TBP>>=
+ procedure :: is_element => array_list_is_element
+<<Array list: sub interfaces>>=
+ pure module function array_list_is_element (list, data) result (flag)
+ class(array_list_t), intent(in) :: list
+ integer, intent(in) :: data
+ logical :: flag
+ end function array_list_is_element
+<<Array list: procedures>>=
+ pure module function array_list_is_element (list, data) result (flag)
class(array_list_t), intent(in) :: list
integer, intent(in) :: data
logical :: flag
if (list%is_empty ()) then
flag = .false.
else
flag = any (data == list%array)
end if
end function array_list_is_element
- function array_list_find (list, data) result (index)
+@ %def array_list_is_element
+@
+<<Array list: array list: TBP>>=
+ procedure :: find => array_list_find
+<<Array list: sub interfaces>>=
+ module function array_list_find (list, data) result (index)
+ class(array_list_t), intent(inout) :: list
+ integer, intent(in) :: data
+ integer :: index
+ end function array_list_find
+<<Array list: procedures>>=
+ module function array_list_find (list, data) result (index)
class(array_list_t), intent(inout) :: list
integer, intent(in) :: data
integer :: index
if (list%is_empty () &
.or. .not. list%is_element (data)) then
index = 0
return
end if
call list%sort () !! INTENT(INOUT)
index = binary_search_leftmost (list%array(:list%count), data)
contains
pure function binary_search_leftmost (array, data) result (index)
integer, dimension(:), intent(in) :: array
integer, intent(in) :: data
integer :: index
integer :: left, right
left = 1
right = size (array)
do while (left < right)
index = floor ((left + right) / 2.)
if (array(index) < data) then
left = index + 1
else
right = index
end if
end do
index = left
end function binary_search_leftmost
end function array_list_find
- subroutine array_list_add_at (list, index, data)
+@ %def array_list_find
+@
+<<Array list: array list: TBP>>=
+ procedure :: add_at => array_list_add_at
+<<Array list: sub interfaces>>=
+ module subroutine array_list_add_at (list, index, data)
+ class(array_list_t), intent(inout) :: list
+ integer, intent(in) :: index
+ integer, intent(in) :: data
+ end subroutine array_list_add_at
+<<Array list: procedures>>=
+ module subroutine array_list_add_at (list, index, data)
class(array_list_t), intent(inout) :: list
integer, intent(in) :: index
integer, intent(in) :: data
if (.not. list%is_index (index)) return
if (list%is_full ()) then
call list%grow_size ()
end if
list%array(index + 1:list%count + 1) = list%array(index:list%count)
list%array(index) = data
list%count = list%count + 1
end subroutine array_list_add_at
- integer function array_list_remove (list) result (data)
+@ %def array_list_add_at
+@
+<<Array list: array list: TBP>>=
+ procedure :: remove => array_list_remove
+<<Array list: sub interfaces>>=
+ module function array_list_remove (list) result (data)
+ class(array_list_t), intent(inout) :: list
+ integer :: data
+ end function array_list_remove
+<<Array list: procedures>>=
+ module function array_list_remove (list) result (data)
class(array_list_t), intent(inout) :: list
+ integer :: data
if (list%is_empty ()) then
data = 0
return
end if
data = list%get (list%count)
list%array(list%count) = 0
list%count = list%count -1
end function array_list_remove
- integer function array_list_remove_at (list, index) result (data)
+@ %def array_list_remove
+@
+<<Array list: array list: TBP>>=
+ procedure :: remove_at => array_list_remove_at
+<<Array list: sub interfaces>>=
+ module function array_list_remove_at (list, index) result (data)
+ class(array_list_t), intent(inout) :: list
+ integer, intent(in) :: index
+ integer :: data
+ end function array_list_remove_at
+<<Array list: procedures>>=
+ module function array_list_remove_at (list, index) result (data)
class(array_list_t), intent(inout) :: list
integer, intent(in) :: index
+ integer :: data
if (list%is_empty ()) then
data = 0
return
end if
data = list%get (index)
list%array(index:list%count - 1) = list%array(index + 1:list%count)
list%array(list%count) = 0
list%count = list%count - 1
end function array_list_remove_at
-end module array_list
-@ %def array_list
+
+@ %def array_list_remove_at
@
\subsection{Unit tests}
\label{sec:unit-tests}
<<[[array_list_ut.f90]]>>=
<<File header>>
module array_list_ut
use unit_tests
use array_list_uti
<<Standard module head>>
<<Array list: public test>>
contains
<<Array list: test driver>>
end module array_list_ut
@ %def array_list_ut
@
<<[[array_list_uti.f90]]>>=
<<File header>>
module array_list_uti
use array_list
<<Standard module head>>
<<Array list: test declarations>>
contains
<<Array list: tests>>
end module array_list_uti
@ %def array_list_uti
@
<<Array list: public test>>=
public :: array_list_test
<<Array list: test driver>>=
subroutine array_list_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Array list: execute tests>>
end subroutine array_list_test
@ %def array_list_test
@ Provide testing for interface stability and correct implementation for the
binary tree and its iterator.
<<Array list: execute tests>>=
call test (array_list_1, "array_list_1", &
"check interface and implementation", &
u, results)
<<Array list: test declarations>>=
public :: array_list_1
<<Array list: tests>>=
subroutine array_list_1 (u)
integer, intent(in) :: u
type(array_list_t) :: list
integer :: ndx, data
write (u, "(A)") "* Test output: Array list"
write (u, "(A)") "* Purpose: test interface and implementation of array list"
write (u, "(A)")
write (u, "(A)") "* Init array_list_t ..."
call list%init ()
write (u, "(A)") "* Test adding a single element..."
call list%add (1)
write (u, "(A)") "* Test removing a single element..."
data = list%remove ()
write (u, "(A)") "* Test growing (unnecessary, so just return)..."
call list%grow_size ()
write (u, "(A)") "* Test adding elements beyond initial capacity..."
call test_grow_and_add (list)
write (u, "(A)") "* Test adding at specific position..."
call list%add_at (10, -1)
write (u, "(A)") "* Test removing at specific position..."
data = list%remove_at (11)
write (u, "(A)") "* Test reverse ordering..."
call list%reverse_order ()
write (u, "(A)") "* Test sorting..."
call list%sort ()
write (u, "(A)") "* Test finding..."
ndx = list%find (1)
write (u, "(A)") "* Test shrinking..."
call list%shrink_size ()
write (u, "(A)") "* Test get procedures..."
call test_get_procedures (list)
write (u, "(A)") "* Test clearing list..."
call list%clear ()
write (u, "(A)") "* Test (more complicated) combinations:"
write (u, "(A)") "* Test growing (necessary) during adding..."
call test_grow_and_add (list)
write (u, "(A)") "* Test adding random data and sorting..."
call test_sort (list)
write (u, "(A)") "* Test finding (before sorted)..."
call test_find (list)
contains
subroutine test_get_procedures (list)
type(array_list_t), intent(in) :: list
integer :: n
logical :: flag
n = list%get(1)
n = list%get_size ()
n = list%get_count ()
flag = list%is_element (1)
end subroutine test_get_procedures
subroutine test_grow_and_add (list)
type(array_list_t), intent(inout) :: list
integer :: i
do i = 1, 2 * list%get_size ()
call list%add (i)
end do
end subroutine test_grow_and_add
subroutine test_get (list)
class(array_list_t), intent(inout) :: list
integer :: i, data
do i = list%get_count (), 1, -1
data = list%get (i)
if (data == 0) then
write (u, "(A,1X,I3)") "INDEX EMPTY", i
end if
end do
end subroutine test_get
subroutine test_sort (list)
class(array_list_t), intent(inout) :: list
call list%add (6)
call list%add (2)
call list%add (9)
call list%add (4)
call list%add (8)
call list%add (7)
call list%sort ()
end subroutine test_sort
subroutine test_find (list)
class(array_list_t), intent(inout) :: list
write (u, "(A,1X,I3)") " 6 INDEX", list%find (6)
write (u, "(A,1X,I3)") "-1 INDEX", list%find (-1)
write (u, "(A,1X,I3)") " 3 INDEX", list%find (3)
write (u, "(A,1X,I3)") "26 INDEX", list%find (26)
call list%write (u)
end subroutine test_find
end subroutine array_list_1
@ %def array_list_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Queue}
<<[[queue.f90]]>>=
<<File header>>
module queue
- use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
implicit none
private
+<<Queue: public>>
+
+<<Queue: parameters>>
+
+<<Queue: types>>
+
+ interface
+<<Queue: sub interfaces>>
+ end interface
+
+end module queue
+@ %def queue
+@
+<<[[queue_sub.f90]]>>=
+<<File header>>
+
+submodule (queue) queue_s
+
+ use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
+
+contains
+
+<<Queue: procedures>>
+
+end submodule queue_s
+
+@ %def queue_s
+@
+<<Queue: parameters>>=
integer, parameter :: QUEUE_SIZE = 10, &
QUEUE_START = 0, &
QUEUE_END = QUEUE_SIZE
+@ %def queue_size queue_start queue_end
+@
+<<Queue: public>>=
+ public :: queue_t
+<<Queue: types>>=
type :: queue_t
private
integer, dimension(QUEUE_SIZE) :: item
integer :: front = 0
integer :: rear = 0
contains
- procedure :: enqueue => queue_enqueue
- procedure :: dequeue => queue_dequeue
- procedure :: is_full => queue_is_full
- procedure :: is_empty => queue_is_empty
- procedure :: peek => queue_peek
- procedure :: write => queue_write
+ <<Queue: queue: TBP>>
end type queue_t
- public :: queue_t
-contains
- elemental logical function queue_is_full (queue) result (flag)
+@ %def queue_t
+@
+<<Queue: queue: TBP>>=
+ procedure :: is_full => queue_is_full
+<<Queue: sub interfaces>>=
+ elemental module function queue_is_full (queue) result (flag)
+ class(queue_t), intent(in) :: queue
+ logical :: flag
+ end function queue_is_full
+<<Queue: procedures>>=
+ elemental module function queue_is_full (queue) result (flag)
class(queue_t), intent(in) :: queue
+ logical :: flag
flag = queue%front == 1 .and. queue%rear == QUEUE_END
end function queue_is_full
- elemental logical function queue_is_empty (queue) result (flag)
+@ %def queue_is_full
+@
+<<Queue: queue: TBP>>=
+ procedure :: is_empty => queue_is_empty
+<<Queue: sub interfaces>>=
+ elemental module function queue_is_empty (queue) result (flag)
+ class(queue_t), intent(in) :: queue
+ logical :: flag
+ end function queue_is_empty
+<<Queue: procedures>>=
+ elemental module function queue_is_empty (queue) result (flag)
class(queue_t), intent(in) :: queue
+ logical :: flag
flag = queue%front == QUEUE_START
end function queue_is_empty
- subroutine queue_enqueue (queue, item)
+@ %def queue_is_empty
+@
+<<Queue: queue: TBP>>=
+ procedure :: enqueue => queue_enqueue
+<<Queue: sub interfaces>>=
+ module subroutine queue_enqueue (queue, item)
+ class(queue_t), intent(inout) :: queue
+ integer, intent(in) :: item
+ end subroutine queue_enqueue
+<<Queue: procedures>>=
+ module subroutine queue_enqueue (queue, item)
class(queue_t), intent(inout) :: queue
integer, intent(in) :: item
if (queue%is_full ()) then
!! Do something.
else
if (queue%front == QUEUE_START) queue%front = 1
queue%rear = queue%rear + 1
queue%item(queue%rear) = item
end if
end subroutine queue_enqueue
- integer function queue_dequeue (queue) result (item)
+@ %def queue_enqueue
+@
+<<Queue: queue: TBP>>=
+ procedure :: dequeue => queue_dequeue
+<<Queue: sub interfaces>>=
+ module function queue_dequeue (queue) result (item)
+ class(queue_t), intent(inout) :: queue
+ integer :: item
+ end function queue_dequeue
+<<Queue: procedures>>=
+ module function queue_dequeue (queue) result (item)
class(queue_t), intent(inout) :: queue
+ integer :: item
if (queue%is_empty ()) then
item = 0
else
item = queue%item(queue%front)
if (queue%front >= queue%rear) then
queue%front = QUEUE_START
queue%rear = QUEUE_START
!! Q has only one element,
!! so we reset the queue after deleting it.
else
queue%front = queue%front + 1
end if
end if
end function queue_dequeue
- integer function queue_peek (queue) result (item)
+@ %def queue_dequeue
+@
+<<Queue: queue: TBP>>=
+ procedure :: peek => queue_peek
+<<Queue: sub interfaces>>=
+ module function queue_peek (queue) result (item)
+ class(queue_t), intent(in) :: queue
+ integer :: item
+ end function queue_peek
+<<Queue: procedures>>=
+ module function queue_peek (queue) result (item)
class(queue_t), intent(in) :: queue
+ integer :: item
if (queue%is_empty ()) then
item = 0
else
item = queue%item(queue%front)
end if
end function queue_peek
- subroutine queue_write (queue, unit)
+@ %def queue_peek
+@
+<<Queue: queue: TBP>>=
+ procedure :: write => queue_write
+<<Queue: sub interfaces>>=
+ module subroutine queue_write (queue, unit)
+ class(queue_t), intent(in) :: queue
+ integer, intent(in), optional :: unit
+ end subroutine queue_write
+<<Queue: procedures>>=
+ module subroutine queue_write (queue, unit)
class(queue_t), intent(in) :: queue
integer, intent(in), optional :: unit
integer :: u, i
u = ERROR_UNIT; if (present (unit)) u = unit
if (queue%is_empty ()) then
write (u, *) "Empty Queue."
else
write (u, *) "Front ->", queue%front
write (u, *) "Items ->"
do i = 1, queue%rear
write (u, *) queue%item(i)
end do
write (u, *) "Rear ->", queue%rear
end if
end subroutine queue_write
-end module queue
-@ %def queue
+
+@ %def queue_write
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Iterator}
<<[[iterator.f90]]>>=
<<File header>>
module iterator
- use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
implicit none
private
+<<Iterator: public>>
+
+<<Iterator: types>>
+
+ interface
+<<Iterator: sub interfaces>>
+ end interface
+
+end module iterator
+
+@ %def iterator
+@
+<<[[iterator_sub.f90]]>>=
+<<File header>>
+
+submodule (iterator) iterator_s
+
+ use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
+
+contains
+
+<<Iterator: procedures>>
+
+end submodule iterator_s
+
+@ %def iterator_s
+@
+<<Iterator: public>>=
+ public :: iterator_t
+<<Iterator: types>>=
!! Forward
type :: iterator_t
integer :: current = 0
integer :: begin = 0
integer :: end = 0
integer :: step = 1
contains
- procedure :: write => iterator_write
- procedure :: init => iterator_init
- procedure :: at_begin => iterator_at_begin
- procedure :: at_end => iterator_at_end
- procedure :: is_iterable => iterator_is_iterable
- procedure :: next => iterator_next
- procedure :: next_step => iterator_next_step
- procedure :: get_current => iterator_get_current
+ <<Iterator: iterator: TBP>>
end type iterator_t
- public :: iterator_t
-contains
- subroutine iterator_write (iter, unit)
+@ %def iterator_t
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: write => iterator_write
+<<Iterator: sub interfaces>>=
+ module subroutine iterator_write (iter, unit)
+ class(iterator_t), intent(in) :: iter
+ integer, intent(in), optional :: unit
+ end subroutine iterator_write
+<<Iterator: procedures>>=
+ module subroutine iterator_write (iter, unit)
class(iterator_t), intent(in) :: iter
integer, intent(in), optional :: unit
integer :: u
u = ERROR_UNIT; if (present (unit)) u = unit
write (u, "(3(A,1X,I3,1X))") "CURRENT", iter%current, &
"BEGIN", iter%begin, "END", iter%end
flush (u)
end subroutine iterator_write
+@ %def iterator_write
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: init => iterator_init
+<<Iterator: sub interfaces>>=
+ module subroutine iterator_init (iter, begin, end, step)
+ class(iterator_t), intent(inout) :: iter
+ integer, intent(in) :: begin
+ integer, intent(in) :: end
+ integer, intent(in), optional :: step
+ end subroutine iterator_init
+<<Iterator: procedures>>=
!! Proof: step > 0, begin < end.
!! Proof: step < 0, begin > end.
!! Proof: step /= 0.
- subroutine iterator_init (iter, begin, end, step)
+ module subroutine iterator_init (iter, begin, end, step)
class(iterator_t), intent(inout) :: iter
integer, intent(in) :: begin
integer, intent(in) :: end
integer, intent(in), optional :: step
iter%begin = begin
iter%end = end
iter%step = 1; if (present (step)) iter%step = step
if (abs (iter%step) > 0) then
iter%current = iter%begin
else
write (ERROR_UNIT, "(A)") "ERROR: Step size MUST be unequal to zero."
stop 1
end if
end subroutine iterator_init
- pure function iterator_at_begin (iter) result (flag)
+@ %def iterator_init
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: at_begin => iterator_at_begin
+<<Iterator: sub interfaces>>=
+ pure module function iterator_at_begin (iter) result (flag)
+ class(iterator_t), intent(in) :: iter
+ logical :: flag
+ end function iterator_at_begin
+<<Iterator: procedures>>=
+ pure module function iterator_at_begin (iter) result (flag)
class(iterator_t), intent(in) :: iter
logical :: flag
flag = iter%current == iter%begin
end function iterator_at_begin
- pure function iterator_at_end (iter) result (flag)
+@ %def iterator_at_begin
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: at_end => iterator_at_end
+<<Iterator: sub interfaces>>=
+ pure module function iterator_at_end (iter) result (flag)
+ class(iterator_t), intent(in) :: iter
+ logical :: flag
+ end function iterator_at_end
+<<Iterator: procedures>>=
+ pure module function iterator_at_end (iter) result (flag)
class(iterator_t), intent(in) :: iter
logical :: flag
flag = iter%current == iter%end
end function iterator_at_end
+@ %def iterator_at_end
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: is_iterable => iterator_is_iterable
+<<Iterator: sub interfaces>>=
+ pure module function iterator_is_iterable (iter) result (flag)
+ class(iterator_t), intent(in) :: iter
+ logical :: flag
+ end function iterator_is_iterable
+<<Iterator: procedures>>=
!! Proof: begin < current < end
- pure function iterator_is_iterable (iter) result (flag)
+ pure module function iterator_is_iterable (iter) result (flag)
class(iterator_t), intent(in) :: iter
logical :: flag
if (iter%step > 0) then
flag = iter%current <= iter%end
else if (iter%step < 0) then
flag = iter%current >= iter%end
else
flag = .false.
end if
end function iterator_is_iterable
- subroutine iterator_next_step (iter)
+@ %def iterator_is_iterable
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: next_step => iterator_next_step
+<<Iterator: sub interfaces>>=
+ module subroutine iterator_next_step (iter)
+ class(iterator_t), intent(inout) :: iter
+ end subroutine iterator_next_step
+<<Iterator: procedures>>=
+ module subroutine iterator_next_step (iter)
class(iterator_t), intent(inout) :: iter
if (.not. iter%is_iterable ()) return
iter%current = iter%current + iter%step
end subroutine iterator_next_step
+@ %def iterator_next_step
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: next => iterator_next
+<<Iterator: sub interfaces>>=
+ module function iterator_next (iter) result (ndx)
+ class(iterator_t), intent(inout) :: iter
+ integer :: ndx
+ end function iterator_next
+<<Iterator: procedures>>=
!! Proof: begin <= current <= end.
!! However, after applying the step, this does not need to be true..
- function iterator_next (iter) result (ndx)
+ module function iterator_next (iter) result (ndx)
class(iterator_t), intent(inout) :: iter
integer :: ndx
if (.not. iter%is_iterable ()) then
ndx = 0
return
end if
ndx = iter%current
iter%current = iter%current + iter%step
end function iterator_next
- pure function iterator_get_current (iter) result (ndx)
+@ %def iterator_next
+@
+<<Iterator: iterator: TBP>>=
+ procedure :: get_current => iterator_get_current
+<<Iterator: sub interfaces>>=
+ pure module function iterator_get_current (iter) result (ndx)
+ class(iterator_t), intent(in) :: iter
+ integer :: ndx
+ end function iterator_get_current
+<<Iterator: procedures>>=
+ pure module function iterator_get_current (iter) result (ndx)
class(iterator_t), intent(in) :: iter
integer :: ndx
if (.not. iter%is_iterable ()) then
ndx = 0
return
end if
ndx = iter%current
end function iterator_get_current
-end module iterator
-@ %def iterator
+@ %def iterator_get_current
@
\subsection{Unit tests}
\label{sec:unit-tests}
<<[[iterator_ut.f90]]>>=
<<File header>>
module iterator_ut
use unit_tests
use iterator_uti
<<Standard module head>>
<<Iterator: public test>>
contains
<<Iterator: test driver>>
end module iterator_ut
@ %def iterator_ut
@
<<[[iterator_uti.f90]]>>=
<<File header>>
module iterator_uti
use iterator
<<Standard module head>>
<<Iterator: test declarations>>
contains
<<Iterator: tests>>
end module iterator_uti
@ %def iterator_uti
@
<<Iterator: public test>>=
public :: iterator_test
<<Iterator: test driver>>=
subroutine iterator_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Iterator: execute tests>>
end subroutine iterator_test
@ %def iterator_test
@ Provide testing for interface stability and correct implementation for the
forward integer iterator.
<<Iterator: execute tests>>=
call test (iterator_1, "iterator_1", &
"check interface and implementation", &
u, results)
<<Iterator: test declarations>>=
public :: iterator_1
<<Iterator: tests>>=
subroutine iterator_1 (u)
integer, intent(in) :: u
type(iterator_t) :: iter
write (u, "(A)") "* Test output: iterator_1"
write (u, "(A)") "* Purpose: test interface and implementation of the forward integer iterator"
write (u, "(A)")
call iter%init (1, 10)
call iter%write (u)
do while (iter%is_iterable ())
write (u, "(A,1X,I3)") "NDX", iter%next ()
end do
call iter%init (10, 1, -1)
call iter%write (u)
do while (iter%is_iterable ())
write (u, "(A,1X,I3)") "NDX", iter%next ()
end do
write (u, "(A,1X,I3)") "INVALID NDX", iter%next ()
call iter%init (1, 10)
call iter%write (u)
do while (iter%is_iterable ())
call iter%next_step ()
write (u, "(A)") "STEP."
end do
end subroutine iterator_1
-@
\ No newline at end of file
+@
Index: trunk/src/physics/physics.nw
===================================================================
--- trunk/src/physics/physics.nw (revision 8768)
+++ trunk/src/physics/physics.nw (revision 8769)
@@ -1,6101 +1,6864 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: physics and such
\chapter{Physics}
\includemodulegraph{physics}
Here we collect definitions and functions that we need for (particle)
physics in general, to make them available for the more specific needs
of WHIZARD.
\begin{description}
\item[physics\_defs]
Physical constants.
\item[c\_particles]
A simple data type for particles which is C compatible.
\item[lorentz]
Define three-vectors, four-vectors and Lorentz
transformations and common operations for them.
\item[phs\_point]
Collections of Lorentz vectors.
\item[sm\_physics]
Here, running functions are stored for special kinematical setup like
running coupling constants, Catani-Seymour dipoles, or Sudakov factors.
\item[sm\_qcd]
Definitions and methods for dealing with the running QCD coupling.
\item[shower\_algorithms]
Algorithms typically used in Parton Showers as well as in their
matching to NLO computations, e.g. with the POWHEG method.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Physics Constants}
There is also the generic [[constants]] module. The constants listed
here are more specific for particle physics.
<<[[physics_defs.f90]]>>=
<<File header>>
module physics_defs
<<Use kinds>>
<<Use strings>>
use constants, only: one, two, three
<<Standard module head>>
<<Physics defs: public parameters>>
<<Physics defs: public>>
<<Physics defs: interfaces>>
contains
<<Physics defs: procedures>>
end module physics_defs
@ %def physics_defs
@
\subsection{Units}
Conversion from energy units to cross-section units.
<<Physics defs: public parameters>>=
real(default), parameter, public :: &
conv = 0.38937966e12_default
@
Conversion from millimeter to nanoseconds for lifetimes.
<<Physics defs: public parameters>>=
real(default), parameter, public :: &
ns_per_mm = 1.e6_default / 299792458._default
@
Rescaling factor.
<<Physics defs: public parameters>>=
real(default), parameter, public :: &
pb_per_fb = 1.e-3_default
@
String for the default energy and cross-section units.
<<Physics defs: public parameters>>=
character(*), parameter, public :: &
energy_unit = "GeV"
character(*), parameter, public :: &
cross_section_unit = "fb"
@
\subsection{SM and QCD constants}
<<Physics defs: public parameters>>=
real(default), parameter, public :: &
NC = three, &
CF = (NC**2 - one) / two / NC, &
CA = NC, &
TR = one / two
@
\subsection{Parameter Reference values}
These are used exclusively in the context of
running QCD parameters. In other contexts, we rely on the uniform
parameter set as provided by the model definition, modifiable by the
user.
<<Physics defs: public parameters>>=
real(default), public, parameter :: MZ_REF = 91.188_default
real(default), public, parameter :: ME_REF = 0.000510998928_default
real(default), public, parameter :: ALPHA_QCD_MZ_REF = 0.1178_default
real(default), public, parameter :: ALPHA_QED_ME_REF = 0.0072973525693_default
real(default), public, parameter :: LAMBDA_QCD_REF = 200.e-3_default
@ %def alpha_s_mz_ref mz_ref lambda_qcd_ref
@
\subsection{Particle codes}
Let us define a few particle codes independent of the model.
We need an UNDEFINED value:
<<Physics defs: public parameters>>=
integer, parameter, public :: UNDEFINED = 0
@ %def UNDEFINED
@ SM fermions:
<<Physics defs: public parameters>>=
integer, parameter, public :: DOWN_Q = 1
integer, parameter, public :: UP_Q = 2
integer, parameter, public :: STRANGE_Q = 3
integer, parameter, public :: CHARM_Q = 4
integer, parameter, public :: BOTTOM_Q = 5
integer, parameter, public :: TOP_Q = 6
integer, parameter, public :: ELECTRON = 11
integer, parameter, public :: ELECTRON_NEUTRINO = 12
integer, parameter, public :: MUON = 13
integer, parameter, public :: MUON_NEUTRINO = 14
integer, parameter, public :: TAU = 15
integer, parameter, public :: TAU_NEUTRINO = 16
@ %def ELECTRON MUON TAU
@ Gauge bosons:
<<Physics defs: public parameters>>=
integer, parameter, public :: GLUON = 21
integer, parameter, public :: PHOTON = 22
integer, parameter, public :: PHOTON_OFFSHELL = -2002
integer, parameter, public :: PHOTON_ONSHELL = 2002
integer, parameter, public :: Z_BOSON = 23
integer, parameter, public :: W_BOSON = 24
@ %def GLUON PHOTON Z_BOSON W_BOSON
@ Light mesons:
<<Physics defs: public parameters>>=
integer, parameter, public :: PION = 111
integer, parameter, public :: PIPLUS = 211
integer, parameter, public :: PIMINUS = - PIPLUS
@ %def PION PIPLUS PIMINUS
@ Di-Quarks:
<<Physics defs: public parameters>>=
integer, parameter, public :: UD0 = 2101
integer, parameter, public :: UD1 = 2103
integer, parameter, public :: UU1 = 2203
@ %def UD0 UD1 UU1
@ Mesons:
<<Physics defs: public parameters>>=
integer, parameter, public :: K0L = 130
integer, parameter, public :: K0S = 310
integer, parameter, public :: K0 = 311
integer, parameter, public :: KPLUS = 321
integer, parameter, public :: DPLUS = 411
integer, parameter, public :: D0 = 421
integer, parameter, public :: B0 = 511
integer, parameter, public :: BPLUS = 521
@ %def K0L K0S K0 KPLUS DPLUS D0 B0 BPLUS
@ Light baryons:
<<Physics defs: public parameters>>=
integer, parameter, public :: PROTON = 2212
integer, parameter, public :: NEUTRON = 2112
integer, parameter, public :: DELTAPLUSPLUS = 2224
integer, parameter, public :: DELTAPLUS = 2214
integer, parameter, public :: DELTA0 = 2114
integer, parameter, public :: DELTAMINUS = 1114
@ %def PROTON NEUTRON DELTAPLUSPLUS DELTAPLUS DELTA0 DELTAMINUS
@ Strange baryons:
<<Physics defs: public parameters>>=
integer, parameter, public :: SIGMAPLUS = 3222
integer, parameter, public :: SIGMA0 = 3212
integer, parameter, public :: SIGMAMINUS = 3112
@ %def SIGMAPLUS SIGMA0 SIGMAMINUS
@ Charmed baryons:
<<Physics defs: public parameters>>=
integer, parameter, public :: SIGMACPLUSPLUS = 4222
integer, parameter, public :: SIGMACPLUS = 4212
integer, parameter, public :: SIGMAC0 = 4112
@ %def SIGMACPLUSPLUS SIGMACPLUS SIGMAC0
@ Bottom baryons:
<<Physics defs: public parameters>>=
integer, parameter, public :: SIGMAB0 = 5212
integer, parameter, public :: SIGMABPLUS = 5222
@ %def SIGMAB0 SIGMABPLUS
@ 81-100 are reserved for internal codes. Hadron and beam remnants:
<<Physics defs: public parameters>>=
integer, parameter, public :: BEAM_REMNANT = 9999
integer, parameter, public :: HADRON_REMNANT = 90
integer, parameter, public :: HADRON_REMNANT_SINGLET = 91
integer, parameter, public :: HADRON_REMNANT_TRIPLET = 92
integer, parameter, public :: HADRON_REMNANT_OCTET = 93
@ %def BEAM_REMNANT HADRON_REMNANT
@ %def HADRON_REMNANT_SINGLET HADRON_REMNANT_TRIPLET HADRON_REMNANT_OCTET
@
Further particle codes for internal use:
<<Physics defs: public parameters>>=
integer, parameter, public :: INTERNAL = 94
integer, parameter, public :: INVALID = 97
integer, parameter, public :: COMPOSITE = 99
@ %def INTERNAL INVALID COMPOSITE
@
\subsection{Spin codes}
Somewhat redundant, but for better readability we define named
constants for spin types. If the mass is nonzero, this is equal to
the number of degrees of freedom.
<<Physics defs: public parameters>>=
integer, parameter, public:: UNKNOWN = 0
integer, parameter, public :: SCALAR = 1, SPINOR = 2, VECTOR = 3, &
VECTORSPINOR = 4, TENSOR = 5
@ %def UNKNOWN SCALAR SPINOR VECTOR VECTORSPINOR TENSOR
@ Isospin types and charge types are counted in an analogous way,
where charge type 1 is charge 0, 2 is charge 1/3, and so on. Zero
always means unknown. Note that charge and isospin types have an
explicit sign.
Color types are defined as the dimension of the representation.
\subsection{NLO status codes}
Used to specify whether a [[term_instance_t]] of a
[[process_instance_t]] is associated with a Born, real-subtracted,
virtual-subtracted or subtraction-dummy matrix element.
<<Physics defs: public parameters>>=
integer, parameter, public :: BORN = 0
integer, parameter, public :: NLO_REAL = 1
integer, parameter, public :: NLO_VIRTUAL = 2
integer, parameter, public :: NLO_MISMATCH = 3
integer, parameter, public :: NLO_DGLAP = 4
integer, parameter, public :: NLO_SUBTRACTION = 5
integer, parameter, public :: NLO_FULL = 6
integer, parameter, public :: GKS = 7
integer, parameter, public :: COMPONENT_UNDEFINED = 99
@ % def BORN, NLO_REAL, NLO_VIRTUAL, NLO_SUBTRACTION, GKS
@ [[NLO_FULL]] is not strictly a component status code but having it is
convenient.
We define the number of additional subtractions for beam-involved NLO calculations.
Each subtraction refers to a rescaling of one of two beams.
Obviously, this approach is not flexible enough to support setups with just a
single beam described by a structure function.
<<Physics defs: public parameters>>=
integer, parameter, public :: n_beams_rescaled = 2
@ %def n_beams_rescaled
@
<<Physics defs: public>>=
public :: component_status
<<Physics defs: interfaces>>=
interface component_status
module procedure component_status_of_string
module procedure component_status_to_string
end interface
<<Physics defs: procedures>>=
elemental function component_status_of_string (string) result (i)
integer :: i
type(string_t), intent(in) :: string
select case (char(string))
case ("born")
i = BORN
case ("real")
i = NLO_REAL
case ("virtual")
i = NLO_VIRTUAL
case ("mismatch")
i = NLO_MISMATCH
case ("dglap")
i = NLO_DGLAP
case ("subtraction")
i = NLO_SUBTRACTION
case ("full")
i = NLO_FULL
case ("GKS")
i = GKS
case default
i = COMPONENT_UNDEFINED
end select
end function component_status_of_string
elemental function component_status_to_string (i) result (string)
type(string_t) :: string
integer, intent(in) :: i
select case (i)
case (BORN)
string = "born"
case (NLO_REAL)
string = "real"
case (NLO_VIRTUAL)
string = "virtual"
case (NLO_MISMATCH)
string = "mismatch"
case (NLO_DGLAP)
string = "dglap"
case (NLO_SUBTRACTION)
string = "subtraction"
case (NLO_FULL)
string = "full"
case (GKS)
string = "GKS"
case default
string = "undefined"
end select
end function component_status_to_string
@ %def component_status
@
<<Physics defs: public>>=
public :: is_nlo_component
<<Physics defs: procedures>>=
elemental function is_nlo_component (comp) result (is_nlo)
logical :: is_nlo
integer, intent(in) :: comp
select case (comp)
case (BORN : GKS)
is_nlo = .true.
case default
is_nlo = .false.
end select
end function is_nlo_component
@ %def is_nlo_component
@
<<Physics defs: public>>=
public :: is_subtraction_component
<<Physics defs: procedures>>=
function is_subtraction_component (emitter, nlo_type) result (is_subtraction)
logical :: is_subtraction
integer, intent(in) :: emitter, nlo_type
is_subtraction = nlo_type == NLO_REAL .and. emitter < 0
end function is_subtraction_component
@ %def is_subtraction_component
@
\subsection{Threshold}
Some commonly used variables for the threshold computation
<<Physics defs: public parameters>>=
integer, parameter, public :: THR_POS_WP = 3
integer, parameter, public :: THR_POS_WM = 4
integer, parameter, public :: THR_POS_B = 5
integer, parameter, public :: THR_POS_BBAR = 6
integer, parameter, public :: THR_POS_GLUON = 7
integer, parameter, public :: THR_EMITTER_OFFSET = 4
integer, parameter, public :: NO_FACTORIZATION = 0
integer, parameter, public :: FACTORIZATION_THRESHOLD = 1
integer, dimension(2), parameter, public :: ass_quark = [5, 6]
integer, dimension(2), parameter, public :: ass_boson = [3, 4]
integer, parameter, public :: PROC_MODE_UNDEFINED = 0
integer, parameter, public :: PROC_MODE_TT = 1
integer, parameter, public :: PROC_MODE_WBWB = 2
@
@
<<Physics defs: public>>=
public :: thr_leg
<<Physics defs: procedures>>=
function thr_leg (emitter) result (leg)
integer :: leg
integer, intent(in) :: emitter
leg = emitter - THR_EMITTER_OFFSET
end function thr_leg
@ %def thr_leg
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{C-compatible Particle Type}
For easy communication with C code, we introduce a simple C-compatible
type for particles. The components are either default C integers or
default C doubles.
The [[c_prt]] type is transparent, and its contents should be regarded
as part of the interface.
<<[[c_particles.f90]]>>=
<<File header>>
module c_particles
use, intrinsic :: iso_c_binding !NODEP!
use io_units
use format_defs, only: FMT_14, FMT_19
<<Standard module head>>
<<C Particles: public>>
<<C Particles: types>>
contains
<<C Particles: procedures>>
end module c_particles
@ %def c_particles
@
<<C Particles: public>>=
public :: c_prt_t
<<C Particles: types>>=
type, bind(C) :: c_prt_t
integer(c_int) :: type = 0
integer(c_int) :: pdg = 0
integer(c_int) :: polarized = 0
integer(c_int) :: h = 0
real(c_double) :: pe = 0
real(c_double) :: px = 0
real(c_double) :: py = 0
real(c_double) :: pz = 0
real(c_double) :: p2 = 0
end type c_prt_t
@ %def c_prt_t
@ This is for debugging only, there is no C binding. It is a
simplified version of [[prt_write]].
<<C Particles: public>>=
public :: c_prt_write
<<C Particles: procedures>>=
subroutine c_prt_write (prt, unit)
type(c_prt_t), intent(in) :: prt
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)", advance="no") "prt("
write (u, "(I0,':')", advance="no") prt%type
if (prt%polarized /= 0) then
write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h
else
write (u, "(I0,'|')", advance="no") prt%pdg
end if
write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // &
FMT_14 // ",','," // FMT_14 // ")", advance="no") &
prt%pe, prt%px, prt%py, prt%pz
write (u, "('|'," // FMT_19 // ")", advance="no") prt%p2
write (u, "(A)") ")"
end subroutine c_prt_write
@ %def c_prt_write
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Lorentz algebra}
Define Lorentz vectors, three-vectors, boosts, and some functions to
manipulate them.
To make maximum use of this, all functions, if possible, are declared
elemental (or pure, if this is not possible).
<<[[lorentz.f90]]>>=
<<File header>>
module lorentz
<<Use kinds with double>>
use numeric_utils
use io_units
use constants, only: pi, twopi, degree, zero, one, two, eps0, tiny_07
use format_defs, only: FMT_11, FMT_13, FMT_15, FMT_19
use format_utils, only: pac_fmt
use diagnostics
use c_particles
<<Standard module head>>
<<Lorentz: public>>
<<Lorentz: public operators>>
<<Lorentz: public functions>>
<<Lorentz: types>>
<<Lorentz: parameters>>
<<Lorentz: interfaces>>
contains
<<Lorentz: procedures>>
end module lorentz
@ %def lorentz
@
\subsection{Three-vectors}
First of all, let us introduce three-vectors in a trivial way. The
functions and overloaded elementary operations clearly are too much
overhead, but we like to keep the interface for three-vectors and
four-vectors exactly parallel. By the way, we might attach a label to
a vector by extending the type definition later.
<<Lorentz: public>>=
public :: vector3_t
<<Lorentz: types>>=
type :: vector3_t
real(default), dimension(3) :: p
end type vector3_t
@ %def vector3_t
@ Output a vector
<<Lorentz: public>>=
public :: vector3_write
<<Lorentz: procedures>>=
subroutine vector3_write (p, unit, testflag)
type(vector3_t), intent(in) :: p
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
character(len=7) :: fmt
integer :: u
u = given_output_unit (unit); if (u < 0) return
call pac_fmt (fmt, FMT_19, FMT_15, testflag)
write(u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p
end subroutine vector3_write
@ %def vector3_write
@ This is a three-vector with zero components
<<Lorentz: public>>=
public :: vector3_null
<<Lorentz: parameters>>=
type(vector3_t), parameter :: vector3_null = &
vector3_t ([ zero, zero, zero ])
@ %def vector3_null
@ Canonical three-vector:
<<Lorentz: public>>=
public :: vector3_canonical
<<Lorentz: procedures>>=
elemental function vector3_canonical (k) result (p)
type(vector3_t) :: p
integer, intent(in) :: k
p = vector3_null
p%p(k) = 1
end function vector3_canonical
@ %def vector3_canonical
@ A moving particle ($k$-axis, or arbitrary axis). Note that the
function for the generic momentum cannot be elemental.
<<Lorentz: public>>=
public :: vector3_moving
<<Lorentz: interfaces>>=
interface vector3_moving
module procedure vector3_moving_canonical
module procedure vector3_moving_generic
end interface
<<Lorentz: procedures>>=
elemental function vector3_moving_canonical (p, k) result(q)
type(vector3_t) :: q
real(default), intent(in) :: p
integer, intent(in) :: k
q = vector3_null
q%p(k) = p
end function vector3_moving_canonical
pure function vector3_moving_generic (p) result(q)
real(default), dimension(3), intent(in) :: p
type(vector3_t) :: q
q%p = p
end function vector3_moving_generic
@ %def vector3_moving
@ Equality and inequality
<<Lorentz: public operators>>=
public :: operator(==), operator(/=)
<<Lorentz: interfaces>>=
interface operator(==)
module procedure vector3_eq
end interface
interface operator(/=)
module procedure vector3_neq
end interface
<<Lorentz: procedures>>=
elemental function vector3_eq (p, q) result (r)
logical :: r
type(vector3_t), intent(in) :: p,q
r = all (abs (p%p - q%p) < eps0)
end function vector3_eq
elemental function vector3_neq (p, q) result (r)
logical :: r
type(vector3_t), intent(in) :: p,q
r = any (abs(p%p - q%p) > eps0)
end function vector3_neq
@ %def == /=
@ Define addition and subtraction
<<Lorentz: public operators>>=
public :: operator(+), operator(-)
<<Lorentz: interfaces>>=
interface operator(+)
module procedure add_vector3
end interface
interface operator(-)
module procedure sub_vector3
end interface
<<Lorentz: procedures>>=
elemental function add_vector3 (p, q) result (r)
type(vector3_t) :: r
type(vector3_t), intent(in) :: p,q
r%p = p%p + q%p
end function add_vector3
elemental function sub_vector3 (p, q) result (r)
type(vector3_t) :: r
type(vector3_t), intent(in) :: p,q
r%p = p%p - q%p
end function sub_vector3
@ %def + -
@ The multiplication sign is overloaded with scalar multiplication;
similarly division:
<<Lorentz: public operators>>=
public :: operator(*), operator(/)
<<Lorentz: interfaces>>=
interface operator(*)
module procedure prod_integer_vector3, prod_vector3_integer
module procedure prod_real_vector3, prod_vector3_real
end interface
interface operator(/)
module procedure div_vector3_real, div_vector3_integer
end interface
<<Lorentz: procedures>>=
elemental function prod_real_vector3 (s, p) result (q)
type(vector3_t) :: q
real(default), intent(in) :: s
type(vector3_t), intent(in) :: p
q%p = s * p%p
end function prod_real_vector3
elemental function prod_vector3_real (p, s) result (q)
type(vector3_t) :: q
real(default), intent(in) :: s
type(vector3_t), intent(in) :: p
q%p = s * p%p
end function prod_vector3_real
elemental function div_vector3_real (p, s) result (q)
type(vector3_t) :: q
real(default), intent(in) :: s
type(vector3_t), intent(in) :: p
q%p = p%p/s
end function div_vector3_real
elemental function prod_integer_vector3 (s, p) result (q)
type(vector3_t) :: q
integer, intent(in) :: s
type(vector3_t), intent(in) :: p
q%p = s * p%p
end function prod_integer_vector3
elemental function prod_vector3_integer (p, s) result (q)
type(vector3_t) :: q
integer, intent(in) :: s
type(vector3_t), intent(in) :: p
q%p = s * p%p
end function prod_vector3_integer
elemental function div_vector3_integer (p, s) result (q)
type(vector3_t) :: q
integer, intent(in) :: s
type(vector3_t), intent(in) :: p
q%p = p%p/s
end function div_vector3_integer
@ %def * /
@ The multiplication sign can also indicate scalar products:
<<Lorentz: interfaces>>=
interface operator(*)
module procedure prod_vector3
end interface
<<Lorentz: procedures>>=
elemental function prod_vector3 (p, q) result (s)
real(default) :: s
type(vector3_t), intent(in) :: p,q
s = dot_product (p%p, q%p)
end function prod_vector3
@ %def *
<<Lorentz: public functions>>=
public :: cross_product
<<Lorentz: interfaces>>=
interface cross_product
module procedure vector3_cross_product
end interface
<<Lorentz: procedures>>=
elemental function vector3_cross_product (p, q) result (r)
type(vector3_t) :: r
type(vector3_t), intent(in) :: p,q
integer :: i
do i=1,3
r%p(i) = dot_product (p%p, matmul(epsilon_three(i,:,:), q%p))
end do
end function vector3_cross_product
@ %def cross_product
@ Exponentiation is defined only for integer powers. Odd powers mean
take the square root; so [[p**1]] is the length of [[p]].
<<Lorentz: public operators>>=
public :: operator(**)
<<Lorentz: interfaces>>=
interface operator(**)
module procedure power_vector3
end interface
<<Lorentz: procedures>>=
elemental function power_vector3 (p, e) result (s)
real(default) :: s
type(vector3_t), intent(in) :: p
integer, intent(in) :: e
s = dot_product (p%p, p%p)
if (e/=2) then
if (mod(e,2)==0) then
s = s**(e/2)
else
s = sqrt(s)**e
end if
end if
end function power_vector3
@ %def **
@ Finally, we need a negation.
<<Lorentz: interfaces>>=
interface operator(-)
module procedure negate_vector3
end interface
<<Lorentz: procedures>>=
elemental function negate_vector3 (p) result (q)
type(vector3_t) :: q
type(vector3_t), intent(in) :: p
integer :: i
do i = 1, 3
if (abs (p%p(i)) < eps0) then
q%p(i) = 0
else
q%p(i) = -p%p(i)
end if
end do
end function negate_vector3
@ %def -
@ The sum function can be useful:
<<Lorentz: public functions>>=
public :: sum
<<Lorentz: interfaces>>=
interface sum
module procedure sum_vector3
end interface
@ %def sum
@
<<Lorentz: public>>=
public :: vector3_set_component
<<Lorentz: procedures>>=
subroutine vector3_set_component (p, i, value)
type(vector3_t), intent(inout) :: p
integer, intent(in) :: i
real(default), intent(in) :: value
p%p(i) = value
end subroutine vector3_set_component
@ %def vector3_set_component
@
<<Lorentz: procedures>>=
pure function sum_vector3 (p) result (q)
type(vector3_t) :: q
type(vector3_t), dimension(:), intent(in) :: p
integer :: i
do i=1, 3
q%p(i) = sum (p%p(i))
end do
end function sum_vector3
@ %def sum
@ Any component:
<<Lorentz: public>>=
public :: vector3_get_component
@ %def component
<<Lorentz: procedures>>=
elemental function vector3_get_component (p, k) result (c)
type(vector3_t), intent(in) :: p
integer, intent(in) :: k
real(default) :: c
c = p%p(k)
end function vector3_get_component
@ %def vector3_get_component
@ Extract all components. This is not elemental.
<<Lorentz: public>>=
public :: vector3_get_components
<<Lorentz: procedures>>=
pure function vector3_get_components (p) result (a)
type(vector3_t), intent(in) :: p
real(default), dimension(3) :: a
a = p%p
end function vector3_get_components
@ %def vector3_get_components
@ This function returns the direction of a three-vector, i.e., a
normalized three-vector. If the vector is null, we return a null vector.
<<Lorentz: public functions>>=
public :: direction
<<Lorentz: interfaces>>=
interface direction
module procedure vector3_get_direction
end interface
<<Lorentz: procedures>>=
elemental function vector3_get_direction (p) result (q)
type(vector3_t) :: q
type(vector3_t), intent(in) :: p
real(default) :: pp
pp = p**1
if (pp > eps0) then
q%p = p%p / pp
else
q%p = 0
end if
end function vector3_get_direction
@ %def direction
@
\subsection{Four-vectors}
In four-vectors the zero-component needs special treatment, therefore
we do not use the standard operations. Sure, we pay for the extra
layer of abstraction by losing efficiency; so we have to assume that
the time-critical applications do not involve four-vector operations.
<<Lorentz: public>>=
public :: vector4_t
<<Lorentz: types>>=
type :: vector4_t
real(default), dimension(0:3) :: p = &
[zero, zero, zero, zero]
contains
<<Lorentz: vector4: TBP>>
end type vector4_t
@ %def vector4_t
@ Output a vector
<<Lorentz: public>>=
public :: vector4_write
<<Lorentz: vector4: TBP>>=
procedure :: write => vector4_write
<<Lorentz: procedures>>=
subroutine vector4_write &
(p, unit, show_mass, testflag, compressed, ultra)
class(vector4_t), intent(in) :: p
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass, testflag, compressed, ultra
logical :: comp, sm, tf, extreme
integer :: u
character(len=7) :: fmt
real(default) :: m
comp = .false.; if (present (compressed)) comp = compressed
sm = .false.; if (present (show_mass)) sm = show_mass
tf = .false.; if (present (testflag)) tf = testflag
extreme = .false.; if (present (ultra)) extreme = ultra
if (extreme) then
call pac_fmt (fmt, FMT_19, FMT_11, testflag)
else
call pac_fmt (fmt, FMT_19, FMT_13, testflag)
end if
u = given_output_unit (unit); if (u < 0) return
if (comp) then
write (u, "(4(F12.3,1X))", advance="no") p%p(0:3)
else
write (u, "(1x,A,1x," // fmt // ")") 'E = ', p%p(0)
write (u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p(1:)
if (sm) then
m = p**1
if (tf) call pacify (m, tolerance = 1E-6_default)
write (u, "(1x,A,1x," // fmt // ")") 'M = ', m
end if
end if
end subroutine vector4_write
@ %def vector4_write
@ Binary I/O
<<Lorentz: public>>=
public :: vector4_write_raw
public :: vector4_read_raw
<<Lorentz: procedures>>=
subroutine vector4_write_raw (p, u)
type(vector4_t), intent(in) :: p
integer, intent(in) :: u
write (u) p%p
end subroutine vector4_write_raw
subroutine vector4_read_raw (p, u, iostat)
type(vector4_t), intent(out) :: p
integer, intent(in) :: u
integer, intent(out), optional :: iostat
read (u, iostat=iostat) p%p
end subroutine vector4_read_raw
@ %def vector4_write_raw vector4_read_raw
@ This is a four-vector with zero components
<<Lorentz: public>>=
public :: vector4_null
<<Lorentz: parameters>>=
type(vector4_t), parameter :: vector4_null = &
vector4_t ([ zero, zero, zero, zero ])
@ %def vector4_null
@ Canonical four-vector:
<<Lorentz: public>>=
public :: vector4_canonical
<<Lorentz: procedures>>=
elemental function vector4_canonical (k) result (p)
type(vector4_t) :: p
integer, intent(in) :: k
p = vector4_null
p%p(k) = 1
end function vector4_canonical
@ %def vector4_canonical
@ A particle at rest:
<<Lorentz: public>>=
public :: vector4_at_rest
<<Lorentz: procedures>>=
elemental function vector4_at_rest (m) result (p)
type(vector4_t) :: p
real(default), intent(in) :: m
p = vector4_t ([ m, zero, zero, zero ])
end function vector4_at_rest
@ %def vector4_at_rest
@ A moving particle ($k$-axis, or arbitrary axis)
<<Lorentz: public>>=
public :: vector4_moving
<<Lorentz: interfaces>>=
interface vector4_moving
module procedure vector4_moving_canonical
module procedure vector4_moving_generic
end interface
<<Lorentz: procedures>>=
elemental function vector4_moving_canonical (E, p, k) result (q)
type(vector4_t) :: q
real(default), intent(in) :: E, p
integer, intent(in) :: k
q = vector4_at_rest(E)
q%p(k) = p
end function vector4_moving_canonical
elemental function vector4_moving_generic (E, p) result (q)
type(vector4_t) :: q
real(default), intent(in) :: E
type(vector3_t), intent(in) :: p
q%p(0) = E
q%p(1:) = p%p
end function vector4_moving_generic
@ %def vector4_moving
@ Equality and inequality
<<Lorentz: interfaces>>=
interface operator(==)
module procedure vector4_eq
end interface
interface operator(/=)
module procedure vector4_neq
end interface
<<Lorentz: procedures>>=
elemental function vector4_eq (p, q) result (r)
logical :: r
type(vector4_t), intent(in) :: p,q
r = all (abs (p%p - q%p) < eps0)
end function vector4_eq
elemental function vector4_neq (p, q) result (r)
logical :: r
type(vector4_t), intent(in) :: p,q
r = any (abs (p%p - q%p) > eps0)
end function vector4_neq
@ %def == /=
@ Addition and subtraction:
<<Lorentz: interfaces>>=
interface operator(+)
module procedure add_vector4
end interface
interface operator(-)
module procedure sub_vector4
end interface
<<Lorentz: procedures>>=
elemental function add_vector4 (p,q) result (r)
type(vector4_t) :: r
type(vector4_t), intent(in) :: p,q
r%p = p%p + q%p
end function add_vector4
elemental function sub_vector4 (p,q) result (r)
type(vector4_t) :: r
type(vector4_t), intent(in) :: p,q
r%p = p%p - q%p
end function sub_vector4
@ %def + -
@ We also need scalar multiplication and division:
<<Lorentz: interfaces>>=
interface operator(*)
module procedure prod_real_vector4, prod_vector4_real
module procedure prod_integer_vector4, prod_vector4_integer
end interface
interface operator(/)
module procedure div_vector4_real
module procedure div_vector4_integer
end interface
<<Lorentz: procedures>>=
elemental function prod_real_vector4 (s, p) result (q)
type(vector4_t) :: q
real(default), intent(in) :: s
type(vector4_t), intent(in) :: p
q%p = s * p%p
end function prod_real_vector4
elemental function prod_vector4_real (p, s) result (q)
type(vector4_t) :: q
real(default), intent(in) :: s
type(vector4_t), intent(in) :: p
q%p = s * p%p
end function prod_vector4_real
elemental function div_vector4_real (p, s) result (q)
type(vector4_t) :: q
real(default), intent(in) :: s
type(vector4_t), intent(in) :: p
q%p = p%p/s
end function div_vector4_real
elemental function prod_integer_vector4 (s, p) result (q)
type(vector4_t) :: q
integer, intent(in) :: s
type(vector4_t), intent(in) :: p
q%p = s * p%p
end function prod_integer_vector4
elemental function prod_vector4_integer (p, s) result (q)
type(vector4_t) :: q
integer, intent(in) :: s
type(vector4_t), intent(in) :: p
q%p = s * p%p
end function prod_vector4_integer
elemental function div_vector4_integer (p, s) result (q)
type(vector4_t) :: q
integer, intent(in) :: s
type(vector4_t), intent(in) :: p
q%p = p%p/s
end function div_vector4_integer
@ %def * /
@ Scalar products and squares in the Minkowski sense:
<<Lorentz: interfaces>>=
interface operator(*)
module procedure prod_vector4
end interface
interface operator(**)
module procedure power_vector4
end interface
<<Lorentz: procedures>>=
elemental function prod_vector4 (p, q) result (s)
real(default) :: s
type(vector4_t), intent(in) :: p,q
s = p%p(0)*q%p(0) - dot_product(p%p(1:), q%p(1:))
end function prod_vector4
@ %def *
@ The power operation for four-vectors is signed, i.e., [[p**1]] is
positive for timelike and negative for spacelike vectors. Note that
[[(p**1)**2]] is not necessarily equal to [[p**2]].
<<Lorentz: procedures>>=
elemental function power_vector4 (p, e) result (s)
real(default) :: s
type(vector4_t), intent(in) :: p
integer, intent(in) :: e
s = p * p
if (e /= 2) then
if (mod(e, 2) == 0) then
s = s**(e / 2)
else if (s >= 0) then
s = sqrt(s)**e
else
s = -(sqrt(abs(s))**e)
end if
end if
end function power_vector4
@ %def **
@ Finally, we introduce a negation
<<Lorentz: interfaces>>=
interface operator(-)
module procedure negate_vector4
end interface
<<Lorentz: procedures>>=
elemental function negate_vector4 (p) result (q)
type(vector4_t) :: q
type(vector4_t), intent(in) :: p
integer :: i
do i = 0, 3
if (abs (p%p(i)) < eps0) then
q%p(i) = 0
else
q%p(i) = -p%p(i)
end if
end do
end function negate_vector4
@ %def -
@ The sum function can be useful:
<<Lorentz: interfaces>>=
interface sum
module procedure sum_vector4, sum_vector4_mask
end interface
@ %def sum
@
<<Lorentz: procedures>>=
pure function sum_vector4 (p) result (q)
type(vector4_t) :: q
type(vector4_t), dimension(:), intent(in) :: p
integer :: i
do i = 0, 3
q%p(i) = sum (p%p(i))
end do
end function sum_vector4
pure function sum_vector4_mask (p, mask) result (q)
type(vector4_t) :: q
type(vector4_t), dimension(:), intent(in) :: p
logical, dimension(:), intent(in) :: mask
integer :: i
do i = 0, 3
q%p(i) = sum (p%p(i), mask=mask)
end do
end function sum_vector4_mask
@ %def sum
@
\subsection{Conversions}
Manually set a component of the four-vector:
<<Lorentz: public>>=
public :: vector4_set_component
<<Lorentz: procedures>>=
subroutine vector4_set_component (p, k, c)
type(vector4_t), intent(inout) :: p
integer, intent(in) :: k
real(default), intent(in) :: c
p%p(k) = c
end subroutine vector4_set_component
@ %def vector4_get_component
Any component:
<<Lorentz: public>>=
public :: vector4_get_component
<<Lorentz: procedures>>=
elemental function vector4_get_component (p, k) result (c)
real(default) :: c
type(vector4_t), intent(in) :: p
integer, intent(in) :: k
c = p%p(k)
end function vector4_get_component
@ %def vector4_get_component
@ Extract all components. This is not elemental.
<<Lorentz: public>>=
public :: vector4_get_components
<<Lorentz: procedures>>=
pure function vector4_get_components (p) result (a)
real(default), dimension(0:3) :: a
type(vector4_t), intent(in) :: p
a = p%p
end function vector4_get_components
@ %def vector4_get_components
@ This function returns the space part of a four-vector, such that we
can apply three-vector operations on it:
<<Lorentz: public functions>>=
public :: space_part
<<Lorentz: interfaces>>=
interface space_part
module procedure vector4_get_space_part
end interface
<<Lorentz: procedures>>=
elemental function vector4_get_space_part (p) result (q)
type(vector3_t) :: q
type(vector4_t), intent(in) :: p
q%p = p%p(1:)
end function vector4_get_space_part
@ %def space_part
@ This function returns the direction of a four-vector, i.e., a
normalized three-vector. If the four-vector has zero space part, we
return a null vector.
<<Lorentz: interfaces>>=
interface direction
module procedure vector4_get_direction
end interface
<<Lorentz: procedures>>=
elemental function vector4_get_direction (p) result (q)
type(vector3_t) :: q
type(vector4_t), intent(in) :: p
real(default) :: qq
q%p = p%p(1:)
qq = q**1
if (abs(qq) > eps0) then
q%p = q%p / qq
else
q%p = 0
end if
end function vector4_get_direction
@ %def direction
@ Change the sign of the spatial part of a four-vector
<<Lorentz: public>>=
public :: vector4_invert_direction
<<Lorentz: procedures>>=
elemental subroutine vector4_invert_direction (p)
type(vector4_t), intent(inout) :: p
p%p(1:3) = -p%p(1:3)
end subroutine vector4_invert_direction
@ %def vector4_invert_direction
@ This function returns the four-vector as an ordinary array. A
second version for an array of four-vectors.
<<Lorentz: public>>=
public :: assignment (=)
<<Lorentz: interfaces>>=
interface assignment (=)
module procedure array_from_vector4_1, array_from_vector4_2, &
array_from_vector3_1, array_from_vector3_2, &
vector4_from_array, vector3_from_array
end interface
<<Lorentz: procedures>>=
pure subroutine array_from_vector4_1 (a, p)
real(default), dimension(:), intent(out) :: a
type(vector4_t), intent(in) :: p
a = p%p
end subroutine array_from_vector4_1
pure subroutine array_from_vector4_2 (a, p)
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:,:), intent(out) :: a
integer :: i
forall (i=1:size(p))
a(:,i) = p(i)%p
end forall
end subroutine array_from_vector4_2
pure subroutine array_from_vector3_1 (a, p)
real(default), dimension(:), intent(out) :: a
type(vector3_t), intent(in) :: p
a = p%p
end subroutine array_from_vector3_1
pure subroutine array_from_vector3_2 (a, p)
type(vector3_t), dimension(:), intent(in) :: p
real(default), dimension(:,:), intent(out) :: a
integer :: i
forall (i=1:size(p))
a(:,i) = p(i)%p
end forall
end subroutine array_from_vector3_2
pure subroutine vector4_from_array (p, a)
type(vector4_t), intent(out) :: p
real(default), dimension(:), intent(in) :: a
p%p(0:3) = a
end subroutine vector4_from_array
pure subroutine vector3_from_array (p, a)
type(vector3_t), intent(out) :: p
real(default), dimension(:), intent(in) :: a
p%p(1:3) = a
end subroutine vector3_from_array
@ %def array_from_vector4 array_from_vector3
@
<<Lorentz: public>>=
public :: vector4
<<Lorentz: procedures>>=
pure function vector4 (a) result (p)
type(vector4_t) :: p
real(default), intent(in), dimension(4) :: a
p%p = a
end function vector4
@ %def vector4
@
<<Lorentz: vector4: TBP>>=
procedure :: to_pythia6 => vector4_to_pythia6
<<Lorentz: procedures>>=
pure function vector4_to_pythia6 (vector4, m) result (p)
real(double), dimension(1:5) :: p
class(vector4_t), intent(in) :: vector4
real(default), intent(in), optional :: m
p(1:3) = vector4%p(1:3)
p(4) = vector4%p(0)
if (present (m)) then
p(5) = m
else
p(5) = vector4 ** 1
end if
end function vector4_to_pythia6
@ %def vector4_to_pythia6
@
\subsection{Interface to [[c_prt]]}
Transform the momentum of a [[c_prt]] object into a four-vector and
vice versa:
<<Lorentz: interfaces>>=
interface assignment (=)
module procedure vector4_from_c_prt, c_prt_from_vector4
end interface
<<Lorentz: procedures>>=
pure subroutine vector4_from_c_prt (p, c_prt)
type(vector4_t), intent(out) :: p
type(c_prt_t), intent(in) :: c_prt
p%p(0) = c_prt%pe
p%p(1) = c_prt%px
p%p(2) = c_prt%py
p%p(3) = c_prt%pz
end subroutine vector4_from_c_prt
pure subroutine c_prt_from_vector4 (c_prt, p)
type(c_prt_t), intent(out) :: c_prt
type(vector4_t), intent(in) :: p
c_prt%pe = p%p(0)
c_prt%px = p%p(1)
c_prt%py = p%p(2)
c_prt%pz = p%p(3)
c_prt%p2 = p ** 2
end subroutine c_prt_from_vector4
@ %def vector4_from_c_prt c_prt_from_vector4
@ Initialize a [[c_prt_t]] object with the components of a four-vector
as its kinematical entries. Compute the invariant mass, or use the
optional mass-squared value instead.
<<Lorentz: public>>=
public :: vector4_to_c_prt
<<Lorentz: procedures>>=
elemental function vector4_to_c_prt (p, p2) result (c_prt)
type(c_prt_t) :: c_prt
type(vector4_t), intent(in) :: p
real(default), intent(in), optional :: p2
c_prt%pe = p%p(0)
c_prt%px = p%p(1)
c_prt%py = p%p(2)
c_prt%pz = p%p(3)
if (present (p2)) then
c_prt%p2 = p2
else
c_prt%p2 = p ** 2
end if
end function vector4_to_c_prt
@ %def vector4_to_c_prt
@
\subsection{Angles}
Return the angles in a canonical system. The angle $\phi$ is defined
between $0\leq\phi<2\pi$. In degenerate cases, return zero.
<<Lorentz: public functions>>=
public :: azimuthal_angle
<<Lorentz: interfaces>>=
interface azimuthal_angle
module procedure vector3_azimuthal_angle
module procedure vector4_azimuthal_angle
end interface
<<Lorentz: procedures>>=
elemental function vector3_azimuthal_angle (p) result (phi)
real(default) :: phi
type(vector3_t), intent(in) :: p
if (any (abs (p%p(1:2)) > 0)) then
phi = atan2(p%p(2), p%p(1))
if (phi < 0) phi = phi + twopi
else
phi = 0
end if
end function vector3_azimuthal_angle
elemental function vector4_azimuthal_angle (p) result (phi)
real(default) :: phi
type(vector4_t), intent(in) :: p
phi = vector3_azimuthal_angle (space_part (p))
end function vector4_azimuthal_angle
@ %def azimuthal_angle
@ Azimuthal angle in degrees
<<Lorentz: public functions>>=
public :: azimuthal_angle_deg
<<Lorentz: interfaces>>=
interface azimuthal_angle_deg
module procedure vector3_azimuthal_angle_deg
module procedure vector4_azimuthal_angle_deg
end interface
<<Lorentz: procedures>>=
elemental function vector3_azimuthal_angle_deg (p) result (phi)
real(default) :: phi
type(vector3_t), intent(in) :: p
phi = vector3_azimuthal_angle (p) / degree
end function vector3_azimuthal_angle_deg
elemental function vector4_azimuthal_angle_deg (p) result (phi)
real(default) :: phi
type(vector4_t), intent(in) :: p
phi = vector4_azimuthal_angle (p) / degree
end function vector4_azimuthal_angle_deg
@ %def azimuthal_angle_deg
@ The azimuthal distance of two vectors. This is the difference of
the azimuthal angles, but cannot be larger than $\pi$: The result is
between $-\pi<\Delta\phi\leq\pi$.
<<Lorentz: public functions>>=
public :: azimuthal_distance
<<Lorentz: interfaces>>=
interface azimuthal_distance
module procedure vector3_azimuthal_distance
module procedure vector4_azimuthal_distance
end interface
<<Lorentz: procedures>>=
elemental function vector3_azimuthal_distance (p, q) result (dphi)
real(default) :: dphi
type(vector3_t), intent(in) :: p,q
dphi = vector3_azimuthal_angle (q) - vector3_azimuthal_angle (p)
if (dphi <= -pi) then
dphi = dphi + twopi
else if (dphi > pi) then
dphi = dphi - twopi
end if
end function vector3_azimuthal_distance
elemental function vector4_azimuthal_distance (p, q) result (dphi)
real(default) :: dphi
type(vector4_t), intent(in) :: p,q
dphi = vector3_azimuthal_distance &
(space_part (p), space_part (q))
end function vector4_azimuthal_distance
@ %def azimuthal_distance
@ The same in degrees:
<<Lorentz: public functions>>=
public :: azimuthal_distance_deg
<<Lorentz: interfaces>>=
interface azimuthal_distance_deg
module procedure vector3_azimuthal_distance_deg
module procedure vector4_azimuthal_distance_deg
end interface
<<Lorentz: procedures>>=
elemental function vector3_azimuthal_distance_deg (p, q) result (dphi)
real(default) :: dphi
type(vector3_t), intent(in) :: p,q
dphi = vector3_azimuthal_distance (p, q) / degree
end function vector3_azimuthal_distance_deg
elemental function vector4_azimuthal_distance_deg (p, q) result (dphi)
real(default) :: dphi
type(vector4_t), intent(in) :: p,q
dphi = vector4_azimuthal_distance (p, q) / degree
end function vector4_azimuthal_distance_deg
@ %def azimuthal_distance_deg
@ The polar angle is defined $0\leq\theta\leq\pi$. Note that
[[ATAN2]] has the reversed order of arguments: [[ATAN2(Y,X)]]. Here,
$x$ is the 3-component while $y$ is the transverse momentum which is
always nonnegative. Therefore, the result is nonnegative as well.
<<Lorentz: public functions>>=
public :: polar_angle
<<Lorentz: interfaces>>=
interface polar_angle
module procedure polar_angle_vector3
module procedure polar_angle_vector4
end interface
<<Lorentz: procedures>>=
elemental function polar_angle_vector3 (p) result (theta)
real(default) :: theta
type(vector3_t), intent(in) :: p
if (any (abs (p%p) > 0)) then
theta = atan2 (sqrt(p%p(1)**2 + p%p(2)**2), p%p(3))
else
theta = 0
end if
end function polar_angle_vector3
elemental function polar_angle_vector4 (p) result (theta)
real(default) :: theta
type(vector4_t), intent(in) :: p
theta = polar_angle (space_part (p))
end function polar_angle_vector4
@ %def polar_angle
@ This is the cosine of the polar angle: $-1\leq\cos\theta\leq 1$.
<<Lorentz: public functions>>=
public :: polar_angle_ct
<<Lorentz: interfaces>>=
interface polar_angle_ct
module procedure polar_angle_ct_vector3
module procedure polar_angle_ct_vector4
end interface
<<Lorentz: procedures>>=
elemental function polar_angle_ct_vector3 (p) result (ct)
real(default) :: ct
type(vector3_t), intent(in) :: p
if (any (abs (p%p) > 0)) then
ct = p%p(3) / p**1
else
ct = 1
end if
end function polar_angle_ct_vector3
elemental function polar_angle_ct_vector4 (p) result (ct)
real(default) :: ct
type(vector4_t), intent(in) :: p
ct = polar_angle_ct (space_part (p))
end function polar_angle_ct_vector4
@ %def polar_angle_ct
@ The polar angle in degrees.
<<Lorentz: public functions>>=
public :: polar_angle_deg
<<Lorentz: interfaces>>=
interface polar_angle_deg
module procedure polar_angle_deg_vector3
module procedure polar_angle_deg_vector4
end interface
<<Lorentz: procedures>>=
elemental function polar_angle_deg_vector3 (p) result (theta)
real(default) :: theta
type(vector3_t), intent(in) :: p
theta = polar_angle (p) / degree
end function polar_angle_deg_vector3
elemental function polar_angle_deg_vector4 (p) result (theta)
real(default) :: theta
type(vector4_t), intent(in) :: p
theta = polar_angle (p) / degree
end function polar_angle_deg_vector4
@ %def polar_angle_deg
@ This is the angle enclosed between two three-momenta. If one of the
momenta is zero, we return an angle of zero. The range of the result
is $0\leq\theta\leq\pi$. If there is only one argument, take the
positive $z$ axis as reference.
<<Lorentz: public functions>>=
public :: enclosed_angle
<<Lorentz: interfaces>>=
interface enclosed_angle
module procedure enclosed_angle_vector3
module procedure enclosed_angle_vector4
end interface
<<Lorentz: procedures>>=
elemental function enclosed_angle_vector3 (p, q) result (theta)
real(default) :: theta
type(vector3_t), intent(in) :: p, q
theta = acos (enclosed_angle_ct (p, q))
end function enclosed_angle_vector3
elemental function enclosed_angle_vector4 (p, q) result (theta)
real(default) :: theta
type(vector4_t), intent(in) :: p, q
theta = enclosed_angle (space_part (p), space_part (q))
end function enclosed_angle_vector4
@ %def enclosed_angle
@ The cosine of the enclosed angle.
<<Lorentz: public functions>>=
public :: enclosed_angle_ct
<<Lorentz: interfaces>>=
interface enclosed_angle_ct
module procedure enclosed_angle_ct_vector3
module procedure enclosed_angle_ct_vector4
end interface
<<Lorentz: procedures>>=
elemental function enclosed_angle_ct_vector3 (p, q) result (ct)
real(default) :: ct
type(vector3_t), intent(in) :: p, q
if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then
ct = p*q / (p**1 * q**1)
if (ct>1) then
ct = 1
else if (ct<-1) then
ct = -1
end if
else
ct = 1
end if
end function enclosed_angle_ct_vector3
elemental function enclosed_angle_ct_vector4 (p, q) result (ct)
real(default) :: ct
type(vector4_t), intent(in) :: p, q
ct = enclosed_angle_ct (space_part (p), space_part (q))
end function enclosed_angle_ct_vector4
@ %def enclosed_angle_ct
@ The enclosed angle in degrees.
<<Lorentz: public functions>>=
public :: enclosed_angle_deg
<<Lorentz: interfaces>>=
interface enclosed_angle_deg
module procedure enclosed_angle_deg_vector3
module procedure enclosed_angle_deg_vector4
end interface
<<Lorentz: procedures>>=
elemental function enclosed_angle_deg_vector3 (p, q) result (theta)
real(default) :: theta
type(vector3_t), intent(in) :: p, q
theta = enclosed_angle (p, q) / degree
end function enclosed_angle_deg_vector3
elemental function enclosed_angle_deg_vector4 (p, q) result (theta)
real(default) :: theta
type(vector4_t), intent(in) :: p, q
theta = enclosed_angle (p, q) / degree
end function enclosed_angle_deg_vector4
@ %def enclosed_angle
@ The polar angle of the first momentum w.r.t.\ the second momentum,
evaluated in the rest frame of the second momentum. If the second
four-momentum is not timelike, return zero.
<<Lorentz: public functions>>=
public :: enclosed_angle_rest_frame
public :: enclosed_angle_ct_rest_frame
public :: enclosed_angle_deg_rest_frame
<<Lorentz: interfaces>>=
interface enclosed_angle_rest_frame
module procedure enclosed_angle_rest_frame_vector4
end interface
interface enclosed_angle_ct_rest_frame
module procedure enclosed_angle_ct_rest_frame_vector4
end interface
interface enclosed_angle_deg_rest_frame
module procedure enclosed_angle_deg_rest_frame_vector4
end interface
<<Lorentz: procedures>>=
elemental function enclosed_angle_rest_frame_vector4 (p, q) result (theta)
type(vector4_t), intent(in) :: p, q
real(default) :: theta
theta = acos (enclosed_angle_ct_rest_frame (p, q))
end function enclosed_angle_rest_frame_vector4
elemental function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct)
type(vector4_t), intent(in) :: p, q
real(default) :: ct
if (invariant_mass(q) > 0) then
ct = enclosed_angle_ct ( &
space_part (boost(-q, invariant_mass (q)) * p), &
space_part (q))
else
ct = 1
end if
end function enclosed_angle_ct_rest_frame_vector4
elemental function enclosed_angle_deg_rest_frame_vector4 (p, q) &
result (theta)
type(vector4_t), intent(in) :: p, q
real(default) :: theta
theta = enclosed_angle_rest_frame (p, q) / degree
end function enclosed_angle_deg_rest_frame_vector4
@ %def enclosed_angle_rest_frame
@ %def enclosed_angle_ct_rest_frame
@ %def enclosed_angle_deg_rest_frame
@
\subsection{More kinematical functions (some redundant)}
The scalar transverse momentum (assuming the $z$ axis is longitudinal)
<<Lorentz: public functions>>=
public :: transverse_part
<<Lorentz: interfaces>>=
interface transverse_part
module procedure transverse_part_vector4_beam_axis
module procedure transverse_part_vector4_vector4
end interface
<<Lorentz: procedures>>=
elemental function transverse_part_vector4_beam_axis (p) result (pT)
real(default) :: pT
type(vector4_t), intent(in) :: p
pT = sqrt(p%p(1)**2 + p%p(2)**2)
end function transverse_part_vector4_beam_axis
elemental function transverse_part_vector4_vector4 (p1, p2) result (pT)
real(default) :: pT
type(vector4_t), intent(in) :: p1, p2
real(default) :: p1_norm, p2_norm, p1p2, pT2
p1_norm = space_part_norm(p1)**2
p2_norm = space_part_norm(p2)**2
! p1p2 = p1%p(1:3)*p2%p(1:3)
p1p2 = vector4_get_space_part(p1) * vector4_get_space_part(p2)
pT2 = (p1_norm*p2_norm - p1p2)/p1_norm
pT = sqrt (pT2)
end function transverse_part_vector4_vector4
@ %def transverse_part
@ The scalar longitudinal momentum (assuming the $z$ axis is
longitudinal). Identical to [[momentum_z_component]].
<<Lorentz: public functions>>=
public :: longitudinal_part
<<Lorentz: interfaces>>=
interface longitudinal_part
module procedure longitudinal_part_vector4
end interface
<<Lorentz: procedures>>=
elemental function longitudinal_part_vector4 (p) result (pL)
real(default) :: pL
type(vector4_t), intent(in) :: p
pL = p%p(3)
end function longitudinal_part_vector4
@ %def longitudinal_part
@ Absolute value of three-momentum
<<Lorentz: public functions>>=
public :: space_part_norm
<<Lorentz: interfaces>>=
interface space_part_norm
module procedure space_part_norm_vector4
end interface
<<Lorentz: procedures>>=
elemental function space_part_norm_vector4 (p) result (p3)
real(default) :: p3
type(vector4_t), intent(in) :: p
p3 = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2)
end function space_part_norm_vector4
@ %def momentum
@ The energy (the zeroth component)
<<Lorentz: public functions>>=
public :: energy
<<Lorentz: interfaces>>=
interface energy
module procedure energy_vector4
module procedure energy_vector3
module procedure energy_real
end interface
<<Lorentz: procedures>>=
elemental function energy_vector4 (p) result (E)
real(default) :: E
type(vector4_t), intent(in) :: p
E = p%p(0)
end function energy_vector4
@ Alternative: The energy corresponding to a given momentum and mass.
If the mass is omitted, it is zero
<<Lorentz: procedures>>=
elemental function energy_vector3 (p, mass) result (E)
real(default) :: E
type(vector3_t), intent(in) :: p
real(default), intent(in), optional :: mass
if (present (mass)) then
E = sqrt (p**2 + mass**2)
else
E = p**1
end if
end function energy_vector3
elemental function energy_real (p, mass) result (E)
real(default) :: E
real(default), intent(in) :: p
real(default), intent(in), optional :: mass
if (present (mass)) then
E = sqrt (p**2 + mass**2)
else
E = abs (p)
end if
end function energy_real
@ %def energy
@ The invariant mass of four-momenta. Zero for lightlike, negative for
spacelike momenta.
<<Lorentz: public functions>>=
public :: invariant_mass
<<Lorentz: interfaces>>=
interface invariant_mass
module procedure invariant_mass_vector4
end interface
<<Lorentz: procedures>>=
elemental function invariant_mass_vector4 (p) result (m)
real(default) :: m
type(vector4_t), intent(in) :: p
real(default) :: msq
msq = p*p
if (msq >= 0) then
m = sqrt (msq)
else
m = - sqrt (abs (msq))
end if
end function invariant_mass_vector4
@ %def invariant_mass
@ The invariant mass squared. Zero for lightlike, negative for
spacelike momenta.
<<Lorentz: public functions>>=
public :: invariant_mass_squared
<<Lorentz: interfaces>>=
interface invariant_mass_squared
module procedure invariant_mass_squared_vector4
end interface
<<Lorentz: procedures>>=
elemental function invariant_mass_squared_vector4 (p) result (msq)
real(default) :: msq
type(vector4_t), intent(in) :: p
msq = p*p
end function invariant_mass_squared_vector4
@ %def invariant_mass_squared
@ The transverse mass. If the mass squared is negative, this value
also is negative.
<<Lorentz: public functions>>=
public :: transverse_mass
<<Lorentz: interfaces>>=
interface transverse_mass
module procedure transverse_mass_vector4
end interface
<<Lorentz: procedures>>=
elemental function transverse_mass_vector4 (p) result (m)
real(default) :: m
type(vector4_t), intent(in) :: p
real(default) :: msq
msq = p%p(0)**2 - p%p(1)**2 - p%p(2)**2
if (msq >= 0) then
m = sqrt (msq)
else
m = - sqrt (abs (msq))
end if
end function transverse_mass_vector4
@ %def transverse_mass
@ The rapidity (defined if particle is massive or $p_\perp>0$)
<<Lorentz: public functions>>=
public :: rapidity
<<Lorentz: interfaces>>=
interface rapidity
module procedure rapidity_vector4
end interface
<<Lorentz: procedures>>=
elemental function rapidity_vector4 (p) result (y)
real(default) :: y
type(vector4_t), intent(in) :: p
y = .5 * log( (energy (p) + longitudinal_part (p)) &
& /(energy (p) - longitudinal_part (p)))
end function rapidity_vector4
@ %def rapidity
@ The pseudorapidity (defined if $p_\perp>0$)
<<Lorentz: public functions>>=
public :: pseudorapidity
<<Lorentz: interfaces>>=
interface pseudorapidity
module procedure pseudorapidity_vector4
end interface
<<Lorentz: procedures>>=
elemental function pseudorapidity_vector4 (p) result (eta)
real(default) :: eta
type(vector4_t), intent(in) :: p
eta = -log( tan (.5 * polar_angle (p)))
end function pseudorapidity_vector4
@ %def pseudorapidity
@ The rapidity distance (defined if both $p_\perp>0$)
<<Lorentz: public functions>>=
public :: rapidity_distance
<<Lorentz: interfaces>>=
interface rapidity_distance
module procedure rapidity_distance_vector4
end interface
<<Lorentz: procedures>>=
elemental function rapidity_distance_vector4 (p, q) result (dy)
type(vector4_t), intent(in) :: p, q
real(default) :: dy
dy = rapidity (q) - rapidity (p)
end function rapidity_distance_vector4
@ %def rapidity_distance
@ The pseudorapidity distance (defined if both $p_\perp>0$)
<<Lorentz: public functions>>=
public :: pseudorapidity_distance
<<Lorentz: interfaces>>=
interface pseudorapidity_distance
module procedure pseudorapidity_distance_vector4
end interface
<<Lorentz: procedures>>=
elemental function pseudorapidity_distance_vector4 (p, q) result (deta)
real(default) :: deta
type(vector4_t), intent(in) :: p, q
deta = pseudorapidity (q) - pseudorapidity (p)
end function pseudorapidity_distance_vector4
@ %def pseudorapidity_distance
@ The distance on the $\eta-\phi$ cylinder:
<<Lorentz: public functions>>=
public :: eta_phi_distance
<<Lorentz: interfaces>>=
interface eta_phi_distance
module procedure eta_phi_distance_vector4
end interface
<<Lorentz: procedures>>=
elemental function eta_phi_distance_vector4 (p, q) result (dr)
type(vector4_t), intent(in) :: p, q
real(default) :: dr
dr = sqrt ( &
pseudorapidity_distance (p, q)**2 &
+ azimuthal_distance (p, q)**2)
end function eta_phi_distance_vector4
@ %def eta_phi_distance
@
\subsection{Lorentz transformations}
<<Lorentz: public>>=
public :: lorentz_transformation_t
<<Lorentz: types>>=
type :: lorentz_transformation_t
private
real(default), dimension(0:3, 0:3) :: L
contains
<<Lorentz: lorentz transformation: TBP>>
end type lorentz_transformation_t
@ %def lorentz_transformation_t
@ Output:
<<Lorentz: public>>=
public :: lorentz_transformation_write
<<Lorentz: lorentz transformation: TBP>>=
procedure :: write => lorentz_transformation_write
<<Lorentz: procedures>>=
subroutine lorentz_transformation_write (L, unit, testflag, ultra)
class(lorentz_transformation_t), intent(in) :: L
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag, ultra
integer :: u, i
logical :: ult
character(len=7) :: fmt
ult = .false.; if (present (ultra)) ult = ultra
if (ult) then
call pac_fmt (fmt, FMT_19, FMT_11, ultra)
else
call pac_fmt (fmt, FMT_19, FMT_13, testflag)
end if
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A,3(1x," // fmt // "))") "L00 = ", L%L(0,0)
write (u, "(1x,A,3(1x," // fmt // "))") "L0j = ", L%L(0,1:3)
do i = 1, 3
write (u, "(1x,A,I0,A,3(1x," // fmt // "))") &
"L", i, "0 = ", L%L(i,0)
write (u, "(1x,A,I0,A,3(1x," // fmt // "))") &
"L", i, "j = ", L%L(i,1:3)
end do
end subroutine lorentz_transformation_write
@ %def lorentz_transformation_write
@ Extract all components:
<<Lorentz: public>>=
public :: lorentz_transformation_get_components
<<Lorentz: procedures>>=
pure function lorentz_transformation_get_components (L) result (a)
type(lorentz_transformation_t), intent(in) :: L
real(default), dimension(0:3,0:3) :: a
a = L%L
end function lorentz_transformation_get_components
@ %def lorentz_transformation_get_components
@
\subsection{Functions of Lorentz transformations}
For the inverse, we make use of the fact that
$\Lambda^{\mu\nu}\Lambda_{\mu\rho}=\delta^\nu_\rho$. So, lowering the
indices and transposing is sufficient.
<<Lorentz: public functions>>=
public :: inverse
<<Lorentz: interfaces>>=
interface inverse
module procedure lorentz_transformation_inverse
end interface
<<Lorentz: procedures>>=
elemental function lorentz_transformation_inverse (L) result (IL)
type(lorentz_transformation_t) :: IL
type(lorentz_transformation_t), intent(in) :: L
IL%L(0,0) = L%L(0,0)
IL%L(0,1:) = -L%L(1:,0)
IL%L(1:,0) = -L%L(0,1:)
IL%L(1:,1:) = transpose(L%L(1:,1:))
end function lorentz_transformation_inverse
@ %def lorentz_transformation_inverse
@ %def inverse
@
\subsection{Invariants}
These are used below. The first array index is varying fastest in
[[FORTRAN]]; therefore the extra minus in the odd-rank tensor
epsilon.
<<Lorentz: parameters>>=
integer, dimension(3,3), parameter :: delta_three = &
& reshape( source = [ 1,0,0, 0,1,0, 0,0,1 ], &
& shape = [3,3] )
integer, dimension(3,3,3), parameter :: epsilon_three = &
& reshape( source = [ 0, 0,0, 0,0,-1, 0,1,0, &
& 0, 0,1, 0,0, 0, -1,0,0, &
& 0,-1,0, 1,0, 0, 0,0,0 ],&
& shape = [3,3,3] )
@ %def delta_three epsilon_three
@ This could be of some use:
<<Lorentz: public>>=
public :: identity
<<Lorentz: parameters>>=
type(lorentz_transformation_t), parameter :: &
& identity = &
& lorentz_transformation_t ( &
& reshape( source = [ one, zero, zero, zero, &
& zero, one, zero, zero, &
& zero, zero, one, zero, &
& zero, zero, zero, one ],&
& shape = [4,4] ) )
@ %def identity
<<Lorentz: public>>=
public :: space_reflection
<<Lorentz: parameters>>=
type(lorentz_transformation_t), parameter :: &
& space_reflection = &
& lorentz_transformation_t ( &
& reshape( source = [ one, zero, zero, zero, &
& zero,-one, zero, zero, &
& zero, zero,-one, zero, &
& zero, zero, zero,-one ],&
& shape = [4,4] ) )
@ %def space_reflection
@ Builds a unit vector orthogal to the input vector in the xy-plane.
<<Lorentz: public functions>>=
public :: create_orthogonal
<<Lorentz: procedures>>=
function create_orthogonal (p_in) result (p_out)
type(vector3_t), intent(in) :: p_in
type(vector3_t) :: p_out
real(default) :: ab
ab = sqrt (p_in%p(1)**2 + p_in%p(2)**2)
if (abs (ab) < eps0) then
p_out%p(1) = 1
p_out%p(2) = 0
p_out%p(3) = 0
else
p_out%p(1) = p_in%p(2)
p_out%p(2) = -p_in%p(1)
p_out%p(3) = 0
p_out = p_out / ab
end if
end function create_orthogonal
@ %def create_orthogonal
@
<<Lorentz: public functions>>=
public :: create_unit_vector
<<Lorentz: procedures>>=
function create_unit_vector (p_in) result (p_out)
type(vector4_t), intent(in) :: p_in
type(vector3_t) :: p_out
p_out%p = p_in%p(1:3) / space_part_norm (p_in)
end function create_unit_vector
@ %def create_unit_vector
@
<<Lorentz: public functions>>=
public :: normalize
<<Lorentz: procedures>>=
function normalize(p) result (p_norm)
type(vector3_t) :: p_norm
type(vector3_t), intent(in) :: p
real(default) :: abs
abs = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2)
p_norm = p / abs
end function normalize
@ %def normalize
@ Computes the invariant mass of the momenta sum given by the indices in
[[i_res_born]] and the optional argument [[i_emitter]].
<<Lorentz: public>>=
public :: compute_resonance_mass
<<Lorentz: procedures>>=
pure function compute_resonance_mass (p, i_res_born, i_gluon) result (m)
real(default) :: m
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), dimension(:) :: i_res_born
integer, intent(in), optional :: i_gluon
type(vector4_t) :: p_res
p_res = get_resonance_momentum (p, i_res_born, i_gluon)
m = p_res**1
end function compute_resonance_mass
@ %def compute_resonance_mass
@
<<Lorentz: public>>=
public :: get_resonance_momentum
<<Lorentz: procedures>>=
pure function get_resonance_momentum (p, i_res_born, i_gluon) result (p_res)
type(vector4_t) :: p_res
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), dimension(:) :: i_res_born
integer, intent(in), optional :: i_gluon
integer :: i
p_res = vector4_null
do i = 1, size (i_res_born)
p_res = p_res + p (i_res_born(i))
end do
if (present (i_gluon)) p_res = p_res + p (i_gluon)
end function get_resonance_momentum
@ %def get_resonance_momentum
@
<<Lorentz: public>>=
public :: create_two_particle_decay
<<Lorentz: procedures>>=
function create_two_particle_decay (s, p1, p2) result (p_rest)
type(vector4_t), dimension(3) :: p_rest
real(default), intent(in) :: s
type(vector4_t), intent(in) :: p1, p2
real(default) :: m1_sq, m2_sq
real(default) :: E1, E2, p
m1_sq = p1**2; m2_sq = p2**2
p = sqrt (lambda (s, m1_sq, m2_sq)) / (two * sqrt (s))
E1 = sqrt (m1_sq + p**2); E2 = sqrt (m2_sq + p**2)
p_rest(1)%p = [sqrt (s), zero, zero, zero]
p_rest(2)%p(0) = E1
p_rest(2)%p(1:3) = p * p1%p(1:3) / space_part_norm (p1)
p_rest(3)%p(0) = E2; p_rest(3)%p(1:3) = -p_rest(2)%p(1:3)
end function create_two_particle_decay
@ %def create_two_particle_decay
@ This function creates a phase-space point for a $1 \to 3$ decay in
the decaying particle's rest frame. There are three rest frames for
this system, corresponding to $s$-, $t$,- and $u$-channel momentum
exchange, also referred to as Gottfried-Jackson frames. Below, we choose
the momentum with index 1 to be aligned along the $z$-axis. We then
have
\begin{align*}
s_1 &= \left(p_1 + p_2\right)^2, \\
s_2 &= \left(p_2 + p_3\right)^2, \\
s_3 &= \left(p_1 + p_3\right)^2, \\
s_1 + s_2 + s_3 &= s + m_1^2 + m_2^2 + m_3^2.
\end{align*}
From these we can construct
\begin{align*}
E_1^{R23} = \frac{s - s_2 - m_1^2}{2\sqrt{s_2}} &\quad P_1^{R23} = \frac{\lambda^{1/2}(s, s_2, m_1^2)}{2\sqrt{s_2}},\\
E_2^{R23} = \frac{s_2 + m_2^2 - m_3^2}{2\sqrt{s_2}} &\quad P_2^{R23} = \frac{\lambda^{1/2}(s_2, m_2^2, m_3^2)}{2\sqrt{s_2}},\\
E_3^{R23} = \frac{s_2 + m_3^2 - m_2^2}{2\sqrt{s_2}} &\quad P_3^{R23} = P_2^{R23},
\end{align*}
where $R23$ denotes the Gottfried-Jackson frame of our choice. Finally, the scattering angle $\theta_{12}^{R23}$ between
momentum $1$ and $2$ can be determined to be
\begin{equation*}
\cos\theta_{12}^{R23} = \frac{(s - s_2 - m_1^2)(s_2 + m_2^2 - m_3^2) + 2s_2 (m_1^2 + m_2^2 - s_1)}
{\lambda^{1/2}(s, s_2, m_1^2) \lambda^{1/2}(s_2, m_2^2, m_3^2)}
\end{equation*}
<<Lorentz: public>>=
public :: create_three_particle_decay
<<Lorentz: procedures>>=
function create_three_particle_decay (p1, p2, p3) result (p_rest)
type(vector4_t), dimension(4) :: p_rest
type(vector4_t), intent(in) :: p1, p2, p3
real(default) :: E1, E2, E3
real(default) :: pr1, pr2, pr3
real(default) :: s, s1, s2, s3
real(default) :: m1_sq, m2_sq, m3_sq
real(default) :: cos_theta_12
type(vector3_t) :: v3_unit
type(lorentz_transformation_t) :: rot
m1_sq = p1**2
m2_sq = p2**2
m3_sq = p3**2
s1 = (p1 + p2)**2
s2 = (p2 + p3)**2
s3 = (p3 + p1)**2
s = s1 + s2 + s3 - m1_sq - m2_sq - m3_sq
E1 = (s - s2 - m1_sq) / (two * sqrt (s2))
E2 = (s2 + m2_sq - m3_sq) / (two * sqrt (s2))
E3 = (s2 + m3_sq - m2_sq) / (two * sqrt (s2))
pr1 = sqrt (lambda (s, s2, m1_sq)) / (two * sqrt (s2))
pr2 = sqrt (lambda (s2, m2_sq, m3_sq)) / (two * sqrt(s2))
pr3 = pr2
cos_theta_12 = ((s - s2 - m1_sq) * (s2 + m2_sq - m3_sq) + two * s2 * (m1_sq + m2_sq - s1)) / &
sqrt (lambda (s, s2, m1_sq) * lambda (s2, m2_sq, m3_sq))
v3_unit%p = [zero, zero, one]
p_rest(1)%p(0) = E1
p_rest(1)%p(1:3) = v3_unit%p * pr1
p_rest(2)%p(0) = E2
p_rest(2)%p(1:3) = v3_unit%p * pr2
p_rest(3)%p(0) = E3
p_rest(3)%p(1:3) = v3_unit%p * pr3
p_rest(4)%p(0) = (s + s2 - m1_sq) / (2 * sqrt (s2))
p_rest(4)%p(1:3) = - p_rest(1)%p(1:3)
rot = rotation (cos_theta_12, sqrt (one - cos_theta_12**2), 2)
p_rest(2) = rot * p_rest(2)
p_rest(3)%p(1:3) = - p_rest(2)%p(1:3)
end function create_three_particle_decay
@ %def create_three_particle_decay
@
<<Lorentz: public>>=
public :: evaluate_one_to_two_splitting_special
<<Lorentz: interfaces>>=
abstract interface
subroutine evaluate_one_to_two_splitting_special (p_origin, &
p1_in, p2_in, p1_out, p2_out, msq_in, jac)
import
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
end subroutine evaluate_one_to_two_splitting_special
end interface
@ %def evaluate_one_to_two_splitting_special
@
<<Lorentz: public>>=
public :: generate_on_shell_decay
<<Lorentz: procedures>>=
recursive subroutine generate_on_shell_decay (p_dec, &
p_in, p_out, i_real, msq_in, jac, evaluate_special)
type(vector4_t), intent(in) :: p_dec
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(inout), dimension(:) :: p_out
integer, intent(in) :: i_real
real(default), intent(in), optional :: msq_in
real(default), intent(inout), optional :: jac
procedure(evaluate_one_to_two_splitting_special), intent(in), &
pointer, optional :: evaluate_special
type(vector4_t) :: p_dec_new
integer :: n_recoil
n_recoil = size (p_in) - 1
if (n_recoil > 1) then
if (present (evaluate_special)) then
call evaluate_special (p_dec, p_in(1), sum (p_in (2 : n_recoil + 1)), &
p_out(i_real), p_dec_new)
call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, &
i_real + 1, msq_in, jac, evaluate_special)
else
call evaluate_one_to_two_splitting (p_dec, p_in(1), &
sum (p_in (2 : n_recoil + 1)), p_out(i_real), p_dec_new, msq_in, jac)
call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, &
i_real + 1, msq_in, jac)
end if
else
call evaluate_one_to_two_splitting (p_dec, p_in(1), p_in(2), &
p_out(i_real), p_out(i_real + 1), msq_in, jac)
end if
end subroutine generate_on_shell_decay
subroutine evaluate_one_to_two_splitting (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) :: m, msq, msq1, msq2
real(default) :: E1, E2, p
real(default) :: lda, rlda_soft
call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest)
msq = p_origin**2; m = sqrt(msq)
msq1 = p1_in**2; msq2 = p2_in**2
lda = lambda (msq, msq1, msq2)
if (lda < zero) then
print *, 'Encountered lambda < 0 in 1 -> 2 splitting! '
print *, 'lda: ', lda
print *, 'm: ', m, 'msq: ', msq
print *, 'm1: ', sqrt (msq1), 'msq1: ', msq1
print *, 'm2: ', sqrt (msq2), 'msq2: ', msq2
stop
end if
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
if (present (jac) .and. present (msq_in)) then
jac = jac * sqrt(lda) / msq
rlda_soft = sqrt (lambda (msq_in, msq1, msq2))
!!! We have to undo the Jacobian which has already been
!!! supplied by the Born phase space.
jac = jac * msq_in / rlda_soft
end if
contains
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
end subroutine evaluate_one_to_two_splitting
@ %def generate_on_shell_decay
@
\subsection{Boosts}
We build Lorentz transformations from boosts and rotations. In both
cases we can supply a three-vector which defines the axis and (hyperbolic)
angle. For a boost, this is the vector $\vec\beta=\vec p/E$,
such that a particle at rest with mass $m$ is boosted to a particle
with three-vector $\vec p$. Here, we have
\begin{equation}
\beta = \tanh\chi = p/E, \qquad
\gamma = \cosh\chi = E/m, \qquad
\beta\gamma = \sinh\chi = p/m
\end{equation}
<<Lorentz: public functions>>=
public :: boost
<<Lorentz: interfaces>>=
interface boost
module procedure boost_from_rest_frame
module procedure boost_from_rest_frame_vector3
module procedure boost_generic
module procedure boost_canonical
end interface
@ %def boost
@ In the first form, the argument is some four-momentum, the space
part of which determines a direction, and the associated mass (which
is not checked against the four-momentum). The boost vector
$\gamma\vec\beta$ is then given by $\vec p/m$. This boosts from the
rest frame of a particle to the current frame. To be explicit, if
$\vec p$ is the momentum of a particle and $m$ its mass, $L(\vec p/m)$
is the transformation that turns $(m;\vec 0)$ into $(E;\vec p)$.
Conversely, the inverse transformation boosts a vector \emph{into} the
rest frame of a particle, in particular $(E;\vec p)$ into $(m;\vec
0)$.
<<Lorentz: procedures>>=
elemental function boost_from_rest_frame (p, m) result (L)
type(lorentz_transformation_t) :: L
type(vector4_t), intent(in) :: p
real(default), intent(in) :: m
L = boost_from_rest_frame_vector3 (space_part (p), m)
end function boost_from_rest_frame
elemental function boost_from_rest_frame_vector3 (p, m) result (L)
type(lorentz_transformation_t) :: L
type(vector3_t), intent(in) :: p
real(default), intent(in) :: m
type(vector3_t) :: beta_gamma
real(default) :: bg2, g, c
integer :: i,j
if (m > eps0) then
beta_gamma = p / m
bg2 = beta_gamma**2
else
bg2 = 0
L = identity
return
end if
if (bg2 > eps0) then
g = sqrt(1 + bg2); c = (g-1)/bg2
else
g = one + bg2 / two
c = one / two
end if
L%L(0,0) = g
L%L(0,1:) = beta_gamma%p
L%L(1:,0) = L%L(0,1:)
do i=1,3
do j=1,3
L%L(i,j) = delta_three(i,j) + c*beta_gamma%p(i)*beta_gamma%p(j)
end do
end do
end function boost_from_rest_frame_vector3
@ %def boost_from_rest_frame
@ A canonical boost is a boost along one of the coordinate axes, which
we may supply as an integer argument. Here, $\gamma\beta$ is scalar.
<<Lorentz: procedures>>=
elemental function boost_canonical (beta_gamma, k) result (L)
type(lorentz_transformation_t) :: L
real(default), intent(in) :: beta_gamma
integer, intent(in) :: k
real(default) :: g
g = sqrt(1 + beta_gamma**2)
L = identity
L%L(0,0) = g
L%L(0,k) = beta_gamma
L%L(k,0) = L%L(0,k)
L%L(k,k) = L%L(0,0)
end function boost_canonical
@ %def boost_canonical
@ Instead of a canonical axis, we can supply an arbitrary axis which
need not be normalized. If it is zero, return the unit matrix.
<<Lorentz: procedures>>=
elemental function boost_generic (beta_gamma, axis) result (L)
type(lorentz_transformation_t) :: L
real(default), intent(in) :: beta_gamma
type(vector3_t), intent(in) :: axis
if (any (abs (axis%p) > 0)) then
L = boost_from_rest_frame_vector3 (beta_gamma * axis, axis**1)
else
L = identity
end if
end function boost_generic
@ %def boost_generic
@
\subsection{Rotations}
For a rotation, the vector defines the rotation axis, and its length
the rotation angle. All of these rotations rotate counterclockwise
in a right-handed coordinate system.
<<Lorentz: public functions>>=
public :: rotation
<<Lorentz: interfaces>>=
interface rotation
module procedure rotation_generic
module procedure rotation_canonical
module procedure rotation_generic_cs
module procedure rotation_canonical_cs
end interface
@ %def rotation
@ If $\cos\phi$ and $\sin\phi$ is already known, we do not have to
calculate them. Of course, the user has to ensure that
$\cos^2\phi+\sin^2\phi=1$, and that the given axis [[n]] is normalized to
one. In the second form, the length of [[axis]] is the rotation
angle.
<<Lorentz: procedures>>=
elemental function rotation_generic_cs (cp, sp, axis) result (R)
type(lorentz_transformation_t) :: R
real(default), intent(in) :: cp, sp
type(vector3_t), intent(in) :: axis
integer :: i,j
R = identity
do i=1,3
do j=1,3
R%L(i,j) = cp*delta_three(i,j) + (1-cp)*axis%p(i)*axis%p(j) &
& - sp*dot_product(epsilon_three(i,j,:), axis%p)
end do
end do
end function rotation_generic_cs
elemental function rotation_generic (axis) result (R)
type(lorentz_transformation_t) :: R
type(vector3_t), intent(in) :: axis
real(default) :: phi
if (any (abs(axis%p) > 0)) then
phi = abs(axis**1)
R = rotation_generic_cs (cos(phi), sin(phi), axis/phi)
else
R = identity
end if
end function rotation_generic
@ %def rotation_generic_cs rotation_generic
@ Alternatively, give just the angle and label the coordinate axis by
an integer.
<<Lorentz: procedures>>=
elemental function rotation_canonical_cs (cp, sp, k) result (R)
type(lorentz_transformation_t) :: R
real(default), intent(in) :: cp, sp
integer, intent(in) :: k
integer :: i,j
R = identity
do i=1,3
do j=1,3
R%L(i,j) = -sp*epsilon_three(i,j,k)
end do
R%L(i,i) = cp
end do
R%L(k,k) = 1
end function rotation_canonical_cs
elemental function rotation_canonical (phi, k) result (R)
type(lorentz_transformation_t) :: R
real(default), intent(in) :: phi
integer, intent(in) :: k
R = rotation_canonical_cs(cos(phi), sin(phi), k)
end function rotation_canonical
@ %def rotation_canonical_cs rotation_canonical
@
This is viewed as a method for the first argument (three-vector):
Reconstruct the rotation that rotates it into the second three-vector.
<<Lorentz: public functions>>=
public :: rotation_to_2nd
<<Lorentz: interfaces>>=
interface rotation_to_2nd
module procedure rotation_to_2nd_generic
module procedure rotation_to_2nd_canonical
end interface
<<Lorentz: procedures>>=
elemental function rotation_to_2nd_generic (p, q) result (R)
type(lorentz_transformation_t) :: R
type(vector3_t), intent(in) :: p, q
type(vector3_t) :: a, b, ab
real(default) :: ct, st
if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then
a = direction (p)
b = direction (q)
ab = cross_product(a,b)
ct = a * b; st = ab**1
if (abs(st) > eps0) then
R = rotation_generic_cs (ct, st, ab / st)
else if (ct < 0) then
R = space_reflection
else
R = identity
end if
else
R = identity
end if
end function rotation_to_2nd_generic
@ %def rotation_to_2nd_generic
@
The same for a canonical axis: The function returns the transformation that
rotates the $k$-axis into the direction of $p$.
<<Lorentz: procedures>>=
elemental function rotation_to_2nd_canonical (k, p) result (R)
type(lorentz_transformation_t) :: R
integer, intent(in) :: k
type(vector3_t), intent(in) :: p
type(vector3_t) :: b, ab
real(default) :: ct, st
integer :: i, j
if (any (abs (p%p) > 0)) then
b = direction (p)
ab%p = 0
do i = 1, 3
do j = 1, 3
ab%p(j) = ab%p(j) + b%p(i) * epsilon_three(i,j,k)
end do
end do
ct = b%p(k); st = ab**1
if (abs(st) > eps0) then
R = rotation_generic_cs (ct, st, ab / st)
else if (ct < 0) then
R = space_reflection
else
R = identity
end if
else
R = identity
end if
end function rotation_to_2nd_canonical
@ %def rotation_to_2nd_canonical
@
\subsection{Composite Lorentz transformations}
This function returns the transformation that, given a pair of vectors
$p_{1,2}$, (a) boosts from the rest frame of the c.m. system (with
invariant mass $m$) into the lab frame where $p_i$ are defined, and
(b) turns the given axis (or the canonical vectors $\pm
e_k$) in the rest frame into the directions of $p_{1,2}$ in the lab frame.
Note that the energy components are not used; for a
consistent result one should have $(p_1+p_2)^2 = m^2$.
<<Lorentz: public functions>>=
public :: transformation
<<Lorentz: interfaces>>=
interface transformation
module procedure transformation_rec_generic
module procedure transformation_rec_canonical
end interface
@ %def transformation
<<Lorentz: procedures>>=
elemental function transformation_rec_generic (axis, p1, p2, m) result (L)
type(vector3_t), intent(in) :: axis
type(vector4_t), intent(in) :: p1, p2
real(default), intent(in) :: m
type(lorentz_transformation_t) :: L
L = boost (p1 + p2, m)
L = L * rotation_to_2nd (axis, space_part (inverse (L) * p1))
end function transformation_rec_generic
elemental function transformation_rec_canonical (k, p1, p2, m) result (L)
integer, intent(in) :: k
type(vector4_t), intent(in) :: p1, p2
real(default), intent(in) :: m
type(lorentz_transformation_t) :: L
L = boost (p1 + p2, m)
L = L * rotation_to_2nd (k, space_part (inverse (L) * p1))
end function transformation_rec_canonical
@ %def transformation_rec_generic transformation_rec_canonical
@
\subsection{Applying Lorentz transformations}
Multiplying vectors and Lorentz transformations is straightforward.
<<Lorentz: interfaces>>=
interface operator(*)
module procedure prod_LT_vector4
module procedure prod_LT_LT
module procedure prod_vector4_LT
end interface
<<Lorentz: procedures>>=
elemental function prod_LT_vector4 (L, p) result (np)
type(vector4_t) :: np
type(lorentz_transformation_t), intent(in) :: L
type(vector4_t), intent(in) :: p
np%p = matmul (L%L, p%p)
end function prod_LT_vector4
elemental function prod_LT_LT (L1, L2) result (NL)
type(lorentz_transformation_t) :: NL
type(lorentz_transformation_t), intent(in) :: L1,L2
NL%L = matmul (L1%L, L2%L)
end function prod_LT_LT
elemental function prod_vector4_LT (p, L) result (np)
type(vector4_t) :: np
type(vector4_t), intent(in) :: p
type(lorentz_transformation_t), intent(in) :: L
np%p = matmul (p%p, L%L)
end function prod_vector4_LT
@ %def *
@
\subsection{Special Lorentz transformations}
These routines have their application in the generation and extraction
of angles in the phase-space sampling routine. Since this part of the
program is time-critical, we calculate the composition of
transformations directly instead of multiplying rotations and boosts.
This Lorentz transformation is the composition of a rotation by $\phi$
around the $3$ axis, a rotation by $\theta$ around the $2$ axis, and a
boost along the $3$ axis:
\begin{equation}
L = B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)
\end{equation}
Instead of the angles we provide sine and cosine.
<<Lorentz: public functions>>=
public :: LT_compose_r3_r2_b3
<<Lorentz: procedures>>=
elemental function LT_compose_r3_r2_b3 &
(cp, sp, ct, st, beta_gamma) result (L)
type(lorentz_transformation_t) :: L
real(default), intent(in) :: cp, sp, ct, st, beta_gamma
real(default) :: gamma
if (abs(beta_gamma) < eps0) then
L%L(0,0) = 1
L%L(1:,0) = 0
L%L(0,1:) = 0
L%L(1,1:) = [ ct*cp, -ct*sp, st ]
L%L(2,1:) = [ sp, cp, zero ]
L%L(3,1:) = [ -st*cp, st*sp, ct ]
else
gamma = sqrt(1 + beta_gamma**2)
L%L(0,0) = gamma
L%L(1,0) = 0
L%L(2,0) = 0
L%L(3,0) = beta_gamma
L%L(0,1:) = beta_gamma * [ -st*cp, st*sp, ct ]
L%L(1,1:) = [ ct*cp, -ct*sp, st ]
L%L(2,1:) = [ sp, cp, zero ]
L%L(3,1:) = gamma * [ -st*cp, st*sp, ct ]
end if
end function LT_compose_r3_r2_b3
@ %def LT_compose_r3_r2_b3
@ Different ordering:
\begin{equation}
L = B_3(\beta\gamma)\,R_3(\phi)\,R_2(\theta)
\end{equation}
<<Lorentz: public functions>>=
public :: LT_compose_r2_r3_b3
<<Lorentz: procedures>>=
elemental function LT_compose_r2_r3_b3 &
(ct, st, cp, sp, beta_gamma) result (L)
type(lorentz_transformation_t) :: L
real(default), intent(in) :: ct, st, cp, sp, beta_gamma
real(default) :: gamma
if (abs(beta_gamma) < eps0) then
L%L(0,0) = 1
L%L(1:,0) = 0
L%L(0,1:) = 0
L%L(1,1:) = [ ct*cp, -sp, st*cp ]
L%L(2,1:) = [ ct*sp, cp, st*sp ]
L%L(3,1:) = [ -st , zero, ct ]
else
gamma = sqrt(1 + beta_gamma**2)
L%L(0,0) = gamma
L%L(1,0) = 0
L%L(2,0) = 0
L%L(3,0) = beta_gamma
L%L(0,1:) = beta_gamma * [ -st , zero, ct ]
L%L(1,1:) = [ ct*cp, -sp, st*cp ]
L%L(2,1:) = [ ct*sp, cp, st*sp ]
L%L(3,1:) = gamma * [ -st , zero, ct ]
end if
end function LT_compose_r2_r3_b3
@ %def LT_compose_r2_r3_b3
@ This function returns the previous Lorentz transformation applied to
an arbitrary four-momentum and extracts the space part of the result:
\begin{equation}
\vec n = [B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)\,p]_{\rm space\ part}
\end{equation}
The second variant applies if there is no rotation
<<Lorentz: public functions>>=
public :: axis_from_p_r3_r2_b3, axis_from_p_b3
<<Lorentz: procedures>>=
elemental function axis_from_p_r3_r2_b3 &
(p, cp, sp, ct, st, beta_gamma) result (n)
type(vector3_t) :: n
type(vector4_t), intent(in) :: p
real(default), intent(in) :: cp, sp, ct, st, beta_gamma
real(default) :: gamma, px, py
px = cp * p%p(1) - sp * p%p(2)
py = sp * p%p(1) + cp * p%p(2)
n%p(1) = ct * px + st * p%p(3)
n%p(2) = py
n%p(3) = -st * px + ct * p%p(3)
if (abs(beta_gamma) > eps0) then
gamma = sqrt(1 + beta_gamma**2)
n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma
end if
end function axis_from_p_r3_r2_b3
elemental function axis_from_p_b3 (p, beta_gamma) result (n)
type(vector3_t) :: n
type(vector4_t), intent(in) :: p
real(default), intent(in) :: beta_gamma
real(default) :: gamma
n%p = p%p(1:3)
if (abs(beta_gamma) > eps0) then
gamma = sqrt(1 + beta_gamma**2)
n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma
end if
end function axis_from_p_b3
@ %def axis_from_p_r3_r2_b3 axis_from_p_b3
@
\subsection{Special functions}
The K\"all\'en function, mostly used for the phase space.
This is equivalent to $\lambda(x,y,z)=x^2+y^2+z^2-2xy-2xz-2yz$.
<<Lorentz: public functions>>=
public :: lambda
<<Lorentz: procedures>>=
elemental function lambda (m1sq, m2sq, m3sq)
real(default) :: lambda
real(default), intent(in) :: m1sq, m2sq, m3sq
lambda = (m1sq - m2sq - m3sq)**2 - 4*m2sq*m3sq
end function lambda
@ %def lambda
@ Return a pair of head-to-head colliding momenta, given the collider
energy, particle masses, and optionally the momentum of the
c.m. system.
<<Lorentz: public functions>>=
public :: colliding_momenta
<<Lorentz: procedures>>=
function colliding_momenta (sqrts, m, p_cm) result (p)
type(vector4_t), dimension(2) :: p
real(default), intent(in) :: sqrts
real(default), dimension(2), intent(in), optional :: m
real(default), intent(in), optional :: p_cm
real(default), dimension(2) :: dmsq
real(default) :: ch, sh
real(default), dimension(2) :: E0, p0
integer, dimension(2), parameter :: sgn = [1, -1]
if (abs(sqrts) < eps0) then
call msg_fatal (" Colliding beams: sqrts is zero (please set sqrts)")
p = vector4_null; return
else if (sqrts <= 0) then
call msg_fatal (" Colliding beams: sqrts is negative")
p = vector4_null; return
end if
if (present (m)) then
dmsq = sgn * (m(1)**2-m(2)**2)
E0 = (sqrts + dmsq/sqrts) / 2
if (any (E0 < m)) then
call msg_fatal &
(" Colliding beams: beam energy is less than particle mass")
p = vector4_null; return
end if
p0 = sgn * sqrt (E0**2 - m**2)
else
E0 = sqrts / 2
p0 = sgn * E0
end if
if (present (p_cm)) then
sh = p_cm / sqrts
ch = sqrt (1 + sh**2)
p = vector4_moving (E0 * ch + p0 * sh, E0 * sh + p0 * ch, 3)
else
p = vector4_moving (E0, p0, 3)
end if
end function colliding_momenta
@ %def colliding_momenta
@ This subroutine is for the purpose of numerical checks and
comparisons. The idea is to set a number to zero if it is numerically
equivalent with zero. The equivalence is established by comparing
with a [[tolerance]] argument. We implement this for vectors and
transformations.
<<Lorentz: public functions>>=
public :: pacify
<<Lorentz: interfaces>>=
interface pacify
module procedure pacify_vector3
module procedure pacify_vector4
module procedure pacify_LT
end interface pacify
<<Lorentz: procedures>>=
elemental subroutine pacify_vector3 (p, tolerance)
type(vector3_t), intent(inout) :: p
real(default), intent(in) :: tolerance
where (abs (p%p) < tolerance) p%p = zero
end subroutine pacify_vector3
elemental subroutine pacify_vector4 (p, tolerance)
type(vector4_t), intent(inout) :: p
real(default), intent(in) :: tolerance
where (abs (p%p) < tolerance) p%p = zero
end subroutine pacify_vector4
elemental subroutine pacify_LT (LT, tolerance)
type(lorentz_transformation_t), intent(inout) :: LT
real(default), intent(in) :: tolerance
where (abs (LT%L) < tolerance) LT%L = zero
end subroutine pacify_LT
@ %def pacify
@
<<Lorentz: public>>=
public :: vector_set_reshuffle
<<Lorentz: procedures>>=
subroutine vector_set_reshuffle (p1, list, p2)
type(vector4_t), intent(in), dimension(:), allocatable :: p1
integer, intent(in), dimension(:), allocatable :: list
type(vector4_t), intent(out), dimension(:), allocatable :: p2
integer :: n, n_p
n_p = size (p1)
if (size (list) /= n_p) return
allocate (p2 (n_p))
do n = 1, n_p
p2(n) = p1(list(n))
end do
end subroutine vector_set_reshuffle
@ %def vector_set_reshuffle
@
<<Lorentz: public>>=
public :: vector_set_is_cms
<<Lorentz: procedures>>=
function vector_set_is_cms (p, n_in) result (is_cms)
logical :: is_cms
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: n_in
integer :: i
type(vector4_t) :: p_sum
p_sum%p = 0._default
do i = 1, n_in
p_sum = p_sum + p(i)
end do
is_cms = all (abs (p_sum%p(1:3)) < tiny_07)
end function vector_set_is_cms
@ %def vector_set_is_cms
@
<<Lorentz: public>>=
public :: vector_set_is_lab
<<Lorentz: procedures>>=
function vector_set_is_lab (p, n_in) result (is_lab)
logical :: is_lab
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: n_in
is_lab = .not. vector_set_is_cms (p, n_in)
end function vector_set_is_lab
@ %def vector_set_is_lab
@
<<Lorentz: public>>=
public :: vector4_write_set
<<Lorentz: procedures>>=
subroutine vector4_write_set (p, unit, show_mass, testflag, &
check_conservation, ultra, n_in)
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass
logical, intent(in), optional :: testflag, ultra
logical, intent(in), optional :: check_conservation
integer, intent(in), optional :: n_in
logical :: extreme
integer :: i, j
real(default), dimension(0:3) :: p_tot
character(len=7) :: fmt
integer :: u
logical :: yorn, is_test
integer :: n
extreme = .false.; if (present (ultra)) extreme = ultra
is_test = .false.; if (present (testflag)) is_test = testflag
u = given_output_unit (unit); if (u < 0) return
n = 2; if (present (n_in)) n = n_in
p_tot = 0
yorn = .false.; if (present (check_conservation)) yorn = check_conservation
do i = 1, size (p)
if (yorn .and. i > n) then
forall (j=0:3) p_tot(j) = p_tot(j) - p(i)%p(j)
else
forall (j=0:3) p_tot(j) = p_tot(j) + p(i)%p(j)
end if
call vector4_write (p(i), u, show_mass=show_mass, &
testflag=testflag, ultra=ultra)
end do
if (extreme) then
call pac_fmt (fmt, FMT_19, FMT_11, testflag)
else
call pac_fmt (fmt, FMT_19, FMT_15, testflag)
end if
if (is_test) call pacify (p_tot, 1.E-9_default)
if (.not. is_test) then
write (u, "(A5)") 'Total: '
write (u, "(1x,A,1x," // fmt // ")") "E = ", p_tot(0)
write (u, "(1x,A,3(1x," // fmt // "))") "P = ", p_tot(1:)
end if
end subroutine vector4_write_set
@ %def vector4_write_set
@
<<Lorentz: public>>=
public :: vector4_check_momentum_conservation
<<Lorentz: procedures>>=
subroutine vector4_check_momentum_conservation (p, n_in, unit, &
abs_smallness, rel_smallness, verbose)
type(vector4_t), dimension(:), intent(in) :: p
integer, intent(in) :: n_in
integer, intent(in), optional :: unit
real(default), intent(in), optional :: abs_smallness, rel_smallness
logical, intent(in), optional :: verbose
integer :: u, i
type(vector4_t) :: psum_in, psum_out
logical, dimension(0:3) :: p_diff
logical :: verb
u = given_output_unit (unit); if (u < 0) return
verb = .false.; if (present (verbose)) verb = verbose
psum_in = vector4_null
do i = 1, n_in
psum_in = psum_in + p(i)
end do
psum_out = vector4_null
do i = n_in + 1, size (p)
psum_out = psum_out + p(i)
end do
p_diff = vanishes (psum_in%p - psum_out%p, &
abs_smallness = abs_smallness, rel_smallness = rel_smallness)
if (.not. all (p_diff)) then
call msg_warning ("Momentum conservation: FAIL", unit = u)
if (verb) then
write (u, "(A)") "Incoming:"
call vector4_write (psum_in, u)
write (u, "(A)") "Outgoing:"
call vector4_write (psum_out, u)
end if
else
if (verb) then
write (u, "(A)") "Momentum conservation: CHECK"
end if
end if
end subroutine vector4_check_momentum_conservation
@ %def vector4_check_momentum_conservation
@ This computes the quantities
\begin{align*}
\langle ij \rangle &= \sqrt{|S_{ij}|} e^{i\phi_{ij}},
[ij] &= \sqrt{|S_{ij}|} e^{\i\tilde{\phi}_{ij}},
\end{align*}
with $S_{ij} = \left(p_i + p_j\right)^2$. The phase space factor
$\phi_{ij}$ is determined by
\begin{align*}
\cos\phi_{ij} &= \frac{p_i^1p_j^+ - p_j^1p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}},
\sin\phi_{ij} &= \frac{p_i^2p_j^+ - p_j^2p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}.
\end{align*}
After $\langle ij \rangle$ has been computed according to these
formulae, $[ij]$ can be obtained by using the relation $S_{ij} =
\langle ij \rangle [ji]$ and taking into account that $[ij] =
-[ji]$. Thus, a minus-sign has to be applied.
<<Lorentz: public>>=
public :: spinor_product
<<Lorentz: procedures>>=
subroutine spinor_product (p1, p2, prod1, prod2)
type(vector4_t), intent(in) :: p1, p2
complex(default), intent(out) :: prod1, prod2
real(default) :: sij
complex(default) :: phase
real(default) :: pp_1, pp_2
pp_1 = p1%p(0) + p1%p(3)
pp_2 = p2%p(0) + p2%p(3)
sij = (p1+p2)**2
phase = cmplx ((p1%p(1)*pp_2 - p2%p(1)*pp_1)/sqrt (sij*pp_1*pp_2), &
(p1%p(2)*pp_2 - p2%p(2)*pp_1)/sqrt (sij*pp_1*pp_2), &
default)
!!! <ij>
prod1 = sqrt (sij) * phase
!!! [ij]
if (abs(prod1) > 0) then
prod2 = - sij / prod1
else
prod2 = 0
end if
end subroutine spinor_product
@ %def spinor_product
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Collections of Lorentz Vectors}
The [[phs_point]] type is a container for an array of Lorentz vectors. This
allows us to transfer Lorentz-vector arrays more freely, and to collect vector
arrays of non-uniform size.
<<[[phs_points.f90]]>>=
<<File header>>
module phs_points
<<Use kinds>>
use lorentz, only: vector4_t
use lorentz, only: vector4_null
use lorentz, only: vector4_write_set
use lorentz, only: lorentz_transformation_t
use lorentz, only: operator(==)
use lorentz, only: operator(*)
use lorentz, only: operator(**)
use lorentz, only: sum
<<Standard module head>>
<<PHS points: public>>
<<PHS points: types>>
<<PHS points: interfaces>>
contains
<<PHS points: procedures>>
end module phs_points
@ %def phs_points
@
\subsection{PHS point definition}
This is a trivial container for an array of momenta. The main
application is to store a non-uniform array of phase-space points.
<<PHS points: public>>=
public :: phs_point_t
<<PHS points: types>>=
type :: phs_point_t
private
type(vector4_t), dimension(:), allocatable :: p
contains
<<PHS points: phs point: TBP>>
end type phs_point_t
@ %def phs_point_t
@
\subsection{PHS point: basic tools}
Output. This is instrumented with options, which have to be
provided by the caller.
<<PHS points: phs point: TBP>>=
procedure :: write => phs_point_write
<<PHS points: procedures>>=
subroutine phs_point_write (phs_point, unit, show_mass, testflag, &
check_conservation, ultra, n_in)
class(phs_point_t), intent(in) :: phs_point
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass
logical, intent(in), optional :: testflag, ultra
logical, intent(in), optional :: check_conservation
integer, intent(in), optional :: n_in
if (allocated (phs_point%p)) then
call vector4_write_set (phs_point%p, &
unit = unit, &
show_mass = show_mass, &
testflag = testflag, &
check_conservation = check_conservation, &
ultra = ultra, &
n_in = n_in)
end if
end subroutine phs_point_write
@ %def phs_point_write
@ Non-intrinsic assignment
<<PHS points: public>>=
public :: assignment(=)
<<PHS points: interfaces>>=
interface assignment(=)
module procedure phs_point_from_n
module procedure phs_point_from_vector4
module procedure vector4_from_phs_point
end interface
@ Initialize with zero momenta but fixed size
<<PHS points: procedures>>=
pure subroutine phs_point_from_n (phs_point, n_particles)
type(phs_point_t), intent(out) :: phs_point
integer, intent(in) :: n_particles
allocate (phs_point%p (n_particles), source = vector4_null)
end subroutine phs_point_from_n
@ %def phs_point_init_from_n
@ Transform from/to plain vector array
<<PHS points: procedures>>=
pure subroutine phs_point_from_vector4 (phs_point, p)
type(phs_point_t), intent(out) :: phs_point
type(vector4_t), dimension(:), intent(in) :: p
phs_point%p = p
end subroutine phs_point_from_vector4
pure subroutine vector4_from_phs_point (p, phs_point)
class(phs_point_t), intent(in) :: phs_point
type(vector4_t), dimension(:), allocatable, intent(out) :: p
if (allocated (phs_point%p)) p = phs_point%p
end subroutine vector4_from_phs_point
@ %def phs_point_from_vector4
@ %def vector4_from_phs_point
@ Query the size of the momentum array (assuming it is allocated).
<<PHS points: public>>=
public :: size
<<PHS points: interfaces>>=
interface size
module procedure phs_point_size
end interface size
<<PHS points: procedures>>=
pure function phs_point_size (phs_point) result (s)
class(phs_point_t), intent(in) :: phs_point
integer :: s
if (allocated (phs_point%p)) then
s = size (phs_point%p)
else
s = 0
end if
end function phs_point_size
@ %def phs_point_size
@ Equality, implemented only for valid points.
<<PHS points: public>>=
public :: operator(==)
<<PHS points: interfaces>>=
interface operator(==)
module procedure phs_point_eq
end interface operator(==)
<<PHS points: procedures>>=
elemental function phs_point_eq (phs_point_1, phs_point_2) result (flag)
class(phs_point_t), intent(in) :: phs_point_1, phs_point_2
logical :: flag
if (allocated (phs_point_1%p) .and. (allocated (phs_point_2%p))) then
flag = all (phs_point_1%p == phs_point_2%p)
else
flag = .false.
end if
end function phs_point_eq
@ %def phs_point_eq
@ Extract all momenta, as a method
<<PHS points: phs point: TBP>>=
procedure :: get => phs_point_get
<<PHS points: procedures>>=
pure function phs_point_get (phs_point) result (p)
class(phs_point_t), intent(in) :: phs_point
type(vector4_t), dimension(:), allocatable :: p
if (allocated (phs_point%p)) then
p = phs_point%p
else
allocate (p (0))
end if
end function phs_point_get
@ %def phs_point_select
@ Extract a subset of all momenta.
<<PHS points: phs point: TBP>>=
procedure :: select => phs_point_select
<<PHS points: procedures>>=
elemental function phs_point_select (phs_point, i) result (p)
class(phs_point_t), intent(in) :: phs_point
integer, intent(in) :: i
type(vector4_t) :: p
if (allocated (phs_point%p)) then
p = phs_point%p(i)
else
p = vector4_null
end if
end function phs_point_select
@ %def phs_point_select
@ Return the invariant mass squared for a subset of momenta
<<PHS points: phs point: TBP>>=
procedure :: get_msq => phs_point_get_msq
<<PHS points: procedures>>=
pure function phs_point_get_msq (phs_point, iarray) result (msq)
class(phs_point_t), intent(in) :: phs_point
integer, dimension(:), intent(in) :: iarray
real(default) :: msq
if (allocated (phs_point%p)) then
msq = (sum (phs_point%p(iarray)))**2
else
msq = 0
end if
end function phs_point_get_msq
@ %def phs_point_get_msq
@
\subsection{Lorentz algebra pieces}
Lorentz transformation.
<<PHS points: public>>=
public :: operator(*)
<<PHS points: interfaces>>=
interface operator(*)
module procedure prod_LT_phs_point
end interface operator(*)
<<PHS points: procedures>>=
elemental function prod_LT_phs_point (L, phs_point) result (phs_point_LT)
type(lorentz_transformation_t), intent(in) :: L
type(phs_point_t), intent(in) :: phs_point
type(phs_point_t) :: phs_point_LT
if (allocated (phs_point%p)) phs_point_LT%p = L * phs_point%p
end function prod_LT_phs_point
@ %def prod_LT_phs_point
@ Compute momentum sum, analogous to the standard [[sum]] function
(mask), and additionally using an index array.
<<PHS points: public>>=
public :: sum
<<PHS points: interfaces>>=
interface sum
module procedure phs_point_sum
module procedure phs_point_sum_iarray
end interface sum
<<PHS points: procedures>>=
pure function phs_point_sum (phs_point, mask) result (p)
class(phs_point_t), intent(in) :: phs_point
logical, dimension(:), intent(in), optional :: mask
type(vector4_t) :: p
if (allocated (phs_point%p)) then
p = sum (phs_point%p, mask)
else
p = vector4_null
end if
end function phs_point_sum
pure function phs_point_sum_iarray (phs_point, iarray) result (p)
class(phs_point_t), intent(in) :: phs_point
integer, dimension(:), intent(in) :: iarray
type(vector4_t) :: p
logical, dimension(:), allocatable :: mask
integer :: i
allocate (mask (size (phs_point)), source = .false.)
mask(iarray) = .true.
p = sum (phs_point, mask)
end function phs_point_sum_iarray
@ %def phs_point_sum
@
\subsection{Methods for specific applications}
Convenience method: compute the pair of energy fractions w.r.t.\ the
specified beam energy. We assume that the momenta represent a
scattering process (two incoming particles) in the c.m.\ frame.
<<PHS points: phs point: TBP>>=
procedure :: get_x => phs_point_get_x
<<PHS points: procedures>>=
pure function phs_point_get_x (phs_point, E_beam) result (x)
class(phs_point_t), intent(in) :: phs_point
real(default), dimension(2) :: x
real(default), intent(in) :: E_beam
x = phs_point%p(1:2)%p(0) / E_beam
end function phs_point_get_x
@ %def phs_point_get_x
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_points_ut.f90]]>>=
<<File header>>
module phs_points_ut
use unit_tests
use phs_points_uti
<<Standard module head>>
<<PHS points: public test>>
contains
<<PHS points: test driver>>
end module phs_points_ut
@ %def phs_points_ut
@
<<[[phs_points_uti.f90]]>>=
<<File header>>
module phs_points_uti
<<Use kinds>>
use phs_points
<<Standard module head>>
<<PHS points: test declarations>>
contains
<<PHS points: tests>>
end module phs_points_uti
@ %def phs_points_ut
@ API: driver for the unit tests below.
<<PHS points: public test>>=
public :: phs_points_test
<<PHS points: test driver>>=
subroutine phs_points_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS points: execute tests>>
end subroutine phs_points_test
@ %def phs_points_test
@
\subsubsection{Splitting functions}
<<PHS points: execute tests>>=
call test (phs_points_1, "phs_points_1", &
"Dummy test", &
u, results)
<<PHS points: test declarations>>=
public :: phs_points_1
<<PHS points: tests>>=
subroutine phs_points_1 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: phs_points_1"
write (u, "(A)") "* Purpose: none yet"
write (u, "(A)")
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_points_1"
end subroutine phs_points_1
@ %def phs_points_1
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Special Physics functions}
Here, we declare functions that are specific for the Standard Model,
including QCD: fixed and running $\alpha_s$, Catani-Seymour
dipole terms, loop functions, etc.
To make maximum use of this, all functions, if possible, are declared
elemental (or pure, if this is not possible).
<<[[sm_physics.f90]]>>=
<<File header>>
module sm_physics
<<Use kinds>>
use io_units
use constants
use numeric_utils
use diagnostics
+ use permutations, only: factorial
use physics_defs
use lorentz
<<Standard module head>>
<<SM physics: public>>
<<SM physics: parameters>>
contains
<<SM physics: procedures>>
end module sm_physics
@ %def sm_physics
@
+\subsection{Constants for Quantum Field Theory calculations}
+
+For loop calculations in quantum field theories, one needs the
+numerical values of the Riemann zeta function:
+\begin{align*}
+ \zeta(2) &=\; 1.64493406684822643647241516665\ldots \; \\
+ \zeta(3) &=\; 1.20205690315959428539973816151\ldots \; \\
+ \zeta(4) &=\; 1.08232323371113819151600369654\ldots \; \\
+ \zeta(5) &=\; 1.03692775514336992633136548646\ldots \;
+\end{align*}
+<<SM physics: public>>=
+ public :: zeta2, zeta3, zeta4, zeta5
+<<SM physics: parameters>>=
+ real(default), parameter :: &
+ zeta2 = 1.64493406684822643647241516665_default, &
+ zeta3 = 1.20205690315959428539973816151_default, &
+ zeta4 = 1.08232323371113819151600369654_default, &
+ zeta5 = 1.03692775514336992633136548646_default
+
+@ %def zeta2 zeta3 zeta4
+@ The Euler-Mascheroni constant is
+\begin{equation*}
+ \gamma_E =
+\end{equation*}
+<<SM physics: public>>=
+ public :: eulerc
+<<SM physics: parameters>>=
+ real(default), parameter :: &
+ eulerc =0.5772156649015328606065120900824024310422_default
+
+@ %def eulerc
+@
\subsection{Running $\alpha_s$}
-@ Then we define the coefficients of the beta function of QCD (as a
+
+Then we define the coefficients of the beta function of QCD (as a
reference cf. the Particle Data Group), where $n_f$ is the number of
active flavors in two different schemes:
\begin{align}
\beta_0 &=\; 11 - \frac23 n_f \\
\beta_1 &=\; 51 - \frac{19}{3} n_f \\
\beta_2 &=\; 2857 - \frac{5033}{9} n_f + \frac{325}{27} n_f^2
\end{align}
\begin{align}
b_0 &=\; \frac{1}{12 \pi} \left( 11 C_A - 2 n_f \right) \\
b_1 &=\; \frac{1}{24 \pi^2} \left( 17 C_A^2 - 5 C_A n_f - 3 C_F n_f \right) \\
b_2 &=\; \frac{1}{(4\pi)^3} \biggl( \frac{2857}{54} C_A^3 -
\frac{1415}{54} * C_A^2 n_f - \frac{205}{18} C_A C_F n_f + C_F^2 n_f
+ \frac{79}{54} C_A n_f**2 + \frac{11}{9} C_F n_f**2 \biggr)
\end{align}
The functions [[sumQ2q]] and [[sumQ4q]] provide the sum of the squared
and quartic electric charges of a number [[nf]] of active quark flavors.
<<SM physics: public>>=
public :: beta0, beta1, beta2
public :: coeff_b0, coeff_b1, coeff_b2, coeffqed_b0, coeffqed_b1
public :: sumQ2q, sumQ4q
<<SM physics: procedures>>=
pure function beta0 (nf)
real(default), intent(in) :: nf
real(default) :: beta0
beta0 = 11.0_default - two/three * nf
end function beta0
pure function beta1 (nf)
real(default), intent(in) :: nf
real(default) :: beta1
beta1 = 51.0_default - 19.0_default/three * nf
end function beta1
pure function beta2 (nf)
real(default), intent(in) :: nf
real(default) :: beta2
beta2 = 2857.0_default - 5033.0_default / 9.0_default * &
nf + 325.0_default/27.0_default * nf**2
end function beta2
pure function coeff_b0 (nf)
real(default), intent(in) :: nf
real(default) :: coeff_b0
coeff_b0 = (11.0_default * CA - two * nf) / (12.0_default * pi)
end function coeff_b0
pure function coeff_b1 (nf)
real(default), intent(in) :: nf
real(default) :: coeff_b1
coeff_b1 = (17.0_default * CA**2 - five * CA * nf - three * CF * nf) / &
(24.0_default * pi**2)
end function coeff_b1
pure function coeff_b2 (nf)
real(default), intent(in) :: nf
real(default) :: coeff_b2
coeff_b2 = (2857.0_default/54.0_default * CA**3 - &
1415.0_default/54.0_default * &
CA**2 * nf - 205.0_default/18.0_default * CA*CF*nf &
+ 79.0_default/54.0_default * CA*nf**2 + &
11.0_default/9.0_default * CF * nf**2) / (four*pi)**3
end function coeff_b2
pure function coeffqed_b0 (nf, nlep)
integer, intent(in) :: nf, nlep
real(default) :: n_lep, coeffqed_b0
n_lep = real(nlep, kind=default)
coeffqed_b0 = - (three * sumQ2q (nf) + n_lep) / (three*pi)
end function coeffqed_b0
pure function coeffqed_b1 (nf, nlep)
integer, intent(in) :: nf, nlep
real(default) :: n_lep, coeffqed_b1
n_lep = real(nlep, kind=default)
coeffqed_b1 = - (three * sumQ4q (nf) + n_lep) / (four*pi**2)
end function coeffqed_b1
pure function sumQ2q (nf)
integer, intent(in) :: nf
real(default) :: sumQ2q
select case (nf)
case (0)
sumQ2q = zero
case (1)
sumQ2q = 1.0_default/9.0_default
case (2)
sumQ2q = 5.0_default/9.0_default
case (3)
sumQ2q = 2.0_default/3.0_default
case (4)
sumQ2q = 10.0_default/9.0_default
case (5)
sumQ2q = 11.0_default/9.0_default
case (6:)
sumQ2q = 5.0_default/3.0_default
end select
end function sumQ2q
pure function sumQ4q (nf)
integer, intent(in) :: nf
real(default) :: sumQ4q
select case (nf)
case (0)
sumQ4q = zero
case (1)
sumQ4q = 1.0_default/81.0_default
case (2)
sumQ4q = 17.0_default/81.0_default
case (3)
sumQ4q = 2.0_default/9.0_default
case (4)
sumQ4q = 34.0_default/81.0_default
case (5)
sumQ4q = 35.0_default/81.0_default
case (6:)
sumQ4q = 17.0_default/27.0_default
end select
end function sumQ4q
@ %def beta0 beta1 beta2
@ %def coeff_b0 coeff_b1 coeff_b2 coeffqed_b0 coeffqed_b1
@ %def sumQ2q sumQ4q
@ There should be two versions of running $\alpha_s$, one which takes
the scale and $\Lambda_{\text{QCD}}$ as input, and one which takes the
scale and e.g. $\alpha_s(m_Z)$ as input. Here, we take the one which
takes the QCD scale and scale as inputs from the PDG book.
<<SM physics: public>>=
public :: running_as, running_as_lam, running_alpha, running_alpha_num
<<SM physics: procedures>>=
pure function running_as (scale, al_mz, mz, order, nf) result (ascale)
real(default), intent(in) :: scale
real(default), intent(in), optional :: al_mz, nf, mz
integer, intent(in), optional :: order
integer :: ord
real(default) :: az, m_z, as_log, n_f, b0, b1, b2, ascale
real(default) :: as0, as1
if (present (mz)) then
m_z = mz
else
m_z = MZ_REF
end if
if (present (order)) then
ord = order
else
ord = 0
end if
if (present (al_mz)) then
az = al_mz
else
az = ALPHA_QCD_MZ_REF
end if
if (present (nf)) then
n_f = nf
else
n_f = 5
end if
b0 = coeff_b0 (n_f)
b1 = coeff_b1 (n_f)
b2 = coeff_b2 (n_f)
as_log = one + b0 * az * log(scale**2/m_z**2)
as0 = az / as_log
as1 = as0 - as0**2 * b1/b0 * log(as_log)
select case (ord)
case (0)
ascale = as0
case (1)
ascale = as1
case (2)
ascale = as1 + as0**3 * (b1**2/b0**2 * ((log(as_log))**2 - &
log(as_log) + as_log - one) - b2/b0 * (as_log - one))
case default
ascale = as0
end select
end function running_as
pure function running_as_lam (nf, scale, lambda, order) result (ascale)
real(default), intent(in) :: nf, scale
real(default), intent(in), optional :: lambda
integer, intent(in), optional :: order
real(default) :: lambda_qcd
real(default) :: as0, as1, logmul, b0, b1, b2, ascale
integer :: ord
if (present (lambda)) then
lambda_qcd = lambda
else
lambda_qcd = LAMBDA_QCD_REF
end if
if (present (order)) then
ord = order
else
ord = 0
end if
b0 = beta0(nf)
logmul = log(scale**2/lambda_qcd**2)
as0 = four*pi / b0 / logmul
if (ord > 0) then
b1 = beta1(nf)
as1 = as0 * (one - two* b1 / b0**2 * log(logmul) / logmul)
end if
select case (ord)
case (0)
ascale = as0
case (1)
ascale = as1
case (2)
b2 = beta2(nf)
ascale = as1 + as0 * four * b1**2/b0**4/logmul**2 * &
((log(logmul) - 0.5_default)**2 + &
b2*b0/8.0_default/b1**2 - five/four)
case default
ascale = as0
end select
end function running_as_lam
pure function running_alpha &
(scale, al_me, me, order, nf, nlep) result (ascale)
real(default), intent(in) :: scale
real(default), intent(in), optional :: al_me, me
integer, intent(in), optional :: order, nf, nlep
integer :: ord, n_f, n_lep
real(default) :: ae, m_e, a_log, b0, b1, ascale
real(default) :: a0, a1
if (present (me)) then
m_e = me
else
m_e = ME_REF
end if
if (present (order)) then
ord = order
else
ord = 0
end if
if (present (al_me)) then
ae = al_me
else
ae = ALPHA_QED_ME_REF
end if
if (present (nf)) then
n_f = nf
else
n_f = 5
end if
if (present (nlep)) then
n_lep = nlep
else
n_lep = 1
end if
b0 = coeffqed_b0 (n_f, n_lep)
b1 = coeffqed_b1 (n_f, n_lep)
a_log = one + b0 * ae * log(scale**2/m_e**2)
a0 = ae / a_log
a1 = ae / (a_log + ae * b1/b0 * &
log((a_log + ae * b1/b0)/(one + ae * b1/b0)))
select case (ord)
case (0)
ascale = a0
case (1)
ascale = a1
case default
ascale = a0
end select
end function running_alpha
pure function running_alpha_num &
(scale, al_me, me, order, nf, nlep) result (ascale)
real(default), intent(in) :: scale
real(default), intent(in), optional :: al_me, me
integer, intent(in), optional :: order, nf, nlep
integer, parameter :: n_steps = 20
integer :: ord, n_f, n_lep, k1
real(default), parameter :: sxth = 1._default/6._default
real(default) :: ae, ascale, m_e, log_q, dlr, &
b0, b1, xk0, xk1, xk2, xk3
if (present (order)) then
ord = order
else
ord = 0
end if
if (present (al_me)) then
ae = al_me
else
ae = ALPHA_QED_ME_REF
end if
if (present (me)) then
m_e = me
else
m_e = ME_REF
end if
if (present (nf)) then
n_f = nf
else
n_f = 5
end if
if (present (nlep)) then
n_lep = nlep
else
n_lep = 1
end if
ascale = ae
log_q = log (scale**2/m_e**2)
dlr = log_q / n_steps
b0 = coeffqed_b0 (n_f, n_lep)
b1 = coeffqed_b1 (n_f, n_lep)
! ..Solution of the evolution equation depending on ORD
! (fourth-order Runge-Kutta beyond the leading order)
select case (ord)
case (0)
ascale = ae / (one + b0 * ae * log_q)
case (1:)
do k1 = 1, n_steps
xk0 = dlr * beta_qed (ascale)
xk1 = dlr * beta_qed (ascale + 0.5 * xk0)
xk2 = dlr * beta_qed (ascale + 0.5 * xk1)
xk3 = dlr * beta_qed (ascale + xk2)
ascale = ascale + sxth * (xk0 + 2._default * xk1 + &
2._default * xk2 + xk3)
end do
end select
contains
pure function beta_qed (alpha)
real(default), intent(in) :: alpha
real(default) :: beta_qed
beta_qed = - alpha**2 * (b0 + alpha * b1)
end function beta_qed
end function running_alpha_num
@ %def running_as
@ %def running_as_lam
@ %def running_alpha running_alpha_num
@
\subsection{Catani-Seymour Parameters}
These are fundamental constants of the Catani-Seymour dipole formalism.
Since the corresponding parameters for the gluon case depend on the
number of flavors which is treated as an argument, there we do have
functions and not parameters.
\begin{equation}
\gamma_q = \gamma_{\bar q} = \frac{3}{2} C_F \qquad \gamma_g =
\frac{11}{6} C_A - \frac{2}{3} T_R N_f
\end{equation}
\begin{equation}
K_q = K_{\bar q} = \left( \frac{7}{2} - \frac{\pi^2}{6} \right) C_F \qquad
K_g = \left( \frac{67}{18} - \frac{\pi^2}{6} \right) C_A -
\frac{10}{9} T_R N_f
\end{equation}
<<SM physics: parameters>>=
real(kind=default), parameter, public :: gamma_q = three/two * CF, &
k_q = (7.0_default/two - pi**2/6.0_default) * CF
@ %def gamma_q
@
<<SM physics: public>>=
public :: gamma_g, k_g
<<SM physics: procedures>>=
elemental function gamma_g (nf) result (gg)
real(kind=default), intent(in) :: nf
real(kind=default) :: gg
gg = 11.0_default/6.0_default * CA - two/three * TR * nf
end function gamma_g
elemental function k_g (nf) result (kg)
real(kind=default), intent(in) :: nf
real(kind=default) :: kg
kg = (67.0_default/18.0_default - pi**2/6.0_default) * CA - &
10.0_default/9.0_default * TR * nf
end function k_g
@ %def gamma_g
@ %def k_g
@
\subsection{Mathematical Functions}
The dilogarithm. This simplified version is bound to double
precision, and restricted to argument values less or equal to unity,
so we do not need complex algebra. The wrapper converts it to default
precision (which is, of course, a no-op if double=default).
The routine calculates the dilogarithm through mapping on the area
where there is a quickly convergent series (adapted from an F77
routine by Hans Kuijf, 1988): Map $x$ such that $x$ is not in the
neighbourhood of $1$. Note that $|z|=-\ln(1-x)$ is always smaller
than $1.10$, but $\frac{1.10^{19}}{19!}{\rm Bernoulli}_{19}=2.7\times
10^{-15}$.
<<SM physics: public>>=
public :: Li2
<<SM physics: procedures>>=
elemental function Li2 (x)
use kinds, only: double
real(default), intent(in) :: x
real(default) :: Li2
Li2 = real( Li2_double (real(x, kind=double)), kind=default)
end function Li2
@ %def: Li2
@
<<SM physics: procedures>>=
elemental function Li2_double (x) result (Li2)
use kinds, only: double
real(kind=double), intent(in) :: x
real(kind=double) :: Li2
real(kind=double), parameter :: pi2_6 = pi**2/6
if (abs(1-x) < tiny_07) then
Li2 = pi2_6
else if (abs(1-x) < 0.5_double) then
Li2 = pi2_6 - log(1-x) * log(x) - Li2_restricted (1-x)
else if (abs(x) > 1.d0) then
! Li2 = 0
! call msg_bug (" Dilogarithm called outside of defined range.")
!!! Reactivate Dilogarithm identity
Li2 = -pi2_6 - 0.5_default * log(-x) * log(-x) - Li2_restricted (1/x)
else
Li2 = Li2_restricted (x)
end if
contains
elemental function Li2_restricted (x) result (Li2)
real(kind=double), intent(in) :: x
real(kind=double) :: Li2
real(kind=double) :: tmp, z, z2
z = - log (1-x)
z2 = z**2
! Horner's rule for the powers z^3 through z^19
tmp = 43867._double/798._double
tmp = tmp * z2 /342._double - 3617._double/510._double
tmp = tmp * z2 /272._double + 7._double/6._double
tmp = tmp * z2 /210._double - 691._double/2730._double
tmp = tmp * z2 /156._double + 5._double/66._double
tmp = tmp * z2 /110._double - 1._double/30._double
tmp = tmp * z2 / 72._double + 1._double/42._double
tmp = tmp * z2 / 42._double - 1._double/30._double
tmp = tmp * z2 / 20._double + 1._double/6._double
! The first three terms of the power series
Li2 = z2 * z * tmp / 6._double - 0.25_double * z2 + z
end function Li2_restricted
end function Li2_double
@ %def Li2_double
+@ Complex digamma function. For this we use the asymptotic formula in
+Abramoqicz/Stegun, Eq. (6.3.18), and the recurrence formula
+Eq. (6.3.6):
+\begin{equation}
+ \psi^{(0})(z) := \psi(z) = \frac{\Gamma'(z)}{\Gamma(z)}
+\end{equation}
+<<SM physics: public>>=
+ public :: psic
+<<SM physics: procedures>>=
+ elemental function psic (z) result (psi)
+ complex(default), intent(in) :: z
+ complex(default) :: psi
+ complex(default) :: shift, zz, zi, zi2
+ shift = 0
+ zz = z
+ if (abs (aimag(zz)) < 10._default) then
+ do while (abs (zz) < 10._default)
+ shift = shift - 1 / zz
+ zz = zz + 1
+ end do
+ end if
+ zi = 1/zz
+ zi2 = zi*zi
+ psi = shift + log(zz) - zi/2 - zi2 / 5040._default * ( 420._default + &
+ zi2 * ( -42._default + zi2 * (20._default - 21._default * zi2)))
+ end function psic
+
+@ %def psic
+@ Complex polygamma function. For this we use the asymptotic formula in
+Abramoqicz/Stegun, Eq. (6.4.11), and the recurrence formula
+Eq. (6.4.11):
+\begin{equation}
+ \psi^{(m})(z) := \frac{d^m}{dz^m} \psi(z) = \frac{d^{m+1}}{dz^{m+1}}
+ \ln \Gamma(z)
+\end{equation}
+<<SM physics: public>>=
+ public :: psim
+<<SM physics: procedures>>=
+ elemental function psim (z, m) result (psi)
+ complex(default), intent(in) :: z
+ integer, intent(in) :: m
+ complex(default) :: psi
+ complex(default) :: shift, rec, zz, zi, zi2
+ real(default) :: c1, c2, c3, c4, c5, c6, c7
+ integer :: i
+ if (m < 1) then
+ psi = psic(z)
+ else
+ shift = 0
+ zz = z
+ if (abs (aimag (zz)) < 10._default) then
+ CHECK_ABS: do i = 1, m
+ rec = (-1)**m * factorial (m) / zz**(m+1)
+ shift = shift - rec
+ zz = zz + 1
+ if (abs (zz) > 10._default) exit CHECK_ABS
+ end do CHECK_ABS
+ end if
+ c1 = 1._default
+ c2 = 1._default / 2._default
+ c3 = 1._default / 6._default
+ c4 = - 1._default / 30._default
+ c5 = 1._default / 42._default
+ c6 = - 1._default / 30._default
+ c7 = 5._default / 66._default
+ do i = 2, m
+ c1 = c1 * (i-1)
+ c2 = c2 * i
+ c3 = c3 * (i+1)
+ c4 = c4 * (i+3)
+ c5 = c5 * (i+5)
+ c6 = c6 * (i+7)
+ c7 = c7 * (i+9)
+ end do
+ zi = 1/zz
+ zi2 = zi*zi
+ psi = shift + (-1)**(m-1) * zi**m * ( c1 + zi * ( c2 + zi * ( &
+ c3 + zi2 * ( c4 + zi2 * ( c5 + zi2 * ( c6 + zi2 * ( c7 * zi2)))))))
+ end if
+ end function psim
+
+@ %def psim
+@ Nielsen's generalized polylogarithms,
+\begin{equation*}
+ S_{n,m}(x) = \frac{(-1)^{n+m-1}}{(n-1)!m!} \int_0^1 t^{-1}
+ \; \ln^{n-1} t \; \ln^m (1-xt) \; dt \; ,
+\end{equation*}
+adapted from the CERNLIB function [[wgplg]] for real arguments [[x]]
+and integer $n$ and $m$ satisfying $1 \leq n \leq 4$, $1 \leq m \leq 4$,
+$n+m \leq 5$, i.e. one of the functions $S_{1,1}$, $S_{1,2}$,
+$S_{2,1}$, $S_{1,3}$, $S_{2,2}$, $S_{3,1}$, $S_{1,4}$, $S_{2,3}$,
+$S_{3,2}$, $S_{4,1}$. If $x\leq1$, $S_{n,m}(x)$ is real, and the
+imaginary part is set to zero.
+<<SM physics: public>>=
+ public :: cnielsen
+ public :: nielsen
+<<SM physics: procedures>>=
+ function cnielsen (n, m, x) result (nplog)
+ integer, intent(in) :: n, m
+ real(default), intent(in) :: x
+ complex(default) :: nplog
+ real(default), parameter :: c1 = 4._default/3._default, &
+ c2 = 1._default/3._default
+ real(default), dimension(0:4), parameter :: &
+ fct = [1.0_default,1.0_default,2.0_default,6.0_default,24.0_default]
+ real(default), dimension(4,4) :: s1, cc
+ real(default), dimension(0:30,10) :: aa
+ complex(default), dimension(0:5) :: vv
+ real(default), dimension(0:5) :: uu
+ real(default) :: x1, h, alfa, b0, b1, b2, qq, rr
+ complex(default) :: sj, sk
+ integer, dimension(10), parameter :: &
+ nc = [24,26,28,30,22,24,26,19,22,17]
+ integer, dimension(31), parameter :: &
+ index = [1,2,3,4,0,0,0,0,0,0,5,6,7,0,0,0,0,0,0,0, &
+ 8,9,0,0,0,0,0,0,0,0,10]
+ real(default), dimension(0:4), parameter :: &
+ sgn = [1._default, -1._default, 1._default, -1._default, 1._default]
+ integer :: it, j, k, l, m1, n1
+ if ((n<1) .or. (n>4) .or. (m<1) .or. (m>4) .or. (n+m > 5)) then
+ call msg_fatal &
+ ("The Nielsen dilogarithms cannot be applied for these values.")
+ end if
+ s1 = 0._default
+ s1(1,1) = 1.6449340668482_default
+ s1(1,2) = 1.2020569031596_default
+ s1(1,3) = 1.0823232337111_default
+ s1(1,4) = 1.0369277551434_default
+ s1(2,1) = 1.2020569031596_default
+ s1(2,2) = 2.7058080842778e-1_default
+ s1(2,3) = 9.6551159989444e-2_default
+ s1(3,1) = 1.0823232337111_default
+ s1(3,2) = 9.6551159989444e-2_default
+ s1(4,1) = 1.0369277551434_default
+ cc = 0._default
+ cc(1,1) = 1.6449340668482_default
+ cc(1,2) = 1.2020569031596_default
+ cc(1,3) = 1.0823232337111_default
+ cc(1,4) = 1.0369277551434_default
+ cc(2,2) =-1.8940656589945_default
+ cc(2,3) =-3.0142321054407_default
+ cc(3,1) = 1.8940656589945_default
+ cc(3,2) = 3.0142321054407_default
+ aa = 0._default
+ aa( 0,1) = 0.96753215043498_default
+ aa( 1,1) = 0.16607303292785_default
+ aa( 2,1) = 0.02487932292423_default
+ aa( 3,1) = 0.00468636195945_default
+ aa( 4,1) = 0.00100162749616_default
+ aa( 5,1) = 0.00023200219609_default
+ aa( 6,1) = 0.00005681782272_default
+ aa( 7,1) = 0.00001449630056_default
+ aa( 8,1) = 0.00000381632946_default
+ aa( 9,1) = 0.00000102990426_default
+ aa(10,1) = 0.00000028357538_default
+ aa(11,1) = 0.00000007938705_default
+ aa(12,1) = 0.00000002253670_default
+ aa(13,1) = 0.00000000647434_default
+ aa(14,1) = 0.00000000187912_default
+ aa(15,1) = 0.00000000055029_default
+ aa(16,1) = 0.00000000016242_default
+ aa(17,1) = 0.00000000004827_default
+ aa(18,1) = 0.00000000001444_default
+ aa(19,1) = 0.00000000000434_default
+ aa(20,1) = 0.00000000000131_default
+ aa(21,1) = 0.00000000000040_default
+ aa(22,1) = 0.00000000000012_default
+ aa(23,1) = 0.00000000000004_default
+ aa(24,1) = 0.00000000000001_default
+
+ aa( 0,2) = 0.95180889127832_default
+ aa( 1,2) = 0.43131131846532_default
+ aa( 2,2) = 0.10002250714905_default
+ aa( 3,2) = 0.02442415595220_default
+ aa( 4,2) = 0.00622512463724_default
+ aa( 5,2) = 0.00164078831235_default
+ aa( 6,2) = 0.00044407920265_default
+ aa( 7,2) = 0.00012277494168_default
+ aa( 8,2) = 0.00003453981284_default
+ aa( 9,2) = 0.00000985869565_default
+ aa(10,2) = 0.00000284856995_default
+ aa(11,2) = 0.00000083170847_default
+ aa(12,2) = 0.00000024503950_default
+ aa(13,2) = 0.00000007276496_default
+ aa(14,2) = 0.00000002175802_default
+ aa(15,2) = 0.00000000654616_default
+ aa(16,2) = 0.00000000198033_default
+ aa(17,2) = 0.00000000060204_default
+ aa(18,2) = 0.00000000018385_default
+ aa(19,2) = 0.00000000005637_default
+ aa(20,2) = 0.00000000001735_default
+ aa(21,2) = 0.00000000000536_default
+ aa(22,2) = 0.00000000000166_default
+ aa(23,2) = 0.00000000000052_default
+ aa(24,2) = 0.00000000000016_default
+ aa(25,2) = 0.00000000000005_default
+ aa(26,2) = 0.00000000000002_default
+
+ aa( 0,3) = 0.98161027991365_default
+ aa( 1,3) = 0.72926806320726_default
+ aa( 2,3) = 0.22774714909321_default
+ aa( 3,3) = 0.06809083296197_default
+ aa( 4,3) = 0.02013701183064_default
+ aa( 5,3) = 0.00595478480197_default
+ aa( 6,3) = 0.00176769013959_default
+ aa( 7,3) = 0.00052748218502_default
+ aa( 8,3) = 0.00015827461460_default
+ aa( 9,3) = 0.00004774922076_default
+ aa(10,3) = 0.00001447920408_default
+ aa(11,3) = 0.00000441154886_default
+ aa(12,3) = 0.00000135003870_default
+ aa(13,3) = 0.00000041481779_default
+ aa(14,3) = 0.00000012793307_default
+ aa(15,3) = 0.00000003959070_default
+ aa(16,3) = 0.00000001229055_default
+ aa(17,3) = 0.00000000382658_default
+ aa(18,3) = 0.00000000119459_default
+ aa(19,3) = 0.00000000037386_default
+ aa(20,3) = 0.00000000011727_default
+ aa(21,3) = 0.00000000003687_default
+ aa(22,3) = 0.00000000001161_default
+ aa(23,3) = 0.00000000000366_default
+ aa(24,3) = 0.00000000000116_default
+ aa(25,3) = 0.00000000000037_default
+ aa(26,3) = 0.00000000000012_default
+ aa(27,3) = 0.00000000000004_default
+ aa(28,3) = 0.00000000000001_default
+
+ aa( 0,4) = 1.0640521184614_default
+ aa( 1,4) = 1.0691720744981_default
+ aa( 2,4) = 0.41527193251768_default
+ aa( 3,4) = 0.14610332936222_default
+ aa( 4,4) = 0.04904732648784_default
+ aa( 5,4) = 0.01606340860396_default
+ aa( 6,4) = 0.00518889350790_default
+ aa( 7,4) = 0.00166298717324_default
+ aa( 8,4) = 0.00053058279969_default
+ aa( 9,4) = 0.00016887029251_default
+ aa(10,4) = 0.00005368328059_default
+ aa(11,4) = 0.00001705923313_default
+ aa(12,4) = 0.00000542174374_default
+ aa(13,4) = 0.00000172394082_default
+ aa(14,4) = 0.00000054853275_default
+ aa(15,4) = 0.00000017467795_default
+ aa(16,4) = 0.00000005567550_default
+ aa(17,4) = 0.00000001776234_default
+ aa(18,4) = 0.00000000567224_default
+ aa(19,4) = 0.00000000181313_default
+ aa(20,4) = 0.00000000058012_default
+ aa(21,4) = 0.00000000018579_default
+ aa(22,4) = 0.00000000005955_default
+ aa(23,4) = 0.00000000001911_default
+ aa(24,4) = 0.00000000000614_default
+ aa(25,4) = 0.00000000000197_default
+ aa(26,4) = 0.00000000000063_default
+ aa(27,4) = 0.00000000000020_default
+ aa(28,4) = 0.00000000000007_default
+ aa(29,4) = 0.00000000000002_default
+ aa(30,4) = 0.00000000000001_default
+
+ aa( 0,5) = 0.97920860669175_default
+ aa( 1,5) = 0.08518813148683_default
+ aa( 2,5) = 0.00855985222013_default
+ aa( 3,5) = 0.00121177214413_default
+ aa( 4,5) = 0.00020722768531_default
+ aa( 5,5) = 0.00003996958691_default
+ aa( 6,5) = 0.00000838064065_default
+ aa( 7,5) = 0.00000186848945_default
+ aa( 8,5) = 0.00000043666087_default
+ aa( 9,5) = 0.00000010591733_default
+ aa(10,5) = 0.00000002647892_default
+ aa(11,5) = 0.00000000678700_default
+ aa(12,5) = 0.00000000177654_default
+ aa(13,5) = 0.00000000047342_default
+ aa(14,5) = 0.00000000012812_default
+ aa(15,5) = 0.00000000003514_default
+ aa(16,5) = 0.00000000000975_default
+ aa(17,5) = 0.00000000000274_default
+ aa(18,5) = 0.00000000000077_default
+ aa(19,5) = 0.00000000000022_default
+ aa(20,5) = 0.00000000000006_default
+ aa(21,5) = 0.00000000000002_default
+ aa(22,5) = 0.00000000000001_default
+
+ aa( 0,6) = 0.95021851963952_default
+ aa( 1,6) = 0.29052529161433_default
+ aa( 2,6) = 0.05081774061716_default
+ aa( 3,6) = 0.00995543767280_default
+ aa( 4,6) = 0.00211733895031_default
+ aa( 5,6) = 0.00047859470550_default
+ aa( 6,6) = 0.00011334321308_default
+ aa( 7,6) = 0.00002784733104_default
+ aa( 8,6) = 0.00000704788108_default
+ aa( 9,6) = 0.00000182788740_default
+ aa(10,6) = 0.00000048387492_default
+ aa(11,6) = 0.00000013033842_default
+ aa(12,6) = 0.00000003563769_default
+ aa(13,6) = 0.00000000987174_default
+ aa(14,6) = 0.00000000276586_default
+ aa(15,6) = 0.00000000078279_default
+ aa(16,6) = 0.00000000022354_default
+ aa(17,6) = 0.00000000006435_default
+ aa(18,6) = 0.00000000001866_default
+ aa(19,6) = 0.00000000000545_default
+ aa(20,6) = 0.00000000000160_default
+ aa(21,6) = 0.00000000000047_default
+ aa(22,6) = 0.00000000000014_default
+ aa(23,6) = 0.00000000000004_default
+ aa(24,6) = 0.00000000000001_default
+
+ aa( 0,7) = 0.95064032186777_default
+ aa( 1,7) = 0.54138285465171_default
+ aa( 2,7) = 0.13649979590321_default
+ aa( 3,7) = 0.03417942328207_default
+ aa( 4,7) = 0.00869027883583_default
+ aa( 5,7) = 0.00225284084155_default
+ aa( 6,7) = 0.00059516089806_default
+ aa( 7,7) = 0.00015995617766_default
+ aa( 8,7) = 0.00004365213096_default
+ aa( 9,7) = 0.00001207474688_default
+ aa(10,7) = 0.00000338018176_default
+ aa(11,7) = 0.00000095632476_default
+ aa(12,7) = 0.00000027313129_default
+ aa(13,7) = 0.00000007866968_default
+ aa(14,7) = 0.00000002283195_default
+ aa(15,7) = 0.00000000667205_default
+ aa(16,7) = 0.00000000196191_default
+ aa(17,7) = 0.00000000058018_default
+ aa(18,7) = 0.00000000017246_default
+ aa(19,7) = 0.00000000005151_default
+ aa(20,7) = 0.00000000001545_default
+ aa(21,7) = 0.00000000000465_default
+ aa(22,7) = 0.00000000000141_default
+ aa(23,7) = 0.00000000000043_default
+ aa(24,7) = 0.00000000000013_default
+ aa(25,7) = 0.00000000000004_default
+ aa(26,7) = 0.00000000000001_default
+
+ aa( 0,8) = 0.98800011672229_default
+ aa( 1,8) = 0.04364067609601_default
+ aa( 2,8) = 0.00295091178278_default
+ aa( 3,8) = 0.00031477809720_default
+ aa( 4,8) = 0.00004314846029_default
+ aa( 5,8) = 0.00000693818230_default
+ aa( 6,8) = 0.00000124640350_default
+ aa( 7,8) = 0.00000024293628_default
+ aa( 8,8) = 0.00000005040827_default
+ aa( 9,8) = 0.00000001099075_default
+ aa(10,8) = 0.00000000249467_default
+ aa(11,8) = 0.00000000058540_default
+ aa(12,8) = 0.00000000014127_default
+ aa(13,8) = 0.00000000003492_default
+ aa(14,8) = 0.00000000000881_default
+ aa(15,8) = 0.00000000000226_default
+ aa(16,8) = 0.00000000000059_default
+ aa(17,8) = 0.00000000000016_default
+ aa(18,8) = 0.00000000000004_default
+ aa(19,8) = 0.00000000000001_default
+
+ aa( 0,9) = 0.95768506546350_default
+ aa( 1,9) = 0.19725249679534_default
+ aa( 2,9) = 0.02603370313918_default
+ aa( 3,9) = 0.00409382168261_default
+ aa( 4,9) = 0.00072681707110_default
+ aa( 5,9) = 0.00014091879261_default
+ aa( 6,9) = 0.00002920458914_default
+ aa( 7,9) = 0.00000637631144_default
+ aa( 8,9) = 0.00000145167850_default
+ aa( 9,9) = 0.00000034205281_default
+ aa(10,9) = 0.00000008294302_default
+ aa(11,9) = 0.00000002060784_default
+ aa(12,9) = 0.00000000522823_default
+ aa(13,9) = 0.00000000135066_default
+ aa(14,9) = 0.00000000035451_default
+ aa(15,9) = 0.00000000009436_default
+ aa(16,9) = 0.00000000002543_default
+ aa(17,9) = 0.00000000000693_default
+ aa(18,9) = 0.00000000000191_default
+ aa(19,9) = 0.00000000000053_default
+ aa(20,9) = 0.00000000000015_default
+ aa(21,9) = 0.00000000000004_default
+ aa(22,9) = 0.00000000000001_default
+
+ aa( 0,10) = 0.99343651671347_default
+ aa( 1,10) = 0.02225770126826_default
+ aa( 2,10) = 0.00101475574703_default
+ aa( 3,10) = 0.00008175156250_default
+ aa( 4,10) = 0.00000899973547_default
+ aa( 5,10) = 0.00000120823987_default
+ aa( 6,10) = 0.00000018616913_default
+ aa( 7,10) = 0.00000003174723_default
+ aa( 8,10) = 0.00000000585215_default
+ aa( 9,10) = 0.00000000114739_default
+ aa(10,10) = 0.00000000023652_default
+ aa(11,10) = 0.00000000005082_default
+ aa(12,10) = 0.00000000001131_default
+ aa(13,10) = 0.00000000000259_default
+ aa(14,10) = 0.00000000000061_default
+ aa(15,10) = 0.00000000000015_default
+ aa(16,10) = 0.00000000000004_default
+ aa(17,10) = 0.00000000000001_default
+
+ if (x == 1._default) then
+ nplog = s1(n,m)
+ else if (x > 2._default .or. x < -1.0_default) then
+ x1 = 1._default / x
+ h = c1 * x1 + c2
+ alfa = h + h
+ vv(0) = 1._default
+ if (x < -1.0_default) then
+ vv(1) = log(-x)
+ else if (x > 2._default) then
+ vv(1) = log(cmplx(-x,0._default,kind=default))
+ end if
+ do l = 2, n+m
+ vv(l) = vv(1) * vv(l-1)/l
+ end do
+ sk = 0._default
+ do k = 0, m-1
+ m1 = m-k
+ rr = x1**m1 / (fct(m1) * fct(n-1))
+ sj = 0._default
+ do j = 0, k
+ n1 = n+k-j
+ l = index(10*n1+m1-10)
+ b1 = 0._default
+ b2 = 0._default
+ do it = nc(l), 0, -1
+ b0 = aa(it,l) + alfa*b1 - b2
+ b2 = b1
+ b1 = b0
+ end do
+ qq = (fct(n1-1) / fct(k-j)) * (b0 - h*b2) * rr / m1**n1
+ sj = sj + vv(j) * qq
+ end do
+ sk = sk + sgn(k) * sj
+ end do
+ sj = 0._default
+ do j = 0, n-1
+ sj = sj + vv(j) * cc(n-j,m)
+ end do
+ nplog = sgn(n) * sk + sgn(m) * (sj + vv(n+m))
+ else if (x > 0.5_default) then
+ x1 = 1._default - x
+ h = c1 * x1 + c2
+ alfa = h + h
+ vv(0) = 1._default
+ uu(0) = 1._default
+ vv(1) = log(cmplx(x1,0._default,kind=default))
+ uu(1) = log(x)
+ do l = 2, m
+ vv(l) = vv(1) * vv(l-1) / l
+ end do
+ do l = 2, n
+ uu(l) = uu(1) * uu(l-1) / l
+ end do
+ sk = 0._default
+ do k = 0, n-1
+ m1 = n-k
+ rr = x1**m1 / fct(m1)
+ sj = 0._default
+ do j = 0, m-1
+ n1 = m-j
+ l = index(10*n1 + m1 - 10)
+ b1 = 0._default
+ b2 = 0._default
+ do it = nc(l), 0, -1
+ b0 = aa(it,l) + alfa*b1 - b2
+ b2 = b1
+ b1 = b0
+ end do
+ qq = sgn(j) * (b0 - h*b2) * rr / m1**n1
+ sj = sj + vv(j) * qq
+ end do
+ sk = sk + uu(k) * (s1(m1,m) - sj)
+ end do
+ nplog = sk + sgn(m) * uu(n) * vv(m)
+ else
+ l = index(10*n + m - 10)
+ h = c1 * x + c2
+ alfa = h + h
+ b1 = 0._default
+ b2 = 0._default
+ do it = nc(l), 0, -1
+ b0 = aa(it,l) + alfa*b1 - b2
+ b2 = b1
+ b1 = b0
+ end do
+ nplog = (b0 - h*b2) * x**m / (fct(m) * m**n)
+ end if
+ end function cnielsen
+
+ function nielsen (n, m, x) result (nplog)
+ integer, intent(in) :: n, m
+ real(default), intent(in) :: x
+ real(default) :: nplog
+ nplog = real (cnielsen (n, m, x))
+ end function nielsen
+
+@ %def cnielsen nielsen
+@ $\text{Li}_{n}(x) = S_{n-1,1}(x)$.
+<<SM physics: public>>=
+ public :: polylog
+<<SM physics: procedures>>=
+ function polylog (n, x) result (plog)
+ integer, intent(in) :: n
+ real(default), intent(in) :: x
+ real(default) :: plog
+ plog = nielsen (n-1,1,x)
+ end function polylog
+
+@ %def polylog
+@ $\text{Li}_2(x)$.
+<<SM physics: public>>=
+ public :: dilog
+<<SM physics: procedures>>=
+ function dilog (x) result (dlog)
+ real(default), intent(in) :: x
+ real(default) :: dlog
+ dlog = polylog (2,x)
+ end function dilog
+
+@ %def dilog
+@ $\text{Li}_3(x)$.
+<<SM physics: public>>=
+ public :: trilog
+<<SM physics: procedures>>=
+ function trilog (x) result (tlog)
+ real(default), intent(in) :: x
+ real(default) :: tlog
+ tlog = polylog (3,x)
+ end function trilog
+
+@ %def trilog
@
\subsection{Loop Integrals}
These functions appear in the calculation of the effective one-loop coupling of
a (pseudo)scalar to a vector boson pair.
<<SM physics: public>>=
public :: faux
<<SM physics: procedures>>=
elemental function faux (x) result (y)
real(default), intent(in) :: x
complex(default) :: y
if (1 <= x) then
y = asin(sqrt(1/x))**2
else
y = - 1/4.0_default * (log((1 + sqrt(1 - x))/ &
(1 - sqrt(1 - x))) - cmplx (0.0_default, pi, kind=default))**2
end if
end function faux
@ %def faux
@
<<SM physics: public>>=
public :: fonehalf
<<SM physics: procedures>>=
elemental function fonehalf (x) result (y)
real(default), intent(in) :: x
complex(default) :: y
if (abs(x) < eps0) then
y = 0
else
y = - 2.0_default * x * (1 + (1 - x) * faux(x))
end if
end function fonehalf
@ %def fonehalf
@
<<SM physics: public>>=
public :: fonehalf_pseudo
<<SM physics: procedures>>=
function fonehalf_pseudo (x) result (y)
real(default), intent(in) :: x
complex(default) :: y
if (abs(x) < eps0) then
y = 0
else
y = - 2.0_default * x * faux(x)
end if
end function fonehalf_pseudo
@ %def fonehalf_pseudo
@
<<SM physics: public>>=
public :: fone
<<SM physics: procedures>>=
elemental function fone (x) result (y)
real(default), intent(in) :: x
complex(default) :: y
if (abs(x) < eps0) then
y = 2.0_default
else
y = 2.0_default + 3.0_default * x + &
3.0_default * x * (2.0_default - x) * &
faux(x)
end if
end function fone
@ %def fone
@
<<SM physics: public>>=
public :: gaux
<<SM physics: procedures>>=
elemental function gaux (x) result (y)
real(default), intent(in) :: x
complex(default) :: y
if (1 <= x) then
y = sqrt(x - 1) * asin(sqrt(1/x))
else
y = sqrt(1 - x) * (log((1 + sqrt(1 - x)) / &
(1 - sqrt(1 - x))) - &
cmplx (0.0_default, pi, kind=default)) / 2.0_default
end if
end function gaux
@ %def gaux
@
<<SM physics: public>>=
public :: tri_i1
<<SM physics: procedures>>=
elemental function tri_i1 (a,b) result (y)
real(default), intent(in) :: a,b
complex(default) :: y
if (a < eps0 .or. b < eps0) then
y = 0
else
y = a*b/2.0_default/(a-b) + a**2 * b**2/2.0_default/(a-b)**2 * &
(faux(a) - faux(b)) + &
a**2 * b/(a-b)**2 * (gaux(a) - gaux(b))
end if
end function tri_i1
@ %def tri_i1
@
<<SM physics: public>>=
public :: tri_i2
<<SM physics: procedures>>=
elemental function tri_i2 (a,b) result (y)
real(default), intent(in) :: a,b
complex(default) :: y
if (a < eps0 .or. b < eps0) then
y = 0
else
y = - a * b / 2.0_default / (a-b) * (faux(a) - faux(b))
end if
end function tri_i2
@ %def tri_i2
@
\subsection{More on $\alpha_s$}
These functions are for the running of the strong coupling constants,
$\alpha_s$.
<<SM physics: public>>=
public :: run_b0
<<SM physics: procedures>>=
elemental function run_b0 (nf) result (bnull)
integer, intent(in) :: nf
real(default) :: bnull
bnull = 33.0_default - 2.0_default * nf
end function run_b0
@ %def run_b0
@
<<SM physics: public>>=
public :: run_b1
<<SM physics: procedures>>=
elemental function run_b1 (nf) result (bone)
integer, intent(in) :: nf
real(default) :: bone
bone = 6.0_default * (153.0_default - 19.0_default * nf)/run_b0(nf)**2
end function run_b1
@ %def run_b1
@
<<SM physics: public>>=
public :: run_aa
<<SM physics: procedures>>=
elemental function run_aa (nf) result (aaa)
integer, intent(in) :: nf
real(default) :: aaa
aaa = 12.0_default * PI / run_b0(nf)
end function run_aa
@ %def run_aa
@
<<SM physics: pubic functions>>=
public :: run_bb
<<SM physics: procedures>>=
elemental function run_bb (nf) result (bbb)
integer, intent(in) :: nf
real(default) :: bbb
bbb = run_b1(nf) / run_aa(nf)
end function run_bb
@ %def run_bb
@
\subsection{Functions for Catani-Seymour dipoles}
For the automated Catani-Seymour dipole subtraction, we need the
following functions.
<<SM physics: public>>=
public :: ff_dipole
<<SM physics: procedures>>=
pure subroutine ff_dipole (v_ijk,y_ijk,p_ij,pp_k,p_i,p_j,p_k)
type(vector4_t), intent(in) :: p_i, p_j, p_k
type(vector4_t), intent(out) :: p_ij, pp_k
real(kind=default), intent(out) :: y_ijk
real(kind=default) :: z_i
real(kind=default), intent(out) :: v_ijk
z_i = (p_i*p_k) / ((p_k*p_j) + (p_k*p_i))
y_ijk = (p_i*p_j) / ((p_i*p_j) + (p_i*p_k) + (p_j*p_k))
p_ij = p_i + p_j - y_ijk/(1.0_default - y_ijk) * p_k
pp_k = (1.0/(1.0_default - y_ijk)) * p_k
!!! We don't multiply by alpha_s right here:
v_ijk = 8.0_default * PI * CF * &
(2.0 / (1.0 - z_i*(1.0 - y_ijk)) - (1.0 + z_i))
end subroutine ff_dipole
@ %def ff_dipole
@
<<SM physics: public>>=
public :: fi_dipole
<<SM physics: procedures>>=
pure subroutine fi_dipole (v_ija,x_ija,p_ij,pp_a,p_i,p_j,p_a)
type(vector4_t), intent(in) :: p_i, p_j, p_a
type(vector4_t), intent(out) :: p_ij, pp_a
real(kind=default), intent(out) :: x_ija
real(kind=default) :: z_i
real(kind=default), intent(out) :: v_ija
z_i = (p_i*p_a) / ((p_a*p_j) + (p_a*p_i))
x_ija = ((p_i*p_a) + (p_j*p_a) - (p_i*p_j)) &
/ ((p_i*p_a) + (p_j*p_a))
p_ij = p_i + p_j - (1.0_default - x_ija) * p_a
pp_a = x_ija * p_a
!!! We don't not multiply by alpha_s right here:
v_ija = 8.0_default * PI * CF * &
(2.0 / (1.0 - z_i + (1.0 - x_ija)) - (1.0 + z_i)) / x_ija
end subroutine fi_dipole
@ %def fi_dipole
@
<<SM physics: public>>=
public :: if_dipole
<<SM physics: procedures>>=
pure subroutine if_dipole (v_kja,u_j,p_aj,pp_k,p_k,p_j,p_a)
type(vector4_t), intent(in) :: p_k, p_j, p_a
type(vector4_t), intent(out) :: p_aj, pp_k
real(kind=default), intent(out) :: u_j
real(kind=default) :: x_kja
real(kind=default), intent(out) :: v_kja
u_j = (p_a*p_j) / ((p_a*p_j) + (p_a*p_k))
x_kja = ((p_a*p_k) + (p_a*p_j) - (p_j*p_k)) &
/ ((p_a*p_j) + (p_a*p_k))
p_aj = x_kja * p_a
pp_k = p_k + p_j - (1.0_default - x_kja) * p_a
v_kja = 8.0_default * PI * CF * &
(2.0 / (1.0 - x_kja + u_j) - (1.0 + x_kja)) / x_kja
end subroutine if_dipole
@ %def if_dipole
@ This function depends on a variable number of final state particles
whose kinematics all get changed by the initial-initial dipole insertion.
<<SM physics: public>>=
public :: ii_dipole
<<SM physics: procedures>>=
pure subroutine ii_dipole (v_jab,v_j,p_in,p_out,flag_1or2)
type(vector4_t), dimension(:), intent(in) :: p_in
type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out
logical, intent(in) :: flag_1or2
real(kind=default), intent(out) :: v_j
real(kind=default), intent(out) :: v_jab
type(vector4_t) :: p_a, p_b, p_j
type(vector4_t) :: k, kk
type(vector4_t) :: p_aj
real(kind=default) :: x_jab
integer :: i
!!! flag_1or2 decides whether this a 12 or 21 dipole
if (flag_1or2) then
p_a = p_in(1)
p_b = p_in(2)
else
p_b = p_in(1)
p_a = p_in(2)
end if
!!! We assume that the unresolved particle has always the last
!!! momentum
p_j = p_in(size(p_in))
x_jab = ((p_a*p_b) - (p_a*p_j) - (p_b*p_j)) / (p_a*p_b)
v_j = (p_a*p_j) / (p_a * p_b)
p_aj = x_jab * p_a
k = p_a + p_b - p_j
kk = p_aj + p_b
do i = 3, size(p_in)-1
p_out(i) = p_in(i) - 2.0*((k+kk)*p_in(i))/((k+kk)*(k+kk)) * (k+kk) + &
(2.0 * (k*p_in(i)) / (k*k)) * kk
end do
if (flag_1or2) then
p_out(1) = p_aj
p_out(2) = p_b
else
p_out(1) = p_b
p_out(2) = p_aj
end if
v_jab = 8.0_default * PI * CF * &
(2.0 / (1.0 - x_jab) - (1.0 + x_jab)) / x_jab
end subroutine ii_dipole
@ %def ii_dipole
@
\subsection{Distributions for integrated dipoles and such}
Note that the following formulae are only meaningful for
$0 \leq x \leq 1$.
The Dirac delta distribution, modified for Monte-Carlo sampling,
centered at $x=1-\frac{\epsilon}{2}$:
<<SM physics: public>>=
public :: delta
<<SM physics: procedures>>=
elemental function delta (x,eps) result (z)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: z
if (x > one - eps) then
z = one / eps
else
z = 0
end if
end function delta
@ %def delta
@ The $+$-distribution, $P_+(x) = \left( \frac{1}{1-x}\right)_+$, for
the regularization of soft-collinear singularities. The constant part
for the Monte-Carlo sampling is the integral over the splitting
function divided by the weight for the WHIZARD numerical integration
over the interval.
<<SM physics: public>>=
public :: plus_distr
<<SM physics: procedures>>=
elemental function plus_distr (x,eps) result (plusd)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: plusd
if (x > one - eps) then
plusd = log(eps) / eps
else
plusd = one / (one - x)
end if
end function plus_distr
@ %def plus_distr
@ The splitting function in $D=4$ dimensions, regularized as
$+$-distributions if necessary:
\begin{align}
P^{qq} (x) = P^{\bar q\bar q} (x) &= \; C_F \cdot \left( \frac{1 +
x^2}{1-x} \right)_+ \\
P^{qg} (x) = P^{\bar q g} (x) &= \; C_F \cdot \frac{1 + (1-x)^2}{x}\\
P^{gq} (x) = P^{g \bar q} (x) &= \; T_R \cdot \left[ x^2 + (1-x)^2
\right] \\
P^{gg} (x) &= \; 2 C_A \biggl[ \left( \frac{1}{1-x} \right)_+ +
\frac{1-x}{x} - 1 + x(1-x) \biggl] \notag{}\\
&\quad + \delta(1-x) \left( \frac{11}{6} C_A -
\frac{2}{3} N_f T_R \right)
\end{align}
Since the number of flavors summed over in the gluon splitting
function might depend on the physics case under consideration, it is
implemented as an input variable.
<<SM physics: public>>=
public :: pqq
<<SM physics: procedures>>=
elemental function pqq (x,eps) result (pqqx)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: pqqx
if (x > (1.0_default - eps)) then
pqqx = (eps - one) / two + two * log(eps) / eps - &
three * (eps - one) / eps / two
else
pqqx = (one + x**2) / (one - x)
end if
pqqx = CF * pqqx
end function pqq
@ %def pqq
@
<<SM physics: public>>=
public :: pgq
<<SM physics: procedures>>=
elemental function pgq (x) result (pgqx)
real(kind=default), intent(in) :: x
real(kind=default) :: pgqx
pgqx = TR * (x**2 + (one - x)**2)
end function pgq
@ %def pgq
@
<<SM physics: public>>=
public :: pqg
<<SM physics: procedures>>=
elemental function pqg (x) result (pqgx)
real(kind=default), intent(in) :: x
real(kind=default) :: pqgx
pqgx = CF * (one + (one - x)**2) / x
end function pqg
@ %def pqg
@
<<SM physics: public>>=
public :: pgg
<<SM physics: procedures>>=
elemental function pgg (x, nf, eps) result (pggx)
real(kind=default), intent(in) :: x, nf, eps
real(kind=default) :: pggx
pggx = two * CA * ( plus_distr (x, eps) + (one-x)/x - one + &
x*(one-x)) + delta (x, eps) * gamma_g(nf)
end function pgg
@ %def pgg
@ For the $qq$ and $gg$ cases, there exist ``regularized'' versions of
the splitting functions:
\begin{align}
P^{qq}_{\text{reg}} (x) &= - C_F \cdot (1 + x) \\
P^{gg}_{\text{reg}} (x) &= 2 C_A \left[ \frac{1-x}{x} - 1 + x(1-x) \right]
\end{align}
<<SM physics: public>>=
public :: pqq_reg
<<SM physics: procedures>>=
elemental function pqq_reg (x) result (pqqregx)
real(kind=default), intent(in) :: x
real(kind=default) :: pqqregx
pqqregx = - CF * (one + x)
end function pqq_reg
@ %def pqq_reg
@
<<SM physics: public>>=
public :: pgg_reg
<<SM physics: procedures>>=
elemental function pgg_reg (x) result (pggregx)
real(kind=default), intent(in) :: x
real(kind=default) :: pggregx
pggregx = two * CA * ((one - x)/x - one + x*(one - x))
end function pgg_reg
@ %def pgg_reg
@ Here, we collect the expressions needed for integrated
Catani-Seymour dipoles, and the so-called flavor kernels. We always
distinguish between the ``ordinary'' Catani-Seymour version, and the
one including a phase-space slicing parameter, $\alpha$.
The standard flavor kernels $\overline{K}^{ab}$ are:
\begin{align}
\overline{K}^{qg} (x) = \overline{K}^{\bar q g} (x) & = \;
P^{qg} (x) \log ((1-x)/x) + CF \times x \\
%%%
\overline{K}^{gq} (x) = \overline{K}^{g \bar q} (x) & = \;
P^{gq} (x) \log ((1-x)/x) + TR \times 2x(1-x) \\
%%%
\overline{K}^{qq} &=\; C_F \biggl[ \left( \frac{2}{1-x} \log
\frac{1-x}{x} \right)_+ - (1+x) \log ((1-x)/x) +
(1-x) \biggr] \notag{}\\
&\quad - (5 - \pi^2) \cdot C_F \cdot \delta(1-x) \\
%%%
\overline{K}^{gg} &=\; 2 C_A \biggl[ \left( \frac{1}{1-x} \log
\frac{1-x}{x} \right)_+ + \left( \frac{1-x}{x} - 1 + x(1-x)
\right) \log((1-x)/x) \biggr] \notag{}\\
&\quad - \delta(1-x) \biggl[ \left(
\frac{50}{9} - \pi^2 \right) C_A - \frac{16}{9} T_R N_f \biggr]
\end{align}
<<SM physics: public>>=
public :: kbarqg
<<SM physics: procedures>>=
function kbarqg (x) result (kbarqgx)
real(kind=default), intent(in) :: x
real(kind=default) :: kbarqgx
kbarqgx = pqg(x) * log((one-x)/x) + CF * x
end function kbarqg
@ %def kbarqg
@
<<SM physics: public>>=
public :: kbargq
<<SM physics: procedures>>=
function kbargq (x) result (kbargqx)
real(kind=default), intent(in) :: x
real(kind=default) :: kbargqx
kbargqx = pgq(x) * log((one-x)/x) + two * TR * x * (one - x)
end function kbargq
@ %def kbarqg
@
<<SM physics: public>>=
public :: kbarqq
<<SM physics: procedures>>=
function kbarqq (x,eps) result (kbarqqx)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: kbarqqx
kbarqqx = CF*(log_plus_distr(x,eps) - (one+x) * log((one-x)/x) + (one - &
x) - (five - pi**2) * delta(x,eps))
end function kbarqq
@ %def kbarqq
@
<<SM physics: public>>=
public :: kbargg
<<SM physics: procedures>>=
function kbargg (x,eps,nf) result (kbarggx)
real(kind=default), intent(in) :: x, eps, nf
real(kind=default) :: kbarggx
kbarggx = CA * (log_plus_distr(x,eps) + two * ((one-x)/x - one + &
x*(one-x) * log((1-x)/x))) - delta(x,eps) * &
((50.0_default/9.0_default - pi**2) * CA - &
16.0_default/9.0_default * TR * nf)
end function kbargg
@ %def kbargg
@ The $\tilde{K}$ are used when two identified hadrons participate:
\begin{equation}
\tilde{K}^{ab} (x) = P^{ab}_{\text{reg}} (x) \cdot \log (1-x) +
\delta^{ab} \mathbf{T}_a^2 \biggl[ \left( \frac{2}{1-x} \log (1-x)
\right)_+ - \frac{\pi^2}{3} \delta(1-x) \biggr]
\end{equation}
<<SM physics: public>>=
public :: ktildeqq
<<SM physics: procedures>>=
function ktildeqq (x,eps) result (ktildeqqx)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: ktildeqqx
ktildeqqx = pqq_reg (x) * log(one-x) + CF * ( - log2_plus_distr (x,eps) &
- pi**2/three * delta(x,eps))
end function ktildeqq
@ %def ktildeqq
@
<<SM physics: public>>=
public :: ktildeqg
<<SM physics: procedures>>=
function ktildeqg (x,eps) result (ktildeqgx)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: ktildeqgx
ktildeqgx = pqg (x) * log(one-x)
end function ktildeqg
@ %def ktildeqg
@
<<SM physics: public>>=
public :: ktildegq
<<SM physics: procedures>>=
function ktildegq (x,eps) result (ktildegqx)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: ktildegqx
ktildegqx = pgq (x) * log(one-x)
end function ktildegq
@ %def ktildeqg
@
<<SM physics: public>>=
public :: ktildegg
<<SM physics: procedures>>=
function ktildegg (x,eps) result (ktildeggx)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: ktildeggx
ktildeggx = pgg_reg (x) * log(one-x) + CA * ( - &
log2_plus_distr (x,eps) - pi**2/three * delta(x,eps))
end function ktildegg
@ %def ktildegg
@ The insertion operator might not be necessary for a GOLEM interface
but is demanded by the Les Houches NLO accord. It is a
three-dimensional array, where the index always gives the inverse
power of the DREG expansion parameter, $\epsilon$.
<<SM physics: public>>=
public :: insert_q
<<SM physics: procedures>>=
pure function insert_q ()
real(kind=default), dimension(0:2) :: insert_q
insert_q(0) = gamma_q + k_q - pi**2/three * CF
insert_q(1) = gamma_q
insert_q(2) = CF
end function insert_q
@ %def insert_q
@
<<SM physics: public>>=
public :: insert_g
<<SM physics: procedures>>=
pure function insert_g (nf)
real(kind=default), intent(in) :: nf
real(kind=default), dimension(0:2) :: insert_g
insert_g(0) = gamma_g (nf) + k_g (nf) - pi**2/three * CA
insert_g(1) = gamma_g (nf)
insert_g(2) = CA
end function insert_g
@ %def insert_g
@ For better convergence, one can exclude regions of phase space with
a slicing parameter from the dipole subtraction procedure. First of
all, the $K$ functions get modified:
\begin{equation}
K_i (\alpha) = K_i - \mathbf{T}_i^2 \log^2 \alpha + \gamma_i (
\alpha - 1 - \log\alpha)
\end{equation}
<<SM physics: public>>=
public :: k_q_al, k_g_al
<<SM physics: procedures>>=
pure function k_q_al (alpha)
real(kind=default), intent(in) :: alpha
real(kind=default) :: k_q_al
k_q_al = k_q - CF * (log(alpha))**2 + gamma_q * &
(alpha - one - log(alpha))
end function k_q_al
pure function k_g_al (alpha, nf)
real(kind=default), intent(in) :: alpha, nf
real(kind=default) :: k_g_al
k_g_al = k_g (nf) - CA * (log(alpha))**2 + gamma_g (nf) * &
(alpha - one - log(alpha))
end function k_g_al
@ %def k_q_al
@ %def k_g_al
@ The $+$-distribution, but with a phase-space slicing parameter,
$\alpha$, $P_{1-\alpha}(x) = \left( \frac{1}{1-x}
\right)_{1-x}$. Since we need the fatal error message here, this
function cannot be elemental.
<<SM physics: public>>=
public :: plus_distr_al
<<SM physics: procedures>>=
function plus_distr_al (x,alpha,eps) result (plusd_al)
real(kind=default), intent(in) :: x, eps, alpha
real(kind=default) :: plusd_al
if ((one - alpha) >= (one - eps)) then
plusd_al = zero
call msg_fatal ('sm_physics, plus_distr_al: alpha and epsilon chosen wrongly')
elseif (x < (1.0_default - alpha)) then
plusd_al = 0
else if (x > (1.0_default - eps)) then
plusd_al = log(eps/alpha)/eps
else
plusd_al = one/(one-x)
end if
end function plus_distr_al
@ %def plus_distr_al
@ Introducing phase-space slicing parameters, these standard flavor
kernels $\overline{K}^{ab}$ become:
\begin{align}
\overline{K}^{qg}_\alpha (x) = \overline{K}^{\bar q g}_\alpha (x) & = \;
P^{qg} (x) \log (\alpha (1-x)/x) + C_F \times x \\
%%%
\overline{K}^{gq}_\alpha (x) = \overline{K}^{g \bar q}_\alpha (x) & = \;
P^{gq} (x) \log (\alpha (1-x)/x) + T_R \times 2x(1-x) \\
%%%
\overline{K}^{qq}_\alpha &=
C_F (1 - x) + P^{qq}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x}
\notag{}\\ &\quad
+ C_F \delta (1 - x) \log^2 \alpha
+ C_F \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ \notag{}\\
&\quad
- \left( \gamma_q + K_q(\alpha) - \frac56 \pi^2 C_F \right) \cdot
\delta(1-x) \; C_F \Bigl[ + \frac{2}{1-x} \log \left(
\frac{\alpha (2-x)}{1+\alpha-x} \right)
- \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log
\frac{2-x}{1-x} \right) \Bigr] \\
%%%
\overline{K}^{gg}_\alpha &=\;
P^{gg}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x}
+ C_A \delta (1 - x) \log^2 \alpha \notag{}\\
&\quad
+ C_A \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+
- \left( \gamma_g + K_g(\alpha) - \frac56 \pi^2 C_A \right) \cdot
\delta(1-x) \; C_A \Bigl[ + \frac{2}{1-x} \log \left(
\frac{\alpha (2-x)}{1+\alpha-x} \right)
- \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log
\frac{2-x}{1-x} \right) \Bigr]
\end{align}
<<SM physics: public>>=
public :: kbarqg_al
<<SM physics: procedures>>=
function kbarqg_al (x,alpha,eps) result (kbarqgx)
real(kind=default), intent(in) :: x, alpha, eps
real(kind=default) :: kbarqgx
kbarqgx = pqg (x) * log(alpha*(one-x)/x) + CF * x
end function kbarqg_al
@ %def kbarqg_al
@
<<SM physics: public>>=
public :: kbargq_al
<<SM physics: procedures>>=
function kbargq_al (x,alpha,eps) result (kbargqx)
real(kind=default), intent(in) :: x, alpha, eps
real(kind=default) :: kbargqx
kbargqx = pgq (x) * log(alpha*(one-x)/x) + two * TR * x * (one-x)
end function kbargq_al
@ %def kbargq_al
@
<<SM physics: public>>=
public :: kbarqq_al
<<SM physics: procedures>>=
function kbarqq_al (x,alpha,eps) result (kbarqqx)
real(kind=default), intent(in) :: x, alpha, eps
real(kind=default) :: kbarqqx
kbarqqx = CF * (one - x) + pqq_reg(x) * log(alpha*(one-x)/x) &
+ CF * log_plus_distr(x,eps) &
- (gamma_q + k_q_al(alpha) - CF * &
five/6.0_default * pi**2 - CF * (log(alpha))**2) * &
delta(x,eps) + &
CF * two/(one -x)*log(alpha*(two-x)/(one+alpha-x))
if (x < (one-alpha)) then
kbarqqx = kbarqqx - CF * two/(one-x) * log((two-x)/(one-x))
end if
end function kbarqq_al
@ %def kbarqq_al
<<SM physics: public>>=
public :: kbargg_al
<<SM physics: procedures>>=
function kbargg_al (x,alpha,eps,nf) result (kbarggx)
real(kind=default), intent(in) :: x, alpha, eps, nf
real(kind=default) :: kbarggx
kbarggx = pgg_reg(x) * log(alpha*(one-x)/x) &
+ CA * log_plus_distr(x,eps) &
- (gamma_g(nf) + k_g_al(alpha,nf) - CA * &
five/6.0_default * pi**2 - CA * (log(alpha))**2) * &
delta(x,eps) + &
CA * two/(one -x)*log(alpha*(two-x)/(one+alpha-x))
if (x < (one-alpha)) then
kbarggx = kbarggx - CA * two/(one-x) * log((two-x)/(one-x))
end if
end function kbargg_al
@ %def kbargg_al
@ The $\tilde{K}$ flavor kernels in the presence of a phase-space slicing
parameter, are:
\begin{equation}
\tilde{K}^{ab} (x,\alpha) = P^{qq, \text{reg}} (x)
\log\frac{1-x}{\alpha} + ..........
\end{equation}
<<SM physics: public>>=
public :: ktildeqq_al
<<SM physics: procedures>>=
function ktildeqq_al (x,alpha,eps) result (ktildeqqx)
real(kind=default), intent(in) :: x, eps, alpha
real(kind=default) :: ktildeqqx
ktildeqqx = pqq_reg(x) * log((one-x)/alpha) + CF*( &
- log2_plus_distr_al(x,alpha,eps) - Pi**2/three * delta(x,eps) &
+ (one+x**2)/(one-x) * log(min(one,(alpha/(one-x)))) &
+ two/(one-x) * log((one+alpha-x)/alpha))
if (x > (one-alpha)) then
ktildeqqx = ktildeqqx - CF*two/(one-x)*log(two-x)
end if
end function ktildeqq_al
@ %def ktildeqq_al
@ This is a logarithmic $+$-distribution, $\left(
\frac{\log((1-x)/x)}{1-x} \right)_+$. For the sampling, we need the
integral over this function over the incomplete sampling interval
$[0,1-\epsilon]$, which is $\log^2(x) + 2 Li_2(x) -
\frac{\pi^2}{3}$. As this function is negative definite for $\epsilon
> 0.1816$, we take a hard upper limit for that sampling parameter,
irrespective of the fact what the user chooses.
<<SM physics: public>>=
public :: log_plus_distr
<<SM physics: procedures>>=
function log_plus_distr (x,eps) result (lpd)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: lpd, eps2
eps2 = min (eps, 0.1816_default)
if (x > (1.0_default - eps2)) then
lpd = ((log(eps2))**2 + two*Li2(eps2) - pi**2/three)/eps2
else
lpd = two*log((one-x)/x)/(one-x)
end if
end function log_plus_distr
@ %def log_plus_distr
@ Logarithmic $+$-distribution, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_+$.
<<SM physics: public>>=
public :: log2_plus_distr
<<SM physics: procedures>>=
function log2_plus_distr (x,eps) result (lpd)
real(kind=default), intent(in) :: x, eps
real(kind=default) :: lpd
if (x > (1.0_default - eps)) then
lpd = - (log(eps))**2/eps
else
lpd = two*log(one/(one-x))/(one-x)
end if
end function log2_plus_distr
@ %def log2_plus_distr
@ Logarithmic $+$-distribution with phase-space slicing parameter, $2
\left( \frac{\log(1/(1-x))}{1-x} \right)_{1-\alpha}$.
<<SM physics: public>>=
public :: log2_plus_distr_al
<<SM physics: procedures>>=
function log2_plus_distr_al (x,alpha,eps) result (lpd_al)
real(kind=default), intent(in) :: x, eps, alpha
real(kind=default) :: lpd_al
if ((one - alpha) >= (one - eps)) then
lpd_al = zero
call msg_fatal ('alpha and epsilon chosen wrongly')
elseif (x < (one - alpha)) then
lpd_al = 0
elseif (x > (1.0_default - eps)) then
lpd_al = - ((log(eps))**2 - (log(alpha))**2)/eps
else
lpd_al = two*log(one/(one-x))/(one-x)
end if
end function log2_plus_distr_al
@ %def log2_plus_distr_al
@
\subsection{Splitting Functions}
@ Analogue to the regularized distributions of the last subsection, we
give here the unregularized splitting functions, relevant for the parton
shower algorithm. We can use this unregularized version since there will
be a cut-off $\epsilon$ that ensures that $\{z,1-z\}>\epsilon(t)$. This
cut-off seperates resolvable from unresolvable emissions.
[[p_xxx]] are the kernels that are summed over helicity:
<<SM physics: public>>=
public :: p_qqg
public :: p_gqq
public :: p_ggg
@ $q\to q g$
<<SM physics: procedures>>=
elemental function p_qqg (z) result (P)
real(default), intent(in) :: z
real(default) :: P
P = CF * (one + z**2) / (one - z)
end function p_qqg
@ $g\to q \bar{q}$
<<SM physics: procedures>>=
elemental function p_gqq (z) result (P)
real(default), intent(in) :: z
real(default) :: P
P = TR * (z**2 + (one - z)**2)
end function p_gqq
@ $g\to g g$
<<SM physics: procedures>>=
elemental function p_ggg (z) result (P)
real(default), intent(in) :: z
real(default) :: P
P = NC * ((one - z) / z + z / (one - z) + z * (one - z))
end function p_ggg
@ %def p_qqg p_gqq p_ggg
@ Analytically integrated splitting kernels:
<<SM physics: public>>=
public :: integral_over_p_qqg
public :: integral_over_p_gqq
public :: integral_over_p_ggg
<<SM physics: procedures>>=
pure function integral_over_p_qqg (zmin, zmax) result (integral)
real(default), intent(in) :: zmin, zmax
real(default) :: integral
integral = (two / three) * (- zmax**2 + zmin**2 - &
two * (zmax - zmin) + four * log((one - zmin) / (one - zmax)))
end function integral_over_p_qqg
pure function integral_over_p_gqq (zmin, zmax) result (integral)
real(default), intent(in) :: zmin, zmax
real(default) :: integral
integral = 0.5_default * ((two / three) * &
(zmax**3 - zmin**3) - (zmax**2 - zmin**2) + (zmax - zmin))
end function integral_over_p_gqq
pure function integral_over_p_ggg (zmin, zmax) result (integral)
real(default), intent(in) :: zmin, zmax
real(default) :: integral
integral = three * ((log(zmax) - two * zmax - &
log(one - zmax) + zmax**2 / two - zmax**3 / three) - &
(log(zmin) - zmin - zmin - log(one - zmin) + zmin**2 &
/ two - zmin**3 / three) )
end function integral_over_p_ggg
@ %def integral_over_p_gqq integral_over_p_ggg integral_over_p_qqg
@ We can also use (massless) helicity dependent splitting functions:
<<SM physics: public>>=
public :: p_qqg_pol
@ $q_a\to q_b g_c$, the helicity of the quark is not changed by gluon
emission and the gluon is preferably polarized in the branching plane
($l_c=1$):
<<SM physics: procedures>>=
elemental function p_qqg_pol (z, l_a, l_b, l_c) result (P)
real(default), intent(in) :: z
integer, intent(in) :: l_a, l_b, l_c
real(default) :: P
if (l_a /= l_b) then
P = zero
return
end if
if (l_c == -1) then
P = one - z
else
P = (one + z)**2 / (one - z)
end if
P = P * CF
end function p_qqg_pol
@
\subsection{Top width}
In order to produce sensible results, the widths have to be recomputed
for each parameter and order.
We start with the LO-expression for the top width given by the decay
$t\,\to\,W^+,b$, cf. [[doi:10.1016/0550-3213(91)90530-B]]:\\
The analytic formula given there is
\begin{equation*}
\Gamma = \frac{G_F m_t^2}{16\sqrt{2}\pi}
\left[\mathcal{F}_0(\varepsilon, \xi^{-1/2}) -
\frac{2\alpha_s}{3\pi} \mathcal{F}_1 (\varepsilon, \xi^{-1/2})\right],
\end{equation*}
with
\begin{align*}
\mathcal{F}_0 &= \frac{\sqrt{\lambda}}{2} f_0, \\
f_0 &= 4\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 2w^4\right], \\
\lambda = 1 + w^4 + \varepsilon^4 - 2(w^2 + \varepsilon^2 + w^2\varepsilon^2).
\end{align*}
Defining
\begin{equation*}
u_q = \frac{1 + \varepsilon^2 - w^2 - \lambda^{1/2}}{1 +
\varepsilon^2 - w^2 + \lambda^{1/2}}
\end{equation*}
and
\begin{equation*}
u_w = \frac{1 - \varepsilon^2 + w^2 - \lambda^{1/2}}{1 -
\varepsilon^2 + w^2 + \lambda^{1/2}}
\end{equation*}
the factor $\mathcal{F}_1$ can be expressed as
\begin{align*}
\mathcal{F}_1 = \frac{1}{2}f_0(1+\varepsilon^2-w^2)
& \left[\pi^2 + 2Li_2(u_w) - 2Li_2(1-u_w) - 4Li_2(u_q) \right. \\
& -4Li_2(u_q u_w) + \log\left(\frac{1-u_q}{w^2}\right)\log(1-u_q)
- \log^2(1-u_q u_w) \\
& \left.+\frac{1}{4}\log^2\left(\frac{w^2}{u_w}\right) - \log(u_w)
\log\left[\frac{(1-u_q u_w)^2}{1-u_q}\right]
-2\log(u_q)\log\left[(1-u_q)(1-u_q u_w)\right]\right] \\
& -\sqrt{\lambda}f_0(2\log(w) + 3\log(\varepsilon) - 2\log{\lambda}) \\
& +4(1-\varepsilon^2)\left[(1-\varepsilon^2)^2 +
w^2(1+\varepsilon^2) - 4w^4\right]\log(u_w) \\
& \left[(3 - \varepsilon^2 + 11\varepsilon^4 - \varepsilon^6)
+ w^2(6 - 12\varepsilon^2 +2\varepsilon^4) - w^4(21 +
5\varepsilon^2) + 12w^6\right] \log(u_q) \\
& 6\sqrt{\lambda} (1-\varepsilon^2) (1 + \varepsilon^2 - w^2)
\log(\varepsilon)
+ \sqrt{\lambda}\left[-5 + 22\varepsilon^2 - 5\varepsilon^4 -
9w^2(1+\varepsilon^2) + 6w^4\right].
\end{align*}
@
<<SM physics: public>>=
public :: top_width_sm_lo
<<SM physics: procedures>>=
elemental function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) &
result (gamma)
real(default) :: gamma
real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb
real(default) :: kappa
kappa = sqrt ((mtop**2 - (mw + mb)**2) * (mtop**2 - (mw - mb)**2))
gamma = alpha / four * mtop / (two * sinthw**2) * &
vtb**2 * kappa / mtop**2 * &
((mtop**2 + mb**2) / (two * mtop**2) + &
(mtop**2 - mb**2)**2 / (two * mtop**2 * mw**2) - &
mw**2 / mtop**2)
end function top_width_sm_lo
@ %def top_width_sm_lo
@
<<SM physics: public>>=
public :: g_mu_from_alpha
<<SM physics: procedures>>=
elemental function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu)
real(default) :: g_mu
real(default), intent(in) :: alpha, mw, sinthw
g_mu = pi * alpha / sqrt(two) / mw**2 / sinthw**2
end function g_mu_from_alpha
@ %def g_mu_from_alpha
@
<<SM physics: public>>=
public :: alpha_from_g_mu
<<SM physics: procedures>>=
elemental function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha)
real(default) :: alpha
real(default), intent(in) :: g_mu, mw, sinthw
alpha = g_mu * sqrt(two) / pi * mw**2 * sinthw**2
end function alpha_from_g_mu
@ %def alpha_from_g_mu
@ Cf. (3.3)-(3.7) in [[1207.5018]].
<<SM physics: public>>=
public :: top_width_sm_qcd_nlo_massless_b
<<SM physics: procedures>>=
elemental function top_width_sm_qcd_nlo_massless_b &
(alpha, sinthw, vtb, mtop, mw, alphas) result (gamma)
real(default) :: gamma
real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas
real(default) :: prefac, g_mu, w2
g_mu = g_mu_from_alpha (alpha, mw, sinthw)
prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi)
w2 = mw**2 / mtop**2
gamma = prefac * (f0 (w2) - (two * alphas) / (3 * Pi) * f1 (w2))
end function top_width_sm_qcd_nlo_massless_b
@ %def top_width_sm_qcd_nlo_massless_b
@
<<SM physics: public>>=
public :: f0
<<SM physics: procedures>>=
elemental function f0 (w2) result (f)
real(default) :: f
real(default), intent(in) :: w2
f = two * (one - w2)**2 * (1 + 2 * w2)
end function f0
@ %def f0
@
<<SM physics: public>>=
public :: f1
<<SM physics: procedures>>=
elemental function f1 (w2) result (f)
real(default) :: f
real(default), intent(in) :: w2
f = f0 (w2) * (pi**2 + two * Li2 (w2) - two * Li2 (one - w2)) &
+ four * w2 * (one - w2 - two * w2**2) * log (w2) &
+ two * (one - w2)**2 * (five + four * w2) * log (one - w2) &
- (one - w2) * (five + 9 * w2 - 6 * w2**2)
end function f1
@ %def f1
@ Basically, the same as above but with $m_b$ dependence,
cf. Jezabek / Kuehn 1989.
<<SM physics: public>>=
public :: top_width_sm_qcd_nlo_jk
<<SM physics: procedures>>=
elemental function top_width_sm_qcd_nlo_jk &
(alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma)
real(default) :: gamma
real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas
real(default) :: prefac, g_mu, eps2, i_xi
g_mu = g_mu_from_alpha (alpha, mw, sinthw)
prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi)
eps2 = (mb / mtop)**2
i_xi = (mw / mtop)**2
gamma = prefac * (ff0 (eps2, i_xi) - &
(two * alphas) / (3 * Pi) * ff1 (eps2, i_xi))
end function top_width_sm_qcd_nlo_jk
@ %def top_width_sm_qcd_nlo_jk
@ Same as above, $m_b > 0$, with the slightly different implementation
(2.6) of arXiv:1204.1513v1 by Campbell and Ellis.
<<SM physics: public>>=
public :: top_width_sm_qcd_nlo_ce
<<SM physics: procedures>>=
elemental function top_width_sm_qcd_nlo_ce &
(alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma)
real(default) :: gamma
real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s
real(default) :: pm, pp, p0, p3
real(default) :: yw, yp
real(default) :: W0, Wp, Wm, w2
real(default) :: beta2
real(default) :: f
real(default) :: g_mu, gamma0
beta2 = (mb / mtop)**2
w2 = (mw / mtop)**2
p0 = (one - w2 + beta2) / two
p3 = sqrt (lambda (one, w2, beta2)) / two
pp = p0 + p3
pm = p0 - p3
W0 = (one + w2 - beta2) / two
Wp = W0 + p3
Wm = W0 - p3
yp = log (pp / pm) / two
yw = log (Wp / Wm) / two
f = (one - beta2)**2 + w2 * (one + beta2) - two * w2**2
g_mu = g_mu_from_alpha (alpha, mw, sinthw)
gamma0 = g_mu * mtop**3 * vtb**2 / (8 * pi * sqrt(two))
gamma = gamma0 * alpha_s / twopi * CF * &
(8 * f * p0 * (Li2(one - pm) - Li2(one - pp) - two * Li2(one - pm / pp) &
+ yp * log((four * p3**2) / (pp**2 * Wp)) + yw * log (pp)) &
+ four * (one - beta2) * ((one - beta2)**2 + w2 * (one + beta2) - four * w2**2) * yw &
+ (3 - beta2 + 11 * beta2**2 - beta2**3 + w2 * (6 - 12 * beta2 + two * beta2**2) &
- w2**2 * (21 + 5 * beta2) + 12 * w2**3) * yp &
+ 8 * f * p3 * log (sqrt(w2) / (four * p3**2)) &
+ 6 * (one - four * beta2 + 3 * beta2**2 + w2 * (3 + beta2) - four * w2**2) * p3 * log(sqrt(beta2)) &
+ (5 - 22 * beta2 + 5 * beta2**2 + 9 * w2 * (one + beta2) - 6 * w2**2) * p3)
end function top_width_sm_qcd_nlo_ce
@ %def top_width_sm_qcd_nlo_ce
@
<<SM physics: public>>=
public :: ff0
<<SM physics: procedures>>=
elemental function ff0 (eps2, w2) result (f)
real(default) :: f
real(default), intent(in) :: eps2, w2
f = one / two * sqrt(ff_lambda (eps2, w2)) * ff_f0 (eps2, w2)
end function ff0
@ %def ff0
@
<<SM physics: public>>=
public :: ff_f0
<<SM physics: procedures>>=
elemental function ff_f0 (eps2, w2) result (f)
real(default) :: f
real(default), intent(in) :: eps2, w2
f = four * ((1 - eps2)**2 + w2 * (1 + eps2) - 2 * w2**2)
end function ff_f0
@ %def ff_f0
@
<<SM physics: public>>=
public :: ff_lambda
<<SM physics: procedures>>=
elemental function ff_lambda (eps2, w2) result (l)
real(default) :: l
real(default), intent(in) :: eps2, w2
l = one + w2**2 + eps2**2 - two * (w2 + eps2 + w2 * eps2)
end function ff_lambda
@ %def ff_lambda
@
<<SM physics: public>>=
public :: ff1
<<SM physics: procedures>>=
elemental function ff1 (eps2, w2) result (f)
real(default) :: f
real(default), intent(in) :: eps2, w2
real(default) :: uq, uw, sq_lam, fff
sq_lam = sqrt (ff_lambda (eps2, w2))
fff = ff_f0 (eps2, w2)
uw = (one - eps2 + w2 - sq_lam) / &
(one - eps2 + w2 + sq_lam)
uq = (one + eps2 - w2 - sq_lam) / &
(one + eps2 - w2 + sq_lam)
f = one / two * fff * (one + eps2 - w2) * &
(pi**2 + two * Li2 (uw) - two * Li2 (one - uw) - four * Li2 (uq) &
- four * Li2 (uq * uw) + log ((one - uq) / w2) * log (one - uq) &
- log (one - uq * uw)**2 + one / four * log (w2 / uw)**2 &
- log (uw) * log ((one - uq * uw)**2 / (one - uq)) &
- two * log (uq) * log ((one - uq) * (one - uq * uw))) &
- sq_lam * fff * (two * log (sqrt (w2)) &
+ three * log (sqrt (eps2)) - two * log (sq_lam**2)) &
+ four * (one - eps2) * ((one - eps2)**2 + w2 * (one + eps2) &
- four * w2**2) * log (uw) &
+ (three - eps2 + 11 * eps2**2 - eps2**3 + w2 * &
(6 - 12 * eps2 + 2 * eps2**2) - w2**2 * (21 + five * eps2) &
+ 12 * w2**3) * log (uq) &
+ 6 * sq_lam * (one - eps2) * &
(one + eps2 - w2) * log (sqrt (eps2)) &
+ sq_lam * (- five + 22 * eps2 - five * eps2**2 - 9 * w2 * &
(one + eps2) + 6 * w2**2)
end function ff1
@ %def ff1
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[sm_physics_ut.f90]]>>=
<<File header>>
module sm_physics_ut
use unit_tests
use sm_physics_uti
<<Standard module head>>
<<SM physics: public test>>
contains
<<SM physics: test driver>>
end module sm_physics_ut
@ %def sm_physics_ut
@
<<[[sm_physics_uti.f90]]>>=
<<File header>>
module sm_physics_uti
<<Use kinds>>
use numeric_utils
use format_defs, only: FMT_15
use constants
use sm_physics
<<Standard module head>>
<<SM physics: test declarations>>
contains
<<SM physics: tests>>
end module sm_physics_uti
@ %def sm_physics_ut
@ API: driver for the unit tests below.
<<SM physics: public test>>=
public :: sm_physics_test
<<SM physics: test driver>>=
subroutine sm_physics_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SM physics: execute tests>>
end subroutine sm_physics_test
@ %def sm_physics_test
@
\subsubsection{Splitting functions}
<<SM physics: execute tests>>=
call test (sm_physics_1, "sm_physics_1", &
"Splitting functions", &
u, results)
<<SM physics: test declarations>>=
public :: sm_physics_1
<<SM physics: tests>>=
subroutine sm_physics_1 (u)
integer, intent(in) :: u
real(default) :: z = 0.75_default
write (u, "(A)") "* Test output: sm_physics_1"
write (u, "(A)") "* Purpose: check analytic properties"
write (u, "(A)")
write (u, "(A)") "* Splitting functions:"
write (u, "(A)")
call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)), "+-+")
call assert (u, vanishes (p_qqg_pol (z, +1, -1, -1)), "+--")
call assert (u, vanishes (p_qqg_pol (z, -1, +1, +1)), "-++")
call assert (u, vanishes (p_qqg_pol (z, -1, +1, -1)), "-+-")
!call assert (u, nearly_equal ( &
!p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), &
!p_qqg (z)), "pol sum")
write (u, "(A)")
write (u, "(A)") "* Test output end: sm_physics_1"
end subroutine sm_physics_1
@ %def sm_physics_1
@
\subsubsection{Top width}
<<SM physics: execute tests>>=
call test(sm_physics_2, "sm_physics_2", &
"Top width", u, results)
<<SM physics: test declarations>>=
public :: sm_physics_2
<<SM physics: tests>>=
subroutine sm_physics_2 (u)
integer, intent(in) :: u
real(default) :: mtop, mw, mz, mb, g_mu, sinthw, alpha, vtb, gamma0
real(default) :: w2, alphas, alphas_mz, gamma1
write (u, "(A)") "* Test output: sm_physics_2"
write (u, "(A)") "* Purpose: Check different top width computations"
write (u, "(A)")
write (u, "(A)") "* Values from [[1207.5018]] (massless b)"
mtop = 172.0
mw = 80.399
mz = 91.1876
mb = zero
mb = 0.00001
g_mu = 1.16637E-5
sinthw = sqrt(one - mw**2 / mz**2)
alpha = alpha_from_g_mu (g_mu, mw, sinthw)
vtb = one
w2 = mw**2 / mtop**2
write (u, "(A)") "* Check Li2 implementation"
call assert_equal (u, Li2(w2), 0.2317566263959552_default, &
"Li2(w2)", rel_smallness=1.0E-6_default)
call assert_equal (u, Li2(one - w2), 1.038200378935867_default, &
"Li2(one - w2)", rel_smallness=1.0E-6_default)
write (u, "(A)") "* Check LO Width"
gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb)
call assert_equal (u, gamma0, 1.4655_default, &
"top_width_sm_lo", rel_smallness=1.0E-5_default)
alphas = zero
gamma0 = top_width_sm_qcd_nlo_massless_b &
(alpha, sinthw, vtb, mtop, mw, alphas)
call assert_equal (u, gamma0, 1.4655_default, &
"top_width_sm_qcd_nlo_massless_b", rel_smallness=1.0E-5_default)
gamma0 = top_width_sm_qcd_nlo_jk &
(alpha, sinthw, vtb, mtop, mw, mb, alphas)
call assert_equal (u, gamma0, 1.4655_default, &
"top_width_sm_qcd_nlo", rel_smallness=1.0E-5_default)
write (u, "(A)") "* Check NLO Width"
alphas_mz = 0.1202 ! MSTW2008 NLO fit
alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default)
gamma1 = top_width_sm_qcd_nlo_massless_b &
(alpha, sinthw, vtb, mtop, mw, alphas)
call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-4_default)
gamma1 = top_width_sm_qcd_nlo_jk &
(alpha, sinthw, vtb, mtop, mw, mb, alphas)
! It would be nice to get one more significant digit but the
! expression is numerically rather unstable for mb -> 0
call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-3_default)
write (u, "(A)") "* Values from threshold validation (massive b)"
alpha = one / 125.924
! ee = 0.315901
! cw = 0.881903
! v = 240.024
mtop = 172.0 ! This is the value for M1S !!!
mb = 4.2
sinthw = 0.47143
mz = 91.188
mw = 80.419
call assert_equal (u, sqrt(one - mw**2 / mz**2), sinthw, &
"sinthw", rel_smallness=1.0E-6_default)
write (u, "(A)") "* Check LO Width"
gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb)
call assert_equal (u, gamma0, 1.5386446_default, &
"gamma0", rel_smallness=1.0E-7_default)
alphas = zero
gamma0 = top_width_sm_qcd_nlo_jk &
(alpha, sinthw, vtb, mtop, mw, mb, alphas)
call assert_equal (u, gamma0, 1.5386446_default, &
"gamma0", rel_smallness=1.0E-7_default)
write (u, "(A)") "* Check NLO Width"
alphas_mz = 0.118 !(Z pole, NLL running to mu_h)
alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default)
write (u, "(A," // FMT_15 // ")") "* alphas = ", alphas
gamma1 = top_width_sm_qcd_nlo_jk &
(alpha, sinthw, vtb, mtop, mw, mb, alphas)
write (u, "(A," // FMT_15 // ")") "* Gamma1 = ", gamma1
mb = zero
gamma1 = top_width_sm_qcd_nlo_massless_b &
(alpha, sinthw, vtb, mtop, mw, alphas)
alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default)
write (u, "(A," // FMT_15 // ")") "* Gamma1(mb=0) = ", gamma1
write (u, "(A)")
write (u, "(A)") "* Test output end: sm_physics_2"
end subroutine sm_physics_2
@ %def sm_physics_2
@
+\subsubsection{Special functions}
+<<SM physics: execute tests>>=
+ call test (sm_physics_3, "sm_physics_3", &
+ "Special functions", &
+ u, results)
+<<SM physics: test declarations>>=
+ public :: sm_physics_3
+<<SM physics: tests>>=
+ subroutine sm_physics_3 (u)
+ integer, intent(in) :: u
+ complex(default) :: z1 = (0.75_default, 1.25_default)
+ complex(default) :: z2 = (1.33_default, 11.25_default)
+ complex(default) :: psiz
+
+ write (u, "(A)") "* Test output: sm_physics_3"
+ write (u, "(A)") "* Purpose: check special functions"
+ write (u, "(A)")
+
+ write (u, "(A)") "* Complex digamma function:"
+ write (u, "(A)")
+
+ psiz = psic (z1)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", &
+ real(z1), aimag(z1)
+ write (u, "(1x,A,'(',F7.5,',',F7.5,')')") " psi(z1) = ", &
+ real(psiz), aimag(psiz)
+ psiz = psic (z2)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", &
+ real(z2), aimag(z2)
+ write (u, "(1x,A,'(',F7.5,',',F7.5,')')") " psi(z2) = ", &
+ real(psiz), aimag(psiz)
+
+ write (u, "(A)")
+ write (u, "(A)") "* Complex polygamma function:"
+ write (u, "(A)")
+
+ psiz = psim (z1,1)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", &
+ real(z1), aimag(z1)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,1) = ", &
+ real(psiz), aimag(psiz)
+ psiz = psim (z2,1)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", &
+ real(z2), aimag(z2)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,1) = ", &
+ real(psiz), aimag(psiz)
+
+ write (u, "(A)")
+
+ psiz = psim (z1,2)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", &
+ real(z1), aimag(z1)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,2) = ", &
+ real(psiz), aimag(psiz)
+ psiz = psim (z2,2)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", &
+ real(z2), aimag(z2)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,2) = ", &
+ real(psiz), aimag(psiz)
+
+ write (u, "(A)")
+
+ psiz = psim (z1,3)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", &
+ real(z1), aimag(z1)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,3) = ", &
+ real(psiz), aimag(psiz)
+ psiz = psim (z2,3)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", &
+ real(z2), aimag(z2)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,3) = ", &
+ real(psiz), aimag(psiz)
+
+ write (u, "(A)")
+
+ psiz = psim (z1,4)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", &
+ real(z1), aimag(z1)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,4) = ", &
+ real(psiz), aimag(psiz)
+ psiz = psim (z2,4)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", &
+ real(z2), aimag(z2)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,4) = ", &
+ real(psiz), aimag(psiz)
+
+ write (u, "(A)")
+
+ psiz = psim (z1,5)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", &
+ real(z1), aimag(z1)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,5) = ", &
+ real(psiz), aimag(psiz)
+ psiz = psim (z2,5)
+ write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", &
+ real(z2), aimag(z2)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,5) = ", &
+ real(psiz), aimag(psiz)
+
+ write (u, "(A)")
+ write (u, "(A)") "* Generalized Nielsen polylogarithm:"
+ write (u, "(A)")
+
+ write (u, "(1x,A,F8.5)") " S(1,1,0) = ", &
+ nielsen(1,1,0._default)
+ write (u, "(1x,A,F8.5)") " S(1,1,-1) = ", &
+ nielsen(1,1,-1._default)
+ write (u, "(1x,A,F8.5)") " S(1,2,-1) = ", &
+ nielsen(1,2,-1._default)
+ write (u, "(1x,A,F8.5)") " S(2,1,-1) = ", &
+ nielsen(2,1,-1._default)
+ write (u, "(1x,A,F8.5)") " S(1,3,-1) = ", &
+ nielsen(1,3,-1._default)
+ write (u, "(1x,A,F8.5)") " S(2,2,-1) = ", &
+ nielsen(2,2,-1._default)
+ write (u, "(1x,A,F8.5)") " S(3,1,-1) = ", &
+ nielsen(3,1,-1._default)
+ write (u, "(1x,A,F8.5)") " S(1,4,-1) = ", &
+ nielsen(1,4,-1._default)
+ write (u, "(1x,A,F8.5)") " S(2,3,-1) = ", &
+ nielsen(2,3,-1._default)
+ write (u, "(1x,A,F8.5)") " S(3,2,-1) = ", &
+ nielsen(3,2,-1._default)
+ write (u, "(1x,A,F8.5)") " S(4,1,-1) = ", &
+ nielsen(4,1,-1._default)
+ write (u, "(1x,A,F8.5)") " S(1,1,0.2) = ", &
+ nielsen(1,1,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(1,2,0.2) = ", &
+ nielsen(1,2,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(2,1,0.2) = ", &
+ nielsen(2,1,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(1,3,0.2) = ", &
+ nielsen(1,3,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(2,2,0.2) = ", &
+ nielsen(2,2,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(3,1,0.2) = ", &
+ nielsen(3,1,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(1,4,0.2) = ", &
+ nielsen(1,4,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(2,3,0.2) = ", &
+ nielsen(2,3,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(3,2,0.2) = ", &
+ nielsen(3,2,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(4,1,0.2) = ", &
+ nielsen(4,1,0.2_default)
+ write (u, "(1x,A,F8.5)") " S(1,1,1) = ", &
+ nielsen(1,1,1._default)
+ write (u, "(1x,A,F8.5)") " S(1,2,1) = ", &
+ nielsen(1,2,1._default)
+ write (u, "(1x,A,F8.5)") " S(2,1,1) = ", &
+ nielsen(2,1,1._default)
+ write (u, "(1x,A,F8.5)") " S(1,3,1) = ", &
+ nielsen(1,3,1._default)
+ write (u, "(1x,A,F8.5)") " S(2,2,1) = ", &
+ nielsen(2,2,1._default)
+ write (u, "(1x,A,F8.5)") " S(3,1,1) = ", &
+ nielsen(3,1,1._default)
+ write (u, "(1x,A,F8.5)") " S(1,4,1) = ", &
+ nielsen(1,4,1._default)
+ write (u, "(1x,A,F8.5)") " S(2,3,1) = ", &
+ nielsen(2,3,1._default)
+ write (u, "(1x,A,F8.5)") " S(3,2,1) = ", &
+ nielsen(3,2,1._default)
+ write (u, "(1x,A,F8.5)") " S(4,1,1) = ", &
+ nielsen(4,1,1._default)
+ write (u, "(1x,A,F8.5)") " S(1,1,0.75) = ", &
+ nielsen(1,1,0.75_default)
+ write (u, "(1x,A,F8.5)") " S(1,3,0.75) = ", &
+ nielsen(1,3,0.75_default)
+ write (u, "(1x,A,F8.5)") " S(1,4,0.75) = ", &
+ nielsen(1,4,0.75_default)
+ write (u, "(1x,A,F8.5)") " S(2,2,0.75) = ", &
+ nielsen(2,2,0.75_default)
+ write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " S(1,1,2) = ", &
+ real(cnielsen(1,1,3._default)), &
+ aimag(cnielsen(1,1,3._default))
+
+ write (u, "(A)")
+ write (u, "(A)") "* Dilog, trilog, polylog:"
+ write (u, "(A)")
+
+ write (u, "(1x,A,F8.5)") " Li2(0.66) = ", &
+ dilog(0.66_default)
+ write (u, "(1x,A,F8.5)") " Li3(0.66) = ", &
+ trilog(0.66_default)
+ write (u, "(1x,A,F8.5)") " Poly(4,0.66) = ", &
+ polylog(4,0.66_default)
+
+ write (u, "(A)")
+ write (u, "(A)") "* Test output end: sm_physics_3"
+
+ end subroutine sm_physics_3
+
+@ %def sm_physics_3
+@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{QCD Coupling}
We provide various distinct implementations of the QCD coupling. In
this module, we define an abstract data type and three
implementations: fixed, running with $\alpha_s(M_Z)$ as input, and
running with $\Lambda_{\text{QCD}}$ as input. We use the functions
defined above in the module [[sm_physics]] but provide a common
interface. Later modules may define additional implementations.
<<[[sm_qcd.f90]]>>=
<<File header>>
module sm_qcd
<<Use kinds>>
use io_units
use format_defs, only: FMT_12
use numeric_utils
use diagnostics
use md5
use physics_defs
use sm_physics
<<Standard module head>>
<<SM qcd: public>>
<<SM qcd: types>>
<<SM qcd: interfaces>>
contains
<<SM qcd: procedures>>
end module sm_qcd
@ %def sm_qcd
@
\subsection{Coupling: Abstract Data Type}
This is the abstract version of the QCD coupling implementation.
<<SM qcd: public>>=
public :: alpha_qcd_t
<<SM qcd: types>>=
type, abstract :: alpha_qcd_t
contains
<<SM qcd: alpha qcd: TBP>>
end type alpha_qcd_t
@ %def alpha_qcd_t
@ There must be an output routine.
<<SM qcd: alpha qcd: TBP>>=
procedure (alpha_qcd_write), deferred :: write
<<SM qcd: interfaces>>=
abstract interface
subroutine alpha_qcd_write (object, unit)
import
class(alpha_qcd_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine alpha_qcd_write
end interface
@ %def alpha_qcd_write
@ This method computes the running coupling, given a certain scale. All
parameters (reference value, order of the approximation, etc.) must be
set before calling this.
<<SM qcd: alpha qcd: TBP>>=
procedure (alpha_qcd_get), deferred :: get
<<SM qcd: interfaces>>=
abstract interface
function alpha_qcd_get (alpha_qcd, scale) result (alpha)
import
class(alpha_qcd_t), intent(in) :: alpha_qcd
real(default), intent(in) :: scale
real(default) :: alpha
end function alpha_qcd_get
end interface
@ %def alpha_qcd_get
@
\subsection{Fixed Coupling}
In this version, the $\alpha_s$ value is fixed, the [[scale]] argument
of the [[get]] method is ignored. There is only one parameter, the
value. By default, this is the value at $M_Z$.
<<SM qcd: public>>=
public :: alpha_qcd_fixed_t
<<SM qcd: types>>=
type, extends (alpha_qcd_t) :: alpha_qcd_fixed_t
real(default) :: val = ALPHA_QCD_MZ_REF
contains
<<SM qcd: alpha qcd fixed: TBP>>
end type alpha_qcd_fixed_t
@ %def alpha_qcd_fixed_t
@ Output.
<<SM qcd: alpha qcd fixed: TBP>>=
procedure :: write => alpha_qcd_fixed_write
<<SM qcd: procedures>>=
subroutine alpha_qcd_fixed_write (object, unit)
class(alpha_qcd_fixed_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A)") "QCD parameters (fixed coupling):"
write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val
end subroutine alpha_qcd_fixed_write
@ %def alpha_qcd_fixed_write
@ Calculation: the scale is ignored in this case.
<<SM qcd: alpha qcd fixed: TBP>>=
procedure :: get => alpha_qcd_fixed_get
<<SM qcd: procedures>>=
function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha)
class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd
real(default), intent(in) :: scale
real(default) :: alpha
alpha = alpha_qcd%val
end function alpha_qcd_fixed_get
@ %def alpha_qcd_fixed_get
@
\subsection{Running Coupling}
In this version, the $\alpha_s$ value runs relative to the value at a
given reference scale. There are two parameters: the value of this
scale (default: $M_Z$), the value of $\alpha_s$ at this scale, and the
number of effective flavors. Furthermore, we have the order of the
approximation.
<<SM qcd: public>>=
public :: alpha_qcd_from_scale_t
<<SM qcd: types>>=
type, extends (alpha_qcd_t) :: alpha_qcd_from_scale_t
real(default) :: mu_ref = MZ_REF
real(default) :: ref = ALPHA_QCD_MZ_REF
integer :: order = 0
integer :: nf = 5
contains
<<SM qcd: alpha qcd from scale: TBP>>
end type alpha_qcd_from_scale_t
@ %def alpha_qcd_from_scale_t
@ Output.
<<SM qcd: alpha qcd from scale: TBP>>=
procedure :: write => alpha_qcd_from_scale_write
<<SM qcd: procedures>>=
subroutine alpha_qcd_from_scale_write (object, unit)
class(alpha_qcd_from_scale_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A)") "QCD parameters (running coupling):"
write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref
write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref
write (u, "(5x,A,I0)") "LL order = ", object%order
write (u, "(5x,A,I0)") "N(flv) = ", object%nf
end subroutine alpha_qcd_from_scale_write
@ %def alpha_qcd_from_scale_write
@ Calculation: here, we call the function for running $\alpha_s$ that
was defined in [[sm_physics]] above. The function does not take into
account thresholds, so the number of flavors should be the correct one
for the chosen scale. Normally, this should be the $Z$ boson mass.
<<SM qcd: alpha qcd from scale: TBP>>=
procedure :: get => alpha_qcd_from_scale_get
<<SM qcd: procedures>>=
function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha)
class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd
real(default), intent(in) :: scale
real(default) :: alpha
alpha = running_as (scale, alpha_qcd%ref, alpha_qcd%mu_ref, &
alpha_qcd%order, real (alpha_qcd%nf, kind=default))
end function alpha_qcd_from_scale_get
@ %def alpha_qcd_from_scale_get
@
\subsection{Running Coupling, determined by $\Lambda_{\text{QCD}}$}
In this version, the inputs are the value $\Lambda_{\text{QCD}}$ and
the order of the approximation.
<<SM qcd: public>>=
public :: alpha_qcd_from_lambda_t
<<SM qcd: types>>=
type, extends (alpha_qcd_t) :: alpha_qcd_from_lambda_t
real(default) :: lambda = LAMBDA_QCD_REF
integer :: order = 0
integer :: nf = 5
contains
<<SM qcd: alpha qcd from lambda: TBP>>
end type alpha_qcd_from_lambda_t
@ %def alpha_qcd_from_lambda_t
@ Output.
<<SM qcd: alpha qcd from lambda: TBP>>=
procedure :: write => alpha_qcd_from_lambda_write
<<SM qcd: procedures>>=
subroutine alpha_qcd_from_lambda_write (object, unit)
class(alpha_qcd_from_lambda_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A)") "QCD parameters (Lambda_QCD as input):"
write (u, "(5x,A," // FMT_12 // ")") "Lambda_QCD = ", object%lambda
write (u, "(5x,A,I0)") "LL order = ", object%order
write (u, "(5x,A,I0)") "N(flv) = ", object%nf
end subroutine alpha_qcd_from_lambda_write
@ %def alpha_qcd_from_lambda_write
@ Calculation: here, we call the second function for running $\alpha_s$ that
was defined in [[sm_physics]] above. The $\Lambda$ value should be
the one that is appropriate for the chosen number of effective
flavors. Again, thresholds are not incorporated.
<<SM qcd: alpha qcd from lambda: TBP>>=
procedure :: get => alpha_qcd_from_lambda_get
<<SM qcd: procedures>>=
function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha)
class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd
real(default), intent(in) :: scale
real(default) :: alpha
alpha = running_as_lam (real (alpha_qcd%nf, kind=default), scale, &
alpha_qcd%lambda, alpha_qcd%order)
end function alpha_qcd_from_lambda_get
@ %def alpha_qcd_from_lambda_get
@
\subsection{QCD Wrapper type}
We could get along with a polymorphic QCD type, but a monomorphic wrapper type
with a polymorphic component is easier to handle and probably safer
(w.r.t.\ compiler bugs). However, we keep the object transparent, so we can
set the type-specific parameters directly (by a [[dispatch]] routine).
<<SM qcd: public>>=
public :: qcd_t
<<SM qcd: types>>=
type :: qcd_t
class(alpha_qcd_t), allocatable :: alpha
character(32) :: md5sum = ""
integer :: n_f = -1
contains
<<SM qcd: qcd: TBP>>
end type qcd_t
@ %def qcd_t
@ Output. We first print the polymorphic [[alpha]] which contains a headline,
then any extra components.
<<SM qcd: qcd: TBP>>=
procedure :: write => qcd_write
<<SM qcd: procedures>>=
subroutine qcd_write (qcd, unit, show_md5sum)
class(qcd_t), intent(in) :: qcd
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_md5sum
logical :: show_md5
integer :: u
u = given_output_unit (unit); if (u < 0) return
show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum
if (allocated (qcd%alpha)) then
call qcd%alpha%write (u)
else
write (u, "(3x,A)") "QCD parameters (coupling undefined)"
end if
if (show_md5 .and. qcd%md5sum /= "") &
write (u, "(5x,A,A,A)") "md5sum = '", qcd%md5sum, "'"
end subroutine qcd_write
@ %def qcd_write
@ Compute an MD5 sum for the [[alpha_s]] setup. This is
done by writing them to a temporary file, using a standard format.
<<SM qcd: qcd: TBP>>=
procedure :: compute_alphas_md5sum => qcd_compute_alphas_md5sum
<<SM qcd: procedures>>=
subroutine qcd_compute_alphas_md5sum (qcd)
class(qcd_t), intent(inout) :: qcd
integer :: unit
if (allocated (qcd%alpha)) then
unit = free_unit ()
open (unit, status="scratch", action="readwrite")
call qcd%alpha%write (unit)
rewind (unit)
qcd%md5sum = md5sum (unit)
close (unit)
end if
end subroutine qcd_compute_alphas_md5sum
@ %def qcd_compute_alphas_md5sum
@
@ Retrieve the MD5 sum of the qcd setup.
<<SM qcd: qcd: TBP>>=
procedure :: get_md5sum => qcd_get_md5sum
<<SM qcd: procedures>>=
function qcd_get_md5sum (qcd) result (md5sum)
character(32) :: md5sum
class(qcd_t), intent(inout) :: qcd
md5sum = qcd%md5sum
end function qcd_get_md5sum
@ %def qcd_get_md5sum
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[sm_qcd_ut.f90]]>>=
<<File header>>
module sm_qcd_ut
use unit_tests
use sm_qcd_uti
<<Standard module head>>
<<SM qcd: public test>>
contains
<<SM qcd: test driver>>
end module sm_qcd_ut
@ %def sm_qcd_ut
@
<<[[sm_qcd_uti.f90]]>>=
<<File header>>
module sm_qcd_uti
<<Use kinds>>
use physics_defs, only: MZ_REF
use sm_qcd
<<Standard module head>>
<<SM qcd: test declarations>>
contains
<<SM qcd: tests>>
end module sm_qcd_uti
@ %def sm_qcd_ut
@ API: driver for the unit tests below.
<<SM qcd: public test>>=
public :: sm_qcd_test
<<SM qcd: test driver>>=
subroutine sm_qcd_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SM qcd: execute tests>>
end subroutine sm_qcd_test
@ %def sm_qcd_test
@
\subsubsection{QCD Coupling}
We check two different implementations of the abstract QCD coupling.
<<SM qcd: execute tests>>=
call test (sm_qcd_1, "sm_qcd_1", &
"running alpha_s", &
u, results)
<<SM qcd: test declarations>>=
public :: sm_qcd_1
<<SM qcd: tests>>=
subroutine sm_qcd_1 (u)
integer, intent(in) :: u
type(qcd_t) :: qcd
write (u, "(A)") "* Test output: sm_qcd_1"
write (u, "(A)") "* Purpose: compute running alpha_s"
write (u, "(A)")
write (u, "(A)") "* Fixed:"
write (u, "(A)")
allocate (alpha_qcd_fixed_t :: qcd%alpha)
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, *)
deallocate (qcd%alpha)
write (u, "(A)") "* Running from MZ (LO):"
write (u, "(A)")
allocate (alpha_qcd_from_scale_t :: qcd%alpha)
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, *)
write (u, "(A)") "* Running from MZ (NLO):"
write (u, "(A)")
select type (alpha => qcd%alpha)
type is (alpha_qcd_from_scale_t)
alpha%order = 1
end select
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, *)
write (u, "(A)") "* Running from MZ (NNLO):"
write (u, "(A)")
select type (alpha => qcd%alpha)
type is (alpha_qcd_from_scale_t)
alpha%order = 2
end select
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, *)
deallocate (qcd%alpha)
write (u, "(A)") "* Running from Lambda_QCD (LO):"
write (u, "(A)")
allocate (alpha_qcd_from_lambda_t :: qcd%alpha)
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, *)
write (u, "(A)") "* Running from Lambda_QCD (NLO):"
write (u, "(A)")
select type (alpha => qcd%alpha)
type is (alpha_qcd_from_lambda_t)
alpha%order = 1
end select
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, *)
write (u, "(A)") "* Running from Lambda_QCD (NNLO):"
write (u, "(A)")
select type (alpha => qcd%alpha)
type is (alpha_qcd_from_lambda_t)
alpha%order = 2
end select
call qcd%compute_alphas_md5sum ()
call qcd%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha_s (mz) =", &
qcd%alpha%get (MZ_REF)
write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", &
qcd%alpha%get (1000._default)
write (u, "(A)")
write (u, "(A)") "* Test output end: sm_qcd_1"
end subroutine sm_qcd_1
@ %def sm_qcd_1
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{QED Coupling}
On the surface similar to the QCD coupling module but much simpler.
Only a fixed QED couping $\alpha_\text{em}$ is allowed.
Can be extended later if we want to enable a running of
$\alpha_\text{em}$ as well.
<<[[sm_qed.f90]]>>=
<<File header>>
module sm_qed
<<Use kinds>>
use io_units
use format_defs, only: FMT_12
use md5
use physics_defs
use sm_physics
<<Standard module head>>
<<SM qed: public>>
<<SM qed: types>>
<<SM qed: interfaces>>
contains
<<SM qed: procedures>>
end module sm_qed
@ %def sm_qed
@
\subsection{Coupling: Abstract Data Type}
This is the abstract version of the QCD coupling implementation.
<<SM qed: public>>=
public :: alpha_qed_t
<<SM qed: types>>=
type, abstract :: alpha_qed_t
contains
<<SM qed: alpha qed: TBP>>
end type alpha_qed_t
@ %def alpha_qed_t
@ There must be an output routine.
<<SM qed: alpha qed: TBP>>=
procedure (alpha_qed_write), deferred :: write
<<SM qed: interfaces>>=
abstract interface
subroutine alpha_qed_write (object, unit)
import
class(alpha_qed_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine alpha_qed_write
end interface
@ %def alpha_qed_write
@ This method computes the running coupling, given a certain scale. All
parameters (reference value, order of the approximation, etc.) must be
set before calling this.
<<SM qed: alpha qed: TBP>>=
procedure (alpha_qed_get), deferred :: get
<<SM qed: interfaces>>=
abstract interface
function alpha_qed_get (alpha_qed, scale) result (alpha)
import
class(alpha_qed_t), intent(in) :: alpha_qed
real(default), intent(in) :: scale
real(default) :: alpha
end function alpha_qed_get
end interface
@ %def alpha_qed_get
@
\subsection{Fixed Coupling}
In this version, the $\alpha$ value is fixed, the [[scale]] argument
of the [[get]] method is ignored. There is only one parameter, the
value. The default depends on the electroweak scheme chosen in the
model.
<<SM qed: public>>=
public :: alpha_qed_fixed_t
<<SM qed: types>>=
type, extends (alpha_qed_t) :: alpha_qed_fixed_t
real(default) :: val = ALPHA_QED_ME_REF
contains
<<SM qed: alpha qed fixed: TBP>>
end type alpha_qed_fixed_t
@ %def alpha_qed_fixed_t
@ Output.
<<SM qed: alpha qed fixed: TBP>>=
procedure :: write => alpha_qed_fixed_write
<<SM qed: procedures>>=
subroutine alpha_qed_fixed_write (object, unit)
class(alpha_qed_fixed_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A)") "QED parameters (fixed coupling):"
write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val
end subroutine alpha_qed_fixed_write
@ %def alpha_qed_fixed_write
@ Calculation: the scale is ignored in this case.
<<SM qed: alpha qed fixed: TBP>>=
procedure :: get => alpha_qed_fixed_get
<<SM qed: procedures>>=
function alpha_qed_fixed_get (alpha_qed, scale) result (alpha)
class(alpha_qed_fixed_t), intent(in) :: alpha_qed
real(default), intent(in) :: scale
real(default) :: alpha
alpha = alpha_qed%val
end function alpha_qed_fixed_get
@ %def alpha_qed_fixed_get
@
\subsection{Running Coupling}
In this version, the $\alpha$ value runs relative to the value at a
given reference scale. There are two parameters: the value of this
scale (default: $M_Z$), the value of $\alpha$ at this scale, and the
number of effective flavors. Furthermore, we have the order of the
approximation.
<<SM qed: public>>=
public :: alpha_qed_from_scale_t
<<SM qed: types>>=
type, extends (alpha_qed_t) :: alpha_qed_from_scale_t
real(default) :: mu_ref = ME_REF
real(default) :: ref = ALPHA_QED_ME_REF
integer :: order = 0
integer :: nf = 5
integer :: nlep = 1
logical :: analytic = .true.
contains
<<SM qed: alpha qed from scale: TBP>>
end type alpha_qed_from_scale_t
@ %def alpha_qed_from_scale_t
@ Output.
<<SM qed: alpha qed from scale: TBP>>=
procedure :: write => alpha_qed_from_scale_write
<<SM qed: procedures>>=
subroutine alpha_qed_from_scale_write (object, unit)
class(alpha_qed_from_scale_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(3x,A)") "QED parameters (running coupling):"
write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref
write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref
write (u, "(5x,A,I0)") "LL order = ", object%order
write (u, "(5x,A,I0)") "N(flv) = ", object%nf
write (u, "(5x,A,I0)") "N(lep) = ", object%nlep
write (u, "(5x,A,L1)") "analytic = ", object%analytic
end subroutine alpha_qed_from_scale_write
@ %def alpha_qed_from_scale_write
@ Calculation: here, we call the function for running $\alpha_s$ that
was defined in [[sm_physics]] above. The function does not take into
account thresholds, so the number of flavors should be the correct one
for the chosen scale. Normally, this should be the $Z$ boson mass.
<<SM qed: alpha qed from scale: TBP>>=
procedure :: get => alpha_qed_from_scale_get
<<SM qed: procedures>>=
function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha)
class(alpha_qed_from_scale_t), intent(in) :: alpha_qed
real(default), intent(in) :: scale
real(default) :: alpha
if (alpha_qed%analytic) then
alpha = running_alpha (scale, alpha_qed%ref, alpha_qed%mu_ref, &
alpha_qed%order, alpha_qed%nf, alpha_qed%nlep)
else
alpha = running_alpha_num (scale, alpha_qed%ref, alpha_qed%mu_ref, &
alpha_qed%order, alpha_qed%nf, alpha_qed%nlep)
end if
end function alpha_qed_from_scale_get
@ %def alpha_qed_from_scale_get
@
\subsection{QED type}
This module is similar to [[qcd_t]], defining the type [[qed_t]].
It stores the [[alpha_qed_t]] type which is either constant or a running $\alpha$
with different options.
<<SM qed: public>>=
public :: qed_t
<<SM qed: types>>=
type :: qed_t
class(alpha_qed_t), allocatable :: alpha
character(32) :: md5sum = ""
integer :: n_f = -1
integer :: n_lep = -1
contains
<<SM qed: qed: TBP>>
end type qed_t
@ %def qed_t
Output. We first print the polymorphic [[alpha]] which contains a headline,
then any extra components.
<<SM qed: qed: TBP>>=
procedure :: write => qed_write
<<SM qed: procedures>>=
subroutine qed_write (qed, unit, show_md5sum)
class(qed_t), intent(in) :: qed
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_md5sum
logical :: show_md5
integer :: u
u = given_output_unit (unit); if (u < 0) return
show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum
if (allocated (qed%alpha)) then
call qed%alpha%write (u)
else
write (u, "(3x,A)") "QED parameters (coupling undefined)"
end if
if (show_md5 .and. qed%md5sum /= "") &
write (u, "(5x,A,A,A)") "md5sum = '", qed%md5sum, "'"
end subroutine qed_write
@ % def qed_write
@ Compute an MD5 sum for the [[alpha]] setup. This is
done by writing them to a temporary file, using a standard format.
<<SM qed: qed: TBP>>=
procedure :: compute_alpha_md5sum => qed_compute_alpha_md5sum
<<SM qed: procedures>>=
subroutine qed_compute_alpha_md5sum (qed)
class(qed_t), intent(inout) :: qed
integer :: unit
if (allocated (qed%alpha)) then
unit = free_unit ()
open (unit, status="scratch", action="readwrite")
call qed%alpha%write (unit)
rewind (unit)
qed%md5sum = md5sum (unit)
close (unit)
end if
end subroutine qed_compute_alpha_md5sum
@ %def qed_compute_alphas_md5sum
@
@ Retrieve the MD5 sum of the qed setup.
<<SM qed: qed: TBP>>=
procedure :: get_md5sum => qed_get_md5sum
<<SM qed: procedures>>=
function qed_get_md5sum (qed) result (md5sum)
character(32) :: md5sum
class(qed_t), intent(inout) :: qed
md5sum = qed%md5sum
end function qed_get_md5sum
@ %def qed_get_md5sum
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[sm_qed_ut.f90]]>>=
<<File header>>
module sm_qed_ut
use unit_tests
use sm_qed_uti
<<Standard module head>>
<<SM qed: public test>>
contains
<<SM qed: test driver>>
end module sm_qed_ut
@ %def sm_qed_ut
@
<<[[sm_qed_uti.f90]]>>=
<<File header>>
module sm_qed_uti
<<Use kinds>>
use physics_defs, only: ME_REF
use sm_qed
<<Standard module head>>
<<SM qed: test declarations>>
contains
<<SM qed: tests>>
end module sm_qed_uti
@ %def sm_qed_ut
@ API: driver for the unit tests below.
<<SM qed: public test>>=
public :: sm_qed_test
<<SM qed: test driver>>=
subroutine sm_qed_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SM qed: execute tests>>
end subroutine sm_qed_test
@ %def sm_qed_test
@
\subsubsection{QED Coupling}
We check two different implementations of the abstract QED coupling.
<<SM qed: execute tests>>=
call test (sm_qed_1, "sm_qed_1", &
"running alpha_s", &
u, results)
<<SM qed: test declarations>>=
public :: sm_qed_1
<<SM qed: tests>>=
subroutine sm_qed_1 (u)
integer, intent(in) :: u
type(qed_t) :: qed
write (u, "(A)") "* Test output: sm_qed_1"
write (u, "(A)") "* Purpose: compute running alpha"
write (u, "(A)")
write (u, "(A)") "* Fixed:"
write (u, "(A)")
allocate (alpha_qed_fixed_t :: qed%alpha)
call qed%compute_alpha_md5sum ()
call qed%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha (me) =", &
qed%alpha%get (ME_REF)
write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", &
qed%alpha%get (10._default)
write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", &
qed%alpha%get (1000._default)
write (u, *)
deallocate (qed%alpha)
write (u, "(A)") "* Running from me (LO):"
write (u, "(A)")
allocate (alpha_qed_from_scale_t :: qed%alpha)
call qed%compute_alpha_md5sum ()
call qed%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha (me) =", &
qed%alpha%get (ME_REF)
write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", &
qed%alpha%get (10._default)
write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", &
qed%alpha%get (1000._default)
write (u, *)
write (u, "(A)") "* Running from me (NLO, analytic):"
write (u, "(A)")
select type (alpha => qed%alpha)
type is (alpha_qed_from_scale_t)
alpha%order = 1
end select
call qed%compute_alpha_md5sum ()
call qed%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha (me) =", &
qed%alpha%get (ME_REF)
write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", &
qed%alpha%get (10._default)
write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", &
qed%alpha%get (1000._default)
write (u, *)
write (u, "(A)") "* Running from me (NLO, numeric):"
write (u, "(A)")
select type (alpha => qed%alpha)
type is (alpha_qed_from_scale_t)
alpha%order = 1
alpha%analytic = .false.
end select
call qed%compute_alpha_md5sum ()
call qed%write (u)
write (u, *)
write (u, "(1x,A,F10.7)") "alpha (me) =", &
qed%alpha%get (ME_REF)
write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", &
qed%alpha%get (10._default)
write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", &
qed%alpha%get (1000._default)
write (u, *)
deallocate (qed%alpha)
write (u, "(A)")
write (u, "(A)") "* Test output end: sm_qed_1"
end subroutine sm_qed_1
@ %def sm_qed_1
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Shower algorithms}
<<[[shower_algorithms.f90]]>>=
<<File header>>
module shower_algorithms
<<Use kinds>>
use diagnostics
use constants
<<Standard module head>>
<<shower algorithms: public>>
<<shower algorithms: interfaces>>
contains
<<shower algorithms: procedures>>
<<shower algorithms: tests>>
end module shower_algorithms
@ %def shower_algorithms
@ We want to generate emission variables [[x]]$\in\mathds{R}^d$
proportional to
\begin{align}
&\quad f(x)\; \Delta(f, h(x)) \quad\text{with}\\
\Delta(f, H) &= \exp\left\{-\int\text{d}^d x'f(x') \Theta(h(x') -
H)\right\}
\end{align}
The [[true_function]] $f$ is however too complicated and we are only
able to generate [[x]] according to the [[overestimator]] $F$. This
algorithm is described in Appendix B of 0709.2092 and is proven e.g.~in
1211.7204 and hep-ph/0606275. Intuitively speaking, we overestimate the
emission probability and can therefore set [[scale_max = scale]] if the
emission is rejected.
<<shower algorithms: procedures>>=
subroutine generate_vetoed (x, overestimator, true_function, &
sudakov, inverse_sudakov, scale_min)
real(default), dimension(:), intent(out) :: x
!class(rng_t), intent(inout) :: rng
procedure(XXX_function), pointer, intent(in) :: overestimator, true_function
procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov
real(default), intent(in) :: scale_min
real(default) :: random, scale_max, scale
scale_max = inverse_sudakov (one)
do while (scale_max > scale_min)
!call rng%generate (random)
scale = inverse_sudakov (random * sudakov (scale_max))
call generate_on_hypersphere (x, overestimator, scale)
!call rng%generate (random)
if (random < true_function (x) / overestimator (x)) then
return !!! accept x
end if
scale_max = scale
end do
end subroutine generate_vetoed
@ %def generate_vetoed
@
<<shower algorithms: procedures>>=
subroutine generate_on_hypersphere (x, overestimator, scale)
real(default), dimension(:), intent(out) :: x
procedure(XXX_function), pointer, intent(in) :: overestimator
real(default), intent(in) :: scale
call msg_bug ("generate_on_hypersphere: not implemented")
end subroutine generate_on_hypersphere
@ %def generate_on_hypersphere
@
<<shower algorithms: interfaces>>=
interface
pure function XXX_function (x)
import
real(default) :: XXX_function
real(default), dimension(:), intent(in) :: x
end function XXX_function
end interface
interface
pure function sudakov_p (x)
import
real(default) :: sudakov_p
real(default), intent(in) :: x
end function sudakov_p
end interface
@
\subsection{Unit tests}
(Currently unused.)
<<XXX shower algorithms: public>>=
public :: shower_algorithms_test
<<XXX shower algorithms: tests>>=
subroutine shower_algorithms_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<shower algorithms: execute tests>>
end subroutine shower_algorithms_test
@ %def shower_algorithms_test
@
\subsubsection{Splitting functions}
<<XXX shower algorithms: execute tests>>=
call test (shower_algorithms_1, "shower_algorithms_1", &
"veto technique", &
u, results)
<<XXX shower algorithms: tests>>=
subroutine shower_algorithms_1 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: shower_algorithms_1"
write (u, "(A)") "* Purpose: check veto technique"
write (u, "(A)")
write (u, "(A)") "* Splitting functions:"
write (u, "(A)")
!call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)))
!call assert (u, nearly_equal ( &
!p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1),
!p_qqg (z))
write (u, "(A)")
write (u, "(A)") "* Test output end: shower_algorithms_1"
end subroutine shower_algorithms_1
@ %def shower_algorithms_1
Index: trunk/src/beams/Makefile.am
===================================================================
--- trunk/src/beams/Makefile.am (revision 8768)
+++ trunk/src/beams/Makefile.am (revision 8769)
@@ -1,233 +1,233 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libbeams.la
check_LTLIBRARIES = libbeams_ut.la
libbeams_la_SOURCES = \
beam_structures.f90 \
beams.f90 \
sf_mappings.f90 \
sf_aux.f90 \
sf_base.f90 \
sf_isr.f90 \
sf_epa.f90 \
sf_ewa.f90 \
sf_escan.f90 \
sf_gaussian.f90 \
sf_beam_events.f90 \
sf_circe1.f90 \
sf_circe2.f90 \
hoppet_interface.f90 \
sf_pdf_builtin.f90 \
sf_lhapdf.f90 \
pdf.f90 \
dispatch_beams.f90
libbeams_ut_la_SOURCES = \
beam_structures_uti.f90 beam_structures_ut.f90 \
beams_uti.f90 beams_ut.f90 \
sf_aux_uti.f90 sf_aux_ut.f90 \
sf_mappings_uti.f90 sf_mappings_ut.f90 \
sf_base_uti.f90 sf_base_ut.f90 \
sf_isr_uti.f90 sf_isr_ut.f90 \
sf_epa_uti.f90 sf_epa_ut.f90 \
sf_ewa_uti.f90 sf_ewa_ut.f90 \
sf_escan_uti.f90 sf_escan_ut.f90 \
sf_gaussian_uti.f90 sf_gaussian_ut.f90 \
sf_beam_events_uti.f90 sf_beam_events_ut.f90 \
sf_circe1_uti.f90 sf_circe1_ut.f90 \
sf_circe2_uti.f90 sf_circe2_ut.f90 \
sf_pdf_builtin_uti.f90 sf_pdf_builtin_ut.f90 \
sf_lhapdf_uti.f90 sf_lhapdf_ut.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = beams.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
${libbeams_la_SOURCES:.f90=.$(FCMOD)}
libbeams_Modules = ${libbeams_la_SOURCES:.f90=} ${libbeams_ut_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libbeams_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../utilities/Modules \
../testing/Modules \
../system/Modules \
../combinatorics/Modules \
../rng/Modules \
../physics/Modules \
../qft/Modules \
../types/Modules \
../particles/Modules \
../variables/Modules \
../qed_pdf/Modules
# Explicit dependencies, not automatically generated
sf_circe1.lo: ../../circe1/src/circe1.$(FCMOD)
sf_circe2.lo: ../../circe2/src/circe2.$(FCMOD)
hoppet_interface.lo: ../lhapdf/lhapdf.$(FCMOD)
sf_pdf_builtin.lo: ../pdf_builtin/pdf_builtin.$(FCMOD)
sf_lhapdf.lo: ../lhapdf/lhapdf.$(FCMOD)
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libbeams_la_SOURCES) $(libbeams_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES = Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(libbeams_la_SOURCES) $(libbeams_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../rng -I../physics -I../fastjet -I../qft -I../types -I../particles -I../../circe1/src -I../../circe2/src -I../pdf_builtin -I../lhapdf -I../qed_pdf -I../variables -I../expr_base -I../parsing
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
beams.stamp: $(PRELUDE) $(srcdir)/beams.nw $(POSTLUDE)
@rm -f beams.tmp
@touch beams.tmp
for src in $(libbeams_la_SOURCES) $(libbeams_ut_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
@mv -f beams.tmp beams.stamp
$(libbeams_la_SOURCES) $(libbeams_ut_la_SOURCES): beams.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f beams.stamp; \
$(MAKE) $(AM_MAKEFLAGS) beams.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f beams.stamp beams.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/share/tests/unit_tests/ref-output/sm_physics_3.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/sm_physics_3.ref (revision 0)
+++ trunk/share/tests/unit_tests/ref-output/sm_physics_3.ref (revision 8769)
@@ -0,0 +1,83 @@
+* Test output: sm_physics_3
+* Purpose: check special functions
+
+* Complex digamma function:
+
+ z1 = ( 0.75, 1.25)
+ psi(z1) = (0.21749,1.36041)
+ z2 = ( 1.33,11.25)
+ psi(z2) = (2.42276,1.49710)
+
+* Complex polygamma function:
+
+ z1 = ( 0.75, 1.25)
+ psi(z1,1) = ( 0.18785,-0.80371)
+ z2 = ( 1.33,11.25)
+ psi(z2,1) = ( 0.00654,-0.08846)
+
+ z1 = ( 0.75, 1.25)
+ psi(z1,2) = ( 0.62049, 0.34840)
+ z2 = ( 1.33,11.25)
+ psi(z2,2) = ( 0.00779, 0.00116)
+
+ z1 = ( 0.75, 1.25)
+ psi(z1,3) = (-0.94963, 0.81949)
+ z2 = ( 1.33,11.25)
+ psi(z2,3) = (-0.00031, 0.00136)
+
+ z1 = ( 0.75, 1.25)
+ psi(z1,4) = (-0.98471,-3.15931)
+ z2 = ( 1.33,11.25)
+ psi(z2,4) = (-0.00036,-0.00011)
+
+ z1 = ( 0.75, 1.25)
+ psi(z1,5) = (11.28657, 1.79522)
+ z2 = ( 1.33,11.25)
+ psi(z2,5) = ( 0.00005,-0.00012)
+
+* Generalized Nielsen polylogarithm:
+
+ S(1,1,0) = 0.00000
+ S(1,1,-1) = -0.82247
+ S(1,2,-1) = 0.15026
+ S(2,1,-1) = -0.90154
+ S(1,3,-1) = -0.02375
+ S(2,2,-1) = 0.08779
+ S(3,1,-1) = -0.94703
+ S(1,4,-1) = 0.00314
+ S(2,3,-1) = -0.00960
+ S(3,2,-1) = 0.04894
+ S(4,1,-1) = -0.97212
+ S(1,1,0.2) = 0.21100
+ S(1,2,0.2) = 0.01155
+ S(2,1,0.2) = 0.20532
+ S(1,3,0.2) = 0.00057
+ S(2,2,0.2) = 0.00550
+ S(3,1,0.2) = 0.20261
+ S(1,4,0.2) = 0.00002
+ S(2,3,0.2) = 0.00018
+ S(3,2,0.2) = 0.00266
+ S(4,1,0.2) = 0.20128
+ S(1,1,1) = 1.64493
+ S(1,2,1) = 1.20206
+ S(2,1,1) = 1.20206
+ S(1,3,1) = 1.08232
+ S(2,2,1) = 0.27058
+ S(3,1,1) = 1.08232
+ S(1,4,1) = 1.03693
+ S(2,3,1) = 0.09655
+ S(3,2,1) = 0.09655
+ S(4,1,1) = 1.03693
+ S(1,1,0.75) = 0.97847
+ S(1,3,0.75) = 0.08497
+ S(1,4,0.75) = 0.02115
+ S(2,2,0.75) = 0.11079
+ S(1,1,2) = ( 2.32018,-3.45139)
+
+* Dilog, trilog, polylog:
+
+ Li2(0.66) = 0.82233
+ Li3(0.66) = 0.72974
+ Poly(4,0.66) = 0.69182
+
+* Test output end: sm_physics_3
Index: trunk/share/tests/Makefile.am
===================================================================
--- trunk/share/tests/Makefile.am (revision 8768)
+++ trunk/share/tests/Makefile.am (revision 8769)
@@ -1,1612 +1,1613 @@
## Makefile.am -- Makefile for WHIZARD tests
##
## Process this file with automake to produce Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2021 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
EXTRA_DIST = \
$(TESTSUITE_MACROS) $(TESTSUITES_M4) $(TESTSUITES_SIN) \
$(TESTSUITE_TOOLS) \
$(REF_OUTPUT_FILES) \
cascades2_1.fds \
cascades2_2.fds \
cascades2_lexer_1.fds \
ext_tests_nmssm/nmssm.slha \
functional_tests/structure_2_inc.sin functional_tests/testproc_3.phs \
functional_tests/susyhit.in \
functional_tests/ufo_5_test.slha
TESTSUITE_MACROS = testsuite.m4
TESTSUITE_TOOLS = \
check-debug-output.py \
check-debug-output-hadro.py \
check-hepmc-weights.py \
compare-histograms.py \
compare-integrals.py \
compare-integrals-multi.py \
compare-methods.py
REF_OUTPUT_FILES = \
extra_integration_results.dat \
$(REF_OUTPUT_FILES_BASE) $(REF_OUTPUT_FILES_DOUBLE) \
$(REF_OUTPUT_FILES_PREC) $(REF_OUTPUT_FILES_EXT) \
$(REF_OUTPUT_FILES_QUAD)
REF_OUTPUT_FILES_BASE = \
unit_tests/ref-output/analysis_1.ref \
unit_tests/ref-output/api_1.ref \
unit_tests/ref-output/api_2.ref \
unit_tests/ref-output/api_3.ref \
unit_tests/ref-output/api_4.ref \
unit_tests/ref-output/api_5.ref \
unit_tests/ref-output/api_6.ref \
unit_tests/ref-output/api_7.ref \
unit_tests/ref-output/api_8.ref \
unit_tests/ref-output/api_c_1.ref \
unit_tests/ref-output/api_c_2.ref \
unit_tests/ref-output/api_c_3.ref \
unit_tests/ref-output/api_c_4.ref \
unit_tests/ref-output/api_c_5.ref \
unit_tests/ref-output/api_cc_1.ref \
unit_tests/ref-output/api_cc_2.ref \
unit_tests/ref-output/api_cc_3.ref \
unit_tests/ref-output/api_cc_4.ref \
unit_tests/ref-output/api_cc_5.ref \
unit_tests/ref-output/api_hepmc2_1.ref \
unit_tests/ref-output/api_hepmc2_cc_1.ref \
unit_tests/ref-output/api_hepmc3_1.ref \
unit_tests/ref-output/api_hepmc3_cc_1.ref \
unit_tests/ref-output/api_lcio_1.ref \
unit_tests/ref-output/api_lcio_cc_1.ref \
unit_tests/ref-output/array_list_1.ref \
unit_tests/ref-output/auto_components_1.ref \
unit_tests/ref-output/auto_components_2.ref \
unit_tests/ref-output/auto_components_3.ref \
unit_tests/ref-output/beam_1.ref \
unit_tests/ref-output/beam_2.ref \
unit_tests/ref-output/beam_3.ref \
unit_tests/ref-output/beam_structures_1.ref \
unit_tests/ref-output/beam_structures_2.ref \
unit_tests/ref-output/beam_structures_3.ref \
unit_tests/ref-output/beam_structures_4.ref \
unit_tests/ref-output/beam_structures_5.ref \
unit_tests/ref-output/beam_structures_6.ref \
unit_tests/ref-output/binary_tree_1.ref \
unit_tests/ref-output/blha_1.ref \
unit_tests/ref-output/blha_2.ref \
unit_tests/ref-output/blha_3.ref \
unit_tests/ref-output/bloch_vectors_1.ref \
unit_tests/ref-output/bloch_vectors_2.ref \
unit_tests/ref-output/bloch_vectors_3.ref \
unit_tests/ref-output/bloch_vectors_4.ref \
unit_tests/ref-output/bloch_vectors_5.ref \
unit_tests/ref-output/bloch_vectors_6.ref \
unit_tests/ref-output/bloch_vectors_7.ref \
unit_tests/ref-output/cascades2_1.ref \
unit_tests/ref-output/cascades2_2.ref \
unit_tests/ref-output/cascades2_lexer_1.ref \
unit_tests/ref-output/cascades_1.ref \
unit_tests/ref-output/cascades_2.ref \
unit_tests/ref-output/color_1.ref \
unit_tests/ref-output/color_2.ref \
unit_tests/ref-output/commands_1.ref \
unit_tests/ref-output/commands_2.ref \
unit_tests/ref-output/commands_3.ref \
unit_tests/ref-output/commands_4.ref \
unit_tests/ref-output/commands_5.ref \
unit_tests/ref-output/commands_6.ref \
unit_tests/ref-output/commands_7.ref \
unit_tests/ref-output/commands_8.ref \
unit_tests/ref-output/commands_9.ref \
unit_tests/ref-output/commands_10.ref \
unit_tests/ref-output/commands_11.ref \
unit_tests/ref-output/commands_12.ref \
unit_tests/ref-output/commands_13.ref \
unit_tests/ref-output/commands_14.ref \
unit_tests/ref-output/commands_15.ref \
unit_tests/ref-output/commands_16.ref \
unit_tests/ref-output/commands_17.ref \
unit_tests/ref-output/commands_18.ref \
unit_tests/ref-output/commands_19.ref \
unit_tests/ref-output/commands_20.ref \
unit_tests/ref-output/commands_21.ref \
unit_tests/ref-output/commands_22.ref \
unit_tests/ref-output/commands_23.ref \
unit_tests/ref-output/commands_24.ref \
unit_tests/ref-output/commands_25.ref \
unit_tests/ref-output/commands_26.ref \
unit_tests/ref-output/commands_27.ref \
unit_tests/ref-output/commands_28.ref \
unit_tests/ref-output/commands_29.ref \
unit_tests/ref-output/commands_30.ref \
unit_tests/ref-output/commands_31.ref \
unit_tests/ref-output/commands_32.ref \
unit_tests/ref-output/commands_33.ref \
unit_tests/ref-output/commands_34.ref \
unit_tests/ref-output/compilations_1.ref \
unit_tests/ref-output/compilations_2.ref \
unit_tests/ref-output/compilations_3.ref \
unit_tests/ref-output/compilations_static_1.ref \
unit_tests/ref-output/compilations_static_2.ref \
unit_tests/ref-output/cputime_1.ref \
unit_tests/ref-output/cputime_2.ref \
unit_tests/ref-output/decays_1.ref \
unit_tests/ref-output/decays_2.ref \
unit_tests/ref-output/decays_3.ref \
unit_tests/ref-output/decays_4.ref \
unit_tests/ref-output/decays_5.ref \
unit_tests/ref-output/decays_6.ref \
unit_tests/ref-output/dispatch_1.ref \
unit_tests/ref-output/dispatch_2.ref \
unit_tests/ref-output/dispatch_7.ref \
unit_tests/ref-output/dispatch_8.ref \
unit_tests/ref-output/dispatch_10.ref \
unit_tests/ref-output/dispatch_11.ref \
unit_tests/ref-output/dispatch_mci_1.ref \
unit_tests/ref-output/dispatch_phs_1.ref \
unit_tests/ref-output/dispatch_phs_2.ref \
unit_tests/ref-output/dispatch_rng_1.ref \
unit_tests/ref-output/dispatch_transforms_1.ref \
unit_tests/ref-output/dispatch_transforms_2.ref \
unit_tests/ref-output/eio_ascii_1.ref \
unit_tests/ref-output/eio_ascii_2.ref \
unit_tests/ref-output/eio_ascii_3.ref \
unit_tests/ref-output/eio_ascii_4.ref \
unit_tests/ref-output/eio_ascii_5.ref \
unit_tests/ref-output/eio_ascii_6.ref \
unit_tests/ref-output/eio_ascii_7.ref \
unit_tests/ref-output/eio_ascii_8.ref \
unit_tests/ref-output/eio_ascii_9.ref \
unit_tests/ref-output/eio_ascii_10.ref \
unit_tests/ref-output/eio_ascii_11.ref \
unit_tests/ref-output/eio_base_1.ref \
unit_tests/ref-output/eio_checkpoints_1.ref \
unit_tests/ref-output/eio_data_1.ref \
unit_tests/ref-output/eio_data_2.ref \
unit_tests/ref-output/eio_direct_1.ref \
unit_tests/ref-output/eio_dump_1.ref \
unit_tests/ref-output/eio_hepmc2_1.ref \
unit_tests/ref-output/eio_hepmc2_2.ref \
unit_tests/ref-output/eio_hepmc2_3.ref \
unit_tests/ref-output/eio_hepmc3_1.ref \
unit_tests/ref-output/eio_hepmc3_2.ref \
unit_tests/ref-output/eio_hepmc3_3.ref \
unit_tests/ref-output/eio_lcio_1.ref \
unit_tests/ref-output/eio_lcio_2.ref \
unit_tests/ref-output/eio_lhef_1.ref \
unit_tests/ref-output/eio_lhef_2.ref \
unit_tests/ref-output/eio_lhef_3.ref \
unit_tests/ref-output/eio_lhef_4.ref \
unit_tests/ref-output/eio_lhef_5.ref \
unit_tests/ref-output/eio_lhef_6.ref \
unit_tests/ref-output/eio_raw_1.ref \
unit_tests/ref-output/eio_raw_2.ref \
unit_tests/ref-output/eio_stdhep_1.ref \
unit_tests/ref-output/eio_stdhep_2.ref \
unit_tests/ref-output/eio_stdhep_3.ref \
unit_tests/ref-output/eio_stdhep_4.ref \
unit_tests/ref-output/eio_weights_1.ref \
unit_tests/ref-output/eio_weights_2.ref \
unit_tests/ref-output/eio_weights_3.ref \
unit_tests/ref-output/epa_handler_1.ref \
unit_tests/ref-output/epa_handler_2.ref \
unit_tests/ref-output/epa_handler_3.ref \
unit_tests/ref-output/evaluator_1.ref \
unit_tests/ref-output/evaluator_2.ref \
unit_tests/ref-output/evaluator_3.ref \
unit_tests/ref-output/evaluator_4.ref \
unit_tests/ref-output/event_streams_1.ref \
unit_tests/ref-output/event_streams_2.ref \
unit_tests/ref-output/event_streams_3.ref \
unit_tests/ref-output/event_streams_4.ref \
unit_tests/ref-output/event_transforms_1.ref \
unit_tests/ref-output/events_1.ref \
unit_tests/ref-output/events_2.ref \
unit_tests/ref-output/events_3.ref \
unit_tests/ref-output/events_4.ref \
unit_tests/ref-output/events_5.ref \
unit_tests/ref-output/events_6.ref \
unit_tests/ref-output/events_7.ref \
unit_tests/ref-output/expressions_1.ref \
unit_tests/ref-output/expressions_2.ref \
unit_tests/ref-output/expressions_3.ref \
unit_tests/ref-output/expressions_4.ref \
unit_tests/ref-output/fks_regions_1.ref \
unit_tests/ref-output/fks_regions_2.ref \
unit_tests/ref-output/fks_regions_3.ref \
unit_tests/ref-output/fks_regions_4.ref \
unit_tests/ref-output/fks_regions_5.ref \
unit_tests/ref-output/fks_regions_6.ref \
unit_tests/ref-output/fks_regions_7.ref \
unit_tests/ref-output/fks_regions_8.ref \
unit_tests/ref-output/format_1.ref \
unit_tests/ref-output/grids_1.ref \
unit_tests/ref-output/grids_2.ref \
unit_tests/ref-output/grids_3.ref \
unit_tests/ref-output/grids_4.ref \
unit_tests/ref-output/grids_5.ref \
unit_tests/ref-output/hep_events_1.ref \
unit_tests/ref-output/hepmc2_interface_1.ref \
unit_tests/ref-output/hepmc3_interface_1.ref \
unit_tests/ref-output/integration_results_1.ref \
unit_tests/ref-output/integration_results_2.ref \
unit_tests/ref-output/integration_results_3.ref \
unit_tests/ref-output/integration_results_4.ref \
unit_tests/ref-output/integration_results_5.ref \
unit_tests/ref-output/integrations_1.ref \
unit_tests/ref-output/integrations_2.ref \
unit_tests/ref-output/integrations_3.ref \
unit_tests/ref-output/integrations_4.ref \
unit_tests/ref-output/integrations_5.ref \
unit_tests/ref-output/integrations_6.ref \
unit_tests/ref-output/integrations_7.ref \
unit_tests/ref-output/integrations_8.ref \
unit_tests/ref-output/integrations_9.ref \
unit_tests/ref-output/integrations_history_1.ref \
unit_tests/ref-output/interaction_1.ref \
unit_tests/ref-output/isr_handler_1.ref \
unit_tests/ref-output/isr_handler_2.ref \
unit_tests/ref-output/isr_handler_3.ref \
unit_tests/ref-output/iterations_1.ref \
unit_tests/ref-output/iterations_2.ref \
unit_tests/ref-output/iterator_1.ref \
unit_tests/ref-output/jets_1.ref \
unit_tests/ref-output/lcio_interface_1.ref \
unit_tests/ref-output/lexer_1.ref \
unit_tests/ref-output/mci_base_1.ref \
unit_tests/ref-output/mci_base_2.ref \
unit_tests/ref-output/mci_base_3.ref \
unit_tests/ref-output/mci_base_4.ref \
unit_tests/ref-output/mci_base_5.ref \
unit_tests/ref-output/mci_base_6.ref \
unit_tests/ref-output/mci_base_7.ref \
unit_tests/ref-output/mci_base_8.ref \
unit_tests/ref-output/mci_midpoint_1.ref \
unit_tests/ref-output/mci_midpoint_2.ref \
unit_tests/ref-output/mci_midpoint_3.ref \
unit_tests/ref-output/mci_midpoint_4.ref \
unit_tests/ref-output/mci_midpoint_5.ref \
unit_tests/ref-output/mci_midpoint_6.ref \
unit_tests/ref-output/mci_midpoint_7.ref \
unit_tests/ref-output/mci_none_1.ref \
unit_tests/ref-output/mci_vamp2_1.ref \
unit_tests/ref-output/mci_vamp2_2.ref \
unit_tests/ref-output/mci_vamp2_3.ref \
unit_tests/ref-output/mci_vamp_1.ref \
unit_tests/ref-output/mci_vamp_2.ref \
unit_tests/ref-output/mci_vamp_3.ref \
unit_tests/ref-output/mci_vamp_4.ref \
unit_tests/ref-output/mci_vamp_5.ref \
unit_tests/ref-output/mci_vamp_6.ref \
unit_tests/ref-output/mci_vamp_7.ref \
unit_tests/ref-output/mci_vamp_8.ref \
unit_tests/ref-output/mci_vamp_9.ref \
unit_tests/ref-output/mci_vamp_10.ref \
unit_tests/ref-output/mci_vamp_11.ref \
unit_tests/ref-output/mci_vamp_12.ref \
unit_tests/ref-output/mci_vamp_13.ref \
unit_tests/ref-output/mci_vamp_14.ref \
unit_tests/ref-output/mci_vamp_15.ref \
unit_tests/ref-output/mci_vamp_16.ref \
unit_tests/ref-output/md5_1.ref \
unit_tests/ref-output/models_1.ref \
unit_tests/ref-output/models_2.ref \
unit_tests/ref-output/models_3.ref \
unit_tests/ref-output/models_4.ref \
unit_tests/ref-output/models_5.ref \
unit_tests/ref-output/models_6.ref \
unit_tests/ref-output/models_7.ref \
unit_tests/ref-output/models_8.ref \
unit_tests/ref-output/models_9.ref \
unit_tests/ref-output/models_10.ref \
unit_tests/ref-output/os_interface_1.ref \
unit_tests/ref-output/parse_1.ref \
unit_tests/ref-output/particle_specifiers_1.ref \
unit_tests/ref-output/particle_specifiers_2.ref \
unit_tests/ref-output/particles_1.ref \
unit_tests/ref-output/particles_2.ref \
unit_tests/ref-output/particles_3.ref \
unit_tests/ref-output/particles_4.ref \
unit_tests/ref-output/particles_5.ref \
unit_tests/ref-output/particles_6.ref \
unit_tests/ref-output/particles_7.ref \
unit_tests/ref-output/particles_8.ref \
unit_tests/ref-output/particles_9.ref \
unit_tests/ref-output/parton_states_1.ref \
unit_tests/ref-output/pdg_arrays_1.ref \
unit_tests/ref-output/pdg_arrays_2.ref \
unit_tests/ref-output/pdg_arrays_3.ref \
unit_tests/ref-output/pdg_arrays_4.ref \
unit_tests/ref-output/pdg_arrays_5.ref \
unit_tests/ref-output/phs_base_1.ref \
unit_tests/ref-output/phs_base_2.ref \
unit_tests/ref-output/phs_base_3.ref \
unit_tests/ref-output/phs_base_4.ref \
unit_tests/ref-output/phs_base_5.ref \
unit_tests/ref-output/phs_fks_generator_1.ref \
unit_tests/ref-output/phs_fks_generator_2.ref \
unit_tests/ref-output/phs_fks_generator_3.ref \
unit_tests/ref-output/phs_fks_generator_4.ref \
unit_tests/ref-output/phs_fks_generator_5.ref \
unit_tests/ref-output/phs_fks_generator_6.ref \
unit_tests/ref-output/phs_fks_generator_7.ref \
unit_tests/ref-output/phs_forest_1.ref \
unit_tests/ref-output/phs_forest_2.ref \
unit_tests/ref-output/phs_none_1.ref \
unit_tests/ref-output/phs_points_1.ref \
unit_tests/ref-output/phs_rambo_1.ref \
unit_tests/ref-output/phs_rambo_2.ref \
unit_tests/ref-output/phs_rambo_3.ref \
unit_tests/ref-output/phs_rambo_4.ref \
unit_tests/ref-output/phs_single_1.ref \
unit_tests/ref-output/phs_single_2.ref \
unit_tests/ref-output/phs_single_3.ref \
unit_tests/ref-output/phs_single_4.ref \
unit_tests/ref-output/phs_tree_1.ref \
unit_tests/ref-output/phs_tree_2.ref \
unit_tests/ref-output/phs_wood_1.ref \
unit_tests/ref-output/phs_wood_2.ref \
unit_tests/ref-output/phs_wood_3.ref \
unit_tests/ref-output/phs_wood_4.ref \
unit_tests/ref-output/phs_wood_5.ref \
unit_tests/ref-output/phs_wood_6.ref \
unit_tests/ref-output/phs_wood_vis_1.ref \
unit_tests/ref-output/polarization_1.ref \
unit_tests/ref-output/polarization_2.ref \
unit_tests/ref-output/prc_omega_1.ref \
unit_tests/ref-output/prc_omega_2.ref \
unit_tests/ref-output/prc_omega_3.ref \
unit_tests/ref-output/prc_omega_4.ref \
unit_tests/ref-output/prc_omega_5.ref \
unit_tests/ref-output/prc_omega_6.ref \
unit_tests/ref-output/prc_omega_diags_1.ref \
unit_tests/ref-output/prc_recola_1.ref \
unit_tests/ref-output/prc_recola_2.ref \
unit_tests/ref-output/prc_template_me_1.ref \
unit_tests/ref-output/prc_template_me_2.ref \
unit_tests/ref-output/prc_test_1.ref \
unit_tests/ref-output/prc_test_2.ref \
unit_tests/ref-output/prc_test_3.ref \
unit_tests/ref-output/prc_test_4.ref \
unit_tests/ref-output/prclib_interfaces_1.ref \
unit_tests/ref-output/prclib_interfaces_2.ref \
unit_tests/ref-output/prclib_interfaces_3.ref \
unit_tests/ref-output/prclib_interfaces_4.ref \
unit_tests/ref-output/prclib_interfaces_5.ref \
unit_tests/ref-output/prclib_interfaces_6.ref \
unit_tests/ref-output/prclib_interfaces_7.ref \
unit_tests/ref-output/prclib_stacks_1.ref \
unit_tests/ref-output/prclib_stacks_2.ref \
unit_tests/ref-output/process_configurations_1.ref \
unit_tests/ref-output/process_configurations_2.ref \
unit_tests/ref-output/process_libraries_1.ref \
unit_tests/ref-output/process_libraries_2.ref \
unit_tests/ref-output/process_libraries_3.ref \
unit_tests/ref-output/process_libraries_4.ref \
unit_tests/ref-output/process_libraries_5.ref \
unit_tests/ref-output/process_libraries_6.ref \
unit_tests/ref-output/process_libraries_7.ref \
unit_tests/ref-output/process_libraries_8.ref \
unit_tests/ref-output/process_stacks_1.ref \
unit_tests/ref-output/process_stacks_2.ref \
unit_tests/ref-output/process_stacks_3.ref \
unit_tests/ref-output/process_stacks_4.ref \
unit_tests/ref-output/processes_1.ref \
unit_tests/ref-output/processes_2.ref \
unit_tests/ref-output/processes_3.ref \
unit_tests/ref-output/processes_4.ref \
unit_tests/ref-output/processes_5.ref \
unit_tests/ref-output/processes_6.ref \
unit_tests/ref-output/processes_7.ref \
unit_tests/ref-output/processes_8.ref \
unit_tests/ref-output/processes_9.ref \
unit_tests/ref-output/processes_10.ref \
unit_tests/ref-output/processes_11.ref \
unit_tests/ref-output/processes_12.ref \
unit_tests/ref-output/processes_13.ref \
unit_tests/ref-output/processes_14.ref \
unit_tests/ref-output/processes_15.ref \
unit_tests/ref-output/processes_16.ref \
unit_tests/ref-output/processes_17.ref \
unit_tests/ref-output/processes_18.ref \
unit_tests/ref-output/processes_19.ref \
unit_tests/ref-output/radiation_generator_1.ref \
unit_tests/ref-output/radiation_generator_2.ref \
unit_tests/ref-output/radiation_generator_3.ref \
unit_tests/ref-output/radiation_generator_4.ref \
unit_tests/ref-output/real_subtraction_1.ref \
unit_tests/ref-output/recoil_kinematics_1.ref \
unit_tests/ref-output/recoil_kinematics_2.ref \
unit_tests/ref-output/recoil_kinematics_3.ref \
unit_tests/ref-output/recoil_kinematics_4.ref \
unit_tests/ref-output/recoil_kinematics_5.ref \
unit_tests/ref-output/recoil_kinematics_6.ref \
unit_tests/ref-output/resonance_insertion_1.ref \
unit_tests/ref-output/resonance_insertion_2.ref \
unit_tests/ref-output/resonance_insertion_3.ref \
unit_tests/ref-output/resonance_insertion_4.ref \
unit_tests/ref-output/resonance_insertion_5.ref \
unit_tests/ref-output/resonance_insertion_6.ref \
unit_tests/ref-output/resonances_1.ref \
unit_tests/ref-output/resonances_2.ref \
unit_tests/ref-output/resonances_3.ref \
unit_tests/ref-output/resonances_4.ref \
unit_tests/ref-output/resonances_5.ref \
unit_tests/ref-output/resonances_6.ref \
unit_tests/ref-output/resonances_7.ref \
unit_tests/ref-output/restricted_subprocesses_1.ref \
unit_tests/ref-output/restricted_subprocesses_2.ref \
unit_tests/ref-output/restricted_subprocesses_3.ref \
unit_tests/ref-output/restricted_subprocesses_4.ref \
unit_tests/ref-output/restricted_subprocesses_5.ref \
unit_tests/ref-output/restricted_subprocesses_6.ref \
unit_tests/ref-output/rng_base_1.ref \
unit_tests/ref-output/rng_base_2.ref \
unit_tests/ref-output/rng_stream_1.ref \
unit_tests/ref-output/rng_stream_2.ref \
unit_tests/ref-output/rng_stream_3.ref \
unit_tests/ref-output/rng_tao_1.ref \
unit_tests/ref-output/rng_tao_2.ref \
unit_tests/ref-output/rt_data_1.ref \
unit_tests/ref-output/rt_data_2.ref \
unit_tests/ref-output/rt_data_3.ref \
unit_tests/ref-output/rt_data_4.ref \
unit_tests/ref-output/rt_data_5.ref \
unit_tests/ref-output/rt_data_6.ref \
unit_tests/ref-output/rt_data_7.ref \
unit_tests/ref-output/rt_data_8.ref \
unit_tests/ref-output/rt_data_9.ref \
unit_tests/ref-output/rt_data_10.ref \
unit_tests/ref-output/rt_data_11.ref \
unit_tests/ref-output/selectors_1.ref \
unit_tests/ref-output/selectors_2.ref \
unit_tests/ref-output/sf_aux_1.ref \
unit_tests/ref-output/sf_aux_2.ref \
unit_tests/ref-output/sf_aux_3.ref \
unit_tests/ref-output/sf_aux_4.ref \
unit_tests/ref-output/sf_base_1.ref \
unit_tests/ref-output/sf_base_2.ref \
unit_tests/ref-output/sf_base_3.ref \
unit_tests/ref-output/sf_base_4.ref \
unit_tests/ref-output/sf_base_5.ref \
unit_tests/ref-output/sf_base_6.ref \
unit_tests/ref-output/sf_base_7.ref \
unit_tests/ref-output/sf_base_8.ref \
unit_tests/ref-output/sf_base_9.ref \
unit_tests/ref-output/sf_base_10.ref \
unit_tests/ref-output/sf_base_11.ref \
unit_tests/ref-output/sf_base_12.ref \
unit_tests/ref-output/sf_base_13.ref \
unit_tests/ref-output/sf_base_14.ref \
unit_tests/ref-output/sf_beam_events_1.ref \
unit_tests/ref-output/sf_beam_events_2.ref \
unit_tests/ref-output/sf_beam_events_3.ref \
unit_tests/ref-output/sf_circe1_1.ref \
unit_tests/ref-output/sf_circe1_2.ref \
unit_tests/ref-output/sf_circe1_3.ref \
unit_tests/ref-output/sf_circe2_1.ref \
unit_tests/ref-output/sf_circe2_2.ref \
unit_tests/ref-output/sf_circe2_3.ref \
unit_tests/ref-output/sf_epa_1.ref \
unit_tests/ref-output/sf_epa_2.ref \
unit_tests/ref-output/sf_epa_3.ref \
unit_tests/ref-output/sf_epa_4.ref \
unit_tests/ref-output/sf_epa_5.ref \
unit_tests/ref-output/sf_escan_1.ref \
unit_tests/ref-output/sf_escan_2.ref \
unit_tests/ref-output/sf_ewa_1.ref \
unit_tests/ref-output/sf_ewa_2.ref \
unit_tests/ref-output/sf_ewa_3.ref \
unit_tests/ref-output/sf_ewa_4.ref \
unit_tests/ref-output/sf_ewa_5.ref \
unit_tests/ref-output/sf_gaussian_1.ref \
unit_tests/ref-output/sf_gaussian_2.ref \
unit_tests/ref-output/sf_isr_1.ref \
unit_tests/ref-output/sf_isr_2.ref \
unit_tests/ref-output/sf_isr_3.ref \
unit_tests/ref-output/sf_isr_4.ref \
unit_tests/ref-output/sf_isr_5.ref \
unit_tests/ref-output/sf_lhapdf5_1.ref \
unit_tests/ref-output/sf_lhapdf5_2.ref \
unit_tests/ref-output/sf_lhapdf5_3.ref \
unit_tests/ref-output/sf_lhapdf6_1.ref \
unit_tests/ref-output/sf_lhapdf6_2.ref \
unit_tests/ref-output/sf_lhapdf6_3.ref \
unit_tests/ref-output/sf_mappings_1.ref \
unit_tests/ref-output/sf_mappings_2.ref \
unit_tests/ref-output/sf_mappings_3.ref \
unit_tests/ref-output/sf_mappings_4.ref \
unit_tests/ref-output/sf_mappings_5.ref \
unit_tests/ref-output/sf_mappings_6.ref \
unit_tests/ref-output/sf_mappings_7.ref \
unit_tests/ref-output/sf_mappings_8.ref \
unit_tests/ref-output/sf_mappings_9.ref \
unit_tests/ref-output/sf_mappings_10.ref \
unit_tests/ref-output/sf_mappings_11.ref \
unit_tests/ref-output/sf_mappings_12.ref \
unit_tests/ref-output/sf_mappings_13.ref \
unit_tests/ref-output/sf_mappings_14.ref \
unit_tests/ref-output/sf_mappings_15.ref \
unit_tests/ref-output/sf_mappings_16.ref \
unit_tests/ref-output/sf_pdf_builtin_1.ref \
unit_tests/ref-output/sf_pdf_builtin_2.ref \
unit_tests/ref-output/sf_pdf_builtin_3.ref \
unit_tests/ref-output/shower_1.ref \
unit_tests/ref-output/shower_2.ref \
unit_tests/ref-output/shower_base_1.ref \
unit_tests/ref-output/simulations_1.ref \
unit_tests/ref-output/simulations_2.ref \
unit_tests/ref-output/simulations_3.ref \
unit_tests/ref-output/simulations_4.ref \
unit_tests/ref-output/simulations_5.ref \
unit_tests/ref-output/simulations_6.ref \
unit_tests/ref-output/simulations_7.ref \
unit_tests/ref-output/simulations_8.ref \
unit_tests/ref-output/simulations_9.ref \
unit_tests/ref-output/simulations_10.ref \
unit_tests/ref-output/simulations_11.ref \
unit_tests/ref-output/simulations_12.ref \
unit_tests/ref-output/simulations_13.ref \
unit_tests/ref-output/simulations_14.ref \
unit_tests/ref-output/simulations_15.ref \
unit_tests/ref-output/slha_1.ref \
unit_tests/ref-output/slha_2.ref \
unit_tests/ref-output/sm_physics_1.ref \
unit_tests/ref-output/sm_physics_2.ref \
+ unit_tests/ref-output/sm_physics_3.ref \
unit_tests/ref-output/sm_qcd_1.ref \
unit_tests/ref-output/sm_qed_1.ref \
unit_tests/ref-output/solver_1.ref \
unit_tests/ref-output/sorting_1.ref \
unit_tests/ref-output/state_matrix_1.ref \
unit_tests/ref-output/state_matrix_2.ref \
unit_tests/ref-output/state_matrix_3.ref \
unit_tests/ref-output/state_matrix_4.ref \
unit_tests/ref-output/state_matrix_5.ref \
unit_tests/ref-output/state_matrix_6.ref \
unit_tests/ref-output/state_matrix_7.ref \
unit_tests/ref-output/su_algebra_1.ref \
unit_tests/ref-output/su_algebra_2.ref \
unit_tests/ref-output/su_algebra_3.ref \
unit_tests/ref-output/su_algebra_4.ref \
unit_tests/ref-output/subevt_expr_1.ref \
unit_tests/ref-output/subevt_expr_2.ref \
unit_tests/ref-output/ttv_formfactors_1.ref \
unit_tests/ref-output/ttv_formfactors_2.ref \
unit_tests/ref-output/vamp2_1.ref \
unit_tests/ref-output/vamp2_2.ref \
unit_tests/ref-output/vamp2_3.ref \
unit_tests/ref-output/vamp2_4.ref \
unit_tests/ref-output/vamp2_5.ref \
unit_tests/ref-output/vegas_1.ref \
unit_tests/ref-output/vegas_2.ref \
unit_tests/ref-output/vegas_3.ref \
unit_tests/ref-output/vegas_4.ref \
unit_tests/ref-output/vegas_5.ref \
unit_tests/ref-output/vegas_6.ref \
unit_tests/ref-output/vegas_7.ref \
unit_tests/ref-output/whizard_lha_1.ref \
unit_tests/ref-output/xml_1.ref \
unit_tests/ref-output/xml_2.ref \
unit_tests/ref-output/xml_3.ref \
unit_tests/ref-output/xml_4.ref \
functional_tests/ref-output/alphas.ref \
functional_tests/ref-output/analyze_1.ref \
functional_tests/ref-output/analyze_2.ref \
functional_tests/ref-output/analyze_3.ref \
functional_tests/ref-output/analyze_4.ref \
functional_tests/ref-output/analyze_5.ref \
functional_tests/ref-output/analyze_6.ref \
functional_tests/ref-output/beam_events_1.ref \
functional_tests/ref-output/beam_events_4.ref \
functional_tests/ref-output/beam_setup_1.ref \
functional_tests/ref-output/beam_setup_2.ref \
functional_tests/ref-output/beam_setup_3.ref \
functional_tests/ref-output/beam_setup_4.ref \
functional_tests/ref-output/bjet_cluster.ref \
functional_tests/ref-output/br_redef_1.ref \
functional_tests/ref-output/cascades2_phs_1.ref \
functional_tests/ref-output/cascades2_phs_2.ref \
functional_tests/ref-output/circe1_1.ref \
functional_tests/ref-output/circe1_2.ref \
functional_tests/ref-output/circe1_3.ref \
functional_tests/ref-output/circe1_6.ref \
functional_tests/ref-output/circe1_10.ref \
functional_tests/ref-output/circe1_errors_1.ref \
functional_tests/ref-output/circe2_1.ref \
functional_tests/ref-output/circe2_2.ref \
functional_tests/ref-output/circe2_3.ref \
functional_tests/ref-output/cmdline_1.ref \
functional_tests/ref-output/colors.ref \
functional_tests/ref-output/colors_hgg.ref \
functional_tests/ref-output/cuts.ref \
functional_tests/ref-output/decay_err_1.ref \
functional_tests/ref-output/decay_err_2.ref \
functional_tests/ref-output/decay_err_3.ref \
functional_tests/ref-output/energy_scan_1.ref \
functional_tests/ref-output/ep_3.ref \
functional_tests/ref-output/epa_1.ref \
functional_tests/ref-output/epa_2.ref \
functional_tests/ref-output/epa_3.ref \
functional_tests/ref-output/epa_4.ref \
functional_tests/ref-output/event_dump_1.ref \
functional_tests/ref-output/event_dump_2.ref \
functional_tests/ref-output/event_eff_1.ref \
functional_tests/ref-output/event_eff_2.ref \
functional_tests/ref-output/event_failed_1.ref \
functional_tests/ref-output/event_weights_1.ref \
functional_tests/ref-output/event_weights_2.ref \
functional_tests/ref-output/ewa_4.ref \
functional_tests/ref-output/extpar.ref \
functional_tests/ref-output/fatal.ref \
functional_tests/ref-output/fatal_beam_decay.ref \
functional_tests/ref-output/fks_res_2.ref \
functional_tests/ref-output/flvsum_1.ref \
functional_tests/ref-output/gaussian_1.ref \
functional_tests/ref-output/gaussian_2.ref \
functional_tests/ref-output/hadronize_1.ref \
functional_tests/ref-output/hepmc_1.ref \
functional_tests/ref-output/hepmc_2.ref \
functional_tests/ref-output/hepmc_3.ref \
functional_tests/ref-output/hepmc_4.ref \
functional_tests/ref-output/hepmc_5.ref \
functional_tests/ref-output/hepmc_6.ref \
functional_tests/ref-output/hepmc_7.ref \
functional_tests/ref-output/hepmc_9.ref \
functional_tests/ref-output/hepmc_10.ref \
functional_tests/ref-output/isr_1.ref \
functional_tests/ref-output/isr_epa_1.ref \
functional_tests/ref-output/jets_xsec.ref \
functional_tests/ref-output/job_id_1.ref \
functional_tests/ref-output/job_id_2.ref \
functional_tests/ref-output/job_id_3.ref \
functional_tests/ref-output/job_id_4.ref \
functional_tests/ref-output/lcio_1.ref \
functional_tests/ref-output/lcio_3.ref \
functional_tests/ref-output/lcio_4.ref \
functional_tests/ref-output/lcio_5.ref \
functional_tests/ref-output/lcio_6.ref \
functional_tests/ref-output/lcio_8.ref \
functional_tests/ref-output/lcio_9.ref \
functional_tests/ref-output/lcio_10.ref \
functional_tests/ref-output/lcio_11.ref \
functional_tests/ref-output/lhef_1.ref \
functional_tests/ref-output/lhef_2.ref \
functional_tests/ref-output/lhef_3.ref \
functional_tests/ref-output/lhef_4.ref \
functional_tests/ref-output/lhef_5.ref \
functional_tests/ref-output/lhef_6.ref \
functional_tests/ref-output/lhef_9.ref \
functional_tests/ref-output/lhef_10.ref \
functional_tests/ref-output/lhef_11.ref \
functional_tests/ref-output/libraries_1.ref \
functional_tests/ref-output/libraries_2.ref \
functional_tests/ref-output/libraries_4.ref \
functional_tests/ref-output/method_ovm_1.ref \
functional_tests/ref-output/mlm_matching_fsr.ref \
functional_tests/ref-output/mlm_pythia6_isr.ref \
functional_tests/ref-output/model_change_1.ref \
functional_tests/ref-output/model_change_2.ref \
functional_tests/ref-output/model_change_3.ref \
functional_tests/ref-output/model_scheme_1.ref \
functional_tests/ref-output/model_test.ref \
functional_tests/ref-output/mssmtest_1.ref \
functional_tests/ref-output/mssmtest_2.ref \
functional_tests/ref-output/mssmtest_3.ref \
functional_tests/ref-output/multi_comp_4.ref \
functional_tests/ref-output/nlo_1.ref \
functional_tests/ref-output/nlo_2.ref \
functional_tests/ref-output/nlo_6.ref \
functional_tests/ref-output/nlo_decay_1.ref \
functional_tests/ref-output/observables_1.ref \
functional_tests/ref-output/openloops_1.ref \
functional_tests/ref-output/openloops_2.ref \
functional_tests/ref-output/openloops_4.ref \
functional_tests/ref-output/openloops_5.ref \
functional_tests/ref-output/openloops_6.ref \
functional_tests/ref-output/openloops_7.ref \
functional_tests/ref-output/openloops_8.ref \
functional_tests/ref-output/openloops_9.ref \
functional_tests/ref-output/openloops_10.ref \
functional_tests/ref-output/openloops_11.ref \
functional_tests/ref-output/pack_1.ref \
functional_tests/ref-output/parton_shower_1.ref \
functional_tests/ref-output/photon_isolation_1.ref \
functional_tests/ref-output/photon_isolation_2.ref \
functional_tests/ref-output/polarized_1.ref \
functional_tests/ref-output/process_log.ref \
functional_tests/ref-output/pythia6_1.ref \
functional_tests/ref-output/pythia6_2.ref \
functional_tests/ref-output/qcdtest_4.ref \
functional_tests/ref-output/qcdtest_5.ref \
functional_tests/ref-output/qcdtest_6.ref \
functional_tests/ref-output/qedtest_1.ref \
functional_tests/ref-output/qedtest_2.ref \
functional_tests/ref-output/qedtest_5.ref \
functional_tests/ref-output/qedtest_6.ref \
functional_tests/ref-output/qedtest_7.ref \
functional_tests/ref-output/qedtest_8.ref \
functional_tests/ref-output/qedtest_9.ref \
functional_tests/ref-output/qedtest_10.ref \
functional_tests/ref-output/rambo_vamp_1.ref \
functional_tests/ref-output/rambo_vamp_2.ref \
functional_tests/ref-output/real_partition_1.ref \
functional_tests/ref-output/rebuild_2.ref \
functional_tests/ref-output/rebuild_3.ref \
functional_tests/ref-output/rebuild_4.ref \
functional_tests/ref-output/recola_1.ref \
functional_tests/ref-output/recola_2.ref \
functional_tests/ref-output/recola_3.ref \
functional_tests/ref-output/recola_4.ref \
functional_tests/ref-output/recola_5.ref \
functional_tests/ref-output/recola_6.ref \
functional_tests/ref-output/recola_7.ref \
functional_tests/ref-output/recola_8.ref \
functional_tests/ref-output/recola_9.ref \
functional_tests/ref-output/resonances_5.ref \
functional_tests/ref-output/resonances_6.ref \
functional_tests/ref-output/resonances_7.ref \
functional_tests/ref-output/resonances_8.ref \
functional_tests/ref-output/resonances_9.ref \
functional_tests/ref-output/resonances_12.ref \
functional_tests/ref-output/restrictions.ref \
functional_tests/ref-output/reweight_1.ref \
functional_tests/ref-output/reweight_2.ref \
functional_tests/ref-output/reweight_3.ref \
functional_tests/ref-output/reweight_4.ref \
functional_tests/ref-output/reweight_5.ref \
functional_tests/ref-output/reweight_6.ref \
functional_tests/ref-output/reweight_7.ref \
functional_tests/ref-output/reweight_8.ref \
functional_tests/ref-output/reweight_9.ref \
functional_tests/ref-output/reweight_10.ref \
functional_tests/ref-output/select_1.ref \
functional_tests/ref-output/select_2.ref \
functional_tests/ref-output/show_1.ref \
functional_tests/ref-output/show_2.ref \
functional_tests/ref-output/show_3.ref \
functional_tests/ref-output/show_4.ref \
functional_tests/ref-output/show_5.ref \
functional_tests/ref-output/shower_err_1.ref \
functional_tests/ref-output/sm_cms_1.ref \
functional_tests/ref-output/smtest_1.ref \
functional_tests/ref-output/smtest_3.ref \
functional_tests/ref-output/smtest_4.ref \
functional_tests/ref-output/smtest_5.ref \
functional_tests/ref-output/smtest_6.ref \
functional_tests/ref-output/smtest_7.ref \
functional_tests/ref-output/smtest_9.ref \
functional_tests/ref-output/smtest_10.ref \
functional_tests/ref-output/smtest_11.ref \
functional_tests/ref-output/smtest_12.ref \
functional_tests/ref-output/smtest_13.ref \
functional_tests/ref-output/smtest_14.ref \
functional_tests/ref-output/smtest_15.ref \
functional_tests/ref-output/smtest_16.ref \
functional_tests/ref-output/smtest_17.ref \
functional_tests/ref-output/spincor_1.ref \
functional_tests/ref-output/static_1.ref \
functional_tests/ref-output/static_2.ref \
functional_tests/ref-output/stdhep_1.ref \
functional_tests/ref-output/stdhep_2.ref \
functional_tests/ref-output/stdhep_3.ref \
functional_tests/ref-output/stdhep_4.ref \
functional_tests/ref-output/stdhep_5.ref \
functional_tests/ref-output/stdhep_6.ref \
functional_tests/ref-output/structure_1.ref \
functional_tests/ref-output/structure_2.ref \
functional_tests/ref-output/structure_3.ref \
functional_tests/ref-output/structure_4.ref \
functional_tests/ref-output/structure_5.ref \
functional_tests/ref-output/structure_6.ref \
functional_tests/ref-output/structure_7.ref \
functional_tests/ref-output/structure_8.ref \
functional_tests/ref-output/susyhit.ref \
functional_tests/ref-output/template_me_1.ref \
functional_tests/ref-output/template_me_2.ref \
functional_tests/ref-output/testproc_1.ref \
functional_tests/ref-output/testproc_2.ref \
functional_tests/ref-output/testproc_3.ref \
functional_tests/ref-output/testproc_4.ref \
functional_tests/ref-output/testproc_5.ref \
functional_tests/ref-output/testproc_6.ref \
functional_tests/ref-output/testproc_7.ref \
functional_tests/ref-output/testproc_8.ref \
functional_tests/ref-output/testproc_9.ref \
functional_tests/ref-output/testproc_10.ref \
functional_tests/ref-output/testproc_11.ref \
functional_tests/ref-output/ufo_1.ref \
functional_tests/ref-output/ufo_2.ref \
functional_tests/ref-output/ufo_3.ref \
functional_tests/ref-output/ufo_4.ref \
functional_tests/ref-output/ufo_5.ref \
functional_tests/ref-output/ufo_6.ref \
functional_tests/ref-output/user_prc_threshold_1.ref \
functional_tests/ref-output/user_prc_threshold_2.ref \
functional_tests/ref-output/vamp2_1.ref \
functional_tests/ref-output/vamp2_2.ref \
functional_tests/ref-output/vamp2_3.ref \
functional_tests/ref-output/vars.ref \
ext_tests_nlo/ref-output/nlo_ee4j.ref \
ext_tests_nlo/ref-output/nlo_ee4t.ref \
ext_tests_nlo/ref-output/nlo_ee5j.ref \
ext_tests_nlo/ref-output/nlo_eejj.ref \
ext_tests_nlo/ref-output/nlo_eejjj.ref \
ext_tests_nlo/ref-output/nlo_eett.ref \
ext_tests_nlo/ref-output/nlo_eetth.ref \
ext_tests_nlo/ref-output/nlo_eetthh.ref \
ext_tests_nlo/ref-output/nlo_eetthj.ref \
ext_tests_nlo/ref-output/nlo_eetthz.ref \
ext_tests_nlo/ref-output/nlo_eettwjj.ref \
ext_tests_nlo/ref-output/nlo_eettww.ref \
ext_tests_nlo/ref-output/nlo_eettz.ref \
ext_tests_nlo/ref-output/nlo_eettzj.ref \
ext_tests_nlo/ref-output/nlo_eettzjj.ref \
ext_tests_nlo/ref-output/nlo_eettzz.ref \
ext_tests_nlo/ref-output/nlo_ppzj_real_partition.ref \
ext_tests_nlo/ref-output/nlo_pptttt.ref \
ext_tests_nlo/ref-output/nlo_ppw.ref \
ext_tests_nlo/ref-output/nlo_ppz.ref \
ext_tests_nlo/ref-output/nlo_ppzj_sim_1.ref \
ext_tests_nlo/ref-output/nlo_ppzj_sim_2.ref \
ext_tests_nlo/ref-output/nlo_ppzj_sim_3.ref \
ext_tests_nlo/ref-output/nlo_ppzj_sim_4.ref \
ext_tests_nlo/ref-output/nlo_ppzw.ref \
ext_tests_nlo/ref-output/nlo_ppzz.ref \
ext_tests_nlo/ref-output/nlo_ppee_ew.ref \
ext_tests_nlo/ref-output/nlo_pphee_ew.ref \
ext_tests_nlo/ref-output/nlo_pphjj_ew.ref \
ext_tests_nlo/ref-output/nlo_pphz_ew.ref \
ext_tests_nlo/ref-output/nlo_ppllll_ew.ref \
ext_tests_nlo/ref-output/nlo_ppllnn_ew.ref \
ext_tests_nlo/ref-output/nlo_pptj_ew.ref \
ext_tests_nlo/ref-output/nlo_ppwhh_ew.ref \
ext_tests_nlo/ref-output/nlo_ppww_ew.ref \
ext_tests_nlo/ref-output/nlo_ppwzh_ew.ref \
ext_tests_nlo/ref-output/nlo_ppz_ew.ref \
ext_tests_nlo/ref-output/nlo_ppzzz_ew.ref
# Reference files that depend on the numerical precision
REF_OUTPUT_FILES_DOUBLE = \
functional_tests/ref-output-double/beam_events_2.ref \
functional_tests/ref-output-double/beam_events_3.ref \
functional_tests/ref-output-double/beam_setup_5.ref \
functional_tests/ref-output-double/circe1_4.ref \
functional_tests/ref-output-double/circe1_5.ref \
functional_tests/ref-output-double/circe1_7.ref \
functional_tests/ref-output-double/circe1_8.ref \
functional_tests/ref-output-double/circe1_9.ref \
functional_tests/ref-output-double/circe1_photons_1.ref \
functional_tests/ref-output-double/circe1_photons_2.ref \
functional_tests/ref-output-double/circe1_photons_3.ref \
functional_tests/ref-output-double/circe1_photons_4.ref \
functional_tests/ref-output-double/circe1_photons_5.ref \
functional_tests/ref-output-double/colors_2.ref \
functional_tests/ref-output-double/defaultcuts.ref \
functional_tests/ref-output-double/ep_1.ref \
functional_tests/ref-output-double/ep_2.ref \
functional_tests/ref-output-double/ewa_1.ref \
functional_tests/ref-output-double/ewa_2.ref \
functional_tests/ref-output-double/ewa_3.ref \
functional_tests/ref-output-double/fks_res_1.ref \
functional_tests/ref-output-double/fks_res_3.ref \
functional_tests/ref-output-double/helicity.ref \
functional_tests/ref-output-double/hepmc_8.ref \
functional_tests/ref-output-double/ilc.ref \
functional_tests/ref-output-double/isr_2.ref \
functional_tests/ref-output-double/isr_3.ref \
functional_tests/ref-output-double/isr_4.ref \
functional_tests/ref-output-double/isr_5.ref \
functional_tests/ref-output-double/isr_6.ref \
functional_tests/ref-output-double/lcio_2.ref \
functional_tests/ref-output-double/lcio_7.ref \
functional_tests/ref-output-double/lcio_12.ref \
functional_tests/ref-output-double/lhapdf5.ref \
functional_tests/ref-output-double/lhapdf6.ref \
functional_tests/ref-output-double/lhef_7.ref \
functional_tests/ref-output-double/mlm_matching_isr.ref \
functional_tests/ref-output-double/multi_comp_1.ref \
functional_tests/ref-output-double/multi_comp_2.ref \
functional_tests/ref-output-double/multi_comp_3.ref \
functional_tests/ref-output-double/testproc_12.ref \
functional_tests/ref-output-double/nlo_3.ref \
functional_tests/ref-output-double/nlo_4.ref \
functional_tests/ref-output-double/nlo_5.ref \
functional_tests/ref-output-double/nlo_7.ref \
functional_tests/ref-output-double/nlo_8.ref \
functional_tests/ref-output-double/nlo_9.ref \
functional_tests/ref-output-double/nlo_10.ref \
functional_tests/ref-output-double/observables_2.ref \
functional_tests/ref-output-double/openloops_3.ref \
functional_tests/ref-output-double/openloops_12.ref \
functional_tests/ref-output-double/openloops_13.ref \
functional_tests/ref-output-double/openloops_14.ref \
functional_tests/ref-output-double/parton_shower_2.ref \
functional_tests/ref-output-double/pdf_builtin.ref \
functional_tests/ref-output-double/powheg_1.ref \
functional_tests/ref-output-double/pythia6_3.ref \
functional_tests/ref-output-double/pythia6_4.ref \
functional_tests/ref-output-double/qcdtest_1.ref \
functional_tests/ref-output-double/qcdtest_2.ref \
functional_tests/ref-output-double/qcdtest_3.ref \
functional_tests/ref-output-double/qedtest_3.ref \
functional_tests/ref-output-double/qedtest_4.ref \
functional_tests/ref-output-double/resonances_1.ref \
functional_tests/ref-output-double/resonances_2.ref \
functional_tests/ref-output-double/resonances_3.ref \
functional_tests/ref-output-double/resonances_4.ref \
functional_tests/ref-output-double/resonances_10.ref \
functional_tests/ref-output-double/resonances_11.ref \
functional_tests/ref-output-double/resonances_13.ref \
functional_tests/ref-output-double/resonances_14.ref \
functional_tests/ref-output-double/resonances_15.ref \
functional_tests/ref-output-double/smtest_2.ref \
functional_tests/ref-output-double/smtest_8.ref \
functional_tests/ref-output-double/tauola_1.ref \
functional_tests/ref-output-double/tauola_2.ref \
functional_tests/ref-output-double/tauola_3.ref
REF_OUTPUT_FILES_PREC = \
functional_tests/ref-output-prec/beam_setup_5.ref \
functional_tests/ref-output-prec/circe1_9.ref \
functional_tests/ref-output-prec/circe1_photons_1.ref \
functional_tests/ref-output-prec/circe1_photons_2.ref \
functional_tests/ref-output-prec/circe1_photons_3.ref \
functional_tests/ref-output-prec/circe1_photons_4.ref \
functional_tests/ref-output-prec/circe1_photons_5.ref \
functional_tests/ref-output-prec/colors_2.ref \
functional_tests/ref-output-prec/defaultcuts.ref \
functional_tests/ref-output-prec/ep_1.ref \
functional_tests/ref-output-prec/ep_2.ref \
functional_tests/ref-output-prec/ewa_1.ref \
functional_tests/ref-output-prec/fks_res_1.ref \
functional_tests/ref-output-prec/fks_res_3.ref \
functional_tests/ref-output-prec/helicity.ref \
functional_tests/ref-output-prec/ilc.ref \
functional_tests/ref-output-prec/lhapdf5.ref \
functional_tests/ref-output-prec/lhapdf6.ref \
functional_tests/ref-output-prec/lhef_7.ref \
functional_tests/ref-output-prec/multi_comp_1.ref \
functional_tests/ref-output-prec/multi_comp_2.ref \
functional_tests/ref-output-prec/multi_comp_3.ref \
functional_tests/ref-output-prec/testproc_12.ref \
functional_tests/ref-output-prec/nlo_3.ref \
functional_tests/ref-output-prec/nlo_4.ref \
functional_tests/ref-output-prec/parton_shower_2.ref \
functional_tests/ref-output-prec/pdf_builtin.ref \
functional_tests/ref-output-prec/qcdtest_1.ref \
functional_tests/ref-output-prec/qcdtest_2.ref \
functional_tests/ref-output-prec/qcdtest_3.ref \
functional_tests/ref-output-prec/qedtest_3.ref \
functional_tests/ref-output-prec/qedtest_4.ref \
functional_tests/ref-output-prec/smtest_2.ref \
functional_tests/ref-output-prec/smtest_8.ref
REF_OUTPUT_FILES_EXT = \
functional_tests/ref-output-ext/beam_events_2.ref \
functional_tests/ref-output-ext/beam_events_3.ref \
functional_tests/ref-output-ext/circe1_4.ref \
functional_tests/ref-output-ext/circe1_5.ref \
functional_tests/ref-output-ext/circe1_7.ref \
functional_tests/ref-output-ext/circe1_8.ref \
functional_tests/ref-output-ext/ewa_2.ref \
functional_tests/ref-output-ext/ewa_3.ref \
functional_tests/ref-output-ext/hepmc_8.ref \
functional_tests/ref-output-ext/isr_2.ref \
functional_tests/ref-output-ext/isr_3.ref \
functional_tests/ref-output-ext/isr_4.ref \
functional_tests/ref-output-ext/isr_5.ref \
functional_tests/ref-output-ext/isr_6.ref \
functional_tests/ref-output-ext/lcio_2.ref \
functional_tests/ref-output-ext/lcio_7.ref \
functional_tests/ref-output-ext/lcio_12.ref \
functional_tests/ref-output-ext/mlm_matching_isr.ref \
functional_tests/ref-output-ext/nlo_5.ref \
functional_tests/ref-output-ext/nlo_7.ref \
functional_tests/ref-output-ext/nlo_8.ref \
functional_tests/ref-output-ext/nlo_9.ref \
functional_tests/ref-output-ext/nlo_10.ref \
functional_tests/ref-output-ext/observables_2.ref \
functional_tests/ref-output-ext/openloops_3.ref \
functional_tests/ref-output-ext/openloops_12.ref \
functional_tests/ref-output-ext/openloops_13.ref \
functional_tests/ref-output-ext/openloops_14.ref \
functional_tests/ref-output-ext/powheg_1.ref \
functional_tests/ref-output-ext/pythia6_3.ref \
functional_tests/ref-output-ext/pythia6_4.ref \
functional_tests/ref-output-ext/resonances_1.ref \
functional_tests/ref-output-ext/resonances_2.ref \
functional_tests/ref-output-ext/resonances_3.ref \
functional_tests/ref-output-ext/resonances_4.ref \
functional_tests/ref-output-ext/resonances_10.ref \
functional_tests/ref-output-ext/resonances_11.ref \
functional_tests/ref-output-ext/resonances_13.ref \
functional_tests/ref-output-ext/resonances_14.ref \
functional_tests/ref-output-ext/resonances_15.ref \
functional_tests/ref-output-ext/tauola_1.ref \
functional_tests/ref-output-ext/tauola_2.ref \
functional_tests/ref-output-ext/tauola_3.ref
REF_OUTPUT_FILES_QUAD = \
functional_tests/ref-output-quad/beam_events_2.ref \
functional_tests/ref-output-quad/beam_events_3.ref \
functional_tests/ref-output-quad/circe1_4.ref \
functional_tests/ref-output-quad/circe1_5.ref \
functional_tests/ref-output-quad/circe1_7.ref \
functional_tests/ref-output-quad/circe1_8.ref \
functional_tests/ref-output-quad/ewa_2.ref \
functional_tests/ref-output-quad/ewa_3.ref \
functional_tests/ref-output-quad/hepmc_8.ref \
functional_tests/ref-output-quad/isr_2.ref \
functional_tests/ref-output-quad/isr_3.ref \
functional_tests/ref-output-quad/isr_4.ref \
functional_tests/ref-output-quad/isr_5.ref \
functional_tests/ref-output-quad/isr_6.ref \
functional_tests/ref-output-quad/lcio_2.ref \
functional_tests/ref-output-quad/lcio_7.ref \
functional_tests/ref-output-quad/lcio_12.ref \
functional_tests/ref-output-quad/mlm_matching_isr.ref \
functional_tests/ref-output-quad/nlo_5.ref \
functional_tests/ref-output-quad/nlo_7.ref \
functional_tests/ref-output-quad/nlo_8.ref \
functional_tests/ref-output-quad/nlo_9.ref \
functional_tests/ref-output-quad/nlo_10.ref \
functional_tests/ref-output-quad/observables_2.ref \
functional_tests/ref-output-quad/openloops_3.ref \
functional_tests/ref-output-quad/openloops_12.ref \
functional_tests/ref-output-quad/openloops_13.ref \
functional_tests/ref-output-quad/openloops_14.ref \
functional_tests/ref-output-quad/powheg_1.ref \
functional_tests/ref-output-quad/pythia6_3.ref \
functional_tests/ref-output-quad/pythia6_4.ref \
functional_tests/ref-output-quad/resonances_1.ref \
functional_tests/ref-output-quad/resonances_2.ref \
functional_tests/ref-output-quad/resonances_3.ref \
functional_tests/ref-output-quad/resonances_4.ref \
functional_tests/ref-output-quad/resonances_10.ref \
functional_tests/ref-output-quad/resonances_11.ref \
functional_tests/ref-output-quad/resonances_13.ref \
functional_tests/ref-output-quad/resonances_14.ref \
functional_tests/ref-output-quad/resonances_15.ref \
functional_tests/ref-output-quad/tauola_1.ref \
functional_tests/ref-output-quad/tauola_2.ref \
functional_tests/ref-output-quad/tauola_3.ref
TESTSUITES_M4 = \
$(MISC_TESTS_M4) \
$(EXT_MSSM_M4) \
$(EXT_NMSSM_M4)
TESTSUITES_SIN = \
$(MISC_TESTS_SIN) \
$(EXT_ILC_SIN) \
$(EXT_MSSM_SIN) \
$(EXT_NMSSM_SIN) \
$(EXT_SHOWER_SIN) \
$(EXT_NLO_SIN) \
$(EXT_NLO_ADD_SIN)
MISC_TESTS_M4 =
MISC_TESTS_SIN = \
functional_tests/alphas.sin \
functional_tests/analyze_1.sin \
functional_tests/analyze_2.sin \
functional_tests/analyze_3.sin \
functional_tests/analyze_4.sin \
functional_tests/analyze_5.sin \
functional_tests/analyze_6.sin \
functional_tests/beam_events_1.sin \
functional_tests/beam_events_2.sin \
functional_tests/beam_events_3.sin \
functional_tests/beam_events_4.sin \
functional_tests/beam_setup_1.sin \
functional_tests/beam_setup_2.sin \
functional_tests/beam_setup_3.sin \
functional_tests/beam_setup_4.sin \
functional_tests/beam_setup_5.sin \
functional_tests/bjet_cluster.sin \
functional_tests/br_redef_1.sin \
functional_tests/cascades2_phs_1.sin \
functional_tests/cascades2_phs_2.sin \
functional_tests/circe1_1.sin \
functional_tests/circe1_2.sin \
functional_tests/circe1_3.sin \
functional_tests/circe1_4.sin \
functional_tests/circe1_5.sin \
functional_tests/circe1_6.sin \
functional_tests/circe1_7.sin \
functional_tests/circe1_8.sin \
functional_tests/circe1_9.sin \
functional_tests/circe1_10.sin \
functional_tests/circe1_errors_1.sin \
functional_tests/circe1_photons_1.sin \
functional_tests/circe1_photons_2.sin \
functional_tests/circe1_photons_3.sin \
functional_tests/circe1_photons_4.sin \
functional_tests/circe1_photons_5.sin \
functional_tests/circe2_1.sin \
functional_tests/circe2_2.sin \
functional_tests/circe2_3.sin \
functional_tests/cmdline_1.sin \
functional_tests/cmdline_1_a.sin \
functional_tests/cmdline_1_b.sin \
functional_tests/colors.sin \
functional_tests/colors_2.sin \
functional_tests/colors_hgg.sin \
functional_tests/cuts.sin \
functional_tests/decay_err_1.sin \
functional_tests/decay_err_2.sin \
functional_tests/decay_err_3.sin \
functional_tests/defaultcuts.sin \
functional_tests/empty.sin \
functional_tests/energy_scan_1.sin \
functional_tests/ep_1.sin \
functional_tests/ep_2.sin \
functional_tests/ep_3.sin \
functional_tests/epa_1.sin \
functional_tests/epa_2.sin \
functional_tests/epa_3.sin \
functional_tests/epa_4.sin \
functional_tests/event_dump_1.sin \
functional_tests/event_dump_2.sin \
functional_tests/event_eff_1.sin \
functional_tests/event_eff_2.sin \
functional_tests/event_failed_1.sin \
functional_tests/event_weights_1.sin \
functional_tests/event_weights_2.sin \
functional_tests/ewa_1.sin \
functional_tests/ewa_2.sin \
functional_tests/ewa_3.sin \
functional_tests/ewa_4.sin \
functional_tests/extpar.sin \
functional_tests/fatal.sin \
functional_tests/fatal_beam_decay.sin \
functional_tests/fks_res_1.sin \
functional_tests/fks_res_2.sin \
functional_tests/fks_res_3.sin \
functional_tests/flvsum_1.sin \
functional_tests/gaussian_1.sin \
functional_tests/gaussian_2.sin \
functional_tests/hadronize_1.sin \
functional_tests/helicity.sin \
functional_tests/hepmc_1.sin \
functional_tests/hepmc_2.sin \
functional_tests/hepmc_3.sin \
functional_tests/hepmc_4.sin \
functional_tests/hepmc_5.sin \
functional_tests/hepmc_6.sin \
functional_tests/hepmc_7.sin \
functional_tests/hepmc_8.sin \
functional_tests/hepmc_9.sin \
functional_tests/hepmc_10.sin \
functional_tests/ilc.sin \
functional_tests/isr_1.sin \
functional_tests/isr_2.sin \
functional_tests/isr_3.sin \
functional_tests/isr_4.sin \
functional_tests/isr_5.sin \
functional_tests/isr_6.sin \
functional_tests/isr_epa_1.sin \
functional_tests/jets_xsec.sin \
functional_tests/job_id_1.sin \
functional_tests/job_id_2.sin \
functional_tests/job_id_3.sin \
functional_tests/job_id_4.sin \
functional_tests/lcio_1.sin \
functional_tests/lcio_2.sin \
functional_tests/lcio_3.sin \
functional_tests/lcio_4.sin \
functional_tests/lcio_5.sin \
functional_tests/lcio_6.sin \
functional_tests/lcio_7.sin \
functional_tests/lcio_8.sin \
functional_tests/lcio_9.sin \
functional_tests/lcio_10.sin \
functional_tests/lcio_11.sin \
functional_tests/lcio_12.sin \
functional_tests/lhapdf5.sin \
functional_tests/lhapdf6.sin \
functional_tests/lhef_1.sin \
functional_tests/lhef_2.sin \
functional_tests/lhef_3.sin \
functional_tests/lhef_4.sin \
functional_tests/lhef_5.sin \
functional_tests/lhef_6.sin \
functional_tests/lhef_7.sin \
functional_tests/lhef_8.sin \
functional_tests/lhef_9.sin \
functional_tests/lhef_10.sin \
functional_tests/lhef_11.sin \
functional_tests/libraries_1.sin \
functional_tests/libraries_2.sin \
functional_tests/libraries_3.sin \
functional_tests/libraries_4.sin \
functional_tests/method_ovm_1.sin \
functional_tests/mlm_matching_fsr.sin \
functional_tests/mlm_matching_isr.sin \
functional_tests/mlm_pythia6_isr.sin \
functional_tests/model_change_1.sin \
functional_tests/model_change_2.sin \
functional_tests/model_change_3.sin \
functional_tests/model_scheme_1.sin \
functional_tests/model_test.sin \
functional_tests/mssmtest_1.sin \
functional_tests/mssmtest_2.sin \
functional_tests/mssmtest_3.sin \
functional_tests/multi_comp_1.sin \
functional_tests/multi_comp_2.sin \
functional_tests/multi_comp_3.sin \
functional_tests/multi_comp_4.sin \
functional_tests/nlo_1.sin \
functional_tests/nlo_2.sin \
functional_tests/nlo_3.sin \
functional_tests/nlo_4.sin \
functional_tests/nlo_5.sin \
functional_tests/nlo_6.sin \
functional_tests/nlo_7.sin \
functional_tests/nlo_8.sin \
functional_tests/nlo_9.sin \
functional_tests/nlo_10.sin \
functional_tests/nlo_decay_1.sin \
functional_tests/observables_1.sin \
functional_tests/observables_2.sin \
functional_tests/openloops_1.sin \
functional_tests/openloops_2.sin \
functional_tests/openloops_3.sin \
functional_tests/openloops_4.sin \
functional_tests/openloops_5.sin \
functional_tests/openloops_6.sin \
functional_tests/openloops_7.sin \
functional_tests/openloops_8.sin \
functional_tests/openloops_9.sin \
functional_tests/openloops_10.sin \
functional_tests/openloops_11.sin \
functional_tests/openloops_12.sin \
functional_tests/openloops_13.sin \
functional_tests/openloops_14.sin \
functional_tests/pack_1.sin \
functional_tests/parton_shower_1.sin \
functional_tests/parton_shower_2.sin \
functional_tests/pdf_builtin.sin \
functional_tests/photon_isolation_1.sin \
functional_tests/photon_isolation_2.sin \
functional_tests/polarized_1.sin \
functional_tests/powheg_1.sin \
functional_tests/process_log.sin \
functional_tests/pythia6_1.sin \
functional_tests/pythia6_2.sin \
functional_tests/pythia6_3.sin \
functional_tests/pythia6_4.sin \
functional_tests/pythia8_1.sin \
functional_tests/pythia8_2.sin \
functional_tests/qcdtest_1.sin \
functional_tests/qcdtest_2.sin \
functional_tests/qcdtest_3.sin \
functional_tests/qcdtest_4.sin \
functional_tests/qcdtest_5.sin \
functional_tests/qcdtest_6.sin \
functional_tests/qedtest_1.sin \
functional_tests/qedtest_2.sin \
functional_tests/qedtest_3.sin \
functional_tests/qedtest_4.sin \
functional_tests/qedtest_5.sin \
functional_tests/qedtest_6.sin \
functional_tests/qedtest_7.sin \
functional_tests/qedtest_8.sin \
functional_tests/qedtest_9.sin \
functional_tests/qedtest_10.sin \
functional_tests/rambo_vamp_1.sin \
functional_tests/rambo_vamp_2.sin \
functional_tests/real_partition_1.sin \
functional_tests/rebuild_1.sin \
functional_tests/rebuild_2.sin \
functional_tests/rebuild_3.sin \
functional_tests/rebuild_4.sin \
functional_tests/rebuild_5.sin \
functional_tests/recola_1.sin \
functional_tests/recola_2.sin \
functional_tests/recola_3.sin \
functional_tests/recola_4.sin \
functional_tests/recola_5.sin \
functional_tests/recola_6.sin \
functional_tests/recola_7.sin \
functional_tests/recola_8.sin \
functional_tests/recola_9.sin \
functional_tests/resonances_1.sin \
functional_tests/resonances_2.sin \
functional_tests/resonances_3.sin \
functional_tests/resonances_4.sin \
functional_tests/resonances_5.sin \
functional_tests/resonances_6.sin \
functional_tests/resonances_7.sin \
functional_tests/resonances_8.sin \
functional_tests/resonances_9.sin \
functional_tests/resonances_10.sin \
functional_tests/resonances_11.sin \
functional_tests/resonances_12.sin \
functional_tests/resonances_13.sin \
functional_tests/resonances_14.sin \
functional_tests/resonances_15.sin \
functional_tests/restrictions.sin \
functional_tests/reweight_1.sin \
functional_tests/reweight_2.sin \
functional_tests/reweight_3.sin \
functional_tests/reweight_4.sin \
functional_tests/reweight_5.sin \
functional_tests/reweight_6.sin \
functional_tests/reweight_7.sin \
functional_tests/reweight_8.sin \
functional_tests/reweight_9.sin \
functional_tests/reweight_10.sin \
functional_tests/select_1.sin \
functional_tests/select_2.sin \
functional_tests/show_1.sin \
functional_tests/show_2.sin \
functional_tests/show_3.sin \
functional_tests/show_4.sin \
functional_tests/show_5.sin \
functional_tests/shower_err_1.sin \
functional_tests/sm_cms_1.sin \
functional_tests/smtest_1.sin \
functional_tests/smtest_2.sin \
functional_tests/smtest_3.sin \
functional_tests/smtest_4.sin \
functional_tests/smtest_5.sin \
functional_tests/smtest_6.sin \
functional_tests/smtest_7.sin \
functional_tests/smtest_8.sin \
functional_tests/smtest_9.sin \
functional_tests/smtest_10.sin \
functional_tests/smtest_11.sin \
functional_tests/smtest_12.sin \
functional_tests/smtest_13.sin \
functional_tests/smtest_14.sin \
functional_tests/smtest_15.sin \
functional_tests/smtest_16.sin \
functional_tests/smtest_17.sin \
functional_tests/spincor_1.sin \
functional_tests/static_1.exe.sin \
functional_tests/static_1.sin \
functional_tests/static_2.exe.sin \
functional_tests/static_2.sin \
functional_tests/stdhep_1.sin \
functional_tests/stdhep_2.sin \
functional_tests/stdhep_3.sin \
functional_tests/stdhep_4.sin \
functional_tests/stdhep_5.sin \
functional_tests/stdhep_6.sin \
functional_tests/structure_1.sin \
functional_tests/structure_2.sin \
functional_tests/structure_3.sin \
functional_tests/structure_4.sin \
functional_tests/structure_5.sin \
functional_tests/structure_6.sin \
functional_tests/structure_7.sin \
functional_tests/structure_8.sin \
functional_tests/susyhit.sin \
functional_tests/tauola_1.sin \
functional_tests/tauola_2.sin \
functional_tests/tauola_3.sin \
functional_tests/template_me_1.sin \
functional_tests/template_me_2.sin \
functional_tests/testproc_1.sin \
functional_tests/testproc_2.sin \
functional_tests/testproc_3.sin \
functional_tests/testproc_4.sin \
functional_tests/testproc_5.sin \
functional_tests/testproc_6.sin \
functional_tests/testproc_7.sin \
functional_tests/testproc_8.sin \
functional_tests/testproc_9.sin \
functional_tests/testproc_10.sin \
functional_tests/testproc_11.sin \
functional_tests/testproc_12.sin \
functional_tests/ufo_1.sin \
functional_tests/ufo_2.sin \
functional_tests/ufo_3.sin \
functional_tests/ufo_4.sin \
functional_tests/ufo_5.sin \
functional_tests/ufo_6.sin \
functional_tests/user_prc_threshold_1.sin \
functional_tests/user_prc_threshold_2.sin \
functional_tests/vamp2_1.sin \
functional_tests/vamp2_2.sin \
functional_tests/vamp2_3.sin \
functional_tests/vars.sin
EXT_MSSM_M4 = \
ext_tests_mssm/mssm_ext-aa.m4 \
ext_tests_mssm/mssm_ext-bb.m4 \
ext_tests_mssm/mssm_ext-bt.m4 \
ext_tests_mssm/mssm_ext-dd.m4 \
ext_tests_mssm/mssm_ext-dd2.m4 \
ext_tests_mssm/mssm_ext-ddckm.m4 \
ext_tests_mssm/mssm_ext-dg.m4 \
ext_tests_mssm/mssm_ext-ee.m4 \
ext_tests_mssm/mssm_ext-ee2.m4 \
ext_tests_mssm/mssm_ext-en.m4 \
ext_tests_mssm/mssm_ext-ga.m4 \
ext_tests_mssm/mssm_ext-gg.m4 \
ext_tests_mssm/mssm_ext-gw.m4 \
ext_tests_mssm/mssm_ext-gz.m4 \
ext_tests_mssm/mssm_ext-tn.m4 \
ext_tests_mssm/mssm_ext-tt.m4 \
ext_tests_mssm/mssm_ext-ug.m4 \
ext_tests_mssm/mssm_ext-uu.m4 \
ext_tests_mssm/mssm_ext-uu2.m4 \
ext_tests_mssm/mssm_ext-uuckm.m4 \
ext_tests_mssm/mssm_ext-wa.m4 \
ext_tests_mssm/mssm_ext-ww.m4 \
ext_tests_mssm/mssm_ext-wz.m4 \
ext_tests_mssm/mssm_ext-za.m4 \
ext_tests_mssm/mssm_ext-zz.m4
EXT_NMSSM_M4 = \
ext_tests_nmssm/nmssm_ext-aa.m4 \
ext_tests_nmssm/nmssm_ext-bb1.m4 \
ext_tests_nmssm/nmssm_ext-bb2.m4 \
ext_tests_nmssm/nmssm_ext-bt.m4 \
ext_tests_nmssm/nmssm_ext-dd1.m4 \
ext_tests_nmssm/nmssm_ext-dd2.m4 \
ext_tests_nmssm/nmssm_ext-ee1.m4 \
ext_tests_nmssm/nmssm_ext-ee2.m4 \
ext_tests_nmssm/nmssm_ext-en.m4 \
ext_tests_nmssm/nmssm_ext-ga.m4 \
ext_tests_nmssm/nmssm_ext-gg.m4 \
ext_tests_nmssm/nmssm_ext-gw.m4 \
ext_tests_nmssm/nmssm_ext-gz.m4 \
ext_tests_nmssm/nmssm_ext-qg.m4 \
ext_tests_nmssm/nmssm_ext-tn.m4 \
ext_tests_nmssm/nmssm_ext-tt1.m4 \
ext_tests_nmssm/nmssm_ext-tt2.m4 \
ext_tests_nmssm/nmssm_ext-uu1.m4 \
ext_tests_nmssm/nmssm_ext-uu2.m4 \
ext_tests_nmssm/nmssm_ext-wa.m4 \
ext_tests_nmssm/nmssm_ext-ww1.m4 \
ext_tests_nmssm/nmssm_ext-ww2.m4 \
ext_tests_nmssm/nmssm_ext-wz.m4 \
ext_tests_nmssm/nmssm_ext-za.m4 \
ext_tests_nmssm/nmssm_ext-zz1.m4 \
ext_tests_nmssm/nmssm_ext-zz2.m4
EXT_MSSM_SIN = $(EXT_MSSM_M4:.m4=.sin)
EXT_NMSSM_SIN = $(EXT_NMSSM_M4:.m4=.sin)
EXT_ILC_SIN = \
ext_tests_ilc/ilc_settings.sin \
ext_tests_ilc/ilc_top_pair_360.sin \
ext_tests_ilc/ilc_top_pair_500.sin \
ext_tests_ilc/ilc_vbf_higgs_360.sin \
ext_tests_ilc/ilc_vbf_higgs_500.sin \
ext_tests_ilc/ilc_vbf_no_higgs_360.sin \
ext_tests_ilc/ilc_vbf_no_higgs_500.sin \
ext_tests_ilc/ilc_higgs_strahlung_360.sin \
ext_tests_ilc/ilc_higgs_strahlung_500.sin \
ext_tests_ilc/ilc_higgs_strahlung_background_360.sin \
ext_tests_ilc/ilc_higgs_strahlung_background_500.sin \
ext_tests_ilc/ilc_higgs_coupling_360.sin \
ext_tests_ilc/ilc_higgs_coupling_500.sin \
ext_tests_ilc/ilc_higgs_coupling_background_360.sin \
ext_tests_ilc/ilc_higgs_coupling_background_500.sin
EXT_SHOWER_SIN = \
ext_tests_shower/shower_1_norad.sin \
ext_tests_shower/shower_2_aall.sin \
ext_tests_shower/shower_3_bb.sin \
ext_tests_shower/shower_3_jj.sin \
ext_tests_shower/shower_3_qqqq.sin \
ext_tests_shower/shower_3_tt.sin \
ext_tests_shower/shower_3_z_nu.sin \
ext_tests_shower/shower_3_z_tau.sin \
ext_tests_shower/shower_4_ee.sin \
ext_tests_shower/shower_5.sin \
ext_tests_shower/shower_6.sin
EXT_NLO_SIN = \
ext_tests_nlo/nlo_ee4b.sin \
ext_tests_nlo/nlo_ee4j.sin \
ext_tests_nlo/nlo_ee4t.sin \
ext_tests_nlo/nlo_ee4tj.sin \
ext_tests_nlo/nlo_ee5j.sin \
ext_tests_nlo/nlo_eebb.sin \
ext_tests_nlo/nlo_eebbj.sin \
ext_tests_nlo/nlo_eebbjj.sin \
ext_tests_nlo/nlo_eejj.sin \
ext_tests_nlo/nlo_eejjj.sin \
ext_tests_nlo/nlo_eett.sin \
ext_tests_nlo/nlo_eetta.sin \
ext_tests_nlo/nlo_eettaa.sin \
ext_tests_nlo/nlo_eettah.sin \
ext_tests_nlo/nlo_eettaj.sin \
ext_tests_nlo/nlo_eettajj.sin \
ext_tests_nlo/nlo_eettaz.sin \
ext_tests_nlo/nlo_eettbb.sin \
ext_tests_nlo/nlo_eetth.sin \
ext_tests_nlo/nlo_eetthh.sin \
ext_tests_nlo/nlo_eetthj.sin \
ext_tests_nlo/nlo_eetthjj.sin \
ext_tests_nlo/nlo_eetthz.sin \
ext_tests_nlo/nlo_eettj.sin \
ext_tests_nlo/nlo_eettjj.sin \
ext_tests_nlo/nlo_eettjjj.sin \
ext_tests_nlo/nlo_eettwjj.sin \
ext_tests_nlo/nlo_eettww.sin \
ext_tests_nlo/nlo_eettz.sin \
ext_tests_nlo/nlo_eettzj.sin \
ext_tests_nlo/nlo_eettzjj.sin \
ext_tests_nlo/nlo_eettzz.sin \
ext_tests_nlo/nlo_ppzj_real_partition.sin \
ext_tests_nlo/nlo_pptttt.sin \
ext_tests_nlo/nlo_ppw.sin \
ext_tests_nlo/nlo_ppz.sin \
ext_tests_nlo/nlo_ppzj_sim_1.sin \
ext_tests_nlo/nlo_ppzj_sim_2.sin \
ext_tests_nlo/nlo_ppzj_sim_3.sin \
ext_tests_nlo/nlo_ppzj_sim_4.sin \
ext_tests_nlo/nlo_ppzw.sin \
ext_tests_nlo/nlo_ppzz.sin \
ext_tests_nlo/nlo_ppee_ew.sin \
ext_tests_nlo/nlo_pphee_ew.sin \
ext_tests_nlo/nlo_pphjj_ew.sin \
ext_tests_nlo/nlo_pphz_ew.sin \
ext_tests_nlo/nlo_ppllll_ew.sin \
ext_tests_nlo/nlo_ppllnn_ew.sin \
ext_tests_nlo/nlo_pptj_ew.sin \
ext_tests_nlo/nlo_ppwhh_ew.sin \
ext_tests_nlo/nlo_ppww_ew.sin \
ext_tests_nlo/nlo_ppwzh_ew.sin \
ext_tests_nlo/nlo_ppz_ew.sin \
ext_tests_nlo/nlo_ppzzz_ew.sin \
ext_tests_nlo/nlo_settings.sin \
ext_tests_nlo/nlo_settings_ew.sin
EXT_NLO_ADD_SIN = \
ext_tests_nlo_add/nlo_decay_tbw.sin \
ext_tests_nlo_add/nlo_fks_delta_i_ppee.sin \
ext_tests_nlo_add/nlo_fks_delta_o_eejj.sin \
ext_tests_nlo_add/nlo_jets.sin \
ext_tests_nlo_add/nlo_methods_gosam.sin \
ext_tests_nlo_add/nlo_qq_powheg.sin \
ext_tests_nlo_add/nlo_threshold_factorized.sin \
ext_tests_nlo_add/nlo_threshold.sin \
ext_tests_nlo_add/nlo_tt_powheg_sudakov.sin \
ext_tests_nlo_add/nlo_tt_powheg.sin \
ext_tests_nlo_add/nlo_tt.sin \
ext_tests_nlo_add/nlo_uu_powheg.sin \
ext_tests_nlo_add/nlo_uu.sin
all-local: $(TESTSUITES_SIN)
if M4_AVAILABLE
SUFFIXES = .m4 .sin
.m4.sin:
case "$@" in \
*/*) \
mkdir -p `sed 's,/.[^/]*$$,,g' <<< "$@"` ;; \
esac
$(M4) $(srcdir)/$(TESTSUITE_MACROS) $< > $@
endif M4_AVAILABLE

File Metadata

Mime Type
text/x-diff
Expires
Tue, Nov 19, 9:20 PM (1 d, 1 h)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
3806244
Default Alt Text
(949 KB)

Event Timeline