No OneTemporary
Actions

Size

949 KB

Subscribers

None

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(i8+j2+1:i8+j2+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(cutoff2)) - log (s / cutoff2)) - &
	log (one/two)
	else
	f = - (log (s) * log (log (s) / log(x2)) - log (s / x2)) - &
	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) + tya(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,bb)
	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,bb)
	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(ktheta),sin(ktheta),SPC)
	zroots_unity(k+2:min(2k,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(2size(uc,1)-1,2size(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+B21hdydx
	call derivs(x+A2*h,ytemp,ak2)
	ytemp=y+h(B31dydx+B32*ak2)
	call derivs(x+A3*h,ytemp,ak3)
	ytemp=y+h(B41dydx+B42ak2+B43ak3)
	call derivs(x+A4*h,ytemp,ak4)
	ytemp=y+h(B51dydx+B52ak2+B53ak3+B54*ak4)
	call derivs(x+A5*h,ytemp,ak5)
	ytemp=y+h(B61dydx+B62ak2+B63ak3+B64ak4+B65ak5)
	call derivs(x+A6*h,ytemp,ak6)
	yout=y+h(C1dydx+C3ak3+C4ak4+C6*ak6)
	yerr=h(DC1dydx+DC3ak3+DC4ak4+DC5ak5+DC6ak6)
	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=SAFETYh(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=SAFETYh(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+hyout)
	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/(2km+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_aahypgeo_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=((aabb)/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=xrsum(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)-pivca(2:n-1:2)
	q(1:nm) = r(2:n-1:2)-piva(1:nm)r(1:n-2:2)-pivcr(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=aya(klo)+bya(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 xcdeltc1 + xcdeltllog(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.d0pi)*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(2n/3+1), w1(2n/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(2n/3+1), w1(2n/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(2n/3+1), w1(2n/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.d0critp), pp(2n/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.d0dsqrt(energytmass))
	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.d0pi/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)2aimag(gg(i)
	cc u (1.d0+kincov(pp(i)/tmass)**2)
	u (1.d0+kincovg0(pp(i))(pp(i)/tmass)*2/g0c(pp(i)))
	u )
	else
	sig1 = sig1 + w1(i)pp(i)2aimag(gg(i))
	endif
	if (pp(i).lt.dcut.and.kinflg.ne.0) then
	sig2 = sig2 + w1(i)pp(i)2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u (1.d0-pp(i)2/2.d0/tmass*2)
	cc u tmass/dsqrt(tmass2+pp(i)*2)
	xdsdp(i)=pp(i)*2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u (1.d0-pp(i)2/2.d0/tmass*2)
	u /(2.d0pi2)const
	else
	sig2 = sig2 + w1(i)pp(i)2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	xdsdp(i)=pp(i)*2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u /(2.d0pi2)const
	endif
	c write(,) 'xdsdp = ',xdsdp(i)
	c write(,) 'zvfct = ',zvfct(i)
	60 continue
	c 'p2' because of substitution p => 1/p in the integration of p2G(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)4aimag(gg(i)
	cc u (1.d0+kincov(pp(i)/tmass)**2)
	u (1.d0+kincovg0(pp(i))(pp(i)/tmass)*2/g0c(pp(i)))
	u )
	else
	sig1 = sig1 + w1(i)pp(i)4aimag(gg(i))
	endif
	if (pp(i).lt.dcut.and.kinflg.ne.0) then
	sig2 = sig2 + w1(i)pp(i)4abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u (1.d0-pp(i)2/2.d0/tmass*2)
	cc u tmass/dsqrt(tmass2+pp(i)*2)
	xdsdp(i)=pp(i)*2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u (1.d0-pp(i)2/2.d0/tmass*2)
	u /(2.d0pi2)const
	else
	sig2 = sig2 + w1(i)pp(i)4abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	xdsdp(i)=pp(i)*2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u /(2.d0pi2)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.d0pi2) const
	sig2 = sig2 / (2.d0pi2) 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 tgammagtpcor(p,2.d0tmass+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.d0tmass+energy),
	u kind=kind(0d0))
	zk=sqrt(zk)
	amd2k=4.d0/3.d0alphastmass/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=-zitmass/(4.d0pzk)/(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.d0pi2)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.d0ca-20.d0/9.d0tf*xnf
	a2=(4343.d0/162.d0+4.d0pi2-pi*4/4.d0+
	u 22.d0/3.d0zeta3)ca**2-
	u (1798.d0/81.d0+56.d0/3.d0zeta3)catfxnf-
	u (55.d0/3.d0-16.d0zeta3)cftfxnf+
	u (20.d0/9.d0tfxnf)**2
	c
	pm=p
	xkm=xk
	cnspot=-4.d0/3.d04.d0pi
	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.d0dlog(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)2dlog(scale/p)
	xkpln3rd=-6.d0(xk/p)2dlog(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 * xk2 / p2 * 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.d0pi)a1
	c1=alphas/(4.d0pi)b0
	c2=0
	else if (npot.eq.4) then
	c0=1.d0+alphas/(4.d0pi)a1+(alphas/(4.d0pi))2a2
	c1=alphas/(4.d0pi)b0+
	u (alphas/(4.d0pi))2(b1+2.d0b0a1)
	c2=(alphas/(4.d0pi))2b0**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(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	c u -1.d0/2.d0(1.d0+2.d0ca/cf)
	c u (picfalphas)*2/tmass
	c u xk/p(p+xk-dabs(xk-p))
	c else if (dabs(xk-p).lt.dcut) then
	c vhat=phiint(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	c u -1.d0/2.d0(1.d0+2.d0ca/cf)
	c u (picfalphas)*2/tmass
	c u xk/p(dcut-dabs(xk-p))
	c else if (dcut.le.dabs(xk-p)) then
	c vhat=phiint(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	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(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	c All other potentials:
	u +cdeltc2.d0xk**2
	u +cdeltlxk/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(p2+xk2)xkpln1st
	u +cfulll(p2+xk2)xk/p/4.d0*
	u (dlog(((p+xk)/scale)2)2-
	u dlog(((p-xk)/scale)2)2)
	u +crm2xk/p(p+xk-dabs(xk-p))
	else
	vhat=phiint(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	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* 4piALPHEF(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/(8PI2P)
	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)Q0Y
	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)Q03Y
	RETURN
	ENTRY FIN03P(Q)
	Q0=Q
	XL=(P0-Q0)**2
	XU=(P0+Q0)**2
	CALL ADQUA(XL,XU,FIN12P,Y,ACC0)
	FIN03P= VQQBAR(Q0)Q0Y
	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)Q03Y
	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/(T12+GAMMA2)
	RETURN
	ENTRY FIN12P(T)
	T1= T+VMEM
	TSQRT= SQRT(T)
	GAMMA= TM*GAMTPE(TSQRT,E0)
	FIN12P= GAMMA/(T12+GAMMA2)
	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/32/piy
	VQ=(-.25-v)(2pi)**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/34PIALPHEF(P)/P*2
	END
	C
	FUNCTION ALPHEF(q)
	c
	c V(q) = -4/3 * 4piALPHEF(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-10nf/9)alphas/(4pi) )
	c where alphas=\alpha_\bar{MS} for nf=5, i.e.
	c alpha=4pi/( b0(nf=5)x + b1(5)/b0(5)*ln(x) )
	c and x = ln(q2/alamb52)
	c for qmat1 > q > qcut:
	c 4pi/b0(nefr=3)(alfmt+1/log(1+q2/alr2))
	c where alr=.4 GeV, nefr=3, and continuity --> alfmt
	c below qcut: alphrc2q2/(q2+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(2q2)/(qcut2+q**2)
	elseif(q.le.qmat1) then
	alphef=alfmt+d/log(1+q2/alr2)
	else
	x=2*log(q/alamb5)
	alfas5=1/(a5x+b5log(x))
	alphef=alfas5(1+c5alfas5)
	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/(a5xa + b5log(xa))
	else
	if(alphas.le.0d0) STOP 10003
	t0=0
	t1=max(1d0,alphas*a5)
	10 tm=(t0+t1)/2
	fm=tm/alphas+b5tmlog(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/(a5x+b5log(x))
	alfmt=alfas(1+c5alfas)-d/log(1+qmat12/alr2)
	alphrc=alfmt+ d/log(1+qcut2/alr2)
	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+2DILOG(X)-2DILOG(1-X)+( 4X(1-X-2X*2)LOG(X)+
	+ F(X)= PI*2+2DILOGG(X)-2DILOGG(1-X)+( 4X(1-X-2X*2)LOG(X)+
	$2(1-X)2(5+4X)LOG(1-X) - (1-X)(5+9X-6X*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= GFERMITMASS3/(8SQRT(2D0)PI)(1-Y)*2(1+2Y)
	$(1- 2D0/3ALPHAS/PIF(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=itptmass/NG2
	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(tp3))
	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 = CORRF2SQRT(1-TOPP2/(TOPP2+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+wmasswgammaTAN((2ran2(idum)-1)*pi/2)
	3 s1= wmass*2+wmasswgammaTAN((2ranf(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+wmasswgammaTAN((2ran2(idum)-1)*pi/2)
	4 s2= wmass*2+wmasswgammaTAN((2ranf(idum)-1)*pi/2)
	if(s2.le.0d0) goto 4
	wmass2= sqrt(s2)
	if(abs(wmass2-wmass).ge.3*wgamma) goto 4
	ew1= (tmass2+wmass12-bmass*2)/(2tmass)
	pwt1= sqrt(ew12-wmass12)
	ew2= (tmass2+wmass22-bmass*2)/(2tmass)
	pwt2= sqrt(ew22-wmass22)
	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(tmass2+p2)
	bet= p/et
	gam= et/tmass
	pw1(0)= gam(ew1+betpw1z)
	pw1(3)= gam(pw1z+betew1)
	pw2(0)= gam(ew2-betpw2z)
	pw2(3)= gam(pw2z-betew2)
	pw1tr= sqrt(pw1(0)2-pw1(3)2-wmass1**2)
	pw2tr= sqrt(pw2(0)2-pw2(3)2-wmass2**2)
	c phi1= 2piran2(idum)
	phi1= 2piranf(idum)
	c phi2= 2piran2(idum)
	phi2= 2piranf(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.d0pi2) g0c(pp(i))
	c cw(i) = w1(i) / (4.d0pi2
	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.d0pi2) g0c(pp(i)) * pp(i)**2
	c cw(i) = w1(i) / (4.d0pi2
	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.D0J-1.D0)ZP2-(J-1.D0)P3)/J
	11 CONTINUE
	PP=N(ZP1-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.D0XL/((1.D0-ZZ)PPPP)
	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-cxx(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-cxx(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+cxx(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+cxx(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 1002*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.d0KH)
	7 S1=0.d0
	DO 10 K=1,N02
	10 S1=S1+F(A+(2.d0K-1.d0)H)
	Y=H/3.d0(S0+4.d0S1+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.5DLOG(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=ST(A-B)+Z
	+ DILOGG=ST(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+(ser3ser02-3.d0ser2ser1ser0+2.d0ser12ser1)
	. /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 xcdeltc1 + xcdeltllog(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_VG_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.d0pi)*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(2n/3+1), w1(2n/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(2n/3+1), w1(2n/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(2n/3+1), w1(2n/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.d0critp), pp(2n/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.d0sqrt(energytmass))
	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.d0pi/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)2aimag(gg(i)
	cc u (1.d0+kincov(pp(i)/tmass)**2)
	u (1.d0+kincovg0(pp(i))(pp(i)/tmass)*2/g0c(pp(i)))
	u )
	else
	sig1 = sig1 + w1(i)pp(i)2aimag(gg(i))
	endif
	if (pp(i).lt.dcut.and.kinflg.ne.0) then
	sig2 = sig2 + w1(i)pp(i)2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u (1.d0-pp(i)2/2.d0/tmass*2)
	cc u tmass/sqrt(tmass2+pp(i)*2)
	c xdsdp(i)=pp(i)*2abs(gg(i))*2
	c u tgamma*gtpcor(pp(i),etot)
	c u (1.d0-pp(i)2/2.d0/tmass*2)
	c u /(2.d0pi2)const
	else
	sig2 = sig2 + w1(i)pp(i)2abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	c xdsdp(i)=pp(i)*2abs(gg(i))*2
	c u tgamma*gtpcor(pp(i),etot)
	c u /(2.d0pi2)const
	endif
	xdsdp(i)=pp(i)4/tmass2abs(zftild(i)g0c(pp(i)))**2
	u tgammagtpcor(pp(i),etot)
	u /(2.d0pi2)const
	xaai=xaai+w1(i)pp(i)4/tmass2
	u aimag(zftild(i)*g0c(pp(i)))
	xaad=xaad+w1(i)pp(i)4/tmass2
	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 'p2' because of substitution p => 1/p in the integration of p2G(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)4aimag(gg(i)
	cc u (1.d0+kincov(pp(i)/tmass)**2)
	u (1.d0+kincovg0(pp(i))(pp(i)/tmass)*2/g0c(pp(i)))
	u )
	else
	sig1 = sig1 + w1(i)pp(i)4aimag(gg(i))
	endif
	if (pp(i).lt.dcut.and.kinflg.ne.0) then
	sig2 = sig2 + w1(i)pp(i)4abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	u (1.d0-pp(i)2/2.d0/tmass*2)
	cc u tmass/sqrt(tmass2+pp(i)*2)
	c xdsdp(i)=pp(i)*2abs(gg(i))*2
	c u tgamma*gtpcor(pp(i),etot)
	c u (1.d0-pp(i)2/2.d0/tmass*2)
	c u /(2.d0pi2)const
	else
	sig2 = sig2 + w1(i)pp(i)4abs(gg(i))*2
	u tgamma*gtpcor(pp(i),etot)
	c xdsdp(i)=pp(i)*2abs(gg(i))*2
	c u tgamma*gtpcor(pp(i),etot)
	c u /(2.d0pi2)const
	endif
	xdsdp(i)=pp(i)4/tmass2abs(zftild(i)g0c(pp(i)))**2
	u tgammagtpcor(pp(i),etot)
	u /(2.d0pi2)const
	xaai=xaai+w1(i)pp(i)6/tmass2
	u aimag(zftild(i)*g0c(pp(i)))
	xaad=xaad+w1(i)pp(i)6/tmass2
	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.d0pi2) const
	sig2 = sig2 / (2.d0pi2) 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.d0pi2) const
	xaad=xaad / (2.d0pi2) 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.d0ca-20.d0/9.d0tf*xnf
	a2=(4343.d0/162.d0+4.d0pi2-pi*4/4.d0+
	u 22.d0/3.d0zeta3)ca**2-
	u (1798.d0/81.d0+56.d0/3.d0zeta3)catfxnf-
	u (55.d0/3.d0-16.d0zeta3)cftfxnf+
	u (20.d0/9.d0tfxnf)**2
	c
	cnspot=-4.d0/3.d04.d0pi
	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=zipi/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.d0pi(zlp+zlm)+2.d0zi(zlm2+zlmzlp+zlp**2))
	c Sum of the Coulomb contributions:
	za=c0zalo-c1(zanlo-2.d0dlog(scale)zalo)
	u +c2(zannlo-4.d0dlog(scale)*zanlo
	u +4.d0dlog(scale)2zalo)
	c (Higgs) Yukawa contribution
	cctt zahig=zipi/2.d0/plog((zb+p+zihmass)/(zb-p+zihmass))
	c Alltogether:
	cctt aax=-tmass/(4.d0pi2)(phiintza+chiggszahig)
	aax=-tmass/(4.d0pi2)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.d0ca-20.d0/9.d0tf*xnf
	a2=(4343.d0/162.d0+4.d0pi2-pi*4/4.d0+
	u 22.d0/3.d0zeta3)ca**2-
	u (1798.d0/81.d0+56.d0/3.d0zeta3)catfxnf-
	u (55.d0/3.d0-16.d0zeta3)cftfxnf+
	u (20.d0/9.d0tfxnf)**2
	c
	pm=p
	xkm=xk
	cnspot=-4.d0/3.d04.d0pi
	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.d0log(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)2log(scale/p)
	xkpln3rd=-6.d0(xk/p)2log(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 * xk2 / p2 * 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.d0pi)a1
	c1=alphas/(4.d0pi)b0
	c2=0
	else if (npot.eq.4) then
	c0=1.d0+alphas/(4.d0pi)a1+(alphas/(4.d0pi))2a2
	c1=alphas/(4.d0pi)b0+
	u (alphas/(4.d0pi))2(b1+2.d0b0a1)
	c2=(alphas/(4.d0pi))2b0**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(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	c u -1.d0/2.d0(1.d0+2.d0ca/cf)
	c u (picfalphas)*2/tmass
	c u xk/p(p+xk-abs(xk-p))
	c else if (abs(xk-p).lt.dcut) then
	c vhatax=phiint(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	c u -1.d0/2.d0(1.d0+2.d0ca/cf)
	c u (picfalphas)*2/tmass
	c u xk/p(dcut-abs(xk-p))
	c else if (dcut.le.abs(xk-p)) then
	c vhatax=phiint(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	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(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	c All other potentials:
	c u +cdeltc2.d0xk**2
	c u +cdeltlxk/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(p2+xk2)xkpln1st
	c u +cfulll(p2+xk2)xk/p/4.d0*
	c u (log(((p+xk)/scale)2)2-
	c u log(((p-xk)/scale)2)2)
	c u +crm2xk/p(p+xk-abs(xk-p))
	c else
	c vhatax=phiint(c0xkpln1st+c1xkpln2nd+c2xkpln3rd)
	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.d0ca-20.d0/9.d0tf*xnf
	a2=(4343.d0/162.d0+4.d0pi2-pi*4/4.d0+
	u 22.d0/3.d0zeta3)ca**2-
	u (1798.d0/81.d0+56.d0/3.d0zeta3)catfxnf-
	u (55.d0/3.d0-16.d0zeta3)cftfxnf+
	u (20.d0/9.d0tfxnf)**2
	c
	pm=p
	xkm=xk
	cnspot=-4.d0/3.d04.d0pi
	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.d0pi)a1
	c1=alphas/(4.d0pi)b0
	c2=0
	else if (npot.eq.4) then
	write(,) '2nd order Coulomb in Vhhat not implemented yet.'
	stop
	c0=1.d0+alphas/(4.d0pi)a1+(alphas/(4.d0pi))2a2
	c1=alphas/(4.d0pi)b0+
	u (alphas/(4.d0pi))2(b1+2.d0b0a1)
	c2=(alphas/(4.d0pi))2b0**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+(xk2+p2)/(2.d0xkp)*
	u (dlog(dabs(p-xk))-dlog(p+xk)))
	c xkpln1st=-(xk/p)*2(1.d0+(xk2+p2)/(4.d0xkp)*
	c u (dlog((p-xk)*2)-2.d0dlog(p+xk)))
	c
	xkpln2nd=((xk/p)*2/2.d0+xk(xk2+p2)/8.d0/p*3
	u (dlog((p-xk)*2)-2.d0dlog(p+xk)))*
	u (-2.d0+dlog((xk-p)2/scale2)
	u +dlog((xk+p)2/scale2))
	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(c0xkpln1st+c1xkpln2nd+c2xkpln3rd),
	cctt u 0.d0)
	vhhat=cmplx(phiint(c0xkpln1st+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.d0pi2) g0c(pp(i))
	c cw(i) = w1(i) / (4.d0pi2
	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.d0pi2) g0c(pp(i)) * pp(i)**2
	c cw(i) = w1(i) / (4.d0pi2
	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.pi2 - pi*4/4. + &
	22./3.z3)CA*2 - (1798./81. + 56./3.z3)CATR*NF - &
	(55./3. - 16.z3)CFTRNF + (20./9.TRNF)**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 - p2
	k2 = (sqrts/2.-p0)2 - p2
	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 - imagom*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(CACF(9.CA - 100.*CF) - &
	B0(26.CA*2 + 19.CACF - 32.CF*2)))/(26.B0*2 CA)
	aa3(1) = CF2/( B02 (6.B0 - 13.CA)(B0 - 2.CA)) &
	(CA*2 (9.CA - 100.CF) + B0CA(74.CF - CA16.) - &
	6.B02 (2.*CF - CA))
	aa4(1) = (24.CF2 (11.CA - 3.B0)(5.CA + 8.*CF)) / &
	(13.CA(6.B0 - 13.CA)**2)
	aa5(1) = (CF*2 (CA(15.-28) + B05.))/(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.CACF(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 v2 + (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 + 2B0A1)
	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( -men -imagom*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.pk) / (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( -men -imagom*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 + imagok(1.-la)(z1-z2) + imagok(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 + imagoGAM_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:in) = 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, 2POINTS_SQ)], reshape (nan, [2POINTS_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 + mv**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 = CFa 2.pi(log_mppp-log_mmpm) * q/p
	case (1)
	log_mu_s = 2.*log(MU_SOFT)
	v = CFa (2.(4.pi+A1a)(log_mppp-log_mmpm) &
	+ B0a((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 - k2p2
	chi = p2k2q2 + 2.m2((p2 + k2)kp - 2.p2k2) + m22 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.(-m2pq - p2kq) + kpL2 - p2L1 - 2.pq*S)
	JB = 1./D2 * (J0/2.( m2kq + k2pq) + kpL1 - k2L2 + 2.kq*S)
	JC = 1/(4.D2) (2.p2 + 2kpm2/k2 - 4.kpS + 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 + 2kpm2/p2 - 4.kpS + 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 + p2q2/chi (k2 - m2)(m2 + kp))*L1 + &
	k2q2/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 + k2q2/chi (p2 - m2)(m2 + kp))*L2 + &
	p2q2/chi (m2 + kp)*L1)
	IC = 1./(4.D2) (2.p2J0 - 4.kp/k2(1. + m2/(k2 - m2)L2) + (2.kp - &
	3.p2)JA - p2JB + (-2.kp(m2 - p2) + 3.p2(m2 - k2))IA + &
	p2(m2 - p2)IB)
	ID = 1./(4.D2) (-2.kpJ0 + 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.k2J0 - 4.kp/p2(1. + m2/(p2 - m2)L1) + (2.kp - &
	3.k2)JB - k2JA + (-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/p2ln1) - 3.*ln1 )
	dM2 = m/k2 * ( (ximo+1.)(1.+m2/k2ln2) - 3.*ln2 )

	!!! coefficient list: vertex function Gamma_mu (k,p) = sum_i( Vi_mu * Pi )
	P1(1) = 2.JA - 2.JC + ximo(m2IC + p2*ID)
	P1(2) = 2.JB - 2.JE + ximo(k2ID + m2*IE)
	P1(3) = -2.J0 + 2.JA + 2.JB - 2.JD + ximo(-J0/2. - k2/2.IC - &
	kpID + m2ID + p2/2.*IE + JA)
	P1(4) = -2.JD + ximo(k2IC + m2ID - 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) = -m2J0 - k2JA - p2JB + k2/2.JC + kpJD + p2/2.JE + &
	(1./2. + CCmsbar - 2.*S) &
	+ ximo(-m2J0/4. - m2/4.k2IC - m2/2.kpID - m2/4.p2IE &
	- k2/2.JA - p2/2.JB + (CCmsbar + 2.))
	P1(7) = 2.mJ0 - 4.mJA + ximom(J0/2. - 2.kpIC + k2/2.*IC - &
	p2ID - kpID - p2/2.*IE - JA)
	P1(8) = 2.mJ0 - 4.mJB + ximom(J0/2. + k2/2.IC - kpID + k2*ID - &
	p2/2.*IE - JB)
	P1(9) = ximom(ID + IE)
	P1(10) = ximom(ID + IC)
	P1(11) = ximom( p2ID + kpIC + p2/2.IE - k2/2.IC) + dM2
	!!! self energy contribution: ~ gamma_mu.k_slash = V11
	P1(12) = ximom(-k2ID - kpIE + 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 - mw2 / mz2)
	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 (m1s2, m1s2, 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 (m1s2, m1s2, 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
	[[(p1)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 = pq / (p1 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 (p2 + mass2)
	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 (p2 + mass2)
	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 = p12; m2_sq = p22
	p = sqrt (lambda (s, m1_sq, m2_sq)) / (two * sqrt (s))
	E1 = sqrt (m1_sq + p2); E2 = sqrt (m2_sq + p2)
	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_in2; msq2 = p2_in2

	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) + cbeta_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) = cpdelta_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:) = [ ctcp, -ctsp, st ]
	L%L(2,1:) = [ sp, cp, zero ]
	L%L(3,1:) = [ -stcp, stsp, 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 * [ -stcp, stsp, ct ]
	L%L(1,1:) = [ ctcp, -ctsp, st ]
	L%L(2,1:) = [ sp, cp, zero ]
	L%L(3,1:) = gamma * [ -stcp, stsp, 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:) = [ ctcp, -sp, stcp ]
	L%L(2,1:) = [ ctsp, cp, stsp ]
	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:) = [ ctcp, -sp, stcp ]
	L%L(2,1:) = [ ctsp, cp, stsp ]
	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 - 4m2sq*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 (E02 - m2)
	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 (sijpp_1pp_2), &
	(p1%p(2)pp_2 - p2%p(2)pp_1)/sqrt (sijpp_1pp_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_f2 + \frac{11}{9} C_F n_f2 \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 * CACFnf &
	+ 79.0_default/54.0_default * CAnf*2 + &
	11.0_default/9.0_default * CF * nf*2) / (fourpi)**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) / (fourpi*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(scale2/m_z2)
	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 (b12/b02 * ((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(scale2/lambda_qcd2)
	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 * b12/b04/logmul*2 &
	((log(logmul) - 0.5_default)**2 + &
	b2b0/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(scale2/m_e2)
	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 (scale2/m_e2)
	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 - hb2) 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 - hb2) 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 - hb2) 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 = ab/2.0_default/(a-b) + a2 b2/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_ip_k) / ((p_kp_j) + (p_k*p_i))
	y_ijk = (p_ip_j) / ((p_ip_j) + (p_ip_k) + (p_jp_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_ip_a) / ((p_ap_j) + (p_a*p_i))
	x_ija = ((p_ip_a) + (p_jp_a) - (p_i*p_j)) &
	/ ((p_ip_a) + (p_jp_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_ap_j) / ((p_ap_j) + (p_a*p_k))
	x_kja = ((p_ap_k) + (p_ap_j) - (p_j*p_k)) &
	/ ((p_ap_j) + (p_ap_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_ap_b) - (p_ap_j) - (p_bp_j)) / (p_ap_b)
	v_j = (p_ap_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 * (kp_in(i)) / (kk)) * 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 * (x2 + (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 - CFtwo/(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 + twoLi2(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 * (z2 + (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) * (- zmax2 + zmin2 - &
	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) * &
	(zmax3 - zmin3) - (zmax2 - zmin2) + (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) + zmax2 / two - zmax3 / 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 ((mtop2 - (mw + mb)2) * (mtop2 - (mw - mb)2))
	gamma = alpha / four * mtop / (two * sinthw*2) &
	vtb*2 kappa / mtop*2 &
	((mtop2 + mb2) / (two * mtop**2) + &
	(mtop2 - mb2)*2 / (two mtop*2 mw**2) - &
	mw2 / mtop2)
	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) / mw2 / sinthw2
	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 = mw2 / mtop2
	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 * p32) / (pp2 * Wp)) + yw * log (pp)) &
	+ four * (one - beta2) * ((one - beta2)*2 + w2 (one + beta2) - four * w2*2) yw &
	+ (3 - beta2 + 11 * beta22 - beta23 + 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 + w22 + eps22 - 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 * eps22 - eps23 + w2 * &
	(6 - 12 * eps2 + 2 * eps22) - w22 * (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 - mw2 / mz2)
	alpha = alpha_from_g_mu (g_mu, mw, sinthw)
	vtb = one
	w2 = mw2 / mtop2

	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 - mw2 / mz2), 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 (22 h, 51 m)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 3806244
Default Alt Text: (949 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions