No OneTemporary
Actions

Size

327 KB

Subscribers

None

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.

	Index: branches/bach/release_2.1.1_hoppet_top_features/src/models/parameters.SM.f90
	===================================================================
	--- branches/bach/release_2.1.1_hoppet_top_features/src/models/parameters.SM.f90 (revision 5246)
	+++ branches/bach/release_2.1.1_hoppet_top_features/src/models/parameters.SM.f90 (revision 5247)
	@@ -1,227 +1,227 @@
	! $Id: parameters.SM.f90,v 1.4 2006/06/16 13:31:48 kilian Exp $
	!
	! Copyright (C) 1999-2012 by
	! Wolfgang Kilian <kilian@physik.uni-siegen.de>
	! Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	! Juergen Reuter <juergen.reuter@desy.de>
	! Christian Speckner <christian.speckner@physik.uni-freiburg.de>
	!
	! 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.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	module parameters_sm
	use kinds
	use constants
	use sm_physics !NODEP!
	use omega_vectors
	use ilc_tt_threshold
	implicit none
	private

	real(default), dimension(27), public :: mass, width
	real(default), public :: as
	complex(default), public :: gs, igs

	real(default), public :: e, g, e_em
	real(default), public :: sinthw, costhw, sin2thw, tanthw
	real(default), public :: qelep, qeup, qedwn
	complex(default), public :: qlep, qup, qdwn, gcc, qw, &
	gzww, gwww, ghww, ghhww, ghzz, ghhzz, &
	ghbb, ghtt, ghcc, ghtautau, gh3, gh4, ghmm, &
	iqw, igzww, igwww, gw4, gzzww, gazww, gaaww
	real(default), public :: vev
	complex(default), dimension(2), public :: &
	gncneu, gnclep, gncup, gncdwn
	logical, public :: ilc_tt_flag = .false.

	public :: import_from_whizard, model_update_alpha_s, &
	ilc_tt_fudge, va_ilc_tta, va_ilc_ttz

	contains

	subroutine import_from_whizard (par_array)
	real(default), dimension(29), intent(in) :: par_array
	type :: parameter_set
	real(default) :: gf
	real(default) :: mZ
	real(default) :: mW
	real(default) :: mH
	real(default) :: alphas
	real(default) :: me
	real(default) :: mmu
	real(default) :: mtau
	real(default) :: ms
	real(default) :: mc
	real(default) :: mb
	real(default) :: mtop
	real(default) :: wtop
	real(default) :: wZ
	real(default) :: wW
	real(default) :: wH
	real(default) :: khgaz
	real(default) :: khgaga
	real(default) :: khgg
	real(default) :: xi0
	real(default) :: xipm
	real(default) :: ilc_tt
	real(default) :: m1s
	real(default) :: vsoft
	real(default) :: nloop
	real(default) :: v
	real(default) :: cw
	real(default) :: sw
	real(default) :: ee
	end type parameter_set
	type(parameter_set) :: par
	!!! This corresponds to 1/alpha = 137.03598949333
	real(default), parameter :: &
	alpha = 1.0_default/137.03598949333_default
	e_em = sqrt(4.0_default * PI * alpha)
	par%gf = par_array(1)
	par%mZ = par_array(2)
	par%mW = par_array(3)
	par%mH = par_array(4)
	par%alphas = par_array(5)
	par%me = par_array(6)
	par%mmu = par_array(7)
	par%mtau = par_array(8)
	par%ms = par_array(9)
	par%mc = par_array(10)
	par%mb = par_array(11)
	par%mtop = par_array(12)
	par%wtop = par_array(13)
	par%wZ = par_array(14)
	par%wW = par_array(15)
	par%wH = par_array(16)
	par%khgaz = par_array(17)
	par%khgaga = par_array(18)
	par%khgg = par_array(19)
	par%xi0 = par_array(20)
	par%xipm = par_array(21)
	par%ilc_tt = par_array(22)
	par%m1s = par_array(23)
	par%vsoft = par_array(24)
	par%nloop = par_array(25)
	par%v = par_array(26)
	par%cw = par_array(27)
	par%sw = par_array(28)
	par%ee = par_array(29)
	mass(1:27) = 0
	width(1:27) = 0
	mass(3) = par%ms
	mass(4) = par%mc
	mass(5) = par%mb
	mass(6) = par%mtop
	width(6) = par%wtop
	mass(11) = par%me
	mass(13) = par%mmu
	mass(15) = par%mtau
	mass(23) = par%mZ
	width(23) = par%wZ
	mass(24) = par%mW
	width(24) = par%wW
	mass(25) = par%mH
	width(25) = par%wH
	mass(26) = par%xi0 * mass(23)
	width(26) = 0
	mass(27) = par%xipm * mass(24)
	width(27) = 0
	vev = par%v
	e = par%ee
	sinthw = par%sw
	sin2thw = par%sw**2
	costhw = par%cw
	tanthw = sinthw/costhw
	qelep = - 1
	qeup = 2.0_default / 3.0_default
	qedwn = - 1.0_default / 3.0_default
	g = e / sinthw
	gcc = - g / 2 / sqrt (2.0_default)
	gncneu(1) = - g / 2 / costhw * ( + 0.5_default)
	gnclep(1) = - g / 2 / costhw * ( - 0.5_default - 2 * qelep * sin2thw)
	gncup(1) = - g / 2 / costhw * ( + 0.5_default - 2 * qeup * sin2thw)
	gncdwn(1) = - g / 2 / costhw * ( - 0.5_default - 2 * qedwn * sin2thw)
	gncneu(2) = - g / 2 / costhw * ( + 0.5_default)
	gnclep(2) = - g / 2 / costhw * ( - 0.5_default)
	gncup(2) = - g / 2 / costhw * ( + 0.5_default)
	gncdwn(2) = - g / 2 / costhw * ( - 0.5_default)
	qlep = - e * qelep
	qup = - e * qeup
	qdwn = - e * qedwn
	qw = e
	iqw = (0,1)*qw
	gzww = g * costhw
	igzww = (0,1)*gzww
	gwww = g
	igwww = (0,1)*gwww
	gw4 = gwww**2
	gzzww = gzww**2
	gazww = gzww * qw
	gaaww = qw**2
	ghww = mass(24) * g
	ghhww = g**2 / 2.0_default
	ghzz = mass(23) * g / costhw
	ghhzz = g2 / 2.0_default / costhw2
	ghtt = - mass(6) / vev
	ghbb = - mass(5) / vev
	ghcc = - mass(4) / vev
	ghtautau = - mass(15) / vev
	ghmm = - mass(13) / vev
	gh3 = - 3 * mass(25)**2 / vev
	gh4 = - 3 * mass(25)2 / vev2
	!!! Color flow basis, divide by sqrt(2)
	gs = sqrt(2.0_defaultPIpar%alphas)
	igs = cmplx (0.0_default, 1.0_default, kind=default) * gs
	if ( par%ilc_tt > 0. ) then
	ilc_tt_flag = .true.
	call ilc_tt_init (mass(6), width(6), par%m1s, par%vsoft, int(par%nloop))
	end if
	end subroutine import_from_whizard

	subroutine model_update_alpha_s (alpha_s)
	real(default), intent(in) :: alpha_s
	gs = sqrt(2.0_defaultPIalpha_s)
	igs = cmplx (0.0_default, 1.0_default, kind=default) * gs
	end subroutine model_update_alpha_s

	function ilc_tt_fudge (p, q, i) result (c)
	complex(default) :: c
	type(momentum), intent(in) :: p, q
	integer, intent(in) :: i
	real(default) :: en, pt
	c = 0.0_default
	if ( .not. ilc_tt_flag ) return
	en = sqrt( (p+q)*(p+q) )
	- if ( .not. en > mass(6) ) return
	pt = sqrt( dot_product(p%x,p%x) )
	c = ilc_tt_formfactor (pt, en, i)
	+! print *, "c = ", c
	end function ilc_tt_fudge

	function va_ilc_tta (p, q, i) result (c)
	complex(default) :: c
	type(momentum), intent(in) :: p, q
	integer, intent(in) :: i
	c = 0.0_default
	if ( i==1 ) c = qup * ilc_tt_fudge (p, q, 1)
	end function va_ilc_tta

	function va_ilc_ttz (p, q, i) result (c)
	complex(default) :: c
	type(momentum), intent(in) :: p, q
	integer, intent(in) :: i
	c = gncup(i) * ilc_tt_fudge (p, q, i)
	end function va_ilc_ttz

	end module parameters_sm
	Index: branches/bach/release_2.1.1_hoppet_top_features/src/omega/src/targets.ml
	===================================================================
	--- branches/bach/release_2.1.1_hoppet_top_features/src/omega/src/targets.ml (revision 5246)
	+++ branches/bach/release_2.1.1_hoppet_top_features/src/omega/src/targets.ml (revision 5247)
	@@ -1,4109 +1,4109 @@
	(* $Id$

	Copyright (C) 1999-2012 by

	Wolfgang Kilian <kilian@physik.uni-siegen.de>
	Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
	Christian Speckner <christian.speckner@physik.uni-freiburg.de>
	Fabian Bach <fabian.bach@cern.ch> (only parts of this 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. *)

	let rcs_file = RCS.parse "Targets" ["Code Generation"]
	{ RCS.revision = "$Revision$";
	RCS.date = "$Date$";
	RCS.author = "$Author$";
	RCS.source
	= "$URL$" }

	module Dummy (F : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
	struct
	let rcs_list = []
	type amplitudes = Fusion.Multi(F)(P)(M).amplitudes
	type diagnostic = All \| Arguments \| Momenta \| Gauge
	let options = Options.empty
	let amplitudes_to_channel cmdline oc amplitudes = failwith "Targets.Dummy"
	let parameters_to_channel oc = failwith "Targets.Dummy"
	end

	(* \thocwmodulesection{\texttt{Fortran\,90/95}} *)

	(* \thocwmodulesubsection{Dirac Fermions}
	We factor out the code for fermions so that we can use the simpler
	implementation for Dirac fermions if the model contains no Majorana
	fermions. *)

	module type Fermions =
	sig
	open Coupling
	val psi_type : string
	val psibar_type : string
	val chi_type : string
	val grav_type : string
	val psi_incoming : string
	val brs_psi_incoming : string
	val psibar_incoming : string
	val brs_psibar_incoming : string
	val chi_incoming : string
	val brs_chi_incoming : string
	val grav_incoming : string
	val psi_outgoing : string
	val brs_psi_outgoing : string
	val psibar_outgoing : string
	val brs_psibar_outgoing : string
	val chi_outgoing : string
	val brs_chi_outgoing : string
	val grav_outgoing : string
	val psi_propagator : string
	val psibar_propagator : string
	val chi_propagator : string
	val grav_propagator : string
	val psi_projector : string
	val psibar_projector : string
	val chi_projector : string
	val grav_projector : string
	val psi_gauss : string
	val psibar_gauss : string
	val chi_gauss : string
	val grav_gauss : string
	val print_current : int * fermionbar * boson * fermion ->
	string -> string -> string -> fuse2 -> unit
	val print_current_mom : int * fermionbar * boson * fermion ->
	string -> string -> string -> string -> string -> string
	-> fuse2 -> unit
	val print_current_p : int * fermion * boson * fermion ->
	string -> string -> string -> fuse2 -> unit
	val print_current_b : int * fermionbar * boson * fermionbar ->
	string -> string -> string -> fuse2 -> unit
	val print_current_g : int * fermionbar * boson * fermion ->
	string -> string -> string -> string -> string -> string
	-> fuse2 -> unit
	val print_current_g4 : int * fermionbar * boson2 * fermion ->
	string -> string -> string -> string -> fuse3 -> unit
	val reverse_braket : lorentz -> bool
	val use_module : string
	val require_library : string list
	val rcs : RCS.t
	end

	module Fortran_Fermions : Fermions =
	struct
	let rcs = RCS.rename rcs_file "Targets.Fortran_Fermions()"
	[ "generates Fortran95 code for Dirac fermions";
	"using revision 2000_10_A of module omega95" ]

	open Coupling
	open Format

	let psi_type = "spinor"
	let psibar_type = "conjspinor"
	let chi_type = "???"
	let grav_type = "???"

	let psi_incoming = "u"
	let brs_psi_incoming = "brs_u"
	let psibar_incoming = "vbar"
	let brs_psibar_incoming = "brs_vbar"
	let chi_incoming = "???"
	let brs_chi_incoming = "???"
	let grav_incoming = "???"
	let psi_outgoing = "v"
	let brs_psi_outgoing = "brs_v"
	let psibar_outgoing = "ubar"
	let brs_psibar_outgoing = "brs_ubar"
	let chi_outgoing = "???"
	let brs_chi_outgoing = "???"
	let grav_outgoing = "???"

	let psi_propagator = "pr_psi"
	let psibar_propagator = "pr_psibar"
	let chi_propagator = "???"
	let grav_propagator = "???"

	let psi_projector = "pj_psi"
	let psibar_projector = "pj_psibar"
	let chi_projector = "???"
	let grav_projector = "???"

	let psi_gauss = "pg_psi"
	let psibar_gauss = "pg_psibar"
	let chi_gauss = "???"
	let grav_gauss = "???"

	let format_coupling coeff c =
	match coeff with
	\| 1 -> c
	\| -1 -> "(-" ^ c ^")"
	\| coeff -> string_of_int coeff ^ "*" ^ c

	let format_coupling_2 coeff c =
	match coeff with
	\| 1 -> c
	\| -1 -> "-" ^ c
	\| coeff -> string_of_int coeff ^ "*" ^ c

	(* \begin{dubious}
	JR's coupling constant HACK, necessitated by tho's bad design descition.
	\end{dubious} *)

	let fastener s i ?p ?q () =
	try
	let offset = (String.index s '(') in
	if ((String.get s (String.length s - 1)) != ')') then
	failwith "fastener: wrong usage of parentheses"
	else
	let func_name = (String.sub s 0 offset) and
	tail =
	(String.sub s (succ offset) (String.length s - offset - 2)) in
	if (String.contains func_name ')') or
	(String.contains tail '(') or
	(String.contains tail ')') then
	failwith "fastener: wrong usage of parentheses"
	else
	func_name ^ "(" ^ string_of_int i ^ "," ^ tail ^ ")"
	with
	\| Not_found ->
	if (String.contains s ')') then
	failwith "fastener: wrong usage of parentheses"
	else
	(* match p with
	\| None -> s ^ "(" ^ string_of_int i ^ ")"
	\| Some p -> s ^ "(" ^ p ^ "" ^ p ^ "," ^ string_of_int i ^ ")" )
	match p with
	\| None -> s ^ "(" ^ string_of_int i ^ ")"
	\| Some p ->
	match q with
	\| None -> s ^ "(" ^ p ^ "*" ^ p ^ "," ^ string_of_int i ^ ")"
	\| Some q -> s ^ "(" ^ p ^ "," ^ q ^ "," ^ string_of_int i ^ ")"

	let print_fermion_current coeff f c wf1 wf2 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
	\| F31 -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1
	\| F23 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
	\| F12 -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2
	\| F21 -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1

	(* \begin{dubious}
	Using a two element array for the combined vector-axial and scalar-pseudo
	couplings helps to support HELAS as well. Since we will probably never
	support general boson couplings with HELAS, it might be retired in favor
	of two separate variables. For this [Model.constant_symbol] has to be
	generalized.
	\end{dubious} *)

	(* \begin{dubious}
	NB: passing the array instead of two separate constants would be a
	\emph{bad} idea, because the support for Majorana spinors below will
	have to flip signs!
	\end{dubious} *)

	let print_fermion_current2 coeff f c wf1 wf2 fusion =
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 ()
	and c2 = fastener c 2 () in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F31 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf2 wf1
	\| F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
	\| F12 -> printf "f_f%s(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F21 -> printf "f_f%s(%s,%s,%s,%s)" f c1 c2 wf2 wf1

	- let print_fermion_current_mom1 coeff f c wf1 wf2 p1 p2 p12 fusion =
	+ let print_fermion_current_mom_v1 coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf1 wf2
	\| F31 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf2 wf1
	\| F23 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf2 wf1
	\| F12 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf1 wf2
	\| F21 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf2 wf1

	- let print_fermion_current_mom2 coeff f c wf1 wf2 p1 p2 p12 fusion =
	+ let print_fermion_current_mom_v2 coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,@,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf1 wf2 p12
	\| F31 -> printf "%s_ff(%s,%s,@,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf2 wf1 p12
	\| F23 -> printf "f_%sf(%s,%s,@,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf1 wf2 p1
	\| F32 -> printf "f_%sf(%s,%s,@,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf2 wf1 p2
	\| F12 -> printf "f_f%s(%s,%s,@,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf1 wf2 p2
	\| F21 -> printf "f_f%s(%s,%s,@,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf2 wf1 p1

	- let print_fermion_current_mom3 coeff f c wf1 wf2 p1 p2 p12 fusion =
	+ let print_fermion_current_mom_ff coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p1 ~q:p2 ()) (c2 ~p:p1 ~q:p2 ()) wf1 wf2
	\| F31 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p1 ~q:p2 ()) (c2 ~p:p1 ~q:p2 ()) wf2 wf1
	\| F23 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p2 ()) (c2 ~p:p12 ~q:p2 ()) wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p1 ()) (c2 ~p:p12 ~q:p1 ()) wf2 wf1
	\| F12 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p1 ()) (c2 ~p:p12 ~q:p1 ()) wf1 wf2
	\| F21 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p2 ()) (c2 ~p:p12 ~q:p2 ()) wf2 wf1

	let print_current = function
	\| coeff, Psibar, VA, Psi -> print_fermion_current2 coeff "va"
	\| coeff, Psibar, VA2, Psi -> print_fermion_current coeff "va2"
	\| coeff, Psibar, VA3, Psi -> print_fermion_current coeff "va3"
	\| coeff, Psibar, V, Psi -> print_fermion_current coeff "v"
	\| coeff, Psibar, A, Psi -> print_fermion_current coeff "a"
	\| coeff, Psibar, VL, Psi -> print_fermion_current coeff "vl"
	\| coeff, Psibar, VR, Psi -> print_fermion_current coeff "vr"
	\| coeff, Psibar, VLR, Psi -> print_fermion_current2 coeff "vlr"
	\| coeff, Psibar, SP, Psi -> print_fermion_current2 coeff "sp"
	\| coeff, Psibar, S, Psi -> print_fermion_current coeff "s"
	\| coeff, Psibar, P, Psi -> print_fermion_current coeff "p"
	\| coeff, Psibar, SL, Psi -> print_fermion_current coeff "sl"
	\| coeff, Psibar, SR, Psi -> print_fermion_current coeff "sr"
	\| coeff, Psibar, SLR, Psi -> print_fermion_current2 coeff "slr"
	\| coeff, Psibar, _, Psi -> invalid_arg
	"Targets.Fortran_Fermions: no superpotential here"
	\| _, Chibar, _, _ \| _, _, _, Chi -> invalid_arg
	"Targets.Fortran_Fermions: Majorana spinors not handled"
	\| _, Gravbar, _, _ \| _, _, _, Grav -> invalid_arg
	"Targets.Fortran_Fermions: Gravitinos not handled"

	let print_current_mom = function
	- \| coeff, Psibar, VLRM, Psi -> print_fermion_current_mom1 coeff "vlr"
	- \| coeff, Psibar, VAM, Psi -> print_fermion_current_mom3 coeff "va"
	- \| coeff, Psibar, VA3M, Psi -> print_fermion_current_mom1 coeff "va3"
	- \| coeff, Psibar, SPM, Psi -> print_fermion_current_mom1 coeff "sp"
	- \| coeff, Psibar, TVA, Psi -> print_fermion_current_mom1 coeff "tva"
	- \| coeff, Psibar, TVAM, Psi -> print_fermion_current_mom2 coeff "tvam"
	- \| coeff, Psibar, TLR, Psi -> print_fermion_current_mom1 coeff "tlr"
	- \| coeff, Psibar, TLRM, Psi -> print_fermion_current_mom2 coeff "tlrm"
	- \| coeff, Psibar, TRL, Psi -> print_fermion_current_mom1 coeff "trl"
	- \| coeff, Psibar, TRLM, Psi -> print_fermion_current_mom2 coeff "trlm"
	+ \| coeff, Psibar, VLRM, Psi -> print_fermion_current_mom_v1 coeff "vlr"
	+ \| coeff, Psibar, VAM, Psi -> print_fermion_current_mom_ff coeff "va"
	+ \| coeff, Psibar, VA3M, Psi -> print_fermion_current_mom_ff coeff "va3"
	+ \| coeff, Psibar, SPM, Psi -> print_fermion_current_mom_v1 coeff "sp"
	+ \| coeff, Psibar, TVA, Psi -> print_fermion_current_mom_v1 coeff "tva"
	+ \| coeff, Psibar, TVAM, Psi -> print_fermion_current_mom_v2 coeff "tvam"
	+ \| coeff, Psibar, TLR, Psi -> print_fermion_current_mom_v1 coeff "tlr"
	+ \| coeff, Psibar, TLRM, Psi -> print_fermion_current_mom_v2 coeff "tlrm"
	+ \| coeff, Psibar, TRL, Psi -> print_fermion_current_mom_v1 coeff "trl"
	+ \| coeff, Psibar, TRLM, Psi -> print_fermion_current_mom_v2 coeff "trlm"
	\| coeff, Psibar, _, Psi -> invalid_arg
	"Targets.Fortran_Fermions: only sigma tensor coupling here"
	\| _, Chibar, _, _ \| _, _, _, Chi -> invalid_arg
	"Targets.Fortran_Fermions: Majorana spinors not handled"
	\| _, Gravbar, _, _ \| _, _, _, Grav -> invalid_arg
	"Targets.Fortran_Fermions: Gravitinos not handled"

	let print_current_p = function
	\| _, _, _, _ -> invalid_arg
	"Targets.Fortran_Fermions: No clashing arrows here"

	let print_current_b = function
	\| _, _, _, _ -> invalid_arg
	"Targets.Fortran_Fermions: No clashing arrows here"

	let print_current_g = function
	\| _, _, _, _ -> invalid_arg
	"Targets.Fortran_Fermions: No gravitinos here"

	let print_current_g4 = function
	\| _, _, _, _ -> invalid_arg
	"Targets.Fortran_Fermions: No gravitinos here"

	let reverse_braket= function
	\| Spinor -> true
	\| _ -> false

	let use_module = "omega95"
	let require_library =
	["omega_spinors_2010_01_A"; "omega_spinor_cpls_2010_01_A"]
	end

	(* \thocwmodulesubsection{Main Functor} *)

	module Make_Fortran (Fermions : Fermions)
	(Fusion_Maker : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
	struct
	let rcs_list =
	[ RCS.rename rcs_file "Targets.Make_Fortran()"
	[ "Interface for Whizard 2.X";
	"NB: non-gauge vector couplings are not available yet" ];
	Fermions.rcs ]

	let require_library =
	Fermions.require_library @
	[ "omega_vectors_2010_01_A"; "omega_polarizations_2010_01_A";
	"omega_couplings_2010_01_A"; "omega_color_2010_01_A";
	"omega_utils_2010_01_A" ]

	module CM = Colorize.It(M)
	module F = Fusion_Maker(P)(M)
	type amplitude = F.amplitude

	module CF = Fusion.Multi(Fusion_Maker)(P)(M)
	type amplitudes = CF.amplitudes

	open Coupling
	open Format

	type output_mode =
	\| Single_Function
	\| Single_Module of int
	\| Single_File of int
	\| Multi_File of int

	let line_length = ref 80
	let continuation_lines = ref (-1) (* 255 *)
	let kind = ref "default"
	let fortran95 = ref true
	let module_name = ref "omega_amplitude"
	let output_mode = ref (Single_Module 10)
	let use_modules = ref []
	let whizard = ref false
	let parameter_module = ref ""
	let md5sum = ref None
	let no_write = ref false
	let km_write = ref false
	let km_pure = ref false
	let openmp = ref false

	let options = Options.create
	[ "90", Arg.Clear fortran95,
	"don't use Fortran95 features that are not in Fortran90";
	"kind", Arg.String (fun s -> kind := s),
	"real and complex kind (default: " ^ !kind ^ ")";
	"width", Arg.Int (fun w -> line_length := w), "maximum line length";
	"continuation", Arg.Int (fun l -> continuation_lines := l),
	"maximum # of continuation lines";
	"module", Arg.String (fun s -> module_name := s), "module name";
	"single_function", Arg.Unit (fun () -> output_mode := Single_Function),
	"compute the matrix element(s) in a monolithis function";
	"split_function", Arg.Int (fun n -> output_mode := Single_Module n),
	"split the matrix element(s) into small functions [default, size = 10]";
	"split_module", Arg.Int (fun n -> output_mode := Single_File n),
	"split the matrix element(s) into small modules";
	"split_file", Arg.Int (fun n -> output_mode := Multi_File n),
	"split the matrix element(s) into small files";
	"use", Arg.String (fun s -> use_modules := s :: !use_modules),
	"use module";
	"parameter_module", Arg.String (fun s -> parameter_module := s),
	"parameter_module";
	"md5sum", Arg.String (fun s -> md5sum := Some s),
	"transfer MD5 checksum";
	"whizard", Arg.Set whizard, "include WHIZARD interface";
	"no_write", Arg.Set no_write, "no 'write' statements";
	"kmatrix_write", Arg.Set km_write, "write K matrix functions";
	"kmatrix_write_pure", Arg.Set km_pure, "write K matrix pure functions";
	"openmp", Arg.Set openmp, "activate OpenMP support in generated code"]

	(* Fortran style line continuation: *)

	(* Default function to output spaces (copied from \texttt{format.ml}). *)
	let blank_line = String.make 80 ' '
	let rec display_blanks oc n =
	if n > 0 then
	if n <= 80 then
	output oc blank_line 0 n
	else begin
	output oc blank_line 0 80;
	display_blanks oc (n - 80)
	end

	(* Default function to output new lines (copied from \texttt{format.ml}). *)
	let display_newline oc () =
	output oc "\n" 0 1

	(* [current_continuation_line]
	\begin{itemize}
	\item $\le0$: not continuing: print a straight newline,
	\item $>0$: continuing: append [" &"] until we run up to [!continuation_lines].
	NB: [!continuation_lines < 0] means \emph{unlimited} continuation lines.
	\end{itemize} *)

	let current_continuation_line = ref 1
	exception Continuation_Lines of int

	let fortran_newline oc () =
	if !current_continuation_line > 0 then begin
	if !continuation_lines >= 0 && !current_continuation_line > !continuation_lines then
	raise (Continuation_Lines !current_continuation_line)
	else begin
	output oc " &" 0 2;
	incr current_continuation_line
	end
	end;
	display_newline oc ()

	let nl () =
	current_continuation_line := 0;
	print_newline ();
	current_continuation_line := 1

	(* Make a formatter with default functions to output spaces and new lines. *)
	let setup_fortran_formatter width oc =
	set_all_formatter_output_functions
	~out:(output oc)
	~flush:(fun () -> flush oc)
	~newline:(fortran_newline oc)
	~spaces:(display_blanks oc);
	set_margin (width - 2)

	let print_list = function
	\| [] -> ()
	\| a :: rest ->
	print_string a;
	List.iter (fun s -> printf ",@ %s" s) rest

	(* \thocwmodulesubsection{Variables and Declarations} *)

	(* ["NC"] is already used up in the module ["constants"]: *)
	let nc_parameter = "N_"
	let omega_color_factor_abbrev = "OCF"
	let openmp_tld_type = "thread_local_data"
	let openmp_tld = "tld"

	let flavors_symbol ?(decl = false) flavors =
	(if !openmp & not decl then openmp_tld ^ "%" else "" ) ^
	"oks_" ^ String.concat "" (List.map CM.flavor_symbol flavors)

	let p2s p =
	if p >= 0 && p <= 9 then
	string_of_int p
	else if p <= 36 then
	String.make 1 (Char.chr (Char.code 'A' + p - 10))
	else
	"_"

	let format_momentum p =
	"p" ^ String.concat "" (List.map p2s p)

	let format_p wf =
	String.concat "" (List.map p2s (F.momentum_list wf))

	let ext_momentum wf =
	match F.momentum_list wf with
	\| [n] -> n
	\| _ -> invalid_arg "Targets.Fortran.ext_momentum"

	module PSet = Set.Make (struct type t = int list let compare = compare end)
	module WFSet = Set.Make (struct type t = F.wf let compare = compare end)

	let add_tag wf name =
	match F.wf_tag wf with
	\| None -> name
	\| Some tag -> name ^ "_" ^ tag

	let variable ?(decl = false) wf =
	(if !openmp & not decl then openmp_tld ^ "%" else "")
	^ add_tag wf ("owf_" ^ CM.flavor_symbol (F.flavor wf) ^ "_" ^ format_p wf)

	let momentum wf = "p" ^ format_p wf
	let spin wf = "s(" ^ string_of_int (ext_momentum wf) ^ ")"

	let format_multiple_variable ?(decl = false) wf i =
	variable ~decl:decl wf ^ "_X" ^ string_of_int i

	let multiple_variable ?(decl = false) amplitude dictionary wf =
	try
	format_multiple_variable ~decl:decl wf (dictionary amplitude wf)
	with
	\| Not_found -> variable wf

	let multiple_variables ?(decl = false) multiplicity wf =
	try
	List.map
	(format_multiple_variable ~decl:decl wf)
	(ThoList.range 1 (multiplicity wf))
	with
	\| Not_found -> [variable ~decl:decl wf]

	let declaration_chunk_size = 64

	let declare_list_chunk multiplicity t = function
	\| [] -> ()
	\| wfs ->
	printf " @[<2>%s :: " t;
	print_list (ThoList.flatmap (multiple_variables ~decl:true multiplicity) wfs); nl ()

	let declare_list multiplicity t = function
	\| [] -> ()
	\| wfs ->
	List.iter
	(declare_list_chunk multiplicity t)
	(ThoList.chopn declaration_chunk_size wfs)

	type declarations =
	{ scalars : F.wf list;
	spinors : F.wf list;
	conjspinors : F.wf list;
	realspinors : F.wf list;
	ghostspinors : F.wf list;
	vectorspinors : F.wf list;
	vectors : F.wf list;
	ward_vectors : F.wf list;
	massive_vectors : F.wf list;
	tensors_1 : F.wf list;
	tensors_2 : F.wf list;
	brs_scalars : F.wf list;
	brs_spinors : F.wf list;
	brs_conjspinors : F.wf list;
	brs_realspinors : F.wf list;
	brs_vectorspinors : F.wf list;
	brs_vectors : F.wf list;
	brs_massive_vectors : F.wf list }

	let rec classify_wfs' acc = function
	\| [] -> acc
	\| wf :: rest ->
	classify_wfs'
	(match CM.lorentz (F.flavor wf) with
	\| Scalar -> {acc with scalars = wf :: acc.scalars}
	\| Spinor -> {acc with spinors = wf :: acc.spinors}
	\| ConjSpinor -> {acc with conjspinors = wf :: acc.conjspinors}
	\| Majorana -> {acc with realspinors = wf :: acc.realspinors}
	\| Maj_Ghost -> {acc with ghostspinors = wf :: acc.ghostspinors}
	\| Vectorspinor ->
	{acc with vectorspinors = wf :: acc.vectorspinors}
	\| Vector -> {acc with vectors = wf :: acc.vectors}
	(*i \| Ward_Vector -> {acc with ward_vectors = wf :: acc.ward_vectors}
	i*)
	\| Massive_Vector ->
	{acc with massive_vectors = wf :: acc.massive_vectors}
	\| Tensor_1 -> {acc with tensors_1 = wf :: acc.tensors_1}
	\| Tensor_2 -> {acc with tensors_2 = wf :: acc.tensors_2}
	\| BRS Scalar -> {acc with brs_scalars = wf :: acc.brs_scalars}
	\| BRS Spinor -> {acc with brs_spinors = wf :: acc.brs_spinors}
	\| BRS ConjSpinor -> {acc with brs_conjspinors =
	wf :: acc.brs_conjspinors}
	\| BRS Majorana -> {acc with brs_realspinors =
	wf :: acc.brs_realspinors}
	\| BRS Vectorspinor -> {acc with brs_vectorspinors =
	wf :: acc.brs_vectorspinors}
	\| BRS Vector -> {acc with brs_vectors = wf :: acc.brs_vectors}
	\| BRS Massive_Vector -> {acc with brs_massive_vectors =
	wf :: acc.brs_massive_vectors}
	\| BRS _ -> invalid_arg "Targets.wfs_classify': not needed here")
	rest

	let classify_wfs wfs = classify_wfs'
	{ scalars = []; spinors = []; conjspinors = []; realspinors = [];
	ghostspinors = []; vectorspinors = []; vectors = [];
	ward_vectors = [];
	massive_vectors = []; tensors_1 = []; tensors_2 = [];
	brs_scalars = [] ; brs_spinors = []; brs_conjspinors = [];
	brs_realspinors = []; brs_vectorspinors = [];
	brs_vectors = []; brs_massive_vectors = []}
	wfs

	(* \thocwmodulesubsection{Parameters} *)

	type 'a parameters =
	{ real_singles : 'a list;
	real_arrays : ('a * int) list;
	complex_singles : 'a list;
	complex_arrays : ('a * int) list }

	let rec classify_singles acc = function
	\| [] -> acc
	\| Real p :: rest -> classify_singles
	{ acc with real_singles = p :: acc.real_singles } rest
	\| Complex p :: rest -> classify_singles
	{ acc with complex_singles = p :: acc.complex_singles } rest

	let rec classify_arrays acc = function
	\| [] -> acc
	\| (Real_Array p, rhs) :: rest -> classify_arrays
	{ acc with real_arrays =
	(p, List.length rhs) :: acc.real_arrays } rest
	\| (Complex_Array p, rhs) :: rest -> classify_arrays
	{ acc with complex_arrays =
	(p, List.length rhs) :: acc.complex_arrays } rest

	let classify_parameters params =
	classify_arrays
	(classify_singles
	{ real_singles = [];
	real_arrays = [];
	complex_singles = [];
	complex_arrays = [] }
	(List.map fst params.derived)) params.derived_arrays

	(* \begin{dubious}
	Unify this with the other code using [ThoList.chopn].
	\end{dubious} *)

	let rec schisma n l =
	if List.length l <= n then
	[l]
	else
	let a, b = ThoList.splitn n l in
	[a] @ (schisma n b)

	let rec schisma_num i n l =
	if List.length l <= n then
	[(i,l)]
	else
	let a, b = ThoList.splitn n l in
	[(i,a)] @ (schisma_num (i+1) n b)

	let declare_parameters' t = function
	\| [] -> ()
	\| plist ->
	printf " @[<2>%s(kind=%s), public, save :: " t !kind;
	print_list (List.map CM.constant_symbol plist); nl ()

	let declare_parameters t plist =
	List.iter (declare_parameters' t) plist

	let declare_parameter_array t (p, n) =
	printf " @[<2>%s(kind=%s), dimension(%d), public, save :: %s"
	t !kind n (CM.constant_symbol p); nl ()

	let default_parameter (x, v) =
	printf "@ %s = %g_%s" (CM.constant_symbol x) v !kind

	let declare_default_parameters t = function
	\| [] -> ()
	\| p :: plist ->
	printf " @[<2>%s(kind=%s), public, save ::" t !kind;
	default_parameter p;
	List.iter (fun p' -> printf ","; default_parameter p') plist;
	nl ()

	let rec format_constant = function
	\| I -> sprintf "cmplx (0.0_%s, 1.0_%s)" !kind !kind
	\| Const c when c < 0 -> sprintf "(%d.0_%s)" c !kind
	\| Const c -> sprintf "%d.0_%s" c !kind
	\| _ -> invalid_arg "format_constant"

	let rec eval_parameter' = function
	\| I -> printf "cmplx (0.0_%s, 1.0_%s)" !kind !kind
	\| Const c when c < 0 -> printf "(%d.0_%s)" c !kind
	\| Const c -> printf "%d.0_%s" c !kind
	\| Atom x -> printf "%s" (CM.constant_symbol x)
	\| Sum [] -> printf "0.0_%s" !kind
	\| Sum [x] -> eval_parameter' x
	\| Sum (x :: xs) ->
	printf "@,("; eval_parameter' x;
	List.iter (fun x -> printf "@, + "; eval_parameter' x) xs;
	printf ")"
	\| Diff (x, y) ->
	printf "@,("; eval_parameter' x;
	printf " - "; eval_parameter' y; printf ")"
	\| Neg x -> printf "@,( - "; eval_parameter' x; printf ")"
	\| Prod [] -> printf "1.0_%s" !kind
	\| Prod [x] -> eval_parameter' x
	\| Prod (x :: xs) ->
	printf "@,("; eval_parameter' x;
	List.iter (fun x -> printf " * "; eval_parameter' x) xs;
	printf ")"
	\| Quot (x, y) ->
	printf "@,("; eval_parameter' x;
	printf " / "; eval_parameter' y; printf ")"
	\| Rec x ->
	printf "@, (1.0_%s / " !kind; eval_parameter' x; printf ")"
	\| Pow (x, n) ->
	printf "@,("; eval_parameter' x; printf "**%d" n; printf ")"
	\| Sqrt x -> printf "@,sqrt ("; eval_parameter' x; printf ")"
	\| Sin x -> printf "@,sin ("; eval_parameter' x; printf ")"
	\| Cos x -> printf "@,cos ("; eval_parameter' x; printf ")"
	\| Tan x -> printf "@,tan ("; eval_parameter' x; printf ")"
	\| Cot x -> printf "@,cot ("; eval_parameter' x; printf ")"
	\| Atan2 (y, x) -> printf "@,atan2 ("; eval_parameter' y;
	printf ",@ "; eval_parameter' x; printf ")"
	\| Conj x -> printf "@,conjg ("; eval_parameter' x; printf ")"

	let strip_single_tag = function
	\| Real x -> x
	\| Complex x -> x

	let strip_array_tag = function
	\| Real_Array x -> x
	\| Complex_Array x -> x

	let eval_parameter (lhs, rhs) =
	let x = CM.constant_symbol (strip_single_tag lhs) in
	printf " @[<2>%s = " x; eval_parameter' rhs; nl ()

	let eval_para_list n l =
	printf " subroutine setup_parameters%s ()" (string_of_int n); nl();
	List.iter eval_parameter l;
	printf " end subroutine setup_parameters%s" (string_of_int n); nl()

	let eval_parameter_pair (lhs, rhs) =
	let x = CM.constant_symbol (strip_array_tag lhs) in
	let _ = List.fold_left (fun i rhs' ->
	printf " @[<2>%s(%d) = " x i; eval_parameter' rhs'; nl ();
	succ i) 1 rhs in
	()

	let eval_para_pair_list n l =
	printf " subroutine setup_parameters%s ()" (string_of_int n); nl();
	List.iter eval_parameter_pair l;
	printf " end subroutine setup_parameters%s" (string_of_int n); nl()

	let print_echo fmt p =
	let s = CM.constant_symbol p in
	printf " write (unit = *, fmt = fmt_%s) \"%s\", %s"
	fmt s s; nl ()

	let print_echo_array fmt (p, n) =
	let s = CM.constant_symbol p in
	for i = 1 to n do
	printf " write (unit = *, fmt = fmt_%s_array) " fmt ;
	printf "\"%s\", %d, %s(%d)" s i s i; nl ()
	done

	let parameters_to_fortran oc params =
	setup_fortran_formatter !line_length oc;
	let declarations = classify_parameters params in
	printf "module %s" !parameter_module; nl ();
	printf " use kinds"; nl ();
	printf " use constants"; nl ();
	printf " implicit none"; nl ();
	printf " private"; nl ();
	printf " @[<2>public :: setup_parameters";
	if !no_write then begin
	printf "! No print_parameters"; nl();
	end else begin
	printf "@,, print_parameters"; nl ();
	end;
	declare_default_parameters "real" params.input;
	declare_parameters "real" (schisma 69 declarations.real_singles);
	List.iter (declare_parameter_array "real") declarations.real_arrays;
	declare_parameters "complex" (schisma 69 declarations.complex_singles);
	List.iter (declare_parameter_array "complex") declarations.complex_arrays;
	printf "contains"; nl ();
	printf " ! derived parameters:"; nl ();
	let shredded = schisma_num 1 120 params.derived in
	let shredded_arrays = schisma_num 1 120 params.derived_arrays in
	let num_sub = List.length shredded in
	let num_sub_arrays = List.length shredded_arrays in
	printf " !length: %s" (string_of_int (List.length params.derived));
	nl();
	printf " !Num_Sub: %s" (string_of_int num_sub); nl();
	List.iter (fun (i,l) -> eval_para_list i l) shredded;
	List.iter (fun (i,l) -> eval_para_pair_list (num_sub + i) l)
	shredded_arrays;
	printf " subroutine setup_parameters ()"; nl();
	let sum_sub = num_sub + num_sub_arrays in
	for i = 1 to sum_sub do
	printf " call setup_parameters%s" (string_of_int i); nl();
	done;
	printf " end subroutine setup_parameters"; nl();
	if !no_write then begin
	printf "! No print_parameters"; nl();
	end else begin
	printf " subroutine print_parameters ()"; nl();
	printf " @[<2>character(len=*), parameter ::";
	printf "@ fmt_real = \"(A12,4X,' = ',E25.18)\",";
	printf "@ fmt_complex = \"(A12,4X,' = ',E25.18,' + i*',E25.18)\",";
	printf "@ fmt_real_array = \"(A12,'(',I2.2,')',' = ',E25.18)\",";
	printf "@ fmt_complex_array = ";
	printf "\"(A12,'(',I2.2,')',' = ',E25.18,' + i*',E25.18)\""; nl ();
	printf " @[<2>write (unit = *, fmt = \"(A)\") @,";
	printf "\"default values for the input parameters:\""; nl ();
	List.iter (fun (p, _) -> print_echo "real" p) params.input;
	printf " @[<2>write (unit = *, fmt = \"(A)\") @,";
	printf "\"derived parameters:\""; nl ();
	List.iter (print_echo "real") declarations.real_singles;
	List.iter (print_echo "complex") declarations.complex_singles;
	List.iter (print_echo_array "real") declarations.real_arrays;
	List.iter (print_echo_array "complex") declarations.complex_arrays;
	printf " end subroutine print_parameters"; nl();
	end;
	printf "end module %s" !parameter_module; nl ();
	printf "! O'Mega revision control information:"; nl ();
	List.iter (fun s -> printf "! %s" s; nl ())
	(ThoList.flatmap RCS.summary (M.rcs :: rcs_list));
	printf "!!! program test_parameters"; nl();
	printf "!!! use %s" !parameter_module; nl();
	printf "!!! call setup_parameters ()"; nl();
	printf "!!! call print_parameters ()"; nl();
	printf "!!! end program test_parameters"; nl()

	(* \thocwmodulesubsection{Run-Time Diagnostics} *)

	type diagnostic = All \| Arguments \| Momenta \| Gauge

	type diagnostic_mode = Off \| Warn \| Panic

	let warn mode =
	match !mode with
	\| Off -> false
	\| Warn -> true
	\| Panic -> true

	let panic mode =
	match !mode with
	\| Off -> false
	\| Warn -> false
	\| Panic -> true

	let suffix mode =
	if panic mode then
	"panic"
	else
	"warn"

	let diagnose_arguments = ref Off
	let diagnose_momenta = ref Off
	let diagnose_gauge = ref Off

	let rec parse_diagnostic = function
	\| All, panic ->
	parse_diagnostic (Arguments, panic);
	parse_diagnostic (Momenta, panic);
	parse_diagnostic (Gauge, panic)
	\| Arguments, panic ->
	diagnose_arguments := if panic then Panic else Warn
	\| Momenta, panic ->
	diagnose_momenta := if panic then Panic else Warn
	\| Gauge, panic ->
	diagnose_gauge := if panic then Panic else Warn

	(* If diagnostics are required, we have to switch off
	Fortran95 features like pure functions. *)

	let parse_diagnostics = function
	\| [] -> ()
	\| diagnostics ->
	fortran95 := false;
	List.iter parse_diagnostic diagnostics

	(* \thocwmodulesubsection{Amplitude} *)

	let declare_momenta_chunk = function
	\| [] -> ()
	\| momenta ->
	printf " @[<2>type(momentum) :: ";
	print_list (List.map format_momentum momenta); nl ()

	let declare_momenta = function
	\| [] -> ()
	\| momenta ->
	List.iter
	declare_momenta_chunk
	(ThoList.chopn declaration_chunk_size momenta)

	let declare_wavefunctions multiplicity wfs =
	let wfs' = classify_wfs wfs in
	declare_list multiplicity ("complex(kind=" ^ !kind ^ ")")
	(wfs'.scalars @ wfs'.brs_scalars);
	declare_list multiplicity ("type(" ^ Fermions.psi_type ^ ")")
	(wfs'.spinors @ wfs'.brs_spinors);
	declare_list multiplicity ("type(" ^ Fermions.psibar_type ^ ")")
	(wfs'.conjspinors @ wfs'.brs_conjspinors);
	declare_list multiplicity ("type(" ^ Fermions.chi_type ^ ")")
	(wfs'.realspinors @ wfs'.brs_realspinors @ wfs'.ghostspinors);
	declare_list multiplicity ("type(" ^ Fermions.grav_type ^ ")") wfs'.vectorspinors;
	declare_list multiplicity "type(vector)" (wfs'.vectors @ wfs'.massive_vectors @
	wfs'.brs_vectors @ wfs'.brs_massive_vectors @ wfs'.ward_vectors);
	declare_list multiplicity "type(tensor2odd)" wfs'.tensors_1;
	declare_list multiplicity "type(tensor)" wfs'.tensors_2

	let flavors a = F.incoming a @ F.outgoing a

	let declare_brakets_chunk = function
	\| [] -> ()
	\| amplitudes ->
	printf " @[<2>complex(kind=%s) :: " !kind;
	print_list (List.map (fun a -> flavors_symbol ~decl:true (flavors a)) amplitudes); nl ()

	let declare_brakets = function
	\| [] -> ()
	\| amplitudes ->
	List.iter
	declare_brakets_chunk
	(ThoList.chopn declaration_chunk_size amplitudes)

	let print_variable_declarations amplitudes =
	let multiplicity = CF.multiplicity amplitudes
	and processes = CF.processes amplitudes in
	declare_momenta
	(PSet.elements
	(List.fold_left
	(fun set a ->
	PSet.union set (List.fold_right
	(fun wf -> PSet.add (F.momentum_list wf))
	(F.externals a) PSet.empty))
	PSet.empty processes));
	declare_momenta
	(PSet.elements
	(List.fold_left
	(fun set a ->
	PSet.union set (List.fold_right
	(fun wf -> PSet.add (F.momentum_list wf))
	(F.variables a) PSet.empty))
	PSet.empty processes));
	if !openmp then begin
	printf " type %s@[<2>" openmp_tld_type;
	nl ();
	end ;
	declare_wavefunctions multiplicity
	(WFSet.elements
	(List.fold_left
	(fun set a ->
	WFSet.union set (List.fold_right WFSet.add (F.externals a) WFSet.empty))
	WFSet.empty processes));
	declare_wavefunctions multiplicity
	(WFSet.elements
	(List.fold_left
	(fun set a ->
	WFSet.union set (List.fold_right WFSet.add (F.variables a) WFSet.empty))
	WFSet.empty processes));
	declare_brakets processes;
	if !openmp then begin
	printf "@] end type %s\n" openmp_tld_type;
	printf " type(%s) :: %s" openmp_tld_type openmp_tld;
	nl ();
	end

	(* [print_current] is the most important function that has to match the functions
	in \verb+omega95+ (see appendix~\ref{sec:fortran}). It offers plentiful
	opportunities for making mistakes, in particular those related to signs.
	We start with a few auxiliary functions: *)

	let children2 rhs =
	match F.children rhs with
	\| [wf1; wf2] -> (wf1, wf2)
	\| _ -> failwith "Targets.children2: can't happen"

	let children3 rhs =
	match F.children rhs with
	\| [wf1; wf2; wf3] -> (wf1, wf2, wf3)
	\| _ -> invalid_arg "Targets.children3: can't happen"

	(* Note that it is (marginally) faster to multiply the two scalar products
	with the coupling constant than the four vector components.
	\begin{dubious}
	This could be part of \verb+omegalib+ as well \ldots
	\end{dubious} *)

	let format_coeff = function
	\| 1 -> ""
	\| -1 -> "-"
	\| coeff -> "(" ^ string_of_int coeff ^ ")*"

	let format_coupling coeff c =
	match coeff with
	\| 1 -> c
	\| -1 -> "(-" ^ c ^")"
	\| coeff -> string_of_int coeff ^ "*" ^ c

	(* \begin{dubious}
	The following is error prone and should be generated automagically.
	\end{dubious} *)

	let print_vector4 c wf1 wf2 wf3 fusion (coeff, contraction) =
	match contraction, fusion with
	\| C_12_34, (F341\|F431\|F342\|F432\|F123\|F213\|F124\|F214)
	\| C_13_42, (F241\|F421\|F243\|F423\|F132\|F312\|F134\|F314)
	\| C_14_23, (F231\|F321\|F234\|F324\|F142\|F412\|F143\|F413) ->
	printf "((%s%s)(%s%s))*%s" (format_coeff coeff) c wf1 wf2 wf3
	\| C_12_34, (F134\|F143\|F234\|F243\|F312\|F321\|F412\|F421)
	\| C_13_42, (F124\|F142\|F324\|F342\|F213\|F231\|F413\|F431)
	\| C_14_23, (F123\|F132\|F423\|F432\|F214\|F241\|F314\|F341) ->
	printf "((%s%s)(%s%s))*%s" (format_coeff coeff) c wf2 wf3 wf1
	\| C_12_34, (F314\|F413\|F324\|F423\|F132\|F231\|F142\|F241)
	\| C_13_42, (F214\|F412\|F234\|F432\|F123\|F321\|F143\|F341)
	\| C_14_23, (F213\|F312\|F243\|F342\|F124\|F421\|F134\|F431) ->
	printf "((%s%s)(%s%s))*%s" (format_coeff coeff) c wf1 wf3 wf2

	let print_add_vector4 c wf1 wf2 wf3 fusion (coeff, contraction) =
	printf "@ + ";
	print_vector4 c wf1 wf2 wf3 fusion (coeff, contraction)

	let print_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction) =
	match contraction, fusion with
	\| C_12_34, (F341\|F431\|F342\|F432\|F123\|F213\|F124\|F214)
	\| C_13_42, (F241\|F421\|F243\|F423\|F132\|F312\|F134\|F314)
	\| C_14_23, (F231\|F321\|F234\|F324\|F142\|F412\|F143\|F413) ->
	printf "((%s%s%s+%s))(%s%s))*%s"
	(format_coeff coeff) c pa pb wf1 wf2 wf3
	\| C_12_34, (F134\|F143\|F234\|F243\|F312\|F321\|F412\|F421)
	\| C_13_42, (F124\|F142\|F324\|F342\|F213\|F231\|F413\|F431)
	\| C_14_23, (F123\|F132\|F423\|F432\|F214\|F241\|F314\|F341) ->
	printf "((%s%s%s+%s))(%s%s))*%s"
	(format_coeff coeff) c pa pb wf2 wf3 wf1
	\| C_12_34, (F314\|F413\|F324\|F423\|F132\|F231\|F142\|F241)
	\| C_13_42, (F214\|F412\|F234\|F432\|F123\|F321\|F143\|F341)
	\| C_14_23, (F213\|F312\|F243\|F342\|F124\|F421\|F134\|F431) ->
	printf "((%s%s%s+%s))(%s%s))*%s"
	(format_coeff coeff) c pa pb wf1 wf3 wf2

	let print_add_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction) =
	printf "@ + ";
	print_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction)

	let print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123
	fusion (coeff, contraction) =
	match contraction, fusion with
	\| C_12_34, (F341\|F431\|F342\|F432\|F123\|F213\|F124\|F214)
	\| C_13_42, (F241\|F421\|F243\|F423\|F132\|F312\|F134\|F314)
	\| C_14_23, (F231\|F321\|F234\|F324\|F142\|F412\|F143\|F413) ->
	printf "((%s%s)(%s%s)(%s%s)%s%s*%s)"
	(format_coeff coeff) c p1 p2 p3 p123 wf1 wf2 wf3
	\| C_12_34, (F134\|F143\|F234\|F243\|F312\|F321\|F412\|F421)
	\| C_13_42, (F124\|F142\|F324\|F342\|F213\|F231\|F413\|F431)
	\| C_14_23, (F123\|F132\|F423\|F432\|F214\|F241\|F314\|F341) ->
	printf "((%s%s)(%s%s)(%s%s)%s%s*%s)"
	(format_coeff coeff) c p2 p3 p1 p123 wf1 wf2 wf3
	\| C_12_34, (F314\|F413\|F324\|F423\|F132\|F231\|F142\|F241)
	\| C_13_42, (F214\|F412\|F234\|F432\|F123\|F321\|F143\|F341)
	\| C_14_23, (F213\|F312\|F243\|F342\|F124\|F421\|F134\|F431) ->
	printf "((%s%s)(%s%s)(%s%s)%s%s*%s)"
	(format_coeff coeff) c p1 p3 p2 p123 wf1 wf2 wf3

	let print_add_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123
	fusion (coeff, contraction) =
	printf "@ + ";
	print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)

	let print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
	fusion (coeff, contraction) =
	failwith "Targets.Fortran.print_dscalar2_vector2: incomplete!";
	match contraction, fusion with
	\| C_12_34, (F134\|F143\|F234\|F243) ->
	printf "((%s%s)(%s%s)(%s%s)*%s)"
	(format_coeff coeff) c p123 p1 wf2 wf3 wf1
	\| C_12_34, (F312\|F321\|F412\|F421) ->
	printf "((%s%s)((%s%s)%s%s)*%s)"
	(format_coeff coeff) c p2 p3 wf2 wf3 wf1
	\| C_12_34, (F341\|F431\|F342\|F432\|F123\|F213\|F124\|F214)
	\| C_13_42, (F241\|F421\|F243\|F423\|F132\|F312\|F134\|F314)
	\| C_14_23, (F231\|F321\|F234\|F324\|F142\|F412\|F143\|F413) ->
	printf "((%s%s)(%s%s)(%s%s)%s%s*%s)"
	(format_coeff coeff) c p1 p2 p3 p123 wf1 wf2 wf3
	\| C_13_42, (F124\|F142\|F324\|F342\|F213\|F231\|F413\|F431)
	\| C_14_23, (F123\|F132\|F423\|F432\|F214\|F241\|F314\|F341) ->
	printf "((%s%s)(%s%s)(%s%s)%s%s*%s)"
	(format_coeff coeff) c p2 p3 p1 p123 wf1 wf2 wf3
	\| C_12_34, (F314\|F413\|F324\|F423\|F132\|F231\|F142\|F241)
	\| C_13_42, (F214\|F412\|F234\|F432\|F123\|F321\|F143\|F341)
	\| C_14_23, (F213\|F312\|F243\|F342\|F124\|F421\|F134\|F431) ->
	printf "((%s%s)(%s%s)(%s%s)%s%s*%s)"
	(format_coeff coeff) c p1 p3 p2 p123 wf1 wf2 wf3

	let print_add_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
	fusion (coeff, contraction) =
	printf "@ + ";
	print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
	fusion (coeff, contraction)

	let print_current amplitude dictionary rhs =
	match F.coupling rhs with
	\| V3 (vertex, fusion, constant) ->
	let ch1, ch2 = children2 rhs in
	let wf1 = multiple_variable amplitude dictionary ch1
	and wf2 = multiple_variable amplitude dictionary ch2
	and p1 = momentum ch1
	and p2 = momentum ch2
	and m1 = CM.mass_symbol (F.flavor ch1)
	and m2 = CM.mass_symbol (F.flavor ch2) in
	let c = CM.constant_symbol constant in
	printf "@, %s " (if (F.sign rhs) < 0 then "-" else "+");
	begin match vertex with

	(* Fermionic currents $\bar\psi\fmslash{A}\psi$ and $\bar\psi\phi\psi$
	are handled by the [Fermions] module, since they depend on the
	choice of Feynman rules: Dirac or Majorana. *)

	\| FBF (coeff, fb, b, f) ->
	begin match coeff, fb, b, f with
	\| _, Psibar, VLRM, Psi \| _, Psibar, SPM, Psi
	\| _, Psibar, VAM, Psi \| _, Psibar, VA3M, Psi
	\| _, Psibar, TVA, Psi \| _, Psibar, TVAM, Psi
	\| _, Psibar, TLR, Psi \| _, Psibar, TLRM, Psi
	\| _, Psibar, TRL, Psi \| _, Psibar, TRLM, Psi ->
	let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
	Fermions.print_current_mom (coeff, fb, b, f) c wf1 wf2 p1 p2
	p12 fusion
	\| _, _, _, _ ->
	Fermions.print_current (coeff, fb, b, f) c wf1 wf2 fusion
	end
	\| PBP (coeff, f1, b, f2) ->
	Fermions.print_current_p (coeff, f1, b, f2) c wf1 wf2 fusion
	\| BBB (coeff, fb1, b, fb2) ->
	Fermions.print_current_b (coeff, fb1, b, fb2) c wf1 wf2 fusion
	\| GBG (coeff, fb, b, f) -> let p12 =
	Printf.sprintf "(-%s-%s)" p1 p2 in
	Fermions.print_current_g (coeff, fb, b, f) c wf1 wf2 p1 p2
	p12 fusion

	(* Table~\ref{tab:dim4-bosons} is a bit misleading, since if includes
	totally antisymmetric structure constants. The space-time part alone
	is also totally antisymmetric: *)

	\| Gauge_Gauge_Gauge coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F31\|F12) ->
	printf "g_gg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| (F32\|F13\|F21) ->
	printf "g_gg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	(* In [Aux_Gauge_Gauge], we can not rely on antisymmetry alone, because of the
	different Lorentz representations of the auxialiary and the gauge field.
	Instead we have to provide the sign in
	\begin{equation}
	(V_2 \wedge V_3) \cdot T_1 =
	\begin{cases}
	V_2 \cdot (T_1 \cdot V_3) = - V_2 \cdot (V_3 \cdot T_1) & \\
	V_3 \cdot (V_2 \cdot T_1) = - V_3 \cdot (T_1 \cdot V_2) &
	\end{cases}
	\end{equation}
	ourselves. Alternatively, one could provide \verb+g_xg+ mirroring
	\verb+g_gx+. *)

	\| Aux_Gauge_Gauge coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "x_gg(%s,%s,%s)" c wf1 wf2
	\| F32 -> printf "x_gg(%s,%s,%s)" c wf2 wf1
	\| F12 -> printf "g_gx(%s,%s,%s)" c wf2 wf1
	\| F21 -> printf "g_gx(%s,%s,%s)" c wf1 wf2
	\| F13 -> printf "(-1)*g_gx(%s,%s,%s)" c wf2 wf1
	\| F31 -> printf "(-1)*g_gx(%s,%s,%s)" c wf1 wf2
	end

	(* These cases are symmetric and we just have to juxtapose the correct fields
	and provide parentheses to minimize the number of multiplications. *)

	\| Scalar_Vector_Vector coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "%s(%s%s)" c wf1 wf2
	\| (F12\|F13) -> printf "(%s%s)%s" c wf1 wf2
	\| (F21\|F31) -> printf "(%s%s)%s" c wf2 wf1
	end

	\| Aux_Vector_Vector coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "%s(%s%s)" c wf1 wf2
	\| (F12\|F13) -> printf "(%s%s)%s" c wf1 wf2
	\| (F21\|F31) -> printf "(%s%s)%s" c wf2 wf1
	end

	(* Even simpler: *)

	\| Scalar_Scalar_Scalar coeff ->
	printf "(%s%s%s)" (format_coupling coeff c) wf1 wf2

	\| Aux_Scalar_Scalar coeff ->
	printf "(%s%s%s)" (format_coupling coeff c) wf1 wf2

	\| Aux_Scalar_Vector coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F13\|F31) -> printf "%s(%s%s)" c wf1 wf2
	\| (F23\|F21) -> printf "(%s%s)%s" c wf1 wf2
	\| (F32\|F12) -> printf "(%s%s)%s" c wf2 wf1
	end

	\| Vector_Scalar_Scalar coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "v_ss(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "v_ss(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F12 -> printf "s_vs(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F21 -> printf "s_vs(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F13 -> printf "(-1)*s_vs(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F31 -> printf "(-1)*s_vs(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Graviton_Scalar_Scalar coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F12 -> printf "s_gravs(%s,%s,-(%s+%s),%s,%s,%s)" c m2 p1 p2 p2 wf1 wf2
	\| F21 -> printf "s_gravs(%s,%s,-(%s+%s),%s,%s,%s)" c m1 p1 p2 p1 wf2 wf1
	\| F13 -> printf "s_gravs(%s,%s,%s,-(%s+%s),%s,%s)" c m2 p2 p1 p2 wf1 wf2
	\| F31 -> printf "s_gravs(%s,%s,%s,-(%s+%s),%s,%s)" c m1 p1 p1 p2 wf2 wf1
	\| F23 -> printf "grav_ss(%s,%s,%s,%s,%s,%s)" c m1 p1 p2 wf1 wf2
	\| F32 -> printf "grav_ss(%s,%s,%s,%s,%s,%s)" c m1 p2 p1 wf2 wf1
	end

	(* In producing a vector in the fusion we always contract the rightmost index with the
	vector wavefunction from [rhs]. So the first momentum is always the one of the
	vector boson produced in the fusion, while the second one is that from the [rhs].
	This makes the cases [F12] and [F13] as well as [F21] and [F31] equal. In principle,
	we could have already done this for the [Graviton_Scalar_Scalar] case. *)


	\| Graviton_Vector_Vector coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F12\|F13) -> printf "v_gravv(%s,%s,-(%s+%s),%s,%s,%s)" c m2 p1 p2 p2 wf1 wf2
	\| (F21\|F31) -> printf "v_gravv(%s,%s,-(%s+%s),%s,%s,%s)" c m1 p1 p2 p1 wf2 wf1
	\| F23 -> printf "grav_vv(%s,%s,%s,%s,%s,%s)" c m1 p1 p2 wf1 wf2
	\| F32 -> printf "grav_vv(%s,%s,%s,%s,%s,%s)" c m1 p2 p1 wf2 wf1
	end

	\| Graviton_Spinor_Spinor coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "f_gravf(%s,%s,-(%s+%s),(-%s),%s,%s)" c m2 p1 p2 p2 wf1 wf2
	\| F32 -> printf "f_gravf(%s,%s,-(%s+%s),(-%s),%s,%s)" c m1 p1 p2 p1 wf2 wf1
	\| F12 -> printf "f_fgrav(%s,%s,%s,%s+%s,%s,%s)" c m1 p1 p1 p2 wf1 wf2
	\| F21 -> printf "f_fgrav(%s,%s,%s,%s+%s,%s,%s)" c m2 p2 p1 p2 wf2 wf1
	\| F13 -> printf "grav_ff(%s,%s,%s,(-%s),%s,%s)" c m1 p1 p2 wf1 wf2
	\| F31 -> printf "grav_ff(%s,%s,%s,(-%s),%s,%s)" c m1 p2 p1 wf2 wf1
	end

	\| Dim4_Vector_Vector_Vector_T coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "tkv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "tkv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F12 -> printf "tv_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F21 -> printf "tv_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F13 -> printf "(-1)*tv_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F31 -> printf "(-1)*tv_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Dim4_Vector_Vector_Vector_L coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "lkv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "lkv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F12 \| F13 -> printf "lv_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
	\| F21 \| F31 -> printf "lv_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
	end

	\| Dim6_Gauge_Gauge_Gauge coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 \| F31 \| F12 ->
	printf "kg_kgkg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 \| F13 \| F21 ->
	printf "kg_kgkg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Dim4_Vector_Vector_Vector_T5 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "t5kv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "t5kv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F12 \| F13 -> printf "t5v_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F21 \| F31 -> printf "t5v_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Dim4_Vector_Vector_Vector_L5 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "l5kv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "l5kv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F12 -> printf "l5v_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
	\| F21 -> printf "l5v_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
	\| F13 -> printf "(-1)*l5v_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
	\| F31 -> printf "(-1)*l5v_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
	end

	\| Dim6_Gauge_Gauge_Gauge_5 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "kg5_kgkg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "kg5_kgkg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F12 -> printf "kg_kg5kg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F21 -> printf "kg_kg5kg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| F13 -> printf "(-1)*kg_kg5kg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F31 -> printf "(-1)*kg_kg5kg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Aux_DScalar_DScalar coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) ->
	printf "%s(%s%s)(%s%s)" c p1 p2 wf1 wf2
	\| (F12\|F13) ->
	printf "%s(-((%s+%s)%s))(%s%s)" c p1 p2 p2 wf1 wf2
	\| (F21\|F31) ->
	printf "%s(-((%s+%s)%s))(%s%s)" c p1 p2 p1 wf1 wf2
	end

	\| Aux_Vector_DScalar coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "%s(%s%s)*%s" c wf1 p2 wf2
	\| F32 -> printf "%s(%s%s)*%s" c wf2 p1 wf1
	\| F12 -> printf "%s(-((%s+%s)%s))*%s" c p1 p2 wf2 wf1
	\| F21 -> printf "%s(-((%s+%s)%s))*%s" c p1 p2 wf1 wf2
	\| (F13\|F31) -> printf "(-(%s+%s))(%s%s*%s)" p1 p2 c wf1 wf2
	end

	\| Dim5_Scalar_Gauge2 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "(%s)((%s%s)(%s%s) - (%s%s)(%s*%s))"
	c p1 wf2 p2 wf1 p1 p2 wf2 wf1
	\| (F12\|F13) -> printf "(%s)%s((-((%s+%s)%s))%s - ((-(%s+%s)%s))%s)"
	c wf1 p1 p2 wf2 p2 p1 p2 p2 wf2
	\| (F21\|F31) -> printf "(%s)%s((-((%s+%s)%s))%s - ((-(%s+%s)%s))%s)"
	c wf2 p2 p1 wf1 p1 p1 p2 p1 wf1
	end

	\| Dim5_Scalar_Gauge2_Skew coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "(- phi_vv (%s, %s, %s, %s, %s))" c p1 p2 wf1 wf2
	\| (F12\|F13) -> printf "(- v_phiv (%s, %s, %s, %s, %s))" c wf1 p1 p2 wf2
	\| (F21\|F31) -> printf "v_phiv (%s, %s, %s, %s, %s)" c wf2 p1 p2 wf1
	end

	\| Dim5_Scalar_Vector_Vector_T coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "(%s)(%s%s)(%s%s)" c p1 wf2 p2 wf1
	\| (F12\|F13) -> printf "(%s)%s(-((%s+%s)%s))%s" c wf1 p1 p2 wf2 p2
	\| (F21\|F31) -> printf "(%s)%s(-((%s+%s)%s))%s" c wf2 p2 p1 wf1 p1
	end

	\| Dim5_Scalar_Vector_Vector_U coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "(%s)((%s%s)(-(%s+%s)%s) - (%s%s)(-(%s+%s)*%s))"
	c p1 wf2 p1 p2 wf1 wf1 wf2 p1 p2 p1
	\| F32 -> printf "(%s)((%s%s)(-(%s+%s)%s) - (%s%s)(-(%s+%s)*%s))"
	c p2 wf1 p2 p1 wf2 wf2 wf1 p2 p1 p2
	\| F12 -> printf "(%s)%s((%s%s)%s - (%s%s)%s)"
	c wf1 p1 wf2 p2 p1 p2 wf2
	\| F21 -> printf "(%s)%s((%s%s)%s - (%s%s)%s)"
	c wf2 p2 wf1 p1 p2 p1 wf1
	\| F13 -> printf "(%s)%s((-((%s+%s)%s))%s - (-(%s+%s)%s)%s)"
	c wf1 p2 p1 wf2 p1 p1 p2 p1 wf2
	\| F31 -> printf "(%s)%s((-((%s+%s)%s))%s - (-(%s+%s)%s)%s)"
	c wf2 p1 p2 wf1 p2 p2 p1 p2 wf1
	end

	\| Dim6_Vector_Vector_Vector_T coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "(%s)(%s%s)(%s%s)*(%s-%s)" c p2 wf1 p1 wf2 p1 p2
	\| F32 -> printf "(%s)(%s%s)(%s%s)*(%s-%s)" c p1 wf2 p2 wf1 p2 p1
	\| (F12\|F13) -> printf "(%s)((%s+2%s)%s)(-((%s+%s)%s))%s"
	c p1 p2 wf1 p1 p2 wf2 p2
	\| (F21\|F31) -> printf "(%s)((-((%s+%s)%s))(%s+2%s)%s)%s"
	c p2 p1 wf1 p2 p1 wf2 p1
	end

	\| Tensor_2_Vector_Vector coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "t2_vv(%s,%s,%s)" c wf1 wf2
	\| (F12\|F13) -> printf "v_t2v(%s,%s,%s)" c wf1 wf2
	\| (F21\|F31) -> printf "v_t2v(%s,%s,%s)" c wf2 wf1
	end

	\| Dim5_Tensor_2_Vector_Vector_1 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| (F23\|F32) -> printf "t2_vv_d5_1(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| (F12\|F13) -> printf "v_t2v_d5_1(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| (F21\|F31) -> printf "v_t2v_d5_1(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Dim5_Tensor_2_Vector_Vector_2 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "t2_vv_d5_2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "t2_vv_d5_2(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| (F12\|F13) -> printf "v_t2v_d5_2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| (F21\|F31) -> printf "v_t2v_d5_2(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	\| Dim7_Tensor_2_Vector_Vector_T coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F23 -> printf "t2_vv_d7(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| F32 -> printf "t2_vv_d7(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	\| (F12\|F13) -> printf "v_t2v_d7(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
	\| (F21\|F31) -> printf "v_t2v_d7(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
	end

	end

	(* Flip the sign to account for the~$\mathrm{i}^2$ relative to diagrams
	with only cubic couplings. *)

	\| V4 (vertex, fusion, constant) ->
	let c = CM.constant_symbol constant
	and ch1, ch2, ch3 = children3 rhs in
	let wf1 = multiple_variable amplitude dictionary ch1
	and wf2 = multiple_variable amplitude dictionary ch2
	and wf3 = multiple_variable amplitude dictionary ch3
	and p1 = momentum ch1
	and p2 = momentum ch2
	and p3 = momentum ch3 in
	printf "@, %s " (if (F.sign rhs) < 0 then "+" else "-");
	begin match vertex with
	\| Scalar4 coeff ->
	printf "(%s%s%s*%s)" (format_coupling coeff c) wf1 wf2 wf3
	\| Scalar2_Vector2 coeff ->
	let c = format_coupling coeff c in
	begin match fusion with
	\| F134 \| F143 \| F234 \| F243 ->
	printf "%s%s(%s*%s)" c wf1 wf2 wf3
	\| F314 \| F413 \| F324 \| F423 ->
	printf "%s%s(%s*%s)" c wf2 wf1 wf3
	\| F341 \| F431 \| F342 \| F432 ->
	printf "%s%s(%s*%s)" c wf3 wf1 wf2
	\| F312 \| F321 \| F412 \| F421 ->
	printf "(%s%s%s)*%s" c wf2 wf3 wf1
	\| F231 \| F132 \| F241 \| F142 ->
	printf "(%s%s%s)*%s" c wf1 wf3 wf2
	\| F123 \| F213 \| F124 \| F214 ->
	printf "(%s%s%s)*%s" c wf1 wf2 wf3
	end
	\| Vector4 contractions ->
	begin match contractions with
	\| [] -> invalid_arg "Targets.print_current: Vector4 []"
	\| head :: tail ->
	printf "(";
	print_vector4 c wf1 wf2 wf3 fusion head;
	List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
	printf ")"
	end
	\| Vector4_K_Matrix_tho (disc, poles) ->
	let pa, pb =
	begin match fusion with
	\| (F341\|F431\|F342\|F432\|F123\|F213\|F124\|F214) -> (p1, p2)
	\| (F134\|F143\|F234\|F243\|F312\|F321\|F412\|F421) -> (p2, p3)
	\| (F314\|F413\|F324\|F423\|F132\|F231\|F142\|F241) -> (p1, p3)
	end in
	printf "(%s(%s%s)(%s%s)(%s%s)@,*("
	c p1 wf1 p2 wf2 p3 wf3;
	List.iter (fun (coeff, pole) ->
	printf "+%s/((%s+%s)*(%s+%s)-%s)"
	(CM.constant_symbol coeff) pa pb pa pb
	(CM.constant_symbol pole))
	poles;
	printf ")*(-%s-%s-%s))" p1 p2 p3
	\| Vector4_K_Matrix_jr (disc, contractions) ->
	let pa, pb =
	begin match disc, fusion with
	\| 3, (F143\|F413\|F142\|F412\|F321\|F231\|F324\|F234) -> (p1, p2)
	\| 3, (F314\|F341\|F214\|F241\|F132\|F123\|F432\|F423) -> (p2, p3)
	\| 3, (F134\|F431\|F124\|F421\|F312\|F213\|F342\|F243) -> (p1, p3)
	\| _, (F341\|F431\|F342\|F432\|F123\|F213\|F124\|F214) -> (p1, p2)
	\| _, (F134\|F143\|F234\|F243\|F312\|F321\|F412\|F421) -> (p2, p3)
	\| _, (F314\|F413\|F324\|F423\|F132\|F231\|F142\|F241) -> (p1, p3)
	end in
	begin match contractions with
	\| [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_jr []"
	\| head :: tail ->
	printf "(";
	print_vector4_km c pa pb wf1 wf2 wf3 fusion head;
	List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
	tail;
	printf ")"
	end
	\| GBBG (coeff, fb, b, f) ->
	Fermions.print_current_g4 (coeff, fb, b, f) c wf1 wf2 wf3
	fusion

	(* \begin{dubious}
	In principle, [p4] could be obtained from the left hand side \ldots
	\end{dubious} *)
	\| DScalar4 contractions ->
	let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
	begin match contractions with
	\| [] -> invalid_arg "Targets.print_current: DScalar4 []"
	\| head :: tail ->
	printf "(";
	print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
	List.iter (print_add_dscalar4
	c wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
	printf ")"
	end

	\| DScalar2_Vector2 contractions ->
	let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
	begin match contractions with
	\| [] -> invalid_arg "Targets.print_current: DScalar4 []"
	\| head :: tail ->
	printf "(";
	print_dscalar2_vector2
	c wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
	List.iter (print_add_dscalar2_vector2
	c wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
	printf ")"
	end
	end

	\| Vn (_, _, _) ->
	invalid_arg "Targets.print_current: n-ary fusion"

	let print_propagator f p m gamma =
	let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
	let w =
	begin match CM.width f with
	\| Vanishing \| Fudged -> "0.0_" ^ !kind
	\| Constant -> gamma
	\| Timelike -> "wd_tl(" ^ p ^ "," ^ gamma ^ ")"
	\| Running ->
	failwith "Targets.Fortran: running width not yet available"
	\| Custom f -> f ^ "(" ^ p ^ "," ^ gamma ^ ")"
	end in
	match CM.propagator f with
	\| Prop_Scalar ->
	printf "pr_phi(%s,%s,%s," p m w
	\| Prop_Col_Scalar ->
	printf "%s * pr_phi(%s,%s,%s," minus_third p m w
	\| Prop_Ghost -> printf "(0,1) * pr_phi(%s, %s, %s," p m w
	\| Prop_Spinor ->
	printf "%s(%s,%s,%s," Fermions.psi_propagator p m w
	\| Prop_ConjSpinor ->
	printf "%s(%s,%s,%s," Fermions.psibar_propagator p m w
	\| Prop_Majorana ->
	printf "%s(%s,%s,%s," Fermions.chi_propagator p m w
	\| Prop_Col_Majorana ->
	printf "%s * %s(%s,%s,%s," minus_third Fermions.chi_propagator p m w
	\| Prop_Unitarity ->
	printf "pr_unitarity(%s,%s,%s," p m w
	\| Prop_Col_Unitarity ->
	printf "%s * pr_unitarity(%s,%s,%s," minus_third p m w
	\| Prop_Feynman ->
	printf "pr_feynman(%s," p
	\| Prop_Col_Feynman ->
	printf "%s * pr_feynman(%s," minus_third p
	\| Prop_Gauge xi ->
	printf "pr_gauge(%s,%s," p (CM.gauge_symbol xi)
	\| Prop_Rxi xi ->
	printf "pr_rxi(%s,%s,%s,%s," p m w (CM.gauge_symbol xi)
	\| Prop_Tensor_2 ->
	printf "pr_tensor(%s,%s,%s," p m w
	\| Prop_Vectorspinor ->
	printf "pr_grav(%s,%s,%s," p m w
	\| Aux_Scalar \| Aux_Spinor \| Aux_ConjSpinor \| Aux_Majorana
	\| Aux_Vector \| Aux_Tensor_1 -> printf "("
	\| Aux_Col_Scalar \| Aux_Col_Vector \| Aux_Col_Tensor_1 -> printf "%s * (" minus_third
	\| Only_Insertion -> printf "("

	let print_projector f p m gamma =
	let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
	match CM.propagator f with
	\| Prop_Scalar ->
	printf "pj_phi(%s,%s," m gamma
	\| Prop_Col_Scalar ->
	printf "%s * pj_phi(%s,%s," minus_third m gamma
	\| Prop_Ghost ->
	printf "(0,1) * pj_phi(%s,%s," m gamma
	\| Prop_Spinor ->
	printf "%s(%s,%s,%s," Fermions.psi_projector p m gamma
	\| Prop_ConjSpinor ->
	printf "%s(%s,%s,%s," Fermions.psibar_projector p m gamma
	\| Prop_Majorana ->
	printf "%s(%s,%s,%s," Fermions.chi_projector p m gamma
	\| Prop_Col_Majorana ->
	printf "%s * %s(%s,%s,%s," minus_third Fermions.chi_projector p m gamma
	\| Prop_Unitarity ->
	printf "pj_unitarity(%s,%s,%s," p m gamma
	\| Prop_Col_Unitarity ->
	printf "%s * pj_unitarity(%s,%s,%s," minus_third p m gamma
	\| Prop_Feynman \| Prop_Col_Feynman ->
	invalid_arg "no on-shell Feynman propagator!"
	\| Prop_Gauge xi ->
	invalid_arg "no on-shell massless gauge propagator!"
	\| Prop_Rxi xi ->
	invalid_arg "no on-shell Rxi propagator!"
	\| Prop_Vectorspinor ->
	printf "pj_grav(%s,%s,%s," p m gamma
	\| Prop_Tensor_2 ->
	printf "pj_tensor(%s,%s,%s," p m gamma
	\| Aux_Scalar \| Aux_Spinor \| Aux_ConjSpinor \| Aux_Majorana
	\| Aux_Vector \| Aux_Tensor_1 -> printf "("
	\| Aux_Col_Scalar \| Aux_Col_Vector \| Aux_Col_Tensor_1 -> printf "%s * (" minus_third
	\| Only_Insertion -> printf "("

	let print_gauss f p m gamma =
	let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
	match CM.propagator f with
	\| Prop_Scalar ->
	printf "pg_phi(%s,%s,%s," p m gamma
	\| Prop_Ghost ->
	printf "(0,1) * pg_phi(%s,%s,%s," p m gamma
	\| Prop_Spinor ->
	printf "%s(%s,%s,%s," Fermions.psi_projector p m gamma
	\| Prop_ConjSpinor ->
	printf "%s(%s,%s,%s," Fermions.psibar_projector p m gamma
	\| Prop_Majorana ->
	printf "%s(%s,%s,%s," Fermions.chi_projector p m gamma
	\| Prop_Col_Majorana ->
	printf "%s * %s(%s,%s,%s," minus_third Fermions.chi_projector p m gamma
	\| Prop_Unitarity ->
	printf "pg_unitarity(%s,%s,%s," p m gamma
	\| Prop_Feynman \| Prop_Col_Feynman ->
	invalid_arg "no on-shell Feynman propagator!"
	\| Prop_Gauge xi ->
	invalid_arg "no on-shell massless gauge propagator!"
	\| Prop_Rxi xi ->
	invalid_arg "no on-shell Rxi propagator!"
	\| Prop_Tensor_2 ->
	printf "pg_tensor(%s,%s,%s," p m gamma
	\| Aux_Scalar \| Aux_Spinor \| Aux_ConjSpinor \| Aux_Majorana
	\| Aux_Vector \| Aux_Tensor_1 -> printf "("
	\| Only_Insertion -> printf "("
	\| _ -> invalid_arg "targets:print_gauss: not available"

	let print_fusion_diagnostics amplitude dictionary fusion =
	if warn diagnose_gauge then begin
	let lhs = F.lhs fusion in
	let f = F.flavor lhs
	and v = variable lhs
	and p = momentum lhs in
	let mass = CM.mass_symbol f in
	match CM.propagator f with
	\| Prop_Gauge _ \| Prop_Feynman
	\| Prop_Rxi _ \| Prop_Unitarity ->
	printf " @[<2>%s =" v;
	List.iter (print_current amplitude dictionary) (F.rhs fusion); nl();
	begin match CM.goldstone f with
	\| None ->
	printf " call omega_ward_%s(\"%s\",%s,%s,%s)"
	(suffix diagnose_gauge) v mass p v; nl ()
	\| Some (g, phase) ->
	let gv = add_tag lhs (CM.flavor_symbol g ^ "_" ^ format_p lhs) in
	printf " call omega_slavnov_%s"
	(suffix diagnose_gauge);
	printf "(@[\"%s\",%s,%s,%s,@,%s*%s)"
	v mass p v (format_constant phase) gv; nl ()
	end
	\| _ -> ()
	end

	let print_fusion amplitude dictionary fusion =
	let lhs = F.lhs fusion in
	let f = F.flavor lhs in
	printf " @[<2>%s =@, " (multiple_variable amplitude dictionary lhs);
	if F.on_shell amplitude lhs then
	print_projector f (momentum lhs)
	(CM.mass_symbol f) (CM.width_symbol f)
	else
	if F.is_gauss amplitude lhs then
	print_gauss f (momentum lhs)
	(CM.mass_symbol f) (CM.width_symbol f)
	else
	print_propagator f (momentum lhs)
	(CM.mass_symbol f) (CM.width_symbol f);
	List.iter (print_current amplitude dictionary) (F.rhs fusion);
	printf ")"; nl ()

	let print_momenta seen_momenta amplitude =
	List.fold_left (fun seen f ->
	let wf = F.lhs f in
	let p = F.momentum_list wf in
	if not (PSet.mem p seen) then begin
	let rhs1 = List.hd (F.rhs f) in
	printf " %s = %s" (momentum wf)
	(String.concat " + "
	(List.map momentum (F.children rhs1))); nl ()
	end;
	PSet.add p seen)
	seen_momenta (F.fusions amplitude)

	let print_fusions dictionary fusions =
	List.iter
	(fun (f, amplitude) ->
	print_fusion_diagnostics amplitude dictionary f;
	print_fusion amplitude dictionary f)
	fusions

	let print_braket amplitude dictionary name braket =
	let bra = F.bra braket
	and ket = F.ket braket in
	printf " @[<2>%s = %s@, + " name name;
	begin match Fermions.reverse_braket (CM.lorentz (F.flavor bra)) with
	\| false ->
	printf "%s*(@," (multiple_variable amplitude dictionary bra);
	List.iter (print_current amplitude dictionary) ket;
	printf ")"
	\| true ->
	printf "(@,";
	List.iter (print_current amplitude dictionary) ket;
	printf ")*%s" (multiple_variable amplitude dictionary bra)
	end; nl ()

	(* \begin{equation}
	\ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
	= \ii^{n-2}\ii^{n-3} \cdots
	= -\ii(-1)^n \cdots
	\end{equation} *)

	(* \begin{dubious}
	[tho:] we write some brakets twice using different names. Is it useful
	to cache them?
	\end{dubious} *)

	let print_brakets dictionary amplitude =
	let name = flavors_symbol (flavors amplitude) in
	printf " %s = 0" name; nl ();
	List.iter (print_braket amplitude dictionary name) (F.brakets amplitude);
	let n = List.length (F.externals amplitude) in
	if n mod 2 = 0 then begin
	printf " @[<2>%s =@, - %s ! %d vertices, %d propagators"
	name name (n - 2) (n - 3); nl ()
	end else begin
	printf " ! %s = %s ! %d vertices, %d propagators"
	name name (n - 2) (n - 3); nl ()
	end;
	let s = F.symmetry amplitude in
	if s > 1 then
	printf " @[<2>%s =@, %s@, / sqrt(%d.0_%s) ! symmetry factor" name name s !kind
	else
	printf " ! unit symmetry factor";
	nl ()

	let print_incoming wf =
	let p = momentum wf
	and s = spin wf
	and f = F.flavor wf in
	let m = CM.mass_symbol f in
	match CM.lorentz f with
	\| Scalar -> printf "1"
	\| BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m
	\| Spinor ->
	printf "%s (%s, - %s, %s)" Fermions.psi_incoming m p s
	\| BRS Spinor ->
	printf "%s (%s, - %s, %s)" Fermions.brs_psi_incoming m p s
	\| ConjSpinor ->
	printf "%s (%s, - %s, %s)" Fermions.psibar_incoming m p s
	\| BRS ConjSpinor ->
	printf "%s (%s, - %s, %s)" Fermions.brs_psibar_incoming m p s
	\| Majorana ->
	printf "%s (%s, - %s, %s)" Fermions.chi_incoming m p s
	\| Maj_Ghost -> printf "ghost (%s, - %s, %s)" m p s
	\| BRS Majorana ->
	printf "%s (%s, - %s, %s)" Fermions.brs_chi_incoming m p s
	\| Vector \| Massive_Vector ->
	printf "eps (%s, - %s, %s)" m p s
	(i \| Ward_Vector -> printf "%s" p i)
	\| BRS Vector \| BRS Massive_Vector -> printf
	"(0,1) * (%s * %s - %s*2) eps (%s, -%s, %s)" p p m m p s
	\| Vectorspinor \| BRS Vectorspinor ->
	printf "%s (%s, - %s, %s)" Fermions.grav_incoming m p s
	\| Tensor_1 -> invalid_arg "Tensor_1 only internal"
	\| Tensor_2 -> printf "eps2 (%s, - %s, %s)" m p s
	\| _ -> invalid_arg "no such BRST transformations"

	let print_outgoing wf =
	let p = momentum wf
	and s = spin wf
	and f = F.flavor wf in
	let m = CM.mass_symbol f in
	match CM.lorentz f with
	\| Scalar -> printf "1"
	\| BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m
	\| Spinor ->
	printf "%s (%s, %s, %s)" Fermions.psi_outgoing m p s
	\| BRS Spinor ->
	printf "%s (%s, %s, %s)" Fermions.brs_psi_outgoing m p s
	\| ConjSpinor ->
	printf "%s (%s, %s, %s)" Fermions.psibar_outgoing m p s
	\| BRS ConjSpinor ->
	printf "%s (%s, %s, %s)" Fermions.brs_psibar_outgoing m p s
	\| Majorana ->
	printf "%s (%s, %s, %s)" Fermions.chi_outgoing m p s
	\| BRS Majorana ->
	printf "%s (%s, %s, %s)" Fermions.brs_chi_outgoing m p s
	\| Maj_Ghost -> printf "ghost (%s, %s, %s)" m p s
	\| Vector \| Massive_Vector ->
	printf "conjg (eps (%s, %s, %s))" m p s
	(i \| Ward_Vector -> printf "%s" p i)
	\| BRS Vector \| BRS Massive_Vector -> printf
	"(0,1) * (%s%s-%s2) (conjg (eps (%s, %s, %s)))" p p m m p s
	\| Vectorspinor \| BRS Vectorspinor ->
	printf "%s (%s, %s, %s)" Fermions.grav_incoming m p s
	\| Tensor_1 -> invalid_arg "Tensor_1 only internal"
	\| Tensor_2 -> printf "conjg (eps2 (%s, %s, %s))" m p s
	\| BRS _ -> invalid_arg "no such BRST transformations"

	let twice_spin wf =
	match CM.lorentz (F.flavor wf) with
	\| Scalar \| BRS Scalar -> "0"
	\| Spinor \| ConjSpinor \| Majorana \| Maj_Ghost \| Vectorspinor
	\| BRS Spinor \| BRS ConjSpinor \| BRS Majorana \| BRS Vectorspinor -> "1"
	\| Vector \| BRS Vector \| Massive_Vector \| BRS Massive_Vector -> "2"
	\| Tensor_1 -> "2"
	\| Tensor_2 -> "4"
	\| BRS _ -> invalid_arg "Targets.twice_spin: no such BRST transformation"

	let print_argument_diagnostics amplitude =
	let externals = (F.externals amplitude) in
	let n = List.length externals
	and masses = List.map (fun wf -> CM.mass_symbol (F.flavor wf)) externals in
	if warn diagnose_arguments then begin
	printf " call omega_check_arguments_%s (%d, k)"
	(suffix diagnose_arguments) n; nl ()
	end;
	if warn diagnose_momenta then begin
	printf " @[<2>call omega_check_momenta_%s ((/ "
	(suffix diagnose_momenta);
	print_list masses;
	printf " /), k)"; nl ()
	end

	let print_external_momenta amplitude =
	let externals =
	List.combine
	(F.externals amplitude)
	(List.map (fun _ -> true) (F.incoming amplitude) @
	List.map (fun _ -> false) (F.outgoing amplitude)) in
	List.iter (fun (wf, incoming) ->
	if incoming then
	printf " %s = - k(:,%d) ! incoming"
	(momentum wf) (ext_momentum wf)
	else
	printf " %s = k(:,%d) ! outgoing"
	(momentum wf) (ext_momentum wf); nl ()) externals

	let print_externals seen_wfs amplitude =
	let externals =
	List.combine
	(F.externals amplitude)
	(List.map (fun _ -> true) (F.incoming amplitude) @
	List.map (fun _ -> false) (F.outgoing amplitude)) in
	List.fold_left (fun seen (wf, incoming) ->
	if not (WFSet.mem wf seen) then begin
	printf " @[<2>%s =@, " (variable wf);
	(if incoming then print_incoming else print_outgoing) wf; nl ()
	end;
	WFSet.add wf seen) seen_wfs externals

	let flavors_to_string flavors =
	String.concat " " (List.map CM.flavor_to_string flavors)

	let process_to_string amplitude =
	flavors_to_string (F.incoming amplitude) ^ " -> " ^
	flavors_to_string (F.outgoing amplitude)

	let flavors_sans_color_to_string flavors =
	String.concat " " (List.map M.flavor_to_string flavors)

	let process_sans_color_to_string (fin, fout) =
	flavors_sans_color_to_string fin ^ " -> " ^
	flavors_sans_color_to_string fout

	let print_fudge_factor amplitude =
	let name = flavors_symbol (flavors amplitude) in
	List.iter (fun wf ->
	let p = momentum wf
	and f = F.flavor wf in
	match CM.width f with
	\| Fudged ->
	let m = CM.mass_symbol f
	and w = CM.width_symbol f in
	printf " if (%s > 0.0_%s) then" w !kind; nl ();
	printf " @[<2>%s = %s@ * (%s%s - %s*2)"
	name name p p m;
	printf "@ / cmplx (%s%s - %s2, %s%s, kind=%s)"
	p p m m w !kind; nl();
	printf " end if"; nl ()
	\| _ -> ()) (F.s_channel amplitude)

	let num_helicities amplitudes =
	List.length (CF.helicities amplitudes)

	(* \thocwmodulesubsection{Spin, Flavor \&\ Color Tables} *)

	(* The following abomination is required to keep the number of continuation
	lines as low as possible. FORTRAN77-style \texttt{DATA} statements
	are actually a bit nicer here, but they are nor available for
	\emph{constant} arrays. *)

	(* \begin{dubious}
	We used to have a more elegent design with a sentinel~0 added to each
	initializer, but some revisions of the Compaq/Digital Compiler have a
	bug that causes it to reject this variant.
	\end{dubious} *)

	(* \begin{dubious}
	The actual table writing code using \texttt{reshape} should be factored,
	since it's the same algorithm every time.
	\end{dubious} *)

	let print_integer_parameter name value =
	printf " @[<2>integer, parameter :: %s = %d" name value; nl ()

	let print_real_parameter name value =
	printf " @[<2>real(kind=%s), parameter :: %s = %d"
	!kind name value; nl ()

	let print_logical_parameter name value =
	printf " @[<2>logical, parameter :: %s = .%s."
	name (if value then "true" else "false"); nl ()

	let num_particles_in amplitudes =
	match CF.flavors amplitudes with
	\| [] -> 0
	\| (fin, _) :: _ -> List.length fin

	let num_particles_out amplitudes =
	match CF.flavors amplitudes with
	\| [] -> 0
	\| (_, fout) :: _ -> List.length fout

	let num_particles amplitudes =
	match CF.flavors amplitudes with
	\| [] -> 0
	\| (fin, fout) :: _ -> List.length fin + List.length fout

	module CFlow = Color.Flow

	let num_color_flows amplitudes =
	List.length (CF.color_flows amplitudes)

	let num_color_indices_default = 2 (* Standard model *)

	let num_color_indices amplitudes =
	try CFlow.rank (List.hd (CF.color_flows amplitudes)) with _ -> num_color_indices_default

	let color_to_string c =
	"(" ^ (String.concat "," (List.map (Printf.sprintf "%3d") c)) ^ ")"

	let cflow_to_string cflow =
	String.concat " " (List.map color_to_string (CFlow.in_to_lists cflow)) ^ " -> " ^
	String.concat " " (List.map color_to_string (CFlow.out_to_lists cflow))

	let protected = ""
	let protected = ", protected" (* Fortran 2003! *)

	let print_spin_table_old abbrev name = function
	\| [] ->
	printf " @[<2>integer, dimension(n_prt,0) ::";
	printf "@ table_spin_%s" name; nl ()
	\| _ :: tuples' as tuples ->
	ignore (List.fold_left (fun i (tuple1, tuple2) ->
	printf " @[<2>integer, dimension(n_prt), parameter, private ::";
	printf "@ %s%04d = (/ %s /)" abbrev i
	(String.concat ", " (List.map (Printf.sprintf "%2d") (tuple1 @ tuple2)));
	nl (); succ i) 1 tuples);
	printf
	" @[<2>integer, dimension(n_prt,n_hel), parameter ::";
	printf "@ table_spin_%s =@ reshape ( (/" name;
	printf "@ %s%04d" abbrev 1;
	ignore (List.fold_left (fun i tuple ->
	printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
	printf "@ /), (/ n_prt, n_hel /) )"; nl ()

	let print_spin_table name tuples =
	printf " @[<2>integer, dimension(n_prt,n_hel), save%s :: table_spin_%s"
	protected name; nl();
	match tuples with
	\| [] -> ()
	\| _ ->
	ignore (List.fold_left (fun i (tuple1, tuple2) ->
	printf " @[<2>data table_spin_%s(:,%4d) / %s /" name i
	(String.concat ", " (List.map (Printf.sprintf "%2d") (tuple1 @ tuple2)));
	nl (); succ i) 1 tuples)

	let print_spin_tables amplitudes =
	(* [print_spin_table_old "s" "states_old" (CF.helicities amplitudes);] *)
	print_spin_table "states" (CF.helicities amplitudes);
	nl ()

	let print_flavor_table_old n abbrev name = function
	\| [] ->
	printf " @[<2>integer, dimension(n_prt,0) ::";
	printf "@ table_flavor_%s" name; nl ()
	\| _ :: tuples' as tuples ->
	ignore (List.fold_left (fun i tuple ->
	printf
	" @[<2>integer, dimension(n_prt), parameter, private ::";
	printf "@ %s%04d = (/ %s /) ! %s" abbrev i
	(String.concat ", "
	(List.map (fun f -> Printf.sprintf "%3d" (M.pdg f)) tuple))
	(String.concat " " (List.map M.flavor_to_string tuple));
	nl (); succ i) 1 tuples);
	printf
	" @[<2>integer, dimension(n_prt,n_flv), parameter ::";
	printf "@ table_flavor_%s =@ reshape ( (/" name;
	printf "@ %s%04d" abbrev 1;
	ignore (List.fold_left (fun i tuple ->
	printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
	printf "@ /), (/ n_prt, n_flv /) )"; nl ()

	let print_flavor_table n name tuples =
	printf " @[<2>integer, dimension(n_prt,n_flv), save%s :: table_flavor_%s"
	protected name; nl();
	match tuples with
	\| [] -> ()
	\| _ ->
	ignore (List.fold_left (fun i tuple ->
	printf " @[<2>data table_flavor_%s(:,%4d) / %s / ! %s" name i
	(String.concat ", "
	(List.map (fun f -> Printf.sprintf "%3d" (M.pdg f)) tuple))
	(String.concat " " (List.map M.flavor_to_string tuple));
	nl (); succ i) 1 tuples)

	let print_flavor_tables amplitudes =
	let n = num_particles amplitudes in
	(* [print_flavor_table_old n "f" "states_old"
	(List.map (fun (fin, fout) -> fin @ fout) (CF.flavors amplitudes));] *)
	print_flavor_table n "states"
	(List.map (fun (fin, fout) -> fin @ fout) (CF.flavors amplitudes));
	nl ()

	let num_flavors amplitudes =
	List.length (CF.flavors amplitudes)

	let print_color_flows_table_old abbrev = function
	\| [] ->
	printf " @[<2>integer, dimension(n_cindex, n_prt, n_cflow) ::";
	printf "@ table_color_flows"; nl ()
	\| _ :: tuples' as tuples ->
	ignore (List.fold_left (fun i tuple ->
	printf
	" @[<2>integer, dimension(n_cindex, n_prt), parameter, private ::";
	printf "@ %s%04d = reshape ( (/ " abbrev i;
	begin match CFlow.to_lists tuple with
	\| [] -> ()
	\| cf1 :: cfn ->
	printf "@ %s" (String.concat "," (List.map string_of_int cf1));
	List.iter (function cf ->
	printf ",@ %s" (String.concat "," (List.map string_of_int cf))) cfn
	end;
	printf "@ /),@ (/ n_cindex, n_prt /) )";
	nl (); succ i) 1 tuples);
	printf
	" @[<2>integer, dimension(n_cindex, n_prt, n_cflow), parameter ::";
	printf "@ table_color_flows_old =@ reshape ( (/";
	printf "@ %s%04d" abbrev 1;
	ignore (List.fold_left (fun i tuple ->
	printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
	printf "@ /),@ (/ n_cindex, n_prt, n_cflow /) )"; nl ()

	let print_ghost_flags_table_old abbrev = function
	\| [] ->
	printf " @[<2>logical, dimension(n_prt, n_cflow) ::";
	printf "@ table_ghost_flags"; nl ()
	\| _ :: tuples' as tuples ->
	ignore (List.fold_left (fun i tuple ->
	printf
	" @[<2>logical, dimension(n_prt), parameter, private ::";
	printf "@ %s%04d = (/ " abbrev i;
	begin match CFlow.ghost_flags tuple with
	\| [] -> ()
	\| gf1 :: gfn ->
	printf "@ %s" (if gf1 then "T" else "F");
	List.iter (function gf -> printf ",@ %s" (if gf then "T" else "F")) gfn
	end;
	printf "@ /)";
	nl (); succ i) 1 tuples);
	printf
	" @[<2>logical, dimension(n_prt, n_cflow), parameter ::";
	printf "@ table_ghost_flags_old =@ reshape ( (/";
	printf "@ %s%04d" abbrev 1;
	ignore (List.fold_left (fun i tuple ->
	printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
	printf "@ /),@ (/ n_prt, n_cflow /) )"; nl ()

	let print_color_flows_table tuples =
	printf
	" @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows"
	protected; nl ();
	match tuples with
	\| [] -> ()
	\| _ :: tuples' as tuples ->
	ignore (List.fold_left (fun i tuple ->
	begin match CFlow.to_lists tuple with
	\| [] -> ()
	\| cf1 :: cfn ->
	printf " @[<2>data table_color_flows(:,:,%4d) /" i;
	printf "@ %s" (String.concat "," (List.map string_of_int cf1));
	List.iter (function cf ->
	printf ",@ %s" (String.concat "," (List.map string_of_int cf))) cfn;
	printf "@ /"; nl ()
	end;
	succ i) 1 tuples)

	let print_ghost_flags_table tuples =
	printf
	" @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags"
	protected; nl ();
	match tuples with
	\| [] -> ()
	\| _ ->
	ignore (List.fold_left (fun i tuple ->
	begin match CFlow.ghost_flags tuple with
	\| [] -> ()
	\| gf1 :: gfn ->
	printf " @[<2>data table_ghost_flags(:,%4d) /" i;
	printf "@ %s" (if gf1 then "T" else "F");
	List.iter (function gf -> printf ",@ %s" (if gf then "T" else "F")) gfn;
	printf " /";
	nl ()
	end;
	succ i) 1 tuples)

	let format_power_of x
	{ Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } =
	match num, den, pwr with
	\| _, 0, _ -> invalid_arg "format_power_of: zero denominator"
	\| 0, _, _ -> "+zero"
	\| 1, 1, 0 \| -1, -1, 0 -> "+one"
	\| -1, 1, 0 \| 1, -1, 0 -> "-one"
	\| 1, 1, 1 \| -1, -1, 1 -> "+" ^ x
	\| -1, 1, 1 \| 1, -1, 1 -> "-" ^ x
	\| 1, 1, -1 \| -1, -1, -1 -> "+1/" ^ x
	\| -1, 1, -1 \| 1, -1, -1 -> "-1/" ^ x
	\| 1, 1, p \| -1, -1, p ->
	"+" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p)
	\| -1, 1, p \| 1, -1, p ->
	"-" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p)
	\| n, 1, 0 ->
	(if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind
	\| n, d, 0 ->
	(if n * d < 0 then "-" else "+") ^
	string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
	string_of_int (abs d)
	\| n, 1, 1 ->
	(if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "*" ^ x
	\| n, 1, -1 ->
	(if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "/" ^ x
	\| n, d, 1 ->
	(if n * d < 0 then "-" else "+") ^
	string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
	string_of_int (abs d) ^ "*" ^ x
	\| n, d, -1 ->
	(if n * d < 0 then "-" else "+") ^
	string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
	string_of_int (abs d) ^ "/" ^ x
	\| n, 1, p ->
	(if n < 0 then "-" else "+") ^ string_of_int (abs n) ^
	(if p > 0 then "" else "/") ^ x ^ "*" ^ string_of_int (abs p)
	\| n, d, p ->
	(if n * d < 0 then "-" else "+") ^
	string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
	string_of_int (abs d) ^
	(if p > 0 then "" else "/") ^ x ^ "*" ^ string_of_int (abs p)

	let format_powers_of x = function
	\| [] -> "zero"
	\| powers -> String.concat "" (List.map (format_power_of x) powers)

	let print_color_factor_table_old table =
	let n_cflow = Array.length table in
	let n_cfactors = ref 0 in
	for c1 = 0 to pred n_cflow do
	for c2 = 0 to pred n_cflow do
	match table.(c1).(c2) with
	\| [] -> ()
	\| _ -> incr n_cfactors
	done
	done;
	print_integer_parameter "n_cfactors" !n_cfactors;
	if n_cflow <= 0 then begin
	printf " @[<2>type(%s), dimension(n_cfactors) ::"
	omega_color_factor_abbrev;
	printf "@ table_color_factors"; nl ()
	end else begin
	printf
	" @[<2>type(%s), dimension(n_cfactors), parameter ::"
	omega_color_factor_abbrev;
	printf "@ table_color_factors = (/@ ";
	let comma = ref "" in
	for c1 = 0 to pred n_cflow do
	for c2 = 0 to pred n_cflow do
	match table.(c1).(c2) with
	\| [] -> ()
	\| cf ->
	printf "%s@ %s(%d,%d,%s)" !comma omega_color_factor_abbrev
	(succ c1) (succ c2) (format_powers_of nc_parameter cf);
	comma := ","
	done
	done;
	printf "@ /)"; nl ()
	end

	(* \begin{dubious}
	We can optimize the following slightly by reusing common color factor [parameter]s.
	\end{dubious} *)

	let print_color_factor_table table =
	let n_cflow = Array.length table in
	let n_cfactors = ref 0 in
	for c1 = 0 to pred n_cflow do
	for c2 = 0 to pred n_cflow do
	match table.(c1).(c2) with
	\| [] -> ()
	\| _ -> incr n_cfactors
	done
	done;
	print_integer_parameter "n_cfactors" !n_cfactors;
	printf " @[<2>type(%s), dimension(n_cfactors), save%s ::"
	omega_color_factor_abbrev protected;
	printf "@ table_color_factors"; nl ();
	let i = ref 1 in
	if n_cflow > 0 then begin
	for c1 = 0 to pred n_cflow do
	for c2 = 0 to pred n_cflow do
	match table.(c1).(c2) with
	\| [] -> ()
	\| cf ->
	printf " @[<2>real(kind=%s), parameter, private :: color_factor_%06d = %s"
	!kind !i (format_powers_of nc_parameter cf);
	nl ();
	printf " @[<2>data table_color_factors(%6d) / %s(%d,%d,color_factor_%06d) /"
	!i omega_color_factor_abbrev (succ c1) (succ c2) !i;
	incr i;
	nl ();
	done
	done
	end

	let print_color_tables amplitudes =
	let cflows = CF.color_flows amplitudes
	and cfactors = CF.color_factors amplitudes in
	(* [print_color_flows_table_old "c" cflows; nl ();] *)
	print_color_flows_table cflows; nl ();
	(* [print_ghost_flags_table_old "g" cflows; nl ();] *)
	print_ghost_flags_table cflows; nl ();
	(* [print_color_factor_table_old cfactors; nl ();] *)
	print_color_factor_table cfactors; nl ()

	let option_to_logical = function
	\| Some _ -> "T"
	\| None -> "F"

	let print_flavor_color_table_old abbrev n_flv n_cflow table =
	if n_flv <= 0 or n_cflow <= 0 then begin
	printf " @[<2>logical, dimension(n_flv, n_cflow) ::";
	printf "@ flv_col_is_allowed"; nl ()
	end else begin
	for c = 0 to pred n_cflow do
	printf
	" @[<2>logical, dimension(n_flv), parameter, private ::";
	printf "@ %s%04d = (/@ %s" abbrev (succ c) (option_to_logical table.(0).(c));
	for f = 1 to pred n_flv do
	printf ",@ %s" (option_to_logical table.(f).(c))
	done;
	printf "@ /)"; nl ()
	done;
	printf
	" @[<2>logical, dimension(n_flv, n_cflow), parameter ::";
	printf "@ flv_col_is_allowed_old =@ reshape ( (/@ %s%04d" abbrev 1;
	for c = 1 to pred n_cflow do
	printf ",@ %s%04d" abbrev (succ c)
	done;
	printf "@ /),@ (/ n_flv, n_cflow /) )"; nl ()
	end

	let print_flavor_color_table n_flv n_cflow table =
	printf
	" @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed"
	protected; nl ();
	if n_flv > 0 then begin
	for c = 0 to pred n_cflow do
	printf
	" @[<2>data flv_col_is_allowed(:,%4d) /" (succ c);
	printf "@ %s" (option_to_logical table.(0).(c));
	for f = 1 to pred n_flv do
	printf ",@ %s" (option_to_logical table.(f).(c))
	done;
	printf "@ /"; nl ()
	done;
	end

	let print_amplitude_table a =
	(* [print_flavor_color_table_old "a"
	(num_flavors a) (List.length (CF.color_flows a)) (CF.process_table a);
	nl ();] *)
	print_flavor_color_table
	(num_flavors a) (List.length (CF.color_flows a)) (CF.process_table a);
	nl ();
	printf
	" @[<2>complex(kind=%s), dimension(n_flv, n_cflow, n_hel), save :: amp" !kind;
	nl ();
	nl ()

	let print_helicity_selection_table () =
	printf " @[<2>logical, dimension(n_hel), save :: ";
	printf "hel_is_allowed = T"; nl();
	printf " @[<2>real(kind=%s), dimension(n_hel), save :: " !kind;
	printf "hel_max_abs = 0"; nl ();
	printf " @[<2>real(kind=%s), save :: " !kind;
	printf "hel_sum_abs = 0, ";
	printf "hel_threshold = 1E10"; nl ();
	printf " @[<2>integer, save :: ";
	printf "hel_count = 0, ";
	printf "hel_cutoff = 100"; nl ();
	printf " @[<2>integer :: ";
	printf "i"; nl ();
	printf " @[<2>integer, save, dimension(n_hel) :: ";
	printf "hel_map = (/(i, i = 1, n_hel)/)"; nl ();
	printf " @[<2>integer, save :: hel_finite = n_hel"; nl ();
	nl ()

	(* \thocwmodulesubsection{Optional MD5 sum function} *)

	let print_md5sum_functions = function
	\| Some s ->
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function md5sum ()"; nl ();
	printf " character(len=32) :: md5sum"; nl ();
	printf " ! DON'T EVEN THINK of modifying the following line!"; nl ();
	printf " md5sum = \"%s\"" s; nl ();
	printf " end function md5sum"; nl ();
	nl ()
	\| None -> ()

	(* \thocwmodulesubsection{Maintenance \&\ Inquiry Functions} *)

	let print_maintenance_functions amplitudes =
	if !whizard then begin
	printf " subroutine init (par)"; nl ();
	printf " real(kind=%s), dimension(*), intent(in) :: par" !kind; nl ();
	printf " call import_from_whizard (par)"; nl ();
	printf " end subroutine init"; nl ();
	nl ();
	printf " subroutine final ()"; nl ();
	printf " end subroutine final"; nl ();
	nl ();
	printf " subroutine update_alpha_s (alpha_s)"; nl ();
	printf " real(kind=%s), intent(in) :: alpha_s" !kind; nl ();
	printf " call model_update_alpha_s (alpha_s)"; nl ();
	printf " end subroutine update_alpha_s"; nl ();
	nl ()
	end

	let print_inquiry_function_openmp () = begin
	printf " pure function openmp_supported () result (status)"; nl ();
	printf " logical :: status"; nl ();
	printf " status = %s" (if !openmp then ".true." else ".false."); nl ();
	printf " end function openmp_supported"; nl ();
	nl ()
	end

	let print_inquiry_function_declarations name =
	printf " @[<2>public :: number_%s,@ %s" name name;
	nl ()

	let print_numeric_inquiry_functions () =
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function number_particles_in () result (n)"; nl ();
	printf " integer :: n"; nl ();
	printf " n = n_in"; nl ();
	printf " end function number_particles_in"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function number_particles_out () result (n)"; nl ();
	printf " integer :: n"; nl ();
	printf " n = n_out"; nl ();
	printf " end function number_particles_out"; nl ();
	nl ()

	let print_numeric_inquiry_functions (f, v) =
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function %s () result (n)" f; nl ();
	printf " integer :: n"; nl ();
	printf " n = %s" v; nl ();
	printf " end function %s" f; nl ();
	nl ()

	let print_inquiry_functions name =
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function number_%s () result (n)" name; nl ();
	printf " integer :: n"; nl ();
	printf " n = size (table_%s, dim=2)" name; nl ();
	printf " end function number_%s" name; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "subroutine %s (a)" name; nl ();
	printf " integer, dimension(:,:), intent(out) :: a"; nl ();
	printf " a = table_%s" name; nl ();
	printf " end subroutine %s" name; nl ();
	nl ()

	let print_color_flows () =
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function number_color_indices () result (n)"; nl ();
	printf " integer :: n"; nl ();
	printf " n = size (table_color_flows, dim=1)"; nl ();
	printf " end function number_color_indices"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function number_color_flows () result (n)"; nl ();
	printf " integer :: n"; nl ();
	printf " n = size (table_color_flows, dim=3)"; nl ();
	printf " end function number_color_flows"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "subroutine color_flows (a, g)"; nl ();
	printf " integer, dimension(:,:,:), intent(out) :: a"; nl ();
	printf " logical, dimension(:,:), intent(out) :: g"; nl ();
	printf " a = table_color_flows"; nl ();
	printf " g = table_ghost_flags"; nl ();
	printf " end subroutine color_flows"; nl ();
	nl ()

	let print_color_factors () =
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function number_color_factors () result (n)"; nl ();
	printf " integer :: n"; nl ();
	printf " n = size (table_color_factors)"; nl ();
	printf " end function number_color_factors"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "subroutine color_factors (cf)"; nl ();
	printf " type(%s), dimension(:), intent(out) :: cf"
	omega_color_factor_abbrev; nl ();
	printf " cf = table_color_factors"; nl ();
	printf " end subroutine color_factors"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function color_sum (flv, hel) result (amp2)"; nl ();
	printf " integer, intent(in) :: flv, hel"; nl ();
	printf " real(kind=%s) :: amp2" !kind; nl ();
	printf " amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))"; nl ();
	printf " end function color_sum"; nl ();
	nl ()

	let print_dispatch_functions () =
	printf " @[<5>";
	printf "subroutine new_event (p)"; nl ();
	printf " real(kind=%s), dimension(0:3,*), intent(in) :: p" !kind; nl ();
	printf " logical :: mask_dirty"; nl ();
	printf " integer :: hel"; nl ();
	printf " call calculate_amplitudes (amp, p, hel_is_allowed)"; nl ();
	printf " if ((hel_threshold .gt. 0) .and. (hel_count .le. hel_cutoff)) then"; nl ();
	printf " call @[<3>omega_update_helicity_selection@ (hel_count,@ amp,@ ";
	printf "hel_max_abs,@ hel_sum_abs,@ hel_is_allowed,@ hel_threshold,@ hel_cutoff,@ mask_dirty)"; nl ();
	printf " if (mask_dirty) then"; nl ();
	printf " hel_finite = 0"; nl ();
	printf " do hel = 1, n_hel"; nl ();
	printf " if (hel_is_allowed(hel)) then"; nl ();
	printf " hel_finite = hel_finite + 1"; nl ();
	printf " hel_map(hel_finite) = hel"; nl ();
	printf " end if"; nl ();
	printf " end do"; nl ();
	printf " end if"; nl ();
	printf " end if"; nl();
	printf " end subroutine new_event"; nl ();
	nl ();
	printf " @[<5>";
	printf "subroutine reset_helicity_selection (threshold, cutoff)"; nl ();
	printf " real(kind=%s), intent(in) :: threshold" !kind; nl ();
	printf " integer, intent(in) :: cutoff"; nl ();
	printf " integer :: i"; nl ();
	printf " hel_is_allowed = T"; nl ();
	printf " hel_max_abs = 0"; nl ();
	printf " hel_sum_abs = 0"; nl ();
	printf " hel_count = 0"; nl ();
	printf " hel_threshold = threshold"; nl ();
	printf " hel_cutoff = cutoff"; nl ();
	printf " hel_map = (/(i, i = 1, n_hel)/)"; nl ();
	printf " hel_finite = n_hel"; nl ();
	printf " end subroutine reset_helicity_selection"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function is_allowed (flv, hel, col) result (yorn)"; nl ();
	printf " logical :: yorn"; nl ();
	printf " integer, intent(in) :: flv, hel, col"; nl ();
	printf " yorn = hel_is_allowed(hel) .and. ";
	printf "flv_col_is_allowed(flv,col)"; nl ();
	printf " end function is_allowed"; nl ();
	nl ();
	printf " @[<5>"; if !fortran95 then printf "pure ";
	printf "function get_amplitude (flv, hel, col) result (amp_result)"; nl ();
	printf " complex(kind=%s) :: amp_result" !kind; nl ();
	printf " integer, intent(in) :: flv, hel, col"; nl ();
	printf " amp_result = amp(flv, col, hel)"; nl ();
	printf " end function get_amplitude"; nl ();
	nl ()

	(* \thocwmodulesubsection{Main Function} *)

	let format_power_of_nc
	{ Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } =
	match num, den, pwr with
	\| _, 0, _ -> invalid_arg "format_power_of_nc: zero denominator"
	\| 0, _, _ -> ""
	\| 1, 1, 0 \| -1, -1, 0 -> "+ 1"
	\| -1, 1, 0 \| 1, -1, 0 -> "- 1"
	\| 1, 1, 1 \| -1, -1, 1 -> "+ N"
	\| -1, 1, 1 \| 1, -1, 1 -> "- N"
	\| 1, 1, -1 \| -1, -1, -1 -> "+ 1/N"
	\| -1, 1, -1 \| 1, -1, -1 -> "- 1/N"
	\| 1, 1, p \| -1, -1, p ->
	"+ " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p)
	\| -1, 1, p \| 1, -1, p ->
	"- " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p)
	\| n, 1, 0 ->
	(if n < 0 then "- " else "+ ") ^ string_of_int (abs n)
	\| n, d, 0 ->
	(if n * d < 0 then "- " else "+ ") ^
	string_of_int (abs n) ^ "/" ^ string_of_int (abs d)
	\| n, 1, 1 ->
	(if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "N"
	\| n, 1, -1 ->
	(if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/N"
	\| n, d, 1 ->
	(if n * d < 0 then "- " else "+ ") ^
	string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "N"
	\| n, d, -1 ->
	(if n * d < 0 then "- " else "+ ") ^
	string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "/N"
	\| n, 1, p ->
	(if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^
	(if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p)
	\| n, d, p ->
	(if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^
	string_of_int (abs d) ^ (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p)

	let format_powers_of_nc = function
	\| [] -> "0"
	\| powers -> String.concat " " (List.map format_power_of_nc powers)

	let print_description cmdline amplitudes () =
	printf "! File generated automatically by O'Mega"; nl();
	printf "!"; nl();
	printf "! %s" cmdline; nl();
	printf "!"; nl();
	printf "! with all scattering amplitudes for the process(es)"; nl ();
	printf "!"; nl ();
	printf "! flavor combinations:"; nl ();
	printf "!"; nl ();
	ThoList.iteri
	(fun i process ->
	printf "! %3d: %s" i (process_sans_color_to_string process); nl ())
	1 (CF.flavors amplitudes);
	printf "!"; nl ();
	printf "! color flows:"; nl ();
	printf "!"; nl ();
	ThoList.iteri
	(fun i cflow ->
	printf "! %3d: %s" i (cflow_to_string cflow); nl ())
	1 (CF.color_flows amplitudes);
	printf "!"; nl ();
	printf "! NB: i.g. not all color flows contribute to all flavor"; nl ();
	printf "! combinations. Consult the array FLV_COL_IS_ALLOWED"; nl ();
	printf "! below for the allowed combinations."; nl ();
	printf "!"; nl ();
	printf "! Color Factors:"; nl ();
	printf "!"; nl ();
	let cfactors = CF.color_factors amplitudes in
	for c1 = 0 to pred (Array.length cfactors) do
	for c2 = 0 to c1 do
	match cfactors.(c1).(c2) with
	\| [] -> ()
	\| cfactor ->
	printf "! (%3d,%3d): %s"
	(succ c1) (succ c2) (format_powers_of_nc cfactor); nl ()
	done
	done;
	printf "!"; nl ();
	printf "! vanishing or redundant flavor combinations:"; nl ();
	printf "!"; nl ();
	List.iter (fun process ->
	printf "! %s" (process_sans_color_to_string process); nl ())
	(CF.vanishing_flavors amplitudes);
	printf "!"; nl ();
	begin
	match CF.constraints amplitudes with
	\| None -> ()
	\| Some s ->
	printf
	"! diagram selection (MIGHT BREAK GAUGE INVARIANCE!!!):"; nl ();
	printf "!"; nl ();
	printf "! %s" s; nl ();
	printf "!"; nl ()
	end;
	begin match RCS.description M.rcs with
	\| line1 :: lines ->
	printf "! in %s" line1; nl ();
	List.iter (fun s -> printf "! %s" s; nl ()) lines
	\| [] -> printf "! in %s" (RCS.name M.rcs); nl ()
	end;
	printf "!"; nl ()

	let print_version () =
	printf "! O'Mega revision control information:"; nl ();
	List.iter (fun s -> printf "! %s" s; nl ())
	(ThoList.flatmap RCS.summary (M.rcs :: rcs_list @ F.rcs_list))

	(* \thocwmodulesubsection{Printing Modules} *)

	type accessibility =
	\| Public
	\| Private
	\| Protected (* Fortran 2003 *)

	let accessibility_to_string = function
	\| Public -> "public"
	\| Private -> "private"
	\| Protected -> "protected"

	type used_symbol =
	\| As_Is of string
	\| Aliased of string * string

	let print_used_symbol = function
	\| As_Is name -> printf "%s" name
	\| Aliased (orig, alias) -> printf "%s => %s" alias orig

	type used_module =
	\| Full of string
	\| Full_Aliased of string * (string * string) list
	\| Subset of string * used_symbol list

	let print_used_module = function
	\| Full name
	\| Full_Aliased (name, [])
	\| Subset (name, []) ->
	printf " use %s" name;
	nl ()
	\| Full_Aliased (name, aliases) ->
	printf " @[<5>use %s" name;
	List.iter
	(fun (orig, alias) -> printf ", %s => %s" alias orig)
	aliases;
	nl ()
	\| Subset (name, used_symbol :: used_symbols) ->
	printf " @[<5>use %s, only: " name;
	print_used_symbol used_symbol;
	List.iter (fun s -> printf ", "; print_used_symbol s) used_symbols;
	nl ()

	type fortran_module =
	{ module_name : string;
	default_accessibility : accessibility;
	used_modules : used_module list;
	public_symbols : string list;
	print_declarations : (unit -> unit) list;
	print_implementations : (unit -> unit) list }

	let print_public = function
	\| name1 :: names ->
	printf " @[<2>public :: %s" name1;
	List.iter (fun n -> printf ",@ %s" n) names; nl ()
	\| [] -> ()

	let print_public_interface generic procedures =
	printf " public :: %s" generic; nl ();
	begin match procedures with
	\| name1 :: names ->
	printf " interface %s" generic; nl ();
	printf " @[<2>module procedure %s" name1;
	List.iter (fun n -> printf ",@ %s" n) names; nl ();
	printf " end interface"; nl ();
	print_public procedures
	\| [] -> ()
	end

	let print_module m =
	printf "module %s" m.module_name; nl ();
	List.iter print_used_module m.used_modules;
	printf " implicit none"; nl ();
	printf " %s" (accessibility_to_string m.default_accessibility); nl ();
	print_public m.public_symbols; nl ();
	begin match m.print_declarations with
	\| [] -> ()
	\| print_declarations ->
	List.iter (fun f -> f ()) print_declarations; nl ()
	end;
	begin match m.print_implementations with
	\| [] -> ()
	\| print_implementations ->
	printf "contains"; nl (); nl ();
	List.iter (fun f -> f ()) print_implementations; nl ();
	end;
	printf "end module %s" m.module_name; nl ()

	let print_modules modules =
	List.iter print_module modules;
	print_version ();
	print_flush ()

	let module_to_file line_length oc prelude m =
	output_string oc (m.module_name ^ "\n");
	let filename = m.module_name ^ ".f90" in
	let channel = open_out filename in
	setup_fortran_formatter line_length channel;
	prelude ();
	print_modules [m];
	close_out channel

	let modules_to_file line_length oc prelude = function
	\| [] -> ()
	\| m :: mlist ->
	module_to_file line_length oc prelude m;
	List.iter (module_to_file line_length oc (fun () -> ())) mlist

	(* \thocwmodulesubsection{Chopping Up Amplitudes} *)

	let num_fusions_brakets size amplitudes =
	let num_fusions =
	max 1 size in
	let count_brakets =
	List.fold_left
	(fun sum process -> sum + List.length (F.brakets process))
	0 (CF.processes amplitudes)
	and count_processes =
	List.length (CF.processes amplitudes) in
	if count_brakets > 0 then
	let num_brakets =
	max 1 ((num_fusions * count_processes) / count_brakets) in
	(num_fusions, num_brakets)
	else
	(num_fusions, 1)

	let chop_amplitudes size amplitudes =
	let num_fusions, num_brakets = num_fusions_brakets size amplitudes in
	(ThoList.enumerate 1 (ThoList.chopn num_fusions (CF.fusions amplitudes)),
	ThoList.enumerate 1 (ThoList.chopn num_brakets (CF.processes amplitudes)))

	let print_compute_fusions1 dictionary (n, fusions) =
	if !openmp then begin
	printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl ();
	printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
	end else begin
	printf " @[<5>subroutine compute_fusions_%04d ()" n; nl ();
	end;
	print_fusions dictionary fusions;
	printf " end subroutine compute_fusions_%04d" n; nl ()

	and print_compute_brakets1 dictionary (n, processes) =
	if !openmp then begin
	printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl ();
	printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
	end else begin
	printf " @[<5>subroutine compute_brakets_%04d ()" n; nl ();
	end;
	List.iter (print_brakets dictionary) processes;
	printf " end subroutine compute_brakets_%04d" n; nl ()

	(* \thocwmodulesubsection{Common Stuff} *)

	let omega_public_symbols =
	["number_particles_in"; "number_particles_out";
	"number_color_indices";
	"reset_helicity_selection"; "new_event";
	"is_allowed"; "get_amplitude"; "color_sum"; "openmp_supported"] @
	ThoList.flatmap
	(fun n -> ["number_" ^ n; n])
	["spin_states"; "flavor_states"; "color_flows"; "color_factors"]

	let whizard_public_symbols md5sum =
	["init"; "final"; "update_alpha_s"] @
	(match md5sum with Some _ -> ["md5sum"] \| None -> [])

	let used_modules () =
	[Full "kinds";
	Full Fermions.use_module;
	Full_Aliased ("omega_color", ["omega_color_factor", omega_color_factor_abbrev])] @
	List.map
	(fun m -> Full m)
	(match !parameter_module with "" -> !use_modules \| pm -> pm :: !use_modules)

	let public_symbols () =
	if !whizard then
	omega_public_symbols @ (whizard_public_symbols !md5sum)
	else
	omega_public_symbols

	let print_constants amplitudes =

	printf " ! DON'T EVEN THINK of removing the following!"; nl ();
	printf " ! If the compiler complains about undeclared"; nl ();
	printf " ! or undefined variables, you are compiling"; nl ();
	printf " ! against an incompatible omega95 module!"; nl ();
	printf " @[<2>integer, dimension(%d), parameter, private :: "
	(List.length require_library);
	printf "require =@ (/ @[";
	print_list require_library;
	printf " /)"; nl(); nl ();

	(* Using these parameters makes sense for documentation, but in
	practice, there is no need to ever change them. *)
	List.iter
	(function name, value -> print_integer_parameter name (value amplitudes))
	[ ("n_prt", num_particles);
	("n_in", num_particles_in);
	("n_out", num_particles_out);
	("n_cflow", num_color_flows); (* Number of different color amplitudes. *)
	("n_cindex", num_color_indices); (* Maximum rank of color tensors. *)
	("n_flv", num_flavors); (* Number of different flavor amplitudes. *)
	("n_hel", num_helicities) (* Number of different helicty amplitudes. *) ];
	nl ();

	(* Abbreviations. *)
	printf " ! NB: you MUST NOT change the value of %s here!!!" nc_parameter; nl();
	printf " ! It is defined here for convenience only and must be"; nl ();
	printf " ! compatible with hardcoded values in the amplitude!"; nl ();
	print_real_parameter nc_parameter (CM.nc ()); (* $N_C$ *)
	List.iter
	(function name, value -> print_logical_parameter name value)
	[ ("F", false); ("T", true) ]; nl ();

	print_spin_tables amplitudes;
	print_flavor_tables amplitudes;
	print_color_tables amplitudes;
	print_amplitude_table amplitudes;
	print_helicity_selection_table ()

	let print_interface amplitudes =
	print_md5sum_functions !md5sum;
	print_maintenance_functions amplitudes;
	List.iter print_numeric_inquiry_functions
	[("number_particles_in", "n_in");
	("number_particles_out", "n_out")];
	List.iter print_inquiry_functions
	["spin_states"; "flavor_states"];
	print_inquiry_function_openmp ();
	print_color_flows ();
	print_color_factors ();
	print_dispatch_functions ();
	nl();
	current_continuation_line := 0;
	if !km_write \|\| !km_pure then (Targets_Kmatrix.Fortran.print !km_pure);
	current_continuation_line := 1;
	nl()

	let print_calculate_amplitudes declarations computations amplitudes =
	printf " @[<5>subroutine calculate_amplitudes (amp, k, mask)"; nl ();
	printf " complex(kind=%s), dimension(:,:,:), intent(out) :: amp" !kind; nl ();
	printf " real(kind=%s), dimension(0:3,*), intent(in) :: k" !kind; nl ();
	printf " logical, dimension(:), intent(in) :: mask"; nl ();
	printf " integer, dimension(n_prt) :: s"; nl ();
	printf " integer :: h, hi"; nl ();
	declarations ();
	begin match CF.processes amplitudes with
	\| p :: _ -> print_external_momenta p
	\| _ -> ()
	end;
	ignore (List.fold_left print_momenta PSet.empty (CF.processes amplitudes));
	printf " amp = 0"; nl ();
	if num_helicities amplitudes > 0 then begin
	printf " if (hel_finite == 0) return"; nl ();
	if !openmp then begin
	printf "!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(s, h, %s) SCHEDULE(STATIC)" openmp_tld; nl();
	end;
	printf " do hi = 1, hel_finite"; nl ();
	printf " h = hel_map(hi)"; nl ();
	printf " s = table_spin_states(:,h)"; nl ();
	ignore (List.fold_left print_externals WFSet.empty (CF.processes amplitudes));
	computations ();
	List.iter print_fudge_factor (CF.processes amplitudes);
	(* This sorting should slightly improve cache locality. *)
	let triple_snd = fun (_, x, _) -> x
	in let triple_fst = fun (x, _, _) -> x
	in let rec builder1 flvi flowi flows = match flows with
	\| (Some a) :: tl -> (flvi, flowi, flavors_symbol (flavors a)) :: (builder1 flvi (flowi + 1) tl)
	\| None :: tl -> builder1 flvi (flowi + 1) tl
	\| [] -> []
	in let rec builder2 flvi flvs = match flvs with
	\| flv :: tl -> (builder1 flvi 1 flv) @ (builder2 (flvi + 1) tl)
	\| [] -> []
	in let unsorted = builder2 1 (List.map Array.to_list (Array.to_list (CF.process_table amplitudes)))
	in let sorted = List.sort (fun a b ->
	if (triple_snd a != triple_snd b) then triple_snd a - triple_snd b else (triple_fst a - triple_fst b))
	unsorted
	in List.iter (fun (flvi, flowi, flv) ->
	(printf " amp(%d,%d,h) = %s" flvi flowi flv; nl ();)) sorted;

	(*i printf " else"; nl ();
	printf " amp(:,h,:) = 0"; nl (); i*)
	printf " end do"; nl ();
	if !openmp then begin
	printf "!$OMP END PARALLEL DO"; nl ();
	end;
	end;
	printf " end subroutine calculate_amplitudes"; nl ()

	let print_compute_chops chopped_fusions chopped_brakets () =
	List.iter
	(fun (i, _) -> printf " call compute_fusions_%04d (%s)" i
	(if !openmp then openmp_tld else ""); nl ())
	chopped_fusions;
	List.iter
	(fun (i, _) -> printf " call compute_brakets_%04d (%s)" i
	(if !openmp then openmp_tld else ""); nl ())
	chopped_brakets

	(* \thocwmodulesubsection{Single Function} *)

	let amplitudes_to_channel_single_function cmdline oc amplitudes =

	let print_declarations () =
	print_constants amplitudes

	and print_implementations () =
	print_interface amplitudes;
	print_calculate_amplitudes
	(fun () -> print_variable_declarations amplitudes)
	(fun () ->
	print_fusions (CF.dictionary amplitudes) (CF.fusions amplitudes);
	List.iter
	(print_brakets (CF.dictionary amplitudes))
	(CF.processes amplitudes))
	amplitudes in

	let fortran_module =
	{ module_name = !module_name;
	used_modules = used_modules ();
	default_accessibility = Private;
	public_symbols = public_symbols ();
	print_declarations = [print_declarations];
	print_implementations = [print_implementations] } in

	setup_fortran_formatter !line_length oc;
	print_description cmdline amplitudes ();
	print_modules [fortran_module]

	(* \thocwmodulesubsection{Single Module} *)

	let amplitudes_to_channel_single_module cmdline oc size amplitudes =

	let print_declarations () =
	print_constants amplitudes;
	print_variable_declarations amplitudes

	and print_implementations () =
	print_interface amplitudes in

	let chopped_fusions, chopped_brakets =
	chop_amplitudes size amplitudes in

	let dictionary = CF.dictionary amplitudes in

	let print_compute_amplitudes () =
	print_calculate_amplitudes
	(fun () -> ())
	(print_compute_chops chopped_fusions chopped_brakets)
	amplitudes

	and print_compute_fusions () =
	List.iter (print_compute_fusions1 dictionary) chopped_fusions

	and print_compute_brakets () =
	List.iter (print_compute_brakets1 dictionary) chopped_brakets in

	let fortran_module =
	{ module_name = !module_name;
	used_modules = used_modules ();
	default_accessibility = Private;
	public_symbols = public_symbols ();
	print_declarations = [print_declarations];
	print_implementations = [print_implementations;
	print_compute_amplitudes;
	print_compute_fusions;
	print_compute_brakets] } in

	setup_fortran_formatter !line_length oc;
	print_description cmdline amplitudes ();
	print_modules [fortran_module]

	(* \thocwmodulesubsection{Multiple Modules} *)

	let modules_of_amplitudes cmdline oc size amplitudes =

	let name = !module_name in

	let print_declarations () =
	print_constants amplitudes
	and print_variables () =
	print_variable_declarations amplitudes in

	let constants_module =
	{ module_name = name ^ "_constants";
	used_modules = used_modules ();
	default_accessibility = Public;
	public_symbols = [];
	print_declarations = [print_declarations];
	print_implementations = [] } in

	let variables_module =
	{ module_name = name ^ "_variables";
	used_modules = used_modules ();
	default_accessibility = Public;
	public_symbols = [];
	print_declarations = [print_variables];
	print_implementations = [] } in

	let dictionary = CF.dictionary amplitudes in

	let print_compute_fusions (n, fusions) () =
	if !openmp then begin
	printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl ();
	printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
	end else begin
	printf " @[<5>subroutine compute_fusions_%04d ()" n; nl ();
	end;
	print_fusions dictionary fusions;
	printf " end subroutine compute_fusions_%04d" n; nl () in

	let print_compute_brakets (n, processes) () =
	if !openmp then begin
	printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl ();
	printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
	end else begin
	printf " @[<5>subroutine compute_brakets_%04d ()" n; nl ();
	end;
	List.iter (print_brakets dictionary) processes;
	printf " end subroutine compute_brakets_%04d" n; nl () in

	let fusions_module (n, _ as fusions) =
	let tag = Printf.sprintf "_fusions_%04d" n in
	{ module_name = name ^ tag;
	used_modules = (used_modules () @
	[Full constants_module.module_name;
	Full variables_module.module_name]);
	default_accessibility = Private;
	public_symbols = ["compute" ^ tag];
	print_declarations = [];
	print_implementations = [print_compute_fusions fusions] } in

	let brakets_module (n, _ as processes) =
	let tag = Printf.sprintf "_brakets_%04d" n in
	{ module_name = name ^ tag;
	used_modules = (used_modules () @
	[Full constants_module.module_name;
	Full variables_module.module_name]);
	default_accessibility = Private;
	public_symbols = ["compute" ^ tag];
	print_declarations = [];
	print_implementations = [print_compute_brakets processes] } in

	let chopped_fusions, chopped_brakets =
	chop_amplitudes size amplitudes in

	let fusions_modules =
	List.map fusions_module chopped_fusions in

	let brakets_modules =
	List.map brakets_module chopped_brakets in

	let print_implementations () =
	print_interface amplitudes;
	print_calculate_amplitudes
	(fun () -> ())
	(print_compute_chops chopped_fusions chopped_brakets)
	amplitudes in

	let public_module =
	{ module_name = name;
	used_modules = (used_modules () @
	[Full constants_module.module_name;
	Full variables_module.module_name ] @
	List.map
	(fun m -> Full m.module_name)
	(fusions_modules @ brakets_modules));
	default_accessibility = Private;
	public_symbols = public_symbols ();
	print_declarations = [];
	print_implementations = [print_implementations] }
	and private_modules =
	[constants_module; variables_module] @ fusions_modules @ brakets_modules in

	(public_module, private_modules)

	let amplitudes_to_channel_single_file cmdline oc size amplitudes =
	let public_module, private_modules =
	modules_of_amplitudes cmdline oc size amplitudes in
	setup_fortran_formatter !line_length oc;
	print_description cmdline amplitudes ();
	print_modules (private_modules @ [public_module])

	let amplitudes_to_channel_multi_file cmdline oc size amplitudes =
	let public_module, private_modules =
	modules_of_amplitudes cmdline oc size amplitudes in
	modules_to_file !line_length oc
	(print_description cmdline amplitudes)
	(public_module :: private_modules)

	(* \thocwmodulesubsection{Dispatch} *)

	let amplitudes_to_channel cmdline oc diagnostics amplitudes =
	parse_diagnostics diagnostics;
	match !output_mode with
	\| Single_Function ->
	amplitudes_to_channel_single_function cmdline oc amplitudes
	\| Single_Module size ->
	amplitudes_to_channel_single_module cmdline oc size amplitudes
	\| Single_File size ->
	amplitudes_to_channel_single_file cmdline oc size amplitudes
	\| Multi_File size ->
	amplitudes_to_channel_multi_file cmdline oc size amplitudes

	let parameters_to_channel oc =
	parameters_to_fortran oc (CM.parameters ())

	end

	module Fortran = Make_Fortran(Fortran_Fermions)

	(* \thocwmodulesubsection{Majorana Fermions} *)

	(* \begin{JR}
	For this function we need a different approach due to our aim of
	implementing the fermion vertices with the right line as ingoing (in a
	calculational sense) and the left line in a fusion as outgoing. In
	defining all external lines and the fermionic wavefunctions built out of
	them as ingoing we have to invert the left lines to make them outgoing.
	This happens by multiplying them with the inverse charge conjugation
	matrix in an appropriate representation and then transposing it. We must
	distinguish whether the direction of calculation and the physical direction
	of the fermion number flow are parallel or antiparallel. In the first case
	we can use the "normal" Feynman rules for Dirac particles, while in the
	second, according to the paper of Denner et al., we have to reverse the
	sign of the vector and antisymmetric bilinears of the Dirac spinors, cf.
	the [Coupling] module.

	Note the subtlety for the left- and righthanded couplings: Only the vector
	part of these couplings changes in the appropriate cases its sign,
	changing the chirality to the negative of the opposite.
	\end{JR} *)

	module Fortran_Majorana_Fermions : Fermions =
	struct
	let rcs = RCS.rename rcs_file "Targets.Fortran_Majorana_Fermions()"
	[ "generates Fortran95 code for Dirac and Majorana fermions";
	" using revision 2003_03_A of module omega95_bispinors" ]

	open Coupling
	open Format

	let psi_type = "bispinor"
	let psibar_type = "bispinor"
	let chi_type = "bispinor"
	let grav_type = "vectorspinor"

	(* \begin{JR}
	Because of our rules for fermions we are going to give all incoming fermions
	a [u] spinor and all outgoing fermions a [v] spinor, no matter whether they
	are Dirac fermions, antifermions or Majorana fermions.
	\end{JR} *)

	let psi_incoming = "u"
	let brs_psi_incoming = "brs_u"
	let psibar_incoming = "u"
	let brs_psibar_incoming = "brs_u"
	let chi_incoming = "u"
	let brs_chi_incoming = "brs_u"
	let grav_incoming = "ueps"

	let psi_outgoing = "v"
	let brs_psi_outgoing = "brs_v"
	let psibar_outgoing = "v"
	let brs_psibar_outgoing = "brs_v"
	let chi_outgoing = "v"
	let brs_chi_outgoing = "brs_v"
	let grav_outgoing = "veps"

	let psi_propagator = "pr_psi"
	let psibar_propagator = "pr_psi"
	let chi_propagator = "pr_psi"
	let grav_propagator = "pr_grav"

	let psi_projector = "pj_psi"
	let psibar_projector = "pj_psi"
	let chi_projector = "pj_psi"
	let grav_projector = "pj_grav"

	let psi_gauss = "pg_psi"
	let psibar_gauss = "pg_psi"
	let chi_gauss = "pg_psi"
	let grav_gauss = "pg_grav"

	let format_coupling coeff c =
	match coeff with
	\| 1 -> c
	\| -1 -> "(-" ^ c ^")"
	\| coeff -> string_of_int coeff ^ "*" ^ c

	let format_coupling_2 coeff c =
	match coeff with
	\| 1 -> c
	\| -1 -> "-" ^ c
	\| coeff -> string_of_int coeff ^ "*" ^ c

	(* \begin{dubious}
	JR's coupling constant HACK, necessitated by tho's bad design descition.
	\end{dubious} *)

	let fastener s i =
	try
	let offset = (String.index s '(') in
	if ((String.get s (String.length s - 1)) != ')') then
	failwith "fastener: wrong usage of parentheses"
	else
	let func_name = (String.sub s 0 offset) and
	tail =
	(String.sub s (succ offset) (String.length s - offset - 2)) in
	if (String.contains func_name ')') or
	(String.contains tail '(') or
	(String.contains tail ')') then
	failwith "fastener: wrong usage of parentheses"
	else
	func_name ^ "(" ^ string_of_int i ^ "," ^ tail ^ ")"
	with
	\| Not_found ->
	if (String.contains s ')') then
	failwith "fastener: wrong usage of parentheses"
	else
	s ^ "(" ^ string_of_int i ^ ")"

	let print_fermion_current coeff f c wf1 wf2 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 \| F31 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
	\| F23 \| F21 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
	\| F32 \| F12 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1

	let print_fermion_current2 coeff f c wf1 wf2 fusion =
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 \| F31 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F23 \| F21 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F32 \| F12 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1

	let print_fermion_current_vector coeff f c wf1 wf2 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
	\| F31 -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2
	\| F23 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
	\| F12 -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1
	\| F21 -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2

	let print_fermion_current2_vector coeff f c wf1 wf2 fusion =
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F31 -> printf "%s_ff(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
	\| F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
	\| F12 -> printf "f_%sf(-(%s),%s,%s,%s)" f c1 c2 wf2 wf1
	\| F21 -> printf "f_%sf(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2

	let print_fermion_current_chiral coeff f1 f2 c wf1 wf2 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s)" f1 c wf1 wf2
	\| F31 -> printf "%s_ff(-%s,%s,%s)" f2 c wf1 wf2
	\| F23 -> printf "f_%sf(%s,%s,%s)" f1 c wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s)" f1 c wf2 wf1
	\| F12 -> printf "f_%sf(-%s,%s,%s)" f2 c wf2 wf1
	\| F21 -> printf "f_%sf(-%s,%s,%s)" f2 c wf1 wf2

	let print_fermion_current2_chiral coeff f c wf1 wf2 fusion =
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F31 -> printf "%s_ff(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
	\| F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
	\| F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
	\| F12 -> printf "f_%sf(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
	\| F21 -> printf "f_%sf(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2

	let print_current = function
	\| coeff, _, VA, _ -> print_fermion_current2_vector coeff "va"
	\| coeff, _, V, _ -> print_fermion_current_vector coeff "v"
	\| coeff, _, A, _ -> print_fermion_current coeff "a"
	\| coeff, _, VL, _ -> print_fermion_current_chiral coeff "vl" "vr"
	\| coeff, _, VR, _ -> print_fermion_current_chiral coeff "vr" "vl"
	\| coeff, _, VLR, _ -> print_fermion_current2_chiral coeff "vlr"
	\| coeff, _, SP, _ -> print_fermion_current2 coeff "sp"
	\| coeff, _, S, _ -> print_fermion_current coeff "s"
	\| coeff, _, P, _ -> print_fermion_current coeff "p"
	\| coeff, _, SL, _ -> print_fermion_current coeff "sl"
	\| coeff, _, SR, _ -> print_fermion_current coeff "sr"
	\| coeff, _, SLR, _ -> print_fermion_current2 coeff "slr"
	\| coeff, _, POT, _ -> print_fermion_current_vector coeff "pot"
	\| coeff, _, _, _ -> invalid_arg
	"Targets.Fortran_Majorana_Fermions: Not needed in the models"

	let print_current_p = function
	\| coeff, Psi, SL, Psi -> print_fermion_current coeff "sl"
	\| coeff, Psi, SR, Psi -> print_fermion_current coeff "sr"
	\| coeff, Psi, SLR, Psi -> print_fermion_current2 coeff "slr"
	\| coeff, _, _, _ -> invalid_arg
	"Targets.Fortran_Majorana_Fermions: Not needed in the used models"

	let print_current_b = function
	\| coeff, Psibar, SL, Psibar -> print_fermion_current coeff "sl"
	\| coeff, Psibar, SR, Psibar -> print_fermion_current coeff "sr"
	\| coeff, Psibar, SLR, Psibar -> print_fermion_current2 coeff "slr"
	\| coeff, _, _, _ -> invalid_arg
	"Targets.Fortran_Majorana_Fermions: Not needed in the used models"

	(* This function is for the vertices with three particles including two
	fermions but also a momentum, therefore with a dimensionful coupling
	constant, e.g. the gravitino vertices. One has to dinstinguish between
	the two kinds of canonical orders in the string of gamma matrices. Of
	course, the direction of the string of gamma matrices is reversed if one
	goes from the [Gravbar, _, Psi] to the [Psibar, _, Grav] vertices, and
	the same is true for the couplings of the gravitino to the Majorana
	fermions. For more details see the tables in the [coupling]
	implementation. *)

	(* We now have to fix the directions of the momenta. For making the compiler
	happy and because we don't want to make constructions of infinite
	complexity we list the momentum including vertices without gravitinos
	here; the pattern matching says that's better. Perhaps we have to find a
	better name now.

	For the cases of $MOM$, $MOM5$, $MOML$ and $MOMR$ which arise only in
	BRST transformations we take the mass as a coupling constant. For
	$VMOM$ we don't need a mass either. These vertices are like kinetic terms
	and so need not have a coupling constant. By this we avoid a strange and
	awful construction with a new variable. But be careful with a
	generalization if you want to use these vertices for other purposes.
	*)

	let format_coupling_mom coeff c =
	match coeff with
	\| 1 -> c
	\| -1 -> "(-" ^ c ^")"
	\| coeff -> string_of_int coeff ^ "*" ^ c

	let commute_proj f =
	match f with
	\| "moml" -> "lmom"
	\| "momr" -> "rmom"
	\| "lmom" -> "moml"
	\| "rmom" -> "momr"
	\| "svl" -> "svr"
	\| "svr" -> "svl"
	\| "sl" -> "sr"
	\| "sr" -> "sl"
	\| "s" -> "s"
	\| "p" -> "p"
	\| _ -> invalid_arg "Targets:Fortran_Majorana_Fermions: wrong case"

	let print_fermion_current_mom coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling_mom coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
	\| F31 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
	\| F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
	\| F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
	\| F12 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
	\| F21 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1

	let print_fermion_current_mom_vector coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling_mom coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
	\| F31 -> printf "%s_ff(-%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
	\| F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
	\| F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
	\| F12 -> printf "f_%sf(-%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
	\| F21 -> printf "f_%sf(-%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1

	let print_fermion_current_mom_sign coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling_mom coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
	\| F31 -> printf "%s_ff(%s,%s,%s,%s,-(%s))" f c1 c2 wf1 wf2 p12
	\| F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
	\| F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
	\| F12 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" f c1 c2 wf2 wf1 p2
	\| F21 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" f c1 c2 wf1 wf2 p1

	let print_fermion_current_mom_sign_1 coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s)" f c wf1 wf2 p12
	\| F31 -> printf "%s_ff(%s,%s,%s,-(%s))" f c wf1 wf2 p12
	\| F23 -> printf "f_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
	\| F32 -> printf "f_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
	\| F12 -> printf "f_%sf(%s,%s,%s,-(%s))" f c wf2 wf1 p2
	\| F21 -> printf "f_%sf(%s,%s,%s,-(%s))" f c wf1 wf2 p1

	let print_fermion_current_mom_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling_mom coeff c and
	cf = commute_proj f in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
	\| F31 -> printf "%s_ff(%s,%s,%s, %s,-(%s))" cf c1 c2 wf1 wf2 p12
	\| F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
	\| F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
	\| F12 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" cf c1 c2 wf2 wf1 p2
	\| F21 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" cf c1 c2 wf1 wf2 p1

	let print_fermion_g_current coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_grf(%s,%s,%s,%s)" f c wf1 wf2 p12
	\| F31 -> printf "%s_fgr(%s,%s,%s,%s)" f c wf1 wf2 p12
	\| F23 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
	\| F32 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
	\| F12 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf2 wf1 p2
	\| F21 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf1 wf2 p1

	let print_fermion_g_2_current coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_grf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
	\| F31 -> printf "%s_fgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
	\| F23 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
	\| F32 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
	\| F12 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
	\| F21 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1

	let print_fermion_g_current_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_fgr(%s,%s,%s,%s)" f c wf1 wf2 p12
	\| F31 -> printf "%s_grf(%s,%s,%s,%s)" f c wf1 wf2 p12
	\| F23 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf1 wf2 p1
	\| F32 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf2 wf1 p2
	\| F12 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
	\| F21 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1

	let print_fermion_g_2_current_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_fgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
	\| F31 -> printf "%s_grf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
	\| F23 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
	\| F32 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
	\| F12 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
	\| F21 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1

	let print_fermion_g_current_vector coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_grf(%s,%s,%s)" f c wf1 wf2
	\| F31 -> printf "%s_fgr(-%s,%s,%s)" f c wf1 wf2
	\| F23 -> printf "gr_%sf(%s,%s,%s)" f c wf1 wf2
	\| F32 -> printf "gr_%sf(%s,%s,%s)" f c wf2 wf1
	\| F12 -> printf "f_%sgr(-%s,%s,%s)" f c wf2 wf1
	\| F21 -> printf "f_%sgr(-%s,%s,%s)" f c wf1 wf2

	let print_fermion_g_current_vector_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
	let c = format_coupling coeff c in
	match fusion with
	\| F13 -> printf "%s_fgr(%s,%s,%s)" f c wf1 wf2
	\| F31 -> printf "%s_grf(-%s,%s,%s)" f c wf1 wf2
	\| F23 -> printf "f_%sgr(%s,%s,%s)" f c wf1 wf2
	\| F32 -> printf "f_%sgr(%s,%s,%s)" f c wf2 wf1
	\| F12 -> printf "gr_%sf(-%s,%s,%s)" f c wf2 wf1
	\| F21 -> printf "gr_%sf(-%s,%s,%s)" f c wf1 wf2

	let print_current_g = function
	\| coeff, _, MOM, _ -> print_fermion_current_mom_sign coeff "mom"
	\| coeff, _, MOM5, _ -> print_fermion_current_mom coeff "mom5"
	\| coeff, _, MOML, _ -> print_fermion_current_mom_chiral coeff "moml"
	\| coeff, _, MOMR, _ -> print_fermion_current_mom_chiral coeff "momr"
	\| coeff, _, LMOM, _ -> print_fermion_current_mom_chiral coeff "lmom"
	\| coeff, _, RMOM, _ -> print_fermion_current_mom_chiral coeff "rmom"
	\| coeff, _, VMOM, _ -> print_fermion_current_mom_sign_1 coeff "vmom"
	\| coeff, Gravbar, S, _ -> print_fermion_g_current coeff "s"
	\| coeff, Gravbar, SL, _ -> print_fermion_g_current coeff "sl"
	\| coeff, Gravbar, SR, _ -> print_fermion_g_current coeff "sr"
	\| coeff, Gravbar, SLR, _ -> print_fermion_g_2_current coeff "slr"
	\| coeff, Gravbar, P, _ -> print_fermion_g_current coeff "p"
	\| coeff, Gravbar, V, _ -> print_fermion_g_current coeff "v"
	\| coeff, Gravbar, VLR, _ -> print_fermion_g_2_current coeff "vlr"
	\| coeff, Gravbar, POT, _ -> print_fermion_g_current_vector coeff "pot"
	\| coeff, _, S, Grav -> print_fermion_g_current_rev coeff "s"
	\| coeff, _, SL, Grav -> print_fermion_g_current_rev coeff "sl"
	\| coeff, _, SR, Grav -> print_fermion_g_current_rev coeff "sr"
	\| coeff, _, SLR, Grav -> print_fermion_g_2_current_rev coeff "slr"
	\| coeff, _, P, Grav -> print_fermion_g_current_rev (-coeff) "p"
	\| coeff, _, V, Grav -> print_fermion_g_current_rev coeff "v"
	\| coeff, _, VLR, Grav -> print_fermion_g_2_current_rev coeff "vlr"
	\| coeff, _, POT, Grav -> print_fermion_g_current_vector_rev coeff "pot"
	\| coeff, _, _, _ -> invalid_arg
	"Targets.Fortran_Majorana_Fermions: not used in the models"

	let print_current_mom = function
	\| coeff, _, _, _ -> invalid_arg
	"Targets.Fortran_Majorana_Fermions: Not needed in the models"

	(* We need support for dimension-5 vertices with two fermions and two
	bosons, appearing in theories of supergravity and also together with in
	insertions of the supersymmetric current. There is a canonical order
	[fermionbar], [boson_1], [boson_2], [fermion], so what one has to do is a
	mapping from the fusions [F123] etc. to the order of the three wave
	functions [wf1], [wf2] and [wf3]. *)

	(* The function [d_p] (for distinct the particle) distinguishes which particle
	(scalar or vector) must be fused to in the special functions. *)

	let d_p = function
	\| 1, ("sv"\|"pv"\|"svl"\|"svr"\|"slrv") -> "1"
	\| 1, _ -> ""
	\| 2, ("sv"\|"pv"\|"svl"\|"svr"\|"slrv") -> "2"
	\| 2, _ -> ""
	\| _, _ -> invalid_arg "Targets.Fortran_Majorana_Fermions: not used"

	let wf_of_f wf1 wf2 wf3 f =
	match f with
	\| (F123\|F423) -> [wf2; wf3; wf1]
	\| (F213\|F243\|F143\|F142\|F413\|F412) -> [wf1; wf3; wf2]
	\| (F132\|F432) -> [wf3; wf2; wf1]
	\| (F231\|F234\|F134\|F124\|F431\|F421) -> [wf1; wf2; wf3]
	\| (F312\|F342) -> [wf3; wf1; wf2]
	\| (F321\|F324\|F314\|F214\|F341\|F241) -> [wf2; wf1; wf3]

	let print_fermion_g4_brs_vector_current coeff f c wf1 wf2 wf3 fusion =
	let cf = commute_proj f and
	cp = format_coupling coeff c and
	cm = if f = "pv" then
	format_coupling coeff c
	else
	format_coupling (-coeff) c
	and
	d1 = d_p (1,f) and
	d2 = d_p (2,f) and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sf(%s,%s,%s,%s)" cf cm f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "f_%sf(%s,%s,%s,%s)" f cp f1 f2 f3
	\| (F134\|F143\|F314) -> printf "%s%s_ff(%s,%s,%s,%s)" f d1 cp f1 f2 f3
	\| (F124\|F142\|F214) -> printf "%s%s_ff(%s,%s,%s,%s)" f d2 cp f1 f2 f3
	\| (F413\|F431\|F341) -> printf "%s%s_ff(%s,%s,%s,%s)" cf d1 cm f1 f2 f3
	\| (F241\|F412\|F421) -> printf "%s%s_ff(%s,%s,%s,%s)" cf d2 cm f1 f2 f3

	let print_fermion_g4_svlr_current coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling_2 coeff c and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_svlrf(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "f_svlrf(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
	\| (F134\|F143\|F314) ->
	printf "svlr2_ff(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
	\| (F124\|F142\|F214) ->
	printf "svlr1_ff(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
	\| (F413\|F431\|F341) ->
	printf "svlr2_ff(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
	\| (F241\|F412\|F421) ->
	printf "svlr1_ff(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3

	let print_fermion_s2_current coeff f c wf1 wf2 wf3 fusion =
	let cp = format_coupling coeff c and
	cm = if f = "p" then
	format_coupling (-coeff) c
	else
	format_coupling coeff c
	and
	cf = commute_proj f and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "%s * f_%sf(%s,%s,%s)" f1 cf cm f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "%s * f_%sf(%s,%s,%s)" f1 f cp f2 f3
	\| (F134\|F143\|F314) ->
	printf "%s * %s_ff(%s,%s,%s)" f2 f cp f1 f3
	\| (F124\|F142\|F214) ->
	printf "%s * %s_ff(%s,%s,%s)" f2 f cp f1 f3
	\| (F413\|F431\|F341) ->
	printf "%s * %s_ff(%s,%s,%s)" f2 cf cm f1 f3
	\| (F241\|F412\|F421) ->
	printf "%s * %s_ff(%s,%s,%s)" f2 cf cm f1 f3

	let print_fermion_s2p_current coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling_2 coeff c and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "%s * f_%sf(%s,-(%s),%s,%s)" f1 f c1 c2 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c1 c2 f2 f3
	\| (F134\|F143\|F314) ->
	printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
	\| (F124\|F142\|F214) ->
	printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
	\| (F413\|F431\|F341) ->
	printf "%s * %s_ff(%s,-(%s),%s,%s)" f2 f c1 c2 f1 f3
	\| (F241\|F412\|F421) ->
	printf "%s * %s_ff(%s,-(%s),%s,%s)" f2 f c1 c2 f1 f3

	let print_fermion_s2lr_current coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling_2 coeff c and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c2 c1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c1 c2 f2 f3
	\| (F134\|F143\|F314) ->
	printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
	\| (F124\|F142\|F214) ->
	printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
	\| (F413\|F431\|F341) ->
	printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c2 c1 f1 f3
	\| (F241\|F412\|F421) ->
	printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c2 c1 f1 f3

	let print_fermion_g4_current coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling coeff c and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sgr(-%s,%s,%s,%s)" f c f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F134\|F143\|F314\|F124\|F142\|F214) ->
	printf "%s_grf(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F413\|F431\|F341\|F241\|F412\|F421) ->
	printf "%s_fgr(-%s,%s,%s,%s)" f c f1 f2 f3

	let print_fermion_2_g4_current coeff f c wf1 wf2 wf3 fusion =
	let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F134\|F143\|F314\|F124\|F142\|F214) ->
	printf "%s_grf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F413\|F431\|F341\|F241\|F412\|F421) ->
	printf "%s_fgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3

	let print_fermion_2_g4_current coeff f c wf1 wf2 wf3 fusion =
	let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F134\|F143\|F314\|F124\|F142\|F214) ->
	printf "%s_grf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F413\|F431\|F341\|F241\|F412\|F421) ->
	printf "%s_fgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3


	let print_fermion_g4_current_rev coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling coeff c and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "gr_%sf(-%s,%s,%s,%s)" f c f1 f2 f3
	\| (F134\|F143\|F314\|F124\|F142\|F214) ->
	printf "%s_grf(-%s,%s,%s,%s)" f c f1 f2 f3
	\| (F413\|F431\|F341\|F241\|F412\|F421) ->
	printf "%s_fgr(%s,%s,%s,%s)" f c f1 f2 f3

	(* Here we have to distinguish which of the two bosons is produced in the
	fusion of three particles which include both fermions. *)

	let print_fermion_g4_vector_current coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling coeff c and
	d1 = d_p (1,f) and
	d2 = d_p (2,f) and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F134\|F143\|F314) -> printf "%s%s_grf(%s,%s,%s,%s)" f d1 c f1 f2 f3
	\| (F124\|F142\|F214) -> printf "%s%s_grf(%s,%s,%s,%s)" f d2 c f1 f2 f3
	\| (F413\|F431\|F341) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d1 c f1 f2 f3
	\| (F241\|F412\|F421) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d2 c f1 f2 f3

	let print_fermion_2_g4_vector_current coeff f c wf1 wf2 wf3 fusion =
	let d1 = d_p (1,f) and
	d2 = d_p (2,f) and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "f_%sgr(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F134\|F143\|F314) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
	\| (F124\|F142\|F214) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
	\| (F413\|F431\|F341) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
	\| (F241\|F412\|F421) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3

	let print_fermion_g4_vector_current_rev coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling coeff c and
	d1 = d_p (1,f) and
	d2 = d_p (2,f) and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
	\| (F134\|F143\|F314) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d1 c f1 f2 f3
	\| (F124\|F142\|F214) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d2 c f1 f2 f3
	\| (F413\|F431\|F341) -> printf "%s%s_grf(%s,%s,%s,%s)" f d1 c f1 f2 f3
	\| (F241\|F412\|F421) -> printf "%s%s_grf(%s,%s,%s,%s)" f d2 c f1 f2 f3

	let print_fermion_2_g4_current_rev coeff f c wf1 wf2 wf3 fusion =
	let c = format_coupling_2 coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 and
	d1 = d_p (1,f) and
	d2 = d_p (2,f) in
	let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F134\|F143\|F314) ->
	printf "%s%s_fgr(-(%s),-(%s),%s,%s,%s)" f d1 c1 c2 f1 f2 f3
	\| (F124\|F142\|F214) ->
	printf "%s%s_fgr(-(%s),-(%s),%s,%s,%s)" f d2 c1 c2 f1 f2 f3
	\| (F413\|F431\|F341) ->
	printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
	\| (F241\|F412\|F421) ->
	printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3

	let print_fermion_2_g4_vector_current_rev coeff f c wf1 wf2 wf3 fusion =
	(* Here we put in the extra minus sign from the coeff. *)
	let c = format_coupling coeff c in
	let c1 = fastener c 1 and
	c2 = fastener c 2 in
	let d1 = d_p (1,f) and
	d2 = d_p (2,f) and
	f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
	f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
	f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
	match fusion with
	\| (F123\|F213\|F132\|F231\|F312\|F321) ->
	printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F423\|F243\|F432\|F234\|F342\|F324) ->
	printf "f_%sgr(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
	\| (F134\|F143\|F314) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
	\| (F124\|F142\|F214) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
	\| (F413\|F431\|F341) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
	\| (F241\|F412\|F421) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3


	let print_current_g4 = function
	\| coeff, Gravbar, S2, _ -> print_fermion_g4_current coeff "s2"
	\| coeff, Gravbar, SV, _ -> print_fermion_g4_vector_current coeff "sv"
	\| coeff, Gravbar, SLV, _ -> print_fermion_g4_vector_current coeff "slv"
	\| coeff, Gravbar, SRV, _ -> print_fermion_g4_vector_current coeff "srv"
	\| coeff, Gravbar, SLRV, _ -> print_fermion_2_g4_vector_current coeff "slrv"
	\| coeff, Gravbar, PV, _ -> print_fermion_g4_vector_current coeff "pv"
	\| coeff, Gravbar, V2, _ -> print_fermion_g4_current coeff "v2"
	\| coeff, Gravbar, V2LR, _ -> print_fermion_2_g4_current coeff "v2lr"
	\| coeff, Gravbar, _, _ -> invalid_arg "print_current_g4: not implemented"
	\| coeff, _, S2, Grav -> print_fermion_g4_current_rev coeff "s2"
	\| coeff, _, SV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "sv"
	\| coeff, _, SLV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "slv"
	\| coeff, _, SRV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "srv"
	\| coeff, _, SLRV, Grav -> print_fermion_2_g4_vector_current_rev coeff "slrv"
	\| coeff, _, PV, Grav -> print_fermion_g4_vector_current_rev coeff "pv"
	\| coeff, _, V2, Grav -> print_fermion_g4_vector_current_rev coeff "v2"
	\| coeff, _, V2LR, Grav -> print_fermion_2_g4_current_rev coeff "v2lr"
	\| coeff, _, _, Grav -> invalid_arg "print_current_g4: not implemented"
	\| coeff, _, S2, _ -> print_fermion_s2_current coeff "s"
	\| coeff, _, P2, _ -> print_fermion_s2_current coeff "p"
	\| coeff, _, S2P, _ -> print_fermion_s2p_current coeff "sp"
	\| coeff, _, S2L, _ -> print_fermion_s2_current coeff "sl"
	\| coeff, _, S2R, _ -> print_fermion_s2_current coeff "sr"
	\| coeff, _, S2LR, _ -> print_fermion_s2lr_current coeff "slr"
	\| coeff, _, V2, _ -> print_fermion_g4_brs_vector_current coeff "v2"
	\| coeff, _, SV, _ -> print_fermion_g4_brs_vector_current coeff "sv"
	\| coeff, _, PV, _ -> print_fermion_g4_brs_vector_current coeff "pv"
	\| coeff, _, SLV, _ -> print_fermion_g4_brs_vector_current coeff "svl"
	\| coeff, _, SRV, _ -> print_fermion_g4_brs_vector_current coeff "svr"
	\| coeff, _, SLRV, _ -> print_fermion_g4_svlr_current coeff "svlr"
	\| coeff, _, V2LR, _ -> invalid_arg "Targets.print_current: not available"

	let reverse_braket _ = false

	let use_module = "omega95_bispinors"
	let require_library =
	["omega_bispinors_2010_01_A"; "omega_bispinor_cpls_2010_01_A"]
	end

	module Fortran_Majorana = Make_Fortran(Fortran_Majorana_Fermions)

	(* \thocwmodulesubsection{\texttt{FORTRAN\,77}} *)

	module Fortran77 = Dummy

	(* \thocwmodulesection{O'Mega Virtual Machine} *)

	module VM = Dummy

	(* \thocwmodulesection{\texttt{C}} *)

	module C = Dummy

	(* \thocwmodulesubsection{\texttt{C++}} *)

	module Cpp = Dummy

	(* \thocwmodulesubsection{Java} *)

	module Java = Dummy

	(* \thocwmodulesection{O'Caml} *)

	module Ocaml = Dummy

	(* \thocwmodulesection{\LaTeX} *)

	module LaTeX = Dummy

	(*i
	module VM_old (F : Fusion.T) (Make_MF : Fusion.MultiMaker)
	(M : Model.T with type flavor = F.flavor and type constant = F.constant) =
	struct
	let rcs_list =
	[ RCS.rename rcs_file "Targets.VM()"
	[ "Bytecode for the O'Mega Virtual Machine" ] ]

	module MF = Make_MF(F)
	type amplitude = F.amplitude
	type amplitudes = MF.amplitudes
	type diagnostic = All \| Arguments \| Momenta \| Gauge
	let options = Options.empty

	let flavors_to_string flavors =
	String.concat " " (List.map M.flavor_to_string flavors)

	let format_process amplitude =
	flavors_to_string (F.incoming amplitude) ^ " -> " ^
	flavors_to_string (F.outgoing amplitude)

	open Format
	open Coupling

	let ovm_LOAD_SCALAR = 1
	let ovm_LOAD_U = 2
	let ovm_LOAD_UBAR = 3
	let ovm_LOAD_V = 4
	let ovm_LOAD_VBAR = 5
	let ovm_LOAD_VECTOR = 6

	let ovm_ADD_MOMENTA = 10

	let ovm_PROPAGATE_SCALAR = 11
	let ovm_PROPAGATE_SPINOR = 12
	let ovm_PROPAGATE_CONJSPINOR = 13
	let ovm_PROPAGATE_UNITARITY = 14
	let ovm_PROPAGATE_FEYNMAN = 15
	let ovm_PROPAGATE_TENSOR2 = 16

	let ovm_FUSE_VECTOR_PSIBAR_PSI = 21
	let ovm_FUSE_PSI_VECTOR_PSI = 22
	let ovm_FUSE_PSIBAR_PSIBAR_VECTOR = 23

	type instruction =
	{ code : int; sign : int; coupl : int;
	lhs : int; rhs1 : int; rhs2 : int }

	let printi i =
	printf "@\n%3d %3d %3d %3d %3d %3d"
	i.code i.sign i.coupl i.lhs i.rhs1 i.rhs2

	let load lhs f rhs =
	let code =
	match M.lorentz f with
	\| Scalar -> ovm_LOAD_SCALAR
	\| Spinor -> ovm_LOAD_U
	\| ConjSpinor -> ovm_LOAD_UBAR
	\| Majorana -> failwith "load: Majoranas not implemented yet"
	\| Maj_Ghost -> failwith "load: SUSY ghosts not implemented yet"
	\| Vector \| Massive_Vector -> ovm_LOAD_VECTOR
	\| Vectorspinor -> invalid_arg "external spin must be <=1"
	\| Tensor_1 -> invalid_arg "Tensor_1 only internal"
	\| Tensor_2 -> invalid_arg "external spin must be <= 1"
	\| BRS _ -> invalid_arg "no BRST"
	in
	{ code = code; sign = 0; coupl = M.pdg f;
	lhs = lhs; rhs1 = rhs; rhs2 = rhs }

	let print_external count flavor =
	printi (load count (F.flavor flavor) count);
	succ count

	let print_externals amplitude =
	printf "@\n@[<2>BEGIN EXTERNALS";
	ignore (List.fold_left print_external 1 (F.externals amplitude));
	printf "@]@\nEND EXTERNALS"

	let print_current rhs =
	match F.coupling rhs with
	\| V3 (vertex, fusion, constant) -> printf "@\nV3"
	\| V4 (vertex, fusion, constant) -> printf "@\nV4"
	\| Vn (_, _, _) -> printf "@\nVn"

	let p2s p =
	if p >= 0 && p <= 9 then
	string_of_int p
	else if p <= 36 then
	String.make 1 (Char.chr (Char.code 'A' + p - 10))
	else
	"_"

	let format_p wf =
	String.concat "" (List.map p2s (F.momentum_list wf))

	let print_fusion fusion =
	let lhs = F.lhs fusion in
	let f = F.flavor lhs in
	(i let momentum = format_p lhs in i)
	List.iter print_current (F.rhs fusion);
	let propagate code =
	printi { code = code; sign = 0; coupl = 0;
	lhs = int_of_string (format_p lhs);
	rhs1 = abs (M.pdg f); rhs2 = abs (M.pdg f) } in
	match M.propagator f with
	\| Prop_Scalar -> propagate ovm_PROPAGATE_SCALAR
	\| Prop_Col_Scalar ->
	failwith "print_fusion: Prop_Col_Scalar not implemented yet!"
	\| Prop_Ghost ->
	failwith "print_fusion: Prop_Ghost not implemented yet!"
	\| Prop_Spinor -> propagate ovm_PROPAGATE_SPINOR
	\| Prop_ConjSpinor -> propagate ovm_PROPAGATE_CONJSPINOR
	\| Prop_Majorana \| Prop_Col_Majorana ->
	failwith "print_fusion: Prop_Majorana not implemented yet!"
	\| Prop_Unitarity -> propagate ovm_PROPAGATE_UNITARITY
	\| Prop_Col_Unitarity ->
	failwith "print_fusion: Prop_Col_Unitarity not implemented yet!"
	\| Prop_Feynman -> propagate ovm_PROPAGATE_FEYNMAN
	\| Prop_Col_Feynman ->
	failwith "print_fusion: Prop_Col_Feynman not implemented yet!"
	\| Prop_Gauge xi ->
	failwith "print_fusion: Prop_Gauge not implemented yet!"
	\| Prop_Rxi xi ->
	failwith "print_fusion: Prop_Rxi not implemented yet!"
	\| Prop_Vectorspinor ->
	failwith "print_fusion: Prop_Vectorspinor not implemented yet!"
	\| Prop_Tensor_2 -> propagate ovm_PROPAGATE_TENSOR2
	\| Aux_Scalar \| Aux_Spinor \| Aux_ConjSpinor \| Aux_Majorana
	\| Aux_Vector \| Aux_Tensor_1 -> ()
	\| Only_Insertion -> ()

	module P = Set.Make (struct type t = int list let compare = compare end)

	let rec add_momenta lhs = function
	\| [] \| [_] -> invalid_arg "add_momenta"
	\| [rhs1; rhs2] ->
	printi { code = ovm_ADD_MOMENTA; sign = 0; coupl = 0;
	lhs = int_of_string (format_p lhs);
	rhs1 = int_of_string (format_p rhs1);
	rhs2 = int_of_string (format_p rhs2) }
	\| rhs1 :: rhs ->
	add_momenta lhs rhs;
	add_momenta lhs [lhs; rhs1]

	let print_fusions amplitude =
	printf "@\n@[<2>BEGIN FUSIONS";
	let momenta =
	List.fold_left (fun seen f ->
	let wf = F.lhs f in
	let p = F.momentum_list wf in
	let momentum = format_p wf in
	if not (P.mem p seen) then
	add_momenta wf (F.children (List.hd (F.rhs f)));
	print_fusion f;
	P.add p seen) P.empty (F.fusions amplitude)
	in
	printf "@]@\nEND FUSIONS"

	let print_brakets amplitude =
	printf "@\n@[<2>BEGIN BRAKETS";
	printf "@\n!!! not implemented yet !!!";
	printf "@]@\nEND BRAKETS"

	let print_fudge_factor amplitude =
	printf "@\n@[<2>BEGIN FUDGE";
	printf "@\n!!! not implemented yet !!!";
	printf "@]@\nEND FUDGE"

	let amplitude_to_channel oc diagnostics amplitude =
	set_formatter_out_channel oc;
	printf "@\n@[<2>BEGIN AMPLITUDE %s" (format_process amplitude);
	print_externals amplitude;
	print_fusions amplitude;
	print_brakets amplitude;
	print_fudge_factor amplitude;
	printf "@]@\nEND AMPLITUDE"

	let amplitudes_to_channel oc diagnostics amplitudes =
	List.iter (amplitude_to_channel oc diagnostics) (MF.allowed amplitudes)

	let parameters_to_channel oc =
	set_formatter_out_channel oc;
	(i let params = M.parameters () in i)
	printf "@[<2>BEGIN PARAMETERS@\n";
	printf "!!! not implemented yet !!!@]@\n";
	printf "END PARAMETERS@\n"

	end

	i*)

	(*i
	* Local Variables:
	* mode:caml
	* indent-tabs-mode:nil
	* page-delimiter:"^(\\* .*\n"
	* End:
	i*)
	Index: branches/bach/release_2.1.1_hoppet_top_features/src/misc/ilc_tt_threshold.f90
	===================================================================
	--- branches/bach/release_2.1.1_hoppet_top_features/src/misc/ilc_tt_threshold.f90 (revision 5246)
	+++ branches/bach/release_2.1.1_hoppet_top_features/src/misc/ilc_tt_threshold.f90 (revision 5247)
	@@ -1,445 +1,461 @@
	! WHIZARD <<Version>> <<Date>>

	! Copyright (C) 1999-2013 by
	! Wolfgang Kilian <kilian@physik.uni-siegen.de>
	! Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	! Juergen Reuter <juergen.reuter@desy.de>
	! Christian Speckner <christian.speckner@physik.uni-freiburg.de>
	! Fabian Bach <fabian.bach@desy.de> (only this 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.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	module ilc_tt_threshold
	use kinds
	use constants, only: CF, imago
	use file_utils, only: free_unit
	use iso_varying_string, string_t => varying_string !NODEP!
	use sm_physics !NODEP!
	use interp !NODEP!
	use nr_hypgeo_interface !NODEP!
	use system_dependencies !NODEP!
	implicit none
	save
	private

	integer, parameter :: data_num = 100
	real(default), parameter :: dm = 30.0_default
	integer :: init = 0
	integer :: nloop = -1
	integer :: data_num_va(2)
	real(default) :: vsoft = 0.
	real(single) :: sqrts = 0.
	+ real(single) :: switch = 1.
	real(default) :: asoft, mtpole, gam, intv(2)
	! real(default), allocatable, dimension ( :, : ) :: k_data, r_data
	real(default) :: k_data(2,data_num), r_data(2,data_num)

	public :: ilc_tt_init, ilc_tt_formfactor

	contains

	subroutine ilc_tt_init (mpole, width, m1s, vs, nl, init_in)
	real(default), intent(inout) :: mpole
	real(default), intent(in) :: width
	real(default), intent(in) :: m1s
	real(default), intent(in) :: vs
	integer, intent(in) :: nl
	integer, intent(in), optional :: init_in
	+ if ( init /= 0 ) return
	print *, "Initialize vector/axial ttbar threshold production resummation:"
	if ( .not.present(init_in) ) then
	call ilc_tt_init_semi (mpole, width, m1s, vs, nl)
	else
	select case (init_in)
	case (1)
	call ilc_tt_init_interp (mpole, width, m1s, vs, nl)
	case (2)
	call ilc_tt_init_analytic (mpole, width, m1s, vs, nl)
	case (3)
	call ilc_tt_init_semi (mpole, width, m1s, vs, nl)
	case default
	print *, " ERROR: invalid form factor approach!"
	print *, " ERROR: rv/ra => LO!"
	+ init = 0
	end select
	end if
	end subroutine ilc_tt_init

	subroutine ilc_tt_init_interp (mpole, width, m1s, vs, nl)
	real(default), intent(inout) :: mpole
	real(default), intent(in) :: width
	real(default), intent(in) :: m1s
	real (default), intent(in) :: vs
	integer, intent(in) :: nl
	integer :: i, j
	integer :: io_error
	real(default) :: k
	real(default) :: r
	type(string_t), dimension(2) :: rva
	type(string_t), dimension(2) :: scanfile
	type(string_t) :: mprefix
	character(len=1) :: nloop_s
	character(len=3) :: vsoft_s
	integer :: u

	if ( init==1 ) then
	if ( (nl==nloop) .and. (vs==vsoft) ) then
	return
	else
	init = 0
	! if ( allocated(k_data) ) deallocate ( k_data )
	! if ( allocated(r_data) ) deallocate ( r_data )
	end if
	end if

	call init_parameters (mpole, width, m1s, vs, nl)

	! data_num = 0
	rva = (/ "rv", "ra" /)
	! mprefix = PKGDATADIR // "/ilc_tt_threshold/scan_"
	mprefix = PREFIX // "/share/whizard/ilc_tt_threshold/scan_"
	write (nloop_s, '(i1)') nloop
	write (vsoft_s, '(f3.1)') vsoft

	print *, " Use numeric threshold shape interpolation (no interference)"
	if ( nloop > 2 ) then
	print *, " WARNING: numeric ", ("N",I=1,nloop), "LL not supported yet!"
	print *, " rv/ra => LO"
	return
	end if
	print *, " rv => ", ("N",i=1,nloop), "LL (v=", vsoft_s, ")"
	if ( nloop==2 ) then
	print *, " ra => LL (v=", vsoft_s, ")"
	else
	print *, " ra => LO"
	end if
	print *, " threshold shapes from Hoang et al. [arXiv:hep-ph/0107144]"

	do i = 1, 2
	data_num_va(i) = 2
	intv(i) = 0.0_default
	if ( i==2 .and. nloop<2 ) exit
	scanfile(i) = mprefix // rva(i) // "_n" // nloop_s // "_v" // vsoft_s // ".dat"
	u = free_unit ()
	open(unit=u, file=char(scanfile(i)), status='old', action='read', iostat=io_error)
	if ( io_error == 0) then
	do
	read(u,*, iostat=io_error)
	data_num_va(i) = data_num_va(i) + 1
	if (io_error == -1) exit
	end do
	else
	print *, " ERROR (", io_error, ") while opening file ", char(scanfile(i))
	cycle
	end if
	close(u)
	end do

	! if ( data_num_va(1) > 2 ) data_num = data_num_va(1)
	! if ( data_num_va(2) > data_num_va(1) ) data_num = data_num_va(2)

	! if ( data_num==0 ) then
	if ( (data_num_va(1)==2) .and. (data_num_va(2)==2) ) then
	print *, " WARNING: rv/ra => LO (no scan points)!"
	return
	end if
	if ( (data_num_va(1)>data_num) .or. (data_num_va(2)>data_num) ) then
	print *, " ERROR: insufficient memory allocated for scan size!"
	print *, " ERROR: rv/ra => LO (no scan points)!"
	return
	end if

	init = 1
	! allocate ( k_data(2,data_num) )
	! allocate ( r_data(2,data_num) )

	do i = 1, 2
	k_data(i,:) = (/ (0.,I=1,data_num) /)
	r_data(i,:) = (/ (0.,I=1,data_num) /)
	if ( i==2 .and. nloop<2 ) exit
	if ( data_num_va(i)==2 ) then
	print *, " WARNING: ", char(rva(i)), " => LO (no scan points)!"
	cycle
	end if
	u = free_unit ()
	open(unit=u, file=char(scanfile(i)), status='old', action='read')
	do j = 2, data_num_va(i)-1
	read(u,*) k, r
	k_data(i,j) = k
	!!! subtract LO contribution (r=1) contained in the SM piece
	if ( r>1. ) r_data(i,j) = r - 1.
	end do
	close(u)
	intv(i) = ( k_data(i,data_num_va(i)-1) - k_data(i,2) )
	k_data(i,1) = k_data(i,2) - intv(i) / 2.
	k_data(i,data_num_va(i)) = k_data(i,data_num_va(i)-1) + intv(i) / 2.
	if ( intv(i)==0.0_default ) then
	print *, " WARNING: ", char(rva(i)), " => LO (interpolation range vanishes)!"
	cycle
	end if
	print *, " ", char(rva(i)), " initialized (", data_num_va(i)-2, " scan points)."
	end do
	end subroutine ilc_tt_init_interp

	subroutine ilc_tt_init_analytic (mpole, width, m1s, vs, nl)
	real(default), intent(inout) :: mpole
	real(default), intent(in) :: width
	real(default), intent(in) :: m1s
	real(default), intent(in) :: vs
	integer, intent(in) :: nl
	integer :: i
	call init_parameters (mpole, width, m1s, vs, nl)
	if ( init==2 ) return

	print *, " Use analytic form factor for ttA/ttZ couplings at threshold"
	if ( nloop > 0 ) then
	print *, " WARNING: analytic ", ("N",i=1,nloop), "LL not supported yet!"
	print *, " rv/ra => LO"
	return
	end if
	print *, " rv => ", ("N",I=1,nloop), "LL (v=", vsoft, ")"
	if ( nloop==2 ) then
	print *, " ra => LL (v=", vsoft, ")"
	else
	print *, " ra => LO"
	end if
	print *, " threshold shapes from Hoang, Stahlhofen [arXiv:1309.6323]"

	init = 2
	end subroutine ilc_tt_init_analytic

	subroutine ilc_tt_init_semi (mpole, width, m1s, vs, nl)
	real(default), intent(inout) :: mpole
	real(default), intent(in) :: width
	real(default), intent(in) :: m1s
	real(default), intent(in) :: vs
	integer, intent(in) :: nl
	integer :: i
	call init_parameters (mpole, width, m1s, vs, nl)
	if ( init==3 ) then
	! if ( allocated(k_data) .and. allocated(r_data) ) then
	return
	! else
	! init = 0
	! if ( allocated(k_data) ) deallocate ( k_data )
	! if ( allocated(r_data) ) deallocate ( r_data )
	! end if
	end if

	print *, " Use semi-analytic form factor for ttA/ttZ couplings at threshold"
	print *, " (scan for constant sqrts and interpolate for top 3-momentum)"
	if ( nloop > 0 ) then
	print *, " WARNING: analytic ", ("N",i=1,nloop), "LL not supported yet!"
	print *, " rv/ra => LO"
	return
	end if
	print *, " rv => ", ("N",I=1,nloop), "LL (v=", vsoft, ")"
	if ( nloop==2 ) then
	print *, " ra => LL (v=", vsoft, ")"
	else
	print *, " ra => LO"
	end if
	print *, " threshold shapes from Hoang, Stahlhofen [arXiv:1309.6323]"

	init = 3
	sqrts = 0.
	! data_num = 100
	! allocate ( k_data(1,data_num) )
	! allocate ( r_data(2,data_num) )
	end subroutine ilc_tt_init_semi

	function ilc_tt_formfactor (pt, sq, i) result (c)
	real(default), intent(in) :: pt
	real(default), intent(in) :: sq
	integer, intent(in) :: i
	complex(default) :: c
	-print *, "asoft = ", asoft
	-print *, "mtpole = ", mtpole
	-print *, "p = ", pt
	-print *, "sqrts = ", sq
	-print *, "gam = ", gam
	+ c = 0.0_default
	+ if ( sq < mtpole+dm ) return
	+! print *, "asoft = ", asoft
	+! print *, "mtpole = ", mtpole
	+! print *, "p = ", pt
	+! print *, "sqrts = ", sq
	+! print *, "gam = ", gam
	select case (init)
	case (1)
	c = ilc_tt_interp (sq, i)
	case (2)
	c = ilc_tt_analytic (pt, sq, i)
	case (3)
	c = ilc_tt_semi (pt, sq, i)
	case default
	- c = 0.0_default
	+ return
	end select
	end function ilc_tt_formfactor

	function ilc_tt_interp (sq, i) result (c)
	real(default), intent(in) :: sq
	integer, intent(in) :: i
	real(default) :: c
	real(default) :: en
	real(default) :: t_data(data_num_va(i))
	real(default) :: p_data(1,data_num_va(i))
	real(default) :: t_interp(1)
	real(default) :: p_interp(2,1)
	c = 0.0_default
	en = ( sq - 2.*mtpole ) / gam
	if ( abs(en) > intv(i) ) return

	t_data(:) = k_data(i,1:data_num_va(i))
	p_data(1,:) = r_data(i,1:data_num_va(i))
	t_interp(1) = en
	p_interp(1,1) = 0.

	!!! INTERP routine
	! call interp_lagrange ( &
	call interp_linear ( &
	! call interp_nearest ( &
	1, data_num_va(i), t_data, p_data, 1, t_interp, p_interp )

	c = p_interp(1,1)
	end function ilc_tt_interp

	!!! analytic form factor, normalizing to and subtracting the LO
	function ilc_tt_analytic (pt, sq, i) result (c)
	real(default), intent(in) :: pt
	real(default), intent(in) :: sq
	integer, intent(in) :: i
	complex(default) :: c
	real(default) :: en
	c = 0.0_default
	en = sq - 2.*mtpole
	if ( i==2 ) return

	c = G0p ( CF * asoft, mtpole, pt, en, gam) &
	/ G0p (0.0_default, mtpole, pt, en, gam) &
	- 1.0_default
	end function ilc_tt_analytic

	!!! semi-analytic form factor: scan for constant sqrts, interpolate pt values
	function ilc_tt_semi (pt, sq, i) result (c)
	real(default), intent(in) :: pt
	real(default), intent(in) :: sq
	integer, intent(in) :: i
	complex(default) :: c
	real(default) :: t_data(data_num)
	real(default) :: p_data(2,data_num)
	real(default) :: t_interp(1)
	real(default) :: p_interp(2,1)
	integer :: data_it
	+ real(default) :: edge
	! real(default) :: dt1, dt2, dt3
	! real(default) :: tres=0., tref=0.
	c = 0.0_default
	if ( i==2 ) return
	! call cpu_time(tres)
	! tref=tres
	+
	!!! refill scan arrays if energy has changed
	if ( real(sq,kind=single) /= sqrts ) then
	-! if ( abs(sq/sqrts-1.) > 0.0001 ) then
	-! if ( abs(sq-sqrts) > 0.01 ) then
	- intv(i) = sqrt( (sq/2.)2 - (mtpole-dm)2 )
	- do data_it=1, data_num
	- k_data(1,data_it) = real(data_it) / real(data_num) * intv(i)
	- c = ilc_tt_analytic (k_data(1,data_it), sq, i)
	- r_data(1,data_it) = real(c)
	- r_data(2,data_it) = aimag(c)
	- end do
	- sqrts = sq
	+
	+ if ( (sq-2.mtpole) < 2.dm ) then
	+ intv(i) = 1.1sqrt( (sq/2.)2 - (mtpole-dm)*2 )
	+ do data_it=1, data_num
	+ k_data(1,data_it) = real(data_it) / real(data_num) * intv(i)
	+ c = ilc_tt_analytic (k_data(1,data_it), sq, i)
	+ r_data(1,data_it) = real(c)
	+ r_data(2,data_it) = aimag(c)
	+ end do
	+ sqrts = sq
	+
	+ !!! interpolate to c = 0 for sq in [2mt+dm, 2mt+2*dm]
	+ if ( (sq-2.*mtpole) > dm ) then
	+ edge = 2.
	+! switch = 1. - (sq-2.*mtpole-dm) / dm !!! linear
	+ switch = ( 1. - atan( 2.edge(sq-2.mtpole-1.5dm)/dm ) / atan(edge) )/2. !!! arctan
	+! switch = ( 1. - erf ( 2.edge(sq-2.mtpole-1.5dm)/dm ) / erf (edge) )/2. !!! erf
	+ end if
	+
	+ else
	+ return
	+ end if
	end if
	! call cpu_time(tres)
	! dt1 = tres-tref
	! tref=tres

	- if ( pt > intv(i) ) return
	-
	t_data(:) = k_data(1,1:data_num)
	p_data(:,:) = r_data(:,1:data_num)
	t_interp(1) = pt
	p_interp(1,1) = 0.
	p_interp(2,1) = 0.
	! call cpu_time(tres)
	! dt2 = tres-tref
	! tref=tres

	!!! INTERP routine
	call interp_linear ( &
	2, data_num, t_data, p_data, 1, t_interp, p_interp )
	+
	+ c = switch * ( p_interp(1,1) + imago*p_interp(2,1) )
	+! print *, "switch = ", switch
	! call cpu_time(tres)
	! dt3 = tres-tref
	! print *, " DT ", dt1, " ", dt2, " ", dt3
	-
	- c = p_interp(1,1) + imago*p_interp(2,1)
	-print *, "c = ", c
	end function ilc_tt_semi

	!!! Max's LL nonrelativistic threshold Green's function
	function G0p (a, m, p, en, w) result (c)
	real(default), intent(in) :: a
	real(default), intent(in) :: m
	real(default), intent(in) :: p
	real(default), intent(in) :: en
	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 = 1.
	two = 2.
	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

	function m1s_to_mpole (m1s, as) result (mpole)
	real(default), intent(in) :: m1s
	real(default), intent(in) :: as
	real(default) :: mpole
	mpole = m1s * ( 1. + deltaLL(as) )
	end function m1s_to_mpole

	function mpole_to_m1s (mpole, as) result (m1s)
	real(default), intent(in) :: mpole
	real(default), intent(in) :: as
	real(default) :: m1s
	m1s = mpole * ( 1. - deltaLL(as) )
	end function mpole_to_m1s

	function deltaLL (as) result (del)
	real(default), intent(in) :: as
	real(default) :: del
	del = 2.0_default / 9.0_default * as**2
	end function deltaLL

	subroutine init_parameters (mpole, width, m1s, vs, nl)
	real(default), intent(inout) :: mpole
	real(default), intent(in) :: width
	real(default), intent(in) :: m1s
	real (default), intent(in) :: vs
	integer, intent(in) :: nl
	vsoft = vs
	nloop = nl
	gam = width
	if ( m1s > 0. ) then
	asoft = running_as (m1s/2.*vsoft)
	mpole = m1s_to_mpole (m1s, asoft)
	else
	asoft = running_as (mpole/2.*vsoft)
	- mpole = mpole
	end if
	mtpole = mpole
	end subroutine init_parameters

	end module ilc_tt_threshold
	Index: branches/bach/release_2.1.1_hoppet_top_features/src/misc/hypgeo.f90
	===================================================================
	--- branches/bach/release_2.1.1_hoppet_top_features/src/misc/hypgeo.f90 (revision 5246)
	+++ branches/bach/release_2.1.1_hoppet_top_features/src/misc/hypgeo.f90 (revision 5247)
	@@ -1,4802 +1,4808 @@
	! WHIZARD <<Version>> <<Date>>

	! routine hypgeo and necessary dependencies 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: reduced hardcoded default stepsize for odeint routine
	+! called by hypgeo, cf. line 4645.
	+!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!



	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 locate(xx,x)
	USE nrtype
	REAL(SP), DIMENSION(:), INTENT(IN) :: xx
	REAL(SP), INTENT(IN) :: x
	INTEGER(I4B) :: locate
	END FUNCTION locate
	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
	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 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.0001_sp,hypdrv,bsstep)
	+ call odeint(ry,0.0_sp,1.0_sp,EPS,0.1_sp,0.00001_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)&
	call nrerror('stepsize smaller than minimum in odeint')
	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



	!!! Whizard wrapper for NR's hypgeo function
	module nr_hypgeo_interface
	use kinds, only: default
	use nrtype, only: spc
	use nr, only: hypgeo
	implicit none

	public :: nr_hypgeo

	contains

	function nr_hypgeo (a, b, c, d) result (hg)
	complex(default), intent(in) :: a, b, c, d
	complex(default) :: hg
	complex(spc) :: aa, bb, cc, dd
	aa = a
	bb = b
	cc = c
	dd = d
	hg = hypgeo (aa, bb, cc, dd)
	end function nr_hypgeo

	end module nr_hypgeo_interface

File Metadata

Mime Type: text/x-diff
Expires: Tue, Nov 19, 7:02 PM (1 d, 10 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 3805741
Default Alt Text: (327 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions