Index: trunk/omega/src/UFO.ml
===================================================================
--- trunk/omega/src/UFO.ml	(revision 8364)
+++ trunk/omega/src/UFO.ml	(revision 8365)
@@ -1,2665 +1,2684 @@
 (* UFO.ml --
 
    Copyright (C) 1999-2019 by
 
        Wolfgang Kilian <kilian@physik.uni-siegen.de>
        Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
        Juergen Reuter <juergen.reuter@desy.de>
        with contributions from
        Christian Speckner <cnspeckn@googlemail.com>
 
    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.  *)
 
 (* Unfortunately, \texttt{ocamlweb} will not typeset all multi character
    operators nicely. E.\,g.~\verb+f @< g+ comes out as [f @< g]. *)
 let (@@) f g x =
  f (g x)
 
 let (@@@) f g x y =
   f (g x y)
 
 module SMap = Map.Make (struct type t = string let compare = compare end)
 module SSet = Sets.String
 
 module CMap =
   Map.Make
     (struct
       type t = string
       let compare = ThoString.compare_caseless
     end)
 module CSet = Sets.String_Caseless
 
 let error_in_string text start_pos end_pos =
   let i = start_pos.Lexing.pos_cnum
   and j = end_pos.Lexing.pos_cnum in
   String.sub text i (j - i)
 
 let error_in_file name start_pos end_pos =
   Printf.sprintf
     "%s:%d.%d-%d.%d"
     name
     start_pos.Lexing.pos_lnum
     (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol)
     end_pos.Lexing.pos_lnum
     (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol)
 
 let parse_string text =
   try
     UFO_parser.file
       UFO_lexer.token
       (UFO_lexer.init_position "" (Lexing.from_string text))
   with
   | UFO_tools.Lexical_Error (msg, start_pos, end_pos) ->
      invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'"
                     msg  (error_in_string text start_pos end_pos))
   | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) ->
      invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'"
                     msg  (error_in_string text start_pos end_pos))
   | Parsing.Parse_error ->
      invalid_arg ("parse error: " ^ text)
 
 let parse_file name =
   let ic = open_in name in
   let result =
     begin
       try
 	UFO_parser.file
 	  UFO_lexer.token
 	  (UFO_lexer.init_position name (Lexing.from_channel ic))
       with
       | UFO_tools.Lexical_Error (msg, start_pos, end_pos) ->
 	 begin
 	   close_in ic;
 	   invalid_arg (Printf.sprintf
 			  "%s: lexical error (%s)"
 			  (error_in_file name start_pos end_pos) msg)
 	 end
       | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) ->
 	 begin
 	   close_in ic;
 	   invalid_arg (Printf.sprintf
 			  "%s: syntax error (%s)"
 			  (error_in_file name start_pos end_pos) msg)
 	 end
       | Parsing.Parse_error ->
 	 begin
 	   close_in ic;
 	   invalid_arg ("parse error: " ^ name)
 	 end
     end in
   close_in ic;
   result
 
 (* These are the contents of the Python files after lexical
    analysis as context-free variable declarations, before
    any semantic interpretation. *)
 
 module type Files =
   sig
     
     type t = private
       { particles : UFO_syntax.t;
 	couplings : UFO_syntax.t;
 	coupling_orders : UFO_syntax.t;
 	vertices : UFO_syntax.t;
 	lorentz : UFO_syntax.t;
 	parameters : UFO_syntax.t;
 	propagators : UFO_syntax.t;
 	decays : UFO_syntax.t }
 
     val parse_directory : string -> t
 
   end
 
 module Files : Files =
   struct
     
     type t =
       { particles : UFO_syntax.t;
 	couplings : UFO_syntax.t;
 	coupling_orders : UFO_syntax.t;
 	vertices : UFO_syntax.t;
 	lorentz : UFO_syntax.t;
 	parameters : UFO_syntax.t;
 	propagators : UFO_syntax.t;
 	decays : UFO_syntax.t }
 
     let parse_directory dir =
       let parse stem = parse_file (Filename.concat dir (stem ^ ".py")) in
       { particles = parse "particles";
 	couplings = parse "couplings";
 	coupling_orders = (try parse "coupling_orders" with _ -> []);
 	vertices = parse "vertices";
 	lorentz = parse "lorentz";
 	parameters = parse "parameters";
 	propagators = (try parse "propagators" with _ -> []);
 	decays = (try parse "decays" with _ -> []) }
 
   end
 
 let dump_file pfx f =
   List.iter
     (fun s -> print_endline (pfx ^ ": " ^ s))
     (UFO_syntax.to_strings f)
 
 type charge =
   | Q_Integer of int
   | Q_Fraction of int * int
 
 let charge_to_string = function
   | Q_Integer i -> Printf.sprintf "%d" i
   | Q_Fraction (n, d) -> Printf.sprintf "%d/%d" n d
 
 module S = UFO_syntax
 
 let find_attrib name attribs =
   try
     (List.find (fun a -> name = a.S.a_name) attribs).S.a_value
   with
   | Not_found -> failwith ("UFO.find_attrib: \"" ^ name ^ "\" not found")
 
 let find_attrib name attribs =
   (List.find (fun a -> name = a.S.a_name) attribs).S.a_value
 
 let name_to_string ?strip name =
   let stripped =
     begin match strip, List.rev name with
     | Some pfx, head :: tail ->
        if pfx = head then
 	 tail
        else
 	 failwith ("UFO.name_to_string: expected prefix '" ^ pfx ^
 		      "', got '" ^ head ^ "'")
     | _, name -> name
     end in
   String.concat "." stripped
 
 let name_attrib ?strip name attribs =
   match find_attrib name attribs with
   | S.Name n -> name_to_string ?strip n
   | _ -> invalid_arg name
 
 let integer_attrib name attribs =
   match find_attrib name attribs with
   | S.Integer i -> i
   | _ -> invalid_arg name
 
 let charge_attrib name attribs =
   match find_attrib name attribs with
   | S.Integer i -> Q_Integer i
   | S.Fraction (n, d) -> Q_Fraction (n, d)
   | _ -> invalid_arg name
 
 let string_attrib name attribs =
   match find_attrib name attribs with
   | S.String s -> s
   | _ -> invalid_arg name
 
 let boolean_attrib name attribs =
   try
     match ThoString.lowercase (name_attrib name attribs) with
     | "true" -> true
     | "false" -> false
     | _ -> invalid_arg name
   with
   | Not_found -> false
 
 type value =
   | Integer of int
   | Fraction of int * int
   | Float of float
   | Expr of UFOx.Expr.t
   | Name of string list
 
 let map_expr f default = function
   | Integer _ | Fraction (_, _) | Float _ | Name _ -> default
   | Expr e -> f e
 
 let variables = map_expr UFOx.Expr.variables CSet.empty
 let functions = map_expr UFOx.Expr.functions CSet.empty
 
 let add_to_set_in_map key element map =
   let set = try CMap.find key map with Not_found -> CSet.empty in
   CMap.add key (CSet.add element set) map
 
 (* Add all variables in [value] to the [map] from variables
    to the names in which they appear, indicating
    that [name] depends on these variables. *)
 let dependency name value map =
   CSet.fold
     (fun variable acc -> add_to_set_in_map variable name acc)
     (variables value)
     map
 
 let dependencies name_value_list =
   List.fold_left
     (fun acc (name, value) -> dependency name value acc)
     CMap.empty
     name_value_list
 
 let dependency_to_string (variable, appearences) =
   Printf.sprintf
     "%s -> {%s}"
     variable (String.concat ", " (CSet.elements appearences))
 
 let dependencies_to_strings map =
   List.map dependency_to_string (CMap.bindings map)
 
 let expr_to_string =
   UFOx.Value.to_string @@ UFOx.Value.of_expr
 
 let value_to_string = function
   | Integer i -> Printf.sprintf "%d" i
   | Fraction (n, d) -> Printf.sprintf "%d/%d" n d
   | Float x -> string_of_float x
   | Expr e -> "'" ^ expr_to_string e ^ "'"
   | Name n -> name_to_string n
 
 let value_to_expr substitutions = function
   | Integer i -> Printf.sprintf "%d" i
   | Fraction (n, d) -> Printf.sprintf "%d/%d" n d
   | Float x -> string_of_float x
   | Expr e -> expr_to_string (substitutions e)
   | Name n -> name_to_string n
 
 let value_to_coupling substitutions atom = function
   | Integer i -> Coupling.Integer i
   | Fraction (n, d) -> Coupling.Quot (Coupling.Integer n, Coupling.Integer d)
   | Float x -> Coupling.Float x
   | Expr e ->
      UFOx.Value.to_coupling atom (UFOx.Value.of_expr (substitutions e))
   | Name n -> failwith "UFO.value_to_coupling: Name not supported yet!"
 
 let value_to_numeric = function
   | Integer i -> Printf.sprintf "%d" i
   | Fraction (n, d) -> Printf.sprintf "%g" (float n /. float d)
   | Float x -> Printf.sprintf "%g" x
   | Expr e -> invalid_arg ("UFO.value_to_numeric: expr = " ^ (expr_to_string e))
   | Name n -> invalid_arg ("UFO.value_to_numeric: name = " ^ name_to_string n)
 
 let value_to_float = function
   | Integer i -> float i
   | Fraction (n, d) -> float n /. float d
   | Float x -> x
   | Expr e -> invalid_arg ("UFO.value_to_float: string = " ^ (expr_to_string e))
   | Name n -> invalid_arg ("UFO.value_to_float: name = " ^ name_to_string n)
 
 let value_attrib name attribs =
   match find_attrib name attribs with
   | S.Integer i -> Integer i
   | S.Fraction (n, d) -> Fraction (n, d)
   | S.Float x -> Float x
   | S.String s -> Expr (UFOx.Expr.of_string s)
   | S.Name n -> Name n
   | _ -> invalid_arg name
 
 let string_list_attrib name attribs =
   match find_attrib name attribs with
   | S.String_List l -> l
   | _ -> invalid_arg name
 
 let name_list_attrib ~strip name attribs =
   match find_attrib name attribs with
   | S.Name_List l -> List.map (name_to_string ~strip) l
   | _ -> invalid_arg name
 
 let integer_list_attrib name attribs =
   match find_attrib name attribs with
   | S.Integer_List l -> l
   | _ -> invalid_arg name
 
 let order_dictionary_attrib name attribs =
   match find_attrib name attribs with
   | S.Order_Dictionary d -> d
   | _ -> invalid_arg name
 
 let coupling_dictionary_attrib ~strip name attribs =
   match find_attrib name attribs with
   | S.Coupling_Dictionary d ->
      List.map (fun (i, j, c) -> (i, j, name_to_string ~strip c)) d
   | _ -> invalid_arg name
 
 let decay_dictionary_attrib name attribs =
   match find_attrib name attribs with
   | S.Decay_Dictionary d ->
      List.map (fun (p, w) -> (List.map List.hd p, w)) d
   | _ -> invalid_arg name
 
 (*i The following doesn't typecheck in applications, even with
     type annotations ...
 let attrib_handlers : type attribs value.
       string -> string -> attribs ->
       ((string -> attribs -> value) -> string -> value) *
         ((string -> attribs -> value) -> string -> value -> value) =
   fun kind symbol attribs ->
   let required query name =
     try
       query name attribs
     with
     | Not_found ->
        invalid_arg
          (Printf.sprintf
             "fatal UFO error: mandatory attribute `%s' missing for %s `%s'!"
             name kind symbol)
   and optional query name default =
     try
       query name attribs
     with
     | Not_found -> default in
   (required, optional) i*)
 
 let required_handler kind symbol attribs query name =
   try
     query name attribs
   with
   | Not_found ->
      invalid_arg
        (Printf.sprintf
           "fatal UFO error: mandatory attribute `%s' missing for %s `%s'!"
           name kind symbol)
 
 let optional_handler attribs query name default =
   try
     query name attribs
   with
   | Not_found -> default
 
 let warn_symbol_name file symbol name =
   if name <> symbol then
     Printf.eprintf
       "UFO: warning: symbol '%s' <> name '%s' in %s.py: expect errors!\n"
       symbol name file
 
 let map_to_alist map =
   SMap.fold (fun key value acc -> (key, value) :: acc) map []
 
 let keys map =
   SMap.fold (fun key _ acc -> key :: acc) map []
 
 let keys_caseless map =
   CMap.fold (fun key _ acc -> key :: acc) map []
 
 let values map =
   SMap.fold (fun _ value acc -> value :: acc) map []
 
 module SKey =
   struct
     type t = string
     let hash = Hashtbl.hash
     let equal = (=)
   end
 module SHash = Hashtbl.Make (SKey)
 
 module type Particle =
   sig
 
     type t = private
       { pdg_code : int;
 	name : string;
 	antiname : string;
 	spin : UFOx.Lorentz.r;
 	color : UFOx.Color.r;
 	mass : string;
 	width : string;
         propagator : string option;
 	texname : string;
 	antitexname : string;
 	charge : charge;
 	ghost_number : int;
 	lepton_number : int;
 	y : int;
 	goldstone : bool;
 	propagating : bool;   (* NOT HANDLED YET! *)
 	line : string option; (* NOT HANDLED YET! *)
         is_anti : bool }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
     val conjugate : t -> t
     val force_spinor : t -> t
     val force_conjspinor : t -> t
     val force_majorana : t -> t
     val is_majorana : t -> bool
     val is_ghost : t -> bool
     val is_goldstone : t -> bool
     val is_physical : t -> bool
     val filter : (t -> bool) -> t SMap.t -> t SMap.t
 
   end
 
 module Particle : Particle =
   struct
     
     type t =
       { pdg_code : int;
 	name : string;
 	antiname : string;
 	spin : UFOx.Lorentz.r;
 	color : UFOx.Color.r;
 	mass : string;
 	width : string;
         propagator : string option;
 	texname : string;
 	antitexname : string;
 	charge : charge;
 	ghost_number : int;
 	lepton_number : int;
 	y : int;
 	goldstone : bool;
 	propagating : bool;  (* NOT HANDLED YET! *)
 	line : string option; (* NOT HANDLED YET! *)
         is_anti : bool }
 
     let to_string symbol p =
       Printf.sprintf
 	"particle: %s => [pdg = %d, name = '%s'/'%s', \
                           spin = %s, color = %s, \
                           mass = %s, width = %s,%s \
                           Q = %s, G = %d, L = %d, Y = %d, \
                           TeX = '%s'/'%s'%s]"
 	symbol p.pdg_code p.name p.antiname
 	(UFOx.Lorentz.rep_to_string p.spin)
 	(UFOx.Color.rep_to_string p.color)
 	p.mass p.width
 	(match p.propagator with
          | None -> ""
          | Some p -> " propagator = " ^ p ^ ",")
 	(charge_to_string p.charge)
 	p.ghost_number p.lepton_number p.y
 	p.texname p.antitexname
 	(if p.goldstone then ", GB" else "")
 
     let conjugate_charge = function
       | Q_Integer i -> Q_Integer (-i)
       | Q_Fraction (n, d) -> Q_Fraction (-n, d)
 
     let is_neutral p =
       (p.name = p.antiname)
 
     (* We \emph{must not} mess with [pdg_code] and [color] if
        the particle is neutral! *)
     let conjugate p =
       if is_neutral p then
 	p
       else
 	{ pdg_code = - p.pdg_code;
 	  name = p.antiname;
 	  antiname = p.name;
 	  spin = UFOx.Lorentz.rep_conjugate p.spin;
 	  color = UFOx.Color.rep_conjugate p.color;
 	  mass = p.mass;
 	  width = p.width;
           propagator = p.propagator;
 	  texname = p.antitexname;
 	  antitexname = p.texname;
 	  charge = conjugate_charge p.charge;
 	  ghost_number = p.ghost_number;
 	  lepton_number = p.lepton_number;
 	  y = p.y;
 	  goldstone = p.goldstone;
 	  propagating = p.propagating;
 	  line = p.line;
           is_anti = not p.is_anti }
 
     let of_file1 map d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Particle" ], attribs ->
          let required query name =
            required_handler "particle" symbol attribs query name
          and optional query name default =
            optional_handler attribs query name default in
          let name = required string_attrib "name"
 	 and antiname = required string_attrib "antiname" in
          let neutral = (name = antiname) in
 	 SMap.add symbol
 	   { (* The required attributes per UFO docs. *)
              pdg_code = required integer_attrib "pdg_code";
 	     name; antiname;
 	     spin =
                UFOx.Lorentz.rep_of_int neutral (required integer_attrib "spin");
 	     color =
                UFOx.Color.rep_of_int neutral (required integer_attrib "color");
 	     mass = required (name_attrib ~strip:"Param") "mass";
 	     width = required (name_attrib ~strip:"Param") "width";
 	     texname = required string_attrib "texname";
 	     antitexname = required string_attrib "antitexname";
 	     charge = required charge_attrib "charge";
 	     (* The optional attributes per UFO docs. *)
              ghost_number = optional integer_attrib "GhostNumber" 0;
 	     lepton_number = optional integer_attrib "LeptonNumber" 0;
 	     y = optional integer_attrib "Y" 0;
 	     goldstone = optional boolean_attrib "goldstone" false;
 	     propagating = optional boolean_attrib "propagating" true;
 	     line =
                (try Some (name_attrib "line" attribs) with _ -> None);
 	     (* Undocumented extensions. *)
              propagator =
                (try Some (name_attrib "propagator" attribs) with _ -> None);
              (* O'Mega extensions. *)
              is_anti = false } map
       | [ "anti"; p ], [] ->
 	 begin
 	   try
 	     SMap.add symbol (conjugate (SMap.find p map)) map
 	   with
 	   | Not_found ->
 	      invalid_arg
 		("Particle.of_file: " ^ p ^ ".anti() not yet defined!")
 	 end
       | _ -> invalid_arg ("Particle.of_file: " ^ name_to_string d.S.kind)
 
     let of_file particles =
       List.fold_left of_file1 SMap.empty particles
 
     let is_spinor p =
       match UFOx.Lorentz.omega p.spin with
       | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> true
       | _ -> false
 
     (* \begin{dubious}
          TODO: this is a bit of a hack: try to expose the type
          [UFOx.Lorentz_Atom'.r] instead.
        \end{dubious} *)
     let force_spinor p =
       if is_spinor p then
         { p with spin = UFOx.Lorentz.rep_of_int false 2 }
       else
         p
 
     let force_conjspinor p =
       if is_spinor p then
         { p with spin = UFOx.Lorentz.rep_of_int false (-2) }
       else
         p
 
     let force_majorana p =
       if is_spinor p then
         { p with spin = UFOx.Lorentz.rep_of_int true 2 }
       else
         p
 
     let is_majorana p =
       match UFOx.Lorentz.omega p.spin with
       | Coupling.Majorana -> true
       | _ -> false
 
     let is_ghost p =
       p.ghost_number <> 0
 
     let is_goldstone p =
       p.goldstone
 
     let is_physical p =
       not (is_ghost p || is_goldstone p)
 
     let filter predicate map =
       SMap.filter (fun symbol p -> predicate p) map
 
   end
 
 module type UFO_Coupling =
   sig
 
     type t = private
       { name : string;
 	value : UFOx.Expr.t;
 	order : (string * int) list }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
 
   end
 
 module UFO_Coupling : UFO_Coupling =
   struct
     
     type t =
       { name : string;
 	value : UFOx.Expr.t;
 	order : (string * int) list }
 
     let order_to_string orders =
       String.concat ", "
 	(List.map (fun (s, i) -> Printf.sprintf "'%s':%d" s i) orders)
 
     let to_string symbol c =
       Printf.sprintf
 	"coupling: %s => [name = '%s', value = '%s', order = [%s]]"
 	symbol c.name (expr_to_string c.value) (order_to_string c.order)
 
     let of_file1 map d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Coupling" ], attribs ->
          let required query name =
            required_handler "coupling" symbol attribs query name in
          let name = required string_attrib "name" in
          warn_symbol_name "couplings" symbol name;
 	 SMap.add symbol
            { name;
 	     value = UFOx.Expr.of_string (required string_attrib "value");
 	     order = required order_dictionary_attrib "order" } map
       | _ -> invalid_arg ("UFO_Coupling.of_file: " ^ name_to_string d.S.kind)
 
     let of_file couplings =
       List.fold_left of_file1 SMap.empty couplings
 
   end
 
 module type Coupling_Order =
   sig
 
     type t = private
       { name : string;
 	expansion_order : int;
 	hierarchy : int }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
 
   end
 
 module Coupling_Order : Coupling_Order =
   struct
 
     type t =
       { name : string;
 	expansion_order : int;
 	hierarchy : int }
 
     let to_string symbol c =
       Printf.sprintf
 	"coupling_order: %s => [name = '%s', \
                                 expansion_order = '%d', \
                                 hierarchy = %d]"
 	symbol c.name c.expansion_order c.hierarchy
 
     let of_file1 map d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "CouplingOrder" ], attribs ->
          let required query name =
            required_handler "coupling order" symbol attribs query name in
          let name = required string_attrib "name" in
          warn_symbol_name "coupling_orders" symbol name;
 	 SMap.add symbol
 	   { name;
 	     expansion_order = required integer_attrib "expansion_order";
 	     hierarchy = required integer_attrib "hierarchy" } map
       | _ -> invalid_arg ("Coupling_order.of_file: " ^ name_to_string d.S.kind)
 
     let of_file coupling_orders =
       List.fold_left of_file1 SMap.empty coupling_orders
   end
 
 module type Lorentz_UFO =
   sig
 
     type t = private
       { name : string;
 	spins : int list;
 	structure : UFOx.Lorentz.t }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
 
   end
 
 module Lorentz_UFO : Lorentz_UFO =
   struct
 
     type t =
       { name : string;
 	spins : int list;
 	structure : UFOx.Lorentz.t }
 
     let to_string symbol l =
       Printf.sprintf
 	"lorentz: %s => [name = '%s', spins = [%s], \
                          structure = %s]"
 	symbol l.name
 	(String.concat ", " (List.map string_of_int l.spins))
 	(UFOx.Lorentz.to_string l.structure)
 
     let of_file1 map d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Lorentz" ], attribs ->
          let required query name =
            required_handler "lorentz" symbol attribs query name in
          let name = required string_attrib "name" in
          warn_symbol_name "lorentz" symbol name;
 	 SMap.add symbol
 	   { name;
 	     spins = required integer_list_attrib "spins";
 	     structure =
 	       UFOx.Lorentz.of_string (required string_attrib "structure") } map
       | _ -> invalid_arg ("Lorentz.of_file: " ^ name_to_string d.S.kind)
 
     let of_file lorentz =
       List.fold_left of_file1 SMap.empty lorentz
 
   end
 
 module type Vertex =
   sig
 
     type lcc = private (* Lorentz-color-coupling *)
       { lorentz : string;
 	color : UFOx.Color.t;
 	coupling : string }
 
     type t = private
       { name : string;
 	particles : string array;
 	lcc : lcc list }
 
     val of_file : Particle.t SMap.t -> S.t -> t SMap.t
     val to_string : string -> t -> string
     val to_string_expanded :
       Lorentz_UFO.t SMap.t -> UFO_Coupling.t SMap.t -> t -> string
     val contains : Particle.t SMap.t -> (Particle.t -> bool) -> t -> bool
     val filter : (t -> bool) -> t SMap.t -> t SMap.t
 
   end
 
 module Vertex : Vertex =
   struct
     
     type lcc =
       { lorentz : string;
 	color : UFOx.Color.t;
 	coupling : string }
 
     type t =
       { name : string;
 	particles : string array;
 	lcc : lcc list }
 
     let to_string symbol c =
       Printf.sprintf
 	"vertex: %s => [name = '%s', particles = [%s], \
                         lorentz-color-couplings = [%s]"
 	symbol c.name
 	(String.concat
            ", " (Array.to_list c.particles))
 	(String.concat
            ", "
            (List.map
               (fun lcc ->
                 Printf.sprintf
                   "%s * %s * %s"
                   lcc.coupling lcc.lorentz
                   (UFOx.Color.to_string lcc.color))
               c.lcc))
         
     let to_string_expanded lorentz couplings c =
       let expand_lorentz s =
         try
           UFOx.Lorentz.to_string (SMap.find s lorentz).Lorentz_UFO.structure
         with
         | Not_found -> "?" in
       Printf.sprintf
 	"expanded: [%s] -> { lorentz-color-couplings = [%s] }"
 	(String.concat ", " (Array.to_list c.particles))
         (String.concat
            ", "
            (List.map
               (fun lcc ->
                 Printf.sprintf
                   "%s * %s * %s"
                   lcc.coupling (expand_lorentz lcc.lorentz)
                   (UFOx.Color.to_string lcc.color))
               c.lcc))
 
     let contains particles predicate v =
       let p = v.particles in
       let rec contains' i =
 	if i < 0 then
 	  false
 	else if predicate (SMap.find p.(i) particles) then
 	  true
 	else
 	  contains' (pred i) in
       contains' (Array.length p - 1)
       
     let force_adj_identity1 adj_indices = function
       | UFOx.Color_Atom.Identity (a, b) as atom ->
          begin match List.mem a adj_indices, List.mem b adj_indices with
          | true, true -> UFOx.Color_Atom.Identity8 (a, b)
          | false, false -> atom
          | true, false | false, true ->
             invalid_arg "force_adj_identity: mixed representations!"
          end
       | atom -> atom
 
     let force_adj_identity adj_indices tensor =
       UFOx.Color.map_atoms (force_adj_identity1 adj_indices) tensor
 
     let find_adj_indices map particles =
       let adj_indices = ref [] in
       Array.iteri
         (fun i p ->
           (* We must pattern match against the O'Mega representation,
              because [UFOx.Color.r] is abstract. *)
           match UFOx.Color.omega (SMap.find p map).Particle.color with
           | Color.AdjSUN _ -> adj_indices := succ i :: !adj_indices
           | _ -> ())
         particles;
       !adj_indices
 
     let classify_color_indices map particles =
       let fund_indices = ref []
       and conj_indices = ref []
       and adj_indices = ref [] in
       Array.iteri
         (fun i p ->
           (* We must pattern match against the O'Mega representation,
              because [UFOx.Color.r] is abstract. *)
           match UFOx.Color.omega (SMap.find p map).Particle.color with
           | Color.SUN n ->
              if n > 0 then
                fund_indices := succ i :: !fund_indices
              else if n < 0 then
                conj_indices := succ i :: !conj_indices
              else
                failwith "classify_color_indices: SU(0)"
           | Color.AdjSUN n ->
              if n <> 0 then
                adj_indices := succ i :: !adj_indices
              else
                failwith "classify_color_indices: SU(0)"
           | _ -> ())
         particles;
       (!fund_indices, !conj_indices, !adj_indices)
 
     (* FIXME: would have expected the opposite order \ldots *)
     let force_identity1 (fund_indices, conj_indices, adj_indices) = function
       | UFOx.Color_Atom.Identity (a, b) as atom ->
          if List.mem a fund_indices then
            begin
              if List.mem b conj_indices then
                UFOx.Color_Atom.Identity (b, a)
              else
                invalid_arg "force_adj_identity: mixed representations!"
            end
          else if List.mem a conj_indices then
            begin
              if List.mem b fund_indices then
                UFOx.Color_Atom.Identity (a, b)
              else
                invalid_arg "force_adj_identity: mixed representations!"
            end else if List.mem a adj_indices then begin
              if List.mem b adj_indices then
                UFOx.Color_Atom.Identity8 (a, b)
              else
                invalid_arg "force_adj_identity: mixed representations!"
            end
          else
            atom
       | atom -> atom
 
     let force_identity indices tensor =
       UFOx.Color.map_atoms (force_identity1 indices) tensor
 
     (* Here we don't have the Lorentz structures available yet.
        Thus we set [fermion_lines = []] for now and correct this
        later. *)
     let of_file1 particle_map map d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Vertex" ], attribs ->
          let required query name =
            required_handler "vertex" symbol attribs query name in
          let name = required string_attrib "name" in
          warn_symbol_name "vertices" symbol name;
          let particles =
 	   Array.of_list (required (name_list_attrib ~strip:"P") "particles") in
 	 let color =
            let indices = classify_color_indices particle_map particles in
 	   Array.of_list
 	     (List.map
                 (force_identity indices @@ UFOx.Color.of_string)
                 (required string_list_attrib "color"))
 	 and lorentz =
 	   Array.of_list (required (name_list_attrib ~strip:"L") "lorentz")
 	 and couplings_alist =
 	   required (coupling_dictionary_attrib ~strip:"C") "couplings" in
 	 let lcc =
 	   List.map
 	     (fun (i, j, c) ->
                { lorentz = lorentz.(j);
                  color = color.(i);
                  coupling = c })
 	     couplings_alist in
 	 SMap.add symbol { name; particles; lcc } map
       | _ -> invalid_arg ("Vertex.of_file: " ^ name_to_string d.S.kind)
 
     let of_file particles vertices =
       List.fold_left (of_file1 particles) SMap.empty vertices
 
     let filter predicate map =
       SMap.filter (fun symbol p -> predicate p) map
 
   end
 
 module type Parameter =
   sig
 
     type nature = private Internal | External
     type ptype = private Real | Complex
 
     type t = private
       { name : string;
 	nature : nature;
 	ptype : ptype;
 	value : value;
 	texname : string;
 	lhablock : string option;
 	lhacode : int list option;
         sequence : int }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
 
     val missing : string -> t
 
   end
 
 module Parameter : Parameter =
   struct
 
     type nature = Internal | External
 	
     let nature_to_string = function
       | Internal -> "internal"
       | External -> "external"
 
     let nature_of_string = function
       | "internal" -> Internal
       | "external" -> External
       | s -> invalid_arg ("Parameter.nature_of_string: " ^ s)
 	 
     type ptype = Real | Complex
 
     let ptype_to_string = function
       | Real -> "real"
       | Complex -> "complex"
 
     let ptype_of_string = function
       | "real" -> Real
       | "complex" -> Complex
       | s -> invalid_arg ("Parameter.ptype_of_string: " ^ s)
 
     type t =
       { name : string;
 	nature : nature;
 	ptype : ptype;
 	value : value;
 	texname : string;
 	lhablock : string option;
 	lhacode : int list option;
         sequence : int }
 
     let to_string symbol p =
       Printf.sprintf
 	"parameter: %s => [#%d, name = '%s', nature = %s, type = %s, \
                            value = %s, texname = '%s', \
                            lhablock = %s, lhacode = [%s]]"
 	symbol p.sequence p.name
 	(nature_to_string p.nature)
 	(ptype_to_string p.ptype)
 	(value_to_string p.value) p.texname
 	(match p.lhablock with None -> "???" | Some s -> s)
 	(match p.lhacode with
 	| None -> ""
 	| Some c -> String.concat ", " (List.map string_of_int c))
       
     let of_file1 (map, n) d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Parameter" ], attribs ->
          let required query name =
            required_handler "particle" symbol attribs query name in
          let name = required string_attrib "name" in
          warn_symbol_name "parameters" symbol name;
 	 (SMap.add symbol
 	    { name;
 	      nature = nature_of_string (required string_attrib "nature");
 	      ptype = ptype_of_string (required string_attrib "type");
 	      value = required value_attrib "value";
 	      texname = required string_attrib "texname";
 	      lhablock =
 	        (try Some (string_attrib "lhablock" attribs) with
 		   Not_found -> None);
 	      lhacode =
 	        (try Some (integer_list_attrib "lhacode" attribs) with
 		   Not_found -> None);
               sequence = n } map, succ n)
       | _ -> invalid_arg ("Parameter.of_file: " ^ name_to_string d.S.kind)
     
     let of_file parameters =
       let map, _ = List.fold_left of_file1 (SMap.empty, 0) parameters in
       map
 
     let missing name =
       { name;
 	nature = External;
 	ptype = Real;
 	value = Integer 0;
 	texname = Printf.sprintf "\\texttt{%s}" name;
 	lhablock = None;
 	lhacode = None;
         sequence = 0 }
 
   end
 
 module type Propagator_UFO =
   sig
 
     type t = (* private *)
       { name : string;
 	numerator : UFOx.Lorentz.t;
 	denominator : UFOx.Lorentz.t }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
 
   end
 
 module Propagator_UFO : Propagator_UFO =
   struct
 
     type t =
       { name : string;
 	numerator : UFOx.Lorentz.t;
 	denominator : UFOx.Lorentz.t }
 
     let to_string symbol p =
       Printf.sprintf
 	"propagator: %s => [name = '%s', numerator = '%s', \
                             denominator = '%s']"
 	symbol p.name
         (UFOx.Lorentz.to_string p.numerator)
         (UFOx.Lorentz.to_string p.denominator)
 
     (* The \texttt{denominator} attribute is optional and
        there is a default (cf.~\texttt{arXiv:1308.1668}) *)
     let default_denominator =
       "P('mu', id) * P('mu', id) \
        - Mass(id) * Mass(id) \
        + complex(0,1) * Mass(id) * Width(id)"
 
     let of_string_with_error_correction symbol num_or_den s =
       try
         UFOx.Lorentz.of_string s
       with
       | Invalid_argument msg ->
          begin
            let fixed = s ^ ")" in
            try
              let tensor = UFOx.Lorentz.of_string fixed in
              Printf.eprintf
                "UFO.Propagator.of_string: added missing closing parenthesis \
                 in %s of %s: \"%s\"\n"
                num_or_den symbol s;
              tensor
            with
            | Invalid_argument _ ->
               invalid_arg
                 (Printf.sprintf
                    "UFO.Propagator.of_string: %s of %s: %s in \"%s\"\n"
                    num_or_den symbol msg fixed)
          end
 
     (* The parser will turn [foo = "bar"] into [foo = "bar"."$"],
        which will be interpreted as a macro definition
        for [foo] expanding to ["bar"].   The dollar is used to
        distinguish it from an empty attribute list.  This
        could also be implemented with a union type for the
        declarations.  *)
 
     let of_file1 (macros, map) d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Propagator" ], attribs ->
          let required query name =
            required_handler "particle" symbol attribs query name
          and optional query name default =
            optional_handler attribs query name default in
         let name = required string_attrib "name" in
          warn_symbol_name "propagators" symbol name;
          let num_string = required string_attrib "numerator"
          and den_string =
 	   begin match optional find_attrib "denominator"
                                 (S.String default_denominator) with
 	   | S.String s -> s
 	   | S.Name [n] -> SMap.find n macros
 	   | _ -> invalid_arg "Propagator.denominator: "
 	   end in
          let numerator =
            of_string_with_error_correction symbol "numerator" num_string
          and denominator =
            of_string_with_error_correction symbol "denominator" den_string in
 	 (macros, SMap.add symbol { name; numerator; denominator } map)
       | [ "$"; s ], [] ->
 	 (SMap.add symbol s macros, map)
       | _ -> invalid_arg ("Propagator:of_file: " ^ name_to_string d.S.kind)
        
     let of_file propagators =
       let _, propagators' =
 	List.fold_left of_file1 (SMap.empty, SMap.empty) propagators in
       propagators'
 
   end
 
 module type Decay =
   sig
 
     type t = private
       { name : string;
 	particle : string;
 	widths : (string list * string) list }
 
     val of_file : S.t -> t SMap.t
     val to_string : string -> t -> string
 
   end
 
 module Decay : Decay =
   struct
 
     type t =
       { name : string;
 	particle : string;
 	widths : (string list * string) list }
 
     let width_to_string ws =
       String.concat ", "
 	(List.map
 	   (fun (ps, w) ->
 	     "(" ^ String.concat ", " ps ^ ") -> '" ^ w ^ "'")
 	   ws)
 
     let to_string symbol d =
       Printf.sprintf
 	"decay: %s => [name = '%s', particle = '%s', widths = [%s]]"
 	symbol d.name d.particle (width_to_string d.widths)
 
     let of_file1 map d =
       let symbol = d.S.name in
       match d.S.kind, d.S.attribs with
       | [ "Decay" ], attribs ->
          let required query name =
            required_handler "particle" symbol attribs query name in
          let name = required string_attrib "name" in
          warn_symbol_name "decays" symbol name;
 	 SMap.add symbol
 	   { name;
 	     particle = required (name_attrib ~strip:"P") "particle";
 	     widths = required decay_dictionary_attrib "partial_widths" } map
       | _ -> invalid_arg ("Decay.of_file: " ^ name_to_string d.S.kind)
 
     let of_file decays =
       List.fold_left of_file1 SMap.empty decays
 
   end
 
 (* We can read the spinor representations off the
    vertices to check for consistency. *)
 (* \begin{dubious}
      Note that we have to conjugate the representations!
    \end{dubious} *)
 
 let collect_spinor_reps_of_vertex particles lorentz v sets =
   List.fold_left
     (fun sets' lcc ->
       let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in
       List.fold_left
         (fun (spinors, conj_spinors as sets'') (i, rep) ->
           let p = v.Vertex.particles.(pred i) in
           match UFOx.Lorentz.omega rep with
           | Coupling.ConjSpinor -> (SSet.add p spinors, conj_spinors)
           | Coupling.Spinor -> (spinors, SSet.add p conj_spinors)
           | _ -> sets'')
         sets' (UFOx.Lorentz.classify_indices l))
     sets v.Vertex.lcc
 
 let collect_spinor_reps_of_vertices particles lorentz vertices =
   SMap.fold
     (fun _ v -> collect_spinor_reps_of_vertex particles lorentz v)
     vertices (SSet.empty, SSet.empty)
 
 let lorentz_reps_of_vertex particles v =
   ThoList.alist_of_list ~predicate:(not @@ UFOx.Lorentz.rep_trivial) ~offset:1
     (List.map
        (fun p ->
 	 (* Why do we need to conjugate??? *)
          UFOx.Lorentz.rep_conjugate
            (SMap.find p particles).Particle.spin)
        (Array.to_list v.Vertex.particles))
 
 let rep_compatible rep_vertex rep_particle =
   let open UFOx.Lorentz in
   let open Coupling in
   match omega rep_vertex, omega rep_particle with
   | (Spinor | ConjSpinor), Majorana -> true
   | r1, r2 -> r1 = r2
 
 let reps_compatible reps_vertex reps_particles =
   List.for_all2
     (fun (iv, rv) (ip, rp) -> iv = ip && rep_compatible rv rp)
     reps_vertex reps_particles
 
 let check_lorentz_reps_of_vertex particles lorentz v =
   let reps_particles =
     List.sort compare (lorentz_reps_of_vertex particles v) in
   List.iter
     (fun lcc ->
       let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in
       let reps_vertex = List.sort compare (UFOx.Lorentz.classify_indices l) in
       if not (reps_compatible reps_vertex reps_particles) then begin
 	Printf.eprintf "%s <> %s [%s]\n"
 	  (UFOx.Index.classes_to_string
 	     UFOx.Lorentz.rep_to_string reps_particles)
 	  (UFOx.Index.classes_to_string
 	     UFOx.Lorentz.rep_to_string reps_vertex)
           v.Vertex.name (* [(Vertex.to_string v.Vertex.name v)] *);
 	(* [invalid_arg "check_lorentz_reps_of_vertex"] *) ()
       end)
     v.Vertex.lcc
 
 let color_reps_of_vertex particles v =
   ThoList.alist_of_list ~predicate:(not @@ UFOx.Color.rep_trivial) ~offset:1
     (List.map
        (fun p -> (SMap.find p particles).Particle.color)
        (Array.to_list v.Vertex.particles))
 
 let check_color_reps_of_vertex particles v =
   let reps_particles =
     List.sort compare (color_reps_of_vertex particles v) in
   List.iter
     (fun lcc ->
       let reps_vertex =
         List.sort compare (UFOx.Color.classify_indices lcc.Vertex.color) in
       if reps_vertex <> reps_particles then begin
 	Printf.printf "%s <> %s\n"
 	  (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_particles)
 	  (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_vertex);
 	invalid_arg "check_color_reps_of_vertex"
      end)
     v.Vertex.lcc
 
 module P = Permutation.Default
 
 module type Lorentz =
   sig
 
     type spins = private
       | Unused
       | Unique of Coupling.lorentz array
       | Ambiguous of Coupling.lorentz array SMap.t
 
     type t = private
       { name : string;
         n : int;
 	spins : spins;
 	structure : UFO_Lorentz.t;
         fermion_lines : Coupling.fermion_lines }
 
     val permute : P.t -> t -> t
 
     val of_lorentz_UFO :
       Particle.t SMap.t -> Vertex.t SMap.t ->
       Lorentz_UFO.t SMap.t -> t SMap.t
 
     val lorentz_to_string : Coupling.lorentz -> string
     val to_string : string -> t -> string
 
   end
 
 module Lorentz : Lorentz =
   struct
 
     let rec lorentz_to_string = function
       | Coupling.Scalar -> "Scalar"
       | Coupling.Spinor -> "Spinor"
       | Coupling.ConjSpinor -> "ConjSpinor"
       | Coupling.Majorana -> "Majorana"
       | Coupling.Maj_Ghost -> "Maj_Ghost"
       | Coupling.Vector -> "Vector"
       | Coupling.Massive_Vector -> "Massive_Vector"
       | Coupling.Vectorspinor -> "Vectorspinor"
       | Coupling.Tensor_1 -> "Tensor_1"
       | Coupling.Tensor_2 -> "Tensor_2"
       | Coupling.BRS l -> "BRS(" ^ lorentz_to_string l ^ ")"
 
     (* Unlike UFO, O'Mega distinguishes bewteen spinors
        and conjugate spinors.  However, we can inspect
        the particles in the vertices in which a Lorentz
        structure is used to determine the correct
        quantum numbers.
 
        Most model files in the real world contain unused Lorentz
        structures.  This is not a problem, we can just ignore them. *)
 
     type spins =
       | Unused
       | Unique of Coupling.lorentz array
       | Ambiguous of Coupling.lorentz array SMap.t
 
     type t =
       { name : string;
         n : int;
 	spins : spins;
 	structure : UFO_Lorentz.t;
         fermion_lines : Coupling.fermion_lines }
 
     let permute_spins p = function
       | Unused -> Unused
       | Unique s -> Unique (P.array p s)
       | Ambiguous map -> Ambiguous (SMap.map (P.array p) map)
 
     (* Note that we apply the \emph{inverse} permutation to
        the indices in order to match the permutation of the
        particles/spins. *)
 
     let permute_structure n p (l, f) =
       let permuted = P.array (P.inverse p) (Array.init n succ) in
       let permute_index i =
         if i > 0 then
           UFOx.Index.map_position (fun pos -> permuted.(pred pos)) i
         else
           i in
       (UFO_Lorentz.map_indices permute_index l,
        UFO_Lorentz.map_fermion_lines permute_index f)
 
     let permute p l =
       let structure, fermion_lines =
         permute_structure l.n p (l.structure, l.fermion_lines) in
       { name = l.name ^ "_p" ^ P.to_string (P.inverse p);
         n = l.n;
         spins = permute_spins p l.spins;
         structure;
         fermion_lines }
 
     let omega_lorentz_reps n alist =
       let reps = Array.make n Coupling.Scalar in
       List.iter
         (fun (i, rep) -> reps.(pred i) <- UFOx.Lorentz.omega rep)
         alist;
       reps
 
     let contained lorentz vertex =
       List.exists
         (fun lcc1 -> lcc1.Vertex.lorentz = lorentz.Lorentz_UFO.name)
         vertex.Vertex.lcc
 
     (* Find all vertices in with the Lorentz structure [lorentz] is
        used and build a map from those vertices to the O'Mega
        Lorentz representations inferred from UFO's Lorentz
        structure and the [particles] involved.
        Then scan the bindings and check that we have inferred
        the same Lorentz representation from all vertices. *)
     let lorentz_reps_of_structure particles vertices lorentz =
       let uses =
         SMap.fold
           (fun name v acc ->
             if contained lorentz v then
               SMap.add
                 name
                 (omega_lorentz_reps
                    (Array.length v.Vertex.particles)
                    (lorentz_reps_of_vertex particles v)) acc
             else
               acc) vertices SMap.empty in
       let variants =
         ThoList.uniq (List.sort compare (List.map snd (SMap.bindings uses))) in
       match variants with
       | [] -> Unused
       | [s] -> Unique s
       | _ ->
          Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: AMBIGUOUS!\n";
          List.iter
            (fun variant ->
              Printf.eprintf
                "UFO.Lorentz.lorentz_reps_of_structure: %s\n"
                (ThoList.to_string lorentz_to_string (Array.to_list variant)))
            variants;
          Ambiguous uses
 
     let of_lorentz_tensor spins lorentz =
       match spins with
       | Unique s ->
          begin
            try
              Some (UFO_Lorentz.parse (Array.to_list s) lorentz)
            with
            | Failure msg ->
               begin
                 prerr_endline msg;
                 Some (UFO_Lorentz.dummy)
               end
          end
       | Unused ->
          Printf.eprintf
            "UFO.Lorentz: stripping unused structure %s\n"
            (UFOx.Lorentz.to_string lorentz);
          None
       | Ambiguous _ -> invalid_arg "UFO.Lorentz.of_lorentz_tensor: Ambiguous"
 
     let of_lorentz_UFO particles vertices lorentz_UFO =
       SMap.fold
         (fun name l acc ->
           let spins = lorentz_reps_of_structure particles vertices l in
           match of_lorentz_tensor spins l.Lorentz_UFO.structure with
           | None -> acc
           | Some structure ->
              SMap.add
                name
                { name = l.Lorentz_UFO.name;
                  n = List.length l.Lorentz_UFO.spins;
 	         spins;
 	         structure;
                  fermion_lines = UFO_Lorentz.fermion_lines structure }
                acc)
         lorentz_UFO SMap.empty
 
     let to_string symbol l =
       Printf.sprintf
 	"lorentz: %s => [name = '%s', spins = %s, \
                          structure = %s, fermion_lines = %s]"
 	symbol l.name
 	(match l.spins with
          | Unique s ->
             "[" ^ String.concat
                     ", " (List.map lorentz_to_string (Array.to_list s)) ^ "]"
          | Ambiguous _ -> "AMBIGUOUS!"
          | Unused -> "UNUSED!")
 	(UFO_Lorentz.to_string l.structure)
 	(UFO_Lorentz.fermion_lines_to_string l.fermion_lines)
 
   end
 
 (* According to arxiv:1308:1668, there should not be a factor
    of~$i$ in the numerators of propagators, but the (unused)
    \texttt{propagators.py} in most models violate this rule! *)
 let divide_propagators_by_i = ref false
 
 module type Propagator =
   sig
 
     type t = (* private *)
       { name : string;
         spins : Coupling.lorentz * Coupling.lorentz;
 	numerator : UFO_Lorentz.t;
 	denominator : UFO_Lorentz.t }
 
     val of_propagator_UFO : Propagator_UFO.t -> t
 
     val of_propagators_UFO :
       Particle.t SMap.t -> Propagator_UFO.t SMap.t -> t SMap.t
 
     val transpose : t -> t
 
     val to_string : string -> t -> string
 
   end
 
 module Propagator : Propagator =
   struct
 
     type t = (* private *)
       { name : string;
         spins : Coupling.lorentz * Coupling.lorentz;
 	numerator : UFO_Lorentz.t;
 	denominator : UFO_Lorentz.t }
 
     let lorentz_rep_at rep_classes i =
       try
         UFOx.Lorentz.omega (List.assoc i rep_classes)
       with
       | Not_found -> Coupling.Scalar
 
     let imaginary = Algebra.QC.make Algebra.Q.null Algebra.Q.unit
     let scalars = [Coupling.Scalar; Coupling.Scalar]
 
     (* If~$51$ and~$52$ show up as indices, we must
        map $(1,51)\to(1001,2001)$ and $(2,52)\to(1002,2002)$,
        as per the UFO conventions for Lorentz structures. *)
 
     (* \begin{dubious}
          This does not work yet, because [UFOx.Lorentz.map_indices]
          affects also the position argument of [P], [Mass] and [Width].
        \end{dubious} *)
 
     let contains_51_52 tensor =
       List.exists
         (fun (i, _) -> i = 51 || i = 52)
         (UFOx.Lorentz.classify_indices tensor)
 
     let remap_51_52 = function
       | 1 -> 1001 | 51 -> 2001
       | 2 -> 1002 | 52 -> 2002
       | i -> i
 
     let canonicalize_51_52 tensor =
       if contains_51_52 tensor then
         UFOx.Lorentz.rename_indices remap_51_52 tensor
       else
         tensor
 
     (* In the current conventions, the factor of~$i$ is not included: *)
     let of_propagator_UFO p =
       let numerator = canonicalize_51_52 p.Propagator_UFO.numerator in
       let lorentz_reps = UFOx.Lorentz.classify_indices numerator in
       let spin1 = lorentz_rep_at lorentz_reps 1
       and spin2 = lorentz_rep_at lorentz_reps 2 in
       let numerator_sans_i =
         if !divide_propagators_by_i then
           UFOx.Lorentz.map_coef (fun q -> Algebra.QC.div q imaginary) numerator
         else
           numerator in
       { name = p.Propagator_UFO.name;
         spins = (spin1, spin2);
         numerator = UFO_Lorentz.parse [spin1; spin2] numerator_sans_i;
         denominator = UFO_Lorentz.parse scalars p.Propagator_UFO.denominator }
 
     let of_propagators_UFO particles propagators_UFO =
       SMap.fold
         (fun name p acc -> SMap.add name (of_propagator_UFO p) acc)
         propagators_UFO SMap.empty
 
     let permute12 = function
       | 1 -> 2
       | 2 -> 1
       | n -> n
 
     let transpose_positions t =
       UFOx.Index.map_position permute12 t
 
     let transpose p =
       { name = p.name;
         spins = (snd p.spins, fst p.spins);
         numerator = UFO_Lorentz.map_indices transpose_positions p.numerator;
         denominator = p.denominator }
 
     let to_string symbol p =
       Printf.sprintf
 	"propagator: %s => [name = '%s', spin = '(%s, %s)', numerator/I = '%s', \
                             denominator = '%s']"
 	symbol p.name
         (Lorentz.lorentz_to_string (fst p.spins))
         (Lorentz.lorentz_to_string (snd p.spins))
         (UFO_Lorentz.to_string p.numerator)
         (UFO_Lorentz.to_string p.denominator)
 
   end
 
 type t =
   { particles : Particle.t SMap.t;
     particle_array : Particle.t array; (* for diagnostics *)
     couplings : UFO_Coupling.t SMap.t;
     coupling_orders : Coupling_Order.t SMap.t;
     vertices : Vertex.t SMap.t;
     lorentz_UFO : Lorentz_UFO.t SMap.t;
     lorentz : Lorentz.t SMap.t;
     parameters : Parameter.t SMap.t;
     propagators_UFO : Propagator_UFO.t SMap.t;
     propagators : Propagator.t SMap.t;
     decays : Decay.t SMap.t;
     nc : int }
 
 let use_majorana_spinors = ref false
 
 let fallback_to_majorana_if_necessary particles vertices lorentz_UFO =
   let majoranas =
     SMap.fold
       (fun p particle acc ->
         if Particle.is_majorana particle then
           SSet.add p acc
         else
           acc)
       particles SSet.empty in
   let spinors, conj_spinors =
     collect_spinor_reps_of_vertices particles lorentz_UFO vertices in
   let ambiguous =
     SSet.diff (SSet.inter spinors conj_spinors) majoranas in
   let no_majoranas = SSet.is_empty majoranas
   and no_ambiguities = SSet.is_empty ambiguous in
   if no_majoranas && no_ambiguities && not !use_majorana_spinors then
     SMap.mapi
       (fun p particle ->
         if SSet.mem p spinors then
           Particle.force_spinor particle
         else if SSet.mem p conj_spinors then
           Particle.force_conjspinor particle
         else
           particle)
       particles
   else
     begin
       if !use_majorana_spinors then
         Printf.eprintf "O'Mega: Majorana fermions requested.\n";
       if not no_majoranas then
         Printf.eprintf "O'Mega: found Majorana fermions!\n";
       if not no_ambiguities then
         Printf.eprintf
           "O'Mega: found ambiguous spinor representations for %s!\n"
           (String.concat ", " (SSet.elements ambiguous));
       Printf.eprintf
         "O'Mega: falling back to the Majorana representation for all fermions.\n";
       SMap.map Particle.force_majorana particles
     end
 
 let nc_of_particles particles =
   let nc_set =
     List.fold_left
       (fun nc_set (_, p) ->
         match UFOx.Color.omega p.Particle.color with
         | Color.Singlet -> nc_set
         | Color.SUN nc -> Sets.Int.add (abs nc) nc_set
         | Color.AdjSUN nc -> Sets.Int.add (abs nc) nc_set)
       Sets.Int.empty (SMap.bindings particles) in
   match Sets.Int.elements nc_set with
   | [] -> 0
   | [n] -> n
   | nc_list ->
      invalid_arg
        ("UFO.Model: more than one value of N_C: " ^
           String.concat ", " (List.map string_of_int nc_list))
 
 let of_file u =
   let particles = Particle.of_file u.Files.particles in
   let vertices = Vertex.of_file particles u.Files.vertices
   and lorentz_UFO = Lorentz_UFO.of_file u.Files.lorentz
   and propagators_UFO = Propagator_UFO.of_file u.Files.propagators in
   let particles =
     fallback_to_majorana_if_necessary particles vertices lorentz_UFO in
   let particle_array = Array.of_list (values particles)
   and lorentz = Lorentz.of_lorentz_UFO particles vertices lorentz_UFO
   and propagators = Propagator.of_propagators_UFO particles propagators_UFO in
   let model =
     { particles;
       particle_array;
       couplings = UFO_Coupling.of_file u.Files.couplings;
       coupling_orders = Coupling_Order.of_file u.Files.coupling_orders;
       vertices;
       lorentz_UFO;
       lorentz;
       parameters = Parameter.of_file u.Files.parameters;
       propagators_UFO;
       propagators;
       decays = Decay.of_file u.Files.decays;
       nc = nc_of_particles particles } in
   SMap.iter
     (fun _ v ->
       check_color_reps_of_vertex model.particles v;
       check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v)
     model.vertices;
   model
 
 let parse_directory dir =
   of_file (Files.parse_directory dir)
 
 let dump model =
   Printf.printf "NC = %d\n" model.nc;
   SMap.iter (print_endline @@@ Particle.to_string) model.particles;
   SMap.iter (print_endline @@@ UFO_Coupling.to_string) model.couplings;
   SMap.iter (print_endline @@@ Coupling_Order.to_string) model.coupling_orders;
   (* [SMap.iter (print_endline @@@ Vertex.to_string) model.vertices;] *)
   SMap.iter
     (fun symbol v ->
       (print_endline @@@ Vertex.to_string) symbol v;
       print_endline
         (Vertex.to_string_expanded model.lorentz_UFO model.couplings v))
     model.vertices;
   SMap.iter (print_endline @@@ Lorentz_UFO.to_string) model.lorentz_UFO;
   SMap.iter (print_endline @@@ Lorentz.to_string) model.lorentz;
   SMap.iter (print_endline @@@ Parameter.to_string) model.parameters;
   SMap.iter (print_endline @@@ Propagator_UFO.to_string) model.propagators_UFO;
   SMap.iter (print_endline @@@ Propagator.to_string) model.propagators;
   SMap.iter (print_endline @@@ Decay.to_string) model.decays;
   SMap.iter
     (fun symbol d ->
       List.iter (fun (_, w) -> ignore (UFOx.Expr.of_string w)) d.Decay.widths)
     model.decays
 
 exception Unhandled of string
 let unhandled s = raise (Unhandled s)
 
 module Model =
   struct
 
     (* NB: we could use [type flavor = Particle.t], but that would
        be very inefficient, because we will use [flavor] as a key
        for maps below. *)
     type flavor = int
     type constant = string
     type gauge = unit
 
     module M = Modeltools.Mutable
         (struct type f = flavor type g = gauge type c = constant end)
 
     let flavors = M.flavors
     let external_flavors = M.external_flavors
     let external_flavors = M.external_flavors
     let lorentz = M.lorentz
     let color = M.color
     let nc = M.nc
     let propagator = M.propagator
     let width = M.width
     let goldstone = M.goldstone
     let conjugate = M.conjugate
     let fermion = M.fermion
     let vertices = M.vertices
     let fuse2 = M.fuse2
     let fuse3 = M.fuse3
     let fuse = M.fuse
     let max_degree = M.max_degree
     let parameters = M.parameters
     let flavor_of_string = M.flavor_of_string
     let flavor_to_string = M.flavor_to_string
     let flavor_to_TeX = M.flavor_to_TeX
     let flavor_symbol = M.flavor_symbol
     let gauge_symbol = M.gauge_symbol
     let pdg = M.pdg
     let mass_symbol = M.mass_symbol
     let width_symbol = M.width_symbol
     let constant_symbol = M.constant_symbol
     module Ch = M.Ch
     let charges = M.charges
 
     let rec fermion_of_lorentz = function
       | Coupling.Spinor -> 1
       | Coupling.ConjSpinor -> -1
       | Coupling.Majorana -> 2
       | Coupling.Maj_Ghost -> 2
       | Coupling.Vectorspinor -> 1
       | Coupling.Vector | Coupling.Massive_Vector -> 0
       | Coupling.Scalar | Coupling.Tensor_1 | Coupling.Tensor_2 -> 0 
       | Coupling.BRS f -> fermion_of_lorentz f
 
     module Q = Algebra.Q
     module QC = Algebra.QC
 
     let dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1
     let dummy_tensor4 = Coupling.Scalar4 1
 
     let triplet p = (p.(0), p.(1), p.(2))
     let quartet p = (p.(0), p.(1), p.(2), p.(3))
 
     let half_times q1 q2 =
       Q.mul (Q.make 1 2) (Q.mul q1 q2)
 
     let name g =
       g.UFO_Coupling.name
 
     let fractional_coupling g r =
       let g = name g in
       match Q.to_ratio r with
       |  0, _ -> "0.0_default"
       |  1, 1 -> g
       | -1, 1 -> Printf.sprintf "(-%s)" g
       |  n, 1 -> Printf.sprintf "(%d*%s)" n g
       |  1, d -> Printf.sprintf "(%s/%d)" g d
       | -1, d -> Printf.sprintf "(-%s/%d)" g d
       |  n, d -> Printf.sprintf "(%d*%s/%d)" n g d
 
     let lorentz_of_symbol model symbol =
       try
 	SMap.find symbol model.lorentz
       with
       | Not_found -> invalid_arg ("lorentz_of_symbol: " ^ symbol)
 
     let lorentz_UFO_of_symbol model symbol =
       try
 	SMap.find symbol model.lorentz_UFO
       with
       | Not_found -> invalid_arg ("lorentz_UFO_of_symbol: " ^ symbol)
 
     let coupling_of_symbol model symbol =
       try
 	SMap.find symbol model.couplings
       with
       | Not_found -> invalid_arg ("coupling_of_symbol: " ^ symbol)
 
     let spin_triplet model name =
       match (lorentz_of_symbol model name).Lorentz.spins with
       | Lorentz.Unique [|s0; s1; s2|] -> (s0, s1, s2)
       | Lorentz.Unique _ -> invalid_arg "spin_triplet: wrong number of spins"
       | Lorentz.Unused -> invalid_arg "spin_triplet: Unused"
       | Lorentz.Ambiguous _ -> invalid_arg "spin_triplet: Ambiguous"
         
     let spin_quartet model name =
       match (lorentz_of_symbol model name).Lorentz.spins with
       | Lorentz.Unique [|s0; s1; s2; s3|] -> (s0, s1, s2, s3)
       | Lorentz.Unique _ -> invalid_arg "spin_quartet: wrong number of spins"
       | Lorentz.Unused -> invalid_arg "spin_quartet: Unused"
       | Lorentz.Ambiguous _ -> invalid_arg "spin_quartet: Ambiguous"
         
     let spin_multiplet model name =
       match (lorentz_of_symbol model name).Lorentz.spins with
       | Lorentz.Unique sarray -> sarray
       | Lorentz.Unused -> invalid_arg "spin_multiplet: Unused"
       | Lorentz.Ambiguous _ -> invalid_arg "spin_multiplet: Ambiguous"
 
     (* If we have reason to belive that a $\delta_{ab}$-vertex is
        an effective $\tr(T_aT_b)$-vertex generated at loop
        level, like~$gg\to H\ldots$ in the SM, we should interpret
        it as such and use the expression~(6.2) from~\cite{Kilian:2012pz}. *)
 
     (* AFAIK, there is no way to distinguish these cases directly
        in a UFO file.  Instead we rely in a heuristic, in which
        each massless color octet vector particle or ghost is a gluon
        and colorless scalars are potential Higgses. *)
 
     let is_massless p =
       match ThoString.uppercase p.Particle.mass with
       | "ZERO" -> true
       | _ -> false
 
     let is_gluon model f =
       let p = model.particle_array.(f) in
       match UFOx.Color.omega p.Particle.color,
             UFOx.Lorentz.omega p.Particle.spin with
       | Color.AdjSUN _, Coupling.Vector -> is_massless p
       | Color.AdjSUN _, Coupling.Scalar ->
          if p.Particle.ghost_number <> 0 then
            is_massless p
          else
            false
       | _ -> false
 
     let is_color_singlet model f =
       let p = model.particle_array.(f) in
       match UFOx.Color.omega p.Particle.color with
       | Color.Singlet -> true
       | _ -> false
 
     let is_higgs_gluon_vertex model p adjoints =
       if Array.length p > List.length adjoints then
         List.for_all
           (fun (i, p) ->
             if List.mem i adjoints then
               is_gluon model p
             else
               is_color_singlet model p)
           (ThoList.enumerate 1 (Array.to_list p))
       else
         false
 
     let delta8_heuristics model p a b =
       if is_higgs_gluon_vertex model p [a; b] then
         Color.Vertex.delta8_loop a b
       else
         Color.Vertex.delta8 a b
 
     let verbatim_higgs_glue = ref false
 
     let translate_color_atom model p = function
       | UFOx.Color_Atom.Identity (i, j) -> Color.Vertex.delta3 i j
       | UFOx.Color_Atom.Identity8 (a, b) ->
          if !verbatim_higgs_glue then
            Color.Vertex.delta8 a b
          else
            delta8_heuristics model p a b
       | UFOx.Color_Atom.T (a, i, j) -> Color.Vertex.t a i j
       | UFOx.Color_Atom.F (a, b, c) -> Color.Vertex.f a b c
       | UFOx.Color_Atom.D (a, b, c) -> Color.Vertex.d a b c
       | UFOx.Color_Atom.Epsilon (i, j, k) -> Color.Vertex.epsilon i j k
       | UFOx.Color_Atom.EpsilonBar (i, j, k) -> Color.Vertex.epsilonbar i j k
       | UFOx.Color_Atom.T6 (a, i, j) -> Color.Vertex.t6 a i j
       | UFOx.Color_Atom.K6 (i, j, k) -> Color.Vertex.k6 i j k
       | UFOx.Color_Atom.K6Bar (i, j, k) -> Color.Vertex.k6bar i j k
 
     let translate_color_term model p = function
       | [], q ->
          Color.Vertex.scale q Color.Vertex.unit
       | [atom], q ->
          Color.Vertex.scale q (translate_color_atom model p atom)
       | atoms, q ->
          let atoms = List.map (translate_color_atom model p) atoms in
          Color.Vertex.scale q (Color.Vertex.multiply atoms)
 
     let translate_color model p terms =
       match terms with
       | [] -> invalid_arg "translate_color: empty"
       | [ term ] -> translate_color_term model p term
       | terms ->
          Color.Vertex.sum (List.map (translate_color_term model p) terms)
 
     let translate_coupling_1 model p lcc =
       let l = lcc.Vertex.lorentz in
       let s = Array.to_list (spin_multiplet model l)
       and fl = (SMap.find l model.lorentz).Lorentz.fermion_lines
       and c = name (coupling_of_symbol model lcc.Vertex.coupling)
       and col = translate_color model p lcc.Vertex.color in
       (Array.to_list p, Coupling.UFO (QC.unit, l, s, fl, col), c)
 
     let translate_coupling model p lcc =
       List.map (translate_coupling_1 model p) lcc
 
     let long_flavors = ref false
 
     module type Lookup =
       sig
         type f = private
           { flavors : flavor list;
             flavor_of_string : string -> flavor;
             flavor_of_symbol : string -> flavor;
             particle : flavor -> Particle.t;
             flavor_symbol : flavor -> string;
             conjugate : flavor -> flavor }
         type flavor_format =
           | Long
           | Decimal
           | Hexadecimal
         val flavor_format : flavor_format ref
         val of_model : t -> f
       end
 
     module Lookup : Lookup =
       struct
 
         type f =
           { flavors : flavor list;
             flavor_of_string : string -> flavor;
             flavor_of_symbol : string -> flavor;
             particle : flavor -> Particle.t;
             flavor_symbol : flavor -> string;
             conjugate : flavor -> flavor }
             
         type flavor_format =
           | Long
           | Decimal
           | Hexadecimal
 
         let flavor_format = ref Hexadecimal
 
         let conjugate_of_particle_array particles =
           Array.init
 	    (Array.length particles)
 	    (fun i ->
 	      let f' = Particle.conjugate particles.(i) in
 	      match ThoArray.match_all f' particles with
 	      | [i'] -> i'
 	      | [] ->
 	         invalid_arg ("no charge conjugate: " ^ f'.Particle.name)
 	      | _ ->
 	         invalid_arg ("multiple charge conjugates: " ^ f'.Particle.name))
 
         let invert_flavor_array a =
           let table = SHash.create 37 in
           Array.iteri (fun i s -> SHash.add table s i) a;
           (fun name ->
 	    try
 	      SHash.find table name
 	    with
 	    | Not_found -> invalid_arg ("not found: " ^ name))
 
         let digits base n =
           let rec digits' acc n =
             if n < 1 then
               acc
             else
               digits' (succ acc) (n / base) in
           if n < 0 then
             digits' 1 (-n)
           else if n = 0 then
             1
           else
             digits' 0 n
 
         let of_model model =
           let particle_array = Array.of_list (values model.particles) in
           let conjugate_array = conjugate_of_particle_array particle_array
           and name_array = Array.map (fun f -> f.Particle.name) particle_array
           and symbol_array = Array.of_list (keys model.particles) in
           let flavor_symbol f =
             begin match !flavor_format with
             | Long -> symbol_array.(f)
             | Decimal -> 
                let w = digits 10 (Array.length particle_array - 1) in
                Printf.sprintf "%0*d" w f
             | Hexadecimal ->
                let w = digits 16 (Array.length particle_array - 1) in
                Printf.sprintf "%0*X" w f
             end in
           { flavors = ThoList.range 0 (Array.length particle_array - 1);
             flavor_of_string = invert_flavor_array name_array;
             flavor_of_symbol = invert_flavor_array symbol_array;
             particle = Array.get particle_array;
             flavor_symbol = flavor_symbol;
             conjugate = Array.get conjugate_array }
 
       end
 
     (* \begin{dubious}
          We appear to need to conjugate all flavors.  Why???
        \end{dubious} *)
     let translate_vertices model tables =
       let vn =
         List.fold_left
           (fun acc v ->
             let p = Array.map tables.Lookup.flavor_of_symbol v.Vertex.particles
             and lcc = v.Vertex.lcc in
             let p = Array.map conjugate p in (* FIXME: why? *)
             translate_coupling model p lcc @ acc)
           [] (values model.vertices) in
       ([], [], vn)
 
     let propagator_of_lorentz = function
       | Coupling.Scalar -> Coupling.Prop_Scalar
       | Coupling.Spinor -> Coupling.Prop_Spinor
       | Coupling.ConjSpinor -> Coupling.Prop_ConjSpinor
       | Coupling.Majorana -> Coupling.Prop_Majorana
       | Coupling.Maj_Ghost -> invalid_arg
          "UFO.Model.propagator_of_lorentz: SUSY ghosts do not propagate"
       | Coupling.Vector -> Coupling.Prop_Feynman
       | Coupling.Massive_Vector -> Coupling.Prop_Unitarity
       | Coupling.Tensor_2 -> Coupling.Prop_Tensor_2
       | Coupling.Vectorspinor -> invalid_arg
          "UFO.Model.propagator_of_lorentz: Vectorspinor"
       | Coupling.Tensor_1 -> invalid_arg
 	 "UFO.Model.propagator_of_lorentz: Tensor_1"
       | Coupling.BRS _ -> invalid_arg
          "UFO.Model.propagator_of_lorentz: no BRST"
 
     let filter_unphysical model =
       let physical_particles =
 	Particle.filter Particle.is_physical model.particles in
       let physical_particle_array =
         Array.of_list (values physical_particles) in
       let physical_vertices =
 	Vertex.filter
 	  (not @@ (Vertex.contains model.particles (not @@ Particle.is_physical)))
 	  model.vertices in
       { model with
         particles = physical_particles;
         particle_array = physical_particle_array;
         vertices = physical_vertices }
 
     let whizard_constants =
       SSet.of_list
         [ "ZERO" ]
 
     let filter_constants parameters =
       List.filter
         (fun p ->
           not (SSet.mem (ThoString.uppercase p.Parameter.name) whizard_constants))
         parameters
 
     let add_name set parameter =
       CSet.add parameter.Parameter.name set
 
     let hardcoded_parameters =
       CSet.of_list
         ["cmath.pi"]
 
     let missing_parameters input derived couplings =
       let input_parameters =
         List.fold_left add_name hardcoded_parameters input in
       let all_parameters =
         List.fold_left add_name input_parameters derived in
       let derived_dependencies =
         dependencies
           (List.map
              (fun p -> (p.Parameter.name, p.Parameter.value))
              derived) in
       let coupling_dependencies =
         dependencies
           (List.map
              (fun p -> (p.UFO_Coupling.name, Expr p.UFO_Coupling.value))
              (values couplings)) in
       let missing_input =
         CMap.filter
           (fun parameter derived_parameters ->
             not (CSet.mem parameter all_parameters))
           derived_dependencies
       and missing =
         CMap.filter
           (fun parameter couplings ->
             not (CSet.mem parameter all_parameters))
           coupling_dependencies in
       CMap.iter
         (fun parameter derived_parameters ->
           Printf.eprintf
             "UFO warning: undefined input parameter %s appears in derived \
              parameters {%s}: will be added to the list of input parameters!\n"
             parameter (String.concat "; " (CSet.elements derived_parameters)))
         missing_input;
       CMap.iter
         (fun parameter couplings ->
           Printf.eprintf
             "UFO warning: undefined parameter %s appears in couplings {%s}: \
              will be added to the list of input parameters!\n"
             parameter (String.concat "; " (CSet.elements couplings)))
         missing;
       keys_caseless missing_input @ keys_caseless missing
 
     let classify_parameters model =
       let compare_parameters p1 p2 =
         compare p1.Parameter.sequence p2.Parameter.sequence in
       let input, derived =
         List.fold_left
           (fun (input, derived) p ->
             match p.Parameter.nature with
             | Parameter.Internal -> (input, p :: derived)
             | Parameter.External ->
                begin match p.Parameter.ptype with
                | Parameter.Real -> ()
                | Parameter.Complex ->
                   Printf.eprintf
                     "UFO warning: invalid complex declaration of input \
                      parameter `%s' ignored!\n"
                     p.Parameter.name
                end;
                (p :: input, derived))
           ([], []) (filter_constants (values model.parameters)) in
       let additional = missing_parameters input derived model.couplings in
       (List.sort compare_parameters input @ List.map Parameter.missing additional,
        List.sort compare_parameters derived)
 
 (*i
       List.iter
         (fun line -> Printf.eprintf "par: %s\n" line)
         (dependencies_to_strings derived_dependencies);
       List.iter
         (fun line -> Printf.eprintf "coupling: %s\n" line)
         (dependencies_to_strings coupling_dependencies);
 i*)
 
     let translate_name map name =
       try SMap.find name map with Not_found -> name
 
     let translate_input map p =
       (translate_name map p.Parameter.name, value_to_float p.Parameter.value)
 
     let alpha_s_half e =
       UFOx.Expr.substitute "aS" (UFOx.Expr.half "aS") e
 
     let alpha_s_half_etc map e =
       UFOx.Expr.rename (map_to_alist map) (alpha_s_half e)
 
     let translate_derived map p =
       let make_atom s = s in
       let c = make_atom (translate_name map p.Parameter.name)
       and v =
         value_to_coupling (alpha_s_half_etc map) make_atom p.Parameter.value in
       match p.Parameter.ptype with
       | Parameter.Real -> (Coupling.Real c, v)
       | Parameter.Complex -> (Coupling.Complex c, v)
 
     let translate_coupling_constant map c =
       let make_atom s = s in
       (Coupling.Complex c.UFO_Coupling.name,
        Coupling.Quot
          (value_to_coupling
             (alpha_s_half_etc map) make_atom
             (Expr c.UFO_Coupling.value),
           Coupling.I))
 
     module Lowercase_Parameters =
       struct
         type elt = string
         type base = string
         let compare_elt = compare
         let compare_base = compare
         let pi = ThoString.lowercase
       end
 
     module Lowercase_Bundle = Bundle.Make (Lowercase_Parameters)
 
     let coupling_names model =
       SMap.fold
         (fun _ c acc -> c.UFO_Coupling.name :: acc)
         model.couplings []
 
     let parameter_names model =
       SMap.fold
         (fun _ c acc -> c.Parameter.name :: acc)
         model.parameters []
 
     let ambiguous_parameters model =
       let all_names =
         List.rev_append (coupling_names model) (parameter_names model) in
       let lc_bundle = Lowercase_Bundle.of_list all_names in
       let lc_set =
         List.fold_left
           (fun acc s -> SSet.add s acc)
           SSet.empty (Lowercase_Bundle.base lc_bundle)
       and ambiguities =
         List.filter
           (fun (_, names) -> List.length names > 1)
           (Lowercase_Bundle.fibers lc_bundle) in
       (lc_set, ambiguities)
 
     let disambiguate1 lc_set name =
       let rec disambiguate1' i =
         let name' = Printf.sprintf "%s_%d" name i in
         let lc_name' = ThoString.lowercase name' in
         if SSet.mem lc_name' lc_set then
           disambiguate1' (succ i)
         else
           (SSet.add lc_name' lc_set, name') in
       disambiguate1' 1
 
     let disambiguate lc_set names =
       let _, replacements =
         List.fold_left
           (fun (lc_set', acc) name ->
             let lc_set'', name' = disambiguate1 lc_set' name in
             (lc_set'', SMap.add name name' acc))
           (lc_set, SMap.empty) names in
       replacements
 
     let omegalib_names =
       ["u"; "ubar"; "v"; "vbar"; "eps"]
 
     let translate_parameters model =
       let lc_set, ambiguities = ambiguous_parameters model in
       let replacements =
         disambiguate lc_set (ThoList.flatmap snd ambiguities) in
       SMap.iter
         (Printf.eprintf
            "warning: case sensitive parameter names: renaming '%s' -> '%s'\n")
         replacements;
       let replacements =
         List.fold_left
           (fun acc name -> SMap.add name ("UFO_" ^ name) acc)
           replacements omegalib_names in
       let input_parameters, derived_parameters = classify_parameters model
       and couplings = values model.couplings in
       { Coupling.input =
           List.map (translate_input replacements) input_parameters;
         Coupling.derived =
           List.map (translate_derived replacements) derived_parameters @
             List.map (translate_coupling_constant replacements) couplings;
         Coupling.derived_arrays = [] }
 
     (* UFO requires us to look up the mass parameter to
        distinguish between massless and massive vectors.
 
        TODO: this is a candidate for another lookup table. *)
 
     let lorentz_of_particle p =
       match UFOx.Lorentz.omega p.Particle.spin with
       | Coupling.Vector ->
          begin match ThoString.uppercase p.Particle.mass with
          | "ZERO" -> Coupling.Vector
          | _ -> Coupling.Massive_Vector
          end
       | s -> s
 
     type state =
       { directory : string;
         model : t }
 
     let initialized = ref None
 
     let is_initialized_from dir =
       match !initialized with
       | None -> false
       | Some state -> dir = state.directory
 
     let dump_raw = ref false
 
     let init dir =
       let model = filter_unphysical (parse_directory dir) in
       if !dump_raw then
 	dump model;
       let tables = Lookup.of_model model in
       let vertices () = translate_vertices model tables in
       let particle f = tables.Lookup.particle f in
       let lorentz f = lorentz_of_particle (particle f) in
       let propagator f =
         let p = particle f in
         match p.Particle.propagator with
         | None -> propagator_of_lorentz (lorentz_of_particle p)
         | Some s -> Coupling.Prop_UFO s in
       let gauge_symbol () = "?GAUGE?" in
       let constant_symbol s = s in
       let parameters = translate_parameters model in
       M.setup
         ~color:(fun f -> UFOx.Color.omega (particle f).Particle.color)
         ~nc:(fun () -> model.nc)
         ~pdg:(fun f -> (particle f).Particle.pdg_code)
         ~lorentz
         ~propagator
         ~width:(fun f -> Coupling.Constant)
         ~goldstone:(fun f -> None)
         ~conjugate:tables.Lookup.conjugate
         ~fermion:(fun f -> fermion_of_lorentz (lorentz f))
         ~vertices
         ~flavors:[("All Flavors", tables.Lookup.flavors)]
         ~parameters:(fun () -> parameters)
         ~flavor_of_string:tables.Lookup.flavor_of_string
         ~flavor_to_string:(fun f -> (particle f).Particle.name)
         ~flavor_to_TeX:(fun f -> (particle f).Particle.texname)
         ~flavor_symbol:tables.Lookup.flavor_symbol
         ~gauge_symbol
         ~mass_symbol:(fun f -> (particle f).Particle.mass)
         ~width_symbol:(fun f -> (particle f).Particle.width)
         ~constant_symbol;
       initialized := Some { directory = dir; model = model }
 
     let ufo_directory = ref Config.default_UFO_dir
 
     let load () =
       if is_initialized_from !ufo_directory then
 	()
       else
 	init !ufo_directory
 
     let include_all_fusions = ref false
 
     let fusions_of_model ?only model =
       let include_fusion =
         match !include_all_fusions, only with
         | true, _
         | false, None -> (fun name -> true)
         | false, Some names -> (fun name -> SSet.mem name names)
       in
       SMap.fold
         (fun name l acc ->
           if include_fusion name then
             List.fold_left
               (fun acc p ->
                 let l' = Lorentz.permute p l in
                 match l'.Lorentz.spins with
                 | Lorentz.Unused -> acc
                 | Lorentz.Unique spins ->
                    (l'.Lorentz.name, spins, l'.Lorentz.structure) :: acc
                 | Lorentz.Ambiguous _ -> failwith "fusions: Lorentz.Ambiguous")
               [] (Permutation.Default.cyclic l.Lorentz.n) @ acc
           else
             acc)
         model.lorentz []
 
     let fusions ?only () =
       match !initialized with
       | None -> []
       | Some { model = model } -> fusions_of_model ?only model
 
     let propagators_of_model ?only model =
       let include_propagator =
         match !include_all_fusions, only with
         | true, _
         | false, None -> (fun name -> true)
         | false, Some names -> (fun name -> SSet.mem name names)
       in
       SMap.fold
         (fun name p acc ->
           if include_propagator name then
             (name, p) :: acc
           else
             acc)
         model.propagators []
 
     let propagators ?only () =
       match !initialized with
       | None -> []
       | Some { model = model } -> propagators_of_model ?only model
 
     let include_hadrons = ref true
 
     module Whizard : sig val write : unit -> unit end =
       struct
         
         let write_header dir =
           Printf.printf "# WHIZARD Model file derived from UFO directory\n";
           Printf.printf "#   '%s'\n\n" dir;
           Printf.printf "model \"%s\"\n\n" (Filename.basename dir)
 
         let write_input_parameters parameters =
           let open Parameter in
           Printf.printf "# Independent (input) Parameters\n";
           List.iter
             (fun p ->
               Printf.printf
-                "parameter %s = %s\n"
-                p.name (value_to_numeric p.value))
+                "parameter %s = %s"
+                p.name (value_to_numeric p.value);
+              begin match p.lhablock, p.lhacode with
+              | None, None -> ()
+              | Some name, Some (index :: indices) ->
+                 Printf.printf " slha_entry %s %d" name index;
+                 List.iter (fun i -> Printf.printf " %d" i) indices
+              | Some name, None ->
+                 Printf.eprintf
+                   "UFO: parameter %s: slhablock %s without slhacode\n"
+                   p.name name
+              | Some name, Some [] ->
+                 Printf.eprintf
+                   "UFO: parameter %s: slhablock %s with empty slhacode\n"
+                   p.name name
+              | None, Some _ ->
+                 Printf.eprintf
+                   "UFO: parameter %s: slhacode without slhablock\n"
+                   p.name
+              end;
+              Printf.printf "\n")
             parameters;
           Printf.printf "\n"
 
         let write_derived_parameters parameters =
           let open Parameter in
           Printf.printf "# Dependent (derived) Parameters\n";
           List.iter
             (fun p ->
               Printf.printf
                 "derived %s = %s\n"
                 p.name (value_to_expr alpha_s_half p.value))
             parameters
 
         let write_particles particles =
           let open Particle in
           Printf.printf "# Particles\n";
           Printf.printf "# NB: hypercharge assignments appear to be unreliable\n";
           Printf.printf "#     therefore we can't infer the isospin\n";
           Printf.printf "# NB: parton-, gauge- & handedness are unavailable\n";
           List.iter
             (fun p ->
               if not p.is_anti then begin
                   Printf.printf
                     "particle \"%s\" %d ### parton? gauge? left?\n"
                     p.name p.pdg_code;
                   Printf.printf
                     "  spin %s charge %s color %s ### isospin?\n"
                     (UFOx.Lorentz.rep_to_string_whizard p.spin)
                     (charge_to_string p.charge)
                     (UFOx.Color.rep_to_string_whizard p.color);
                   Printf.printf "  name \"%s\"\n" p.name;
                   if p.antiname <> p.name then
                     Printf.printf "  anti \"%s\"\n" p.antiname;
                   Printf.printf "  tex_name \"%s\"\n" p.texname;
                   if p.antiname <> p.name then
                     Printf.printf "  tex_anti \"%s\"\n" p.antitexname;
                   Printf.printf "  mass %s width %s\n\n" p.mass p.width
                 end)
             (values particles);
           Printf.printf "\n"
 
         let write_hadrons () =
           Printf.printf "# Hadrons (protons and beam remnants)\n";
           Printf.printf "# NB: these are NOT part of the UFO model\n";
           Printf.printf "#     but added for WHIZARD's convenience!\n";
           Printf.printf "particle PROTON 2212\n";
           Printf.printf "  spin 1/2  charge 1\n";
           Printf.printf "  name p \"p+\"\n";
           Printf.printf "  anti pbar \"p-\"\n";
           Printf.printf "particle HADRON_REMNANT 90\n";
           Printf.printf "  name hr\n";
           Printf.printf "  tex_name \"had_r\"\n";
           Printf.printf "particle HADRON_REMNANT_SINGLET 91\n";
           Printf.printf "  name hr1\n";
           Printf.printf "  tex_name \"had_r^{(1)}\"\n";
           Printf.printf "particle HADRON_REMNANT_TRIPLET 92\n";
           Printf.printf "  color 3\n";
           Printf.printf "  name hr3\n";
           Printf.printf "  tex_name \"had_r^{(3)}\"\n";
           Printf.printf "  anti hr3bar\n";
           Printf.printf "  tex_anti \"had_r^{(\\bar 3)}\"\n";
           Printf.printf "particle HADRON_REMNANT_OCTET 93\n";
           Printf.printf "  color 8\n";
           Printf.printf "  name hr8\n";
           Printf.printf "  tex_name \"had_r^{(8)}\"\n";
           Printf.printf "\n"
 
         let write_vertices model vertices  =
           Printf.printf "# Vertices (for phasespace generation only)\n";
           Printf.printf "# NB: particles should be sorted increasing in mass.\n";
           Printf.printf "#     This is NOT implemented yet!\n";
           List.iter
             (fun v ->
               let particles =
                 String.concat
                   " "
                   (List.map
                      (fun s ->
                        "\"" ^ (SMap.find s model.particles).Particle.name ^ "\"")
                      (Array.to_list v.Vertex.particles)) in
               Printf.printf "vertex %s\n" particles)
             (values vertices);
           Printf.printf "\n"
 
         let write () =
           match !initialized with
           | None -> failwith "UFO.Whizard.write: UFO model not initialized"
           | Some { directory = dir; model = model } ->
              let input_parameters, derived_parameters =
                classify_parameters model in
              write_header dir;
              write_input_parameters input_parameters;
              write_derived_parameters derived_parameters;
              write_particles model.particles;
              if !include_hadrons then
                write_hadrons ();
              write_vertices model model.vertices;
              exit 0
 
       end
 
     let options =
       Options.create
         [ ("UFO_dir", Arg.String (fun name -> ufo_directory := name),
            "UFO model directory (default: " ^ !ufo_directory ^ ")");
           ("Majorana", Arg.Set use_majorana_spinors,
            "use Majorana spinors (must come _before_ exec!)");
           ("divide_propagators_by_i", Arg.Set divide_propagators_by_i,
            "divide propagators by I (pre 2013 FeynRules convention)");
           ("verbatim_Hg", Arg.Set verbatim_higgs_glue,
            "don't correct the color flows for effective Higgs Gluon couplings");
           ("write_WHIZARD", Arg.Unit Whizard.write,
            "write the WHIZARD model file (required once per model)");
           ("long_flavors",
            Arg.Unit (fun () -> Lookup.flavor_format := Lookup.Long),
            "write use the UFO flavor names instead of integers");
           ("dump", Arg.Set dump_raw,
            "dump UFO model for debugging the parser (must come _before_ exec!)");
           ("all_fusions", Arg.Set include_all_fusions,
            "include all fusions in the fortran module");
           ("no_hadrons", Arg.Clear include_hadrons,
            "don't add any particle not in the UFO file");
           ("add_hadrons", Arg.Set include_hadrons,
            "add protons and beam remants for WHIZARD");
           ("exec", Arg.Unit load,
            "load the UFO model files (required _before_ using particles names)");
           ("help", Arg.Unit (fun () -> prerr_endline "..."),
            "print information on the model")]
 
   end
 
 module type Fortran_Target =
   sig
 
     val fuse :
       Algebra.QC.t -> string -> Coupling.lorentzn ->
       string -> string list -> string list -> Coupling.fusen -> unit
 
     val lorentz_module :
       ?only:SSet.t -> ?name:string -> ?fortran_module:string ->
       Format_Fortran.formatter -> unit -> unit
 
   end
 
 module Targets =
   struct
 
     module Fortran : Fortran_Target =
       struct
 
         open Format_Fortran
 
         let fuse = UFO_targets.Fortran.fuse
 
         let lorentz_functions ff fusions () =
           List.iter
             (fun (name, s, l) -> UFO_targets.Fortran.lorentz ff name s l)
             fusions
 
         let propagator_functions ff propagators () =
           List.iter
             (fun (name, p) ->
               UFO_targets.Fortran.propagator
                 ff name p.Propagator.spins
                 p.Propagator.numerator p.Propagator.denominator)
             propagators
 
         let lorentz_module
               ?only ?(name="omega_amplitude_ufo")
               ?(fortran_module="omega95") ff () =
           let printf fmt = fprintf ff fmt
           and nl = pp_newline ff in
           printf "module %s" name; nl ();
           printf "  use kinds"; nl ();
           printf "  use %s" fortran_module; nl ();
           printf "  implicit none"; nl ();
           printf "  private"; nl ();
           let fusions = Model.fusions ?only ()
           and propagators = Model.propagators () in
           List.iter
             (fun (name, _, _) -> printf "  public :: %s" name; nl ())
             fusions;
           List.iter
             (fun (name, _) -> printf "  public :: pr_U_%s" name; nl ())
             propagators;
           UFO_targets.Fortran.eps4_g4_g44_decl ff ();
           UFO_targets.Fortran.eps4_g4_g44_init ff ();
           printf "contains"; nl ();
           lorentz_functions ff fusions ();
           propagator_functions ff propagators ();
           printf "end module %s" name; nl ();
           pp_flush ff ()
 
       end
 
   end
 
 module type Test =
   sig
     val suite : OUnit.test
   end
 
 module Test : Test =
   struct
 
     open OUnit
 
     let lexer s =
       UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string s))
 
     let suite_lexer_escapes =
       "escapes" >:::
 
         [ "single-quote" >::
             (fun () ->
               assert_equal (UFO_parser.STRING "a'b'c") (lexer "'a\\'b\\'c'"));
 
           "unterminated" >::
             (fun () ->
               assert_raises End_of_file (fun () -> lexer "'a\\'b\\'c")) ]
 
     let suite_lexer =
       "lexer" >:::
         [suite_lexer_escapes]
 
     let suite =
       "UFO" >:::
         [suite_lexer]
 
   end
Index: trunk/src/model_features/model_features.nw
===================================================================
--- trunk/src/model_features/model_features.nw	(revision 8364)
+++ trunk/src/model_features/model_features.nw	(revision 8365)
@@ -1,16987 +1,16992 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: model features
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Model Handling and Features}
 \includemodulegraph{model_features}
 
 These modules deal with process definitions and physics models.
 
 These modules use the [[model_data]] methods to automatically generate
 process definitions.
 \begin{description}
 \item[auto\_components]
   Generic process-definition generator.  We can specify a basic
   process or initial particle(s) and some rules to extend this
   process, given a model definition with particle names and vertex
   structures.
 \item[radiation\_generator]
   Applies the generic generator to the specific problem of generating
   NLO corrections in a restricted setup.
 \end{description}
 
 Model construction:
 \begin{description}
 \item[eval\_trees]
   Implementation of the generic [[expr_t]] type for the concrete
   evaluation of expressions that access user variables.
 
   This module is actually part of the Sindarin language implementation, and
   should be moved elsewhere.  Currently, the [[models]] module relies
   on it.
 \item[models]
   Extends the [[model_data_t]] structure by user-variable objects for
   easy access, and provides the means to read a model definition from file.
 \item[slha\_interface]
   Read/write a SUSY model in the standardized SLHA format.  The format
   defines fields and parameters, but no vertices.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Automatic generation of process components}
 
 This module provides the functionality for automatically generating radiation
 corrections or decays, provided as lists of PDG codes.
 <<[[auto_components.f90]]>>=
 <<File header>>
 
 module auto_components
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use diagnostics
   use model_data
   use pdg_arrays
   use physics_defs, only: PHOTON, GLUON, Z_BOSON, W_BOSON
   use numeric_utils, only: extend_integer_array
 
 <<Standard module head>>
 
 <<Auto components: public>>
 
 <<Auto components: parameters>>
 
 <<Auto components: types>>
 
 <<Auto components: interfaces>>
 
 contains
 
 <<Auto components: procedures>>
 
 end module auto_components
 @ %def auto_components
 @
 \subsection{Constraints: Abstract types}
 An abstract type that denotes a constraint on the automatically generated
 states.  The concrete objects are applied as visitor objects at certain hooks
 during the splitting algorithm.
 <<Auto components: types>>=
   type, abstract :: split_constraint_t
   contains
   <<Auto components: split constraint: TBP>>
   end type split_constraint_t
 
 @ %def split_constraint_t
 @ By default, all checks return true.
 <<Auto components: split constraint: TBP>>=
   procedure :: check_before_split  => split_constraint_check_before_split
   procedure :: check_before_insert => split_constraint_check_before_insert
   procedure :: check_before_record => split_constraint_check_before_record
 <<Auto components: procedures>>=
   subroutine split_constraint_check_before_split (c, table, pl, k, passed)
     class(split_constraint_t), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: k
     logical, intent(out) :: passed
     passed = .true.
   end subroutine split_constraint_check_before_split
 
   subroutine split_constraint_check_before_insert (c, table, pa, pl, passed)
     class(split_constraint_t), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_array_t), intent(in) :: pa
     type(pdg_list_t), intent(inout) :: pl
     logical, intent(out) :: passed
     passed = .true.
   end subroutine split_constraint_check_before_insert
 
   subroutine split_constraint_check_before_record (c, table, pl, n_loop, passed)
     class(split_constraint_t), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     passed = .true.
   end subroutine split_constraint_check_before_record
 
 @ %def check_before_split
 @ %def check_before_insert
 @ %def check_before_record
 @ A transparent wrapper, so we can collect constraints of different type.
 <<Auto components: types>>=
   type :: split_constraint_wrap_t
      class(split_constraint_t), allocatable :: c
   end type split_constraint_wrap_t
 
 @ %def split_constraint_wrap_t
 @ A collection of constraints.
 <<Auto components: public>>=
   public :: split_constraints_t
 <<Auto components: types>>=
   type :: split_constraints_t
      class(split_constraint_wrap_t), dimension(:), allocatable :: cc
    contains
    <<Auto components: split constraints: TBP>>
   end type split_constraints_t
 
 @ %def split_constraints_t
 @ Initialize the constraints set with a specific number of elements.
 <<Auto components: split constraints: TBP>>=
   procedure :: init => split_constraints_init
 <<Auto components: procedures>>=
   subroutine split_constraints_init (constraints, n)
     class(split_constraints_t), intent(out) :: constraints
     integer, intent(in) :: n
     allocate (constraints%cc (n))
   end subroutine split_constraints_init
 
 @ %def split_constraints_init
 @ Set a constraint.
 <<Auto components: split constraints: TBP>>=
   procedure :: set => split_constraints_set
 <<Auto components: procedures>>=
   subroutine split_constraints_set (constraints, i, c)
     class(split_constraints_t), intent(inout) :: constraints
     integer, intent(in) :: i
     class(split_constraint_t), intent(in) :: c
     allocate (constraints%cc(i)%c, source = c)
   end subroutine split_constraints_set
 
 @ %def split_constraints_set
 @ Apply checks.
 
 [[check_before_split]] is applied to the particle list that we want
 to split.
 
 [[check_before_insert]] is applied to the particle list [[pl]] that is to
 replace the particle [[pa]] that is split.  This check may transform the
 particle list.
 
 [[check_before_record]] is applied to the complete new particle list that
 results from splitting before it is recorded.
 <<Auto components: split constraints: TBP>>=
   procedure :: check_before_split  => split_constraints_check_before_split
   procedure :: check_before_insert => split_constraints_check_before_insert
   procedure :: check_before_record => split_constraints_check_before_record
 <<Auto components: procedures>>=
   subroutine split_constraints_check_before_split &
        (constraints, table, pl, k, passed)
     class(split_constraints_t), intent(in) :: constraints
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: k
     logical, intent(out) :: passed
     integer :: i
     passed = .true.
     do i = 1, size (constraints%cc)
        call constraints%cc(i)%c%check_before_split (table, pl, k, passed)
        if (.not. passed)  return
     end do
   end subroutine split_constraints_check_before_split
 
   subroutine split_constraints_check_before_insert &
        (constraints, table, pa, pl, passed)
     class(split_constraints_t), intent(in) :: constraints
     class(ps_table_t), intent(in) :: table
     type(pdg_array_t), intent(in) :: pa
     type(pdg_list_t), intent(inout) :: pl
     logical, intent(out) :: passed
     integer :: i
     passed = .true.
     do i = 1, size (constraints%cc)
        call constraints%cc(i)%c%check_before_insert (table, pa, pl, passed)
        if (.not. passed)  return
     end do
   end subroutine split_constraints_check_before_insert
 
   subroutine split_constraints_check_before_record &
        (constraints, table, pl, n_loop, passed)
     class(split_constraints_t), intent(in) :: constraints
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     integer :: i
     passed = .true.
     do i = 1, size (constraints%cc)
        call constraints%cc(i)%c%check_before_record (table, pl, n_loop, passed)
        if (.not. passed)  return
     end do
   end subroutine split_constraints_check_before_record
 
 @ %def split_constraints_check_before_split
 @ %def split_constraints_check_before_insert
 @ %def split_constraints_check_before_record
 @
 \subsection{Specific constraints}
 \subsubsection{Number of particles}
 Specific constraint: The number of particles plus the number of loops, if
 any, must remain less than the given limit.  Note that the number of loops is
 defined only when we are recording the entry.
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_n_tot
      private
      integer :: n_max = 0
    contains
      procedure :: check_before_split => constraint_n_tot_check_before_split
      procedure :: check_before_record => constraint_n_tot_check_before_record
   end type constraint_n_tot
 
 @ %def constraint_n_tot
 <<Auto components: public>>=
   public :: constrain_n_tot
 <<Auto components: procedures>>=
   function constrain_n_tot (n_max) result (c)
     integer, intent(in) :: n_max
     type(constraint_n_tot) :: c
     c%n_max = n_max
   end function constrain_n_tot
 
   subroutine constraint_n_tot_check_before_split (c, table, pl, k, passed)
     class(constraint_n_tot), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: k
     logical, intent(out) :: passed
     passed = pl%get_size () < c%n_max
   end subroutine constraint_n_tot_check_before_split
 
   subroutine constraint_n_tot_check_before_record (c, table, pl, n_loop, passed)
     class(constraint_n_tot), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     passed = pl%get_size () + n_loop <= c%n_max
   end subroutine constraint_n_tot_check_before_record
 
 @ %def constrain_n_tot
 @ %def constraint_n_tot_check_before_insert
 @
 \subsubsection{Number of loops}
 Specific constraint: The number of loops is limited, independent of the
 total number of particles.
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_n_loop
      private
      integer :: n_loop_max = 0
    contains
      procedure :: check_before_record => constraint_n_loop_check_before_record
   end type constraint_n_loop
 
 @ %def constraint_n_loop
 <<Auto components: public>>=
   public :: constrain_n_loop
 <<Auto components: procedures>>=
   function constrain_n_loop (n_loop_max) result (c)
     integer, intent(in) :: n_loop_max
     type(constraint_n_loop) :: c
     c%n_loop_max = n_loop_max
   end function constrain_n_loop
 
   subroutine constraint_n_loop_check_before_record &
        (c, table, pl, n_loop, passed)
     class(constraint_n_loop), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     passed = n_loop <= c%n_loop_max
   end subroutine constraint_n_loop_check_before_record
 
 @ %def constrain_n_loop
 @ %def constraint_n_loop_check_before_insert
 @
 \subsubsection{Particles allowed in splitting}
 Specific constraint: The entries in the particle list ready for insertion
 are matched to a given list of particle patterns.  If a match occurs, the
 entry is replaced by the corresponding pattern. If there is no match, the
 check fails. If a massless gauge boson splitting is detected, the splitting
 partners are checked against a list of excluded particles. If a match
 occurs, the check fails.
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_splittings
      private
      type(pdg_list_t) :: pl_match, pl_excluded_gauge_splittings
    contains
      procedure :: check_before_insert => constraint_splittings_check_before_insert
   end type constraint_splittings
 
 @ %def constraint_splittings
 <<Auto components: public>>=
   public :: constrain_splittings
 <<Auto components: procedures>>=
   function constrain_splittings (pl_match, pl_excluded_gauge_splittings) result (c)
     type(pdg_list_t), intent(in) :: pl_match
     type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings
     type(constraint_splittings) :: c
     c%pl_match = pl_match
     c%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings
   end function constrain_splittings
 
   subroutine constraint_splittings_check_before_insert (c, table, pa, pl, passed)
     class(constraint_splittings), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_array_t), intent(in) :: pa
     type(pdg_list_t), intent(inout) :: pl
     logical, intent(out) :: passed
     logical :: has_massless_vector
     integer :: i
     has_massless_vector = .false.
     do i = 1, pa%get_length ()
        if (is_massless_vector(pa%get(i))) then
           has_massless_vector = .true.
           exit
        end if
     end do
     passed = .false.
     if (has_massless_vector .and. count (is_fermion(pl%a%get ())) == 2) then
        do i = 1, c%pl_excluded_gauge_splittings%get_size ()
           if (pl .match. c%pl_excluded_gauge_splittings%a(i)) return
        end do
        call pl%match_replace (c%pl_match, passed)
        passed = .true.
     else
        call pl%match_replace (c%pl_match, passed)
     end if
   end subroutine constraint_splittings_check_before_insert
 
 @ %def constrain_splittings
 @ %def constraint_splittings_check_before_insert
 @
 Specific constraint: The entries in the particle list ready for insertion
 are matched to a given list of particle patterns.  If a match occurs, the
 entry is replaced by the corresponding pattern.  If there is no match, the
 check fails.
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_insert
      private
      type(pdg_list_t) :: pl_match
    contains
      procedure :: check_before_insert => constraint_insert_check_before_insert
   end type constraint_insert
 
 @ %def constraint_insert
 <<Auto components: public>>=
   public :: constrain_insert
 <<Auto components: procedures>>=
   function constrain_insert (pl_match) result (c)
     type(pdg_list_t), intent(in) :: pl_match
     type(constraint_insert) :: c
     c%pl_match = pl_match
   end function constrain_insert
 
   subroutine constraint_insert_check_before_insert (c, table, pa, pl, passed)
     class(constraint_insert), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_array_t), intent(in) :: pa
     type(pdg_list_t), intent(inout) :: pl
     logical, intent(out) :: passed
     call pl%match_replace (c%pl_match, passed)
   end subroutine constraint_insert_check_before_insert
 
 @ %def constrain_insert
 @ %def constraint_insert_check_before_insert
 @
 \subsubsection{Particles required in final state}
 Specific constraint: The entries in the recorded state must be a superset of
 the entries in the given list (for instance, the lowest-order
 state).
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_require
      private
      type(pdg_list_t) :: pl
    contains
      procedure :: check_before_record => constraint_require_check_before_record
   end type constraint_require
 
 @ %def constraint_require
 @ We check the current state by matching all particle entries against the
 stored particle list, and crossing out the particles in the latter list when a
 match is found.  The constraint passed if all entries have been crossed out.
 
 For an [[if_table]] in particular, we check the final state only.
 <<Auto components: public>>=
   public :: constrain_require
 <<Auto components: procedures>>=
   function constrain_require (pl) result (c)
     type(pdg_list_t), intent(in) :: pl
     type(constraint_require) :: c
     c%pl = pl
   end function constrain_require
 
   subroutine constraint_require_check_before_record &
        (c, table, pl, n_loop, passed)
     class(constraint_require), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     logical, dimension(:), allocatable :: mask
     integer :: i, k, n_in
     select type (table)
     type is (if_table_t)
        if (table%proc_type > 0) then
           select case (table%proc_type)
           case (PROC_DECAY)
              n_in = 1
           case (PROC_SCATTER)
              n_in = 2
           end select
        else
           call msg_fatal ("Neither a decay nor a scattering process")
        end if
     class default
        n_in = 0
     end select
     allocate (mask (c%pl%get_size ()), source = .true.)
     do i = n_in + 1, pl%get_size ()
        k = c%pl%find_match (pl%get (i), mask)
        if (k /= 0)  mask(k) = .false.
     end do
     passed = .not. any (mask)
   end subroutine constraint_require_check_before_record
 
 @ %def constrain_require
 @ %def constraint_require_check_before_record
 @
 \subsubsection{Radiation}
 Specific constraint: We have radiation pattern if the original particle
 matches an entry in the list of particles that should replace it.  The
 constraint prohibits this situation.
 <<Auto components: public>>=
   public :: constrain_radiation
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_radiation
      private
    contains
      procedure :: check_before_insert => &
           constraint_radiation_check_before_insert
   end type constraint_radiation
 
 @ %def constraint_radiation
 <<Auto components: procedures>>=
   function constrain_radiation () result (c)
     type(constraint_radiation) :: c
   end function constrain_radiation
 
   subroutine constraint_radiation_check_before_insert (c, table, pa, pl, passed)
     class(constraint_radiation), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_array_t), intent(in) :: pa
     type(pdg_list_t), intent(inout) :: pl
     logical, intent(out) :: passed
     passed = .not. (pl .match. pa)
   end subroutine constraint_radiation_check_before_insert
 
 @ %def constrain_radiation
 @ %def constraint_radiation_check_before_insert
 @
 \subsubsection{Mass sum}
 Specific constraint: The sum of masses within the particle list must
 be smaller than a given limit.  For in/out state combinations, we
 check initial and final state separately.
 
 If we specify [[margin]] in the initialization, the sum must be
 strictly less than the limit minus the given margin (which may be
 zero).  If not, equality is allowed.
 <<Auto components: public>>=
   public :: constrain_mass_sum
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_mass_sum
      private
      real(default) :: mass_limit = 0
      logical :: strictly_less = .false.
      real(default) :: margin = 0
    contains
      procedure :: check_before_record => constraint_mass_sum_check_before_record
   end type constraint_mass_sum
 
 @ %def contraint_mass_sum
 <<Auto components: procedures>>=
   function constrain_mass_sum (mass_limit, margin) result (c)
     real(default), intent(in) :: mass_limit
     real(default), intent(in), optional :: margin
     type(constraint_mass_sum) :: c
     c%mass_limit = mass_limit
     if (present (margin)) then
        c%strictly_less = .true.
        c%margin = margin
     end if
   end function constrain_mass_sum
 
   subroutine constraint_mass_sum_check_before_record &
        (c, table, pl, n_loop, passed)
     class(constraint_mass_sum), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     real(default) :: limit
     if (c%strictly_less) then
        limit = c%mass_limit - c%margin
        select type (table)
        type is (if_table_t)
           passed = mass_sum (pl, 1, 2, table%model) < limit  &
                .and. mass_sum (pl, 3, pl%get_size (), table%model) < limit
        class default
           passed = mass_sum (pl, 1, pl%get_size (), table%model) < limit
        end select
     else
        limit = c%mass_limit
        select type (table)
        type is (if_table_t)
           passed = mass_sum (pl, 1, 2, table%model) <= limit &
                .and. mass_sum (pl, 3, pl%get_size (), table%model) <= limit
        class default
           passed = mass_sum (pl, 1, pl%get_size (), table%model) <= limit
        end select
     end if
   end subroutine constraint_mass_sum_check_before_record
 
 @ %def constrain_mass_sum
 @ %def constraint_mass_sum_check_before_record
 @
 \subsubsection{Initial state particles}
 Specific constraint: The two incoming particles must both match the given
 particle list.  This is checked for the generated particle list, just before
 it is recorded.
 <<Auto components: public>>=
   public :: constrain_in_state
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_in_state
      private
      type(pdg_list_t) :: pl
    contains
      procedure :: check_before_record => constraint_in_state_check_before_record
   end type constraint_in_state
 
 @ %def constraint_in_state
 <<Auto components: procedures>>=
   function constrain_in_state (pl) result (c)
     type(pdg_list_t), intent(in) :: pl
     type(constraint_in_state) :: c
     c%pl = pl
   end function constrain_in_state
 
   subroutine constraint_in_state_check_before_record &
        (c, table, pl, n_loop, passed)
     class(constraint_in_state), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     integer :: i
     select type (table)
     type is (if_table_t)
        passed = .false.
        do i = 1, 2
           if (.not. (c%pl .match. pl%get (i)))  return
        end do
     end select
     passed = .true.
   end subroutine constraint_in_state_check_before_record
 
 @ %def constrain_in_state
 @ %def constraint_in_state_check_before_record
 @
 \subsubsection{Photon induced processes}
 If set, filter out photon induced processes.
 <<Auto components: public>>=
   public :: constrain_photon_induced_processes
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_photon_induced_processes
      private
      integer :: n_in
    contains
      procedure :: check_before_record => &
           constraint_photon_induced_processes_check_before_record
   end type constraint_photon_induced_processes
 
 @ %def constraint_photon_induced_processes
 <<Auto components: procedures>>=
   function constrain_photon_induced_processes (n_in) result (c)
     integer, intent(in) :: n_in
     type(constraint_photon_induced_processes) :: c
     c%n_in = n_in
   end function constrain_photon_induced_processes
 
   subroutine constraint_photon_induced_processes_check_before_record &
        (c, table, pl, n_loop, passed)
     class(constraint_photon_induced_processes), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop
     logical, intent(out) :: passed
     integer :: i
     select type (table)
     type is (if_table_t)
        passed = .false.
        do i = 1, c%n_in
           if (pl%a(i)%get () == 22)  return
        end do
     end select
     passed = .true.
   end subroutine constraint_photon_induced_processes_check_before_record
 
 @ %def constrain_photon_induced_processes
 @ %def constraint_photon_induced_processes_check_before_record
 @
 \subsubsection{Coupling constraint}
 Filters vertices which do not match the desired NLO pattern.
 <<Auto components: types>>=
   type, extends (split_constraint_t) :: constraint_coupling_t
     private
     logical :: qed = .false.
     logical :: qcd = .true.
     logical :: ew = .false.
     integer :: n_nlo_correction_types
   contains
   <<Auto components: constraint coupling: TBP>>
   end type constraint_coupling_t
 
 @ %def constraint_coupling_t
 @
 <<Auto components: public>>=
   public :: constrain_couplings
 <<Auto components: procedures>>=
   function constrain_couplings (qcd, qed, n_nlo_correction_types) result (c)
     type(constraint_coupling_t) :: c
     logical, intent(in) :: qcd, qed
     integer, intent(in) :: n_nlo_correction_types
     c%qcd = qcd; c%qed = qed
     c%n_nlo_correction_types = n_nlo_correction_types
   end function constrain_couplings
 
 @ %def constrain_couplings
 @
 <<Auto components: constraint coupling: TBP>>=
   procedure :: check_before_insert => constraint_coupling_check_before_insert
 <<Auto components: procedures>>=
   subroutine constraint_coupling_check_before_insert (c, table, pa, pl, passed)
     class(constraint_coupling_t), intent(in) :: c
     class(ps_table_t), intent(in) :: table
     type(pdg_array_t), intent(in) :: pa
     type(pdg_list_t), intent(inout) :: pl
     logical, intent(out) :: passed
     type(pdg_list_t) :: pl_vertex
     type(pdg_array_t) :: pdg_gluon, pdg_photon, pdg_W_Z, pdg_gauge_bosons
     integer :: i, j
     pdg_gluon = GLUON; pdg_photon = PHOTON
     pdg_W_Z = [W_BOSON,-W_BOSON, Z_BOSON]
     if (c%qcd) pdg_gauge_bosons = pdg_gauge_bosons // pdg_gluon
     if (c%qed) pdg_gauge_bosons = pdg_gauge_bosons // pdg_photon
     if (c%ew) pdg_gauge_bosons = pdg_gauge_bosons // pdg_W_Z
     do j = 1, pa%get_length ()
        call pl_vertex%init (pl%get_size () + 1)
        call pl_vertex%set (1, pa%get(j))
        do i = 1, pl%get_size ()
           call pl_vertex%set (i + 1, pl%get(i))
        end do
        if (pl_vertex%get_size () > 3) then
           passed = .false.
           cycle
        end if
        if (is_massless_vector(pa%get(j))) then
           if (.not. table%model%check_vertex &
                (pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then
              passed = .false.
              cycle
           end if
        else if (.not. table%model%check_vertex &
             (- pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then
           passed = .false.
           cycle
        end if
        if (.not. (pl_vertex .match. pdg_gauge_bosons)) then
           passed = .false.
           cycle
        end if
        passed = .true.
        exit
     end do
   end subroutine constraint_coupling_check_before_insert
 
 @ %def constraint_coupling_check_before_insert
 @
 \subsection{Tables of states}
 Automatically generate a list of possible process components for a given
 initial set (a single massive particle or a preset list of states).
 
 The set of process components are generated by recursive splitting, applying
 constraints on the fly that control and limit the process.  The generated
 states are accumulated in a table that we can read out after completion.
 <<Auto components: types>>=
   type, extends (pdg_list_t) :: ps_entry_t
      integer :: n_loop = 0
      integer :: n_rad = 0
      type(ps_entry_t), pointer :: previous => null ()
      type(ps_entry_t), pointer :: next => null ()
   end type ps_entry_t
 
 @ %def ps_entry_t
 @
 <<Auto components: parameters>>=
   integer, parameter :: PROC_UNDEFINED = 0
   integer, parameter :: PROC_DECAY = 1
   integer, parameter :: PROC_SCATTER = 2
 
 @ %def auto_components parameters
 @ This is the wrapper type for the decay tree for the list of final
 states and the final array.  First, an abstract base type:
 <<Auto components: public>>=
   public :: ps_table_t
 <<Auto components: types>>=
   type, abstract :: ps_table_t
      private
      class(model_data_t), pointer :: model => null ()
      logical :: loops = .false.
      type(ps_entry_t), pointer :: first => null ()
      type(ps_entry_t), pointer :: last => null ()
      integer :: proc_type
    contains
    <<Auto components: ps table: TBP>>
   end type ps_table_t
 
 @ %def ps_table_t
 @ The extensions: one for decay, one for generic final states.  The decay-state
 table stores the initial particle.  The final-state table is
 indifferent, and the initial/final state table treats the first two
 particles in its list as incoming antiparticles.
 <<Auto components: public>>=
   public :: ds_table_t
   public :: fs_table_t
   public :: if_table_t
 <<Auto components: types>>=
   type, extends (ps_table_t) :: ds_table_t
      private
      integer :: pdg_in = 0
    contains
    <<Auto components: ds table: TBP>>
   end type ds_table_t
 
   type, extends (ps_table_t) :: fs_table_t
    contains
    <<Auto components: fs table: TBP>>
   end type fs_table_t
 
   type, extends (fs_table_t) :: if_table_t
    contains
    <<Auto components: if table: TBP>>
   end type if_table_t
 
 @ %def ds_table_t fs_table_t if_table_t
 @ Finalizer: we must deallocate the embedded list.
 <<Auto components: ps table: TBP>>=
   procedure :: final => ps_table_final
 <<Auto components: procedures>>=
   subroutine ps_table_final (object)
     class(ps_table_t), intent(inout) :: object
     type(ps_entry_t), pointer :: current
     do while (associated (object%first))
        current => object%first
        object%first => current%next
        deallocate (current)
     end do
     nullify (object%last)
   end subroutine ps_table_final
 
 @ %def ps_table_final
 @ Write the table.  A base writer for the body and specific writers
 for the headers.
 <<Auto components: ps table: TBP>>=
   procedure :: base_write => ps_table_base_write
   procedure (ps_table_write), deferred :: write
 <<Auto components: interfaces>>=
   interface
      subroutine ps_table_write (object, unit)
        import
        class(ps_table_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine ps_table_write
   end interface
 <<Auto components: ds table: TBP>>=
   procedure :: write => ds_table_write
 <<Auto components: fs table: TBP>>=
   procedure :: write => fs_table_write
 <<Auto components: if table: TBP>>=
   procedure :: write => if_table_write
 @ The first [[n_in]] particles will be replaced by antiparticles in
 the output, and we write an arrow if [[n_in]] is present.
 <<Auto components: procedures>>=
   subroutine ps_table_base_write (object, unit, n_in)
     class(ps_table_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: n_in
     integer, dimension(:), allocatable :: pdg
     type(ps_entry_t), pointer :: entry
     type(field_data_t), pointer :: prt
     integer :: u, i, j, n0
     u = given_output_unit (unit)
     entry => object%first
     do while (associated (entry))
        write (u, "(2x)", advance = "no")
        if (present (n_in)) then
           do i = 1, n_in
              write (u, "(1x)", advance = "no")
              pdg = entry%get (i)
              do j = 1, size (pdg)
                 prt => object%model%get_field_ptr (pdg(j))
                 if (j > 1)  write (u, "(':')", advance = "no")
                 write (u, "(A)", advance = "no") &
                      char (prt%get_name (pdg(j) >= 0))
              end do
           end do
           write (u, "(1x,A)", advance = "no")  "=>"
           n0 = n_in + 1
        else
           n0 = 1
        end if
        do i = n0, entry%get_size ()
           write (u, "(1x)", advance = "no")
           pdg = entry%get (i)
           do j = 1, size (pdg)
              prt => object%model%get_field_ptr (pdg(j))
              if (j > 1)  write (u, "(':')", advance = "no")
              write (u, "(A)", advance = "no") &
                   char (prt%get_name (pdg(j) < 0))
           end do
        end do
        if (object%loops) then
           write (u, "(2x,'[',I0,',',I0,']')")  entry%n_loop, entry%n_rad
        else
           write (u, "(A)")
        end if
        entry => entry%next
     end do
   end subroutine ps_table_base_write
 
   subroutine ds_table_write (object, unit)
     class(ds_table_t), intent(in) :: object
     integer, intent(in), optional :: unit
     type(field_data_t), pointer :: prt
     integer :: u
     u = given_output_unit (unit)
     prt => object%model%get_field_ptr (object%pdg_in)
     write (u, "(1x,A,1x,A)")  "Decays for particle:", &
          char (prt%get_name (object%pdg_in < 0))
     call object%base_write (u)
   end subroutine ds_table_write
 
   subroutine fs_table_write (object, unit)
     class(fs_table_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Table of final states:"
     call object%base_write (u)
   end subroutine fs_table_write
 
   subroutine if_table_write (object, unit)
     class(if_table_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Table of in/out states:"
     select case (object%proc_type)
     case (PROC_DECAY)
        call object%base_write (u, n_in = 1)
     case (PROC_SCATTER)
        call object%base_write (u, n_in = 2)
      end select
   end subroutine if_table_write
 
 @ %def ps_table_write ds_table_write fs_table_write
 @ Obtain a particle string for a given index in the pdg list
 <<Auto components: ps table: TBP>>=
   procedure :: get_particle_string => ps_table_get_particle_string
 <<Auto components: procedures>>=
   subroutine ps_table_get_particle_string (object, index, prt_in, prt_out)
     class(ps_table_t), intent(in) :: object
     integer, intent(in) :: index
     type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out
     integer :: n_in
     type(field_data_t), pointer :: prt
     type(ps_entry_t), pointer :: entry
     integer, dimension(:), allocatable :: pdg
     integer :: n0
     integer :: i, j
     entry => object%first
     i = 1
     do while (i < index)
       if (associated (entry%next)) then
          entry => entry%next
          i = i + 1
       else
          call msg_fatal ("ps_table: entry with requested index does not exist!")
       end if
     end do
 
     if (object%proc_type > 0) then
        select case (object%proc_type)
        case (PROC_DECAY)
           n_in = 1
        case (PROC_SCATTER)
           n_in = 2
        end select
     else
        call msg_fatal ("Neither decay nor scattering process")
     end if
 
     n0 = n_in + 1
     allocate (prt_in (n_in), prt_out (entry%get_size () - n_in))
     do i = 1, n_in
        prt_in(i) = ""
        pdg = entry%get(i)
        do j = 1, size (pdg)
           prt => object%model%get_field_ptr (pdg(j))
           prt_in(i) = prt_in(i) // prt%get_name (pdg(j) >= 0)
           if (j /= size (pdg))  prt_in(i) = prt_in(i) // ":"
        end do
     end do
     do i = n0, entry%get_size ()
        prt_out(i-n_in) = ""
        pdg = entry%get(i)
        do j = 1, size (pdg)
           prt => object%model%get_field_ptr (pdg(j))
           prt_out(i-n_in) = prt_out(i-n_in) // prt%get_name (pdg(j) < 0)
           if (j /= size (pdg))  prt_out(i-n_in) = prt_out(i-n_in) // ":"
        end do
     end do
   end subroutine ps_table_get_particle_string
 
 @ %def ps_table_get_particle_string
 @ Initialize with a predefined set of final states, or in/out state lists.
 <<Auto components: ps table: TBP>>=
   generic :: init => ps_table_init
   procedure, private :: ps_table_init
 <<Auto components: if table: TBP>>=
   generic :: init => if_table_init
   procedure, private :: if_table_init
 <<Auto components: procedures>>=
   subroutine ps_table_init (table, model, pl, constraints, n_in, do_not_check_regular)
     class(ps_table_t), intent(out) :: table
     class(model_data_t), intent(in), target :: model
     type(pdg_list_t), dimension(:), intent(in) :: pl
     type(split_constraints_t), intent(in) :: constraints
     integer, intent(in), optional :: n_in
     logical, intent(in), optional :: do_not_check_regular
     logical :: passed
     integer :: i
     table%model => model
 
     if (present (n_in)) then
        select case (n_in)
        case (1)
           table%proc_type = PROC_DECAY
        case (2)
           table%proc_type = PROC_SCATTER
        case default
           table%proc_type = PROC_UNDEFINED
        end select
     else
        table%proc_type = PROC_UNDEFINED
     end if
 
     do i = 1, size (pl)
        call table%record (pl(i), 0, 0, constraints, &
             do_not_check_regular, passed)
        if (.not. passed) then
           call msg_fatal ("ps_table: Registering process components failed")
        end if
     end do
   end subroutine ps_table_init
 
   subroutine if_table_init (table, model, pl_in, pl_out, constraints)
     class(if_table_t), intent(out) :: table
     class(model_data_t), intent(in), target :: model
     type(pdg_list_t), dimension(:), intent(in) :: pl_in, pl_out
     type(split_constraints_t), intent(in) :: constraints
     integer :: i, j, k, p, n_in, n_out
     type(pdg_array_t), dimension(:), allocatable :: pa_in
     type(pdg_list_t), dimension(:), allocatable :: pl
     allocate (pl (size (pl_in) * size (pl_out)))
     k = 0
     do i = 1, size (pl_in)
        n_in = pl_in(i)%get_size ()
        allocate (pa_in (n_in))
        do p = 1, n_in
           pa_in(p) = pl_in(i)%get (p)
        end do
        do j = 1, size (pl_out)
           n_out = pl_out(j)%get_size ()
           k = k + 1
           call pl(k)%init (n_in + n_out)
           do p = 1, n_in
              call pl(k)%set (p, invert_pdg_array (pa_in(p), model))
           end do
           do p = 1, n_out
              call pl(k)%set (n_in + p, pl_out(j)%get (p))
           end do
        end do
        deallocate (pa_in)
     end do
     n_in = size (pl_in(1)%a)
     call table%init (model, pl, constraints, n_in, do_not_check_regular = .true.)
   end subroutine if_table_init
 
 @ %def ps_table_init if_table_init
 @ Enable loops for the table.  This affects both splitting and output.
 <<Auto components: ps table: TBP>>=
   procedure :: enable_loops => ps_table_enable_loops
 <<Auto components: procedures>>=
   subroutine ps_table_enable_loops (table)
     class(ps_table_t), intent(inout) :: table
     table%loops = .true.
   end subroutine ps_table_enable_loops
 
 @ %def ps_table_enable_loops
 @
 \subsection{Top-level methods}
 Create a table for a single-particle decay.  Construct all possible final
 states from a single particle with PDG code [[pdg_in]].  The construction is
 limited by the given [[constraints]].
 <<Auto components: ds table: TBP>>=
   procedure :: make => ds_table_make
 <<Auto components: procedures>>=
   subroutine ds_table_make (table, model, pdg_in, constraints)
     class(ds_table_t), intent(out) :: table
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: pdg_in
     type(split_constraints_t), intent(in) :: constraints
     type(pdg_list_t) :: pl_in
     type(pdg_list_t), dimension(0) :: pl
     call table%init (model, pl, constraints)
     table%pdg_in = pdg_in
     call pl_in%init (1)
     call pl_in%set (1, [pdg_in])
     call table%split (pl_in, 0, constraints)
   end subroutine ds_table_make
 
 @ %def ds_table_make
 @ Split all entries in a growing table, starting from a table that may already
 contain states.  Add and record split states on the fly.
 <<Auto components: fs table: TBP>>=
   procedure :: radiate => fs_table_radiate
 <<Auto components: procedures>>=
   subroutine fs_table_radiate (table, constraints, do_not_check_regular)
     class(fs_table_t), intent(inout) :: table
     type(split_constraints_t) :: constraints
     logical, intent(in), optional :: do_not_check_regular
     type(ps_entry_t), pointer :: current
     current => table%first
     do while (associated (current))
        call table%split (current, 0, constraints, record = .true., &
             do_not_check_regular = do_not_check_regular)
        current => current%next
     end do
   end subroutine fs_table_radiate
 
 @ %def fs_table_radiate
 @
 \subsection{Splitting algorithm}
 Recursive splitting.  First of all, we record the current [[pdg_list]] in
 the table, subject to [[constraints]], if requested.  We also record copies of
 the list marked as loop corrections.
 
 When we record a particle list, we sort it first.
 
 If there is room for splitting, We take a PDG array list and the index of an
 element, and split this element in all possible ways.  The split entry is
 inserted into the list, which we split further.
 
 The recursion terminates whenever the split array would have a length
 greater than $n_\text{max}$.
 <<Auto components: ps table: TBP>>=
   procedure :: split => ps_table_split
 <<Auto components: procedures>>=
   recursive subroutine ps_table_split (table, pl, n_rad, constraints, &
         record, do_not_check_regular)
     class(ps_table_t), intent(inout) :: table
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_rad
     type(split_constraints_t), intent(in) :: constraints
     logical, intent(in), optional :: record, do_not_check_regular
     integer :: n_loop, i
     logical :: passed, save_pdg_index
     type(vertex_iterator_t) :: vit
     integer, dimension(:), allocatable :: pdg1
     integer, dimension(:), allocatable :: pdg2
     if (present (record)) then
        if (record) then
           n_loop = 0
           INCR_LOOPS: do
              call table%record_sorted (pl, n_loop, n_rad, constraints, &
                   do_not_check_regular, passed)
              if (.not. passed)  exit INCR_LOOPS
              if (.not. table%loops)  exit INCR_LOOPS
              n_loop = n_loop + 1
           end do INCR_LOOPS
        end if
     end if
     select type (table)
     type is (if_table_t)
        save_pdg_index = .true.
     class default
        save_pdg_index = .false.
     end select
     do i = 1, pl%get_size ()
        call constraints%check_before_split (table, pl, i, passed)
        if (passed) then
           pdg1 = pl%get (i)
           call vit%init (table%model, pdg1, save_pdg_index)
           SCAN_VERTICES: do
              call vit%get_next_match (pdg2)
              if (allocated (pdg2)) then
                 call table%insert (pl, n_rad, i, pdg2, constraints, &
                      do_not_check_regular = do_not_check_regular)
              else
                 exit SCAN_VERTICES
              end if
           end do SCAN_VERTICES
        end if
     end do
   end subroutine ps_table_split
 
 @ %def ps_table_split
 @ The worker part: insert the list of particles found by vertex matching in
 place of entry [[i]] in the PDG list.  Then split/record further.
 
 The [[n_in]] parameter tells the replacement routine to insert the new
 particles after entry [[n_in]].  Otherwise, they follow index [[i]].
 <<Auto components: ps table: TBP>>=
   procedure :: insert => ps_table_insert
 <<Auto components: procedures>>=
   recursive subroutine ps_table_insert &
        (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular)
     class(ps_table_t), intent(inout) :: table
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_rad, i
     integer, dimension(:), intent(in) :: pdg
     type(split_constraints_t), intent(in) :: constraints
     integer, intent(in), optional :: n_in
     logical, intent(in), optional :: do_not_check_regular
     type(pdg_list_t) :: pl_insert
     logical :: passed
     integer :: k, s
     s = size (pdg)
     call pl_insert%init (s)
     do k = 1, s
        call pl_insert%set (k, pdg(k))
     end do
     call constraints%check_before_insert (table, pl%get (i), pl_insert, passed)
     if (passed) then
        if (.not. is_colored_isr ()) return
        call table%split (pl%replace (i, pl_insert, n_in), n_rad + s - 1, &
             constraints, record = .true., do_not_check_regular = .true.)
     end if
   contains
     logical function is_colored_isr () result (ok)
       type(pdg_list_t) :: pl_replaced
       ok = .true.
       if (present (n_in)) then
          if (i <= n_in) then
             ok = pl_insert%contains_colored_particles ()
             if (.not. ok) then
                pl_replaced = pl%replace (i, pl_insert, n_in)
                associate (size_replaced => pl_replaced%get_pdg_sizes (), &
                     size => pl%get_pdg_sizes ())
                   ok = all (size_replaced(:n_in) == size(:n_in))
                end associate
             end if
          end if
       end if
     end function is_colored_isr
  end subroutine ps_table_insert
 
 @ %def ps_table_insert
 @ Special case:
 If we are splitting an initial particle, there is slightly more to
 do.  We loop over the particles from the vertex match and replace the
 initial particle by each of them in turn.  The remaining particles
 must be appended after the second initial particle, so they will end
 up in the out state.  This is done by providing the [[n_in]] argument
 to the base method as an optional argument.
 
 Note that we must call the base-method procedure explicitly, so the
 [[table]] argument keeps its dynamic type as [[if_table]] inside this
 procedure.
 <<Auto components: if table: TBP>>=
   procedure :: insert => if_table_insert
 <<Auto components: procedures>>=
   recursive subroutine if_table_insert  &
        (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular)
     class(if_table_t), intent(inout) :: table
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_rad, i
     integer, dimension(:), intent(in) :: pdg
     type(split_constraints_t), intent(in) :: constraints
     integer, intent(in), optional :: n_in
     logical, intent(in), optional :: do_not_check_regular
     integer, dimension(:), allocatable :: pdg_work
     integer :: p
     if (i > 2) then
        call ps_table_insert (table, pl, n_rad, i, pdg, constraints, &
             do_not_check_regular = do_not_check_regular)
     else
        allocate (pdg_work (size (pdg)))
        do p = 1, size (pdg)
           pdg_work(1) = pdg(p)
           pdg_work(2:p) = pdg(1:p-1)
           pdg_work(p+1:) = pdg(p+1:)
           select case (table%proc_type)
           case (PROC_DECAY)
              call ps_table_insert (table, &
                   pl, n_rad, i, pdg_work, constraints, n_in = 1, &
                   do_not_check_regular = do_not_check_regular)
           case (PROC_SCATTER)
              call ps_table_insert (table, &
                   pl, n_rad, i, pdg_work, constraints, n_in = 2, &
                   do_not_check_regular = do_not_check_regular)
           end select
        end do
     end if
   end subroutine if_table_insert
 
 @ %def if_table_insert
 @ Sort before recording.  In the case of the [[if_table]], we do not
 sort the first [[n_in]] particle entries.  Instead, we check whether they are
 allowed in the [[pl_beam]] PDG list, if that is provided.
 <<Auto components: ps table: TBP>>=
   procedure :: record_sorted => ps_table_record_sorted
 <<Auto components: if table: TBP>>=
   procedure :: record_sorted => if_table_record_sorted
 <<Auto components: procedures>>=
   subroutine ps_table_record_sorted &
        (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed)
     class(ps_table_t), intent(inout) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop, n_rad
     type(split_constraints_t), intent(in) :: constraints
     logical, intent(in), optional :: do_not_check_regular
     logical, intent(out) :: passed
     call table%record (pl%sort_abs (), n_loop, n_rad, constraints, &
          do_not_check_regular, passed)
   end subroutine ps_table_record_sorted
 
   subroutine if_table_record_sorted &
        (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed)
     class(if_table_t), intent(inout) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop, n_rad
     type(split_constraints_t), intent(in) :: constraints
     logical, intent(in), optional :: do_not_check_regular
     logical, intent(out) :: passed
     call table%record (pl%sort_abs (2), n_loop, n_rad, constraints, &
          do_not_check_regular, passed)
   end subroutine if_table_record_sorted
 
 @ %def ps_table_record_sorted if_table_record_sorted
 @ Record an entry: insert into the list.  Check the ordering and
 insert it at the correct place, unless it is already there.
 
 We record an array only if its mass sum is less than the total
 available energy.  This restriction is removed by setting
 [[constrained]] to false.
 <<Auto components: ps table: TBP>>=
   procedure :: record => ps_table_record
 <<Auto components: procedures>>=
   subroutine ps_table_record (table, pl, n_loop, n_rad, constraints, &
        do_not_check_regular, passed)
     class(ps_table_t), intent(inout) :: table
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n_loop, n_rad
     type(split_constraints_t), intent(in) :: constraints
     logical, intent(in), optional :: do_not_check_regular
     logical, intent(out) :: passed
     type(ps_entry_t), pointer :: current
     logical :: needs_check
     passed = .false.
     needs_check = .true.
     if (present (do_not_check_regular))  needs_check = .not. do_not_check_regular
     if (needs_check .and. .not. pl%is_regular ()) then
        call msg_warning ("Record ps_table entry: Irregular pdg-list encountered!")
        return
     end if
     call constraints%check_before_record (table, pl, n_loop, passed)
     if (.not. passed)  then
        return
     end if
     current => table%first
     do while (associated (current))
        if (pl == current) then
           if (n_loop == current%n_loop)  return
        else if (pl < current) then
           call insert
           return
        end if
        current => current%next
     end do
     call insert
   contains
     subroutine insert ()
       type(ps_entry_t), pointer :: entry
       allocate (entry)
       entry%pdg_list_t = pl
       entry%n_loop = n_loop
       entry%n_rad = n_rad
       if (associated (current)) then
          if (associated (current%previous)) then
             current%previous%next => entry
             entry%previous => current%previous
          else
             table%first => entry
          end if
          entry%next => current
          current%previous => entry
       else
          if (associated (table%last)) then
             table%last%next => entry
             entry%previous => table%last
          else
             table%first => entry
          end if
          table%last => entry
       end if
     end subroutine insert
   end subroutine ps_table_record
 
 @ %def ps_table_record
 @
 \subsection{Tools}
 Compute the mass sum for a PDG list object, counting the entries with indices
 between (including) [[n1]] and [[n2]].  Rely on the requirement that
 if an entry is a PDG array, this array must be degenerate in mass.
 <<Auto components: procedures>>=
   function mass_sum (pl, n1, n2, model) result (m)
     type(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: n1, n2
     class(model_data_t), intent(in), target :: model
     integer, dimension(:), allocatable :: pdg
     real(default) :: m
     type(field_data_t), pointer :: prt
     integer :: i
     m = 0
     do i = n1, n2
        pdg = pl%get (i)
        prt => model%get_field_ptr (pdg(1))
        m = m + prt%get_mass ()
     end do
   end function mass_sum
 
 @ %def mass_sum
 @ Invert a PDG array, replacing particles by antiparticles.  This
 depends on the model.
 <<Auto components: procedures>>=
   function invert_pdg_array (pa, model) result (pa_inv)
     type(pdg_array_t), intent(in) :: pa
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t) :: pa_inv
     type(field_data_t), pointer :: prt
     integer :: i, pdg
     pa_inv = pa
     do i = 1, pa_inv%get_length ()
        pdg = pa_inv%get (i)
        prt => model%get_field_ptr (pdg)
        if (prt%has_antiparticle ())  call pa_inv%set (i, -pdg)
     end do
   end function invert_pdg_array
 
 @ %def invert_pdg_array
 @
 \subsection{Access results}
 Return the number of generated decays.
 <<Auto components: ps table: TBP>>=
   procedure :: get_length => ps_table_get_length
 <<Auto components: procedures>>=
   function ps_table_get_length (ps_table) result (n)
     class(ps_table_t), intent(in) :: ps_table
     integer :: n
     type(ps_entry_t), pointer :: entry
     n = 0
     entry => ps_table%first
     do while (associated (entry))
        n = n + 1
        entry => entry%next
     end do
   end function ps_table_get_length
 
 @ %def ps_table_get_length
 @
 <<Auto components: ps table: TBP>>=
   procedure :: get_emitters => ps_table_get_emitters
 <<Auto components: procedures>>=
   subroutine ps_table_get_emitters (table, constraints, emitters)
      class(ps_table_t), intent(in) :: table
      type(split_constraints_t), intent(in) :: constraints
      integer, dimension(:), allocatable, intent(out) :: emitters
      class(pdg_list_t), pointer :: pl
      integer :: i
      logical :: passed
      type(vertex_iterator_t) :: vit
      integer, dimension(:), allocatable :: pdg1, pdg2
      integer :: n_emitters
      integer, dimension(:), allocatable :: emitters_tmp
      integer, parameter :: buf0 = 6
      n_emitters = 0
      pl => table%first
      allocate (emitters_tmp (buf0))
      do i = 1, pl%get_size ()
         call constraints%check_before_split (table, pl, i, passed)
         if (passed) then
            pdg1 = pl%get(i)
            call vit%init (table%model, pdg1, .false.)
            do
               call vit%get_next_match(pdg2)
               if (allocated (pdg2)) then
                  if (n_emitters + 1 > size (emitters_tmp)) &
                       call extend_integer_array (emitters_tmp, 10)
                  emitters_tmp (n_emitters + 1) = pdg1(1)
                  n_emitters = n_emitters + 1
               else
                  exit
               end if
            end do
         end if
      end do
      allocate (emitters (n_emitters))
      emitters = emitters_tmp (1:n_emitters)
      deallocate (emitters_tmp)
   end subroutine ps_table_get_emitters
 
 @ %def ps_table_get_emitters
 @ Return an allocated array of decay products (PDG codes).  If
 requested, return also the loop and radiation order count.
 <<Auto components: ps table: TBP>>=
   procedure :: get_pdg_out => ps_table_get_pdg_out
 <<Auto components: procedures>>=
   subroutine ps_table_get_pdg_out (ps_table, i, pa_out, n_loop, n_rad)
     class(ps_table_t), intent(in) :: ps_table
     integer, intent(in) :: i
     type(pdg_array_t), dimension(:), allocatable, intent(out) :: pa_out
     integer, intent(out), optional :: n_loop, n_rad
     type(ps_entry_t), pointer :: entry
     integer :: n, j
     n = 0
     entry => ps_table%first
     FIND_ENTRY: do while (associated (entry))
        n = n + 1
        if (n == i) then
           allocate (pa_out (entry%get_size ()))
           do j = 1, entry%get_size ()
              pa_out(j) = entry%get (j)
              if (present (n_loop))  n_loop = entry%n_loop
              if (present (n_rad))  n_rad = entry%n_rad
           end do
           exit FIND_ENTRY
        end if
        entry => entry%next
     end do FIND_ENTRY
   end subroutine ps_table_get_pdg_out
 
 @ %def ps_table_get_pdg_out
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[auto_components_ut.f90]]>>=
 <<File header>>
 
 module auto_components_ut
   use unit_tests
   use auto_components_uti
 
 <<Standard module head>>
 
 <<Auto components: public test>>
 
 contains
 
 <<Auto components: test driver>>
 
 end module auto_components_ut
 @ %def auto_components_ut
 @
 <<[[auto_components_uti.f90]]>>=
 <<File header>>
 
 module auto_components_uti
 
 <<Use kinds>>
 <<Use strings>>
   use pdg_arrays
   use model_data
   use model_testbed, only: prepare_model, cleanup_model
 
   use auto_components
 
 <<Standard module head>>
 
 <<Auto components: test declarations>>
 
 contains
 
 <<Auto components: tests>>
 
 end module auto_components_uti
 @ %def auto_components_ut
 @ API: driver for the unit tests below.
 <<Auto components: public test>>=
   public :: auto_components_test
 <<Auto components: test driver>>=
   subroutine auto_components_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Auto components: execute tests>>
   end subroutine auto_components_test
 
 @ %def auto_components_tests
 @
 \subsubsection{Generate Decay Table}
 Determine all kinematically allowed decay channels for a Higgs boson,
 using default parameter values.
 <<Auto components: execute tests>>=
   call test (auto_components_1, "auto_components_1", &
        "generate decay table", &
        u, results)
 <<Auto components: test declarations>>=
   public :: auto_components_1
 <<Auto components: tests>>=
   subroutine auto_components_1 (u)
     integer, intent(in) :: u
     class(model_data_t), pointer :: model
     type(field_data_t), pointer :: prt
     type(ds_table_t) :: ds_table
     type(split_constraints_t) :: constraints
 
     write (u, "(A)")  "* Test output: auto_components_1"
     write (u, "(A)")  "*   Purpose: determine Higgs decay table"
     write (u, *)
 
     write (u, "(A)")  "* Read Standard Model"
 
     model => null ()
     call prepare_model (model, var_str ("SM"))
 
     prt => model%get_field_ptr (25)
 
     write (u, *)
     write (u, "(A)")  "* Higgs decays n = 2"
     write (u, *)
 
     call constraints%init (2)
     call constraints%set (1, constrain_n_tot (2))
     call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
 
     call ds_table%make (model, 25, constraints)
     call ds_table%write (u)
     call ds_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Higgs decays n = 3 (w/o radiative)"
     write (u, *)
 
     call constraints%init (3)
     call constraints%set (1, constrain_n_tot (3))
     call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
     call constraints%set (3, constrain_radiation ())
 
     call ds_table%make (model, 25, constraints)
     call ds_table%write (u)
     call ds_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Higgs decays n = 3 (w/ radiative)"
     write (u, *)
 
     call constraints%init (2)
     call constraints%set (1, constrain_n_tot (3))
     call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
 
     call ds_table%make (model, 25, constraints)
     call ds_table%write (u)
     call ds_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call cleanup_model (model)
     deallocate (model)
 
     write (u, *)
     write (u, "(A)")  "* Test output end: auto_components_1"
 
   end subroutine auto_components_1
 
 @ %def auto_components_1
 @
 \subsubsection{Generate radiation}
 Given a final state, add radiation (NLO and NNLO).  We provide a list
 of particles that is allowed to occur in the generated final states.
 <<Auto components: execute tests>>=
   call test (auto_components_2, "auto_components_2", &
        "generate NLO corrections, final state", &
        u, results)
 <<Auto components: test declarations>>=
   public :: auto_components_2
 <<Auto components: tests>>=
   subroutine auto_components_2 (u)
     integer, intent(in) :: u
     class(model_data_t), pointer :: model
     type(pdg_list_t), dimension(:), allocatable :: pl, pl_zzh
     type(pdg_list_t) :: pl_match
     type(fs_table_t) :: fs_table
     type(split_constraints_t) :: constraints
     real(default) :: sqrts
     integer :: i
 
     write (u, "(A)")  "* Test output: auto_components_2"
     write (u, "(A)")  "*   Purpose: generate radiation (NLO)"
     write (u, *)
 
 
     write (u, "(A)")  "* Read Standard Model"
 
     model => null ()
     call prepare_model (model, var_str ("SM"))
 
     write (u, *)
     write (u, "(A)")  "* LO final state"
     write (u, *)
 
     allocate (pl (2))
     call pl(1)%init (2)
     call pl(1)%set (1, 1)
     call pl(1)%set (2, -1)
     call pl(2)%init (2)
     call pl(2)%set (1, 21)
     call pl(2)%set (2, 21)
     do i = 1, 2
        call pl(i)%write (u);  write (u, *)
     end do
 
     write (u, *)
     write (u, "(A)")  "* Initialize FS table"
     write (u, *)
 
     call constraints%init (1)
     call constraints%set (1, constrain_n_tot (3))
 
     call fs_table%init (model, pl, constraints)
     call fs_table%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, unconstrained"
     write (u, *)
 
     call fs_table%radiate (constraints)
     call fs_table%write (u)
     call fs_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, &
          &complete but mass-constrained"
     write (u, *)
 
     sqrts = 50
 
     call constraints%init (2)
     call constraints%set (1, constrain_n_tot (3))
     call constraints%set (2, constrain_mass_sum (sqrts))
 
     call fs_table%init (model, pl, constraints)
     call fs_table%radiate (constraints)
     call fs_table%write (u)
     call fs_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, restricted"
     write (u, *)
 
     call pl_match%init ([1, -1, 21])
 
     call constraints%init (2)
     call constraints%set (1, constrain_n_tot (3))
     call constraints%set (2, constrain_insert (pl_match))
 
     call fs_table%init (model, pl, constraints)
     call fs_table%radiate (constraints)
     call fs_table%write (u)
     call fs_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NNLO corrections, restricted, with one loop"
     write (u, *)
 
     call pl_match%init ([1, -1, 21])
 
     call constraints%init (3)
     call constraints%set (1, constrain_n_tot (4))
     call constraints%set (2, constrain_n_loop (1))
     call constraints%set (3, constrain_insert (pl_match))
 
     call fs_table%init (model, pl, constraints)
     call fs_table%enable_loops ()
     call fs_table%radiate (constraints)
     call fs_table%write (u)
     call fs_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NNLO corrections, restricted, with loops"
     write (u, *)
 
     call constraints%init (2)
     call constraints%set (1, constrain_n_tot (4))
     call constraints%set (2, constrain_insert (pl_match))
 
     call fs_table%init (model, pl, constraints)
     call fs_table%enable_loops ()
     call fs_table%radiate (constraints)
     call fs_table%write (u)
     call fs_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NNLO corrections, restricted, to Z Z H, &
          &no loops"
     write (u, *)
 
     allocate (pl_zzh (1))
     call pl_zzh(1)%init (3)
     call pl_zzh(1)%set (1, 23)
     call pl_zzh(1)%set (2, 23)
     call pl_zzh(1)%set (3, 25)
 
     call constraints%init (3)
     call constraints%set (1, constrain_n_tot (5))
     call constraints%set (2, constrain_mass_sum (500._default))
     call constraints%set (3, constrain_require (pl_zzh(1)))
 
     call fs_table%init (model, pl_zzh, constraints)
     call fs_table%radiate (constraints)
     call fs_table%write (u)
     call fs_table%final ()
 
     call cleanup_model (model)
     deallocate (model)
 
     write (u, *)
     write (u, "(A)")  "* Test output end: auto_components_2"
 
   end subroutine auto_components_2
 
 @ %def auto_components_2
 @
 \subsubsection{Generate radiation from initial and final state}
 Given a process, add radiation (NLO and NNLO).  We provide a list
 of particles that is allowed to occur in the generated final states.
 <<Auto components: execute tests>>=
   call test (auto_components_3, "auto_components_3", &
        "generate NLO corrections, in and out", &
        u, results)
 <<Auto components: test declarations>>=
   public :: auto_components_3
 <<Auto components: tests>>=
   subroutine auto_components_3 (u)
     integer, intent(in) :: u
     class(model_data_t), pointer :: model
     type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
     type(pdg_list_t) :: pl_match, pl_beam
     type(if_table_t) :: if_table
     type(split_constraints_t) :: constraints
     real(default) :: sqrts
     integer :: i
 
     write (u, "(A)")  "* Test output: auto_components_3"
     write (u, "(A)")  "*   Purpose: generate radiation (NLO)"
     write (u, *)
 
     write (u, "(A)")  "* Read Standard Model"
 
     model => null ()
     call prepare_model (model, var_str ("SM"))
 
     write (u, *)
     write (u, "(A)")  "* LO initial state"
     write (u, *)
 
     allocate (pl_in (2))
     call pl_in(1)%init (2)
     call pl_in(1)%set (1, 1)
     call pl_in(1)%set (2, -1)
     call pl_in(2)%init (2)
     call pl_in(2)%set (1, -1)
     call pl_in(2)%set (2, 1)
     do i = 1, 2
        call pl_in(i)%write (u);  write (u, *)
     end do
 
     write (u, *)
     write (u, "(A)")  "* LO final state"
     write (u, *)
 
     allocate (pl_out (1))
     call pl_out(1)%init (1)
     call pl_out(1)%set (1, 23)
     call pl_out(1)%write (u);  write (u, *)
 
     write (u, *)
     write (u, "(A)")  "* Initialize FS table"
     write (u, *)
 
     call constraints%init (1)
     call constraints%set (1, constrain_n_tot (4))
 
     call if_table%init (model, pl_in, pl_out, constraints)
     call if_table%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, unconstrained"
     write (u, *)
 
     call if_table%radiate (constraints)
     call if_table%write (u)
     call if_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, &
          &complete but mass-constrained"
     write (u, *)
 
     sqrts = 100
     call constraints%init (2)
     call constraints%set (1, constrain_n_tot (4))
     call constraints%set (2, constrain_mass_sum (sqrts))
 
     call if_table%init (model, pl_in, pl_out, constraints)
     call if_table%radiate (constraints)
     call if_table%write (u)
     call if_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, &
          &mass-constrained, restricted beams"
     write (u, *)
 
     call pl_beam%init (3)
     call pl_beam%set (1, 1)
     call pl_beam%set (2, -1)
     call pl_beam%set (3, 21)
 
     call constraints%init (3)
     call constraints%set (1, constrain_n_tot (4))
     call constraints%set (2, constrain_in_state (pl_beam))
     call constraints%set (3, constrain_mass_sum (sqrts))
 
     call if_table%init (model, pl_in, pl_out, constraints)
     call if_table%radiate (constraints)
     call if_table%write (u)
     call if_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NLO corrections, restricted"
     write (u, *)
 
     call pl_match%init ([1, -1, 21])
 
     call constraints%init (4)
     call constraints%set (1, constrain_n_tot (4))
     call constraints%set (2, constrain_in_state (pl_beam))
     call constraints%set (3, constrain_mass_sum (sqrts))
     call constraints%set (4, constrain_insert (pl_match))
 
     call if_table%init (model, pl_in, pl_out, constraints)
     call if_table%radiate (constraints)
     call if_table%write (u)
     call if_table%final ()
 
     write (u, *)
     write (u, "(A)")  "* Generate NNLO corrections, restricted, Z preserved, &
          &with loops"
     write (u, *)
 
     call constraints%init (5)
     call constraints%set (1, constrain_n_tot (5))
     call constraints%set (2, constrain_in_state (pl_beam))
     call constraints%set (3, constrain_mass_sum (sqrts))
     call constraints%set (4, constrain_insert (pl_match))
     call constraints%set (5, constrain_require (pl_out(1)))
 
     call if_table%init (model, pl_in, pl_out, constraints)
     call if_table%enable_loops ()
     call if_table%radiate (constraints)
     call if_table%write (u)
     call if_table%final ()
 
     call cleanup_model (model)
     deallocate (model)
 
     write (u, *)
     write (u, "(A)")  "* Test output end: auto_components_3"
 
   end subroutine auto_components_3
 
 @ %def auto_components_3
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Creating the real flavor structure}
 <<[[radiation_generator.f90]]>>=
 <<File header>>
 
 module radiation_generator
 
 <<Use kinds>>
 <<Use strings>>
   use diagnostics
   use io_units
   use physics_defs, only: PHOTON, GLUON
   use pdg_arrays
   use flavors
   use model_data
   use auto_components
   use string_utils, only: split_string, string_contains_word
 
   implicit none
   private
 
 <<radiation generator: public>>
 
 <<radiation generator: types>>
 
 contains
 
 <<radiation generator: procedures>>
 
 end module radiation_generator
 @ %def radiation_generator
 @
 <<radiation generator: types>>=
   type :: pdg_sorter_t
      integer :: pdg
      logical :: checked = .false.
      integer :: associated_born = 0
   end type pdg_sorter_t
 
 @ %def pdg_sorter
 @
 <<radiation generator: types>>=
   type :: pdg_states_t
     type(pdg_array_t), dimension(:), allocatable :: pdg
     type(pdg_states_t), pointer :: next
     integer :: n_particles
   contains
   <<radiation generator: pdg states: TBP>>
   end type pdg_states_t
 
 @ %def pdg_states_t
 <<radiation generator: pdg states: TBP>>=
   procedure :: init => pdg_states_init
 <<radiation generator: procedures>>=
   subroutine pdg_states_init (states)
     class(pdg_states_t), intent(inout) :: states
     nullify (states%next)
   end subroutine pdg_states_init
 
 @ %def pdg_states_init
 @
 <<radiation generator: pdg states: TBP>>=
   procedure :: add => pdg_states_add
 <<radiation generator: procedures>>=
   subroutine pdg_states_add (states, pdg)
     class(pdg_states_t), intent(inout), target :: states
     type(pdg_array_t), dimension(:), intent(in) :: pdg
     type(pdg_states_t), pointer :: current_state
     select type (states)
     type is (pdg_states_t)
       current_state => states
       do
         if (associated (current_state%next)) then
           current_state => current_state%next
         else
           allocate (current_state%next)
           nullify(current_state%next%next)
           current_state%pdg = pdg
           exit
         end if
       end do
     end select
   end subroutine pdg_states_add
 
 @ %def pdg_states_add
 @
 <<radiation generator: pdg states: TBP>>=
   procedure :: get_n_states => pdg_states_get_n_states
 <<radiation generator: procedures>>=
   function pdg_states_get_n_states (states) result (n)
     class(pdg_states_t), intent(in), target :: states
     integer :: n
     type(pdg_states_t), pointer :: current_state
     n = 0
     select type(states)
     type is (pdg_states_t)
       current_state => states
       do
         if (associated (current_state%next)) then
           n = n+1
           current_state => current_state%next
         else
           exit
         end if
       end do
     end select
   end function pdg_states_get_n_states
 
 @ %def pdg_states_get_n_states
 @
 <<radiation generator: types>>=
   type :: prt_queue_t
     type(string_t), dimension(:), allocatable :: prt_string
     type(prt_queue_t), pointer :: next => null ()
     type(prt_queue_t), pointer :: previous => null ()
     type(prt_queue_t), pointer :: front => null ()
     type(prt_queue_t), pointer :: current_prt => null ()
     type(prt_queue_t), pointer :: back => null ()
     integer :: n_lists = 0
   contains
   <<radiation generator: prt queue: TBP>>
   end type prt_queue_t
 
 @ %def prt_queue_t
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: null => prt_queue_null
 <<radiation generator: procedures>>=
   subroutine prt_queue_null (queue)
     class(prt_queue_t), intent(out) :: queue
     queue%next => null ()
     queue%previous => null ()
     queue%front => null ()
     queue%current_prt => null ()
     queue%back => null ()
     queue%n_lists = 0
     if (allocated (queue%prt_string))  deallocate (queue%prt_string)
   end subroutine prt_queue_null
 
 @ %def prt_queue_null
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: append => prt_queue_append
 <<radiation generator: procedures>>=
   subroutine prt_queue_append (queue, prt_string)
     class(prt_queue_t), intent(inout) :: queue
     type(string_t), intent(in), dimension(:) :: prt_string
     type(prt_queue_t), pointer :: new_element => null ()
     type(prt_queue_t), pointer :: current_back => null ()
     allocate (new_element)
     allocate (new_element%prt_string(size (prt_string)))
     new_element%prt_string = prt_string
     if (associated (queue%back)) then
        current_back => queue%back
        current_back%next => new_element
        new_element%previous => current_back
        queue%back => new_element
     else
        !!! Initial entry
        queue%front => new_element
        queue%back => queue%front
        queue%current_prt => queue%front
     end if
     queue%n_lists = queue%n_lists + 1
   end subroutine prt_queue_append
 
 @ %def prt_queue_append
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: get => prt_queue_get
 <<radiation generator: procedures>>=
   subroutine prt_queue_get (queue, prt_string)
     class(prt_queue_t), intent(inout) :: queue
     type(string_t), dimension(:), allocatable, intent(out) :: prt_string
     if (associated (queue%current_prt)) then
        prt_string = queue%current_prt%prt_string
        if (associated (queue%current_prt%next)) &
           queue%current_prt => queue%current_prt%next
     else
        prt_string = " "
     end if
   end subroutine prt_queue_get
 
 @ %def prt_queue_get
 @ As above.
 <<radiation generator: prt queue: TBP>>=
   procedure :: get_last => prt_queue_get_last
 <<radiation generator: procedures>>=
   subroutine prt_queue_get_last (queue, prt_string)
     class(prt_queue_t), intent(in) :: queue
     type(string_t), dimension(:), allocatable, intent(out) :: prt_string
     if (associated (queue%back)) then
        allocate (prt_string(size (queue%back%prt_string)))
        prt_string = queue%back%prt_string
     else
        prt_string = " "
     end if
   end subroutine prt_queue_get_last
 
 @ %def prt_queue_get_last
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: reset => prt_queue_reset
 <<radiation generator: procedures>>=
   subroutine prt_queue_reset (queue)
     class(prt_queue_t), intent(inout) :: queue
     queue%current_prt => queue%front
   end subroutine prt_queue_reset
 
 @ %def prt_queue_reset
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: check_for_same_prt_strings => prt_queue_check_for_same_prt_strings
 <<radiation generator: procedures>>=
   function prt_queue_check_for_same_prt_strings (queue) result (val)
     class(prt_queue_t), intent(inout) :: queue
     logical :: val
     type(string_t), dimension(:), allocatable :: prt_string
     integer, dimension(:,:), allocatable :: i_particle
     integer :: n_d, n_dbar, n_u, n_ubar, n_s, n_sbar, n_gl, n_e, n_ep, n_mu, n_mup, n_A
     integer :: i, j
     call queue%reset ()
     allocate (i_particle (queue%n_lists, 12))
     do i = 1, queue%n_lists
        call queue%get (prt_string)
        n_d = count_particle (prt_string, 1)
        n_dbar = count_particle (prt_string, -1)
        n_u = count_particle (prt_string, 2)
        n_ubar = count_particle (prt_string, -2)
        n_s = count_particle (prt_string, 3)
        n_sbar = count_particle (prt_string, -3)
        n_gl = count_particle (prt_string, 21)
        n_e = count_particle (prt_string, 11)
        n_ep = count_particle (prt_string, -11)
        n_mu = count_particle (prt_string, 13)
        n_mup = count_particle (prt_string, -13)
        n_A = count_particle (prt_string, 22)
        i_particle (i, 1) = n_d
        i_particle (i, 2) = n_dbar
        i_particle (i, 3) = n_u
        i_particle (i, 4) = n_ubar
        i_particle (i, 5) = n_s
        i_particle (i, 6) = n_sbar
        i_particle (i, 7) = n_gl
        i_particle (i, 8) = n_e
        i_particle (i, 9) = n_ep
        i_particle (i, 10) = n_mu
        i_particle (i, 11) = n_mup
        i_particle (i, 12) = n_A
     end do
     val = .false.
     do i = 1, queue%n_lists
        do j = 1, queue%n_lists
           if  (i == j) cycle
           val = val .or. all (i_particle (i,:) == i_particle(j,:))
        end do
     end do
   contains
     function count_particle (prt_string, pdg) result (n)
       type(string_t), dimension(:), intent(in) :: prt_string
       integer, intent(in) :: pdg
       integer :: n
       integer :: i
       type(string_t) :: prt_ref
       n = 0
       select case (pdg)
       case (1)
          prt_ref = "d"
       case (-1)
          prt_ref = "dbar"
       case (2)
          prt_ref = "u"
       case (-2)
          prt_ref = "ubar"
       case (3)
          prt_ref = "s"
       case (-3)
          prt_ref = "sbar"
       case (21)
          prt_ref = "gl"
       case (11)
          prt_ref = "e-"
       case (-11)
          prt_ref = "e+"
       case (13)
          prt_ref = "mu-"
       case (-13)
          prt_ref = "mu+"
       case (22)
          prt_ref = "A"
       end select
       do i = 1, size (prt_string)
          if (prt_string(i) == prt_ref) n = n+1
       end do
     end function count_particle
 
   end function prt_queue_check_for_same_prt_strings
 
 @ %def prt_queue_check_for_same_prt_strings
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: contains => prt_queue_contains
 <<radiation generator: procedures>>=
   function prt_queue_contains (queue, prt_string) result (val)
     class(prt_queue_t), intent(in) :: queue
     type(string_t), intent(in), dimension(:) :: prt_string
     logical :: val
     type(prt_queue_t), pointer :: current => null()
     if (associated (queue%front)) then
        current => queue%front
     else
        call msg_fatal ("Trying to access empty particle queue")
     end if
     val = .false.
     do
        if (size (current%prt_string) == size (prt_string)) then
           if (all (current%prt_string == prt_string)) then
              val = .true.
              exit
           end if
        end if
        if (associated (current%next)) then
           current => current%next
        else
           exit
        end if
     end do
   end function prt_queue_contains
 
 @ %def prt_string_list_contains
 @
 <<radiation generator: prt queue: TBP>>=
   procedure :: write => prt_queue_write
 <<radiation generator: procedures>>=
   subroutine prt_queue_write (queue, unit)
     class(prt_queue_t), intent(in) :: queue
     integer, optional :: unit
     type(prt_queue_t), pointer :: current => null ()
     integer :: i, j, u
     u = given_output_unit (unit)
     if (associated (queue%front)) then
        current => queue%front
     else
        write (u, "(A)") "[Particle queue is empty]"
        return
     end if
     j = 1
     do
        write (u, "(I2,A,1X)", advance = 'no') j , ":"
        do i = 1, size (current%prt_string)
           write (u, "(A,1X)", advance = 'no') char (current%prt_string(i))
        end do
        write (u, "(A)")
        if (associated (current%next)) then
           current => current%next
           j = j+1
        else
           exit
        end if
     end do
   end subroutine prt_queue_write
 
 @ %def prt_queue_write
 @
 <<radiation generator: procedures>>=
   subroutine sort_prt (prt, model)
     type(string_t), dimension(:), intent(inout) :: prt
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(:), allocatable :: pdg
     type(flavor_t) :: flv
     integer :: i
     call create_pdg_array (prt, model, pdg)
     call sort_pdg (pdg)
     do i = 1, size (pdg)
        call flv%init (pdg(i)%get(), model)
        prt(i) = flv%get_name ()
     end do
   end subroutine sort_prt
 
   subroutine sort_pdg (pdg)
     type(pdg_array_t), dimension(:), intent(inout) :: pdg
     integer, dimension(:), allocatable :: i_pdg
     integer :: i
     allocate (i_pdg (size (pdg)))
     do i = 1, size (pdg)
        i_pdg(i) = pdg(i)%get ()
     end do
     i_pdg = sort_abs (i_pdg)
     do i = 1, size (pdg)
        call pdg(i)%set (1, i_pdg(i))
     end do
   end subroutine sort_pdg
 
   subroutine create_pdg_array (prt, model, pdg)
     type (string_t), dimension(:), intent(in) :: prt
     class (model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(:), allocatable, intent(out) :: pdg
     type(flavor_t) :: flv
     integer :: i
     allocate (pdg (size (prt)))
     do i = 1, size (prt)
        call flv%init (prt(i), model)
        pdg(i) = flv%get_pdg ()
     end do
   end subroutine create_pdg_array
 
 @ %def sort_prt sort_pdg create_pdg_array
 @ This is used in unit tests:
 <<radiation generator: test auxiliary>>=
   subroutine write_pdg_array (pdg, u)
     use pdg_arrays
     type(pdg_array_t), dimension(:), intent(in) :: pdg
     integer, intent(in) :: u
     integer :: i
     do i = 1, size (pdg)
        call pdg(i)%write (u)
     end do
     write (u, "(A)")
   end subroutine write_pdg_array
 
   subroutine write_particle_string (prt, u)
   <<Use strings>>
     type(string_t), dimension(:), intent(in) :: prt
     integer, intent(in) :: u
     integer :: i
     do i = 1, size (prt)
        write (u, "(A,1X)", advance = "no") char (prt(i))
     end do
     write (u, "(A)")
   end subroutine write_particle_string
 
 @ %def write_pdg_array write_particle_string
 <<radiation generator: types>>=
   type :: reshuffle_list_t
      integer, dimension(:), allocatable :: ii
      type(reshuffle_list_t), pointer :: next => null ()
   contains
   <<radiation generator: reshuffle list: TBP>>
   end type reshuffle_list_t
 
 @ %def reshuffle_list_t
 @
 <<radiation generator: reshuffle list: TBP>>=
   procedure :: write => reshuffle_list_write
 <<radiation generator: procedures>>=
   subroutine reshuffle_list_write (rlist)
     class(reshuffle_list_t), intent(in) :: rlist
     type(reshuffle_list_t), pointer :: current => null ()
     integer :: i
     print *, 'Content of reshuffling list: '
     if (associated (rlist%next)) then
        current => rlist%next
        i = 1
        do
          print *, 'i: ', i, 'list: ', current%ii
          i = i + 1
          if (associated (current%next)) then
             current => current%next
          else
             exit
          end if
        end do
     else
        print *, '[EMPTY]'
     end if
   end subroutine reshuffle_list_write
 
 @ %def reshuffle_list_write
 @
 <<radiation generator: reshuffle list: TBP>>=
   procedure :: append => reshuffle_list_append
 <<radiation generator: procedures>>=
   subroutine reshuffle_list_append (rlist, ii)
     class(reshuffle_list_t), intent(inout) :: rlist
     integer, dimension(:), allocatable, intent(in) :: ii
     type(reshuffle_list_t), pointer :: current
     if (associated (rlist%next)) then
        current => rlist%next
        do
           if (associated (current%next)) then
              current => current%next
           else
              allocate (current%next)
              allocate (current%next%ii (size (ii)))
              current%next%ii = ii
              exit
           end if
        end do
     else
        allocate (rlist%next)
        allocate (rlist%next%ii (size (ii)))
        rlist%next%ii = ii
     end if
   end subroutine reshuffle_list_append
 
 @ %def reshuffle_list_append
 @
 <<radiation generator: reshuffle list: TBP>>=
   procedure :: is_empty => reshuffle_list_is_empty
 <<radiation generator: procedures>>=
   elemental function reshuffle_list_is_empty (rlist) result (is_empty)
     logical :: is_empty
     class(reshuffle_list_t), intent(in) :: rlist
     is_empty = .not. associated (rlist%next)
   end function reshuffle_list_is_empty
 
 @ %def reshuffle_list_is_empty
 @
 <<radiation generator: reshuffle list: TBP>>=
   procedure :: get => reshuffle_list_get
 <<radiation generator: procedures>>=
   function reshuffle_list_get (rlist, index) result (ii)
     integer, dimension(:), allocatable :: ii
     class(reshuffle_list_t), intent(inout) :: rlist
     integer, intent(in) :: index
     type(reshuffle_list_t), pointer :: current => null ()
     integer :: i
     current => rlist%next
     do i = 1, index - 1
        if (associated (current%next)) then
           current => current%next
        else
           call msg_fatal ("Index exceeds size of reshuffling list")
        end if
     end do
     allocate (ii (size (current%ii)))
     ii = current%ii
   end function reshuffle_list_get
 
 @ %def reshuffle_list_get
 @ We need to reset the [[reshuffle_list]] in order to deal with
 subsequent usages of the [[radiation_generator]]. Below is obviously
 the lazy and dirty solution. Otherwise, we would have to equip this
 auxiliary type with additional information about [[last]] and [[previous]]
 pointers. Considering that at most $n_{\rm{legs}}$ integers are saved
 in the lists, and that the subroutine is only called during the
 initialization phase (more precisely: at the moment only in the
 [[radiation_generator]] unit tests), I think this quick fix is justified.
 <<radiation generator: reshuffle list: TBP>>=
   procedure :: reset => reshuffle_list_reset
 <<radiation generator: procedures>>=
   subroutine reshuffle_list_reset (rlist)
     class(reshuffle_list_t), intent(inout) :: rlist
     rlist%next => null ()
   end subroutine reshuffle_list_reset
 
 @ %def reshuffle_list_reset
 @
 <<radiation generator: public>>=
   public :: radiation_generator_t
 <<radiation generator: types>>=
   type :: radiation_generator_t
     logical :: qcd_enabled = .false.
     logical :: qed_enabled = .false.
     logical :: is_gluon = .false.
     logical :: fs_gluon = .false.
     logical :: is_photon = .false.
     logical :: fs_photon = .false.
     logical :: only_final_state = .true.
     type(pdg_list_t) :: pl_in, pl_out
     type(pdg_list_t) :: pl_excluded_gauge_splittings
     type(split_constraints_t) :: constraints
     integer :: n_tot
     integer :: n_in, n_out
     integer :: n_loops
     integer :: n_light_quarks
     real(default) :: mass_sum
     type(prt_queue_t) :: prt_queue
     type(pdg_states_t) :: pdg_raw
     type(pdg_array_t), dimension(:), allocatable :: pdg_in_born, pdg_out_born
     type(if_table_t) :: if_table
     type(reshuffle_list_t) :: reshuffle_list
   contains
   <<radiation generator: radiation generator: TBP>>
   end type radiation_generator_t
 
 @
 @ %def radiation_generator_t
 <<radiation generator: radiation generator: TBP>>=
   generic :: init => init_pdg_list, init_pdg_array
   procedure :: init_pdg_list => radiation_generator_init_pdg_list
   procedure :: init_pdg_array => radiation_generator_init_pdg_array
 <<radiation generator: procedures>>=
   subroutine radiation_generator_init_pdg_list &
        (generator, pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed)
     class(radiation_generator_t), intent(inout) :: generator
     type(pdg_list_t), intent(in) :: pl_in, pl_out
     type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings
     logical, intent(in), optional :: qcd, qed
     if (present (qcd))  generator%qcd_enabled = qcd
     if (present (qed))  generator%qed_enabled = qed
     generator%pl_in = pl_in
     generator%pl_out = pl_out
     generator%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings
     generator%is_gluon = pl_in%search_for_particle (GLUON)
     generator%fs_gluon = pl_out%search_for_particle (GLUON)
     generator%is_photon = pl_in%search_for_particle (PHOTON)
     generator%fs_photon = pl_out%search_for_particle (PHOTON)
     generator%mass_sum = 0._default
     call generator%pdg_raw%init ()
   end subroutine radiation_generator_init_pdg_list
 
   subroutine radiation_generator_init_pdg_array &
        (generator, pdg_in, pdg_out, pdg_excluded_gauge_splittings, qcd, qed)
     class(radiation_generator_t), intent(inout) :: generator
     type(pdg_array_t), intent(in), dimension(:) :: pdg_in, pdg_out
     type(pdg_array_t), intent(in), dimension(:) :: pdg_excluded_gauge_splittings
     logical, intent(in), optional :: qcd, qed
     type(pdg_list_t) :: pl_in, pl_out
     type(pdg_list_t) :: pl_excluded_gauge_splittings
     integer :: i
     call pl_in%init(size (pdg_in))
     call pl_out%init(size (pdg_out))
     do i = 1, size (pdg_in)
        call pl_in%set (i, pdg_in(i))
     end do
     do i = 1, size (pdg_out)
        call pl_out%set (i, pdg_out(i))
     end do
     call pl_excluded_gauge_splittings%init(size (pdg_excluded_gauge_splittings))
     do i = 1, size (pdg_excluded_gauge_splittings)
        call pl_excluded_gauge_splittings%set &
             (i, pdg_excluded_gauge_splittings(i))
     end do
     call generator%init (pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed)
   end subroutine radiation_generator_init_pdg_array
 
 @ %def radiation_generator_init_pdg_list radiation_generator_init_pdg_array
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: set_initial_state_emissions => &
      radiation_generator_set_initial_state_emissions
 <<radiation generator: procedures>>=
   subroutine radiation_generator_set_initial_state_emissions (generator)
      class(radiation_generator_t), intent(inout) :: generator
      generator%only_final_state = .false.
   end subroutine radiation_generator_set_initial_state_emissions
 
 @ %def radiation_generator_set_initial_state_emissions
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: setup_if_table => radiation_generator_setup_if_table
 <<radiation generator: procedures>>=
   subroutine radiation_generator_setup_if_table (generator, model)
     class(radiation_generator_t), intent(inout) :: generator
     class(model_data_t), intent(in), target :: model
     type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
 
     allocate (pl_in(1), pl_out(1))
 
     pl_in(1) = generator%pl_in
     pl_out(1) = generator%pl_out
 
     call generator%if_table%init &
          (model, pl_in, pl_out, generator%constraints)
   end subroutine radiation_generator_setup_if_table
 
 @ %def radiation_generator_setup_if_table
 @
 <<radiation generator: radiation generator: TBP>>=
   generic :: reset_particle_content => reset_particle_content_pdg_array, &
                                        reset_particle_content_pdg_list
   procedure :: reset_particle_content_pdg_list => &
     radiation_generator_reset_particle_content_pdg_list
   procedure :: reset_particle_content_pdg_array => &
     radiation_generator_reset_particle_content_pdg_array
 <<radiation generator: procedures>>=
   subroutine radiation_generator_reset_particle_content_pdg_list (generator, pl)
     class(radiation_generator_t), intent(inout) :: generator
     type(pdg_list_t), intent(in) :: pl
     generator%pl_out = pl
     generator%fs_gluon = pl%search_for_particle (GLUON)
     generator%fs_photon = pl%search_for_particle (PHOTON)
   end subroutine radiation_generator_reset_particle_content_pdg_list
 
   subroutine radiation_generator_reset_particle_content_pdg_array (generator, pdg)
     class(radiation_generator_t), intent(inout) :: generator
     type(pdg_array_t), intent(in), dimension(:) :: pdg
     type(pdg_list_t) :: pl
     integer :: i
     call pl%init (size (pdg))
     do i = 1, size (pdg)
        call pl%set (i, pdg(i))
     end do
     call generator%reset_particle_content (pl)
   end subroutine radiation_generator_reset_particle_content_pdg_array
 
 @ %def radiation_generator_reset_particle_content
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: reset_reshuffle_list=> radiation_generator_reset_reshuffle_list
 <<radiation generator: procedures>>=
   subroutine radiation_generator_reset_reshuffle_list (generator)
     class(radiation_generator_t), intent(inout) :: generator
     call generator%reshuffle_list%reset ()
   end subroutine radiation_generator_reset_reshuffle_list
 
 @ %def radiation_generator_reset_reshuffle_list
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: set_n => radiation_generator_set_n
 <<radiation generator: procedures>>=
   subroutine radiation_generator_set_n (generator, n_in, n_out, n_loops)
     class(radiation_generator_t), intent(inout) :: generator
     integer, intent(in) :: n_in, n_out, n_loops
     generator%n_tot = n_in + n_out + 1
     generator%n_in = n_in
     generator%n_out = n_out
     generator%n_loops = n_loops
   end subroutine radiation_generator_set_n
 
 @ %def radiation_generator_set_n
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: set_constraints => radiation_generator_set_constraints
 <<radiation generator: procedures>>=
   subroutine radiation_generator_set_constraints &
        (generator, set_n_loop, set_mass_sum, &
         set_selected_particles, set_required_particles)
     class(radiation_generator_t), intent(inout), target :: generator
     logical, intent(in) :: set_n_loop
     logical, intent(in) :: set_mass_sum
     logical, intent(in) :: set_selected_particles
     logical, intent(in) :: set_required_particles
     logical :: set_no_photon_induced = .true.
     integer :: i, j, n, n_constraints
     type(pdg_list_t) :: pl_req, pl_insert
     type(pdg_list_t) :: pl_antiparticles
     type(pdg_array_t) :: pdg_gluon, pdg_photon
     type(pdg_array_t) :: pdg_add, pdg_tmp
     integer :: last_index
     integer :: n_new_particles, n_skip
     integer, dimension(:), allocatable :: i_skip
     integer :: n_nlo_correction_types
 
     n_nlo_correction_types = count ([generator%qcd_enabled, generator%qed_enabled])
     if (generator%is_photon) set_no_photon_induced = .false.
 
     allocate (i_skip (generator%n_tot))
     i_skip = -1
 
     n_constraints = 2 + count([set_n_loop, set_mass_sum, &
          set_selected_particles, set_required_particles, set_no_photon_induced])
     associate (constraints => generator%constraints)
       n = 1
       call constraints%init (n_constraints)
       call constraints%set (n, constrain_n_tot (generator%n_tot))
       n = 2
       call constraints%set (n, constrain_couplings (generator%qcd_enabled, &
            generator%qed_enabled, n_nlo_correction_types))
       n = n + 1
       if (set_no_photon_induced) then
          call constraints%set (n, constrain_photon_induced_processes (generator%n_in))
          n = n + 1
       end if
       if (set_n_loop) then
          call constraints%set (n, constrain_n_loop(generator%n_loops))
          n = n + 1
       end if
       if (set_mass_sum) then
          call constraints%set (n, constrain_mass_sum(generator%mass_sum))
          n = n + 1
       end if
       if (set_required_particles) then
          if (generator%fs_gluon .or. generator%fs_photon) then
             do i = 1, generator%n_out
                pdg_tmp = generator%pl_out%get(i)
                if (pdg_tmp%search_for_particle (GLUON) &
                     .or. pdg_tmp%search_for_particle (PHOTON)) then
                   i_skip(i) = i
                end if
             end do
 
             n_skip = count (i_skip > 0)
             call pl_req%init (generator%n_out-n_skip)
          else
             call pl_req%init (generator%n_out)
          end if
          j = 1
          do i = 1, generator%n_out
             if (any (i == i_skip)) cycle
             call pl_req%set (j, generator%pl_out%get(i))
             j = j + 1
          end do
          call constraints%set (n, constrain_require (pl_req))
          n = n + 1
       end if
       if (set_selected_particles) then
          if (generator%only_final_state ) then
             call pl_insert%init (generator%n_out + n_nlo_correction_types)
             do i = 1, generator%n_out
                call pl_insert%set(i, generator%pl_out%get(i))
             end do
             last_index = generator%n_out + 1
          else
             call generator%pl_in%create_antiparticles (pl_antiparticles, n_new_particles)
             call pl_insert%init (generator%n_tot + n_new_particles &
                  + n_nlo_correction_types)
             do i = 1, generator%n_in
                call pl_insert%set(i, generator%pl_in%get(i))
             end do
             do i = 1, generator%n_out
                j = i + generator%n_in
                call pl_insert%set(j, generator%pl_out%get(i))
             end do
             do i = 1, n_new_particles
                j = i + generator%n_in + generator%n_out
                call pl_insert%set(j, pl_antiparticles%get(i))
             end do
             last_index = generator%n_tot + n_new_particles + 1
          end if
          pdg_gluon = GLUON; pdg_photon = PHOTON
          if (generator%qcd_enabled) then
             pdg_add = pdg_gluon
             call pl_insert%set (last_index, pdg_add)
             last_index = last_index + 1
          end if
          if (generator%qed_enabled) then
             pdg_add = pdg_photon
             call pl_insert%set (last_index, pdg_add)
          end if
          call constraints%set (n, constrain_splittings (pl_insert, &
               generator%pl_excluded_gauge_splittings))
       end if
     end associate
   end subroutine radiation_generator_set_constraints
 
 @ %def radiation_generator_set_constraints
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: find_splittings => radiation_generator_find_splittings
 <<radiation generator: procedures>>=
   subroutine radiation_generator_find_splittings (generator)
     class(radiation_generator_t), intent(inout) :: generator
     integer :: i
     type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out, pdg_tmp
     integer, dimension(:), allocatable :: reshuffle_list
 
     call generator%pl_in%create_pdg_array (pdg_in)
     call generator%pl_out%create_pdg_array (pdg_out)
 
     associate (if_table => generator%if_table)
        call if_table%radiate (generator%constraints, do_not_check_regular = .true.)
 
        do i = 1, if_table%get_length ()
           call if_table%get_pdg_out (i, pdg_tmp)
           if (size (pdg_tmp) == generator%n_tot) then
              call pdg_reshuffle (pdg_out, pdg_tmp, reshuffle_list)
              call generator%reshuffle_list%append (reshuffle_list)
           end if
        end do
     end associate
 
   contains
 
     subroutine pdg_reshuffle (pdg_born, pdg_real, list)
       type(pdg_array_t), intent(in), dimension(:) :: pdg_born, pdg_real
       integer, intent(out), dimension(:), allocatable :: list
       type(pdg_sorter_t), dimension(:), allocatable :: sort_born
       type(pdg_sorter_t), dimension(:), allocatable :: sort_real
       integer :: i_min, n_in, n_born, n_real
       integer :: ib, ir
 
       n_in = generator%n_in
       n_born = size (pdg_born)
       n_real = size (pdg_real)
       allocate (list (n_real - n_in))
       allocate (sort_born (n_born))
       allocate (sort_real (n_real - n_in))
       sort_born%pdg = pdg_born%get ()
       sort_real%pdg = pdg_real(n_in + 1 : n_real)%get()
       do ib = 1, n_born
          if (any (sort_born(ib)%pdg == sort_real%pdg)) &
             call associate_born_indices (sort_born(ib), sort_real, ib, n_real)
       end do
       i_min = maxval (sort_real%associated_born) + 1
       do ir = 1, n_real - n_in
          if (sort_real(ir)%associated_born == 0) then
             sort_real(ir)%associated_born = i_min
             i_min = i_min + 1
          end if
       end do
       list = sort_real%associated_born
     end subroutine pdg_reshuffle
 
     subroutine associate_born_indices (sort_born, sort_real, ib, n_real)
       type(pdg_sorter_t), intent(in) :: sort_born
       type(pdg_sorter_t), intent(inout), dimension(:) :: sort_real
       integer, intent(in) :: ib, n_real
       integer :: ir
       do ir = 1, n_real - generator%n_in
          if (sort_born%pdg == sort_real(ir)%pdg &
             .and..not. sort_real(ir)%checked) then
             sort_real(ir)%associated_born = ib
             sort_real(ir)%checked = .true.
             exit
         end if
       end do
     end subroutine associate_born_indices
   end subroutine radiation_generator_find_splittings
 
 @ %def radiation_generator_find_splittings
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: generate_real_particle_strings &
        => radiation_generator_generate_real_particle_strings
 <<radiation generator: procedures>>=
   subroutine radiation_generator_generate_real_particle_strings &
        (generator, prt_tot_in, prt_tot_out)
     type :: prt_array_t
        type(string_t), dimension(:), allocatable :: prt
     end type
     class(radiation_generator_t), intent(inout) :: generator
     type(string_t), intent(out), dimension(:), allocatable :: prt_tot_in, prt_tot_out
     type(prt_array_t), dimension(:), allocatable :: prt_in, prt_out
     type(prt_array_t), dimension(:), allocatable :: prt_out0, prt_in0
     type(pdg_array_t), dimension(:), allocatable :: pdg_tmp, pdg_out, pdg_in
     type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
     type(prt_array_t) :: prt_out0_tmp, prt_in0_tmp
     integer :: i, j
     integer, dimension(:), allocatable :: reshuffle_list_local
     type(reshuffle_list_t) :: reshuffle_list
     integer :: flv
     type(string_t), dimension(:), allocatable :: buf
     integer :: i_buf
 
     flv = 0
     allocate (prt_in0(0), prt_out0(0))
     associate (if_table => generator%if_table)
        do i = 1, if_table%get_length ()
           call if_table%get_pdg_out (i, pdg_tmp)
           if (size (pdg_tmp) == generator%n_tot) then
              call if_table%get_particle_string (i, &
                   prt_in0_tmp%prt, prt_out0_tmp%prt)
              prt_in0 = [prt_in0, prt_in0_tmp]
              prt_out0 = [prt_out0, prt_out0_tmp]
              flv = flv + 1
           end if
        end do
     end associate
 
     allocate (prt_in(size (prt_in0)), prt_out(size (prt_out0)))
     do i = 1, flv
        allocate (prt_in(i)%prt (generator%n_in))
        allocate (prt_out(i)%prt (generator%n_tot - generator%n_in))
     end do
     allocate (prt_tot_in (generator%n_in))
     allocate (prt_tot_out (generator%n_tot - generator%n_in))
     allocate (buf (generator%n_tot))
     buf = ""
 
     do j = 1, flv
        do i = 1, generator%n_in
           prt_in(j)%prt(i) = prt_in0(j)%prt(i)
           call fill_buffer (buf(i), prt_in0(j)%prt(i))
        end do
     end do
     prt_tot_in = buf(1 : generator%n_in)
 
     do j = 1, flv
        allocate (reshuffle_list_local (size (generator%reshuffle_list%get(j))))
        reshuffle_list_local = generator%reshuffle_list%get(j)
        do i = 1, size (reshuffle_list_local)
           prt_out(j)%prt(reshuffle_list_local(i)) = prt_out0(j)%prt(i)
           i_buf = reshuffle_list_local(i) + generator%n_in
           call fill_buffer (buf(i_buf), &
                prt_out(j)%prt(reshuffle_list_local(i)))
        end do
        !!! Need to deallocate here because in the next iteration the reshuffling
        !!! list can have a different size
        deallocate (reshuffle_list_local)
     end do
     prt_tot_out = buf(generator%n_in + 1 : generator%n_tot)
     if (debug2_active (D_CORE)) then
        print *, 'Generated initial state: '
        do i = 1, size (prt_tot_in)
           print *, char (prt_tot_in(i))
        end do
        print *, 'Generated final state: '
        do i = 1, size (prt_tot_out)
           print *, char (prt_tot_out(i))
        end do
     end if
 
 
   contains
 
     subroutine fill_buffer (buffer, particle)
       type(string_t), intent(inout) :: buffer
       type(string_t), intent(in) :: particle
       logical :: particle_present
       if (len (buffer) > 0) then
          particle_present = check_for_substring (char(buffer), particle)
          if (.not. particle_present) buffer = buffer // ":" // particle
       else
          buffer = buffer // particle
       end if
     end subroutine fill_buffer
 
     function check_for_substring (buffer, substring) result (exist)
       character(len=*), intent(in) :: buffer
       type(string_t), intent(in) :: substring
       character(len=50) :: buffer_internal
       logical :: exist
       integer :: i_first, i_last
       exist = .false.
       i_first = 1; i_last = 1
       do
          if (buffer(i_last:i_last) == ":") then
             buffer_internal = buffer (i_first : i_last - 1)
             if (buffer_internal == char (substring)) then
                exist = .true.
                exit
             end if
             i_first = i_last + 1; i_last = i_first + 1
             if (i_last > len(buffer)) exit
          else if (i_last == len(buffer)) then
             buffer_internal = buffer (i_first : i_last)
             exist = buffer_internal == char (substring)
             exit
          else
             i_last = i_last + 1
             if (i_last > len(buffer)) exit
          end if
       end do
     end function check_for_substring
   end subroutine radiation_generator_generate_real_particle_strings
 
 @ %def radiation_generator_generate_real_particle_strings
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: contains_emissions => radiation_generator_contains_emissions
 <<radiation generator: procedures>>=
   function radiation_generator_contains_emissions (generator) result (has_em)
     logical :: has_em
     class(radiation_generator_t), intent(in) :: generator
     has_em = .not. generator%reshuffle_list%is_empty ()
   end function radiation_generator_contains_emissions
 
 @ %def radiation_generator_contains_emissions
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: generate => radiation_generator_generate
 <<radiation generator: procedures>>=
   subroutine radiation_generator_generate (generator, prt_in, prt_out)
     class(radiation_generator_t), intent(inout) :: generator
     type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out
     call generator%find_splittings ()
     call generator%generate_real_particle_strings (prt_in, prt_out)
   end subroutine radiation_generator_generate
 
 @ %def radiation_generator_generate
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: generate_multiple => radiation_generator_generate_multiple
 <<radiation generator: procedures>>=
   subroutine radiation_generator_generate_multiple (generator, max_multiplicity, model)
     class(radiation_generator_t), intent(inout) :: generator
     integer, intent(in) :: max_multiplicity
     class(model_data_t), intent(in), target :: model
     if (max_multiplicity <= generator%n_out) &
          call msg_fatal ("GKS states: Multiplicity is not large enough!")
     call generator%first_emission (model)
     call generator%reset_reshuffle_list ()
     if (max_multiplicity - generator%n_out > 1) &
          call generator%append_emissions (max_multiplicity, model)
   end subroutine radiation_generator_generate_multiple
 
 @ %def radiation_generator_generate_multiple
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: first_emission => radiation_generator_first_emission
 <<radiation generator: procedures>>=
   subroutine radiation_generator_first_emission (generator, model)
     class(radiation_generator_t), intent(inout) :: generator
     class(model_data_t), intent(in), target :: model
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     call generator%setup_if_table (model)
     call generator%generate (prt_in, prt_out)
     call generator%prt_queue%null ()
     call generator%prt_queue%append (prt_out)
   end subroutine radiation_generator_first_emission
 
 @ %def radiation_generator_first_emission
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: append_emissions => radiation_generator_append_emissions
 <<radiation generator: procedures>>=
   subroutine radiation_generator_append_emissions (generator, max_multiplicity, model)
     class(radiation_generator_t), intent(inout) :: generator
     integer, intent(in) :: max_multiplicity
     class(model_data_t), intent(in), target :: model
     type(string_t), dimension(:), allocatable :: prt_fetched
     type(string_t), dimension(:), allocatable :: prt_in
     type(string_t), dimension(:), allocatable :: prt_out
     type(pdg_array_t), dimension(:), allocatable :: pdg_new_out
     integer :: current_multiplicity, i, j, n_longest_length
     type :: prt_table_t
        type(string_t), dimension(:), allocatable :: prt
     end type prt_table_t
     type(prt_table_t), dimension(:), allocatable :: prt_table_out
     do
        call generator%prt_queue%get (prt_fetched)
        current_multiplicity = size (prt_fetched)
        if (current_multiplicity == max_multiplicity) exit
        call create_pdg_array (prt_fetched, model, &
             pdg_new_out)
        call generator%reset_particle_content (pdg_new_out)
        call generator%set_n (2, current_multiplicity, 0)
        call generator%set_constraints (.false., .false., .true., .true.)
        call generator%setup_if_table (model)
        call generator%generate (prt_in, prt_out)
        n_longest_length = get_length_of_longest_tuple (prt_out)
        call separate_particles (prt_out, prt_table_out)
        do i = 1, n_longest_length
           if (.not. any (prt_table_out(i)%prt == " ")) then
              call sort_prt (prt_table_out(i)%prt, model)
              if (.not. generator%prt_queue%contains (prt_table_out(i)%prt)) then
                 call generator%prt_queue%append (prt_table_out(i)%prt)
              end if
           end if
        end do
        call generator%reset_reshuffle_list ()
     end do
 
   contains
     subroutine separate_particles (prt, prt_table)
       type(string_t), intent(in), dimension(:) :: prt
       type(string_t), dimension(:), allocatable :: prt_tmp
       type(prt_table_t), intent(out), dimension(:), allocatable :: prt_table
       integer :: i, j
       logical, dimension(:), allocatable :: tuples_occured
       allocate (prt_table (n_longest_length))
       do i = 1, n_longest_length
          allocate (prt_table(i)%prt (size (prt)))
       end do
       allocate (tuples_occured (size (prt)))
       do j = 1, size (prt)
          call split_string (prt(j), var_str (":"), prt_tmp)
          do i = 1, n_longest_length
             if (i <= size (prt_tmp)) then
                prt_table(i)%prt(j) = prt_tmp(i)
             else
                prt_table(i)%prt(j) = " "
             end if
          end do
          if (n_longest_length > 1) &
               tuples_occured(j) = prt_table(1)%prt(j) /= " " &
               .and. prt_table(2)%prt(j) /= " "
       end do
       if (any (tuples_occured)) then
          do j = 1, size (tuples_occured)
             if (.not. tuples_occured(j)) then
                do i = 2, n_longest_length
                   prt_table(i)%prt(j) = prt_table(1)%prt(j)
                end do
             end if
          end do
       end if
     end subroutine separate_particles
 
   function get_length_of_longest_tuple (prt) result (longest_length)
       type(string_t), intent(in), dimension(:) :: prt
       integer :: longest_length, i
       type(prt_table_t), dimension(:), allocatable :: prt_table
       allocate (prt_table (size (prt)))
       longest_length = 0
       do i = 1, size (prt)
          call split_string (prt(i), var_str (":"), prt_table(i)%prt)
          if (size (prt_table(i)%prt) > longest_length) &
               longest_length = size (prt_table(i)%prt)
       end do
     end function get_length_of_longest_tuple
   end subroutine radiation_generator_append_emissions
 @ %def radiation_generator_append_emissions
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: reset_queue => radiation_generator_reset_queue
 <<radiation generator: procedures>>=
   subroutine radiation_generator_reset_queue (generator)
     class(radiation_generator_t), intent(inout) :: generator
     call generator%prt_queue%reset ()
   end subroutine radiation_generator_reset_queue
 
 @ %def radiation_generator_reset_queue
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: get_n_gks_states => radiation_generator_get_n_gks_states
 <<radiation generator: procedures>>=
   function radiation_generator_get_n_gks_states (generator) result (n)
     class(radiation_generator_t), intent(in) :: generator
     integer :: n
     n = generator%prt_queue%n_lists
   end function radiation_generator_get_n_gks_states
 
 @ %def radiation_generator_get_n_fks_states
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: get_next_state => radiation_generator_get_next_state
 <<radiation generator: procedures>>=
   function radiation_generator_get_next_state (generator) result (prt_string)
     class(radiation_generator_t), intent(inout) :: generator
     type(string_t), dimension(:), allocatable :: prt_string
     call generator%prt_queue%get (prt_string)
   end function radiation_generator_get_next_state
 
 @ %def radiation_generator_get_next_state
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: get_emitter_indices => radiation_generator_get_emitter_indices
 <<radiation generator: procedures>>=
   subroutine radiation_generator_get_emitter_indices (generator, indices)
      class(radiation_generator_t), intent(in) :: generator
      integer, dimension(:), allocatable, intent(out) :: indices
      type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
      integer, dimension(:), allocatable :: flv_in, flv_out
      integer, dimension(:), allocatable :: emitters
      integer :: i, j
      integer :: n_in, n_out
 
      call generator%pl_in%create_pdg_array (pdg_in)
      call generator%pl_out%create_pdg_array (pdg_out)
 
      n_in = size (pdg_in); n_out = size (pdg_out)
      allocate (flv_in (n_in), flv_out (n_out))
      forall (i=1:n_in) flv_in(i) = pdg_in(i)%get()
      forall (i=1:n_out) flv_out(i) = pdg_out(i)%get()
 
      call generator%if_table%get_emitters (generator%constraints, emitters)
      allocate (indices (size (emitters)))
 
      j = 1
      do i = 1, n_in + n_out
         if (i <= n_in) then
            if (any (flv_in(i) == emitters)) then
               indices (j) = i
               j = j + 1
            end if
         else
            if (any (flv_out(i-n_in) == emitters)) then
               indices (j) = i
               j = j + 1
            end if
         end if
      end do
   end subroutine radiation_generator_get_emitter_indices
 
 @ %def radiation_generator_get_emitter_indices
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: get_raw_states => radiation_generator_get_raw_states
 <<radiation generator: procedures>>=
   function radiation_generator_get_raw_states (generator) result (raw_states)
     class(radiation_generator_t), intent(in), target :: generator
     integer, dimension(:,:), allocatable :: raw_states
     type(pdg_states_t), pointer :: state
     integer :: n_states, n_particles
     integer :: i_state
     integer :: j
     state => generator%pdg_raw
     n_states = generator%pdg_raw%get_n_states ()
     n_particles = size (generator%pdg_raw%pdg)
     allocate (raw_states (n_particles, n_states))
     do i_state = 1, n_states
       do j = 1, n_particles
         raw_states (j, i_state) = state%pdg(j)%get ()
       end do
         state => state%next
     end do
   end function radiation_generator_get_raw_states
 
 @ %def radiation_generator_get_raw_states
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: save_born_raw => radiation_generator_save_born_raw
 <<radiation generator: procedures>>=
   subroutine radiation_generator_save_born_raw (generator, pdg_in, pdg_out)
     class(radiation_generator_t), intent(inout) :: generator
     type(pdg_array_t), dimension(:), allocatable, intent(in) :: pdg_in, pdg_out
     generator%pdg_in_born = pdg_in
     generator%pdg_out_born = pdg_out
   end subroutine radiation_generator_save_born_raw
 @ %def radiation_generator_save_born_raw
 @
 <<radiation generator: radiation generator: TBP>>=
   procedure :: get_born_raw => radiation_generator_get_born_raw
 <<radiation generator: procedures>>=
   function radiation_generator_get_born_raw (generator) result (flv_born)
     class(radiation_generator_t), intent(in) :: generator
     integer, dimension(:,:), allocatable :: flv_born
     integer :: i_part, n_particles
     n_particles = size (generator%pdg_in_born) + size (generator%pdg_out_born)
     allocate (flv_born (n_particles, 1))
     flv_born(1,1) = generator%pdg_in_born(1)%get ()
     flv_born(2,1) = generator%pdg_in_born(2)%get ()
     do i_part = 3, n_particles
       flv_born(i_part, 1) = generator%pdg_out_born(i_part-2)%get ()
     end do
   end function radiation_generator_get_born_raw
 
 @ %def radiation_generator_get_born_raw
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[radiation_generator_ut.f90]]>>=
 <<File header>>
 
 module radiation_generator_ut
   use unit_tests
   use radiation_generator_uti
 
 <<Standard module head>>
 
 <<radiation generator: public test>>
 
 contains
 
 <<radiation generator: test driver>>
 
 end module radiation_generator_ut
 @ %def radiation_generator_ut
 @
 <<[[radiation_generator_uti.f90]]>>=
 <<File header>>
 
 module radiation_generator_uti
 
 <<Use strings>>
   use format_utils, only: write_separator
   use os_interface
   use pdg_arrays
   use models
   use kinds, only: default
 
   use radiation_generator
 
 <<Standard module head>>
 
 <<radiation generator: test declarations>>
 
 contains
 
 <<radiation generator: tests>>
 
 <<radiation generator: test auxiliary>>
 
 end module radiation_generator_uti
 @ %def radiation_generator_ut
 @ API: driver for the unit tests below.
 <<radiation generator: public test>>=
   public :: radiation_generator_test
 <<radiation generator: test driver>>=
   subroutine radiation_generator_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
     call test(radiation_generator_1, "radiation_generator_1", &
          "Test the generator of N+1-particle flavor structures in QCD", &
          u, results)
     call test(radiation_generator_2, "radiation_generator_2", &
          "Test multiple splittings in QCD", &
          u, results)
     call test(radiation_generator_3, "radiation_generator_3", &
          "Test the generator of N+1-particle flavor structures in QED", &
          u, results)
     call test(radiation_generator_4, "radiation_generator_4", &
          "Test multiple splittings in QED", &
          u, results)
   end subroutine radiation_generator_test
 
 @ %def radiation_generator_test
 @
 <<radiation generator: test declarations>>=
   public :: radiation_generator_1
 <<radiation generator: tests>>=
   subroutine radiation_generator_1 (u)
     integer, intent(in) :: u
     type(radiation_generator_t) :: generator
     type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model => null ()
 
     write (u, "(A)") "* Test output: radiation_generator_1"
     write (u, "(A)") "* Purpose: Create N+1-particle flavor structures &
          &from predefined N-particle flavor structures"
     write (u, "(A)") "* One additional strong coupling, no additional electroweak coupling"
     write (u, "(A)")
     write (u, "(A)") "* Loading radiation model: SM.mdl"
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model_list%read_model &
          (var_str ("SM"), var_str ("SM.mdl"), &
          os_data, model)
     write (u, "(A)") "* Success"
 
     allocate (pdg_in (2))
     pdg_in(1) = 11; pdg_in(2) = -11
 
     write (u, "(A)") "* Start checking processes"
     call write_separator (u)
 
     write (u, "(A)") "* Process 1: Top pair-production with additional gluon"
     allocate (pdg_out(3))
     pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = 21
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 2: Top pair-production with additional jet"
     allocate (pdg_out(3))
     pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = [-1,1,-2,2,-3,3,-4,4,-5,5,21]
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 3: Quark-antiquark production"
     allocate (pdg_out(2))
     pdg_out(1) = 2; pdg_out(2) = -2
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 4: Quark-antiquark production with additional gluon"
     allocate (pdg_out(3))
     pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 21
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 5: Z + jets"
     allocate (pdg_out(3))
     pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 6: Top Decay"
     allocate (pdg_out(4))
     pdg_out(1) = 24; pdg_out(2) = -24
     pdg_out(3) = 5; pdg_out(4) = -5
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 7: Production of four quarks"
     allocate (pdg_out(4))
     pdg_out(1) = 2; pdg_out(2) = -2;
     pdg_out(3) = 2; pdg_out(4) = -2
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out); deallocate (pdg_in)
 
     write (u, "(A)") "* Process 8: Drell-Yan lepto-production"
     allocate (pdg_in (2)); allocate (pdg_out (2))
     pdg_in(1) = 2; pdg_in(2) = -2
     pdg_out(1) = 11; pdg_out(2) = -11
     call test_process (generator, pdg_in, pdg_out, u, .true.)
     deallocate (pdg_out); deallocate (pdg_in)
 
     write (u, "(A)") "* Process 9: WZ production at hadron-colliders"
     allocate (pdg_in (2)); allocate (pdg_out (2))
     pdg_in(1) = 1; pdg_in(2) = -2
     pdg_out(1) = -24; pdg_out(2) = 23
     call test_process (generator, pdg_in, pdg_out, u, .true.)
     deallocate (pdg_out); deallocate (pdg_in)
 
   contains
     subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state)
       type(radiation_generator_t), intent(inout) :: generator
       type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
       integer, intent(in) :: u
       logical, intent(in), optional :: include_initial_state
       type(string_t), dimension(:), allocatable :: prt_strings_in
       type(string_t), dimension(:), allocatable :: prt_strings_out
       type(pdg_array_t), dimension(10) :: pdg_excluded
       logical :: yorn
       yorn = .false.
       pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
       if (present (include_initial_state)) yorn = include_initial_state
       write (u, "(A)") "* Leading order: "
       write (u, "(A)", advance = 'no') '* Incoming: '
       call write_pdg_array (pdg_in, u)
       write (u, "(A)", advance = 'no') '* Outgoing: '
       call write_pdg_array (pdg_out, u)
 
       call generator%init (pdg_in, pdg_out, &
            pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.)
       call generator%set_n (2, size(pdg_out), 0)
       if (yorn)  call generator%set_initial_state_emissions ()
       call generator%set_constraints (.false., .false., .true., .true.)
       call generator%setup_if_table (model)
       call generator%generate (prt_strings_in, prt_strings_out)
       write (u, "(A)") "* Additional radiation: "
       write (u, "(A)") "* Incoming: "
       call write_particle_string (prt_strings_in, u)
       write (u, "(A)") "* Outgoing: "
       call write_particle_string (prt_strings_out, u)
       call write_separator(u)
       call generator%reset_reshuffle_list ()
     end subroutine test_process
 
   end subroutine radiation_generator_1
 
 @ %def radiation_generator_1
 @
 <<radiation generator: test declarations>>=
   public :: radiation_generator_2
 <<radiation generator: tests>>=
   subroutine radiation_generator_2 (u)
     integer, intent(in) :: u
     type(radiation_generator_t) :: generator
     type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
     type(pdg_array_t), dimension(:), allocatable :: pdg_excluded
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model => null ()
     integer, parameter :: max_multiplicity = 10
     type(string_t), dimension(:), allocatable :: prt_last
 
     write (u, "(A)") "* Test output: radiation_generator_2"
     write (u, "(A)") "* Purpose: Test the repeated application of &
          &a radiation generator splitting in QCD"
     write (u, "(A)") "* Only Final state emissions! "
     write (u, "(A)")
     write (u, "(A)") "* Loading radiation model: SM.mdl"
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model_list%read_model &
        (var_str ("SM"), var_str ("SM.mdl"), &
         os_data, model)
     write (u, "(A)") "* Success"
 
     allocate (pdg_in (2))
     pdg_in(1) = 11; pdg_in(2) = -11
     allocate (pdg_out(2))
     pdg_out(1) = 2; pdg_out(2) = -2
     allocate (pdg_excluded (10))
     pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
 
     write (u, "(A)") "* Leading order"
     write (u, "(A)", advance = 'no') "* Incoming: "
     call write_pdg_array (pdg_in, u)
     write (u, "(A)", advance = 'no') "* Outgoing: "
     call write_pdg_array (pdg_out, u)
 
     call generator%init (pdg_in, pdg_out, &
          pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.)
     call generator%set_n (2, 2, 0)
     call generator%set_constraints (.false., .false., .true., .true.)
 
     call write_separator (u)
     write (u, "(A)") "Generate higher-multiplicity states"
     write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity
     call generator%generate_multiple (max_multiplicity, model)
     call generator%prt_queue%write (u)
     call write_separator (u)
     write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists
 
     write (u, "(A)") "Check that no particle state occurs twice or more"
     if (.not. generator%prt_queue%check_for_same_prt_strings()) then
        write (u, "(A)") "SUCCESS"
     else
        write (u, "(A)") "FAIL"
     end if
     call write_separator (u)
     write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:"
     call generator%prt_queue%get_last (prt_last)
     if (size (prt_last) == max_multiplicity) then
        write (u, "(A)") "SUCCESS"
     else
        write (u, "(A)") "FAIL"
     end if
   end subroutine radiation_generator_2
 
 @ %def radiation_generator_2
 @
 <<radiation generator: test declarations>>=
   public :: radiation_generator_3
 <<radiation generator: tests>>=
   subroutine radiation_generator_3 (u)
     integer, intent(in) :: u
     type(radiation_generator_t) :: generator
     type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model => null ()
 
     write (u, "(A)") "* Test output: radiation_generator_3"
     write (u, "(A)") "* Purpose: Create N+1-particle flavor structures &
          &from predefined N-particle flavor structures"
     write (u, "(A)") "* One additional electroweak coupling, no additional strong coupling"
     write (u, "(A)")
     write (u, "(A)") "* Loading radiation model: SM.mdl"
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model_list%read_model &
          (var_str ("SM"), var_str ("SM.mdl"), &
          os_data, model)
     write (u, "(A)") "* Success"
 
     allocate (pdg_in (2))
     pdg_in(1) = 11; pdg_in(2) = -11
 
     write (u, "(A)") "* Start checking processes"
     call write_separator (u)
 
     write (u, "(A)") "* Process 1: Tau pair-production with additional photon"
     allocate (pdg_out(3))
     pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = 22
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 2: Tau pair-production with additional leptons or photon"
     allocate (pdg_out(3))
     pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = [-13, 13, 22]
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 3: Electron-positron production"
     allocate (pdg_out(2))
     pdg_out(1) = 11; pdg_out(2) = -11
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 4: Quark-antiquark production with additional photon"
     allocate (pdg_out(3))
     pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 22
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 5: Z + jets "
     allocate (pdg_out(3))
     pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 6: W + jets"
     allocate (pdg_out(3))
     pdg_out(1) = 1; pdg_out(2) = -2; pdg_out(3) = -24
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 7: Top Decay"
     allocate (pdg_out(4))
     pdg_out(1) = 24; pdg_out(2) = -24
     pdg_out(3) = 5; pdg_out(4) = -5
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 8: Production of four quarks"
     allocate (pdg_out(4))
     pdg_out(1) = 2; pdg_out(2) = -2;
     pdg_out(3) = 2; pdg_out(4) = -2
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out)
 
     write (u, "(A)") "* Process 9: Neutrino pair-production"
     allocate (pdg_out(2))
     pdg_out(1) = 12; pdg_out(2) = -12
     call test_process (generator, pdg_in, pdg_out, u, .true.)
     deallocate (pdg_out); deallocate (pdg_in)
 
     write (u, "(A)") "* Process 10: Drell-Yan lepto-production"
     allocate (pdg_in (2)); allocate (pdg_out (2))
     pdg_in(1) = 2; pdg_in(2) = -2
     pdg_out(1) = 11; pdg_out(2) = -11
     call test_process (generator, pdg_in, pdg_out, u, .true.)
     deallocate (pdg_out); deallocate (pdg_in)
 
     write (u, "(A)") "* Process 11: WZ production at hadron-colliders"
     allocate (pdg_in (2)); allocate (pdg_out (2))
     pdg_in(1) = 1; pdg_in(2) = -2
     pdg_out(1) = -24; pdg_out(2) = 23
     call test_process (generator, pdg_in, pdg_out, u, .true.)
     deallocate (pdg_out); deallocate (pdg_in)
 
     write (u, "(A)") "* Process 12: Positron-neutrino production"
     allocate (pdg_in (2)); allocate (pdg_out (2))
     pdg_in(1) = -1; pdg_in(2) = 2
     pdg_out(1) = -11; pdg_out(2) = 12
     call test_process (generator, pdg_in, pdg_out, u)
     deallocate (pdg_out); deallocate (pdg_in)
 
   contains
     subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state)
       type(radiation_generator_t), intent(inout) :: generator
       type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
       integer, intent(in) :: u
       logical, intent(in), optional :: include_initial_state
       type(string_t), dimension(:), allocatable :: prt_strings_in
       type(string_t), dimension(:), allocatable :: prt_strings_out
       type(pdg_array_t), dimension(10) :: pdg_excluded
       logical :: yorn
       yorn = .false.
       pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
       if (present (include_initial_state)) yorn = include_initial_state
       write (u, "(A)") "* Leading order: "
       write (u, "(A)", advance = 'no') '* Incoming: '
       call write_pdg_array (pdg_in, u)
       write (u, "(A)", advance = 'no') '* Outgoing: '
       call write_pdg_array (pdg_out, u)
 
       call generator%init (pdg_in, pdg_out, &
            pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.)
       call generator%set_n (2, size(pdg_out), 0)
       if (yorn) call generator%set_initial_state_emissions ()
       call generator%set_constraints (.false., .false., .true., .true.)
       call generator%setup_if_table (model)
       call generator%generate (prt_strings_in, prt_strings_out)
       write (u, "(A)") "* Additional radiation: "
       write (u, "(A)") "* Incoming: "
       call write_particle_string (prt_strings_in, u)
       write (u, "(A)") "* Outgoing: "
       call write_particle_string (prt_strings_out, u)
       call write_separator(u)
       call generator%reset_reshuffle_list ()
     end subroutine test_process
 
   end subroutine radiation_generator_3
 
 @ %def radiation_generator_3
 @
 <<radiation generator: test declarations>>=
   public :: radiation_generator_4
 <<radiation generator: tests>>=
   subroutine radiation_generator_4 (u)
     integer, intent(in) :: u
     type(radiation_generator_t) :: generator
     type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
     type(pdg_array_t), dimension(:), allocatable :: pdg_excluded
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model => null ()
     integer, parameter :: max_multiplicity = 10
     type(string_t), dimension(:), allocatable :: prt_last
 
     write (u, "(A)") "* Test output: radiation_generator_4"
     write (u, "(A)") "* Purpose: Test the repeated application of &
          &a radiation generator splitting in QED"
     write (u, "(A)") "* Only Final state emissions! "
     write (u, "(A)")
     write (u, "(A)") "* Loading radiation model: SM.mdl"
 
     call syntax_model_file_init ()
     call os_data%init ()
     call model_list%read_model &
        (var_str ("SM"), var_str ("SM.mdl"), &
         os_data, model)
     write (u, "(A)") "* Success"
 
     allocate (pdg_in (2))
     pdg_in(1) = 2; pdg_in(2) = -2
     allocate (pdg_out(2))
     pdg_out(1) = 11; pdg_out(2) = -11
     allocate ( pdg_excluded (14))
     pdg_excluded = [1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, -6, 15, -15]
 
     write (u, "(A)") "* Leading order"
     write (u, "(A)", advance = 'no') "* Incoming: "
     call write_pdg_array (pdg_in, u)
     write (u, "(A)", advance = 'no') "* Outgoing: "
     call write_pdg_array (pdg_out, u)
 
     call generator%init (pdg_in, pdg_out, &
          pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.)
     call generator%set_n (2, 2, 0)
     call generator%set_constraints (.false., .false., .true., .true.)
 
     call write_separator (u)
     write (u, "(A)") "Generate higher-multiplicity states"
     write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity
     call generator%generate_multiple (max_multiplicity, model)
     call generator%prt_queue%write (u)
     call write_separator (u)
     write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists
 
     write (u, "(A)") "Check that no particle state occurs twice or more"
     if (.not. generator%prt_queue%check_for_same_prt_strings()) then
        write (u, "(A)") "SUCCESS"
     else
        write (u, "(A)") "FAIL"
     end if
     call write_separator (u)
     write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:"
     call generator%prt_queue%get_last (prt_last)
     if (size (prt_last) == max_multiplicity) then
        write (u, "(A)") "SUCCESS"
     else
        write (u, "(A)") "FAIL"
     end if
   end subroutine radiation_generator_4
 
 @ %def radiation_generator_4
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Sindarin Expression Implementation}
 
 This module defines expressions of all kinds, represented in
 a tree structure, for repeated evaluation.  This provides an
 implementation of the [[expr_base]] abstract type.
 
 We have two flavors of expressions: one with particles and one without
 particles.  The latter version is used for defining cut/selection
 criteria and for online analysis.
 <<[[eval_trees.f90]]>>=
 <<File header>>
 
 module eval_trees
 
   use, intrinsic :: iso_c_binding !NODEP!
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants, only: DEGREE, IMAGO, PI
   use format_defs, only: FMT_19
   use numeric_utils, only: nearly_equal
   use diagnostics
   use lorentz
   use md5
   use formats
   use sorting
   use ifiles
   use lexers
   use syntax_rules
   use parser
   use analysis
   use jets
   use pdg_arrays
   use subevents
   use user_code_interface
   use var_base
   use expr_base
   use variables
   use observables
 
 <<Standard module head>>
 
 <<Eval trees: public>>
 
 <<Eval trees: types>>
 
 <<Eval trees: interfaces>>
 
 <<Eval trees: variables>>
 
 contains
 
 <<Eval trees: procedures>>
 
 end module eval_trees
 @ %def eval_trees
 @
 \subsection{Tree nodes}
 The evaluation tree consists of branch nodes (unary and binary) and of
 leaf nodes, originating from a common root.  The node object should be
 polymorphic.  For the time being, polymorphism is emulated here.  This
 means that we have to maintain all possibilities that the node may
 hold, including associated procedures as pointers.
 
 The following parameter values characterize the node.  Unary and
 binary operators have sub-nodes.  The other are leaf nodes.  Possible
 leafs are literal constants or named-parameter references.
 <<Eval trees: types>>=
   integer, parameter :: EN_UNKNOWN = 0, EN_UNARY = 1, EN_BINARY = 2
   integer, parameter :: EN_CONSTANT = 3, EN_VARIABLE = 4
   integer, parameter :: EN_CONDITIONAL = 5, EN_BLOCK = 6
   integer, parameter :: EN_RECORD_CMD = 7
   integer, parameter :: EN_OBS1_INT = 11, EN_OBS2_INT = 12
   integer, parameter :: EN_OBS1_REAL = 21, EN_OBS2_REAL = 22
   integer, parameter :: EN_UOBS1_INT = 31, EN_UOBS2_INT = 32
   integer, parameter :: EN_UOBS1_REAL = 41, EN_UOBS2_REAL = 42
   integer, parameter :: EN_PRT_FUN_UNARY = 101, EN_PRT_FUN_BINARY = 102
   integer, parameter :: EN_EVAL_FUN_UNARY = 111, EN_EVAL_FUN_BINARY = 112
   integer, parameter :: EN_LOG_FUN_UNARY = 121, EN_LOG_FUN_BINARY = 122
   integer, parameter :: EN_INT_FUN_UNARY = 131, EN_INT_FUN_BINARY = 132
   integer, parameter :: EN_REAL_FUN_UNARY = 141, EN_REAL_FUN_BINARY = 142
   integer, parameter :: EN_FORMAT_STR = 161
 
 @ %def EN_UNKNOWN EN_UNARY EN_BINARY EN_CONSTANT EN_VARIABLE EN_CONDITIONAL
 @ %def EN_RECORD_CMD
 @ %def EN_OBS1_INT EN_OBS2_INT EN_OBS1_REAL EN_OBS2_REAL
 @ %def EN_UOBS1_INT EN_UOBS2_INT EN_UOBS1_REAL EN_UOBS2_REAL
 @ %def EN_PRT_FUN_UNARY EN_PRT_FUN_BINARY
 @ %def EN_EVAL_FUN_UNARY EN_EVAL_FUN_BINARY
 @ %def EN_LOG_FUN_UNARY EN_LOG_FUN_BINARY
 @ %def EN_INT_FUN_UNARY EN_INT_FUN_BINARY
 @ %def EN_REAL_FUN_UNARY EN_REAL_FUN_BINARY
 @ %def EN_FORMAT_STR
 @ This is exported only for use within unit tests.
 <<Eval trees: public>>=
   public :: eval_node_t
 <<Eval trees: types>>=
   type :: eval_node_t
      private
      type(string_t) :: tag
      integer :: type = EN_UNKNOWN
      integer :: result_type = V_NONE
      type(var_list_t), pointer :: var_list => null ()
      type(string_t) :: var_name
      logical, pointer :: value_is_known => null ()
      logical,           pointer :: lval => null ()
      integer,           pointer :: ival => null ()
      real(default),     pointer :: rval => null ()
      complex(default),  pointer :: cval => null ()
      type(subevt_t),  pointer :: pval => null ()
      type(pdg_array_t), pointer :: aval => null ()
      type(string_t),    pointer :: sval => null ()
      type(eval_node_t), pointer :: arg0 => null ()
      type(eval_node_t), pointer :: arg1 => null ()
      type(eval_node_t), pointer :: arg2 => null ()
      type(eval_node_t), pointer :: arg3 => null ()
      type(eval_node_t), pointer :: arg4 => null ()
      procedure(obs_unary_int),   nopass, pointer :: obs1_int  => null ()
      procedure(obs_unary_real),  nopass, pointer :: obs1_real => null ()
      procedure(obs_binary_int),  nopass, pointer :: obs2_int  => null ()
      procedure(obs_binary_real), nopass, pointer :: obs2_real => null ()
      integer, pointer :: prt_type => null ()
      integer, pointer :: index => null ()
      real(default), pointer :: tolerance => null ()
      integer, pointer :: jet_algorithm => null ()
      real(default), pointer :: jet_r => null ()
      real(default), pointer :: jet_p => null ()
      real(default), pointer :: jet_ycut => null ()
      real(default), pointer :: photon_iso_eps => null ()
      real(default), pointer :: photon_iso_n => null ()
      real(default), pointer :: photon_iso_r0 => null ()
      type(prt_t), pointer :: prt1 => null ()
      type(prt_t), pointer :: prt2 => null ()
      procedure(unary_log),  nopass, pointer :: op1_log  => null ()
      procedure(unary_int),  nopass, pointer :: op1_int  => null ()
      procedure(unary_real), nopass, pointer :: op1_real => null ()
      procedure(unary_cmplx), nopass, pointer :: op1_cmplx => null ()
      procedure(unary_pdg),  nopass, pointer :: op1_pdg  => null ()
      procedure(unary_sev),  nopass, pointer :: op1_sev  => null ()
      procedure(unary_str),  nopass, pointer :: op1_str  => null ()
      procedure(unary_cut),  nopass, pointer :: op1_cut  => null ()
      procedure(unary_evi),  nopass, pointer :: op1_evi  => null ()
      procedure(unary_evr),  nopass, pointer :: op1_evr  => null ()
      procedure(binary_log),  nopass, pointer :: op2_log  => null ()
      procedure(binary_int),  nopass, pointer :: op2_int  => null ()
      procedure(binary_real), nopass, pointer :: op2_real => null ()
      procedure(binary_cmplx), nopass, pointer :: op2_cmplx => null ()
      procedure(binary_pdg),  nopass, pointer :: op2_pdg  => null ()
      procedure(binary_sev),  nopass, pointer :: op2_sev  => null ()
      procedure(binary_str),  nopass, pointer :: op2_str  => null ()
      procedure(binary_cut),  nopass, pointer :: op2_cut  => null ()
      procedure(binary_evi),  nopass, pointer :: op2_evi  => null ()
      procedure(binary_evr),  nopass, pointer :: op2_evr  => null ()
    contains
    <<Eval trees: eval node: TBP>>
   end type eval_node_t
 
 @ %def eval_node_t
 @ Finalize a node recursively.  Allocated constants are deleted,
 pointers are ignored.
 <<Eval trees: eval node: TBP>>=
   procedure :: final_rec => eval_node_final_rec
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_final_rec (node)
     class(eval_node_t), intent(inout) :: node
     select case (node%type)
     case (EN_UNARY)
        call eval_node_final_rec (node%arg1)
     case (EN_BINARY)
        call eval_node_final_rec (node%arg1)
        call eval_node_final_rec (node%arg2)
     case (EN_CONDITIONAL)
        call eval_node_final_rec (node%arg0)
        call eval_node_final_rec (node%arg1)
        call eval_node_final_rec (node%arg2)
     case (EN_BLOCK)
        call eval_node_final_rec (node%arg0)
        call eval_node_final_rec (node%arg1)
     case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, &
           EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY)
        if (associated (node%arg0))  call eval_node_final_rec (node%arg0)
        call eval_node_final_rec (node%arg1)
        deallocate (node%index)
        deallocate (node%prt1)
     case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, &
           EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY)
        if (associated (node%arg0))  call eval_node_final_rec (node%arg0)
        call eval_node_final_rec (node%arg1)
        call eval_node_final_rec (node%arg2)
        deallocate (node%index)
        deallocate (node%prt1)
        deallocate (node%prt2)
     case (EN_FORMAT_STR)
        if (associated (node%arg0))  call eval_node_final_rec (node%arg0)
        if (associated (node%arg1))  call eval_node_final_rec (node%arg1)
        deallocate (node%ival)
     case (EN_RECORD_CMD)
        if (associated (node%arg0))  call eval_node_final_rec (node%arg0)
        if (associated (node%arg1))  call eval_node_final_rec (node%arg1)
        if (associated (node%arg2))  call eval_node_final_rec (node%arg2)
        if (associated (node%arg3))  call eval_node_final_rec (node%arg3)
        if (associated (node%arg4))  call eval_node_final_rec (node%arg4)
     end select
     select case (node%type)
     case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, EN_CONSTANT, EN_BLOCK, &
           EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, &
           EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, &
           EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, &
           EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, &
           EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, &
           EN_FORMAT_STR, EN_RECORD_CMD)
        select case (node%result_type)
        case (V_LOG);  deallocate (node%lval)
        case (V_INT);  deallocate (node%ival)
        case (V_REAL); deallocate (node%rval)
        case (V_CMPLX); deallocate (node%cval)
        case (V_SEV);  deallocate (node%pval)
        case (V_PDG);  deallocate (node%aval)
        case (V_STR);  deallocate (node%sval)
        end select
        deallocate (node%value_is_known)
     end select
   end subroutine eval_node_final_rec
 
 @ %def eval_node_final_rec
 @
 \subsubsection{Leaf nodes}
 Initialize a leaf node with a literal constant.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_log (node, lval)
     type(eval_node_t), intent(out) :: node
     logical, intent(in) :: lval
     node%type = EN_CONSTANT
     node%result_type = V_LOG
     allocate (node%lval, node%value_is_known)
     node%lval = lval
     node%value_is_known = .true.
   end subroutine eval_node_init_log
 
   subroutine eval_node_init_int (node, ival)
     type(eval_node_t), intent(out) :: node
     integer, intent(in) :: ival
     node%type = EN_CONSTANT
     node%result_type = V_INT
     allocate (node%ival, node%value_is_known)
     node%ival = ival
     node%value_is_known = .true.
   end subroutine eval_node_init_int
 
   subroutine eval_node_init_real (node, rval)
     type(eval_node_t), intent(out) :: node
     real(default), intent(in) :: rval
     node%type = EN_CONSTANT
     node%result_type = V_REAL
     allocate (node%rval, node%value_is_known)
     node%rval = rval
     node%value_is_known = .true.
   end subroutine eval_node_init_real
 
   subroutine eval_node_init_cmplx (node, cval)
     type(eval_node_t), intent(out) :: node
     complex(default), intent(in) :: cval
     node%type = EN_CONSTANT
     node%result_type = V_CMPLX
     allocate (node%cval, node%value_is_known)
     node%cval = cval
     node%value_is_known = .true.
   end subroutine eval_node_init_cmplx
 
   subroutine eval_node_init_subevt (node, pval)
     type(eval_node_t), intent(out) :: node
     type(subevt_t), intent(in) :: pval
     node%type = EN_CONSTANT
     node%result_type = V_SEV
     allocate (node%pval, node%value_is_known)
     node%pval = pval
     node%value_is_known = .true.
   end subroutine eval_node_init_subevt
 
   subroutine eval_node_init_pdg_array (node, aval)
     type(eval_node_t), intent(out) :: node
     type(pdg_array_t), intent(in) :: aval
     node%type = EN_CONSTANT
     node%result_type = V_PDG
     allocate (node%aval, node%value_is_known)
     node%aval = aval
     node%value_is_known = .true.
   end subroutine eval_node_init_pdg_array
 
   subroutine eval_node_init_string (node, sval)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: sval
     node%type = EN_CONSTANT
     node%result_type = V_STR
     allocate (node%sval, node%value_is_known)
     node%sval = sval
     node%value_is_known = .true.
   end subroutine eval_node_init_string
 
 @ %def eval_node_init_log eval_node_init_int eval_node_init_real
 @ %def eval_node_init_cmplx eval_node_init_prt eval_node_init_subevt
 @ %def eval_node_init_pdg_array eval_node_init_string
 @ Initialize a leaf node with a pointer to a named parameter
 <<Eval trees: procedures>>=
   subroutine eval_node_init_log_ptr (node, name, lval, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     logical, intent(in), target :: lval
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_LOG
     node%lval => lval
     node%value_is_known => is_known
   end subroutine eval_node_init_log_ptr
 
   subroutine eval_node_init_int_ptr (node, name, ival, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     integer, intent(in), target :: ival
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_INT
     node%ival => ival
     node%value_is_known => is_known
   end subroutine eval_node_init_int_ptr
 
   subroutine eval_node_init_real_ptr (node, name, rval, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     real(default), intent(in), target :: rval
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_REAL
     node%rval => rval
     node%value_is_known => is_known
   end subroutine eval_node_init_real_ptr
 
   subroutine eval_node_init_cmplx_ptr (node, name, cval, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     complex(default), intent(in), target :: cval
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_CMPLX
     node%cval => cval
     node%value_is_known => is_known
   end subroutine eval_node_init_cmplx_ptr
 
   subroutine eval_node_init_subevt_ptr (node, name, pval, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), target :: pval
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_SEV
     node%pval => pval
     node%value_is_known => is_known
   end subroutine eval_node_init_subevt_ptr
 
   subroutine eval_node_init_pdg_array_ptr (node, name, aval, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), target :: aval
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_PDG
     node%aval => aval
     node%value_is_known => is_known
   end subroutine eval_node_init_pdg_array_ptr
 
   subroutine eval_node_init_string_ptr (node, name, sval, is_known)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(string_t), intent(in), target :: sval
     logical, intent(in), target :: is_known
     node%type = EN_VARIABLE
     node%tag = name
     node%result_type = V_STR
     node%sval => sval
     node%value_is_known => is_known
   end subroutine eval_node_init_string_ptr
 
 @ %def eval_node_init_log_ptr eval_node_init_int_ptr
 @ %def eval_node_init_real_ptr eval_node_init_cmplx_ptr
 @ %def eval_node_init_subevt_ptr eval_node_init_string_ptr
 @ The procedure-pointer cases:
 <<Eval trees: procedures>>=
   subroutine eval_node_init_obs1_int_ptr (node, name, obs1_iptr, p1)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     procedure(obs_unary_int), intent(in), pointer :: obs1_iptr
     type(prt_t), intent(in), target :: p1
     node%type = EN_OBS1_INT
     node%tag = name
     node%result_type = V_INT
     node%obs1_int => obs1_iptr
     node%prt1 => p1
     allocate (node%ival, node%value_is_known)
     node%value_is_known = .false.
   end subroutine eval_node_init_obs1_int_ptr
 
   subroutine eval_node_init_obs2_int_ptr (node, name, obs2_iptr, p1, p2)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     procedure(obs_binary_int), intent(in), pointer :: obs2_iptr
     type(prt_t), intent(in), target :: p1, p2
     node%type = EN_OBS2_INT
     node%tag = name
     node%result_type = V_INT
     node%obs2_int => obs2_iptr
     node%prt1 => p1
     node%prt2 => p2
     allocate (node%ival, node%value_is_known)
     node%value_is_known = .false.
   end subroutine eval_node_init_obs2_int_ptr
 
   subroutine eval_node_init_obs1_real_ptr (node, name, obs1_rptr, p1)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     procedure(obs_unary_real), intent(in), pointer :: obs1_rptr
     type(prt_t), intent(in), target :: p1
     node%type = EN_OBS1_REAL
     node%tag = name
     node%result_type = V_REAL
     node%obs1_real => obs1_rptr
     node%prt1 => p1
     allocate (node%rval, node%value_is_known)
     node%value_is_known = .false.
   end subroutine eval_node_init_obs1_real_ptr
 
   subroutine eval_node_init_obs2_real_ptr (node, name, obs2_rptr, p1, p2)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     procedure(obs_binary_real), intent(in), pointer :: obs2_rptr
     type(prt_t), intent(in), target :: p1, p2
     node%type = EN_OBS2_REAL
     node%tag = name
     node%result_type = V_REAL
     node%obs2_real => obs2_rptr
     node%prt1 => p1
     node%prt2 => p2
     allocate (node%rval, node%value_is_known)
     node%value_is_known = .false.
   end subroutine eval_node_init_obs2_real_ptr
 
 @ %def eval_node_init_obs1_int_ptr
 @ %def eval_node_init_obs2_int_ptr
 @ %def eval_node_init_obs1_real_ptr
 @ %def eval_node_init_obs2_real_ptr
 @ These nodes refer to user-defined procedures.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_uobs1_int (node, name, arg)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(eval_node_t), intent(in), target :: arg
     node%type = EN_UOBS1_INT
     node%tag = name
     node%result_type = V_INT
     allocate (node%ival, node%value_is_known)
     node%value_is_known = .false.
     node%arg0 => arg
   end subroutine eval_node_init_uobs1_int
 
   subroutine eval_node_init_uobs2_int (node, name, arg)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(eval_node_t), intent(in), target :: arg
     node%type = EN_UOBS2_INT
     node%tag = name
     node%result_type = V_INT
     allocate (node%ival, node%value_is_known)
     node%value_is_known = .false.
     node%arg0 => arg
   end subroutine eval_node_init_uobs2_int
 
   subroutine eval_node_init_uobs1_real (node, name, arg)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(eval_node_t), intent(in), target :: arg
     node%type = EN_UOBS1_REAL
     node%tag = name
     node%result_type = V_REAL
     allocate (node%rval, node%value_is_known)
     node%value_is_known = .false.
     node%arg0 => arg
   end subroutine eval_node_init_uobs1_real
 
   subroutine eval_node_init_uobs2_real (node, name, arg)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: name
     type(eval_node_t), intent(in), target :: arg
     node%type = EN_UOBS2_REAL
     node%tag = name
     node%result_type = V_REAL
     allocate (node%rval, node%value_is_known)
     node%value_is_known = .false.
     node%arg0 => arg
   end subroutine eval_node_init_uobs2_real
 
 @ %def eval_node_init_uobs1_int
 @ %def eval_node_init_uobs2_int
 @ %def eval_node_init_uobs1_real
 @ %def eval_node_init_uobs2_real
 @
 \subsubsection{Branch nodes}
 Initialize a branch node, sub-nodes are given.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_branch (node, tag, result_type, arg1, arg2)
     type(eval_node_t), intent(out) :: node
     type(string_t), intent(in) :: tag
     integer, intent(in) :: result_type
     type(eval_node_t), intent(in), target :: arg1
     type(eval_node_t), intent(in), target, optional :: arg2
     if (present (arg2)) then
        node%type = EN_BINARY
     else
        node%type = EN_UNARY
     end if
     node%tag = tag
     node%result_type = result_type
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     if (present (arg2))  node%arg2 => arg2
   end subroutine eval_node_init_branch
 
 @ %def eval_node_init_branch
 @ Allocate the node value according to the result type.
 <<Eval trees: procedures>>=
   subroutine eval_node_allocate_value (node)
     type(eval_node_t), intent(inout) :: node
     select case (node%result_type)
     case (V_LOG);  allocate (node%lval)
     case (V_INT);  allocate (node%ival)
     case (V_REAL); allocate (node%rval)
     case (V_CMPLX); allocate (node%cval)
     case (V_PDG);  allocate (node%aval)
     case (V_SEV);  allocate (node%pval)
        call subevt_init (node%pval)
     case (V_STR);  allocate (node%sval)
     end select
     allocate (node%value_is_known)
     node%value_is_known = .false.
   end subroutine eval_node_allocate_value
 
 @ %def eval_node_allocate_value
 @ Initialize a block node which contains, in addition to the
 expression to be evaluated, a variable definition.  The result type is
 not yet assigned, because we can compile the enclosed expression only
 after the var list is set up.
 
 Note that the node always allocates a new variable list and appends it to the
 current one.  Thus, if the variable redefines an existing one, it only shadows
 it but does not reset it.  Any side-effects are therefore absent and need not
 be undone outside the block.
 
 If the flag [[new]] is set, a variable is (re)declared.  This must not be done
 for intrinsic variables.  Vice versa, if the variable is not existent, the
 [[new]] flag is required.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_block (node, name, type, var_def, var_list)
     type(eval_node_t), intent(out), target :: node
     type(string_t), intent(in) :: name
     integer, intent(in) :: type
     type(eval_node_t), intent(in), target :: var_def
     type(var_list_t), intent(in), target :: var_list
     node%type = EN_BLOCK
     node%tag = "var_def"
     node%var_name = name
     node%arg1 => var_def
     allocate (node%var_list)
     call node%var_list%link (var_list)
     if (var_def%type == EN_CONSTANT) then
        select case (type)
        case (V_LOG)
           call var_list_append_log  (node%var_list, name, var_def%lval)
        case (V_INT)
           call var_list_append_int  (node%var_list, name, var_def%ival)
        case (V_REAL)
           call var_list_append_real (node%var_list, name, var_def%rval)
        case (V_CMPLX)
           call var_list_append_cmplx (node%var_list, name, var_def%cval)
        case (V_PDG)
           call var_list_append_pdg_array &
                (node%var_list, name, var_def%aval)
        case (V_SEV)
           call var_list_append_subevt &
                (node%var_list, name, var_def%pval)
        case (V_STR)
           call var_list_append_string (node%var_list, name, var_def%sval)
        end select
     else
        select case (type)
        case (V_LOG);  call var_list_append_log_ptr &
             (node%var_list, name, var_def%lval, var_def%value_is_known)
        case (V_INT);  call var_list_append_int_ptr &
             (node%var_list, name, var_def%ival, var_def%value_is_known)
        case (V_REAL); call var_list_append_real_ptr &
             (node%var_list, name, var_def%rval, var_def%value_is_known)
        case (V_CMPLX); call var_list_append_cmplx_ptr &
             (node%var_list, name, var_def%cval, var_def%value_is_known)
        case (V_PDG);  call var_list_append_pdg_array_ptr &
             (node%var_list, name, var_def%aval, var_def%value_is_known)
        case (V_SEV); call var_list_append_subevt_ptr &
             (node%var_list, name, var_def%pval, var_def%value_is_known)
        case (V_STR); call var_list_append_string_ptr &
             (node%var_list, name, var_def%sval, var_def%value_is_known)
        end select
     end if
   end subroutine eval_node_init_block
 
 @ %def eval_node_init_block
 @ Complete block initialization by assigning the expression to
 evaluate to [[arg0]].
 <<Eval trees: procedures>>=
   subroutine eval_node_set_expr (node, arg, result_type)
     type(eval_node_t), intent(inout) :: node
     type(eval_node_t), intent(in), target :: arg
     integer, intent(in), optional :: result_type
     if (present (result_type)) then
        node%result_type = result_type
     else
        node%result_type = arg%result_type
     end if
     call eval_node_allocate_value (node)
     node%arg0 => arg
   end subroutine eval_node_set_expr
 
 @ %def eval_node_set_block_expr
 @ Initialize a conditional.  There are three branches: the condition
 (evaluates to logical) and the two alternatives (evaluate both to the
 same arbitrary type).
 <<Eval trees: procedures>>=
   subroutine eval_node_init_conditional (node, result_type, cond, arg1, arg2)
     type(eval_node_t), intent(out) :: node
     integer, intent(in) :: result_type
     type(eval_node_t), intent(in), target :: cond, arg1, arg2
     node%type = EN_CONDITIONAL
     node%tag = "cond"
     node%result_type = result_type
     call eval_node_allocate_value (node)
     node%arg0 => cond
     node%arg1 => arg1
     node%arg2 => arg2
   end subroutine eval_node_init_conditional
 
 @ %def eval_node_init_conditional
 @ Initialize a recording command (which evaluates to a logical
 constant).  The first branch is the ID of the analysis object to be
 filled, the optional branches 1 to 4 are the values to be recorded.
 
 If the event-weight pointer is null, we record values with unit weight.
 Otherwise, we use the value pointed to as event weight.
 
 There can be up to four arguments which represent $x$, $y$, $\Delta y$,
 $\Delta x$.  Therefore, this is the only node type that may fill four
 sub-nodes.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_record_cmd &
       (node, event_weight, id, arg1, arg2, arg3, arg4)
     type(eval_node_t), intent(out) :: node
     real(default), pointer :: event_weight
     type(eval_node_t), intent(in), target :: id
     type(eval_node_t), intent(in), optional, target :: arg1, arg2, arg3, arg4
     call eval_node_init_log (node, .true.)
     node%type = EN_RECORD_CMD
     node%rval => event_weight
     node%tag = "record_cmd"
     node%arg0 => id
     if (present (arg1)) then
        node%arg1 => arg1
        if (present (arg2)) then
           node%arg2 => arg2
           if (present (arg3)) then
              node%arg3 => arg3
              if (present (arg4)) then
                 node%arg4 => arg4
              end if
           end if
        end if
     end if
   end subroutine eval_node_init_record_cmd
 
 @ %def eval_node_init_record_cmd
 @ Initialize a node for operations on subevents.  The particle
 lists (one or two) are inserted as [[arg1]] and [[arg2]].  We
 allocated particle pointers as temporaries for iterating over particle
 lists.  The procedure pointer which holds the function to evaluate for
 the subevents (e.g., combine, select) is also initialized.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_prt_fun_unary (node, arg1, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1
     type(string_t), intent(in) :: name
     procedure(unary_sev) :: proc
     node%type = EN_PRT_FUN_UNARY
     node%tag = name
     node%result_type = V_SEV
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     allocate (node%index, source = 0)
     allocate (node%prt1)
     node%op1_sev => proc
   end subroutine eval_node_init_prt_fun_unary
 
   subroutine eval_node_init_prt_fun_binary (node, arg1, arg2, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1, arg2
     type(string_t), intent(in) :: name
     procedure(binary_sev) :: proc
     node%type = EN_PRT_FUN_BINARY
     node%tag = name
     node%result_type = V_SEV
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     node%arg2 => arg2
     allocate (node%index, source = 0)
     allocate (node%prt1)
     allocate (node%prt2)
     node%op2_sev => proc
   end subroutine eval_node_init_prt_fun_binary
 
 @ %def eval_node_init_prt_fun_unary eval_node_init_prt_fun_binary
 @ Similar, but for particle-list functions that evaluate to a real
 value.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_eval_fun_unary (node, arg1, name)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1
     type(string_t), intent(in) :: name
     node%type = EN_EVAL_FUN_UNARY
     node%tag = name
     node%result_type = V_REAL
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     allocate (node%index, source = 0)
     allocate (node%prt1)
   end subroutine eval_node_init_eval_fun_unary
 
   subroutine eval_node_init_eval_fun_binary (node, arg1, arg2, name)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1, arg2
     type(string_t), intent(in) :: name
     node%type = EN_EVAL_FUN_BINARY
     node%tag = name
     node%result_type = V_REAL
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     node%arg2 => arg2
     allocate (node%index, source = 0)
     allocate (node%prt1)
     allocate (node%prt2)
   end subroutine eval_node_init_eval_fun_binary
 
 @ %def eval_node_init_eval_fun_unary eval_node_init_eval_fun_binary
 @ These are for particle-list functions that evaluate to a logical
 value.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_log_fun_unary (node, arg1, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1
     type(string_t), intent(in) :: name
     procedure(unary_cut) :: proc
     node%type = EN_LOG_FUN_UNARY
     node%tag = name
     node%result_type = V_LOG
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     allocate (node%index, source = 0)
     allocate (node%prt1)
     node%op1_cut => proc
   end subroutine eval_node_init_log_fun_unary
 
   subroutine eval_node_init_log_fun_binary (node, arg1, arg2, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1, arg2
     type(string_t), intent(in) :: name
     procedure(binary_cut) :: proc
     node%type = EN_LOG_FUN_BINARY
     node%tag = name
     node%result_type = V_LOG
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     node%arg2 => arg2
     allocate (node%index, source = 0)
     allocate (node%prt1)
     allocate (node%prt2)
     node%op2_cut => proc
   end subroutine eval_node_init_log_fun_binary
 
 @ %def eval_node_init_log_fun_unary eval_node_init_log_fun_binary
 @ These are for particle-list functions that evaluate to an integer
 value.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_int_fun_unary (node, arg1, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1
     type(string_t), intent(in) :: name
     procedure(unary_evi) :: proc
     node%type = EN_INT_FUN_UNARY
     node%tag = name
     node%result_type = V_INT
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     allocate (node%index, source = 0)
     allocate (node%prt1)
     node%op1_evi => proc
   end subroutine eval_node_init_int_fun_unary
 
   subroutine eval_node_init_int_fun_binary (node, arg1, arg2, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1, arg2
     type(string_t), intent(in) :: name
     procedure(binary_evi) :: proc
     node%type = EN_INT_FUN_BINARY
     node%tag = name
     node%result_type = V_INT
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     node%arg2 => arg2
     allocate (node%index, source = 0)
     allocate (node%prt1)
     allocate (node%prt2)
     node%op2_evi => proc
   end subroutine eval_node_init_int_fun_binary
 
 @ %def eval_node_init_int_fun_unary eval_node_init_int_fun_binary
 @ These are for particle-list functions that evaluate to a real
 value.
 <<Eval trees: procedures>>=
   subroutine eval_node_init_real_fun_unary (node, arg1, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1
     type(string_t), intent(in) :: name
     procedure(unary_evr) :: proc
     node%type = EN_REAL_FUN_UNARY
     node%tag = name
     node%result_type = V_INT
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     allocate (node%index, source = 0)
     allocate (node%prt1)
     node%op1_evr => proc
   end subroutine eval_node_init_real_fun_unary
 
   subroutine eval_node_init_real_fun_binary (node, arg1, arg2, name, proc)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), intent(in), target :: arg1, arg2
     type(string_t), intent(in) :: name
     procedure(binary_evr) :: proc
     node%type = EN_REAL_FUN_BINARY
     node%tag = name
     node%result_type = V_INT
     call eval_node_allocate_value (node)
     node%arg1 => arg1
     node%arg2 => arg2
     allocate (node%index, source = 0)
     allocate (node%prt1)
     allocate (node%prt2)
     node%op2_evr => proc
   end subroutine eval_node_init_real_fun_binary
 
 @ %def eval_node_init_real_fun_unary eval_node_init_real_fun_binary
 @ Initialize a node for a string formatting function (sprintf).
 <<Eval trees: procedures>>=
   subroutine eval_node_init_format_string (node, fmt, arg, name, n_args)
     type(eval_node_t), intent(out) :: node
     type(eval_node_t), pointer :: fmt, arg
     type(string_t), intent(in) :: name
     integer, intent(in) :: n_args
     node%type = EN_FORMAT_STR
     node%tag = name
     node%result_type = V_STR
     call eval_node_allocate_value (node)
     node%arg0 => fmt
     node%arg1 => arg
     allocate (node%ival)
     node%ival = n_args
   end subroutine eval_node_init_format_string
 
 @ %def eval_node_init_format_string
 @ If particle functions depend upon a condition (or an expression is
 evaluated), the observables that can be evaluated for the given
 particles have to be thrown on the local variable stack.  This is done
 here.  Each observable is initialized with the particle pointers which
 have been allocated for the node.
 
 The integer variable that is referred to by the [[Index]]
 pseudo-observable is always known when it is referred to.
 <<Eval trees: procedures>>=
   subroutine eval_node_set_observables (node, var_list)
     type(eval_node_t), intent(inout) :: node
     type(var_list_t), intent(in), target :: var_list
     logical, save, target :: known = .true.
     allocate (node%var_list)
     call node%var_list%link (var_list)
     allocate (node%index, source = 0)
     call var_list_append_int_ptr &
          (node%var_list, var_str ("Index"), node%index, known, intrinsic=.true.)
     if (.not. associated (node%prt2)) then
        call var_list_set_observables_unary &
             (node%var_list, node%prt1)
     else
        call var_list_set_observables_binary &
             (node%var_list, node%prt1, node%prt2)
     end if
   end subroutine eval_node_set_observables
 
 @ %def eval_node_set_observables
 @
 \subsubsection{Output}
 <<Eval trees: eval node: TBP>>=
   procedure :: write => eval_node_write
 <<Eval trees: procedures>>=
   subroutine eval_node_write (node, unit, indent)
     class(eval_node_t), intent(in) :: node
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: indent
     integer :: u, ind
     u = given_output_unit (unit);  if (u < 0)  return
     ind = 0;  if (present (indent)) ind = indent
     write (u, "(A)", advance="no")  repeat ("|  ", ind) // "o "
     select case (node%type)
     case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, &
           EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, &
           EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, &
           EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, &
           EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, &
           EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY)
        write (u, "(A)", advance="no")  "[" // char (node%tag) // "] ="
     case (EN_CONSTANT)
        write (u, "(A)", advance="no")  "[const] ="
     case (EN_VARIABLE)
        write (u, "(A)", advance="no")  char (node%tag) // " =>"
     case (EN_OBS1_INT, EN_OBS2_INT, EN_OBS1_REAL, EN_OBS2_REAL, &
          EN_UOBS1_INT, EN_UOBS2_INT, EN_UOBS1_REAL, EN_UOBS2_REAL)
        write (u, "(A)", advance="no")  char (node%tag) // " ="
     case (EN_BLOCK)
        write (u, "(A)", advance="no")  "[" // char (node%tag) // "]" // &
             char (node%var_name) // " [expr] = "
     case default
        write (u, "(A)", advance="no")  "[???] ="
     end select
     select case (node%result_type)
     case (V_LOG)
        if (node%value_is_known) then
           if (node%lval) then
              write (u, "(1x,A)") "true"
           else
              write (u, "(1x,A)") "false"
           end if
        else
           write (u, "(1x,A)") "[unknown logical]"
        end if
     case (V_INT)
        if (node%value_is_known) then
           write (u, "(1x,I0)")  node%ival
        else
           write (u, "(1x,A)") "[unknown integer]"
        end if
     case (V_REAL)
        if (node%value_is_known) then
           write (u, "(1x," // FMT_19 // ")") node%rval
        else
           write (u, "(1x,A)") "[unknown real]"
        end if
    case (V_CMPLX)
        if (node%value_is_known) then
           write (u, "(1x,'('," // FMT_19 // ",','," // &
                FMT_19 // ",')')") node%cval
        else
           write (u, "(1x,A)") "[unknown complex]"
        end if
     case (V_SEV)
        if (char (node%tag) == "@evt") then
           write (u, "(1x,A)") "[event subevent]"
        else if (node%value_is_known) then
           call subevt_write &
                (node%pval, unit, prefix = repeat ("|  ", ind + 1))
        else
           write (u, "(1x,A)") "[unknown subevent]"
        end if
     case (V_PDG)
        write (u, "(1x)", advance="no")
        call pdg_array_write (node%aval, u);  write (u, *)
     case (V_STR)
        if (node%value_is_known) then
           write (u, "(A)")  '"' // char (node%sval) // '"'
        else
           write (u, "(1x,A)") "[unknown string]"
        end if
     case default
        write (u, "(1x,A)") "[empty]"
     end select
     select case (node%type)
     case (EN_OBS1_INT, EN_OBS1_REAL, EN_UOBS1_INT, EN_UOBS1_REAL)
        write (u, "(A,6x,A)", advance="no")  repeat ("|  ", ind), "prt1 ="
        call prt_write (node%prt1, unit)
     case (EN_OBS2_INT, EN_OBS2_REAL, EN_UOBS2_INT, EN_UOBS2_REAL)
        write (u, "(A,6x,A)", advance="no")  repeat ("|  ", ind), "prt1 ="
        call prt_write (node%prt1, unit)
        write (u, "(A,6x,A)", advance="no")  repeat ("|  ", ind), "prt2 ="
        call prt_write (node%prt2, unit)
     end select
   end subroutine eval_node_write
 
   recursive subroutine eval_node_write_rec (node, unit, indent)
     type(eval_node_t), intent(in) :: node
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: indent
     integer :: u, ind
     u = given_output_unit (unit);  if (u < 0)  return
     ind = 0;  if (present (indent))  ind = indent
     call eval_node_write (node, unit, indent)
     select case (node%type)
     case (EN_UNARY)
        if (associated (node%arg0)) &
             call eval_node_write_rec (node%arg0, unit, ind+1)
        call eval_node_write_rec (node%arg1, unit, ind+1)
     case (EN_BINARY)
        if (associated (node%arg0)) &
             call eval_node_write_rec (node%arg0, unit, ind+1)
        call eval_node_write_rec (node%arg1, unit, ind+1)
        call eval_node_write_rec (node%arg2, unit, ind+1)
     case (EN_BLOCK)
        call eval_node_write_rec (node%arg1, unit, ind+1)
        call eval_node_write_rec (node%arg0, unit, ind+1)
     case (EN_CONDITIONAL)
        call eval_node_write_rec (node%arg0, unit, ind+1)
        call eval_node_write_rec (node%arg1, unit, ind+1)
        call eval_node_write_rec (node%arg2, unit, ind+1)
     case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, &
           EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY)
        if (associated (node%arg0)) &
             call eval_node_write_rec (node%arg0, unit, ind+1)
        call eval_node_write_rec (node%arg1, unit, ind+1)
     case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, &
           EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY)
        if (associated (node%arg0)) &
             call eval_node_write_rec (node%arg0, unit, ind+1)
        call eval_node_write_rec (node%arg1, unit, ind+1)
        call eval_node_write_rec (node%arg2, unit, ind+1)
     case (EN_RECORD_CMD)
        if (associated (node%arg1)) then
           call eval_node_write_rec (node%arg1, unit, ind+1)
           if (associated (node%arg2)) then
              call eval_node_write_rec (node%arg2, unit, ind+1)
              if (associated (node%arg3)) then
                 call eval_node_write_rec (node%arg3, unit, ind+1)
                 if (associated (node%arg4)) then
                    call eval_node_write_rec (node%arg4, unit, ind+1)
                 end if
              end if
           end if
        end if
     end select
   end subroutine eval_node_write_rec
 
 @ %def eval_node_write eval_node_write_rec
 @
 \subsection{Operation types}
 For the operations associated to evaluation tree nodes, we define
 abstract interfaces for all cases.
 
 Particles/subevents are transferred by-reference, to avoid
 unnecessary copying.  Therefore, subroutines instead of functions.
 <<Eval trees: interfaces>>=
   abstract interface
      logical function unary_log (arg)
        import eval_node_t
        type(eval_node_t), intent(in) :: arg
      end function unary_log
   end interface
   abstract interface
      integer function unary_int (arg)
        import eval_node_t
        type(eval_node_t), intent(in) :: arg
      end function unary_int
   end interface
   abstract interface
      real(default) function unary_real (arg)
        import default
        import eval_node_t
        type(eval_node_t), intent(in) :: arg
      end function unary_real
   end interface
   abstract interface
      complex(default) function unary_cmplx (arg)
        import default
        import eval_node_t
        type(eval_node_t), intent(in) :: arg
      end function unary_cmplx
   end interface
   abstract interface
      subroutine unary_pdg (pdg_array, arg)
        import pdg_array_t
        import eval_node_t
        type(pdg_array_t), intent(out) :: pdg_array
        type(eval_node_t), intent(in) :: arg
      end subroutine unary_pdg
   end interface
   abstract interface
      subroutine unary_sev (subevt, arg, arg0)
        import subevt_t
        import eval_node_t
        type(subevt_t), intent(inout) :: subevt
        type(eval_node_t), intent(in) :: arg
        type(eval_node_t), intent(inout), optional :: arg0
      end subroutine unary_sev
   end interface
   abstract interface
      subroutine unary_str (string, arg)
        import string_t
        import eval_node_t
        type(string_t), intent(out) :: string
        type(eval_node_t), intent(in) :: arg
      end subroutine unary_str
   end interface
   abstract interface
      logical function unary_cut (arg1, arg0)
        import eval_node_t
        type(eval_node_t), intent(in) :: arg1
        type(eval_node_t), intent(inout) :: arg0
      end function unary_cut
   end interface
   abstract interface
      subroutine unary_evi (ival, arg1, arg0)
        import eval_node_t
        integer, intent(out) :: ival
        type(eval_node_t), intent(in) :: arg1
        type(eval_node_t), intent(inout), optional :: arg0
      end subroutine unary_evi
   end interface
   abstract interface
      subroutine unary_evr (rval, arg1, arg0)
        import eval_node_t, default
        real(default), intent(out) :: rval
        type(eval_node_t), intent(in) :: arg1
        type(eval_node_t), intent(inout), optional :: arg0
      end subroutine unary_evr
   end interface
   abstract interface
      logical function binary_log (arg1, arg2)
        import eval_node_t
        type(eval_node_t), intent(in) :: arg1, arg2
      end function binary_log
   end interface
   abstract interface
      integer function binary_int (arg1, arg2)
        import eval_node_t
        type(eval_node_t), intent(in) :: arg1, arg2
      end function binary_int
   end interface
   abstract interface
      real(default) function binary_real (arg1, arg2)
        import default
        import eval_node_t
        type(eval_node_t), intent(in) :: arg1, arg2
      end function binary_real
   end interface
   abstract interface
      complex(default) function binary_cmplx (arg1, arg2)
        import default
        import eval_node_t
        type(eval_node_t), intent(in) :: arg1, arg2
      end function binary_cmplx
   end interface
   abstract interface
      subroutine binary_pdg (pdg_array, arg1, arg2)
        import pdg_array_t
        import eval_node_t
        type(pdg_array_t), intent(out) :: pdg_array
        type(eval_node_t), intent(in) :: arg1, arg2
      end subroutine binary_pdg
   end interface
   abstract interface
      subroutine binary_sev (subevt, arg1, arg2, arg0)
        import subevt_t
        import eval_node_t
        type(subevt_t), intent(inout) :: subevt
        type(eval_node_t), intent(in) :: arg1, arg2
        type(eval_node_t), intent(inout), optional :: arg0
      end subroutine binary_sev
   end interface
   abstract interface
      subroutine binary_str (string, arg1, arg2)
        import string_t
        import eval_node_t
        type(string_t), intent(out) :: string
        type(eval_node_t), intent(in) :: arg1, arg2
      end subroutine binary_str
   end interface
   abstract interface
      logical function binary_cut (arg1, arg2, arg0)
        import eval_node_t
        type(eval_node_t), intent(in) :: arg1, arg2
        type(eval_node_t), intent(inout) :: arg0
      end function binary_cut
   end interface
   abstract interface
      subroutine binary_evi (ival, arg1, arg2, arg0)
        import eval_node_t
        integer, intent(out) :: ival
        type(eval_node_t), intent(in) :: arg1, arg2
        type(eval_node_t), intent(inout), optional :: arg0
      end subroutine binary_evi
   end interface
   abstract interface
      subroutine binary_evr (rval, arg1, arg2, arg0)
        import eval_node_t, default
        real(default), intent(out) :: rval
        type(eval_node_t), intent(in) :: arg1, arg2
        type(eval_node_t), intent(inout), optional :: arg0
      end subroutine binary_evr
   end interface
 
 @ The following subroutines set the procedure pointer:
 <<Eval trees: procedures>>=
   subroutine eval_node_set_op1_log (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_log) :: op
     en%op1_log => op
     end subroutine eval_node_set_op1_log
 
   subroutine eval_node_set_op1_int (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_int) :: op
     en%op1_int => op
   end subroutine eval_node_set_op1_int
 
   subroutine eval_node_set_op1_real (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_real) :: op
     en%op1_real => op
   end subroutine eval_node_set_op1_real
 
   subroutine eval_node_set_op1_cmplx (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_cmplx) :: op
     en%op1_cmplx => op
   end subroutine eval_node_set_op1_cmplx
 
   subroutine eval_node_set_op1_pdg (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_pdg) :: op
     en%op1_pdg => op
   end subroutine eval_node_set_op1_pdg
 
   subroutine eval_node_set_op1_sev (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_sev) :: op
     en%op1_sev => op
   end subroutine eval_node_set_op1_sev
 
   subroutine eval_node_set_op1_str (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(unary_str) :: op
     en%op1_str => op
   end subroutine eval_node_set_op1_str
 
   subroutine eval_node_set_op2_log (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_log) :: op
     en%op2_log => op
   end subroutine eval_node_set_op2_log
 
   subroutine eval_node_set_op2_int (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_int) :: op
     en%op2_int => op
   end subroutine eval_node_set_op2_int
 
   subroutine eval_node_set_op2_real (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_real) :: op
     en%op2_real => op
   end subroutine eval_node_set_op2_real
 
   subroutine eval_node_set_op2_cmplx (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_cmplx) :: op
     en%op2_cmplx => op
   end subroutine eval_node_set_op2_cmplx
 
   subroutine eval_node_set_op2_pdg (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_pdg) :: op
     en%op2_pdg => op
   end subroutine eval_node_set_op2_pdg
 
   subroutine eval_node_set_op2_sev (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_sev) :: op
     en%op2_sev => op
   end subroutine eval_node_set_op2_sev
 
   subroutine eval_node_set_op2_str (en, op)
     type(eval_node_t), intent(inout) :: en
     procedure(binary_str) :: op
     en%op2_str => op
   end subroutine eval_node_set_op2_str
 
 @ %def eval_node_set_operator
 @
 \subsection{Specific operators}
 
 Our expression syntax contains all Fortran functions that make sense.
 These functions have to be provided in a form that they can be used in
 procedures pointers, and have the abstract interfaces above.
 For some intrinsic functions, we could use specific versions provided
 by Fortran directly.  However, this has two drawbacks: (i) We should
 work with the values instead of the eval-nodes as argument, which
 complicates the interface; (ii) more importantly, the [[default]] real
 type need not be equivalent to double precision.  This would, at
 least, introduce system dependencies.  Finally, for operators there
 are no specific versions.
 
 Therefore, we write wrappers for all possible functions, at the
 expense of some overhead.
 \subsubsection{Binary numerical functions}
 <<Eval trees: procedures>>=
   integer function add_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival + en2%ival
   end function add_ii
   real(default) function add_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival + en2%rval
   end function add_ir
   complex(default) function add_ic (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival + en2%cval
   end function add_ic
   real(default) function add_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval + en2%ival
   end function add_ri
   complex(default) function add_ci (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval + en2%ival
   end function add_ci
   complex(default) function add_cr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval + en2%rval
   end function add_cr
   complex(default) function add_rc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval + en2%cval
   end function add_rc
   real(default) function add_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval + en2%rval
   end function add_rr
   complex(default) function add_cc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval + en2%cval
   end function add_cc
 
   integer function sub_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival - en2%ival
   end function sub_ii
   real(default) function sub_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival - en2%rval
   end function sub_ir
   real(default) function sub_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval - en2%ival
   end function sub_ri
   complex(default) function sub_ic (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival - en2%cval
   end function sub_ic
   complex(default) function sub_ci (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval - en2%ival
   end function sub_ci
   complex(default) function sub_cr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval - en2%rval
   end function sub_cr
   complex(default) function sub_rc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval - en2%cval
   end function sub_rc
   real(default) function sub_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval - en2%rval
   end function sub_rr
   complex(default) function sub_cc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval - en2%cval
   end function sub_cc
 
   integer function mul_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival * en2%ival
   end function mul_ii
   real(default) function mul_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival * en2%rval
   end function mul_ir
   real(default) function mul_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval * en2%ival
   end function mul_ri
   complex(default) function mul_ic (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival * en2%cval
   end function mul_ic
   complex(default) function mul_ci (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval * en2%ival
   end function mul_ci
   complex(default) function mul_rc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval * en2%cval
   end function mul_rc
   complex(default) function mul_cr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval * en2%rval
   end function mul_cr
   real(default) function mul_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval * en2%rval
   end function mul_rr
   complex(default) function mul_cc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval * en2%cval
   end function mul_cc
 
   integer function div_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (en2%ival == 0) then
        if (en1%ival >= 0) then
           call msg_warning ("division by zero: " // int2char (en1%ival) // &
              " / 0 ; result set to 0")
        else
           call msg_warning ("division by zero: (" // int2char (en1%ival) // &
              ") / 0 ; result set to 0")
        end if
        y = 0
        return
     end if
     y = en1%ival / en2%ival
   end function div_ii
   real(default) function div_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival / en2%rval
   end function div_ir
   real(default) function div_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval / en2%ival
   end function div_ri
   complex(default) function div_ic (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival / en2%cval
   end function div_ic
   complex(default) function div_ci (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval / en2%ival
   end function div_ci
   complex(default) function div_rc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval / en2%cval
   end function div_rc
   complex(default) function div_cr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval / en2%rval
   end function div_cr
   real(default) function div_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval / en2%rval
   end function div_rr
   complex(default) function div_cc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval / en2%cval
   end function div_cc
 
   integer function pow_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     integer :: a, b
     real(default) :: rres
     a = en1%ival
     b = en2%ival
     if ((a == 0) .and. (b < 0)) then
        call msg_warning ("division by zero: " // int2char (a) // &
           " ^ (" // int2char (b) // ") ; result set to 0")
        y = 0
        return
     end if
     rres = real(a, default) ** b
     y = rres
     if (real(y, default) /= rres) then
        if (b < 0) then
           call msg_warning ("result of all-integer operation " // &
                 int2char (a) // " ^ (" // int2char (b) // &
                 ") has been trucated to "// int2char (y), &
              [  var_str ("Chances are that you want to use " // &
                 "reals instead of integers at this point.") ])
        else
           call msg_warning ("integer overflow in " // int2char (a) // &
                 " ^ " // int2char (b) // " ; result is " // int2char (y), &
              [  var_str ("Using reals instead of integers might help.")])
        end if
     end if
   end function pow_ii
   real(default) function pow_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval ** en2%ival
   end function pow_ri
   complex(default) function pow_ci (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval ** en2%ival
   end function pow_ci
   real(default) function pow_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival ** en2%rval
   end function pow_ir
   real(default) function pow_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval ** en2%rval
   end function pow_rr
   complex(default) function pow_cr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval ** en2%rval
   end function pow_cr
   complex(default) function pow_ic (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival ** en2%cval
   end function pow_ic
   complex(default) function pow_rc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval ** en2%cval
   end function pow_rc
   complex(default) function pow_cc (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%cval ** en2%cval
   end function pow_cc
 
   integer function max_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = max (en1%ival, en2%ival)
   end function max_ii
   real(default) function max_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = max (real (en1%ival, default), en2%rval)
   end function max_ir
   real(default) function max_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = max (en1%rval, real (en2%ival, default))
   end function max_ri
   real(default) function max_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = max (en1%rval, en2%rval)
   end function max_rr
   integer function min_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = min (en1%ival, en2%ival)
   end function min_ii
   real(default) function min_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = min (real (en1%ival, default), en2%rval)
   end function min_ir
   real(default) function min_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = min (en1%rval, real (en2%ival, default))
   end function min_ri
   real(default) function min_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = min (en1%rval, en2%rval)
   end function min_rr
 
   integer function mod_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = mod (en1%ival, en2%ival)
   end function mod_ii
   real(default) function mod_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = mod (real (en1%ival, default), en2%rval)
   end function mod_ir
   real(default) function mod_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = mod (en1%rval, real (en2%ival, default))
   end function mod_ri
   real(default) function mod_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = mod (en1%rval, en2%rval)
   end function mod_rr
   integer function modulo_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = modulo (en1%ival, en2%ival)
   end function modulo_ii
   real(default) function modulo_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = modulo (real (en1%ival, default), en2%rval)
   end function modulo_ir
   real(default) function modulo_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = modulo (en1%rval, real (en2%ival, default))
   end function modulo_ri
   real(default) function modulo_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = modulo (en1%rval, en2%rval)
   end function modulo_rr
 
 @
 \subsubsection{Unary numeric functions}
 <<Eval trees: procedures>>=
   real(default) function real_i (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%ival
   end function real_i
   real(default) function real_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%cval
   end function real_c
   integer function int_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%rval
   end function int_r
   complex(default) function cmplx_i (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%ival
   end function cmplx_i
   integer function int_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%cval
   end function int_c
   complex(default) function cmplx_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%rval
   end function cmplx_r
   integer function nint_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = nint (en%rval)
   end function nint_r
   integer function floor_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = floor (en%rval)
   end function floor_r
   integer function ceiling_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = ceiling (en%rval)
   end function ceiling_r
 
   integer function neg_i (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = - en%ival
   end function neg_i
   real(default) function neg_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = - en%rval
   end function neg_r
   complex(default) function neg_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = - en%cval
   end function neg_c
   integer function abs_i (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = abs (en%ival)
   end function abs_i
   real(default) function abs_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = abs (en%rval)
   end function abs_r
   real(default) function abs_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = abs (en%cval)
   end function abs_c
   integer function conjg_i (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%ival
   end function conjg_i
   real(default) function conjg_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = en%rval
   end function conjg_r
   complex(default) function conjg_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = conjg (en%cval)
   end function conjg_c
   integer function sgn_i (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sign (1, en%ival)
   end function sgn_i
   real(default) function sgn_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sign (1._default, en%rval)
   end function sgn_r
 
   real(default) function sqrt_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sqrt (en%rval)
   end function sqrt_r
   real(default) function exp_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = exp (en%rval)
   end function exp_r
   real(default) function log_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = log (en%rval)
   end function log_r
   real(default) function log10_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = log10 (en%rval)
   end function log10_r
 
   complex(default) function sqrt_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sqrt (en%cval)
   end function sqrt_c
   complex(default) function exp_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = exp (en%cval)
   end function exp_c
   complex(default) function log_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = log (en%cval)
   end function log_c
 
   real(default) function sin_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sin (en%rval)
   end function sin_r
   real(default) function cos_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = cos (en%rval)
   end function cos_r
   real(default) function tan_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = tan (en%rval)
   end function tan_r
   real(default) function asin_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = asin (en%rval)
   end function asin_r
   real(default) function acos_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = acos (en%rval)
   end function acos_r
   real(default) function atan_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = atan (en%rval)
   end function atan_r
 
   complex(default) function sin_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sin (en%cval)
   end function sin_c
   complex(default) function cos_c (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = cos (en%cval)
   end function cos_c
 
   real(default) function sinh_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = sinh (en%rval)
   end function sinh_r
   real(default) function cosh_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = cosh (en%rval)
   end function cosh_r
   real(default) function tanh_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = tanh (en%rval)
   end function tanh_r
   real(default) function asinh_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = asinh (en%rval)
   end function asinh_r
   real(default) function acosh_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = acosh (en%rval)
   end function acosh_r
   real(default) function atanh_r (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = atanh (en%rval)
   end function atanh_r
 
 @
 \subsubsection{Binary logical functions}
 Logical expressions:
 <<Eval trees: procedures>>=
   logical function ignore_first_ll (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en2%lval
   end function ignore_first_ll
   logical function or_ll (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%lval .or. en2%lval
   end function or_ll
   logical function and_ll (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%lval .and. en2%lval
   end function and_ll
 
 @ Comparisons:
 <<Eval trees: procedures>>=
   logical function comp_lt_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival < en2%ival
   end function comp_lt_ii
   logical function comp_lt_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival < en2%rval
   end function comp_lt_ir
   logical function comp_lt_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval < en2%ival
   end function comp_lt_ri
   logical function comp_lt_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval < en2%rval
   end function comp_lt_rr
 
   logical function comp_gt_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival > en2%ival
   end function comp_gt_ii
   logical function comp_gt_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival > en2%rval
   end function comp_gt_ir
   logical function comp_gt_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval > en2%ival
   end function comp_gt_ri
   logical function comp_gt_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval > en2%rval
   end function comp_gt_rr
 
   logical function comp_le_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival <= en2%ival
   end function comp_le_ii
   logical function comp_le_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival <= en2%rval
   end function comp_le_ir
   logical function comp_le_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval <= en2%ival
   end function comp_le_ri
   logical function comp_le_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval <= en2%rval
   end function comp_le_rr
 
   logical function comp_ge_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival >= en2%ival
   end function comp_ge_ii
   logical function comp_ge_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival >= en2%rval
   end function comp_ge_ir
   logical function comp_ge_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval >= en2%ival
   end function comp_ge_ri
   logical function comp_ge_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval >= en2%rval
   end function comp_ge_rr
 
   logical function comp_eq_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival == en2%ival
   end function comp_eq_ii
   logical function comp_eq_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival == en2%rval
   end function comp_eq_ir
   logical function comp_eq_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval == en2%ival
   end function comp_eq_ri
   logical function comp_eq_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval == en2%rval
   end function comp_eq_rr
   logical function comp_eq_ss (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%sval == en2%sval
   end function comp_eq_ss
 
   logical function comp_ne_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival /= en2%ival
   end function comp_ne_ii
   logical function comp_ne_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%ival /= en2%rval
   end function comp_ne_ir
   logical function comp_ne_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval /= en2%ival
   end function comp_ne_ri
   logical function comp_ne_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%rval /= en2%rval
   end function comp_ne_rr
   logical function comp_ne_ss (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     y = en1%sval /= en2%sval
   end function comp_ne_ss
 
 @ Comparisons with tolerance:
 <<Eval trees: procedures>>=
   logical function comp_se_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%ival - en2%ival) <= en1%tolerance
     else
        y = en1%ival == en2%ival
     end if
   end function comp_se_ii
   logical function comp_se_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%rval - en2%ival) <= en1%tolerance
     else
        y = en1%rval == en2%ival
     end if
   end function comp_se_ri
   logical function comp_se_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%ival - en2%rval) <= en1%tolerance
     else
        y = en1%ival == en2%rval
     end if
   end function comp_se_ir
   logical function comp_se_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%rval - en2%rval) <= en1%tolerance
     else
        y = en1%rval == en2%rval
     end if
   end function comp_se_rr
   logical function comp_ns_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%ival - en2%ival) > en1%tolerance
     else
        y = en1%ival /= en2%ival
     end if
   end function comp_ns_ii
   logical function comp_ns_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%rval - en2%ival) > en1%tolerance
     else
        y = en1%rval /= en2%ival
     end if
   end function comp_ns_ri
   logical function comp_ns_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%ival - en2%rval) > en1%tolerance
     else
        y = en1%ival /= en2%rval
     end if
   end function comp_ns_ir
   logical function comp_ns_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = abs (en1%rval - en2%rval) > en1%tolerance
     else
        y = en1%rval /= en2%rval
     end if
   end function comp_ns_rr
 
   logical function comp_ls_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival <= en2%ival + en1%tolerance
     else
        y = en1%ival <= en2%ival
     end if
   end function comp_ls_ii
   logical function comp_ls_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval <= en2%ival + en1%tolerance
     else
        y = en1%rval <= en2%ival
     end if
   end function comp_ls_ri
   logical function comp_ls_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival <= en2%rval + en1%tolerance
     else
        y = en1%ival <= en2%rval
     end if
   end function comp_ls_ir
   logical function comp_ls_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval <= en2%rval + en1%tolerance
     else
        y = en1%rval <= en2%rval
     end if
   end function comp_ls_rr
 
   logical function comp_ll_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival < en2%ival - en1%tolerance
     else
        y = en1%ival < en2%ival
     end if
   end function comp_ll_ii
   logical function comp_ll_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval < en2%ival - en1%tolerance
     else
        y = en1%rval < en2%ival
     end if
   end function comp_ll_ri
   logical function comp_ll_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival < en2%rval - en1%tolerance
     else
        y = en1%ival < en2%rval
     end if
   end function comp_ll_ir
   logical function comp_ll_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval < en2%rval - en1%tolerance
     else
        y = en1%rval < en2%rval
     end if
   end function comp_ll_rr
 
   logical function comp_gs_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival >= en2%ival - en1%tolerance
     else
        y = en1%ival >= en2%ival
     end if
   end function comp_gs_ii
   logical function comp_gs_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval >= en2%ival - en1%tolerance
     else
        y = en1%rval >= en2%ival
     end if
   end function comp_gs_ri
   logical function comp_gs_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival >= en2%rval - en1%tolerance
     else
        y = en1%ival >= en2%rval
     end if
   end function comp_gs_ir
   logical function comp_gs_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval >= en2%rval - en1%tolerance
     else
        y = en1%rval >= en2%rval
     end if
   end function comp_gs_rr
 
   logical function comp_gg_ii (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival > en2%ival + en1%tolerance
     else
        y = en1%ival > en2%ival
     end if
   end function comp_gg_ii
   logical function comp_gg_ri (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval > en2%ival + en1%tolerance
     else
        y = en1%rval > en2%ival
     end if
   end function comp_gg_ri
   logical function comp_gg_ir (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%ival > en2%rval + en1%tolerance
     else
        y = en1%ival > en2%rval
     end if
   end function comp_gg_ir
   logical function comp_gg_rr (en1, en2) result (y)
     type(eval_node_t), intent(in) :: en1, en2
     if (associated (en1%tolerance)) then
        y = en1%rval > en2%rval + en1%tolerance
     else
        y = en1%rval > en2%rval
     end if
   end function comp_gg_rr
 
 @
 \subsubsection{Unary logical functions}
 <<Eval trees: procedures>>=
   logical function not_l (en) result (y)
     type(eval_node_t), intent(in) :: en
     y = .not. en%lval
   end function not_l
 
 @
 \subsubsection{Unary PDG-array functions}
 Make a PDG-array object from an integer.
 <<Eval trees: procedures>>=
   subroutine pdg_i (pdg_array, en)
     type(pdg_array_t), intent(out) :: pdg_array
     type(eval_node_t), intent(in) :: en
     pdg_array = en%ival
   end subroutine pdg_i
 
 @
 \subsubsection{Binary PDG-array functions}
 Concatenate two PDG-array objects.
 <<Eval trees: procedures>>=
   subroutine concat_cc (pdg_array, en1, en2)
     type(pdg_array_t), intent(out) :: pdg_array
     type(eval_node_t), intent(in) :: en1, en2
     pdg_array = en1%aval // en2%aval
   end subroutine concat_cc
 
 @
 \subsubsection{Unary particle-list functions}
 Combine all particles of the first argument.  If [[en0]] is present,
 create a mask which is true only for those particles that pass the
 test.
 <<Eval trees: procedures>>=
   subroutine collect_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))
     if (present (en0)) then
        do i = 1, n
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval
        end do
     else
        mask1 = .true.
     end if
     call subevt_collect (subevt, en1%pval, mask1)
   end subroutine collect_p
 
 @ %def collect_p
 @ Cluster the particles of the first argument.  If [[en0]] is present,
 create a mask which is true only for those particles that pass the
 test.
 <<Eval trees: procedures>>=
   subroutine cluster_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     !!! Should not be initialized for every event
     type(jet_definition_t) :: jet_def
     logical :: keep_jets
     call jet_def%init (en1%jet_algorithm, en1%jet_r, en1%jet_p, en1%jet_ycut)
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))
     if (present (en0)) then
        do i = 1, n
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval
        end do
     else
        mask1 = .true.
     end if
     if (associated (en1%var_list)) then
        keep_jets = en1%var_list%get_lval (var_str("?keep_flavors_when_clustering"))
     else
        keep_jets = .false.
     end if
     call subevt_cluster (subevt, en1%pval, mask1, jet_def, keep_jets)
     call jet_def%final ()
   end subroutine cluster_p
 
 @ %def cluster_p
 @ Select all particles of the first argument.  If [[en0]] is present,
 create a mask which is true only for those particles that pass the
 test.
 <<Eval trees: procedures>>=
   subroutine select_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))
     if (present (en0)) then
        do i = 1, subevt_get_length (en1%pval)
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval
        end do
     else
        mask1 = .true.
     end if
     call subevt_select (subevt, en1%pval, mask1)
   end subroutine select_p
 
 @ %def select_p
 [[select_b_jet_p]], [[select_non_b_jet_p]], [[select_c_jet_p]], and 
 [[select_light_jet_p]] are special selection function acting on a
 subevent of combined particles (jets) and result in a list of $b$
 jets, non-$b$ jets (i.e. $c$ and light jets), $c$ jets, and light
 jets, respectively. 
 <<Eval trees: procedures>>=
   subroutine select_b_jet_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))    
     do i = 1, subevt_get_length (en1%pval)
        mask1(i) = prt_is_b_jet (subevt_get_prt (en1%pval, i))
        if (present (en0)) then
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval .and. mask1(i)
         end if
     end do
     call subevt_select (subevt, en1%pval, mask1)
   end subroutine select_b_jet_p
 
 @ %def select_b_jet_p
 <<Eval trees: procedures>>=
   subroutine select_non_b_jet_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))    
     do i = 1, subevt_get_length (en1%pval)
        mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i))
        if (present (en0)) then
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval .and. mask1(i)
         end if
     end do
     call subevt_select (subevt, en1%pval, mask1)
   end subroutine select_non_b_jet_p
 
 @ %def select_non_b_jet_p
 <<Eval trees: procedures>>=
   subroutine select_c_jet_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))    
     do i = 1, subevt_get_length (en1%pval)
        mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) &
             .and. prt_is_c_jet (subevt_get_prt (en1%pval, i))
        if (present (en0)) then
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval .and. mask1(i)
         end if
     end do
     call subevt_select (subevt, en1%pval, mask1)
   end subroutine select_c_jet_p
 
 @ %def select_c_jet_p
 <<Eval trees: procedures>>=
   subroutine select_light_jet_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: n, i
     n = subevt_get_length (en1%pval)
     allocate (mask1 (n))    
     do i = 1, subevt_get_length (en1%pval)
        mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) &
             .and. .not. prt_is_c_jet (subevt_get_prt (en1%pval, i))
        if (present (en0)) then
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           mask1(i) = en0%lval .and. mask1(i)
         end if
     end do
     call subevt_select (subevt, en1%pval, mask1)
   end subroutine select_light_jet_p
 
 @ %def select_light_jet_p
 @ Extract the particle with index given by [[en0]] from the argument
 list.  Negative indices count from the end.  If [[en0]] is absent,
 extract the first particle.  The result is a list with a single entry,
 or no entries if the original list was empty or if the index is out of
 range.
 
 This function has no counterpart with two arguments.
 <<Eval trees: procedures>>=
   subroutine extract_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     integer :: index
     if (present (en0)) then
        call eval_node_evaluate (en0)
        select case (en0%result_type)
        case (V_INT);  index = en0%ival
        case default
           call eval_node_write (en0)
           call msg_fatal (" Index parameter of 'extract' must be integer.")
        end select
     else
        index = 1
     end if
     call subevt_extract (subevt, en1%pval, index)
   end subroutine extract_p
 
 @ %def extract_p
 @ Sort the subevent according to the result of evaluating
 [[en0]].  If [[en0]] is absent, sort by default method (PDG code,
 particles before antiparticles).
 <<Eval trees: procedures>>=
   subroutine sort_p (subevt, en1, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     integer, dimension(:), allocatable :: ival
     real(default), dimension(:), allocatable :: rval
     integer :: i, n
     n = subevt_get_length (en1%pval)
     if (present (en0)) then
        select case (en0%result_type)
        case (V_INT);  allocate (ival (n))
        case (V_REAL); allocate (rval (n))
        end select
        do i = 1, n
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           select case (en0%result_type)
           case (V_INT);  ival(i) = en0%ival
           case (V_REAL); rval(i) = en0%rval
           end select
        end do
        select case (en0%result_type)
        case (V_INT);  call subevt_sort (subevt, en1%pval, ival)
        case (V_REAL); call subevt_sort (subevt, en1%pval, rval)
        end select
     else
        call subevt_sort (subevt, en1%pval)
     end if
   end subroutine sort_p
 
 @ %def sort_p
 @ The following functions return a logical value.  [[all]] evaluates
 to true if the condition [[en0]] is true for all elements of the
 subevent.  [[any]] and [[no]] are analogous.
 <<Eval trees: procedures>>=
   function all_p (en1, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout) :: en0
     integer :: i, n
     n = subevt_get_length (en1%pval)
     lval = .true.
     do i = 1, n
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        call eval_node_evaluate (en0)
        lval = en0%lval
        if (.not. lval)  exit
     end do
   end function all_p
 
   function any_p (en1, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout) :: en0
     integer :: i, n
     n = subevt_get_length (en1%pval)
     lval = .false.
     do i = 1, n
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        call eval_node_evaluate (en0)
        lval = en0%lval
        if (lval)  exit
     end do
   end function any_p
 
   function no_p (en1, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout) :: en0
     integer :: i, n
     n = subevt_get_length (en1%pval)
     lval = .true.
     do i = 1, n
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        call eval_node_evaluate (en0)
        lval = .not. en0%lval
        if (lval)  exit
     end do
   end function no_p
 
 @ %def all_p any_p no_p
 @ This is the interface to user-supplied observables.  The node [[en0]]
 evaluates to a string that indicates the procedure name.  We search for the
 procedure in the dynamic library and load it into the procedure pointer which
 is then called.  [[en1]] is the subevent on which the external code
 operates.  The external function returns a [[c_int]], which we translate
 into a real value.
 <<Eval trees: procedures>>=
   function user_obs_int_p (en0, prt1) result (ival)
     integer :: ival
     type(eval_node_t), intent(inout) :: en0
     type(prt_t), intent(in) :: prt1
     type(string_t) :: name
     procedure(user_obs_int_unary), pointer :: user_obs
     call eval_node_evaluate (en0)
     if (en0%value_is_known) then
        select case (en0%result_type)
        case (V_STR);  name = en0%sval
        case default
           call msg_bug ("user_obs: procedure name must be a string")
           name = ""
        end select
        call c_f_procpointer (user_code_find_proc (name), user_obs)
        ival = user_obs (c_prt (prt1))
     else
        call eval_node_write_rec (en0)
        call msg_fatal ("User observable name is undefined")
     end if
   end function user_obs_int_p
 
   function user_obs_real_p (en0, prt1) result (rval)
     real(default) :: rval
     type(eval_node_t), intent(inout) :: en0
     type(prt_t), intent(in) :: prt1
     type(string_t) :: name
     procedure(user_obs_real_unary), pointer :: user_obs
     call eval_node_evaluate (en0)
     if (en0%value_is_known) then
        select case (en0%result_type)
        case (V_STR);  name = en0%sval
        case default
           call msg_bug ("user_obs: procedure name must be a string")
           name = ""
        end select
        call c_f_procpointer (user_code_find_proc (name), user_obs)
        rval = user_obs (c_prt (prt1))
     else
        call eval_node_write_rec (en0)
        call msg_fatal ("User observable name is undefined")
     end if
   end function user_obs_real_p
 
 @ %def user_obs_int_p
 @ %def user_obs_real_p
 @ This is the interface to user-supplied cut code.  The node [[en0]]
 evaluates to a string that indicates the procedure name.
 <<Eval trees: procedures>>=
   function user_cut_p (en1, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout) :: en0
     type(string_t) :: name
     procedure(user_cut_fun), pointer :: user_cut
     call eval_node_evaluate (en0)
     select case (en0%result_type)
     case (V_STR);  name = en0%sval
     case default
        call msg_bug ("user_cut: procedure name must be a string")
        name = ""
     end select
     call c_f_procpointer (user_code_find_proc (name), user_cut)
     lval = user_cut (c_prt (en1%pval), &
                      int (subevt_get_length (en1%pval), kind=c_int)) &
            /= 0
   end function user_cut_p
 
 @ %def user_cut_p
 @ The following function returns an integer value, namely the number
 of particles for which the condition is true.  If there is no
 condition, it returns simply the length of the subevent.
 <<Eval trees: procedures>>=
   subroutine count_a (ival, en1, en0)
     integer, intent(out) :: ival
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     integer :: i, n, count
     n = subevt_get_length (en1%pval)
     if (present (en0)) then
        count = 0
        do i = 1, n
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           call eval_node_evaluate (en0)
           if (en0%lval)  count = count + 1
        end do
        ival = count
     else
        ival = n
     end if
   end subroutine count_a
 
 @ %def count_a
 @ This evaluates a user-defined event-shape observable for the current
 subevent.
 <<Eval trees: procedures>>=
   subroutine user_event_shape_a (rval, en1, en0)
     real(default), intent(out) :: rval
     type(eval_node_t), intent(in) :: en1
     type(eval_node_t), intent(inout), optional :: en0
     type(string_t) :: name
     procedure(user_event_shape_fun), pointer :: user_event_shape
     if (.not. present (en0))  call msg_bug &
          ("user_event_shape called without procedure name")
     call eval_node_evaluate (en0)
     select case (en0%result_type)
     case (V_STR);  name = en0%sval
     case default
        call msg_bug ("user_event_shape: procedure name must be a string")
        name = ""
     end select
     call c_f_procpointer (user_code_find_proc (name), user_event_shape)
     rval = user_event_shape (c_prt (en1%pval), &
                              int (subevt_get_length (en1%pval), kind=c_int))
   end subroutine user_event_shape_a
 
 @ %def user_event_shape_a
 @
 \subsubsection{Binary particle-list functions}
 This joins two subevents, stored in the evaluation nodes [[en1]]
 and [[en2]].  If [[en0]] is also present, it amounts to a logical test
 returning true or false for every pair of particles.  A particle of
 the second list gets a mask entry only if it passes the test for all
 particles of the first list.
 <<Eval trees: procedures>>=
   subroutine join_pp (subevt, en1, en2, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask2
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     allocate (mask2 (n2))
     mask2 = .true.
     if (present (en0)) then
        do i = 1, n1
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           do j = 1, n2
              en0%prt2 = subevt_get_prt (en2%pval, j)
              call eval_node_evaluate (en0)
              mask2(j) = mask2(j) .and. en0%lval
           end do
        end do
     end if
     call subevt_join (subevt, en1%pval, en2%pval, mask2)
   end subroutine join_pp
 
 @ %def join_pp
 @ Combine two subevents, i.e., make a list of composite particles
 built from all possible particle pairs from the two lists.  If [[en0]]
 is present, create a mask which is true only for those pairs that pass
 the test.
 <<Eval trees: procedures>>=
   subroutine combine_pp (subevt, en1, en2, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:,:), allocatable :: mask12
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     if (present (en0)) then
        allocate (mask12 (n1, n2))
        do i = 1, n1
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           do j = 1, n2
              en0%prt2 = subevt_get_prt (en2%pval, j)
              call eval_node_evaluate (en0)
              mask12(i,j) = en0%lval
           end do
        end do
        call subevt_combine (subevt, en1%pval, en2%pval, mask12)
     else
        call subevt_combine (subevt, en1%pval, en2%pval)
     end if
   end subroutine combine_pp
 
 @ %def combine_pp
 @ Combine all particles of the first argument.  If [[en0]] is present,
 create a mask which is true only for those particles that pass the
 test w.r.t. all particles in the second argument.  If [[en0]] is
 absent, the second argument is ignored.
 <<Eval trees: procedures>>=
   subroutine collect_pp (subevt, en1, en2, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     allocate (mask1 (n1))
     mask1 = .true.
     if (present (en0)) then
        do i = 1, n1
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           do j = 1, n2
              en0%prt2 = subevt_get_prt (en2%pval, j)
              call eval_node_evaluate (en0)
              mask1(i) = mask1(i) .and. en0%lval
           end do
        end do
     end if
     call subevt_collect (subevt, en1%pval, mask1)
   end subroutine collect_pp
 
 @ %def collect_pp
 @ Select all particles of the first argument.  If [[en0]] is present,
 create a mask which is true only for those particles that pass the
 test w.r.t. all particles in the second argument.  If [[en0]] is
 absent, the second argument is ignored, and the first argument is
 transferred unchanged.  (This case is not very useful, of course.)
 <<Eval trees: procedures>>=
   subroutine select_pp (subevt, en1, en2, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     logical, dimension(:), allocatable :: mask1
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     allocate (mask1 (n1))
     mask1 = .true.
     if (present (en0)) then
        do i = 1, n1
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           do j = 1, n2
              en0%prt2 = subevt_get_prt (en2%pval, j)
              call eval_node_evaluate (en0)
              mask1(i) = mask1(i) .and. en0%lval
           end do
        end do
     end if
     call subevt_select (subevt, en1%pval, mask1)
   end subroutine select_pp
 
 @ %def select_pp
 @ Sort the first subevent according to the result of evaluating
 [[en0]].  From the second subevent, only the first element is
 taken as reference.  If [[en0]] is absent, we sort by default method
 (PDG code, particles before antiparticles).
 <<Eval trees: procedures>>=
   subroutine sort_pp (subevt, en1, en2, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     integer, dimension(:), allocatable :: ival
     real(default), dimension(:), allocatable :: rval
     integer :: i, n1
     n1 = subevt_get_length (en1%pval)
     if (present (en0)) then
        select case (en0%result_type)
        case (V_INT);  allocate (ival (n1))
        case (V_REAL); allocate (rval (n1))
        end select
        do i = 1, n1
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           en0%prt2 = subevt_get_prt (en2%pval, 1)
           call eval_node_evaluate (en0)
           select case (en0%result_type)
           case (V_INT);  ival(i) = en0%ival
           case (V_REAL); rval(i) = en0%rval
           end select
        end do
        select case (en0%result_type)
        case (V_INT);  call subevt_sort (subevt, en1%pval, ival)
        case (V_REAL); call subevt_sort (subevt, en1%pval, rval)
        end select
     else
        call subevt_sort (subevt, en1%pval)
     end if
   end subroutine sort_pp
 
 @ %def sort_pp
 @ The following functions return a logical value.  [[all]] evaluates
 to true if the condition [[en0]] is true for all valid element pairs
 of both subevents.  Invalid pairs (with common [[src]] entry) are
 ignored.
 
 [[any]] and [[no]] are analogous.
 <<Eval trees: procedures>>=
   function all_pp (en1, en2, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout) :: en0
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     lval = .true.
     LOOP1: do i = 1, n1
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        do j = 1, n2
           en0%prt2 = subevt_get_prt (en2%pval, j)
           if (are_disjoint (en0%prt1, en0%prt2)) then
              call eval_node_evaluate (en0)
              lval = en0%lval
              if (.not. lval)  exit LOOP1
           end if
        end do
     end do LOOP1
   end function all_pp
 
   function any_pp (en1, en2, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout) :: en0
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     lval = .false.
     LOOP1: do i = 1, n1
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        do j = 1, n2
           en0%prt2 = subevt_get_prt (en2%pval, j)
           if (are_disjoint (en0%prt1, en0%prt2)) then
              call eval_node_evaluate (en0)
              lval = en0%lval
              if (lval)  exit LOOP1
           end if
        end do
     end do LOOP1
   end function any_pp
 
   function no_pp (en1, en2, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout) :: en0
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     lval = .true.
     LOOP1: do i = 1, n1
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        do j = 1, n2
           en0%prt2 = subevt_get_prt (en2%pval, j)
           if (are_disjoint (en0%prt1, en0%prt2)) then
              call eval_node_evaluate (en0)
              lval = .not. en0%lval
              if (lval)  exit LOOP1
           end if
        end do
     end do LOOP1
   end function no_pp
 
 @ %def all_pp any_pp no_pp
 The conditional restriction encoded in the [[eval_node_t]] [[en_0]] is
 applied only to the photons from [[en1]], not to the objects being
 isolated from in [[en2]].
 <<Eval trees: procedures>>=
   function photon_isolation_pp (en1, en2, en0) result (lval)
     logical :: lval
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout) :: en0
     type(prt_t) :: prt
     type(prt_t), dimension(:), allocatable :: prt_gam0, prt_lep
     type(vector4_t), dimension(:), allocatable :: &
          p_gam0, p_lep0, p_lep, p_par
     integer :: i, j, n1, n2, n_par, n_lep, n_gam, n_delta
     real(default), dimension(:), allocatable :: delta_r, et_sum
     integer, dimension(:), allocatable :: index
     real(default) :: eps, iso_n, r0, pt_gam
     logical, dimension(:,:), allocatable :: photon_mask
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     allocate (p_gam0 (n1), prt_gam0 (n1))
     eps = en1%photon_iso_eps
     iso_n = en1%photon_iso_n
     r0 = en1%photon_iso_r0
     lval = .true.
     do i = 1, n1
        en0%index = i
        prt = subevt_get_prt (en1%pval, i)
        prt_gam0(i) = prt
        if (.not. prt_is_photon (prt_gam0(i))) &
             call msg_fatal ("Photon isolation can only " // &
             "be applied to photons.")
        p_gam0(i) = prt_get_momentum (prt_gam0(i))
        en0%prt1 = prt
        call eval_node_evaluate (en0)
        lval = en0%lval
        if (.not. lval) return
     end do
     if (n1 == 0) then
        call msg_fatal ("Photon isolation applied on empty photon sample.")
     end if
     n_par = 0
     n_lep = 0
     n_gam = 0
     do i = 1, n2
        prt = subevt_get_prt (en2%pval, i)
        if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then
           n_par = n_par + 1
        end if
        if (prt_is_lepton (prt)) then
           n_lep = n_lep + 1
        end if
        if (prt_is_photon (prt)) then
           n_gam = n_gam + 1
        end if
     end do
     if (n_lep > 0 .and. n_gam == 0) then
        call msg_fatal ("Photon isolation from EM energy: photons " // &
             "have to be included.")
     end if
     if (n_lep > 0 .and. n_gam /= n1) then
        call msg_fatal ("Photon isolation: photon samples do not match.")
     end if
     allocate (p_par (n_par))
     allocate (p_lep0 (n_gam+n_lep), prt_lep(n_gam+n_lep))
     n_par = 0
     n_lep = 0
     do i = 1, n2
        prt = subevt_get_prt (en2%pval, i)
        if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then
           n_par = n_par + 1
           p_par(n_par) = prt_get_momentum (prt)
        end if
        if (prt_is_lepton (prt) .or. prt_is_photon(prt)) then
           n_lep = n_lep + 1
           prt_lep(n_lep) = prt
           p_lep0(n_lep) = prt_get_momentum (prt_lep(n_lep))
        end if       
     end do
     if (n_par > 0) then
        allocate (delta_r (n_par), index (n_par))
        HADRON_ISOLATION: do i = 1, n1
           pt_gam = transverse_part (p_gam0(i))
           delta_r(1:n_par) = sort (eta_phi_distance (p_gam0(i), p_par(1:n_par)))
           index(1:n_par) = order (eta_phi_distance (p_gam0(i), p_par(1:n_par)))
           n_delta = count (delta_r < r0)
           allocate (et_sum(n_delta))
           do j = 1, n_delta
              et_sum(j) = sum (transverse_part (p_par (index (1:j))))
              if (.not. et_sum(j) <= &
                   iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then
                 lval = .false.
                 return
              end if
           end do
           deallocate (et_sum)
        end do HADRON_ISOLATION
        deallocate (delta_r)
        deallocate (index)
     end if
     if (n_lep > 0) then
        allocate (photon_mask(n1,n_lep))
        do i = 1, n1
           photon_mask(i,:) = .not. (prt_gam0(i) .match. prt_lep(:))
        end do
        allocate (delta_r (n_lep-1), index (n_lep-1), p_lep(n_lep-1))
        EM_ISOLATION: do i = 1, n1
           pt_gam = transverse_part (p_gam0(i))
           p_lep = pack (p_lep0, photon_mask(i,:))          
           delta_r(1:n_lep-1) = sort (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1)))
           index(1:n_lep-1) = order (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1)))
           n_delta = count (delta_r < r0)
           allocate (et_sum(n_delta))
           do j = 1, n_delta
              et_sum(j) = sum (transverse_part (p_lep (index(1:j))))
              if (.not. et_sum(j) <= &
                   iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then
                 lval = .false.
                 return
              end if
           end do
           deallocate (et_sum)
        end do EM_ISOLATION
        deallocate (delta_r)
        deallocate (index)
     end if
   contains
     function iso_chi_gamma (dr, r0_gam, n_gam, eps_gam, pt_gam) result (iso)
       real(default) :: iso
       real(default), intent(in) :: dr, r0_gam, n_gam, eps_gam, pt_gam
       iso = eps_gam * pt_gam
       if (.not. nearly_equal (abs(n_gam), 0._default)) then
          iso = iso * ((1._default - cos(dr)) / &
               (1._default - cos(r0_gam)))**abs(n_gam)
       end if
     end function iso_chi_gamma
   end function photon_isolation_pp
 
 @ %def photon_isolation_pp
 @ This function evaluates an observable for a pair of particles.  From the two
 particle lists, we take the first pair without [[src]] overlap.  If there is
 no valid pair, we revert the status of the value to unknown.
 <<Eval trees: procedures>>=
   subroutine eval_pp (en1, en2, en0, rval, is_known)
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout) :: en0
     real(default), intent(out) :: rval
     logical, intent(out) :: is_known
     integer :: i, j, n1, n2
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     rval = 0
     is_known = .false.
     LOOP1: do i = 1, n1
        en0%index = i
        en0%prt1 = subevt_get_prt (en1%pval, i)
        do j = 1, n2
           en0%prt2 = subevt_get_prt (en2%pval, j)
           if (are_disjoint (en0%prt1, en0%prt2)) then
              call eval_node_evaluate (en0)
              rval = en0%rval
              is_known = .true.
              exit LOOP1
           end if
        end do
     end do LOOP1
   end subroutine eval_pp
 
 @ %def eval_pp
 @ This is the interface to user-supplied observables.  The node [[en0]]
 evaluates to a string that indicates the procedure name.  We search for the
 procedure in the dynamic library and load it into the procedure pointer which
 is then called.  [[en1]] is the subevent on which the external code
 operates.  The external function returns a [[c_int]], which we translate
 into a real value.
 <<Eval trees: procedures>>=
   function user_obs_int_pp (en0, prt1, prt2) result (ival)
     integer :: ival
     type(eval_node_t), intent(inout) :: en0
     type(prt_t), intent(in) :: prt1, prt2
     type(string_t) :: name
     procedure(user_obs_int_binary), pointer :: user_obs
     call eval_node_evaluate (en0)
     if (en0%value_is_known) then
        select case (en0%result_type)
        case (V_STR);  name = en0%sval
        case default
           call msg_bug ("user_obs: procedure name must be a string")
           name = ""
        end select
        call c_f_procpointer (user_code_find_proc (name), user_obs)
        ival = user_obs (c_prt (prt1), c_prt (prt2))
     else
        call eval_node_write_rec (en0)
        call msg_fatal ("User observable name is undefined")
     end if
   end function user_obs_int_pp
 
   function user_obs_real_pp (en0, prt1, prt2) result (rval)
     real(default) :: rval
     type(eval_node_t), intent(inout) :: en0
     type(prt_t), intent(in) :: prt1, prt2
     type(string_t) :: name
     procedure(user_obs_real_binary), pointer :: user_obs
     call eval_node_evaluate (en0)
     if (en0%value_is_known) then
        select case (en0%result_type)
        case (V_STR);  name = en0%sval
        case default
           call msg_bug ("user_obs: procedure name must be a string")
           name = ""
        end select
        call c_f_procpointer (user_code_find_proc (name), user_obs)
        rval = user_obs (c_prt (prt1), c_prt (prt2))
     else
        call eval_node_write_rec (en0)
        call msg_fatal ("User observable name is undefined")
     end if
   end function user_obs_real_pp
 
 @ %def user_obs_int_pp
 @ %def user_obs_real_pp
 @ The following function returns an integer value, namely the number
 of valid particle-pairs from both lists for which the condition is
 true.  Invalid pairs (with common [[src]] entry) are ignored.  If
 there is no condition, it returns the number of valid particle pairs.
 <<Eval trees: procedures>>=
   subroutine count_pp (ival, en1, en2, en0)
     integer, intent(out) :: ival
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     integer :: i, j, n1, n2, count
     n1 = subevt_get_length (en1%pval)
     n2 = subevt_get_length (en2%pval)
     if (present (en0)) then
        count = 0
        do i = 1, n1
           en0%index = i
           en0%prt1 = subevt_get_prt (en1%pval, i)
           do j = 1, n2
              en0%prt2 = subevt_get_prt (en2%pval, j)
              if (are_disjoint (en0%prt1, en0%prt2)) then
                 call eval_node_evaluate (en0)
                 if (en0%lval)  count = count + 1
              end if
           end do
        end do
     else
        count = 0
        do i = 1, n1
           do j = 1, n2
              if (are_disjoint (subevt_get_prt (en1%pval, i), &
                                subevt_get_prt (en2%pval, j))) then
                 count = count + 1
              end if
           end do
        end do
     end if
     ival = count
   end subroutine count_pp
 
 @ %def count_pp
 @ This function makes up a subevent from the second argument
 which consists only of particles which match the PDG code array (first
 argument).
 <<Eval trees: procedures>>=
   subroutine select_pdg_ca (subevt, en1, en2, en0)
     type(subevt_t), intent(inout) :: subevt
     type(eval_node_t), intent(in) :: en1, en2
     type(eval_node_t), intent(inout), optional :: en0
     if (present (en0)) then
        call subevt_select_pdg_code (subevt, en1%aval, en2%pval, en0%ival)
     else
        call subevt_select_pdg_code (subevt, en1%aval, en2%pval)
     end if
   end subroutine select_pdg_ca
 
 @ %def select_pdg_ca
 @
 \subsubsection{Binary string functions}
 Currently, the only string operation is concatenation.
 <<Eval trees: procedures>>=
   subroutine concat_ss (string, en1, en2)
     type(string_t), intent(out) :: string
     type(eval_node_t), intent(in) :: en1, en2
     string = en1%sval // en2%sval
   end subroutine concat_ss
 
 @ %def concat_ss
 @
 \subsection{Compiling the parse tree}
 The evaluation tree is built recursively by following a parse tree.
 Evaluate an expression.  The requested type is given as an optional
 argument; default is numeric (integer or real).
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_genexpr &
        (en, pn, var_list, result_type)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(in), optional :: result_type
     if (debug_active (D_MODEL_F)) then
        print *, "read genexpr";  call parse_node_write (pn)
     end if
     if (present (result_type)) then
        select case (result_type)
        case (V_INT, V_REAL, V_CMPLX)
           call eval_node_compile_expr  (en, pn, var_list)
        case (V_LOG)
           call eval_node_compile_lexpr (en, pn, var_list)
        case (V_SEV)
           call eval_node_compile_pexpr (en, pn, var_list)
        case (V_PDG)
           call eval_node_compile_cexpr (en, pn, var_list)
        case (V_STR)
           call eval_node_compile_sexpr (en, pn, var_list)
        end select
     else
        call eval_node_compile_expr  (en, pn, var_list)
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done genexpr"
     end if
   end subroutine eval_node_compile_genexpr
 
 @ %def eval_node_compile_genexpr
 @
 \subsubsection{Numeric expressions}
 This procedure compiles a numerical expression.  This is a single term
 or a sum or difference of terms.  We have to account for all
 combinations of integer and real arguments.  If both are constant, we
 immediately do the calculation and allocate a constant node.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_expr (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_term, pn_addition, pn_op, pn_arg
     type(eval_node_t), pointer :: en1, en2
     type(string_t) :: key
     integer :: t1, t2, t
     if (debug_active (D_MODEL_F)) then
        print *, "read expr";  call parse_node_write (pn)
     end if
     pn_term => parse_node_get_sub_ptr (pn)
     select case (char (parse_node_get_rule_key (pn_term)))
     case ("term")
        call eval_node_compile_term (en, pn_term, var_list)
        pn_addition => parse_node_get_next_ptr (pn_term, tag="addition")
     case ("addition")
        en => null ()
        pn_addition => pn_term
     case default
        call parse_node_mismatch ("term|addition", pn)
     end select
     do while (associated (pn_addition))
        pn_op => parse_node_get_sub_ptr (pn_addition)
        pn_arg => parse_node_get_next_ptr (pn_op, tag="term")
        call eval_node_compile_term (en2, pn_arg, var_list)
        t2 = en2%result_type
        if (associated (en)) then
           en1 => en
           t1 = en1%result_type
        else
           allocate (en1)
           select case (t2)
           case (V_INT);  call eval_node_init_int  (en1, 0)
           case (V_REAL); call eval_node_init_real (en1, 0._default)
           case (V_CMPLX); call eval_node_init_cmplx (en1, cmplx &
                          (0._default, 0._default, kind=default))
           end select
           t1 = t2
        end if
        t = numeric_result_type (t1, t2)
        allocate (en)
        key = parse_node_get_key (pn_op)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           select case (char (key))
           case ("+")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);  call eval_node_init_int  (en, add_ii (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, add_ir (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, add_ic (en1, en2))
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);  call eval_node_init_real (en, add_ri (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, add_rr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, add_rc (en1, en2))
                 end select
               case (V_CMPLX)
                 select case (t2)
                 case (V_INT);  call eval_node_init_cmplx (en, add_ci (en1, en2))
                 case (V_REAL); call eval_node_init_cmplx (en, add_cr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, add_cc (en1, en2))
                 end select
              end select
           case ("-")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);  call eval_node_init_int  (en, sub_ii (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, sub_ir (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, sub_ic (en1, en2))
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);  call eval_node_init_real (en, sub_ri (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, sub_rr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, sub_rc (en1, en2))
                 end select
              case (V_CMPLX)
                 select case (t2)
                 case (V_INT);  call eval_node_init_cmplx (en, sub_ci (en1, en2))
                 case (V_REAL); call eval_node_init_cmplx (en, sub_cr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, sub_cc (en1, en2))
                 end select
              end select
           end select
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch (en, key, t, en1, en2)
           select case (char (key))
           case ("+")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_int  (en, add_ii)
                 case (V_REAL);  call eval_node_set_op2_real (en, add_ir)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, add_ic)
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_real (en, add_ri)
                 case (V_REAL);  call eval_node_set_op2_real (en, add_rr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, add_rc)
                 end select
              case (V_CMPLX)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_cmplx (en, add_ci)
                 case (V_REAL);  call eval_node_set_op2_cmplx (en, add_cr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, add_cc)
                 end select
              end select
           case ("-")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_int  (en, sub_ii)
                 case (V_REAL);  call eval_node_set_op2_real (en, sub_ir)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, sub_ic)
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_real (en, sub_ri)
                 case (V_REAL);  call eval_node_set_op2_real (en, sub_rr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, sub_rc)
                 end select
              case (V_CMPLX)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_cmplx (en, sub_ci)
                 case (V_REAL);  call eval_node_set_op2_cmplx (en, sub_cr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, sub_cc)
                 end select
              end select
           end select
        end if
        pn_addition => parse_node_get_next_ptr (pn_addition)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done expr"
     end if
   end subroutine eval_node_compile_expr
 
 @ %def eval_node_compile_expr
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_term (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_factor, pn_multiplication, pn_op, pn_arg
     type(eval_node_t), pointer :: en1, en2
     type(string_t) :: key
     integer :: t1, t2, t
     if (debug_active (D_MODEL_F)) then
        print *, "read term";  call parse_node_write (pn)
     end if
     pn_factor => parse_node_get_sub_ptr (pn, tag="factor")
     call eval_node_compile_factor (en, pn_factor, var_list)
     pn_multiplication => &
          parse_node_get_next_ptr (pn_factor, tag="multiplication")
     do while (associated (pn_multiplication))
        pn_op => parse_node_get_sub_ptr (pn_multiplication)
        pn_arg => parse_node_get_next_ptr (pn_op, tag="factor")
        en1 => en
        call eval_node_compile_factor (en2, pn_arg, var_list)
        t1 = en1%result_type
        t2 = en2%result_type
        t = numeric_result_type (t1, t2)
        allocate (en)
        key = parse_node_get_key (pn_op)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           select case (char (key))
           case ("*")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);  call eval_node_init_int  (en, mul_ii (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, mul_ir (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, mul_ic (en1, en2))
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);  call eval_node_init_real (en, mul_ri (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, mul_rr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, mul_rc (en1, en2))
                 end select
               case (V_CMPLX)
                 select case (t2)
                 case (V_INT);  call eval_node_init_cmplx (en, mul_ci (en1, en2))
                 case (V_REAL); call eval_node_init_cmplx (en, mul_cr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, mul_cc (en1, en2))
                 end select
              end select
           case ("/")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);  call eval_node_init_int  (en, div_ii (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, div_ir (en1, en2))
                 case (V_CMPLX); call eval_node_init_real (en, div_ir (en1, en2))
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);  call eval_node_init_real (en, div_ri (en1, en2))
                 case (V_REAL); call eval_node_init_real (en, div_rr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, div_rc (en1, en2))
                 end select
              case (V_CMPLX)
                 select case (t2)
                 case (V_INT);  call eval_node_init_cmplx (en, div_ci (en1, en2))
                 case (V_REAL); call eval_node_init_cmplx (en, div_cr (en1, en2))
                 case (V_CMPLX); call eval_node_init_cmplx (en, div_cc (en1, en2))
                 end select
              end select
           end select
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch (en, key, t, en1, en2)
           select case (char (key))
           case ("*")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_int  (en, mul_ii)
                 case (V_REAL);  call eval_node_set_op2_real (en, mul_ir)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, mul_ic)
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_real (en, mul_ri)
                 case (V_REAL);  call eval_node_set_op2_real (en, mul_rr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, mul_rc)
                 end select
              case (V_CMPLX)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_cmplx (en, mul_ci)
                 case (V_REAL);  call eval_node_set_op2_cmplx (en, mul_cr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, mul_cc)
                 end select
              end select
           case ("/")
              select case (t1)
              case (V_INT)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_int  (en, div_ii)
                 case (V_REAL);  call eval_node_set_op2_real (en, div_ir)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, div_ic)
                 end select
              case (V_REAL)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_real (en, div_ri)
                 case (V_REAL);  call eval_node_set_op2_real (en, div_rr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, div_rc)
                 end select
              case (V_CMPLX)
                 select case (t2)
                 case (V_INT);   call eval_node_set_op2_cmplx (en, div_ci)
                 case (V_REAL);  call eval_node_set_op2_cmplx (en, div_cr)
                 case (V_CMPLX);  call eval_node_set_op2_cmplx (en, div_cc)
                 end select
              end select
           end select
        end if
        pn_multiplication => parse_node_get_next_ptr (pn_multiplication)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done term"
     end if
   end subroutine eval_node_compile_term
 
 @ %def eval_node_compile_term
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_factor (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_value, pn_exponentiation, pn_op, pn_arg
     type(eval_node_t), pointer :: en1, en2
     type(string_t) :: key
     integer :: t1, t2, t
     if (debug_active (D_MODEL_F)) then
        print *, "read factor";  call parse_node_write (pn)
     end if
     pn_value => parse_node_get_sub_ptr (pn)
     call eval_node_compile_signed_value (en, pn_value, var_list)
     pn_exponentiation => &
          parse_node_get_next_ptr (pn_value, tag="exponentiation")
     if (associated (pn_exponentiation)) then
        pn_op => parse_node_get_sub_ptr (pn_exponentiation)
        pn_arg => parse_node_get_next_ptr (pn_op)
        en1 => en
        call eval_node_compile_signed_value (en2, pn_arg, var_list)
        t1 = en1%result_type
        t2 = en2%result_type
        t = numeric_result_type (t1, t2)
        allocate (en)
        key = parse_node_get_key (pn_op)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);   call eval_node_init_int   (en, pow_ii (en1, en2))
              case (V_REAL);  call eval_node_init_real  (en, pow_ir (en1, en2))
              case (V_CMPLX); call eval_node_init_cmplx (en, pow_ic (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);   call eval_node_init_real  (en, pow_ri (en1, en2))
              case (V_REAL);  call eval_node_init_real  (en, pow_rr (en1, en2))
              case (V_CMPLX); call eval_node_init_cmplx (en, pow_rc (en1, en2))
              end select
           case (V_CMPLX)
              select case (t2)
              case (V_INT);   call eval_node_init_cmplx (en, pow_ci (en1, en2))
              case (V_REAL);  call eval_node_init_cmplx (en, pow_cr (en1, en2))
              case (V_CMPLX); call eval_node_init_cmplx (en, pow_cc (en1, en2))
              end select
           end select
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch (en, key, t, en1, en2)
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);   call eval_node_set_op2_int  (en, pow_ii)
              case (V_REAL,V_CMPLX);  call eval_type_error (pn, "exponentiation", t1)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);   call eval_node_set_op2_real (en, pow_ri)
              case (V_REAL);  call eval_node_set_op2_real (en, pow_rr)
              case (V_CMPLX);  call eval_type_error (pn, "exponentiation", t1)
              end select
           case (V_CMPLX)
              select case (t2)
              case (V_INT);   call eval_node_set_op2_cmplx (en, pow_ci)
              case (V_REAL);  call eval_node_set_op2_cmplx (en, pow_cr)
              case (V_CMPLX);  call eval_node_set_op2_cmplx (en, pow_cc)
              end select
           end select
        end if
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done factor"
     end if
   end subroutine eval_node_compile_factor
 
 @ %def eval_node_compile_factor
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_signed_value (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_arg
     type(eval_node_t), pointer :: en1
     integer :: t
     if (debug_active (D_MODEL_F)) then
        print *, "read signed value";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("signed_value")
        pn_arg => parse_node_get_sub_ptr (pn, 2)
        call eval_node_compile_value (en1, pn_arg, var_list)
        t = en1%result_type
        allocate (en)
        if (en1%type == EN_CONSTANT) then
           select case (t)
           case (V_INT);  call eval_node_init_int  (en, neg_i (en1))
           case (V_REAL); call eval_node_init_real (en, neg_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, neg_c (en1))
           end select
           call eval_node_final_rec (en1)
           deallocate (en1)
        else
           call eval_node_init_branch (en, var_str ("-"), t, en1)
           select case (t)
           case (V_INT);  call eval_node_set_op1_int  (en, neg_i)
           case (V_REAL); call eval_node_set_op1_real (en, neg_r)
           case (V_CMPLX); call eval_node_set_op1_cmplx (en, neg_c)
           end select
        end if
     case default
        call eval_node_compile_value (en, pn, var_list)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done signed value"
     end if
   end subroutine eval_node_compile_signed_value
 
 @ %def eval_node_compile_signed_value
 @ Integer, real and complex values have an optional unit.  The unit is
 extracted and applied immediately.  An integer with unit evaluates to
 a real constant.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_value (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     if (debug_active (D_MODEL_F)) then
        print *, "read value";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("integer_value", "real_value", "complex_value")
        call eval_node_compile_numeric_value (en, pn)
     case ("pi")
        call eval_node_compile_constant (en, pn)
     case ("I")
        call eval_node_compile_constant (en, pn)
     case ("variable")
        call eval_node_compile_variable (en, pn, var_list)
     case ("result")
        call eval_node_compile_result (en, pn, var_list)
     case ("user_observable")
        call eval_node_compile_user_observable (en, pn, var_list)
     case ("expr")
        call eval_node_compile_expr (en, pn, var_list)
     case ("block_expr")
        call eval_node_compile_block_expr (en, pn, var_list)
     case ("conditional_expr")
        call eval_node_compile_conditional (en, pn, var_list)
     case ("unary_function")
        call eval_node_compile_unary_function (en, pn, var_list)
     case ("binary_function")
        call eval_node_compile_binary_function (en, pn, var_list)
     case ("eval_fun")
        call eval_node_compile_eval_function (en, pn, var_list)
     case ("count_fun", "user_event_fun")
        call eval_node_compile_numeric_function (en, pn, var_list)
     case default
        call parse_node_mismatch &
             ("integer|real|complex|constant|variable|" // &
              "expr|block_expr|conditional_expr|" // &
              "unary_function|binary_function|numeric_pexpr", pn)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done value"
     end if
   end subroutine eval_node_compile_value
 
 @ %def eval_node_compile_value
 @ Real, complex and integer values are numeric literals with an
 optional unit attached.  In case of an integer, the unit actually
 makes it a real value in disguise.  The signed version of real values
 is not possible in generic expressions; it is a special case for
 numeric constants in model files (see below). We do not introduce
 signed versions of complex values.
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_numeric_value (en, pn)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(parse_node_t), pointer :: pn_val, pn_unit
     allocate (en)
     pn_val => parse_node_get_sub_ptr (pn)
     pn_unit => parse_node_get_next_ptr (pn_val)
     select case (char (parse_node_get_rule_key (pn)))
     case ("integer_value")
        if (associated (pn_unit)) then
           call eval_node_init_real (en, &
                parse_node_get_integer (pn_val) * parse_node_get_unit (pn_unit))
        else
           call eval_node_init_int (en, parse_node_get_integer (pn_val))
        end if
     case ("real_value")
        if (associated (pn_unit)) then
           call eval_node_init_real (en, &
                parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
        else
           call eval_node_init_real (en, parse_node_get_real (pn_val))
        end if
     case ("complex_value")
        if (associated (pn_unit)) then
           call eval_node_init_cmplx (en, &
                parse_node_get_cmplx (pn_val) * parse_node_get_unit (pn_unit))
        else
           call eval_node_init_cmplx (en, parse_node_get_cmplx (pn_val))
        end if
     case ("neg_real_value")
        pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2))
        pn_unit => parse_node_get_next_ptr (pn_val)
        if (associated (pn_unit)) then
           call eval_node_init_real (en, &
                - parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
        else
           call eval_node_init_real (en, - parse_node_get_real (pn_val))
        end if
     case ("pos_real_value")
        pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2))
        pn_unit => parse_node_get_next_ptr (pn_val)
        if (associated (pn_unit)) then
           call eval_node_init_real (en, &
                parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
        else
           call eval_node_init_real (en, parse_node_get_real (pn_val))
        end if
     case default
        call parse_node_mismatch &
        ("integer_value|real_value|complex_value|neg_real_value|pos_real_value", pn)
     end select
   end subroutine eval_node_compile_numeric_value
 
 @ %def eval_node_compile_numeric_value
 @ These are the units, predefined and hardcoded.  The default energy
 unit is GeV, the default angular unit is radians.  We include units
 for observables of dimension energy squared.  Luminosities are
 normalized in inverse femtobarns.
 <<Eval trees: procedures>>=
   function parse_node_get_unit (pn) result (factor)
     real(default) :: factor
     real(default) :: unit
     type(parse_node_t), intent(in) :: pn
     type(parse_node_t), pointer :: pn_unit, pn_unit_power
     type(parse_node_t), pointer :: pn_frac, pn_num, pn_int, pn_div, pn_den
     integer :: num, den
     pn_unit => parse_node_get_sub_ptr (pn)
     select case (char (parse_node_get_key (pn_unit)))
     case ("TeV");  unit = 1.e3_default
     case ("GeV");  unit = 1
     case ("MeV");  unit = 1.e-3_default
     case ("keV");  unit = 1.e-6_default
     case ("eV");   unit = 1.e-9_default
     case ("meV");   unit = 1.e-12_default
     case ("nbarn");  unit = 1.e6_default
     case ("pbarn");  unit = 1.e3_default
     case ("fbarn");  unit = 1
     case ("abarn");  unit = 1.e-3_default
     case ("rad");     unit = 1
     case ("mrad");    unit = 1.e-3_default
     case ("degree");  unit = degree
     case ("%");  unit = 1.e-2_default
     case default
        call msg_bug (" Unit '" // &
             char (parse_node_get_key (pn)) // "' is undefined.")
     end select
     pn_unit_power => parse_node_get_next_ptr (pn_unit)
     if (associated (pn_unit_power)) then
        pn_frac => parse_node_get_sub_ptr (pn_unit_power, 2)
        pn_num => parse_node_get_sub_ptr (pn_frac)
        select case (char (parse_node_get_rule_key (pn_num)))
        case ("neg_int")
           pn_int => parse_node_get_sub_ptr (pn_num, 2)
           num = - parse_node_get_integer (pn_int)
        case ("pos_int")
           pn_int => parse_node_get_sub_ptr (pn_num, 2)
           num = parse_node_get_integer (pn_int)
        case ("integer_literal")
           num = parse_node_get_integer (pn_num)
        case default
           call parse_node_mismatch ("neg_int|pos_int|integer_literal", pn_num)
        end select
        pn_div => parse_node_get_next_ptr (pn_num)
        if (associated (pn_div)) then
           pn_den => parse_node_get_sub_ptr (pn_div, 2)
           den = parse_node_get_integer (pn_den)
        else
           den = 1
        end if
     else
        num = 1
        den = 1
     end if
     factor = unit ** (real (num, default) / den)
   end function parse_node_get_unit
 
 @ %def parse_node_get_unit
 @ There are only two predefined constants, but more can be added easily.
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_constant (en, pn)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     if (debug_active (D_MODEL_F)) then
        print *, "read constant";  call parse_node_write (pn)
     end if
     allocate (en)
     select case (char (parse_node_get_key (pn)))
     case ("pi");     call eval_node_init_real (en, pi)
     case ("I");      call eval_node_init_cmplx (en, imago)
     case default
        call parse_node_mismatch ("pi or I", pn)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done constant"
     end if
   end subroutine eval_node_compile_constant
 
 @ %def eval_node_compile_constant
 @ Compile a variable, with or without a specified type.
 Take the list of variables, look for the name and make a node with a
 pointer to the value.  If no type is provided, the variable is
 numeric, and the stored value determines whether it is real or integer.
 
 We explicitly demand that the variable is defined, so we do not accidentally
 point to variables that are declared only later in the script but have come
 into existence in a previous compilation pass.
 
 Variables may actually be anonymous, these are expressions in disguise.  In
 that case, the expression replaces the variable name in the parse tree, and we
 allocate an ordinary expression node in the eval tree.
 
 Variables of type [[V_PDG]] (pdg-code array) are not treated here.
 They are handled by [[eval_node_compile_cvariable]].
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_variable (en, pn, var_list, var_type)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(in), optional :: var_type
     type(parse_node_t), pointer :: pn_name
     type(string_t) :: var_name
     logical, target, save :: no_lval
     real(default), target, save :: no_rval
     type(subevt_t), target, save :: no_pval
     type(string_t), target, save :: no_sval
     logical, target, save :: unknown = .false.
     integer :: type
     logical :: defined
     logical, pointer :: known
     logical, pointer :: lptr
     integer, pointer :: iptr
     real(default), pointer :: rptr
     complex(default), pointer :: cptr
     type(subevt_t), pointer :: pptr
     type(string_t), pointer :: sptr
     procedure(obs_unary_int), pointer :: obs1_iptr
     procedure(obs_unary_real), pointer :: obs1_rptr
     procedure(obs_binary_int), pointer :: obs2_iptr
     procedure(obs_binary_real), pointer :: obs2_rptr
     type(prt_t), pointer :: p1, p2
     if (debug_active (D_MODEL_F)) then
        print *, "read variable";  call parse_node_write (pn)
     end if
     if (present (var_type)) then
        select case (var_type)
        case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, &
                 V_OBS2_INT, V_CMPLX)
           pn_name => pn
        case default
           pn_name => parse_node_get_sub_ptr (pn, 2)
        end select
     else
        pn_name => pn
     end if
     select case (char (parse_node_get_rule_key (pn_name)))
     case ("expr")
        call eval_node_compile_expr (en, pn_name, var_list)
     case ("lexpr")
        call eval_node_compile_lexpr (en, pn_name, var_list)
     case ("sexpr")
        call eval_node_compile_sexpr (en, pn_name, var_list)
     case ("pexpr")
        call eval_node_compile_pexpr (en, pn_name, var_list)
     case ("variable")
        var_name = parse_node_get_string (pn_name)
        if (present (var_type)) then
           select case (var_type)
           case (V_LOG);  var_name = "?" // var_name
           case (V_SEV);  var_name = "@" // var_name
           case (V_STR);  var_name = "$" // var_name   ! $ sign
           end select
        end if
        call var_list%get_var_properties &
             (var_name, req_type=var_type, type=type, is_defined=defined)
        allocate (en)
        if (defined) then
           select case (type)
           case (V_LOG)
              call var_list%get_lptr (var_name, lptr, known)
              call eval_node_init_log_ptr (en, var_name, lptr, known)
           case (V_INT)
              call var_list%get_iptr (var_name, iptr, known)
              call eval_node_init_int_ptr (en, var_name, iptr, known)
           case (V_REAL)
              call var_list%get_rptr (var_name, rptr, known)
              call eval_node_init_real_ptr (en, var_name, rptr, known)
           case (V_CMPLX)
              call var_list%get_cptr (var_name, cptr, known)
              call eval_node_init_cmplx_ptr (en, var_name, cptr, known)
           case (V_SEV)
              call var_list%get_pptr (var_name, pptr, known)
              call eval_node_init_subevt_ptr (en, var_name, pptr, known)
           case (V_STR)
              call var_list%get_sptr (var_name, sptr, known)
              call eval_node_init_string_ptr (en, var_name, sptr, known)
           case (V_OBS1_INT)
              call var_list%get_obs1_iptr (var_name, obs1_iptr, p1)
              call eval_node_init_obs1_int_ptr (en, var_name, obs1_iptr, p1)
           case (V_OBS2_INT)
              call var_list%get_obs2_iptr (var_name, obs2_iptr, p1, p2)
              call eval_node_init_obs2_int_ptr (en, var_name, obs2_iptr, p1, p2)
           case (V_OBS1_REAL)
              call var_list%get_obs1_rptr (var_name, obs1_rptr, p1)
              call eval_node_init_obs1_real_ptr (en, var_name, obs1_rptr, p1)
           case (V_OBS2_REAL)
              call var_list%get_obs2_rptr (var_name, obs2_rptr, p1, p2)
              call eval_node_init_obs2_real_ptr (en, var_name, obs2_rptr, p1, p2)
           case default
              call parse_node_write (pn)
              call msg_fatal ("Variable of this type " // &
                   "is not allowed in the present context")
              if (present (var_type)) then
                 select case (var_type)
                 case (V_LOG)
                    call eval_node_init_log_ptr (en, var_name, no_lval, unknown)
                 case (V_SEV)
                    call eval_node_init_subevt_ptr &
                         (en, var_name, no_pval, unknown)
                 case (V_STR)
                    call eval_node_init_string_ptr &
                         (en, var_name, no_sval, unknown)
                 end select
              else
                 call eval_node_init_real_ptr (en, var_name, no_rval, unknown)
              end if
           end select
        else
           call parse_node_write (pn)
           call msg_error ("This variable is undefined at this point")
           if (present (var_type)) then
              select case (var_type)
              case (V_LOG)
                 call eval_node_init_log_ptr (en, var_name, no_lval, unknown)
              case (V_SEV)
                 call eval_node_init_subevt_ptr &
                      (en, var_name, no_pval, unknown)
              case (V_STR)
                 call eval_node_init_string_ptr (en, var_name, no_sval, unknown)
              end select
           else
              call eval_node_init_real_ptr (en, var_name, no_rval, unknown)
           end if
        end if
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done variable"
     end if
   end subroutine eval_node_compile_variable
 
 @ %def eval_node_compile_variable
 @ In a given context, a variable has to have a certain type.
 <<Eval trees: procedures>>=
   subroutine check_var_type (pn, ok, type_actual, type_requested)
     type(parse_node_t), intent(in) :: pn
     logical, intent(out) :: ok
     integer, intent(in) :: type_actual
     integer, intent(in), optional :: type_requested
     if (present (type_requested)) then
        select case (type_requested)
        case (V_LOG)
           select case (type_actual)
           case (V_LOG)
           case default
              call parse_node_write (pn)
              call msg_fatal ("Variable type is invalid (should be logical)")
              ok = .false.
           end select
        case (V_SEV)
           select case (type_actual)
           case (V_SEV)
           case default
              call parse_node_write (pn)
              call msg_fatal &
                   ("Variable type is invalid (should be particle set)")
              ok = .false.
           end select
        case (V_PDG)
           select case (type_actual)
           case (V_PDG)
           case default
              call parse_node_write (pn)
              call msg_fatal &
                   ("Variable type is invalid (should be PDG array)")
              ok = .false.
           end select
        case (V_STR)
           select case (type_actual)
           case (V_STR)
           case default
              call parse_node_write (pn)
              call msg_fatal &
                   ("Variable type is invalid (should be string)")
              ok = .false.
           end select
        case default
           call parse_node_write (pn)
           call msg_bug ("Variable type is unknown")
        end select
     else
        select case (type_actual)
        case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, &
                 V_OBS2_INT, V_CMPLX)
        case default
           call parse_node_write (pn)
           call msg_fatal ("Variable type is invalid (should be numeric)")
           ok = .false.
        end select
     end if
     ok = .true.
   end subroutine check_var_type
 
 @ %def check_var_type
 @ Retrieve the result of an integration.  If the requested process has
 been integrated, the results are available as special variables.  (The
 variables cannot be accessed in the usual way since they contain
 brackets in their names.)
 
 Since this compilation step may occur before the processes have been
 loaded, we have to initialize the required variables before they are
 used.
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_result (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_key, pn_prc_id
     type(string_t) :: key, prc_id, var_name
     integer, pointer :: iptr
     real(default), pointer :: rptr
     logical, pointer :: known
     if (debug_active (D_MODEL_F)) then
        print *, "read result";  call parse_node_write (pn)
     end if
     pn_key => parse_node_get_sub_ptr (pn)
     pn_prc_id => parse_node_get_next_ptr (pn_key)
     key = parse_node_get_key (pn_key)
     prc_id = parse_node_get_string (pn_prc_id)
     var_name = key // "(" // prc_id // ")"
     if (var_list%contains (var_name)) then
        allocate (en)
        select case (char(key))
        case ("num_id", "n_calls")
           call var_list%get_iptr (var_name, iptr, known)
           call eval_node_init_int_ptr (en, var_name, iptr, known)
        case ("integral", "error")
           call var_list%get_rptr (var_name, rptr, known)
           call eval_node_init_real_ptr (en, var_name, rptr, known)
        end select
     else
        call msg_fatal ("Result variable '" // char (var_name) &
             // "' is undefined (call 'integrate' before use)")
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done result"
     end if
   end subroutine eval_node_compile_result
 
 @ %def eval_node_compile_result
 @ This user observable behaves like a variable.  We link the node to
 the generic user-observable entry in the variable list.  The syntax
 element has an argument which provides the name of the user variable,
 this is stored as an eval-node alongside with the variable.  When the
 variable value is used, the user-supplied external function is called
 and provides the (real) result value.
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_user_observable (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_key, pn_arg, pn_obs
     type(eval_node_t), pointer :: en0
     integer :: res_type
     type(string_t) :: var_name
     integer :: type
     logical :: defined
     if (debug_active (D_MODEL_F)) then
        print *, "read user observable";  call parse_node_write (pn)
     end if
     pn_key => parse_node_get_sub_ptr (pn)
     select case (char (parse_node_get_key (pn_key)))
     case ("user_obs")
        res_type = V_REAL
     case default
        call parse_node_write (pn_key)
        call msg_bug ("user_observable: wrong keyword")
     end select
     pn_arg => parse_node_get_next_ptr (pn_key)
     pn_obs => parse_node_get_sub_ptr (pn_arg)
     call eval_node_compile_sexpr (en0, pn_obs, var_list)
     select case (res_type)
     case (V_INT);  var_name = "_User_obs_int"
     case (V_REAL); var_name = "_User_obs_real"
     end select
     call var_list%get_var_properties (var_name, type=type, is_defined=defined)
     allocate (en)
     if (defined) then
        select case (type)
        case (V_UOBS1_INT)
           call eval_node_init_uobs1_int (en, var_name, en0)
        case (V_UOBS2_INT)
           call eval_node_init_uobs2_int (en, var_name, en0)
        case (V_UOBS1_REAL)
           call eval_node_init_uobs1_real (en, var_name, en0)
        case (V_UOBS2_REAL)
           call eval_node_init_uobs2_real (en, var_name, en0)
        end select
     else
        call parse_node_write (pn)
        call msg_error ("This variable is undefined at this point")
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done user observable"
     end if
   end subroutine eval_node_compile_user_observable
 
 @ %def eval_node_compile_user_observable
 @ Functions with a single argument.  For non-constant arguments, watch
 for functions which convert their argument to a different type.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_unary_function (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_fname, pn_arg
     type(eval_node_t), pointer :: en1
     type(string_t) :: key
     integer :: t
     if (debug_active (D_MODEL_F)) then
        print *, "read unary function";  call parse_node_write (pn)
     end if
     pn_fname => parse_node_get_sub_ptr (pn)
     pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg1")
     call eval_node_compile_expr &
          (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list)
     t = en1%result_type
     allocate (en)
     key = parse_node_get_key (pn_fname)
     if (en1%type == EN_CONSTANT) then
        select case (char (key))
        case ("complex")
           select case (t)
           case (V_INT);  call eval_node_init_cmplx (en, cmplx_i (en1))
           case (V_REAL); call eval_node_init_cmplx (en, cmplx_r (en1))
           case (V_CMPLX); deallocate (en);  en => en1;  en1 => null ()
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("real")
           select case (t)
           case (V_INT);  call eval_node_init_real (en, real_i (en1))
           case (V_REAL); deallocate (en);  en => en1;  en1 => null ()
           case (V_CMPLX); call eval_node_init_real (en, real_c (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("int")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1;  en1 => null ()
           case (V_REAL); call eval_node_init_int  (en, int_r (en1))
           case (V_CMPLX); call eval_node_init_int  (en, int_c (en1))
           end select
        case ("nint")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1;  en1 => null ()
           case (V_REAL); call eval_node_init_int  (en, nint_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("floor")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1;  en1 => null ()
           case (V_REAL); call eval_node_init_int  (en, floor_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("ceiling")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1;  en1 => null ()
           case (V_REAL); call eval_node_init_int  (en, ceiling_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("abs")
           select case (t)
           case (V_INT);  call eval_node_init_int  (en, abs_i (en1))
           case (V_REAL); call eval_node_init_real (en, abs_r (en1))
           case (V_CMPLX); call eval_node_init_real (en, abs_c (en1))
           end select
        case ("conjg")
           select case (t)
           case (V_INT);  call eval_node_init_int  (en, conjg_i (en1))
           case (V_REAL); call eval_node_init_real (en, conjg_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, conjg_c (en1))
           end select
        case ("sgn")
           select case (t)
           case (V_INT);  call eval_node_init_int  (en, sgn_i (en1))
           case (V_REAL); call eval_node_init_real (en, sgn_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("sqrt")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, sqrt_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, sqrt_c (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("exp")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, exp_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, exp_c (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("log")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, log_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, log_c (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("log10")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, log10_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("sin")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, sin_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, sin_c (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("cos")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, cos_r (en1))
           case (V_CMPLX); call eval_node_init_cmplx (en, cos_c (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("tan")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, tan_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("asin")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, asin_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("acos")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, acos_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("atan")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, atan_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("sinh")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, sinh_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("cosh")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, cosh_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("tanh")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, tanh_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("asinh")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, asinh_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("acosh")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, acosh_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("atanh")
           select case (t)
           case (V_REAL); call eval_node_init_real (en, atanh_r (en1))
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case default
           call parse_node_mismatch ("function name", pn_fname)
        end select
        if (associated (en1)) then
           call eval_node_final_rec (en1)
           deallocate (en1)
        end if
     else
        select case (char (key))
        case ("complex")
           call eval_node_init_branch (en, key, V_CMPLX, en1)
        case ("real")
           call eval_node_init_branch (en, key, V_REAL, en1)
        case ("int", "nint", "floor", "ceiling")
           call eval_node_init_branch (en, key, V_INT, en1)
        case default
           call eval_node_init_branch (en, key, t, en1)
        end select
        select case (char (key))
        case ("complex")
           select case (t)
           case (V_INT);  call eval_node_set_op1_cmplx (en, cmplx_i)
           case (V_REAL); call eval_node_set_op1_cmplx (en, cmplx_r)
           case (V_CMPLX); deallocate (en);  en => en1
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("real")
           select case (t)
           case (V_INT);  call eval_node_set_op1_real (en, real_i)
           case (V_REAL); deallocate (en);  en => en1
           case (V_CMPLX); call eval_node_set_op1_real (en, real_c)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("int")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1
           case (V_REAL); call eval_node_set_op1_int (en, int_r)
           case (V_CMPLX); call eval_node_set_op1_int (en, int_c)
           end select
        case ("nint")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1
           case (V_REAL); call eval_node_set_op1_int (en, nint_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("floor")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1
           case (V_REAL); call eval_node_set_op1_int (en, floor_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("ceiling")
           select case (t)
           case (V_INT);  deallocate (en);  en => en1
           case (V_REAL); call eval_node_set_op1_int (en, ceiling_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("abs")
           select case (t)
           case (V_INT);  call eval_node_set_op1_int  (en, abs_i)
           case (V_REAL); call eval_node_set_op1_real (en, abs_r)
           case (V_CMPLX);
              call eval_node_init_branch (en, key, V_REAL, en1)
              call eval_node_set_op1_real (en, abs_c)
           end select
        case ("conjg")
           select case (t)
           case (V_INT);  call eval_node_set_op1_int  (en, conjg_i)
           case (V_REAL); call eval_node_set_op1_real (en, conjg_r)
           case (V_CMPLX);  call eval_node_set_op1_cmplx (en, conjg_c)
           end select
        case ("sgn")
           select case (t)
           case (V_INT);  call eval_node_set_op1_int  (en, sgn_i)
           case (V_REAL); call eval_node_set_op1_real (en, sgn_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("sqrt")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, sqrt_r)
           case (V_CMPLX); call eval_node_set_op1_cmplx (en, sqrt_c)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("exp")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, exp_r)
           case (V_CMPLX); call eval_node_set_op1_cmplx (en, exp_c)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("log")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, log_r)
           case (V_CMPLX); call eval_node_set_op1_cmplx (en, log_c)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("log10")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, log10_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("sin")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, sin_r)
           case (V_CMPLX); call eval_node_set_op1_cmplx (en, sin_c)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("cos")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, cos_r)
           case (V_CMPLX); call eval_node_set_op1_cmplx (en, cos_c)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("tan")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, tan_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("asin")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, asin_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("acos")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, acos_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("atan")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, atan_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("sinh")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, sinh_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("cosh")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, cosh_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("tanh")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, tanh_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("asinh")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, asinh_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("acosh")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, acosh_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case ("atanh")
           select case (t)
           case (V_REAL); call eval_node_set_op1_real (en, atanh_r)
           case default;  call eval_type_error (pn, char (key), t)
           end select
        case default
           call parse_node_mismatch ("function name", pn_fname)
        end select
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done function"
     end if
   end subroutine eval_node_compile_unary_function
 
 @ %def eval_node_compile_unary_function
 @ Functions with two arguments.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_binary_function (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_fname, pn_arg, pn_arg1, pn_arg2
     type(eval_node_t), pointer :: en1, en2
     type(string_t) :: key
     integer :: t1, t2
     if (debug_active (D_MODEL_F)) then
        print *, "read binary function";  call parse_node_write (pn)
     end if
     pn_fname => parse_node_get_sub_ptr (pn)
     pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg2")
     pn_arg1 => parse_node_get_sub_ptr (pn_arg, tag="expr")
     pn_arg2 => parse_node_get_next_ptr (pn_arg1, tag="expr")
     call eval_node_compile_expr (en1, pn_arg1, var_list)
     call eval_node_compile_expr (en2, pn_arg2, var_list)
     t1 = en1%result_type
     t2 = en2%result_type
     allocate (en)
     key = parse_node_get_key (pn_fname)
     if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
        select case (char (key))
        case ("max")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_int  (en, max_ii (en1, en2))
              case (V_REAL); call eval_node_init_real (en, max_ir (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_real (en, max_ri (en1, en2))
              case (V_REAL); call eval_node_init_real (en, max_rr (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t1)
          end select
        case ("min")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_int  (en, min_ii (en1, en2))
              case (V_REAL); call eval_node_init_real (en, min_ir (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_real (en, min_ri (en1, en2))
              case (V_REAL); call eval_node_init_real (en, min_rr (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t1)
          end select
        case ("mod")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_int  (en, mod_ii (en1, en2))
              case (V_REAL); call eval_node_init_real (en, mod_ir (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_real (en, mod_ri (en1, en2))
              case (V_REAL); call eval_node_init_real (en, mod_rr (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t1)
           end select
        case ("modulo")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_int  (en, modulo_ii (en1, en2))
              case (V_REAL); call eval_node_init_real (en, modulo_ir (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_real (en, modulo_ri (en1, en2))
              case (V_REAL); call eval_node_init_real (en, modulo_rr (en1, en2))
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t2)
          end select
        case default
           call parse_node_mismatch ("function name", pn_fname)
        end select
        call eval_node_final_rec (en1)
        deallocate (en1)
     else
        call eval_node_init_branch (en, key, t1, en1, en2)
        select case (char (key))
        case ("max")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_int  (en, max_ii)
              case (V_REAL); call eval_node_set_op2_real (en, max_ir)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_real (en, max_ri)
              case (V_REAL); call eval_node_set_op2_real (en, max_rr)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t2)
          end select
        case ("min")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_int  (en, min_ii)
              case (V_REAL); call eval_node_set_op2_real (en, min_ir)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_real (en, min_ri)
              case (V_REAL); call eval_node_set_op2_real (en, min_rr)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t2)
          end select
        case ("mod")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_int  (en, mod_ii)
              case (V_REAL); call eval_node_set_op2_real (en, mod_ir)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_real (en, mod_ri)
              case (V_REAL); call eval_node_set_op2_real (en, mod_rr)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t2)
         end select
        case ("modulo")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_int  (en, modulo_ii)
              case (V_REAL); call eval_node_set_op2_real (en, modulo_ir)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_real (en, modulo_ri)
              case (V_REAL); call eval_node_set_op2_real (en, modulo_rr)
              case default;  call eval_type_error (pn, char (key), t2)
              end select
            case default;  call eval_type_error (pn, char (key), t2)
          end select
        case default
           call parse_node_mismatch ("function name", pn_fname)
        end select
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done function"
     end if
   end subroutine eval_node_compile_binary_function
 
 @ %def eval_node_compile_binary_function
 @
 \subsubsection{Variable definition}
 A block expression contains a variable definition (first argument) and
 an expression where the definition can be used (second argument).  The
 [[result_type]] decides which type of expression is expected for the
 second argument.  For numeric variables, if there is a mismatch
 between real and integer type, insert an extra node for type
 conversion.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_block_expr &
        (en, pn, var_list, result_type)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(in), optional :: result_type
     type(parse_node_t), pointer :: pn_var_spec, pn_var_subspec
     type(parse_node_t), pointer :: pn_var_type, pn_var_name, pn_var_expr
     type(parse_node_t), pointer :: pn_expr
     type(string_t) :: var_name
     type(eval_node_t), pointer :: en1, en2
     integer :: var_type
     logical :: new
     if (debug_active (D_MODEL_F)) then
        print *, "read block expr";  call parse_node_write (pn)
     end if
     new = .false.
     pn_var_spec => parse_node_get_sub_ptr (pn, 2)
     select case (char (parse_node_get_rule_key (pn_var_spec)))
     case ("var_num");      var_type = V_NONE
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec)
     case ("var_int");      var_type = V_INT
        new = .true.
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case ("var_real");     var_type = V_REAL
        new = .true.
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case ("var_cmplx");     var_type = V_CMPLX
        new = .true.
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case ("var_logical_new");  var_type = V_LOG
        new = .true.
        pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
        pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
     case ("var_logical_spec");  var_type = V_LOG
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case ("var_plist_new");    var_type = V_SEV
        new = .true.
        pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
        pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
     case ("var_plist_spec");    var_type = V_SEV
        new = .true.
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case ("var_alias");    var_type = V_PDG
        new = .true.
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case ("var_string_new");   var_type = V_STR
        new = .true.
        pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
        pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
     case ("var_string_spec");   var_type = V_STR
        pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
     case default
        call parse_node_mismatch &
             ("logical|int|real|plist|alias", pn_var_type)
     end select
     pn_var_expr => parse_node_get_next_ptr (pn_var_name, 2)
     pn_expr => parse_node_get_next_ptr (pn_var_spec, 2)
     var_name = parse_node_get_string (pn_var_name)
     select case (var_type)
     case (V_LOG);  var_name = "?" // var_name
     case (V_SEV);  var_name = "@" // var_name
     case (V_STR);  var_name = "$" // var_name    ! $ sign
     end select
     call var_list_check_user_var (var_list, var_name, var_type, new)
     call eval_node_compile_genexpr (en1, pn_var_expr, var_list, var_type)
     call insert_conversion_node (en1, var_type)
     allocate (en)
     call eval_node_init_block (en, var_name, var_type, en1, var_list)
     call eval_node_compile_genexpr (en2, pn_expr, en%var_list, result_type)
     call eval_node_set_expr (en, en2)
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done block expr"
     end if
   end subroutine eval_node_compile_block_expr
 
 @ %def eval_node_compile_block_expr
 @ Insert a conversion node for integer/real/complex transformation if necessary.
 What shall we do for the complex to integer/real conversion?
 <<Eval trees: procedures>>=
   subroutine insert_conversion_node (en, result_type)
     type(eval_node_t), pointer :: en
     integer, intent(in) :: result_type
     type(eval_node_t), pointer :: en_conv
     select case (en%result_type)
     case (V_INT)
        select case (result_type)
        case (V_REAL)
           allocate (en_conv)
           call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en)
           call eval_node_set_op1_real (en_conv, real_i)
           en => en_conv
        case (V_CMPLX)
           allocate (en_conv)
           call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en)
           call eval_node_set_op1_cmplx (en_conv, cmplx_i)
           en => en_conv
        end select
     case (V_REAL)
        select case (result_type)
        case (V_INT)
           allocate (en_conv)
           call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en)
           call eval_node_set_op1_int (en_conv, int_r)
           en => en_conv
        case (V_CMPLX)
           allocate (en_conv)
           call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en)
           call eval_node_set_op1_cmplx (en_conv, cmplx_r)
           en => en_conv
        end select
     case (V_CMPLX)
        select case (result_type)
        case (V_INT)
           allocate (en_conv)
           call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en)
           call eval_node_set_op1_int (en_conv, int_c)
           en => en_conv
        case (V_REAL)
           allocate (en_conv)
           call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en)
           call eval_node_set_op1_real (en_conv, real_c)
           en => en_conv
        end select
      case default
      end select
   end subroutine insert_conversion_node
 
 @ %def insert_conversion_node
 @
 \subsubsection{Conditionals}
 A conditional has the structure if lexpr then expr else expr.  So we
 first evaluate the logical expression, then depending on the result
 the first or second expression.  Note that the second expression is
 mandatory.
 
 The [[result_type]], if present, defines the requested type of the
 [[then]] and [[else]] clauses.  Default is numeric (int/real).  If
 there is a mismatch between real and integer result types, insert
 conversion nodes.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_conditional &
        (en, pn, var_list, result_type)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(in), optional :: result_type
     type(parse_node_t), pointer :: pn_condition, pn_expr
     type(parse_node_t), pointer :: pn_maybe_elsif, pn_elsif_branch
     type(parse_node_t), pointer :: pn_maybe_else, pn_else_branch, pn_else_expr
     type(eval_node_t), pointer :: en0, en1, en2
     integer :: restype
     if (debug_active (D_MODEL_F)) then
        print *, "read conditional";  call parse_node_write (pn)
     end if
     pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr")
     pn_expr => parse_node_get_next_ptr (pn_condition, 2)
     call eval_node_compile_lexpr (en0, pn_condition, var_list)
     call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type)
     if (present (result_type)) then
        restype = major_result_type (result_type, en1%result_type)
     else
        restype = en1%result_type
     end if
     pn_maybe_elsif => parse_node_get_next_ptr (pn_expr)
     select case (char (parse_node_get_rule_key (pn_maybe_elsif)))
     case ("maybe_elsif_expr", &
           "maybe_elsif_lexpr", &
           "maybe_elsif_pexpr", &
           "maybe_elsif_cexpr", &
           "maybe_elsif_sexpr")
        pn_elsif_branch => parse_node_get_sub_ptr (pn_maybe_elsif)
        pn_maybe_else => parse_node_get_next_ptr (pn_maybe_elsif)
        select case (char (parse_node_get_rule_key (pn_maybe_else)))
        case ("maybe_else_expr", &
           "maybe_else_lexpr", &
           "maybe_else_pexpr", &
           "maybe_else_cexpr", &
           "maybe_else_sexpr")
           pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else)
           pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2)
        case default
           pn_else_expr => null ()
        end select
        call eval_node_compile_elsif &
             (en2, pn_elsif_branch, pn_else_expr, var_list, restype)
     case ("maybe_else_expr", &
           "maybe_else_lexpr", &
           "maybe_else_pexpr", &
           "maybe_else_cexpr", &
           "maybe_else_sexpr")
        pn_maybe_else => pn_maybe_elsif
        pn_maybe_elsif => null ()
        pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else)
        pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2)
        call eval_node_compile_genexpr &
             (en2, pn_else_expr, var_list, restype)
     case ("endif")
        call eval_node_compile_default_else (en2, restype)
     case default
        call msg_bug ("Broken conditional: unexpected " &
             // char (parse_node_get_rule_key (pn_maybe_elsif)))
     end select
     call eval_node_create_conditional (en, en0, en1, en2, restype)
     call conditional_insert_conversion_nodes (en, restype)
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done conditional"
     end if
   end subroutine eval_node_compile_conditional
 
 @ %def eval_node_compile_conditional
 @ This recursively generates 'elsif' conditionals as a chain of sub-nodes of
 the main conditional.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_elsif &
        (en, pn, pn_else_expr, var_list, result_type)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(parse_node_t), pointer :: pn_else_expr
     type(var_list_t), intent(in), target :: var_list
     integer, intent(inout) :: result_type
     type(parse_node_t), pointer :: pn_next, pn_condition, pn_expr
     type(eval_node_t), pointer :: en0, en1, en2
     pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr")
     pn_expr => parse_node_get_next_ptr (pn_condition, 2)
     call eval_node_compile_lexpr (en0, pn_condition, var_list)
     call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type)
     result_type = major_result_type (result_type, en1%result_type)
     pn_next => parse_node_get_next_ptr (pn)
     if (associated (pn_next)) then
        call eval_node_compile_elsif &
             (en2, pn_next, pn_else_expr, var_list, result_type)
        result_type = major_result_type (result_type, en2%result_type)
     else if (associated (pn_else_expr)) then
        call eval_node_compile_genexpr &
             (en2, pn_else_expr, var_list, result_type)
        result_type = major_result_type (result_type, en2%result_type)
     else
        call eval_node_compile_default_else (en2, result_type)
     end if
     call eval_node_create_conditional (en, en0, en1, en2, result_type)
   end subroutine eval_node_compile_elsif
 
 @ %def eval_node_compile_elsif
 @ This makes a default 'else' branch in case it was omitted.  The default value
 just depends on the expected type.
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_default_else (en, result_type)
     type(eval_node_t), pointer :: en
     integer, intent(in) :: result_type
     type(subevt_t) :: pval_empty
     type(pdg_array_t) :: aval_undefined
     allocate (en)
     select case (result_type)
     case (V_LOG);  call eval_node_init_log (en, .false.)
     case (V_INT);  call eval_node_init_int (en, 0)
     case (V_REAL);  call eval_node_init_real (en, 0._default)
     case (V_CMPLX)
          call eval_node_init_cmplx (en, (0._default, 0._default))
     case (V_SEV)
        call subevt_init (pval_empty)
        call eval_node_init_subevt (en, pval_empty)
     case (V_PDG)
        call eval_node_init_pdg_array  (en, aval_undefined)
     case (V_STR)
        call eval_node_init_string (en, var_str (""))
     case default
        call msg_bug ("Undefined type for 'else' branch in conditional")
     end select
   end subroutine eval_node_compile_default_else
 
 @ %def eval_node_compile_default_else
 @ If the logical expression is constant, we can simplify the conditional node
 by replacing it with the selected branch.  Otherwise, we initialize a true
 branching.
 <<Eval trees: procedures>>=
   subroutine eval_node_create_conditional (en, en0, en1, en2, result_type)
     type(eval_node_t), pointer :: en, en0, en1, en2
     integer, intent(in) :: result_type
     if (en0%type == EN_CONSTANT) then
        if (en0%lval) then
           en => en1
           call eval_node_final_rec (en2)
           deallocate (en2)
        else
           en => en2
           call eval_node_final_rec (en1)
           deallocate (en1)
        end if
     else
        allocate (en)
        call eval_node_init_conditional (en, result_type, en0, en1, en2)
     end if
   end subroutine eval_node_create_conditional
 
 @ %def eval_node_create_conditional
 @ Return the numerical result type which should be used for the combination of
 the two result types.
 <<Eval trees: procedures>>=
   function major_result_type (t1, t2) result (t)
     integer :: t
     integer, intent(in) :: t1, t2
     select case (t1)
     case (V_INT)
        select case (t2)
        case (V_INT, V_REAL, V_CMPLX)
           t = t2
        case default
           call type_mismatch ()
        end select
     case (V_REAL)
        select case (t2)
        case (V_INT)
           t = t1
        case (V_REAL, V_CMPLX)
           t = t2
        case default
           call type_mismatch ()
        end select
     case (V_CMPLX)
        select case (t2)
        case (V_INT, V_REAL, V_CMPLX)
           t = t1
        case default
           call type_mismatch ()
        end select
     case default
        if (t1 == t2) then
           t = t1
        else
           call type_mismatch ()
        end if
     end select
   contains
     subroutine type_mismatch ()
       call msg_bug ("Type mismatch in branches of a conditional expression")
     end subroutine type_mismatch
   end function major_result_type
 
 @ %def major_result_type
 @ Recursively insert conversion nodes where necessary.
 <<Eval trees: procedures>>=
   recursive subroutine conditional_insert_conversion_nodes (en, result_type)
     type(eval_node_t), intent(inout), target :: en
     integer, intent(in) :: result_type
     select case (result_type)
     case (V_INT, V_REAL, V_CMPLX)
        call insert_conversion_node (en%arg1, result_type)
        if (en%arg2%type == EN_CONDITIONAL) then
           call conditional_insert_conversion_nodes (en%arg2, result_type)
        else
           call insert_conversion_node (en%arg2, result_type)
        end if
     end select
   end subroutine conditional_insert_conversion_nodes
 
 @ %def conditional_insert_conversion_nodes
 @
 \subsubsection{Logical expressions}
 A logical expression consists of one or more singlet logical expressions
 concatenated by [[;]].  This is for allowing side-effects, only the last value
 is used.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_lexpr (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_term, pn_sequel, pn_arg
     type(eval_node_t), pointer :: en1, en2
     if (debug_active (D_MODEL_F)) then
        print *, "read lexpr";  call parse_node_write (pn)
     end if
     pn_term => parse_node_get_sub_ptr (pn, tag="lsinglet")
     call eval_node_compile_lsinglet (en, pn_term, var_list)
     pn_sequel => parse_node_get_next_ptr (pn_term, tag="lsequel")
     do while (associated (pn_sequel))
        pn_arg => parse_node_get_sub_ptr (pn_sequel, 2, tag="lsinglet")
        en1 => en
        call eval_node_compile_lsinglet (en2, pn_arg, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call eval_node_init_log (en, ignore_first_ll (en1, en2))
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch &
                (en, var_str ("lsequel"), V_LOG, en1, en2)
           call eval_node_set_op2_log (en, ignore_first_ll)
        end if
        pn_sequel => parse_node_get_next_ptr (pn_sequel)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done lexpr"
     end if
   end subroutine eval_node_compile_lexpr
 
 @ %def eval_node_compile_lexpr
 @ A logical singlet expression consists of one or more logical terms
 concatenated by [[or]].
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_lsinglet (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_term, pn_alternative, pn_arg
     type(eval_node_t), pointer :: en1, en2
     if (debug_active (D_MODEL_F)) then
        print *, "read lsinglet";  call parse_node_write (pn)
     end if
     pn_term => parse_node_get_sub_ptr (pn, tag="lterm")
     call eval_node_compile_lterm (en, pn_term, var_list)
     pn_alternative => parse_node_get_next_ptr (pn_term, tag="alternative")
     do while (associated (pn_alternative))
        pn_arg => parse_node_get_sub_ptr (pn_alternative, 2, tag="lterm")
        en1 => en
        call eval_node_compile_lterm (en2, pn_arg, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call eval_node_init_log (en, or_ll (en1, en2))
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch &
                (en, var_str ("alternative"), V_LOG, en1, en2)
           call eval_node_set_op2_log (en, or_ll)
        end if
        pn_alternative => parse_node_get_next_ptr (pn_alternative)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done lsinglet"
     end if
   end subroutine eval_node_compile_lsinglet
 
 @ %def eval_node_compile_lsinglet
 @ A logical term consists of one or more logical values
 concatenated by [[and]].
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_lterm (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_term, pn_coincidence, pn_arg
     type(eval_node_t), pointer :: en1, en2
     if (debug_active (D_MODEL_F)) then
        print *, "read lterm";  call parse_node_write (pn)
     end if
     pn_term => parse_node_get_sub_ptr (pn)
     call eval_node_compile_lvalue (en, pn_term, var_list)
     pn_coincidence => parse_node_get_next_ptr (pn_term, tag="coincidence")
     do while (associated (pn_coincidence))
        pn_arg => parse_node_get_sub_ptr (pn_coincidence, 2)
        en1 => en
        call eval_node_compile_lvalue (en2, pn_arg, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call eval_node_init_log (en, and_ll (en1, en2))
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch &
                (en, var_str ("coincidence"), V_LOG, en1, en2)
           call eval_node_set_op2_log (en, and_ll)
        end if
        pn_coincidence => parse_node_get_next_ptr (pn_coincidence)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done lterm"
     end if
   end subroutine eval_node_compile_lterm
 
 @ %def eval_node_compile_lterm
 @ Logical variables are disabled, because they are confused with the
 l.h.s.\ of compared expressions.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_lvalue (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     if (debug_active (D_MODEL_F)) then
        print *, "read lvalue";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("true")
        allocate (en)
        call eval_node_init_log (en, .true.)
     case ("false")
        allocate (en)
        call eval_node_init_log (en, .false.)
     case ("negation")
        call eval_node_compile_negation (en, pn, var_list)
     case ("lvariable")
        call eval_node_compile_variable (en, pn, var_list, V_LOG)
     case ("lexpr")
        call eval_node_compile_lexpr (en, pn, var_list)
     case ("block_lexpr")
        call eval_node_compile_block_expr (en, pn, var_list, V_LOG)
     case ("conditional_lexpr")
        call eval_node_compile_conditional (en, pn, var_list, V_LOG)
     case ("compared_expr")
        call eval_node_compile_compared_expr (en, pn, var_list, V_REAL)
     case ("compared_sexpr")
        call eval_node_compile_compared_expr (en, pn, var_list, V_STR)
     case ("all_fun", "any_fun", "no_fun", "user_cut_fun", &
           "photon_isolation_fun")
        call eval_node_compile_log_function (en, pn, var_list)
     case ("record_cmd")
        call eval_node_compile_record_cmd (en, pn, var_list)
     case default
        call parse_node_mismatch &
             ("true|false|negation|lvariable|" // &
              "lexpr|block_lexpr|conditional_lexpr|" // &
              "compared_expr|compared_sexpr|logical_pexpr", pn)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done lvalue"
     end if
   end subroutine eval_node_compile_lvalue
 
 @ %def eval_node_compile_lvalue
 @ A negation consists of the keyword [[not]] and a logical value.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_negation (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_arg
     type(eval_node_t), pointer :: en1
     if (debug_active (D_MODEL_F)) then
        print *, "read negation";  call parse_node_write (pn)
     end if
     pn_arg => parse_node_get_sub_ptr (pn, 2)
     call eval_node_compile_lvalue (en1, pn_arg, var_list)
     allocate (en)
     if (en1%type == EN_CONSTANT) then
        call eval_node_init_log (en, not_l (en1))
        call eval_node_final_rec (en1)
        deallocate (en1)
     else
        call eval_node_init_branch (en, var_str ("not"), V_LOG, en1)
        call eval_node_set_op1_log (en, not_l)
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done negation"
     end if
   end subroutine eval_node_compile_negation
 
 @ %def eval_node_compile_negation
 @
 \subsubsection{Comparisons}
 Up to the loop, this is easy.  There is always at least one
 comparison.  This is evaluated, and the result is the logical node
 [[en]].  If it is constant, we keep its second sub-node as [[en2]].
 (Thus, at the very end [[en2]] has to be deleted if [[en]] is (still)
 constant.)
 
 If there is another comparison, we first check if the first comparison
 was constant.  In that case, there are two possibilities: (i) it was
 true.  Then, its right-hand side is compared with the new right-hand
 side, and the result replaces the previous one which is deleted.  (ii)
 it was false.  In this case, the result of the whole comparison is
 false, and we can exit the loop without evaluating anything else.
 
 Now assume that the first comparison results in a valid branch, its
 second sub-node kept as [[en2]].  We first need a copy of this, which
 becomes the new left-hand side.  If [[en2]] is constant, we make an
 identical constant node [[en1]].  Otherwise, we make [[en1]] an
 appropriate pointer node.  Next, the first branch is saved as [[en0]]
 and we evaluate the comparison between [[en1]] and the a right-hand
 side.  If this turns out to be constant, there are again two
 possibilities: (i) true, then we revert to the previous result.  (ii)
 false, then the wh
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_compared_expr (en, pn, var_list, type)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(in) :: type
     type(parse_node_t), pointer :: pn_comparison, pn_expr1
     type(eval_node_t), pointer :: en0, en1, en2
     if (debug_active (D_MODEL_F)) then
        print *, "read comparison";  call parse_node_write (pn)
     end if
     select case (type)
     case (V_INT, V_REAL)
        pn_expr1 => parse_node_get_sub_ptr (pn, tag="expr")
        call eval_node_compile_expr (en1, pn_expr1, var_list)
        pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="comparison")
     case (V_STR)
        pn_expr1 => parse_node_get_sub_ptr (pn, tag="sexpr")
        call eval_node_compile_sexpr (en1, pn_expr1, var_list)
        pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="str_comparison")
     end select
     call eval_node_compile_comparison &
          (en, en1, en2, pn_comparison, var_list, type)
     pn_comparison => parse_node_get_next_ptr (pn_comparison)
     SCAN_FURTHER: do while (associated (pn_comparison))
        if (en%type == EN_CONSTANT) then
           if (en%lval) then
              en1 => en2
              call eval_node_final_rec (en);  deallocate (en)
              call eval_node_compile_comparison &
                   (en, en1, en2, pn_comparison, var_list, type)
           else
              exit SCAN_FURTHER
           end if
        else
           allocate (en1)
           if (en2%type == EN_CONSTANT) then
              select case (en2%result_type)
              case (V_INT);  call eval_node_init_int    (en1, en2%ival)
              case (V_REAL); call eval_node_init_real   (en1, en2%rval)
              case (V_STR);  call eval_node_init_string (en1, en2%sval)
              end select
           else
              select case (en2%result_type)
              case (V_INT);  call eval_node_init_int_ptr &
                   (en1, var_str ("(previous)"), en2%ival, en2%value_is_known)
              case (V_REAL); call eval_node_init_real_ptr &
                   (en1, var_str ("(previous)"), en2%rval, en2%value_is_known)
              case (V_STR);  call eval_node_init_string_ptr &
                   (en1, var_str ("(previous)"), en2%sval, en2%value_is_known)
              end select
           end if
           en0 => en
           call eval_node_compile_comparison &
                (en, en1, en2, pn_comparison, var_list, type)
           if (en%type == EN_CONSTANT) then
              if (en%lval) then
                 call eval_node_final_rec (en);  deallocate (en)
                 en => en0
              else
                 call eval_node_final_rec (en0);  deallocate (en0)
                 exit SCAN_FURTHER
              end if
           else
              en1 => en
              allocate (en)
              call eval_node_init_branch (en, var_str ("and"), V_LOG, en0, en1)
              call eval_node_set_op2_log (en, and_ll)
           end if
        end if
        pn_comparison => parse_node_get_next_ptr (pn_comparison)
     end do SCAN_FURTHER
     if (en%type == EN_CONSTANT .and. associated (en2)) then
        call eval_node_final_rec (en2);  deallocate (en2)
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done compared_expr"
     end if
   end subroutine eval_node_compile_compared_expr
 
 @ %dev eval_node_compile_compared_expr
 @ This takes two extra arguments: [[en1]], the left-hand-side of the
 comparison, is already allocated and evaluated.  [[en2]] (the
 right-hand side) and [[en]] (the result) are allocated by the
 routine.  [[pn]] is the parse node which contains the operator and the
 right-hand side as subnodes.
 
 If the result of the comparison is constant, [[en1]] is deleted but
 [[en2]] is kept, because it may be used in a subsequent comparison.
 [[en]] then becomes a constant.  If the result is variable, [[en]]
 becomes a branch node which refers to [[en1]] and [[en2]].
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_comparison &
        (en, en1, en2, pn, var_list, type)
     type(eval_node_t), pointer :: en, en1, en2
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(in) :: type
     type(parse_node_t), pointer :: pn_op, pn_arg
     type(string_t) :: key
     integer :: t1, t2
     real(default), pointer :: tolerance_ptr
     pn_op => parse_node_get_sub_ptr (pn)
     key = parse_node_get_key (pn_op)
     select case (type)
     case (V_INT, V_REAL)
        pn_arg => parse_node_get_next_ptr (pn_op, tag="expr")
        call eval_node_compile_expr (en2, pn_arg, var_list)
     case (V_STR)
        pn_arg => parse_node_get_next_ptr (pn_op, tag="sexpr")
        call eval_node_compile_sexpr (en2, pn_arg, var_list)
     end select
     t1 = en1%result_type
     t2 = en2%result_type
     allocate (en)
     if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
        call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr)
        en1%tolerance => tolerance_ptr
        select case (char (key))
        case ("<")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_lt_ii (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_ll_ir (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_ll_ri (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_ll_rr (en1, en2))
              end select
           end select
        case (">")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_gt_ii (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_gg_ir (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_gg_ri (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_gg_rr (en1, en2))
              end select
           end select
        case ("<=")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_le_ii (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_ls_ir (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_ls_ri (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_ls_rr (en1, en2))
              end select
           end select
        case (">=")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_ge_ii (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_gs_ir (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_gs_ri (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_gs_rr (en1, en2))
              end select
           end select
        case ("==")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_eq_ii (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_se_ir (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_se_ri (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_se_rr (en1, en2))
              end select
           case (V_STR)
              select case (t2)
              case (V_STR);  call eval_node_init_log (en, comp_eq_ss (en1, en2))
              end select
           end select
        case ("<>")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_ne_ii (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_ns_ir (en1, en2))
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_init_log (en, comp_ns_ri (en1, en2))
              case (V_REAL); call eval_node_init_log (en, comp_ns_rr (en1, en2))
              end select
           case (V_STR)
              select case (t2)
              case (V_STR);  call eval_node_init_log (en, comp_ne_ss (en1, en2))
              end select
           end select
        end select
        call eval_node_final_rec (en1)
        deallocate (en1)
     else
        call eval_node_init_branch (en, key, V_LOG, en1, en2)
        select case (char (key))
        case ("<")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_lt_ii)
              case (V_REAL); call eval_node_set_op2_log (en, comp_ll_ir)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_ll_ri)
              case (V_REAL); call eval_node_set_op2_log (en, comp_ll_rr)
              end select
           end select
        case (">")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_gt_ii)
              case (V_REAL); call eval_node_set_op2_log (en, comp_gg_ir)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_gg_ri)
              case (V_REAL); call eval_node_set_op2_log (en, comp_gg_rr)
              end select
           end select
        case ("<=")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_le_ii)
              case (V_REAL); call eval_node_set_op2_log (en, comp_ls_ir)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_ls_ri)
              case (V_REAL); call eval_node_set_op2_log (en, comp_ls_rr)
              end select
           end select
        case (">=")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_ge_ii)
              case (V_REAL); call eval_node_set_op2_log (en, comp_gs_ir)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_gs_ri)
              case (V_REAL); call eval_node_set_op2_log (en, comp_gs_rr)
              end select
           end select
        case ("==")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_eq_ii)
              case (V_REAL); call eval_node_set_op2_log (en, comp_se_ir)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_se_ri)
              case (V_REAL); call eval_node_set_op2_log (en, comp_se_rr)
              end select
           case (V_STR)
              select case (t2)
              case (V_STR);  call eval_node_set_op2_log (en, comp_eq_ss)
              end select
           end select
        case ("<>")
           select case (t1)
           case (V_INT)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_ne_ii)
              case (V_REAL); call eval_node_set_op2_log (en, comp_ns_ir)
              end select
           case (V_REAL)
              select case (t2)
              case (V_INT);  call eval_node_set_op2_log (en, comp_ns_ri)
              case (V_REAL); call eval_node_set_op2_log (en, comp_ns_rr)
              end select
           case (V_STR)
              select case (t2)
              case (V_STR);  call eval_node_set_op2_log (en, comp_ne_ss)
              end select
           end select
        end select
        call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr)
        en1%tolerance => tolerance_ptr
     end if
   end subroutine eval_node_compile_comparison
 
 @ %def eval_node_compile_comparison
 @
 \subsubsection{Recording analysis data}
 The [[record]] command is actually a logical expression which always
 evaluates [[true]].
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_record_cmd (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_key, pn_tag, pn_arg
     type(parse_node_t), pointer :: pn_arg1, pn_arg2, pn_arg3, pn_arg4
     type(eval_node_t), pointer :: en0, en1, en2, en3, en4
     real(default), pointer :: event_weight
     if (debug_active (D_MODEL_F)) then
        print *, "read record_cmd";  call parse_node_write (pn)
     end if
     pn_key => parse_node_get_sub_ptr (pn)
     pn_tag => parse_node_get_next_ptr (pn_key)
     pn_arg => parse_node_get_next_ptr (pn_tag)
     select case (char (parse_node_get_key (pn_key)))
     case ("record")
        call var_list%get_rptr (var_str ("event_weight"), event_weight)
     case ("record_unweighted")
        event_weight => null ()
     case ("record_excess")
        call var_list%get_rptr (var_str ("event_excess"), event_weight)
     end select
     select case (char (parse_node_get_rule_key (pn_tag)))
     case ("analysis_id")
        allocate (en0)
        call eval_node_init_string (en0, parse_node_get_string (pn_tag))
     case default
        call eval_node_compile_sexpr (en0, pn_tag, var_list)
     end select
     allocate (en)
     if (associated (pn_arg)) then
        pn_arg1 => parse_node_get_sub_ptr (pn_arg)
        call eval_node_compile_expr (en1, pn_arg1, var_list)
        if (en1%result_type == V_INT) &
             call insert_conversion_node (en1, V_REAL)
        pn_arg2 => parse_node_get_next_ptr (pn_arg1)
        if (associated (pn_arg2)) then
           call eval_node_compile_expr (en2, pn_arg2, var_list)
           if (en2%result_type == V_INT) &
                call insert_conversion_node (en2, V_REAL)
           pn_arg3 => parse_node_get_next_ptr (pn_arg2)
           if (associated (pn_arg3)) then
              call eval_node_compile_expr (en3, pn_arg3, var_list)
              if (en3%result_type == V_INT) &
                   call insert_conversion_node (en3, V_REAL)
              pn_arg4 => parse_node_get_next_ptr (pn_arg3)
              if (associated (pn_arg4)) then
                 call eval_node_compile_expr (en4, pn_arg4, var_list)
                 if (en4%result_type == V_INT) &
                      call insert_conversion_node (en4, V_REAL)
                 call eval_node_init_record_cmd &
                      (en, event_weight, en0, en1, en2, en3, en4)
              else
                 call eval_node_init_record_cmd &
                      (en, event_weight, en0, en1, en2, en3)
              end if
           else
              call eval_node_init_record_cmd (en, event_weight, en0, en1, en2)
           end if
        else
           call eval_node_init_record_cmd (en, event_weight, en0, en1)
        end if
     else
        call eval_node_init_record_cmd (en, event_weight, en0)
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done record_cmd"
     end if
   end subroutine eval_node_compile_record_cmd
 
 @ %def eval_node_compile_record_cmd
 @
 \subsubsection{Particle-list expressions}
 A particle expression is a subevent or a concatenation of
 particle-list terms (using \verb|join|).
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_pexpr (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_pterm, pn_concatenation, pn_op, pn_arg
     type(eval_node_t), pointer :: en1, en2
     type(subevt_t) :: subevt
     if (debug_active (D_MODEL_F)) then
        print *, "read pexpr";  call parse_node_write (pn)
     end if
     pn_pterm => parse_node_get_sub_ptr (pn)
     call eval_node_compile_pterm (en, pn_pterm, var_list)
     pn_concatenation => &
          parse_node_get_next_ptr (pn_pterm, tag="pconcatenation")
     do while (associated (pn_concatenation))
        pn_op => parse_node_get_sub_ptr (pn_concatenation)
        pn_arg => parse_node_get_next_ptr (pn_op)
        en1 => en
        call eval_node_compile_pterm (en2, pn_arg, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call subevt_join (subevt, en1%pval, en2%pval)
           call eval_node_init_subevt (en, subevt)
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch &
                (en, var_str ("join"), V_SEV, en1, en2)
           call eval_node_set_op2_sev (en, join_pp)
        end if
        pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done pexpr"
     end if
   end subroutine eval_node_compile_pexpr
 
 @ %def eval_node_compile_pexpr
 @ A particle term is a subevent or a combination of
 particle-list values (using \verb|combine|).
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_pterm (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_pvalue, pn_combination, pn_op, pn_arg
     type(eval_node_t), pointer :: en1, en2
     type(subevt_t) :: subevt
     if (debug_active (D_MODEL_F)) then
        print *, "read pterm";  call parse_node_write (pn)
     end if
     pn_pvalue => parse_node_get_sub_ptr (pn)
     call eval_node_compile_pvalue (en, pn_pvalue, var_list)
     pn_combination => &
          parse_node_get_next_ptr (pn_pvalue, tag="pcombination")
     do while (associated (pn_combination))
        pn_op => parse_node_get_sub_ptr (pn_combination)
        pn_arg => parse_node_get_next_ptr (pn_op)
        en1 => en
        call eval_node_compile_pvalue (en2, pn_arg, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call subevt_combine (subevt, en1%pval, en2%pval)
           call eval_node_init_subevt (en, subevt)
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch &
                (en, var_str ("combine"), V_SEV, en1, en2)
           call eval_node_set_op2_sev (en, combine_pp)
        end if
        pn_combination => parse_node_get_next_ptr (pn_combination)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done pterm"
     end if
   end subroutine eval_node_compile_pterm
 
 @ %def eval_node_compile_pterm
 @ A particle-list value is a PDG-code array, a particle identifier, a
 variable, a (grouped) pexpr, a block pexpr, a conditional, or a
 particle-list function.
 
 The [[cexpr]] node is responsible for transforming a constant PDG-code
 array into a subevent.  It takes the code array as its first
 argument, the event subevent as its second argument, and the
 requested particle type (incoming/outgoing) as its zero-th argument.
 The result is the list of particles in the event that match the code
 array.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_pvalue (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_prefix_cexpr
     type(eval_node_t), pointer :: en1, en2, en0
     type(string_t) :: key
     type(subevt_t), pointer :: evt_ptr
     logical, pointer :: known
     if (debug_active (D_MODEL_F)) then
        print *, "read pvalue";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("pexpr_src")
        call eval_node_compile_prefix_cexpr (en1, pn, var_list)
        allocate (en2)
        if (var_list%contains (var_str ("@evt"))) then
           call var_list%get_pptr (var_str ("@evt"), evt_ptr, known)
           call eval_node_init_subevt_ptr (en2, var_str ("@evt"), evt_ptr, known)
           allocate (en)
           call eval_node_init_branch &
                (en, var_str ("prt_selection"), V_SEV, en1, en2)
           call eval_node_set_op2_sev (en, select_pdg_ca)
           allocate (en0)
           pn_prefix_cexpr => parse_node_get_sub_ptr (pn)
           key = parse_node_get_rule_key (pn_prefix_cexpr)
           select case (char (key))
           case ("beam_prt")
              call eval_node_init_int (en0, PRT_BEAM)
              en%arg0 => en0
           case ("incoming_prt")
              call eval_node_init_int (en0, PRT_INCOMING)
              en%arg0 => en0
           case ("outgoing_prt")
              call eval_node_init_int (en0, PRT_OUTGOING)
              en%arg0 => en0
           case ("unspecified_prt")
              call eval_node_init_int (en0, PRT_OUTGOING)
              en%arg0 => en0
           end select
        else
           call parse_node_write (pn)
           call msg_bug (" Missing event data while compiling pvalue")
        end if
     case ("pvariable")
        call eval_node_compile_variable (en, pn, var_list, V_SEV)
     case ("pexpr")
        call eval_node_compile_pexpr (en, pn, var_list)
     case ("block_pexpr")
        call eval_node_compile_block_expr (en, pn, var_list, V_SEV)
     case ("conditional_pexpr")
        call eval_node_compile_conditional (en, pn, var_list, V_SEV)
     case ("join_fun", "combine_fun", "collect_fun", "cluster_fun", &
           "select_fun", "extract_fun", "sort_fun", "select_b_jet_fun", &
           "select_non_bjet_fun", "select_c_jet_fun", &
           "select_light_jet_fun")
        call eval_node_compile_prt_function (en, pn, var_list)
     case default
        call parse_node_mismatch &
             ("prefix_cexpr|pvariable|" // &
              "grouped_pexpr|block_pexpr|conditional_pexpr|" // &
              "prt_function", pn)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done pvalue"
     end if
   end subroutine eval_node_compile_pvalue
 
 @ %def eval_node_compile_pvalue
 @
 \subsubsection{Particle functions}
 This combines the treatment of 'join', 'combine', 'collect', 'cluster',
 'select', and 'extract' which all have the same syntax.  The one or two
 argument nodes are allocated.  If there is a condition, the condition
 node is also allocated as a logical expression, for which the variable
 list is augmented by the appropriate (unary/binary) observables.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_prt_function (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args
     type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
     type(eval_node_t), pointer :: en0, en1, en2
     type(string_t) :: key
     if (debug_active (D_MODEL_F)) then
        print *, "read prt_function";  call parse_node_write (pn)
     end if
     pn_clause => parse_node_get_sub_ptr (pn)
     pn_key  => parse_node_get_sub_ptr (pn_clause)
     pn_cond => parse_node_get_next_ptr (pn_key)
     if (associated (pn_cond)) &
          pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
     pn_args => parse_node_get_next_ptr (pn_clause)
     pn_arg1 => parse_node_get_sub_ptr (pn_args)
     pn_arg2 => parse_node_get_next_ptr (pn_arg1)
     key = parse_node_get_key (pn_key)
     call eval_node_compile_pexpr (en1, pn_arg1, var_list)
     allocate (en)
     if (.not. associated (pn_arg2)) then
        select case (char (key))
        case ("collect")
           call eval_node_init_prt_fun_unary (en, en1, key, collect_p)
        case ("cluster")
           if (fastjet_available ()) then
              call fastjet_init ()
           else
              call msg_fatal &
                ("'cluster' function requires FastJet, which is not enabled")
           end if
           en1%var_list => var_list
           call eval_node_init_prt_fun_unary (en, en1, key, cluster_p)
           call var_list%get_iptr (var_str ("jet_algorithm"), en1%jet_algorithm)
           call var_list%get_rptr (var_str ("jet_r"), en1%jet_r)
           call var_list%get_rptr (var_str ("jet_p"), en1%jet_p)
           call var_list%get_rptr (var_str ("jet_ycut"), en1%jet_ycut)
        case ("select")
           call eval_node_init_prt_fun_unary (en, en1, key, select_p)
        case ("extract")
           call eval_node_init_prt_fun_unary (en, en1, key, extract_p)
        case ("sort")
           call eval_node_init_prt_fun_unary (en, en1, key, sort_p)
        case ("select_b_jet")
           call eval_node_init_prt_fun_unary (en, en1, key, select_b_jet_p)
        case ("select_non_b_jet")
           call eval_node_init_prt_fun_unary (en, en1, key, select_non_b_jet_p)
        case ("select_c_jet")
           call eval_node_init_prt_fun_unary (en, en1, key, select_c_jet_p)
        case ("select_light_jet")
           call eval_node_init_prt_fun_unary (en, en1, key, select_light_jet_p)
        case default
           call msg_bug (" Unary particle function '" // char (key) // &
                "' undefined")
        end select
     else
        call eval_node_compile_pexpr (en2, pn_arg2, var_list)
        select case (char (key))
        case ("join")
           call eval_node_init_prt_fun_binary (en, en1, en2, key, join_pp)
        case ("combine")
           call eval_node_init_prt_fun_binary (en, en1, en2, key, combine_pp)
        case ("collect")
           call eval_node_init_prt_fun_binary (en, en1, en2, key, collect_pp)
        case ("select")
           call eval_node_init_prt_fun_binary (en, en1, en2, key, select_pp)
        case ("sort")
           call eval_node_init_prt_fun_binary (en, en1, en2, key, sort_pp)
        case default
           call msg_bug (" Binary particle function '" // char (key) // &
                "' undefined")
        end select
     end if
     if (associated (pn_cond)) then
        call eval_node_set_observables (en, var_list)
        select case (char (key))
        case ("extract", "sort")
           call eval_node_compile_expr (en0, pn_arg0, en%var_list)
        case default
           call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
        end select
        en%arg0 => en0
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done prt_function"
     end if
   end subroutine eval_node_compile_prt_function
 
 @ %def eval_node_compile_prt_function
 @ The [[eval]] expression is similar, but here the expression [[arg0]]
 is mandatory, and the whole thing evaluates to a numeric value.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_eval_function (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_key, pn_arg0, pn_args, pn_arg1, pn_arg2
     type(eval_node_t), pointer :: en0, en1, en2
     type(string_t) :: key
     if (debug_active (D_MODEL_F)) then
        print *, "read eval_function";  call parse_node_write (pn)
     end if
     pn_key => parse_node_get_sub_ptr (pn)
     pn_arg0 => parse_node_get_next_ptr (pn_key)
     pn_args => parse_node_get_next_ptr (pn_arg0)
     pn_arg1 => parse_node_get_sub_ptr (pn_args)
     pn_arg2 => parse_node_get_next_ptr (pn_arg1)
     key = parse_node_get_key (pn_key)
     call eval_node_compile_pexpr (en1, pn_arg1, var_list)
     allocate (en)
     if (.not. associated (pn_arg2)) then
        call eval_node_init_eval_fun_unary (en, en1, key)
     else
        call eval_node_compile_pexpr (en2, pn_arg2, var_list)
        call eval_node_init_eval_fun_binary (en, en1, en2, key)
     end if
     call eval_node_set_observables (en, var_list)
     call eval_node_compile_expr (en0, pn_arg0, en%var_list)
     if (en0%result_type /= V_REAL) &
          call msg_fatal (" 'eval' function does not result in real value")
     call eval_node_set_expr (en, en0)
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done eval_function"
     end if
   end subroutine eval_node_compile_eval_function
 
 @ %def eval_node_compile_eval_function
 @ Logical functions of subevents. For [[photon_isolation]] there is a
 conditional selection expression instead of a mandatory logical
 expression, so in the case of the absence of the selection we have to
 create a logical [[eval_node_t]] with value [[.true.]].
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_log_function (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_clause, pn_key, pn_str, pn_cond
     type(parse_node_t), pointer :: pn_arg0, pn_args, pn_arg1, pn_arg2
     type(eval_node_t), pointer :: en0, en1, en2
     type(string_t) :: key
     if (debug_active (D_MODEL_F)) then
        print *, "read log_function";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("all_fun", "any_fun", "no_fun")
        pn_key => parse_node_get_sub_ptr (pn)
        pn_arg0 => parse_node_get_next_ptr (pn_key)
        pn_args => parse_node_get_next_ptr (pn_arg0)
     case ("photon_isolation_fun")
        pn_clause => parse_node_get_sub_ptr (pn)
        pn_key => parse_node_get_sub_ptr (pn_clause)
        pn_cond => parse_node_get_next_ptr (pn_key)
        if (associated (pn_cond)) then
           pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
        else
           pn_arg0 => null ()
        end if
        pn_args => parse_node_get_next_ptr (pn_clause)
     case ("user_cut_fun")
        pn_key => parse_node_get_sub_ptr (pn)
        pn_str => parse_node_get_next_ptr (pn_key)
        pn_arg0 => parse_node_get_sub_ptr (pn_str)
        pn_args => parse_node_get_next_ptr (pn_str)
     case default
        call parse_node_mismatch ("all_fun|any_fun|" // &
             "no_fun|photon_isolation_fun|user_cut_fun", pn)
     end select
     pn_arg1 => parse_node_get_sub_ptr (pn_args)
     pn_arg2 => parse_node_get_next_ptr (pn_arg1)
     key = parse_node_get_key (pn_key)
     call eval_node_compile_pexpr (en1, pn_arg1, var_list)
     allocate (en)
     if (.not. associated (pn_arg2)) then
        select case (char (key))
        case ("all")
           call eval_node_init_log_fun_unary (en, en1, key, all_p)
        case ("any")
           call eval_node_init_log_fun_unary (en, en1, key, any_p)
        case ("no")
           call eval_node_init_log_fun_unary (en, en1, key, no_p)
        case ("user_cut")
           call eval_node_init_log_fun_unary (en, en1, key, user_cut_p)
        case default
           call msg_bug ("Unary logical particle function '" // char (key) // &
                "' undefined")
        end select
     else
        call eval_node_compile_pexpr (en2, pn_arg2, var_list)
        select case (char (key))
        case ("all")
           call eval_node_init_log_fun_binary (en, en1, en2, key, all_pp)
        case ("any")
           call eval_node_init_log_fun_binary (en, en1, en2, key, any_pp)
        case ("no")
           call eval_node_init_log_fun_binary (en, en1, en2, key, no_pp)
        case ("photon_isolation")
           en1%var_list => var_list
           call var_list%get_rptr (var_str ("photon_iso_eps"), en1%photon_iso_eps)
           call var_list%get_rptr (var_str ("photon_iso_n"), en1%photon_iso_n)
           call var_list%get_rptr (var_str ("photon_iso_r0"), en1%photon_iso_r0)
           call eval_node_init_log_fun_binary (en, en1, en2, key, photon_isolation_pp)
        case default
           call msg_bug ("Binary logical particle function '" // char (key) // &
                "' undefined")
        end select
     end if
     if (associated (pn_arg0)) then
        call eval_node_set_observables (en, var_list)
        select case (char (key))
        case ("all", "any", "no", "photon_isolation")
           call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
        case ("user_cut")
           call eval_node_compile_sexpr (en0, pn_arg0, en%var_list)
        case default
           call msg_bug ("Compiling logical particle function: missing mode")
        end select
        call eval_node_set_expr (en, en0, V_LOG)
     else
        select case (char (key))
        case ("photon_isolation")
           allocate (en0)
           call eval_node_init_log (en0, .true.)
           call eval_node_set_expr (en, en0, V_LOG)
        case default
           call msg_bug ("Only photon isolation can be called unconditionally")
        end select
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done log_function"
     end if
   end subroutine eval_node_compile_log_function
 
 @ %def eval_node_compile_log_function
 @ Numeric functions of subevents.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_numeric_function (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args
     type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
     type(eval_node_t), pointer :: en0, en1, en2
     type(string_t) :: key
     if (debug_active (D_MODEL_F)) then
        print *, "read numeric_function";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("count_fun")
        pn_clause => parse_node_get_sub_ptr (pn)
        pn_key  => parse_node_get_sub_ptr (pn_clause)
        pn_cond => parse_node_get_next_ptr (pn_key)
        if (associated (pn_cond)) then
           pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
        else
           pn_arg0 => null ()
        end if
        pn_args => parse_node_get_next_ptr (pn_clause)
     case ("user_event_fun")
        pn_key => parse_node_get_sub_ptr (pn)
        pn_cond => parse_node_get_next_ptr (pn_key)
        pn_arg0 => parse_node_get_sub_ptr (pn_cond)
        pn_args => parse_node_get_next_ptr (pn_cond)
     end select
     pn_arg1 => parse_node_get_sub_ptr (pn_args)
     pn_arg2 => parse_node_get_next_ptr (pn_arg1)
     key = parse_node_get_key (pn_key)
     call eval_node_compile_pexpr (en1, pn_arg1, var_list)
     allocate (en)
     if (.not. associated (pn_arg2)) then
        select case (char (key))
        case ("count")
           call eval_node_init_int_fun_unary (en, en1, key, count_a)
        case ("user_event_shape")
           call eval_node_init_real_fun_unary (en, en1, key, user_event_shape_a)
        case default
           call msg_bug ("Unary subevent function '" // char (key) // &
                "' undefined")
        end select
     else
        call eval_node_compile_pexpr (en2, pn_arg2, var_list)
        select case (char (key))
        case ("count")
           call eval_node_init_int_fun_binary (en, en1, en2, key, count_pp)
        case default
           call msg_bug ("Binary subevent function '" // char (key) // &
                "' undefined")
        end select
     end if
     if (associated (pn_arg0)) then
        call eval_node_set_observables (en, var_list)
        select case (char (key))
        case ("count")
           call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
           call eval_node_set_expr (en, en0, V_INT)
        case ("user_event_shape")
           call eval_node_compile_sexpr (en0, pn_arg0, en%var_list)
           call eval_node_set_expr (en, en0, V_REAL)
        end select
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done numeric_function"
     end if
   end subroutine eval_node_compile_numeric_function
 
 @ %def eval_node_compile_numeric_function
 @
 \subsubsection{PDG-code arrays}
 A PDG-code expression is (optionally) prefixed by [[beam]], [[incoming]], or
 [[outgoing]], a block, or a conditional.  In any case, it evaluates to
 a constant.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_prefix_cexpr (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_avalue, pn_prt
     type(string_t) :: key
     if (debug_active (D_MODEL_F)) then
        print *, "read prefix_cexpr";  call parse_node_write (pn)
     end if
     pn_avalue => parse_node_get_sub_ptr (pn)
     key = parse_node_get_rule_key (pn_avalue)
     select case (char (key))
     case ("beam_prt")
        pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
        call eval_node_compile_cexpr (en, pn_prt, var_list)
     case ("incoming_prt")
        pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
        call eval_node_compile_cexpr (en, pn_prt, var_list)
     case ("outgoing_prt")
        pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
        call eval_node_compile_cexpr (en, pn_prt, var_list)
     case ("unspecified_prt")
        pn_prt => parse_node_get_sub_ptr (pn_avalue, 1)
        call eval_node_compile_cexpr (en, pn_prt, var_list)
     case default
        call parse_node_mismatch &
             ("beam_prt|incoming_prt|outgoing_prt|unspecified_prt", &
              pn_avalue)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done prefix_cexpr"
     end if
   end subroutine eval_node_compile_prefix_cexpr
 
 @ %def eval_node_compile_prefix_cexpr
 @ A PDG array is a string of PDG code definitions (or aliases),
 concatenated by ':'.  The code definitions may be variables which are
 not defined at compile time, so we have to allocate sub-nodes.  This
 analogous to [[eval_node_compile_term]].
 <<Eval trees: procedures>>=
    recursive subroutine eval_node_compile_cexpr (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_prt, pn_concatenation
     type(eval_node_t), pointer :: en1, en2
     type(pdg_array_t) :: aval
     if (debug_active (D_MODEL_F)) then
        print *, "read cexpr";  call parse_node_write (pn)
     end if
     pn_prt => parse_node_get_sub_ptr (pn)
     call eval_node_compile_avalue (en, pn_prt, var_list)
     pn_concatenation => parse_node_get_next_ptr (pn_prt)
     do while (associated (pn_concatenation))
        pn_prt => parse_node_get_sub_ptr (pn_concatenation, 2)
        en1 => en
        call eval_node_compile_avalue (en2, pn_prt, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call concat_cc (aval, en1, en2)
           call eval_node_init_pdg_array (en, aval)
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch (en, var_str (":"), V_PDG, en1, en2)
           call eval_node_set_op2_pdg (en, concat_cc)
        end if
        pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done cexpr"
     end if
   end subroutine eval_node_compile_cexpr
 
 @ %def eval_node_compile_cexpr
 @ Compile a PDG-code type value.  It may be either an integer expression
 or a variable of type PDG array, optionally quoted.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_avalue (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     if (debug_active (D_MODEL_F)) then
        print *, "read avalue";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("pdg_code")
        call eval_node_compile_pdg_code (en, pn, var_list)
     case ("cvariable", "variable", "prt_name")
        call eval_node_compile_cvariable (en, pn, var_list)
     case ("cexpr")
        call eval_node_compile_cexpr (en, pn, var_list)
     case ("block_cexpr")
        call eval_node_compile_block_expr (en, pn, var_list, V_PDG)
     case ("conditional_cexpr")
        call eval_node_compile_conditional (en, pn, var_list, V_PDG)
     case default
        call parse_node_mismatch &
             ("grouped_cexpr|block_cexpr|conditional_cexpr|" // &
              "pdg_code|cvariable|prt_name", pn)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done avalue"
     end if
   end subroutine eval_node_compile_avalue
 
 @ %def eval_node_compile_avalue
 @ Compile a PDG-code expression, which is the key [[PDG]] with an
 integer expression as argument.  The procedure is analogous to
 [[eval_node_compile_unary_function]].
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_pdg_code (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_arg
     type(eval_node_t), pointer :: en1
     type(string_t) :: key
     type(pdg_array_t) :: aval
     integer :: t
     if (debug_active (D_MODEL_F)) then
        print *, "read PDG code";  call parse_node_write (pn)
     end if
     pn_arg => parse_node_get_sub_ptr (pn, 2)
     call eval_node_compile_expr &
          (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list)
     t = en1%result_type
     allocate (en)
     key = "PDG"
     if (en1%type == EN_CONSTANT) then
        select case (t)
        case (V_INT)
           call pdg_i (aval, en1)
           call eval_node_init_pdg_array (en, aval)
        case default;  call eval_type_error (pn, char (key), t)
        end select
        call eval_node_final_rec (en1)
        deallocate (en1)
     else
        select case (t)
        case (V_INT);  call eval_node_set_op1_pdg (en, pdg_i)
        case default;  call eval_type_error (pn, char (key), t)
        end select
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done function"
     end if
   end subroutine eval_node_compile_pdg_code
 
 @ %def eval_node_compile_pdg_code
 @ This is entirely analogous to [[eval_node_compile_variable]].
 However, PDG-array variables occur in different contexts.
 
 To avoid name clashes between PDG-array variables and ordinary
 variables, we prepend a character ([[*]]).  This is not visible to the
 user.
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_cvariable (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_name
     type(string_t) :: var_name
     type(pdg_array_t), pointer :: aptr
     type(pdg_array_t), target, save :: no_aval
     logical, pointer :: known
     logical, target, save :: unknown = .false.
     if (debug_active (D_MODEL_F)) then
        print *, "read cvariable";  call parse_node_write (pn)
     end if
     pn_name => pn
     var_name = parse_node_get_string (pn_name)
     allocate (en)
     if (var_list%contains (var_name)) then
        call var_list%get_aptr (var_name, aptr, known)
        call eval_node_init_pdg_array_ptr (en, var_name, aptr, known)
     else
        call parse_node_write (pn)
        call msg_error ("This PDG-array variable is undefined at this point")
        call eval_node_init_pdg_array_ptr (en, var_name, no_aval, unknown)
     end if
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done cvariable"
     end if
   end subroutine eval_node_compile_cvariable
 
 @ %def eval_node_compile_cvariable
 @
 \subsubsection{String expressions}
 A string expression is either a string value or a concatenation of
 string values.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_sexpr (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_svalue, pn_concatenation, pn_op, pn_arg
     type(eval_node_t), pointer :: en1, en2
     type(string_t) :: string
     if (debug_active (D_MODEL_F)) then
        print *, "read sexpr";  call parse_node_write (pn)
     end if
     pn_svalue => parse_node_get_sub_ptr (pn)
     call eval_node_compile_svalue (en, pn_svalue, var_list)
     pn_concatenation => &
          parse_node_get_next_ptr (pn_svalue, tag="str_concatenation")
     do while (associated (pn_concatenation))
        pn_op => parse_node_get_sub_ptr (pn_concatenation)
        pn_arg => parse_node_get_next_ptr (pn_op)
        en1 => en
        call eval_node_compile_svalue (en2, pn_arg, var_list)
        allocate (en)
        if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
           call concat_ss (string, en1, en2)
           call eval_node_init_string (en, string)
           call eval_node_final_rec (en1)
           call eval_node_final_rec (en2)
           deallocate (en1, en2)
        else
           call eval_node_init_branch &
                (en, var_str ("concat"), V_STR, en1, en2)
           call eval_node_set_op2_str (en, concat_ss)
        end if
        pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
     end do
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done sexpr"
     end if
   end subroutine eval_node_compile_sexpr
 
 @ %def eval_node_compile_sexpr
 @ A string value is a string literal, a
 variable, a (grouped) sexpr, a block sexpr, or a conditional.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_svalue (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     if (debug_active (D_MODEL_F)) then
        print *, "read svalue";  call parse_node_write (pn)
     end if
     select case (char (parse_node_get_rule_key (pn)))
     case ("svariable")
        call eval_node_compile_variable (en, pn, var_list, V_STR)
     case ("sexpr")
        call eval_node_compile_sexpr (en, pn, var_list)
     case ("block_sexpr")
        call eval_node_compile_block_expr (en, pn, var_list, V_STR)
     case ("conditional_sexpr")
        call eval_node_compile_conditional (en, pn, var_list, V_STR)
     case ("sprintf_fun")
        call eval_node_compile_sprintf (en, pn, var_list)
     case ("string_literal")
        allocate (en)
        call eval_node_init_string (en, parse_node_get_string (pn))
     case default
        call parse_node_mismatch &
             ("svariable|" // &
              "grouped_sexpr|block_sexpr|conditional_sexpr|" // &
              "string_function|string_literal", pn)
     end select
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done svalue"
     end if
   end subroutine eval_node_compile_svalue
 
 @ %def eval_node_compile_svalue
 @ There is currently one string function, [[sprintf]].  For
 [[sprintf]], the first argument (no brackets) is the format string, the
 optional arguments in brackets are the expressions or variables to be
 formatted.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_compile_sprintf (en, pn, var_list)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_clause, pn_key, pn_args
     type(parse_node_t), pointer :: pn_arg0
     type(eval_node_t), pointer :: en0, en1
     integer :: n_args
     type(string_t) :: key
     if (debug_active (D_MODEL_F)) then
        print *, "read sprintf_fun";  call parse_node_write (pn)
     end if
     pn_clause => parse_node_get_sub_ptr (pn)
     pn_key  => parse_node_get_sub_ptr (pn_clause)
     pn_arg0 => parse_node_get_next_ptr (pn_key)
     pn_args => parse_node_get_next_ptr (pn_clause)
     call eval_node_compile_sexpr (en0, pn_arg0, var_list)
     if (associated (pn_args)) then
        call eval_node_compile_sprintf_args (en1, pn_args, var_list, n_args)
     else
        n_args = 0
        en1 => null ()
     end if
     allocate (en)
     key = parse_node_get_key (pn_key)
     call eval_node_init_format_string (en, en0, en1, key, n_args)
     if (debug_active (D_MODEL_F)) then
        call eval_node_write (en)
        print *, "done sprintf_fun"
     end if
   end subroutine eval_node_compile_sprintf
 
 @ %def eval_node_compile_sprintf
 <<Eval trees: procedures>>=
   subroutine eval_node_compile_sprintf_args (en, pn, var_list, n_args)
     type(eval_node_t), pointer :: en
     type(parse_node_t), intent(in) :: pn
     type(var_list_t), intent(in), target :: var_list
     integer, intent(out) :: n_args
     type(parse_node_t), pointer :: pn_arg
     integer :: i
     type(eval_node_t), pointer :: en1, en2
     n_args = parse_node_get_n_sub (pn)
     en => null ()
     do i = n_args, 1, -1
        pn_arg => parse_node_get_sub_ptr (pn, i)
        select case (char (parse_node_get_rule_key (pn_arg)))
        case ("lvariable")
           call eval_node_compile_variable (en1, pn_arg, var_list, V_LOG)
        case ("svariable")
           call eval_node_compile_variable (en1, pn_arg, var_list, V_STR)
        case ("expr")
           call eval_node_compile_expr (en1, pn_arg, var_list)
        case default
           call parse_node_mismatch ("variable|svariable|lvariable|expr", pn_arg)
        end select
        if (associated (en)) then
           en2 => en
           allocate (en)
           call eval_node_init_branch &
                (en, var_str ("sprintf_arg"), V_NONE, en1, en2)
        else
           allocate (en)
           call eval_node_init_branch &
                (en, var_str ("sprintf_arg"), V_NONE, en1)
        end if
     end do
   end subroutine eval_node_compile_sprintf_args
 
 @ %def eval_node_compile_sprintf_args
 @ Evaluation.  We allocate the argument list and apply the Fortran wrapper for
 the [[sprintf]] function.
 <<Eval trees: procedures>>=
   subroutine evaluate_sprintf (string, n_args, en_fmt, en_arg)
     type(string_t), intent(out) :: string
     integer, intent(in) :: n_args
     type(eval_node_t), pointer :: en_fmt
     type(eval_node_t), intent(in), optional, target :: en_arg
     type(eval_node_t), pointer :: en_branch, en_var
     type(sprintf_arg_t), dimension(:), allocatable :: arg
     type(string_t) :: fmt
     logical :: autoformat
     integer :: i, j, sprintf_argc
     autoformat = .not. associated (en_fmt)
     if (autoformat) fmt = ""
     if (present (en_arg)) then
        sprintf_argc = 0
        en_branch => en_arg
        do i = 1, n_args
           select case (en_branch%arg1%result_type)
              case (V_CMPLX); sprintf_argc = sprintf_argc + 2
              case default  ; sprintf_argc = sprintf_argc + 1
           end select
           en_branch => en_branch%arg2
        end do
        allocate (arg (sprintf_argc))
        j = 1
        en_branch => en_arg
        do i = 1, n_args
           en_var => en_branch%arg1
           select case (en_var%result_type)
           case (V_LOG)
              call sprintf_arg_init (arg(j), en_var%lval)
              if (autoformat) fmt = fmt // "%s "
           case (V_INT);
              call sprintf_arg_init (arg(j), en_var%ival)
              if (autoformat) fmt = fmt // "%i "
           case (V_REAL);
              call sprintf_arg_init (arg(j), en_var%rval)
              if (autoformat) fmt = fmt // "%g "
           case (V_STR)
              call sprintf_arg_init (arg(j), en_var%sval)
              if (autoformat) fmt = fmt // "%s "
           case (V_CMPLX)
              call sprintf_arg_init (arg(j), real (en_var%cval, default))
              j = j + 1
              call sprintf_arg_init (arg(j), aimag (en_var%cval))
              if (autoformat) fmt = fmt // "(%g + %g * I) "
           case default
              call eval_node_write (en_var)
              call msg_error ("sprintf is implemented " &
                   // "for logical, integer, real, and string values only")
           end select
           j = j + 1
           en_branch => en_branch%arg2
        end do
     else
        allocate (arg(0))
     end if
     if (autoformat) then
        string = sprintf (trim (fmt), arg)
     else
        string = sprintf (en_fmt%sval, arg)
     end if
   end subroutine evaluate_sprintf
 
 @ %def evaluate_sprintf
 @
 \subsection{Auxiliary functions for the compiler}
 Issue an error that the current node could not be compiled because of
 type mismatch:
 <<Eval trees: procedures>>=
   subroutine eval_type_error (pn, string, t)
     type(parse_node_t), intent(in) :: pn
     character(*), intent(in) :: string
     integer, intent(in) :: t
     type(string_t) :: type
     select case (t)
     case (V_NONE); type = "(none)"
     case (V_LOG);  type = "'logical'"
     case (V_INT);  type = "'integer'"
     case (V_REAL); type = "'real'"
     case (V_CMPLX); type = "'complex'"
     case default;  type = "(unknown)"
     end select
     call parse_node_write (pn)
     call msg_fatal (" The " // string // &
          " operation is not defined for the given argument type " // &
          char (type))
   end subroutine eval_type_error
 
 @ %def eval_type_error
 @
 If two numerics are combined, the result is integer if both
 arguments are integer, if one is integer and the other real or both
 are real, than its argument is real, otherwise complex.
 <<Eval trees: procedures>>=
   function numeric_result_type (t1, t2) result (t)
     integer, intent(in) :: t1, t2
     integer :: t
     if (t1 == V_INT .and. t2 == V_INT) then
        t = V_INT
     else if (t1 == V_INT .and. t2 == V_REAL) then
        t = V_REAL
     else if (t1 == V_REAL .and. t2 == V_INT) then
        t = V_REAL
     else if (t1 == V_REAL .and. t2 == V_REAL) then
        t = V_REAL
     else
        t = V_CMPLX
     end if
   end function numeric_result_type
 
 @ %def numeric_type
 @
 \subsection{Evaluation}
 Evaluation is done recursively.  For leaf nodes nothing is to be done.
 
 Evaluating particle-list functions: First, we evaluate the particle
 lists.  If a condition is present, we assign the particle pointers of
 the condition node to the allocated particle entries in the parent
 node, keeping in mind that the observables in the variable stack used
 for the evaluation of the condition also contain pointers to these
 entries.  Then, the assigned procedure is evaluated, which sets the
 subevent in the parent node.  If required, the procedure
 evaluates the condition node once for each (pair of) particles to
 determine the result.
 <<Eval trees: procedures>>=
   recursive subroutine eval_node_evaluate (en)
     type(eval_node_t), intent(inout) :: en
     logical :: exist
     select case (en%type)
     case (EN_UNARY)
        if (associated (en%arg1)) then
           call eval_node_evaluate (en%arg1)
           en%value_is_known = en%arg1%value_is_known
        else
           en%value_is_known = .false.
        end if
        if (en%value_is_known) then
           select case (en%result_type)
           case (V_LOG);  en%lval = en%op1_log  (en%arg1)
           case (V_INT);  en%ival = en%op1_int  (en%arg1)
           case (V_REAL); en%rval = en%op1_real (en%arg1)
           case (V_CMPLX); en%cval = en%op1_cmplx (en%arg1)
           case (V_PDG);
              call en%op1_pdg  (en%aval, en%arg1)
           case (V_SEV)
              if (associated (en%arg0)) then
                 call en%op1_sev (en%pval, en%arg1, en%arg0)
              else
                 call en%op1_sev (en%pval, en%arg1)
              end if
           case (V_STR)
              call en%op1_str (en%sval, en%arg1)
           end select
        end if
     case (EN_BINARY)
        if (associated (en%arg1) .and. associated (en%arg2)) then
           call eval_node_evaluate (en%arg1)
           call eval_node_evaluate (en%arg2)
           en%value_is_known = &
                en%arg1%value_is_known .and. en%arg2%value_is_known
        else
           en%value_is_known = .false.
        end if
        if (en%value_is_known) then
           select case (en%result_type)
           case (V_LOG);  en%lval = en%op2_log  (en%arg1, en%arg2)
           case (V_INT);  en%ival = en%op2_int  (en%arg1, en%arg2)
           case (V_REAL); en%rval = en%op2_real (en%arg1, en%arg2)
           case (V_CMPLX); en%cval = en%op2_cmplx (en%arg1, en%arg2)
           case (V_PDG)
              call en%op2_pdg  (en%aval, en%arg1, en%arg2)
           case (V_SEV)
              if (associated (en%arg0)) then
                 call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0)
              else
                 call en%op2_sev (en%pval, en%arg1, en%arg2)
              end if
           case (V_STR)
              call en%op2_str (en%sval, en%arg1, en%arg2)
           end select
        end if
     case (EN_BLOCK)
        if (associated (en%arg1) .and. associated (en%arg0)) then
           call eval_node_evaluate (en%arg1)
           call eval_node_evaluate (en%arg0)
           en%value_is_known = en%arg0%value_is_known
        else
           en%value_is_known = .false.
        end if
        if (en%value_is_known) then
           select case (en%result_type)
           case (V_LOG);  en%lval = en%arg0%lval
           case (V_INT);  en%ival = en%arg0%ival
           case (V_REAL); en%rval = en%arg0%rval
           case (V_CMPLX); en%cval = en%arg0%cval
           case (V_PDG);  en%aval = en%arg0%aval
           case (V_SEV);  en%pval = en%arg0%pval
           case (V_STR);  en%sval = en%arg0%sval
           end select
        end if
     case (EN_CONDITIONAL)
        if (associated (en%arg0)) then
           call eval_node_evaluate (en%arg0)
           en%value_is_known = en%arg0%value_is_known
        else
           en%value_is_known = .false.
        end if
        if (en%arg0%value_is_known) then
           if (en%arg0%lval) then
              call eval_node_evaluate (en%arg1)
              en%value_is_known = en%arg1%value_is_known
              if (en%value_is_known) then
                 select case (en%result_type)
                 case (V_LOG);  en%lval = en%arg1%lval
                 case (V_INT);  en%ival = en%arg1%ival
                 case (V_REAL); en%rval = en%arg1%rval
                 case (V_CMPLX); en%cval = en%arg1%cval
                 case (V_PDG);  en%aval = en%arg1%aval
                 case (V_SEV);  en%pval = en%arg1%pval
                 case (V_STR);  en%sval = en%arg1%sval
                 end select
              end if
           else
              call eval_node_evaluate (en%arg2)
              en%value_is_known = en%arg2%value_is_known
              if (en%value_is_known) then
                 select case (en%result_type)
                 case (V_LOG);  en%lval = en%arg2%lval
                 case (V_INT);  en%ival = en%arg2%ival
                 case (V_REAL); en%rval = en%arg2%rval
                 case (V_CMPLX); en%cval = en%arg2%cval
                 case (V_PDG);  en%aval = en%arg2%aval
                 case (V_SEV);  en%pval = en%arg2%pval
                 case (V_STR);  en%sval = en%arg2%sval
                 end select
              end if
           end if
        end if
     case (EN_RECORD_CMD)
        exist = .true.
        en%lval = .false.
        call eval_node_evaluate (en%arg0)
        if (en%arg0%value_is_known) then
           if (associated (en%arg1)) then
              call eval_node_evaluate (en%arg1)
              if (en%arg1%value_is_known) then
                 if (associated (en%arg2)) then
                    call eval_node_evaluate (en%arg2)
                    if (en%arg2%value_is_known) then
                       if (associated (en%arg3)) then
                          call eval_node_evaluate (en%arg3)
                          if (en%arg3%value_is_known) then
                             if (associated (en%arg4)) then
                                call eval_node_evaluate (en%arg4)
                                if (en%arg4%value_is_known) then
                                   if (associated (en%rval)) then
                                      call analysis_record_data (en%arg0%sval, &
                                           en%arg1%rval, en%arg2%rval, &
                                           en%arg3%rval, en%arg4%rval, &
                                           weight=en%rval, exist=exist, &
                                           success=en%lval)
                                   else
                                      call analysis_record_data (en%arg0%sval, &
                                           en%arg1%rval, en%arg2%rval, &
                                           en%arg3%rval, en%arg4%rval, &
                                           exist=exist, success=en%lval)
                                   end if
                                end if
                             else
                                if (associated (en%rval)) then
                                   call analysis_record_data (en%arg0%sval, &
                                        en%arg1%rval, en%arg2%rval, &
                                        en%arg3%rval, &
                                        weight=en%rval, exist=exist, &
                                        success=en%lval)
                                else
                                   call analysis_record_data (en%arg0%sval, &
                                        en%arg1%rval, en%arg2%rval, &
                                        en%arg3%rval, &
                                        exist=exist, success=en%lval)
                                end if
                             end if
                          end if
                       else
                          if (associated (en%rval)) then
                             call analysis_record_data (en%arg0%sval, &
                                  en%arg1%rval, en%arg2%rval, &
                                  weight=en%rval, exist=exist, &
                                  success=en%lval)
                          else
                             call analysis_record_data (en%arg0%sval, &
                                  en%arg1%rval, en%arg2%rval, &
                                  exist=exist, success=en%lval)
                          end if
                       end if
                    end if
                 else
                    if (associated (en%rval)) then
                       call analysis_record_data (en%arg0%sval, &
                            en%arg1%rval, &
                            weight=en%rval, exist=exist, success=en%lval)
                    else
                       call analysis_record_data (en%arg0%sval, &
                            en%arg1%rval, &
                            exist=exist, success=en%lval)
                    end if
                 end if
              end if
           else
              if (associated (en%rval)) then
                 call analysis_record_data (en%arg0%sval, 1._default, &
                      weight=en%rval, exist=exist, success=en%lval)
              else
                 call analysis_record_data (en%arg0%sval, 1._default, &
                      exist=exist, success=en%lval)
              end if
           end if
           if (.not. exist) then
              call msg_error ("Analysis object '" // char (en%arg0%sval) &
                   // "' is undefined")
              en%arg0%value_is_known = .false.
           end if
        end if
     case (EN_OBS1_INT)
        en%ival = en%obs1_int (en%prt1)
        en%value_is_known = .true.
     case (EN_OBS2_INT)
        en%ival = en%obs2_int (en%prt1, en%prt2)
        en%value_is_known = .true.
     case (EN_OBS1_REAL)
        en%rval = en%obs1_real (en%prt1)
        en%value_is_known = .true.
     case (EN_OBS2_REAL)
        en%rval = en%obs2_real (en%prt1, en%prt2)
        en%value_is_known = .true.
     case (EN_UOBS1_INT)
        en%ival = user_obs_int_p (en%arg0, en%prt1)
        en%value_is_known = .true.
     case (EN_UOBS2_INT)
        en%ival = user_obs_int_pp (en%arg0, en%prt1, en%prt2)
        en%value_is_known = .true.
     case (EN_UOBS1_REAL)
        en%rval = user_obs_real_p (en%arg0, en%prt1)
        en%value_is_known = .true.
     case (EN_UOBS2_REAL)
        en%rval = user_obs_real_pp (en%arg0, en%prt1, en%prt2)
        en%value_is_known = .true.
     case (EN_PRT_FUN_UNARY)
        call eval_node_evaluate (en%arg1)
        en%value_is_known = en%arg1%value_is_known
        if (en%value_is_known) then
           if (associated (en%arg0)) then
              en%arg0%index => en%index
              en%arg0%prt1 => en%prt1
              call en%op1_sev (en%pval, en%arg1, en%arg0)
           else
              call en%op1_sev (en%pval, en%arg1)
           end if
        end if
     case (EN_PRT_FUN_BINARY)
        call eval_node_evaluate (en%arg1)
        call eval_node_evaluate (en%arg2)
        en%value_is_known = &
             en%arg1%value_is_known .and. en%arg2%value_is_known
        if (en%value_is_known) then
           if (associated (en%arg0)) then
              en%arg0%index => en%index
              en%arg0%prt1 => en%prt1
              en%arg0%prt2 => en%prt2
              call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0)
           else
              call en%op2_sev (en%pval, en%arg1, en%arg2)
           end if
        end if
     case (EN_EVAL_FUN_UNARY)
        call eval_node_evaluate (en%arg1)
        en%value_is_known = subevt_is_nonempty (en%arg1%pval)
        if (en%value_is_known) then
           en%arg0%index => en%index
           en%index = 1
           en%arg0%prt1 => en%prt1
           en%prt1 = subevt_get_prt (en%arg1%pval, 1)
           call eval_node_evaluate (en%arg0)
           en%rval = en%arg0%rval
        end if
     case (EN_EVAL_FUN_BINARY)
        call eval_node_evaluate (en%arg1)
        call eval_node_evaluate (en%arg2)
        en%value_is_known = &
             subevt_is_nonempty (en%arg1%pval) .and. &
             subevt_is_nonempty (en%arg2%pval)
        if (en%value_is_known) then
           en%arg0%index => en%index
           en%arg0%prt1 => en%prt1
           en%arg0%prt2 => en%prt2
           en%index = 1
           call eval_pp (en%arg1, en%arg2, en%arg0, en%rval, en%value_is_known)
        end if
     case (EN_LOG_FUN_UNARY)
        call eval_node_evaluate (en%arg1)
        en%value_is_known = .true.
        if (en%value_is_known) then
           en%arg0%index => en%index
           en%arg0%prt1 => en%prt1
           en%lval = en%op1_cut (en%arg1, en%arg0)
        end if
     case (EN_LOG_FUN_BINARY)
        call eval_node_evaluate (en%arg1)
        call eval_node_evaluate (en%arg2)
        en%value_is_known = .true.
        if (en%value_is_known) then
           en%arg0%index => en%index
           en%arg0%prt1 => en%prt1
           en%arg0%prt2 => en%prt2
           en%lval = en%op2_cut (en%arg1, en%arg2, en%arg0)
        end if
     case (EN_INT_FUN_UNARY)
        call eval_node_evaluate (en%arg1)
        en%value_is_known = en%arg1%value_is_known
        if (en%value_is_known) then
           if (associated (en%arg0)) then
              en%arg0%index => en%index
              en%arg0%prt1 => en%prt1
              call en%op1_evi (en%ival, en%arg1, en%arg0)
           else
              call en%op1_evi (en%ival, en%arg1)
           end if
        end if
     case (EN_INT_FUN_BINARY)
        call eval_node_evaluate (en%arg1)
        call eval_node_evaluate (en%arg2)
        en%value_is_known = &
             en%arg1%value_is_known .and. &
             en%arg2%value_is_known
        if (en%value_is_known) then
           if (associated (en%arg0)) then
              en%arg0%index => en%index
              en%arg0%prt1 => en%prt1
              en%arg0%prt2 => en%prt2
              call en%op2_evi (en%ival, en%arg1, en%arg2, en%arg0)
           else
              call en%op2_evi (en%ival, en%arg1, en%arg2)
           end if
        end if
     case (EN_REAL_FUN_UNARY)
        call eval_node_evaluate (en%arg1)
        en%value_is_known = en%arg1%value_is_known
        if (en%value_is_known) then
           if (associated (en%arg0)) then
              en%arg0%index => en%index
              en%arg0%prt1 => en%prt1
              call en%op1_evr (en%rval, en%arg1, en%arg0)
           else
              call en%op1_evr (en%rval, en%arg1)
           end if
        end if
     case (EN_REAL_FUN_BINARY)
        call eval_node_evaluate (en%arg1)
        call eval_node_evaluate (en%arg2)
        en%value_is_known = &
             en%arg1%value_is_known .and. &
             en%arg2%value_is_known
        if (en%value_is_known) then
           if (associated (en%arg0)) then
              en%arg0%index => en%index
              en%arg0%prt1 => en%prt1
              en%arg0%prt2 => en%prt2
              call en%op2_evr (en%rval, en%arg1, en%arg2, en%arg0)
           else
              call en%op2_evr (en%rval, en%arg1, en%arg2)
           end if
        end if
     case (EN_FORMAT_STR)
        if (associated (en%arg0)) then
           call eval_node_evaluate (en%arg0)
           en%value_is_known = en%arg0%value_is_known
        else
           en%value_is_known = .true.
        end if
        if (associated (en%arg1)) then
           call eval_node_evaluate (en%arg1)
           en%value_is_known = &
                en%value_is_known .and. en%arg1%value_is_known
           if (en%value_is_known) then
              call evaluate_sprintf (en%sval, en%ival, en%arg0, en%arg1)
           end if
        else
           if (en%value_is_known) then
              call evaluate_sprintf (en%sval, en%ival, en%arg0)
           end if
        end if
     end select
     if (debug2_active (D_MODEL_F)) then
        print *, "eval_node_evaluate"
        call eval_node_write (en)
     end if
   end subroutine eval_node_evaluate
 
 @ %def eval_node_evaluate
 @
 \subsubsection{Test method}
 This is called from a unit test: initialize a particular observable.
 <<Eval trees: eval node: TBP>>=
   procedure :: test_obs => eval_node_test_obs
 <<Eval trees: procedures>>=
   subroutine eval_node_test_obs (node, var_list, var_name)
     class(eval_node_t), intent(inout) :: node
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: var_name
     procedure(obs_unary_int), pointer :: obs1_iptr
     type(prt_t), pointer :: p1
     call var_list%get_obs1_iptr (var_name, obs1_iptr, p1)
     call eval_node_init_obs1_int_ptr (node, var_name, obs1_iptr, p1)
   end subroutine eval_node_test_obs
 
 @ %def eval_node_test_obs
 @
 \subsection{Evaluation syntax}
 We have two different flavors of the syntax: with and without particles.
 <<Eval trees: public>>=
   public :: syntax_expr
   public :: syntax_pexpr
 <<Eval trees: variables>>=
   type(syntax_t), target, save :: syntax_expr
   type(syntax_t), target, save :: syntax_pexpr
 
 @ %def syntax_expr syntax_pexpr
 @ These are for testing only and may be removed:
 <<Eval trees: public>>=
   public :: syntax_expr_init
   public :: syntax_pexpr_init
 <<Eval trees: procedures>>=
   subroutine syntax_expr_init ()
     type(ifile_t) :: ifile
     call define_expr_syntax (ifile, particles=.false., analysis=.false.)
     call syntax_init (syntax_expr, ifile)
     call ifile_final (ifile)
   end subroutine syntax_expr_init
 
   subroutine syntax_pexpr_init ()
     type(ifile_t) :: ifile
     call define_expr_syntax (ifile, particles=.true., analysis=.false.)
     call syntax_init (syntax_pexpr, ifile)
     call ifile_final (ifile)
   end subroutine syntax_pexpr_init
 
 @ %def syntax_expr_init syntax_pexpr_init
 <<Eval trees: public>>=
   public :: syntax_expr_final
   public :: syntax_pexpr_final
 <<Eval trees: procedures>>=
   subroutine syntax_expr_final ()
     call syntax_final (syntax_expr)
   end subroutine syntax_expr_final
 
   subroutine syntax_pexpr_final ()
     call syntax_final (syntax_pexpr)
   end subroutine syntax_pexpr_final
 
 @ %def syntax_expr_final syntax_pexpr_final
 <<Eval trees: public>>=
   public :: syntax_pexpr_write
 <<Eval trees: procedures>>=
   subroutine syntax_pexpr_write (unit)
     integer, intent(in), optional :: unit
     call syntax_write (syntax_pexpr, unit)
   end subroutine syntax_pexpr_write
 
 @ %def syntax_pexpr_write
 <<Eval trees: public>>=
   public :: define_expr_syntax
 @ Numeric expressions.
 <<Eval trees: procedures>>=
   subroutine define_expr_syntax (ifile, particles, analysis)
     type(ifile_t), intent(inout) :: ifile
     logical, intent(in) :: particles, analysis
     type(string_t) :: numeric_pexpr
     type(string_t) :: var_plist, var_alias
     if (particles) then
        numeric_pexpr = " | numeric_pexpr"
        var_plist = " | var_plist"
        var_alias = " | var_alias"
     else
        numeric_pexpr = ""
        var_plist = ""
        var_alias = ""
     end if
     call ifile_append (ifile, "SEQ expr = subexpr addition*")
     call ifile_append (ifile, "ALT subexpr = addition | term")
     call ifile_append (ifile, "SEQ addition = plus_or_minus term")
     call ifile_append (ifile, "SEQ term = factor multiplication*")
     call ifile_append (ifile, "SEQ multiplication = times_or_over factor")
     call ifile_append (ifile, "SEQ factor = value exponentiation?")
     call ifile_append (ifile, "SEQ exponentiation = to_the value")
     call ifile_append (ifile, "ALT plus_or_minus = '+' | '-'")
     call ifile_append (ifile, "ALT times_or_over = '*' | '/'")
     call ifile_append (ifile, "ALT to_the = '^' | '**'")
     call ifile_append (ifile, "KEY '+'")
     call ifile_append (ifile, "KEY '-'")
     call ifile_append (ifile, "KEY '*'")
     call ifile_append (ifile, "KEY '/'")
     call ifile_append (ifile, "KEY '^'")
     call ifile_append (ifile, "KEY '**'")
     call ifile_append (ifile, "ALT value = signed_value | unsigned_value")
     call ifile_append (ifile, "SEQ signed_value = '-' unsigned_value")
     call ifile_append (ifile, "ALT unsigned_value = " // &
          "numeric_value | constant | variable | " // &
          "result | user_observable | " // &
          "grouped_expr | block_expr | conditional_expr | " // &
          "unary_function | binary_function" // &
          numeric_pexpr)
     call ifile_append (ifile, "ALT numeric_value = integer_value | " &
          // "real_value | complex_value")
     call ifile_append (ifile, "SEQ integer_value = integer_literal unit_expr?")
     call ifile_append (ifile, "SEQ real_value = real_literal unit_expr?")
     call ifile_append (ifile, "SEQ complex_value = complex_literal unit_expr?")
     call ifile_append (ifile, "INT integer_literal")
     call ifile_append (ifile, "REA real_literal")
     call ifile_append (ifile, "COM complex_literal")
     call ifile_append (ifile, "SEQ unit_expr = unit unit_power?")
     call ifile_append (ifile, "ALT unit = " // &
          "TeV | GeV | MeV | keV | eV | meV | " // &
          "nbarn | pbarn | fbarn | abarn | " // &
          "rad | mrad | degree | '%'")
     call ifile_append (ifile, "KEY TeV")
     call ifile_append (ifile, "KEY GeV")
     call ifile_append (ifile, "KEY MeV")
     call ifile_append (ifile, "KEY keV")
     call ifile_append (ifile, "KEY eV")
     call ifile_append (ifile, "KEY meV")
     call ifile_append (ifile, "KEY nbarn")
     call ifile_append (ifile, "KEY pbarn")
     call ifile_append (ifile, "KEY fbarn")
     call ifile_append (ifile, "KEY abarn")
     call ifile_append (ifile, "KEY rad")
     call ifile_append (ifile, "KEY mrad")
     call ifile_append (ifile, "KEY degree")
     call ifile_append (ifile, "KEY '%'")
     call ifile_append (ifile, "SEQ unit_power = '^' frac_expr")
     call ifile_append (ifile, "ALT frac_expr = frac | grouped_frac")
     call ifile_append (ifile, "GRO grouped_frac = ( frac_expr )")
     call ifile_append (ifile, "SEQ frac = signed_int div?")
     call ifile_append (ifile, "ALT signed_int = " &
          // "neg_int | pos_int | integer_literal")
     call ifile_append (ifile, "SEQ neg_int = '-' integer_literal")
     call ifile_append (ifile, "SEQ pos_int = '+' integer_literal")
     call ifile_append (ifile, "SEQ div = '/' integer_literal")
     call ifile_append (ifile, "ALT constant = pi | I")
     call ifile_append (ifile, "KEY pi")
     call ifile_append (ifile, "KEY I")
     call ifile_append (ifile, "IDE variable")
     call ifile_append (ifile, "SEQ result = result_key result_arg")
     call ifile_append (ifile, "ALT result_key = " // &
          "num_id | integral | error")
     call ifile_append (ifile, "SEQ user_observable = user_obs user_arg")
     call ifile_append (ifile, "KEY user_obs")
     call ifile_append (ifile, "ARG user_arg = ( sexpr )")
     call ifile_append (ifile, "KEY num_id")
     call ifile_append (ifile, "KEY integral")
     call ifile_append (ifile, "KEY error")
     call ifile_append (ifile, "GRO result_arg = ( process_id )")
     call ifile_append (ifile, "IDE process_id")
     call ifile_append (ifile, "SEQ unary_function = fun_unary function_arg1")
     call ifile_append (ifile, "SEQ binary_function = fun_binary function_arg2")
     call ifile_append (ifile, "ALT fun_unary = " // &
          "complex | real | int | nint | floor | ceiling | abs | conjg | sgn | " // &
          "sqrt | exp | log | log10 | " // &
          "sin | cos | tan | asin | acos | atan | " // &
          "sinh | cosh | tanh | asinh | acosh | atanh")
     call ifile_append (ifile, "KEY complex")
     call ifile_append (ifile, "KEY real")
     call ifile_append (ifile, "KEY int")
     call ifile_append (ifile, "KEY nint")
     call ifile_append (ifile, "KEY floor")
     call ifile_append (ifile, "KEY ceiling")
     call ifile_append (ifile, "KEY abs")
     call ifile_append (ifile, "KEY conjg")
     call ifile_append (ifile, "KEY sgn")
     call ifile_append (ifile, "KEY sqrt")
     call ifile_append (ifile, "KEY exp")
     call ifile_append (ifile, "KEY log")
     call ifile_append (ifile, "KEY log10")
     call ifile_append (ifile, "KEY sin")
     call ifile_append (ifile, "KEY cos")
     call ifile_append (ifile, "KEY tan")
     call ifile_append (ifile, "KEY asin")
     call ifile_append (ifile, "KEY acos")
     call ifile_append (ifile, "KEY atan")
     call ifile_append (ifile, "KEY sinh")
     call ifile_append (ifile, "KEY cosh")
     call ifile_append (ifile, "KEY tanh")
     call ifile_append (ifile, "KEY asinh")
     call ifile_append (ifile, "KEY acosh")
     call ifile_append (ifile, "KEY atanh")
     call ifile_append (ifile, "ALT fun_binary = max | min | mod | modulo")
     call ifile_append (ifile, "KEY max")
     call ifile_append (ifile, "KEY min")
     call ifile_append (ifile, "KEY mod")
     call ifile_append (ifile, "KEY modulo")
     call ifile_append (ifile, "ARG function_arg1 = ( expr )")
     call ifile_append (ifile, "ARG function_arg2 = ( expr, expr )")
     call ifile_append (ifile, "GRO grouped_expr = ( expr )")
     call ifile_append (ifile, "SEQ block_expr = let var_spec in expr")
     call ifile_append (ifile, "KEY let")
     call ifile_append (ifile, "ALT var_spec = " // &
          "var_num | var_int | var_real | var_complex | " // &
          "var_logical" // var_plist // var_alias // " | var_string")
     call ifile_append (ifile, "SEQ var_num = var_name '=' expr")
     call ifile_append (ifile, "SEQ var_int = int var_name '=' expr")
     call ifile_append (ifile, "SEQ var_real = real var_name '=' expr")
     call ifile_append (ifile, "SEQ var_complex = complex var_name '=' complex_expr")
     call ifile_append (ifile, "ALT complex_expr = " // &
          "cexpr_real | cexpr_complex")
     call ifile_append (ifile, "ARG cexpr_complex = ( expr, expr )")
     call ifile_append (ifile, "SEQ cexpr_real = expr")
     call ifile_append (ifile, "IDE var_name")
     call ifile_append (ifile, "KEY '='")
     call ifile_append (ifile, "KEY in")
     call ifile_append (ifile, "SEQ conditional_expr = " // &
          "if lexpr then expr maybe_elsif_expr maybe_else_expr endif")
     call ifile_append (ifile, "SEQ maybe_elsif_expr = elsif_expr*")
     call ifile_append (ifile, "SEQ maybe_else_expr = else_expr?")
     call ifile_append (ifile, "SEQ elsif_expr = elsif lexpr then expr")
     call ifile_append (ifile, "SEQ else_expr = else expr")
     call ifile_append (ifile, "KEY if")
     call ifile_append (ifile, "KEY then")
     call ifile_append (ifile, "KEY elsif")
     call ifile_append (ifile, "KEY else")
     call ifile_append (ifile, "KEY endif")
     call define_lexpr_syntax (ifile, particles, analysis)
     call define_sexpr_syntax (ifile)
     if (particles) then
        call define_pexpr_syntax (ifile)
        call define_cexpr_syntax (ifile)
        call define_var_plist_syntax (ifile)
        call define_var_alias_syntax (ifile)
        call define_numeric_pexpr_syntax (ifile)
        call define_logical_pexpr_syntax (ifile)
     end if
 
   end subroutine define_expr_syntax
 
 @ %def define_expr_syntax
 @ Logical expressions.
 <<Eval trees: procedures>>=
   subroutine define_lexpr_syntax (ifile, particles, analysis)
     type(ifile_t), intent(inout) :: ifile
     logical, intent(in) :: particles, analysis
     type(string_t) :: logical_pexpr, record_cmd
     if (particles) then
        logical_pexpr = " | logical_pexpr"
     else
        logical_pexpr = ""
     end if
     if (analysis) then
        record_cmd = " | record_cmd"
     else
        record_cmd = ""
     end if
     call ifile_append (ifile, "SEQ lexpr = lsinglet lsequel*")
     call ifile_append (ifile, "SEQ lsequel = ';' lsinglet")
     call ifile_append (ifile, "SEQ lsinglet = lterm alternative*")
     call ifile_append (ifile, "SEQ alternative = or lterm")
     call ifile_append (ifile, "SEQ lterm = lvalue coincidence*")
     call ifile_append (ifile, "SEQ coincidence = and lvalue")
     call ifile_append (ifile, "KEY ';'")
     call ifile_append (ifile, "KEY or")
     call ifile_append (ifile, "KEY and")
     call ifile_append (ifile, "ALT lvalue = " // &
          "true | false | lvariable | negation | " // &
          "grouped_lexpr | block_lexpr | conditional_lexpr | " // &
          "compared_expr | compared_sexpr" // &
          logical_pexpr //  record_cmd)
     call ifile_append (ifile, "KEY true")
     call ifile_append (ifile, "KEY false")
     call ifile_append (ifile, "SEQ lvariable = '?' alt_lvariable")
     call ifile_append (ifile, "KEY '?'")
     call ifile_append (ifile, "ALT alt_lvariable = variable | grouped_lexpr")
     call ifile_append (ifile, "SEQ negation = not lvalue")
     call ifile_append (ifile, "KEY not")
     call ifile_append (ifile, "GRO grouped_lexpr = ( lexpr )")
     call ifile_append (ifile, "SEQ block_lexpr = let var_spec in lexpr")
     call ifile_append (ifile, "ALT var_logical = " // &
          "var_logical_new | var_logical_spec")
     call ifile_append (ifile, "SEQ var_logical_new = logical var_logical_spec")
     call ifile_append (ifile, "KEY logical")
     call ifile_append (ifile, "SEQ var_logical_spec = '?' var_name = lexpr")
     call ifile_append (ifile, "SEQ conditional_lexpr = " // &
          "if lexpr then lexpr maybe_elsif_lexpr maybe_else_lexpr endif")
     call ifile_append (ifile, "SEQ maybe_elsif_lexpr = elsif_lexpr*")
     call ifile_append (ifile, "SEQ maybe_else_lexpr = else_lexpr?")
     call ifile_append (ifile, "SEQ elsif_lexpr = elsif lexpr then lexpr")
     call ifile_append (ifile, "SEQ else_lexpr = else lexpr")
     call ifile_append (ifile, "SEQ compared_expr = expr comparison+")
     call ifile_append (ifile, "SEQ comparison = compare expr")
     call ifile_append (ifile, "ALT compare = " // &
          "'<' | '>' | '<=' | '>=' | '==' | '<>'")
     call ifile_append (ifile, "KEY '<'")
     call ifile_append (ifile, "KEY '>'")
     call ifile_append (ifile, "KEY '<='")
     call ifile_append (ifile, "KEY '>='")
     call ifile_append (ifile, "KEY '=='")
     call ifile_append (ifile, "KEY '<>'")
     call ifile_append (ifile, "SEQ compared_sexpr = sexpr str_comparison+")
     call ifile_append (ifile, "SEQ str_comparison = str_compare sexpr")
     call ifile_append (ifile, "ALT str_compare = '==' | '<>'")
     if (analysis) then
        call ifile_append (ifile, "SEQ record_cmd = " // &
             "record_key analysis_tag record_arg?")
        call ifile_append (ifile, "ALT record_key = " // &
             "record | record_unweighted | record_excess")
        call ifile_append (ifile, "KEY record")
        call ifile_append (ifile, "KEY record_unweighted")
        call ifile_append (ifile, "KEY record_excess")
        call ifile_append (ifile, "ALT analysis_tag = analysis_id | sexpr")
        call ifile_append (ifile, "IDE analysis_id")
        call ifile_append (ifile, "ARG record_arg = ( expr+ )")
     end if
   end subroutine define_lexpr_syntax
 
 @ %def define_lexpr_syntax
 @ String expressions.
 <<Eval trees: procedures>>=
   subroutine define_sexpr_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ sexpr = svalue str_concatenation*")
     call ifile_append (ifile, "SEQ str_concatenation = '&' svalue")
     call ifile_append (ifile, "KEY '&'")
     call ifile_append (ifile, "ALT svalue = " // &
          "grouped_sexpr | block_sexpr | conditional_sexpr | " // &
          "svariable | string_function | string_literal")
     call ifile_append (ifile, "GRO grouped_sexpr = ( sexpr )")
     call ifile_append (ifile, "SEQ block_sexpr = let var_spec in sexpr")
     call ifile_append (ifile, "SEQ conditional_sexpr = " // &
          "if lexpr then sexpr maybe_elsif_sexpr maybe_else_sexpr endif")
     call ifile_append (ifile, "SEQ maybe_elsif_sexpr = elsif_sexpr*")
     call ifile_append (ifile, "SEQ maybe_else_sexpr = else_sexpr?")
     call ifile_append (ifile, "SEQ elsif_sexpr = elsif lexpr then sexpr")
     call ifile_append (ifile, "SEQ else_sexpr = else sexpr")
     call ifile_append (ifile, "SEQ svariable = '$' alt_svariable")
     call ifile_append (ifile, "KEY '$'")
     call ifile_append (ifile, "ALT alt_svariable = variable | grouped_sexpr")
     call ifile_append (ifile, "ALT var_string = " // &
          "var_string_new | var_string_spec")
     call ifile_append (ifile, "SEQ var_string_new = string var_string_spec")
     call ifile_append (ifile, "KEY string")
     call ifile_append (ifile, "SEQ var_string_spec = '$' var_name = sexpr") ! $
     call ifile_append (ifile, "ALT string_function = sprintf_fun")
     call ifile_append (ifile, "SEQ sprintf_fun = sprintf_clause sprintf_args?")
     call ifile_append (ifile, "SEQ sprintf_clause = sprintf sexpr")
     call ifile_append (ifile, "KEY sprintf")
     call ifile_append (ifile, "ARG sprintf_args = ( sprintf_arg* )")
     call ifile_append (ifile, "ALT sprintf_arg = " &
          // "lvariable | svariable | expr")
     call ifile_append (ifile, "QUO string_literal = '""'...'""'")
   end subroutine define_sexpr_syntax
 
 @ %def define_sexpr_syntax
 @ Eval trees that evaluate to subevents.
 <<Eval trees: procedures>>=
   subroutine define_pexpr_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ pexpr = pterm pconcatenation*")
     call ifile_append (ifile, "SEQ pconcatenation = '&' pterm")
     ! call ifile_append (ifile, "KEY '&'")   !!! (Key exists already)
     call ifile_append (ifile, "SEQ pterm = pvalue pcombination*")
     call ifile_append (ifile, "SEQ pcombination = '+' pvalue")
     ! call ifile_append (ifile, "KEY '+'")   !!! (Key exists already)
     call ifile_append (ifile, "ALT pvalue = " // &
          "pexpr_src | pvariable | " // &
          "grouped_pexpr | block_pexpr | conditional_pexpr | " // &
          "prt_function")
     call ifile_append (ifile, "SEQ pexpr_src = prefix_cexpr")
     call ifile_append (ifile, "ALT prefix_cexpr = " // &
          "beam_prt | incoming_prt | outgoing_prt | unspecified_prt")
     call ifile_append (ifile, "SEQ beam_prt = beam cexpr")
     call ifile_append (ifile, "KEY beam")
     call ifile_append (ifile, "SEQ incoming_prt = incoming cexpr")
     call ifile_append (ifile, "KEY incoming")
     call ifile_append (ifile, "SEQ outgoing_prt = outgoing cexpr")
     call ifile_append (ifile, "KEY outgoing")
     call ifile_append (ifile, "SEQ unspecified_prt = cexpr")
     call ifile_append (ifile, "SEQ pvariable = '@' alt_pvariable")
     call ifile_append (ifile, "KEY '@'")
     call ifile_append (ifile, "ALT alt_pvariable = variable | grouped_pexpr")
     call ifile_append (ifile, "GRO grouped_pexpr = '[' pexpr ']'")
     call ifile_append (ifile, "SEQ block_pexpr = let var_spec in pexpr")
     call ifile_append (ifile, "SEQ conditional_pexpr = " // &
          "if lexpr then pexpr maybe_elsif_pexpr maybe_else_pexpr endif")
     call ifile_append (ifile, "SEQ maybe_elsif_pexpr = elsif_pexpr*")
     call ifile_append (ifile, "SEQ maybe_else_pexpr = else_pexpr?")
     call ifile_append (ifile, "SEQ elsif_pexpr = elsif lexpr then pexpr")
     call ifile_append (ifile, "SEQ else_pexpr = else pexpr")
     call ifile_append (ifile, "ALT prt_function = " // &
          "join_fun | combine_fun | collect_fun | cluster_fun | " // &
          "select_fun | extract_fun | sort_fun | " // &
          "select_b_jet_fun | select_non_b_jet_fun | " // &
          "select_c_jet_fun | select_light_jet_fun")
     call ifile_append (ifile, "SEQ join_fun = join_clause pargs2")
     call ifile_append (ifile, "SEQ combine_fun = combine_clause pargs2")
     call ifile_append (ifile, "SEQ collect_fun = collect_clause pargs1")
     call ifile_append (ifile, "SEQ cluster_fun = cluster_clause pargs1")
     call ifile_append (ifile, "SEQ select_fun = select_clause pargs1")
     call ifile_append (ifile, "SEQ extract_fun = extract_clause pargs1")
     call ifile_append (ifile, "SEQ sort_fun = sort_clause pargs1")
     call ifile_append (ifile, "SEQ select_b_jet_fun = " // &
           "select_b_jet_clause pargs1")
     call ifile_append (ifile, "SEQ select_non_b_jet_fun = " // &
           "select_non_b_jet_clause pargs1")
     call ifile_append (ifile, "SEQ select_c_jet_fun = " // &
           "select_c_jet_clause pargs1")
     call ifile_append (ifile, "SEQ select_light_jet_fun = " // &
           "select_light_jet_clause pargs1")
     call ifile_append (ifile, "SEQ join_clause = join condition?")
     call ifile_append (ifile, "SEQ combine_clause = combine condition?")
     call ifile_append (ifile, "SEQ collect_clause = collect condition?")
     call ifile_append (ifile, "SEQ cluster_clause = cluster condition?")
     call ifile_append (ifile, "SEQ select_clause = select condition?")
     call ifile_append (ifile, "SEQ extract_clause = extract position?")
     call ifile_append (ifile, "SEQ sort_clause = sort criterion?")
     call ifile_append (ifile, "SEQ select_b_jet_clause = " // &
          "select_b_jet condition?")
     call ifile_append (ifile, "SEQ select_non_b_jet_clause = " // &
          "select_non_b_jet condition?")
     call ifile_append (ifile, "SEQ select_c_jet_clause = " // &
          "select_c_jet condition?")
     call ifile_append (ifile, "SEQ select_light_jet_clause = " // &
          "select_light_jet condition?")
     call ifile_append (ifile, "KEY join")
     call ifile_append (ifile, "KEY combine")
     call ifile_append (ifile, "KEY collect")
     call ifile_append (ifile, "KEY cluster")
     call ifile_append (ifile, "KEY select")
     call ifile_append (ifile, "SEQ condition = if lexpr")
     call ifile_append (ifile, "KEY extract")
     call ifile_append (ifile, "SEQ position = index expr")
     call ifile_append (ifile, "KEY sort")
     call ifile_append (ifile, "KEY select_b_jet")
     call ifile_append (ifile, "KEY select_non_b_jet")
     call ifile_append (ifile, "KEY select_c_jet")
     call ifile_append (ifile, "KEY select_light_jet")
     call ifile_append (ifile, "SEQ criterion = by expr")
     call ifile_append (ifile, "KEY index")
     call ifile_append (ifile, "KEY by")
     call ifile_append (ifile, "ARG pargs2 = '[' pexpr, pexpr ']'")
     call ifile_append (ifile, "ARG pargs1 = '[' pexpr, pexpr? ']'")
   end subroutine define_pexpr_syntax
 
 @ %def define_pexpr_syntax
 @ Eval trees that evaluate to PDG-code arrays.
 <<Eval trees: procedures>>=
   subroutine define_cexpr_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ cexpr = avalue concatenation*")
     call ifile_append (ifile, "SEQ concatenation = ':' avalue")
     call ifile_append (ifile, "KEY ':'")
     call ifile_append (ifile, "ALT avalue = " // &
          "grouped_cexpr | block_cexpr | conditional_cexpr | " // &
          "variable | pdg_code | prt_name")
     call ifile_append (ifile, "GRO grouped_cexpr = ( cexpr )")
     call ifile_append (ifile, "SEQ block_cexpr = let var_spec in cexpr")
     call ifile_append (ifile, "SEQ conditional_cexpr = " // &
          "if lexpr then cexpr maybe_elsif_cexpr maybe_else_cexpr endif")
     call ifile_append (ifile, "SEQ maybe_elsif_cexpr = elsif_cexpr*")
     call ifile_append (ifile, "SEQ maybe_else_cexpr = else_cexpr?")
     call ifile_append (ifile, "SEQ elsif_cexpr = elsif lexpr then cexpr")
     call ifile_append (ifile, "SEQ else_cexpr = else cexpr")
     call ifile_append (ifile, "SEQ pdg_code = pdg pdg_arg")
     call ifile_append (ifile, "KEY pdg")
     call ifile_append (ifile, "ARG pdg_arg = ( expr )")
     call ifile_append (ifile, "QUO prt_name = '""'...'""'")
   end subroutine define_cexpr_syntax
 
 @ %def define_cexpr_syntax
 @ Extra variable types.
 <<Eval trees: procedures>>=
   subroutine define_var_plist_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "ALT var_plist = var_plist_new | var_plist_spec")
     call ifile_append (ifile, "SEQ var_plist_new = subevt var_plist_spec")
     call ifile_append (ifile, "KEY subevt")
     call ifile_append (ifile, "SEQ var_plist_spec = '@' var_name '=' pexpr")
   end subroutine define_var_plist_syntax
 
   subroutine define_var_alias_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ var_alias = alias var_name '=' cexpr")
     call ifile_append (ifile, "KEY alias")
   end subroutine define_var_alias_syntax
 
 @ %def define_var_plist_syntax define_var_alias_syntax
 @ Particle-list expressions that evaluate to numeric values
 <<Eval trees: procedures>>=
   subroutine define_numeric_pexpr_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "ALT numeric_pexpr = " &
          // "eval_fun | count_fun | event_shape_fun")
     call ifile_append (ifile, "SEQ eval_fun = eval expr pargs1")
     call ifile_append (ifile, "SEQ count_fun = count_clause pargs1")
     call ifile_append (ifile, "SEQ count_clause = count condition?")
     call ifile_append (ifile, "KEY eval")
     call ifile_append (ifile, "KEY count")
     call ifile_append (ifile, "ALT event_shape_fun = user_event_fun")
     call ifile_append (ifile, "SEQ user_event_fun = " &
          // "user_event_shape user_arg pargs1")
     call ifile_append (ifile, "KEY user_event_shape")
   end subroutine define_numeric_pexpr_syntax
 
 @ %def define_numeric_pexpr_syntax
 @ Particle-list functions that evaluate to logical values.
 <<Eval trees: procedures>>=
   subroutine define_logical_pexpr_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "ALT logical_pexpr = " // &
          "all_fun | any_fun | no_fun | user_cut_fun |" // &
          "photon_isolation_fun")
     call ifile_append (ifile, "SEQ all_fun = all lexpr pargs1")
     call ifile_append (ifile, "SEQ any_fun = any lexpr pargs1")
     call ifile_append (ifile, "SEQ no_fun = no lexpr pargs1")
     call ifile_append (ifile, "SEQ photon_isolation_fun = " // &
          "photon_isolation_clause pargs2")
     call ifile_append (ifile, "SEQ photon_isolation_clause = " // &
          "photon_isolation condition?")
     call ifile_append (ifile, "KEY all")
     call ifile_append (ifile, "KEY any")
     call ifile_append (ifile, "KEY no")
     call ifile_append (ifile, "KEY photon_isolation")
     call ifile_append (ifile, "SEQ user_cut_fun = user_cut user_arg pargs1")
     call ifile_append (ifile, "KEY user_cut")
   end subroutine define_logical_pexpr_syntax
 
 @ %def define_logical_pexpr_syntax
 @ All characters that can occur in expressions (apart from alphanumeric).
 <<Eval trees: procedures>>=
   subroutine lexer_init_eval_tree (lexer, particles)
     type(lexer_t), intent(out) :: lexer
     logical, intent(in) :: particles
     type(keyword_list_t), pointer :: keyword_list
     if (particles) then
        keyword_list => syntax_get_keyword_list_ptr (syntax_pexpr)
     else
        keyword_list => syntax_get_keyword_list_ptr (syntax_expr)
     end if
     call lexer_init (lexer, &
          comment_chars = "#!", &
          quote_chars = '"', &
          quote_match = '"', &
          single_chars = "()[],;:&%?$@", &
          special_class = [ "+-*/^", "<>=~ " ] , &
          keyword_list = keyword_list)
   end subroutine lexer_init_eval_tree
 
 @ %def lexer_init_eval_tree
 @
 \subsection{Set up appropriate parse trees}
 Parse an input stream as a specific flavor of expression.  The
 appropriate expression syntax has to be available.
 <<Eval trees: public>>=
   public :: parse_tree_init_expr
   public :: parse_tree_init_lexpr
   public :: parse_tree_init_pexpr
   public :: parse_tree_init_cexpr
   public :: parse_tree_init_sexpr
 <<Eval trees: procedures>>=
   subroutine parse_tree_init_expr (parse_tree, stream, particles)
     type(parse_tree_t), intent(out) :: parse_tree
     type(stream_t), intent(inout), target :: stream
     logical, intent(in) :: particles
     type(lexer_t) :: lexer
     call lexer_init_eval_tree (lexer, particles)
     call lexer_assign_stream (lexer, stream)
     if (particles) then
        call parse_tree_init &
             (parse_tree, syntax_pexpr, lexer, var_str ("expr"))
     else
        call parse_tree_init &
             (parse_tree, syntax_expr, lexer, var_str ("expr"))
     end if
     call lexer_final (lexer)
   end subroutine parse_tree_init_expr
 
   subroutine parse_tree_init_lexpr (parse_tree, stream, particles)
     type(parse_tree_t), intent(out) :: parse_tree
     type(stream_t), intent(inout), target :: stream
     logical, intent(in) :: particles
     type(lexer_t) :: lexer
     call lexer_init_eval_tree (lexer, particles)
     call lexer_assign_stream (lexer, stream)
     if (particles) then
        call parse_tree_init &
             (parse_tree, syntax_pexpr, lexer, var_str ("lexpr"))
     else
        call parse_tree_init &
             (parse_tree, syntax_expr, lexer, var_str ("lexpr"))
     end if
     call lexer_final (lexer)
   end subroutine parse_tree_init_lexpr
 
   subroutine parse_tree_init_pexpr (parse_tree, stream)
     type(parse_tree_t), intent(out) :: parse_tree
     type(stream_t), intent(inout), target :: stream
     type(lexer_t) :: lexer
     call lexer_init_eval_tree (lexer, .true.)
     call lexer_assign_stream (lexer, stream)
     call parse_tree_init &
          (parse_tree, syntax_pexpr, lexer, var_str ("pexpr"))
     call lexer_final (lexer)
   end subroutine parse_tree_init_pexpr
 
   subroutine parse_tree_init_cexpr (parse_tree, stream)
     type(parse_tree_t), intent(out) :: parse_tree
     type(stream_t), intent(inout), target :: stream
     type(lexer_t) :: lexer
     call lexer_init_eval_tree (lexer, .true.)
     call lexer_assign_stream (lexer, stream)
     call parse_tree_init &
          (parse_tree, syntax_pexpr, lexer, var_str ("cexpr"))
     call lexer_final (lexer)
   end subroutine parse_tree_init_cexpr
 
   subroutine parse_tree_init_sexpr (parse_tree, stream, particles)
     type(parse_tree_t), intent(out) :: parse_tree
     type(stream_t), intent(inout), target :: stream
     logical, intent(in) :: particles
     type(lexer_t) :: lexer
     call lexer_init_eval_tree (lexer, particles)
     call lexer_assign_stream (lexer, stream)
     if (particles) then
        call parse_tree_init &
             (parse_tree, syntax_pexpr, lexer, var_str ("sexpr"))
     else
        call parse_tree_init &
             (parse_tree, syntax_expr, lexer, var_str ("sexpr"))
     end if
     call lexer_final (lexer)
   end subroutine parse_tree_init_sexpr
 
 @ %def parse_tree_init_expr
 @ %def parse_tree_init_lexpr
 @ %def parse_tree_init_pexpr
 @ %def parse_tree_init_cexpr
 @ %def parse_tree_init_sexpr
 @
 \subsection{The evaluation tree}
 The evaluation tree contains the initial variable list and the root node.
 <<Eval trees: public>>=
   public :: eval_tree_t
 <<Eval trees: types>>=
   type, extends (expr_t) :: eval_tree_t
      private
      type(parse_node_t), pointer :: pn => null ()
      type(var_list_t) :: var_list
      type(eval_node_t), pointer :: root => null ()
    contains
    <<Eval trees: eval tree: TBP>>
   end type eval_tree_t
 
 @ %def eval_tree_t
 @ Init from stream, using a temporary parse tree.
 <<Eval trees: eval tree: TBP>>=
   procedure :: init_stream => eval_tree_init_stream
 <<Eval trees: procedures>>=
   subroutine eval_tree_init_stream &
        (eval_tree, stream, var_list, subevt, result_type)
     class(eval_tree_t), intent(out), target :: eval_tree
     type(stream_t), intent(inout), target :: stream
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), target, optional :: subevt
     integer, intent(in), optional :: result_type
     type(parse_tree_t) :: parse_tree
     type(parse_node_t), pointer :: nd_root
     integer :: type
     type = V_REAL;  if (present (result_type))  type = result_type
     select case (type)
     case (V_INT, V_REAL, V_CMPLX)
        call parse_tree_init_expr (parse_tree, stream, present (subevt))
     case (V_LOG)
        call parse_tree_init_lexpr (parse_tree, stream, present (subevt))
     case (V_SEV)
        call parse_tree_init_pexpr (parse_tree, stream)
     case (V_PDG)
        call parse_tree_init_cexpr (parse_tree, stream)
     case (V_STR)
        call parse_tree_init_sexpr (parse_tree, stream, present (subevt))
     end select
     nd_root => parse_tree%get_root_ptr ()
     if (associated (nd_root)) then
        select case (type)
        case (V_INT, V_REAL, V_CMPLX)
           call eval_tree_init_expr (eval_tree, nd_root, var_list, subevt)
        case (V_LOG)
           call eval_tree_init_lexpr (eval_tree, nd_root, var_list, subevt)
        case (V_SEV)
           call eval_tree_init_pexpr (eval_tree, nd_root, var_list, subevt)
        case (V_PDG)
           call eval_tree_init_cexpr (eval_tree, nd_root, var_list, subevt)
        case (V_STR)
           call eval_tree_init_sexpr (eval_tree, nd_root, var_list, subevt)
        end select
     end if
     call parse_tree_final (parse_tree)
   end subroutine eval_tree_init_stream
 
 @ %def eval_tree_init_stream
 @ API (to be superseded by the methods below): Init from a given parse-tree
 node.  If we evaluate an expression that contains particle-list references,
 the original subevent has to be supplied.  The initial variable list is
 optional.
 <<Eval trees: eval tree: TBP>>=
   procedure :: init_expr  => eval_tree_init_expr
   procedure :: init_lexpr => eval_tree_init_lexpr
   procedure :: init_pexpr => eval_tree_init_pexpr
   procedure :: init_cexpr => eval_tree_init_cexpr
   procedure :: init_sexpr => eval_tree_init_sexpr
 <<Eval trees: procedures>>=
   subroutine eval_tree_init_expr &
       (expr, parse_node, var_list, subevt)
     class(eval_tree_t), intent(out), target :: expr
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     call eval_tree_link_var_list (expr, var_list)
     if (present (subevt))  call eval_tree_set_subevt (expr, subevt)
     call eval_node_compile_expr &
          (expr%root, parse_node, expr%var_list)
   end subroutine eval_tree_init_expr
 
   subroutine eval_tree_init_lexpr &
       (expr, parse_node, var_list, subevt)
     class(eval_tree_t), intent(out), target :: expr
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     call eval_tree_link_var_list (expr, var_list)
     if (present (subevt))  call eval_tree_set_subevt (expr, subevt)
     call eval_node_compile_lexpr &
          (expr%root, parse_node, expr%var_list)
   end subroutine eval_tree_init_lexpr
 
   subroutine eval_tree_init_pexpr &
       (expr, parse_node, var_list, subevt)
     class(eval_tree_t), intent(out), target :: expr
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     call eval_tree_link_var_list (expr, var_list)
     if (present (subevt))  call eval_tree_set_subevt (expr, subevt)
     call eval_node_compile_pexpr &
          (expr%root, parse_node, expr%var_list)
   end subroutine eval_tree_init_pexpr
 
   subroutine eval_tree_init_cexpr &
       (expr, parse_node, var_list, subevt)
     class(eval_tree_t), intent(out), target :: expr
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     call eval_tree_link_var_list (expr, var_list)
     if (present (subevt))  call eval_tree_set_subevt (expr, subevt)
     call eval_node_compile_cexpr &
          (expr%root, parse_node, expr%var_list)
   end subroutine eval_tree_init_cexpr
 
   subroutine eval_tree_init_sexpr &
       (expr, parse_node, var_list, subevt)
     class(eval_tree_t), intent(out), target :: expr
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     call eval_tree_link_var_list (expr, var_list)
     if (present (subevt))  call eval_tree_set_subevt (expr, subevt)
     call eval_node_compile_sexpr &
          (expr%root, parse_node, expr%var_list)
   end subroutine eval_tree_init_sexpr
 
 @ %def eval_tree_init_expr
 @ %def eval_tree_init_lexpr
 @ %def eval_tree_init_pexpr
 @ %def eval_tree_init_cexpr
 @ %def eval_tree_init_sexpr
 @ Alternative: set up the expression using the parse node that has already
 been stored.  We assume that the [[subevt]] or any other variable that
 may be referred to has already been added to the local variable list.
 <<Eval trees: eval tree: TBP>>=
   procedure :: setup_expr  => eval_tree_setup_expr
   procedure :: setup_lexpr => eval_tree_setup_lexpr
   procedure :: setup_pexpr => eval_tree_setup_pexpr
   procedure :: setup_cexpr => eval_tree_setup_cexpr
   procedure :: setup_sexpr => eval_tree_setup_sexpr
 <<Eval trees: procedures>>=
   subroutine eval_tree_setup_expr (expr, vars)
     class(eval_tree_t), intent(inout), target :: expr
     class(vars_t), intent(in), target :: vars
     call eval_tree_link_var_list (expr, vars)
     call eval_node_compile_expr (expr%root, expr%pn, expr%var_list)
   end subroutine eval_tree_setup_expr
 
   subroutine eval_tree_setup_lexpr (expr, vars)
     class(eval_tree_t), intent(inout), target :: expr
     class(vars_t), intent(in), target :: vars
     call eval_tree_link_var_list (expr, vars)
     call eval_node_compile_lexpr (expr%root, expr%pn, expr%var_list)
   end subroutine eval_tree_setup_lexpr
 
   subroutine eval_tree_setup_pexpr (expr, vars)
     class(eval_tree_t), intent(inout), target :: expr
     class(vars_t), intent(in), target :: vars
     call eval_tree_link_var_list (expr, vars)
     call eval_node_compile_pexpr (expr%root, expr%pn, expr%var_list)
   end subroutine eval_tree_setup_pexpr
 
   subroutine eval_tree_setup_cexpr (expr, vars)
     class(eval_tree_t), intent(inout), target :: expr
     class(vars_t), intent(in), target :: vars
     call eval_tree_link_var_list (expr, vars)
     call eval_node_compile_cexpr (expr%root, expr%pn, expr%var_list)
   end subroutine eval_tree_setup_cexpr
 
   subroutine eval_tree_setup_sexpr (expr, vars)
     class(eval_tree_t), intent(inout), target :: expr
     class(vars_t), intent(in), target :: vars
     call eval_tree_link_var_list (expr, vars)
     call eval_node_compile_sexpr (expr%root, expr%pn, expr%var_list)
   end subroutine eval_tree_setup_sexpr
 
 @ %def eval_tree_setup_expr
 @ %def eval_tree_setup_lexpr
 @ %def eval_tree_setup_pexpr
 @ %def eval_tree_setup_cexpr
 @ %def eval_tree_setup_sexpr
 @ This extra API function handles numerical constant expressions only.
 The only nontrivial part is the optional unit.
 <<Eval trees: eval tree: TBP>>=
   procedure :: init_numeric_value => eval_tree_init_numeric_value
 <<Eval trees: procedures>>=
   subroutine eval_tree_init_numeric_value (eval_tree, parse_node)
     class(eval_tree_t), intent(out), target :: eval_tree
     type(parse_node_t), intent(in), target :: parse_node
     call eval_node_compile_numeric_value (eval_tree%root, parse_node)
   end subroutine eval_tree_init_numeric_value
 
 @ %def eval_tree_init_numeric_value
 @ Initialize the variable list, linking it to a context variable list.
 <<Eval trees: procedures>>=
   subroutine eval_tree_link_var_list (eval_tree, vars)
     type(eval_tree_t), intent(inout), target :: eval_tree
     class(vars_t), intent(in), target :: vars
     call eval_tree%var_list%link (vars)
   end subroutine eval_tree_link_var_list
 
 @ %def eval_tree_link_var_list
 @ Include a subevent object in the initialization.  We add a pointer
 to this as variable [[@evt]] in the local variable list.
 <<Eval trees: procedures>>=
   subroutine eval_tree_set_subevt (eval_tree, subevt)
     type(eval_tree_t), intent(inout), target :: eval_tree
     type(subevt_t), intent(in), target :: subevt
     logical, save, target :: known = .true.
     call var_list_append_subevt_ptr &
          (eval_tree%var_list, var_str ("@evt"), subevt, known, &
          intrinsic=.true.)
   end subroutine eval_tree_set_subevt
 
 @ %def eval_tree_set_subevt
 @ Finalizer.
 <<Eval trees: eval tree: TBP>>=
   procedure :: final => eval_tree_final
 <<Eval trees: procedures>>=
   subroutine eval_tree_final (expr)
     class(eval_tree_t), intent(inout) :: expr
     call expr%var_list%final ()
     if (associated (expr%root)) then
        call eval_node_final_rec (expr%root)
        deallocate (expr%root)
     end if
   end subroutine eval_tree_final
 
 @ %def eval_tree_final
 @
 <<Eval trees: eval tree: TBP>>=
   procedure :: evaluate => eval_tree_evaluate
 <<Eval trees: procedures>>=
   subroutine eval_tree_evaluate (expr)
     class(eval_tree_t), intent(inout) :: expr
     if (associated (expr%root)) then
        call eval_node_evaluate (expr%root)
     end if
   end subroutine eval_tree_evaluate
 
 @ %def eval_tree_evaluate
 @ Check if the eval tree is allocated.
 <<Eval trees: procedures>>=
   function eval_tree_is_defined (eval_tree) result (flag)
     logical :: flag
     type(eval_tree_t), intent(in) :: eval_tree
     flag = associated (eval_tree%root)
   end function eval_tree_is_defined
 
 @ %def eval_tree_is_defined
 @ Check if the eval tree result is constant.
 <<Eval trees: procedures>>=
   function eval_tree_is_constant (eval_tree) result (flag)
     logical :: flag
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        flag = eval_tree%root%type == EN_CONSTANT
     else
        flag = .false.
     end if
   end function eval_tree_is_constant
 
 @ %def eval_tree_is_constant
 @ Insert a conversion node at the root, if necessary (only for
 real/int conversion)
 <<Eval trees: procedures>>=
   subroutine eval_tree_convert_result (eval_tree, result_type)
     type(eval_tree_t), intent(inout) :: eval_tree
     integer, intent(in) :: result_type
     if (associated (eval_tree%root)) then
        call insert_conversion_node (eval_tree%root, result_type)
     end if
   end subroutine eval_tree_convert_result
 
 @ %def eval_tree_convert_result
 @ Return the value of the top node, after evaluation.  If the tree is
 empty, return the type of [[V_NONE]].  When extracting the value, no
 check for existence is done.  For numeric values, the functions are
 safe against real/integer mismatch.
 <<Eval trees: eval tree: TBP>>=
   procedure :: is_known => eval_tree_result_is_known
   procedure :: get_log => eval_tree_get_log
   procedure :: get_int => eval_tree_get_int
   procedure :: get_real => eval_tree_get_real
   procedure :: get_cmplx => eval_tree_get_cmplx
   procedure :: get_pdg_array => eval_tree_get_pdg_array
   procedure :: get_subevt => eval_tree_get_subevt
   procedure :: get_string => eval_tree_get_string
 <<Eval trees: procedures>>=
   function eval_tree_get_result_type (expr) result (type)
     integer :: type
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        type = expr%root%result_type
     else
        type = V_NONE
     end if
   end function eval_tree_get_result_type
 
   function eval_tree_result_is_known (expr) result (flag)
     logical :: flag
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        select case (expr%root%result_type)
        case (V_LOG, V_INT, V_REAL)
           flag = expr%root%value_is_known
        case default
           flag = .true.
        end select
     else
        flag = .false.
     end if
   end function eval_tree_result_is_known
 
   function eval_tree_result_is_known_ptr (expr) result (ptr)
     logical, pointer :: ptr
     class(eval_tree_t), intent(in) :: expr
     logical, target, save :: known = .true.
     if (associated (expr%root)) then
        select case (expr%root%result_type)
        case (V_LOG, V_INT, V_REAL)
           ptr => expr%root%value_is_known
        case default
           ptr => known
        end select
     else
        ptr => null ()
     end if
   end function eval_tree_result_is_known_ptr
 
   function eval_tree_get_log (expr) result (lval)
     logical :: lval
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root))  lval = expr%root%lval
   end function eval_tree_get_log
 
   function eval_tree_get_int (expr) result (ival)
     integer :: ival
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        select case (expr%root%result_type)
        case (V_INT);  ival = expr%root%ival
        case (V_REAL); ival = expr%root%rval
        case (V_CMPLX); ival = expr%root%cval
        end select
     end if
   end function eval_tree_get_int
 
   function eval_tree_get_real (expr) result (rval)
     real(default) :: rval
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        select case (expr%root%result_type)
        case (V_REAL); rval = expr%root%rval
        case (V_INT);  rval = expr%root%ival
        case (V_CMPLX);  rval = expr%root%cval
        end select
     end if
   end function eval_tree_get_real
 
   function eval_tree_get_cmplx (expr) result (cval)
     complex(default) :: cval
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        select case (expr%root%result_type)
        case (V_CMPLX); cval = expr%root%cval
        case (V_REAL); cval = expr%root%rval
        case (V_INT);  cval = expr%root%ival
        end select
     end if
   end function eval_tree_get_cmplx
 
   function eval_tree_get_pdg_array (expr) result (aval)
     type(pdg_array_t) :: aval
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        aval = expr%root%aval
     end if
   end function eval_tree_get_pdg_array
 
   function eval_tree_get_subevt (expr) result (pval)
     type(subevt_t) :: pval
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        pval = expr%root%pval
     end if
   end function eval_tree_get_subevt
 
   function eval_tree_get_string (expr) result (sval)
     type(string_t) :: sval
     class(eval_tree_t), intent(in) :: expr
     if (associated (expr%root)) then
        sval = expr%root%sval
     end if
   end function eval_tree_get_string
 
 @ %def eval_tree_get_result_type
 @ %def eval_tree_result_is_known
 @ %def eval_tree_get_log eval_tree_get_int eval_tree_get_real
 @ %def eval_tree_get_cmplx
 @ %def eval_tree_get_pdg_expr
 @ %def eval_tree_get_pdg_array
 @ %def eval_tree_get_subevt
 @ %def eval_tree_get_string
 @ Return a pointer to the value of the top node.
 <<Eval trees: procedures>>=
   function eval_tree_get_log_ptr (eval_tree) result (lval)
     logical, pointer :: lval
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        lval => eval_tree%root%lval
     else
        lval => null ()
     end if
   end function eval_tree_get_log_ptr
 
   function eval_tree_get_int_ptr (eval_tree) result (ival)
     integer, pointer :: ival
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        ival => eval_tree%root%ival
     else
        ival => null ()
     end if
   end function eval_tree_get_int_ptr
 
   function eval_tree_get_real_ptr (eval_tree) result (rval)
     real(default), pointer :: rval
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        rval => eval_tree%root%rval
     else
        rval => null ()
     end if
   end function eval_tree_get_real_ptr
 
   function eval_tree_get_cmplx_ptr (eval_tree) result (cval)
     complex(default), pointer :: cval
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        cval => eval_tree%root%cval
     else
        cval => null ()
     end if
   end function eval_tree_get_cmplx_ptr
 
   function eval_tree_get_subevt_ptr (eval_tree) result (pval)
     type(subevt_t), pointer :: pval
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        pval => eval_tree%root%pval
     else
        pval => null ()
     end if
   end function eval_tree_get_subevt_ptr
 
   function eval_tree_get_pdg_array_ptr (eval_tree) result (aval)
     type(pdg_array_t), pointer :: aval
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        aval => eval_tree%root%aval
     else
        aval => null ()
     end if
   end function eval_tree_get_pdg_array_ptr
 
   function eval_tree_get_string_ptr (eval_tree) result (sval)
     type(string_t), pointer :: sval
     type(eval_tree_t), intent(in) :: eval_tree
     if (associated (eval_tree%root)) then
        sval => eval_tree%root%sval
     else
        sval => null ()
     end if
   end function eval_tree_get_string_ptr
 
 @ %def eval_tree_get_log_ptr eval_tree_get_int_ptr eval_tree_get_real_ptr
 @ %def eval_tree_get_cmplx_ptr
 @ %def eval_tree_get_subevt_ptr eval_tree_get_pdg_array_ptr
 @ %def eval_tree_get_string_ptr
 <<Eval trees: eval tree: TBP>>=
   procedure :: write => eval_tree_write
 <<Eval trees: procedures>>=
   subroutine eval_tree_write (expr, unit, write_vars)
     class(eval_tree_t), intent(in) :: expr
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: write_vars
     integer :: u
     logical :: vl
     u = given_output_unit (unit);  if (u < 0)  return
     vl = .false.;  if (present (write_vars))  vl = write_vars
     write (u, "(1x,A)") "Evaluation tree:"
     if (associated (expr%root)) then
        call eval_node_write_rec (expr%root, unit)
     else
        write (u, "(3x,A)") "[empty]"
     end if
     if (vl)  call var_list_write (expr%var_list, unit)
   end subroutine eval_tree_write
 
 @ %def eval_tree_write
 @ Use the written representation for generating an MD5 sum:
 <<Eval trees: procedures>>=
   function eval_tree_get_md5sum (eval_tree) result (md5sum_et)
     character(32) :: md5sum_et
     type(eval_tree_t), intent(in) :: eval_tree
     integer :: u
     u = free_unit ()
     open (unit = u, status = "scratch", action = "readwrite")
     call eval_tree_write (eval_tree, unit=u)
     rewind (u)
     md5sum_et = md5sum (u)
     close (u)
   end function eval_tree_get_md5sum
 
 @ %def eval_tree_get_md5sum
 @
 \subsection{Direct evaluation}
 These procedures create an eval tree and evaluate it on-the-fly, returning
 only the final value.  The evaluation must yield a well-defined value, unless
 the [[is_known]] flag is present, which will be set accordingly.
 <<Eval trees: public>>=
   public :: eval_log
   public :: eval_int
   public :: eval_real
   public :: eval_cmplx
   public :: eval_subevt
   public :: eval_pdg_array
   public :: eval_string
 <<Eval trees: procedures>>=
   function eval_log &
        (parse_node, var_list, subevt, is_known) result (lval)
     logical :: lval
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_lexpr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        lval = eval_tree_get_log (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
        lval = .false.
     end if
     call eval_tree_final (eval_tree)
   end function eval_log
 
   function eval_int &
        (parse_node, var_list, subevt, is_known) result (ival)
     integer :: ival
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_expr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        ival = eval_tree_get_int (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
        ival = 0
     end if
     call eval_tree_final (eval_tree)
   end function eval_int
 
   function eval_real &
        (parse_node, var_list, subevt, is_known) result (rval)
     real(default) :: rval
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_expr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        rval = eval_tree_get_real (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
        rval = 0
     end if
     call eval_tree_final (eval_tree)
   end function eval_real
 
   function eval_cmplx &
        (parse_node, var_list, subevt, is_known) result (cval)
     complex(default) :: cval
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_expr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        cval = eval_tree_get_cmplx (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
        cval = 0
     end if
     call eval_tree_final (eval_tree)
   end function eval_cmplx
 
   function eval_subevt &
        (parse_node, var_list, subevt, is_known) result (pval)
     type(subevt_t) :: pval
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_pexpr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        pval = eval_tree_get_subevt (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
     end if
     call eval_tree_final (eval_tree)
   end function eval_subevt
 
   function eval_pdg_array &
        (parse_node, var_list, subevt, is_known) result (aval)
     type(pdg_array_t) :: aval
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_cexpr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        aval = eval_tree_get_pdg_array (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
     end if
     call eval_tree_final (eval_tree)
   end function eval_pdg_array
 
   function eval_string &
        (parse_node, var_list, subevt, is_known) result (sval)
     type(string_t) :: sval
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     logical, intent(out), optional :: is_known
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_sexpr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (is_known))  is_known = .true.
        sval = eval_tree_get_string (eval_tree)
     else if (present (is_known)) then
        is_known = .false.
     else
        call eval_tree_unknown (eval_tree, parse_node)
        sval = ""
     end if
     call eval_tree_final (eval_tree)
   end function eval_string
 
 @ %def eval_log eval_int eval_real eval_cmplx
 @ %def eval_subevt eval_pdg_array eval_string
 @ %def eval_tree_unknown
 @ Here is a variant that returns numeric values of all possible kinds, the
 appropriate kind to be selected later:
 <<Eval trees: public>>=
   public :: eval_numeric
 <<Eval trees: procedures>>=
   subroutine eval_numeric &
        (parse_node, var_list, subevt, ival, rval, cval, &
         is_known, result_type)
     type(parse_node_t), intent(in), target :: parse_node
     type(var_list_t), intent(in), target :: var_list
     type(subevt_t), intent(in), optional, target :: subevt
     integer, intent(out), optional :: ival
     real(default), intent(out), optional :: rval
     complex(default), intent(out), optional :: cval
     logical, intent(out), optional :: is_known
     integer, intent(out), optional :: result_type
     type(eval_tree_t), target :: eval_tree
     call eval_tree_init_expr &
          (eval_tree, parse_node, var_list, subevt)
     call eval_tree_evaluate (eval_tree)
     if (eval_tree_result_is_known (eval_tree)) then
        if (present (ival))  ival = eval_tree_get_int (eval_tree)
        if (present (rval))  rval = eval_tree_get_real (eval_tree)
        if (present (cval))  cval = eval_tree_get_cmplx (eval_tree)
        if (present (is_known))  is_known = .true.
     else
        call eval_tree_unknown (eval_tree, parse_node)
        if (present (ival))  ival = 0
        if (present (rval))  rval = 0
        if (present (cval))  cval = 0
        if (present (is_known))  is_known = .false.
     end if
     if (present (result_type))  &
          result_type = eval_tree_get_result_type (eval_tree)
     call eval_tree_final (eval_tree)
   end subroutine eval_numeric
 
 @ %def eval_numeric
 @ Error message with debugging info:
 <<Eval trees: procedures>>=
   subroutine eval_tree_unknown (eval_tree, parse_node)
     type(eval_tree_t), intent(in) :: eval_tree
     type(parse_node_t), intent(in) :: parse_node
     call parse_node_write_rec (parse_node)
     call eval_tree_write (eval_tree)
     call msg_error ("Evaluation yields an undefined result, inserting default")
   end subroutine eval_tree_unknown
 
 @ %def eval_tree_unknown
 @
 \subsection{Factory Type}
 Since [[eval_tree_t]] is an implementation of [[expr_t]], we also need a
 matching factory type and build method.
 <<Eval trees: public>>=
   public :: eval_tree_factory_t
 <<Eval trees: types>>=
   type, extends (expr_factory_t) :: eval_tree_factory_t
      private
      type(parse_node_t), pointer :: pn => null ()
    contains
   <<Eval trees: eval tree factory: TBP>>
   end type eval_tree_factory_t
 
 @ %def eval_tree_factory_t
 @ Output: delegate to the output of the embedded parse node.
 <<Eval trees: eval tree factory: TBP>>=
   procedure :: write => eval_tree_factory_write
 <<Eval trees: procedures>>=
   subroutine eval_tree_factory_write (expr_factory, unit)
     class(eval_tree_factory_t), intent(in) :: expr_factory
     integer, intent(in), optional :: unit
     if (associated (expr_factory%pn)) then
        call parse_node_write_rec (expr_factory%pn, unit)
     end if
   end subroutine eval_tree_factory_write
 
 @ %def eval_tree_factory_write
 @ Initializer: take a parse node and hide it thus from the environment.
 <<Eval trees: eval tree factory: TBP>>=
   procedure :: init => eval_tree_factory_init
 <<Eval trees: procedures>>=
   subroutine eval_tree_factory_init (expr_factory, pn)
     class(eval_tree_factory_t), intent(out) :: expr_factory
     type(parse_node_t), intent(in), pointer :: pn
     expr_factory%pn => pn
   end subroutine eval_tree_factory_init
 
 @ %def eval_tree_factory_init
 @ Factory method: allocate expression with correct eval tree type.  If the
 stored parse node is not associate, don't allocate.
 <<Eval trees: eval tree factory: TBP>>=
   procedure :: build => eval_tree_factory_build
 <<Eval trees: procedures>>=
   subroutine eval_tree_factory_build (expr_factory, expr)
     class(eval_tree_factory_t), intent(in) :: expr_factory
     class(expr_t), intent(out), allocatable :: expr
     if (associated (expr_factory%pn)) then
        allocate (eval_tree_t :: expr)
        select type (expr)
        type is (eval_tree_t)
           expr%pn => expr_factory%pn
        end select
     end if
   end subroutine eval_tree_factory_build
 
 @ %def eval_tree_factory_build
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[eval_trees_ut.f90]]>>=
 <<File header>>
 
 module eval_trees_ut
   use unit_tests
   use eval_trees_uti
 
 <<Standard module head>>
 
 <<Eval trees: public test>>
 
 contains
 
 <<Eval trees: test driver>>
 
 end module eval_trees_ut
 @ %def eval_trees_ut
 @
 <<[[eval_trees_uti.f90]]>>=
 <<File header>>
 
 module eval_trees_uti
 
 <<Use kinds>>
 <<Use strings>>
 
   use ifiles
   use lexers
   use lorentz
   use syntax_rules, only: syntax_write
   use pdg_arrays
   use subevents
   use variables
   use observables
 
   use eval_trees
 
 <<Standard module head>>
 
 <<Eval trees: test declarations>>
 
 contains
 
 <<Eval trees: tests>>
 
 end module eval_trees_uti
 @ %def eval_trees_ut
 @ API: driver for the unit tests below.
 <<Eval trees: public test>>=
   public :: expressions_test
 <<Eval trees: test driver>>=
   subroutine expressions_test (u, results)
     integer, intent(in) :: u
     type (test_results_t), intent(inout) :: results
   <<Eval trees: execute tests>>
   end subroutine expressions_test
 
 @ %def expressions_test
 @ Testing the routines of the expressions module. First a simple unary
 observable and the node evaluation.
 <<Eval trees: execute tests>>=
   call test (expressions_1, "expressions_1", &
        "check simple observable", &
        u, results)
 <<Eval trees: test declarations>>=
   public :: expressions_1
 <<Eval trees: tests>>=
   subroutine expressions_1 (u)
     integer, intent(in) :: u
     type(var_list_t), pointer :: var_list => null ()
     type(eval_node_t), pointer :: node => null ()
     type(prt_t), pointer :: prt => null ()
     type(string_t) :: var_name
 
     write (u, "(A)")  "* Test output: Expressions"
     write (u, "(A)")  "*   Purpose: test simple observable and node evaluation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Setting a unary observable:"
     write (u, "(A)")
 
     allocate (var_list)
     allocate (prt)
     call var_list_set_observables_unary (var_list, prt)
     call var_list%write (u)
 
     write (u, "(A)")  "* Evaluating the observable node:"
     write (u, "(A)")
 
     var_name = "PDG"
 
     allocate (node)
     call node%test_obs (var_list, var_name)
     call node%write (u)
 
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call node%final_rec ()
     deallocate (node)
     !!! Workaround for NAGFOR 6.2 
     ! call var_list%final ()
     deallocate (var_list)
     deallocate (prt)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: expressions_1"
 
   end subroutine expressions_1
 
 @  %def expressions_1
 @ Parse a complicated expression, transfer it to a parse tree and evaluate.
 <<Eval trees: execute tests>>=
   call test (expressions_2, "expressions_2", &
        "check expression transfer to parse tree", &
        u, results)
 <<Eval trees: test declarations>>=
   public :: expressions_2
 <<Eval trees: tests>>=
   subroutine expressions_2 (u)
     integer, intent(in) :: u
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(eval_tree_t) :: eval_tree
     type(string_t) :: expr_text
     type(var_list_t), pointer :: var_list => null ()
 
     write (u, "(A)")  "* Test output: Expressions"
     write (u, "(A)")  "*   Purpose: test parse routines"
     write (u, "(A)")
 
     call syntax_expr_init ()
     call syntax_write (syntax_expr, u)
     allocate (var_list)
     call var_list_append_real (var_list, var_str ("tolerance"), 0._default)
     call var_list_append_real (var_list, var_str ("x"), -5._default)
     call var_list_append_int  (var_list, var_str ("foo"), -27)
     call var_list_append_real (var_list, var_str ("mb"), 4._default)
     expr_text = &
          "let real twopi = 2 * pi in" // &
          "  twopi * sqrt (25.d0 - mb^2)" // &
          "  / (let int mb_or_0 = max (mb, 0) in" // &
          "       1 + (if -1 TeV <= x < mb_or_0 then abs(x) else x endif))"
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call var_list%write (u)
     call eval_tree%init_stream (stream, var_list=var_list)
     call eval_tree%evaluate ()
     call eval_tree%write (u)
 
     write (u, "(A)")  "* Input string:"
     write (u, "(A,A)")  "     ", char (expr_text)
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stream_final (stream)
     call ifile_final (ifile)
     call eval_tree%final ()
     call var_list%final ()
     deallocate (var_list)
     call syntax_expr_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: expressions_2"
 
   end subroutine expressions_2
 
 @  %def expressions_2
 @ Test a subevent expression.
 <<Eval trees: execute tests>>=
   call test (expressions_3, "expressions_3", &
        "check subevent expressions", &
        u, results)
 <<Eval trees: test declarations>>=
   public :: expressions_3
 <<Eval trees: tests>>=
   subroutine expressions_3 (u)
     integer, intent(in) :: u
     type(subevt_t) :: subevt
 
     write (u, "(A)")  "* Test output: Expressions"
     write (u, "(A)")  "*   Purpose: test subevent expressions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize subevent:"
     write (u, "(A)")
 
     call subevt_init (subevt)
     call subevt_reset (subevt, 1)
     call subevt_set_incoming (subevt, 1, &
          22, vector4_moving (1.e3_default, 1.e3_default, 1), &
          0._default, [2])
     call subevt_write (subevt, u)
     call subevt_reset (subevt, 4)
     call subevt_reset (subevt, 3)
     call subevt_set_incoming (subevt, 1, &
          21, vector4_moving (1.e3_default, 1.e3_default, 3), &
          0._default, [1])
     call subevt_polarize (subevt, 1, -1)
     call subevt_set_outgoing (subevt, 2, &
          1, vector4_moving (0._default, 1.e3_default, 3), &
          -1.e6_default, [7])
     call subevt_set_composite (subevt, 3, &
          vector4_moving (-1.e3_default, 0._default, 3), &
          [2, 7])
     call subevt_write (subevt, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: expressions_3"
 
   end subroutine expressions_3
 
 @  %def expressions_3
 @ Test expressions from a PDG array.
 <<Eval trees: execute tests>>=
   call test (expressions_4, "expressions_4", &
        "check pdg array expressions", &
        u, results)
 <<Eval trees: test declarations>>=
   public :: expressions_4
 <<Eval trees: tests>>=
   subroutine expressions_4 (u)
     integer, intent(in) :: u
     type(subevt_t), target :: subevt
     type(string_t) :: expr_text
     type(ifile_t) :: ifile
     type(stream_t) :: stream
     type(eval_tree_t) :: eval_tree
     type(var_list_t), pointer :: var_list => null ()
     type(pdg_array_t) :: aval
 
     write (u, "(A)")  "* Test output: Expressions"
     write (u, "(A)")  "*   Purpose: test pdg array expressions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization:"
     write (u, "(A)")
 
     call syntax_pexpr_init ()
     call syntax_write (syntax_pexpr, u)
     allocate (var_list)
     call var_list_append_real (var_list, var_str ("tolerance"), 0._default)
     aval = 0
     call var_list_append_pdg_array (var_list, var_str ("particle"), aval)
     aval = [11,-11]
     call var_list_append_pdg_array (var_list, var_str ("lepton"), aval)
     aval = 22
     call var_list_append_pdg_array (var_list, var_str ("photon"), aval)
     aval = 1
     call var_list_append_pdg_array (var_list, var_str ("u"), aval)
     call subevt_init (subevt)
     call subevt_reset (subevt, 6)
     call subevt_set_incoming (subevt, 1, &
          1, vector4_moving (1._default, 1._default, 1), 0._default)
     call subevt_set_incoming (subevt, 2, &
          -1, vector4_moving (2._default, 2._default, 1), 0._default)
     call subevt_set_outgoing (subevt, 3, &
          22, vector4_moving (3._default, 3._default, 1), 0._default)
     call subevt_set_outgoing (subevt, 4, &
          22, vector4_moving (4._default, 4._default, 1), 0._default)
     call subevt_set_outgoing (subevt, 5, &
          11, vector4_moving (5._default, 5._default, 1), 0._default)
     call subevt_set_outgoing (subevt, 6, &
          -11, vector4_moving (6._default, 6._default, 1), 0._default)
     write (u, "(A)")
     write (u, "(A)")  "* Expression:"
     expr_text = &
          "let alias quark = pdg(1):pdg(2):pdg(3) in" // &
          "  any E > 3 GeV " // &
          "    [sort by - Pt " // &
          "       [select if Index < 6 " // &
          "          [photon:pdg(-11):pdg(3):quark " // &
          "           & incoming particle]]]" // &
          "  and" // &
          "  eval Theta [extract index -1 [photon]] > 45 degree" // &
          "  and" // &
          "  count [incoming photon] * 3 > 0"
     write (u, "(A,A)")  "     ", char (expr_text)
     write (u, "(A)")
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract the evaluation tree:"
     write (u, "(A)")
 
     call ifile_append (ifile, expr_text)
     call stream_init (stream, ifile)
     call eval_tree%init_stream (stream, var_list, subevt, V_LOG)
     call eval_tree%write (u)
     call eval_tree%evaluate ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate the tree:"
     write (u, "(A)")
 
     call eval_tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call stream_final (stream)
     call ifile_final (ifile)
     call eval_tree%final ()
     call var_list%final ()
     deallocate (var_list)
     call syntax_pexpr_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: expressions_4"
 
   end subroutine expressions_4
 
 @ %def expressions_4
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Physics Models}
 
 A model object represents a physics model.  It contains a table of particle
 data, a list of parameters, and a vertex table.  The list of parameters is a
 variable list which includes the real parameters (which are pointers to the
 particle data table) and PDG array variables for the particles themselves.
 The vertex list is used for phase-space generation, not for calculating the
 matrix element.
 
 The actual numeric model data are in the base type [[model_data_t]],
 as part of the [[qft]] section.  We implement the [[model_t]] as an
 extension of this, for convenient direct access to the base-type
 methods via inheritance.  (Alternatively, we could delegate these calls
 explicitly.)  The extension contains administrative additions, such as
 the methods for recalculating derived data and keeping the parameter
 set consistent.  It thus acts as a proxy of the actual model-data
 object towards the \whizard\ package.  There are further proxy
 objects, such as the [[parameter_t]] array which provides the
 interface to the actual numeric parameters.
 
 Model definitions are read from model files.  Therefore, this module contains
 a parser for model files.  The parameter definitions (derived parameters) are
 Sindarin expressions.
 
 The models, as read from file, are stored in a model library which is a simple
 list of model definitions.  For setting up a process object we should make a
 copy (an instance) of a model, which gets the current parameter values from
 the global variable list.
 
 \subsection{Module}
 <<[[models.f90]]>>=
 <<File header>>
 
 module models
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use kinds>>
   use kinds, only: c_default_float
 <<Use strings>>
   use io_units
   use diagnostics
   use md5
   use os_interface
   use physics_defs, only: UNDEFINED
   use model_data
 
   use ifiles
   use syntax_rules
   use lexers
   use parser
   use pdg_arrays
   use variables
   use expr_base
   use eval_trees
 
   use ttv_formfactors, only: init_parameters
 
 <<Standard module head>>
 
 <<Models: public>>
 
 <<Models: parameters>>
 
 <<Models: types>>
 
 <<Models: interfaces>>
 
 <<Models: variables>>
 
 contains
 
 <<Models: procedures>>
 
 end module models
 @ %def models
 @
 \subsection{Physics Parameters}
 A parameter has a name, a value.  Derived parameters also have a
 definition in terms of other parameters, which is stored as an
 [[eval_tree]].  External parameters are set by an external program.
 
 This parameter object should be considered as a proxy object.  The
 parameter name and value are stored in a corresponding
 [[modelpar_data_t]] object which is located in a [[model_data_t]]
 object.  The latter is a component of the [[model_t]] handler.
 Methods of [[parameter_t]] can be delegated to the [[par_data_t]]
 component.
 
 The [[pn]] component is a pointer to the parameter definition inside the
 model parse tree.  It allows us to recreate the [[eval_tree]] when making
 copies (instances) of the parameter object.
 <<Models: parameters>>=
   integer, parameter :: PAR_NONE = 0, PAR_UNUSED = -1
   integer, parameter :: PAR_INDEPENDENT = 1, PAR_DERIVED = 2
   integer, parameter :: PAR_EXTERNAL = 3
 
 @ %def PAR_NONE PAR_INDEPENDENT PAR_DERIVED PAR_EXTERNAL PAR_UNUSED
 <<Models: types>>=
   type :: parameter_t
      private
      integer :: type  = PAR_NONE
      class(modelpar_data_t), pointer :: data => null ()
      type(parse_node_t), pointer :: pn => null ()
      class(expr_t), allocatable :: expr
    contains
    <<Models: parameter: TBP>>
   end type parameter_t
 
 @ %def parameter_t
 @ Initialization depends on parameter type.  Independent parameters
 are initialized by a constant value or a constant numerical expression
 (which may contain a unit).  Derived parameters are initialized by an
 arbitrary numerical expression, which makes use of the current
 variable list.  The expression is evaluated by the function
 [[parameter_reset]].
 
 This implementation supports only real parameters and real values.
 <<Models: parameter: TBP>>=
   procedure :: init_independent_value => parameter_init_independent_value
   procedure :: init_independent => parameter_init_independent
   procedure :: init_derived => parameter_init_derived
   procedure :: init_external => parameter_init_external
   procedure :: init_unused => parameter_init_unused
 <<Models: procedures>>=
   subroutine parameter_init_independent_value (par, par_data, name, value)
     class(parameter_t), intent(out) :: par
     class(modelpar_data_t), intent(in), target :: par_data
     type(string_t), intent(in) :: name
     real(default), intent(in) :: value
     par%type = PAR_INDEPENDENT
     par%data => par_data
     call par%data%init (name, value)
   end subroutine parameter_init_independent_value
 
   subroutine parameter_init_independent (par, par_data, name, pn)
     class(parameter_t), intent(out) :: par
     class(modelpar_data_t), intent(in), target :: par_data
     type(string_t), intent(in) :: name
     type(parse_node_t), intent(in), target :: pn
     par%type = PAR_INDEPENDENT
     par%pn => pn
     allocate (eval_tree_t :: par%expr)
     select type (expr => par%expr)
     type is (eval_tree_t)
        call expr%init_numeric_value (pn)
     end select
     par%data => par_data
     call par%data%init (name, par%expr%get_real ())
   end subroutine parameter_init_independent
 
   subroutine parameter_init_derived (par, par_data, name, pn, var_list)
     class(parameter_t), intent(out) :: par
     class(modelpar_data_t), intent(in), target :: par_data
     type(string_t), intent(in) :: name
     type(parse_node_t), intent(in), target :: pn
     type(var_list_t), intent(in), target :: var_list
     par%type = PAR_DERIVED
     par%pn => pn
     allocate (eval_tree_t :: par%expr)
     select type (expr => par%expr)
     type is (eval_tree_t)
        call expr%init_expr (pn, var_list=var_list)
     end select
     par%data => par_data
 !    call par%expr%evaluate ()
     call par%data%init (name, 0._default)
   end subroutine parameter_init_derived
 
   subroutine parameter_init_external (par, par_data, name)
     class(parameter_t), intent(out) :: par
     class(modelpar_data_t), intent(in), target :: par_data
     type(string_t), intent(in) :: name
     par%type = PAR_EXTERNAL
     par%data => par_data
     call par%data%init (name, 0._default)
   end subroutine parameter_init_external
 
   subroutine parameter_init_unused (par, par_data, name)
     class(parameter_t), intent(out) :: par
     class(modelpar_data_t), intent(in), target :: par_data
     type(string_t), intent(in) :: name
     par%type = PAR_UNUSED
     par%data => par_data
     call par%data%init (name, 0._default)
   end subroutine parameter_init_unused
 
 @ %def parameter_init_independent_value
 @ %def parameter_init_independent
 @ %def parameter_init_derived
 @ %def parameter_init_external
 @ %def parameter_init_unused
 @ The finalizer is needed for the evaluation tree in the definition.
 <<Models: parameter: TBP>>=
   procedure :: final => parameter_final
 <<Models: procedures>>=
   subroutine parameter_final (par)
     class(parameter_t), intent(inout) :: par
     if (allocated (par%expr)) then
        call par%expr%final ()
     end if
   end subroutine parameter_final
 
 @ %def parameter_final
 @ All derived parameters should be recalculated if some independent
 parameters have changed:
 <<Models: parameter: TBP>>=
   procedure :: reset_derived => parameter_reset_derived
 <<Models: procedures>>=
   subroutine parameter_reset_derived (par)
     class(parameter_t), intent(inout) :: par
     select case (par%type)
     case (PAR_DERIVED)
        call par%expr%evaluate ()
        par%data = par%expr%get_real ()
     end select
   end subroutine parameter_reset_derived
 
 @ %def parameter_reset_derived parameter_reset_external
 @ Output.  [We should have a formula format for the eval tree,
 suitable for input and output!]
 <<Models: parameter: TBP>>=
   procedure :: write => parameter_write
 <<Models: procedures>>=
   subroutine parameter_write (par, unit, write_defs)
     class(parameter_t), intent(in) :: par
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: write_defs
     logical :: defs
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     defs = .false.;  if (present (write_defs))  defs = write_defs
     select case (par%type)
     case (PAR_INDEPENDENT)
        write (u, "(3x,A)", advance="no")  "parameter"
        call par%data%write (u)
     case (PAR_DERIVED)
        write (u, "(3x,A)", advance="no")  "derived"
        call par%data%write (u)
     case (PAR_EXTERNAL)
        write (u, "(3x,A)", advance="no")  "external"
        call par%data%write (u)
     case (PAR_UNUSED)
        write (u, "(3x,A)", advance="no")  "unused"
        write (u, "(1x,A)", advance="no")  char (par%data%get_name ())
     end select
     select case (par%type)
     case (PAR_DERIVED)
        if (defs) then
           call par%expr%write (unit)
        else
           write (u, "(A)")
        end if
     case default
        write (u, "(A)")
     end select
   end subroutine parameter_write
 
 @ %def parameter_write
 @ Screen output variant.  Restrict output to the given parameter type.
 <<Models: parameter: TBP>>=
   procedure :: show => parameter_show
 <<Models: procedures>>=
   subroutine parameter_show (par, l, u, partype)
     class(parameter_t), intent(in) :: par
     integer, intent(in) :: l, u
     integer, intent(in) :: partype
     if (par%type == partype) then
        call par%data%show (l, u)
     end if
   end subroutine parameter_show
 
 @ %def parameter_show
 @
 \subsection{Model Object}
 A model object holds all information about parameters, particles,
 and vertices.  For models that require an external program for
 parameter calculation, there is the pointer to a function that does
 this calculation, given the set of independent and derived parameters.
 
 As explained above, the type inherits from [[model_data_t]], which is
 the actual storage for the model data.
 
 When reading a model, we create a parse tree.  Parameter definitions are
 available via parse nodes.  Since we may need those later when making model
 instances, we keep the whole parse tree in the model definition (but not in
 the instances).
 <<Models: public>>=
   public :: model_t
 <<Models: types>>=
   type, extends (model_data_t) :: model_t
      private
      character(32) :: md5sum = ""
      logical :: ufo_model = .false.
      type(string_t) :: ufo_path
      type(string_t), dimension(:), allocatable :: schemes
      type(string_t), allocatable :: selected_scheme
      type(parameter_t), dimension(:), allocatable :: par
      integer :: max_par_name_length = 0
      integer :: max_field_name_length = 0
      type(var_list_t) :: var_list
      type(string_t) :: dlname
      procedure(model_init_external_parameters), nopass, pointer :: &
           init_external_parameters => null ()
      type(dlaccess_t) :: dlaccess
      type(parse_tree_t) :: parse_tree
    contains
    <<Models: model: TBP>>
   end type model_t
 
 @ %def model_t
 @ This is the interface for a procedure that initializes the
 calculation of external parameters, given the array of all
 parameters.
 <<Models: interfaces>>=
   abstract interface
      subroutine model_init_external_parameters (par) bind (C)
        import
        real(c_default_float), dimension(*), intent(inout) :: par
      end subroutine model_init_external_parameters
   end interface
 
 @ %def model_init_external_parameters
 @ Initialization: Specify the number of parameters, particles,
 vertices and allocate memory.  If an associated DL library is
 specified, load this library.
 
 The model may already carry scheme information, so we have to save and
 restore the scheme number when actually initializing the [[model_data_t]]
 base.
 <<Models: model: TBP>>=
   generic :: init => model_init
   procedure, private :: model_init
 <<Models: procedures>>=
   subroutine model_init &
        (model, name, libname, os_data, n_par, n_prt, n_vtx, ufo)
     class(model_t), intent(inout) :: model
     type(string_t), intent(in) :: name, libname
     type(os_data_t), intent(in) :: os_data
     integer, intent(in) :: n_par, n_prt, n_vtx
     logical, intent(in), optional :: ufo
     type(c_funptr) :: c_fptr
     type(string_t) :: libpath
     integer :: scheme_num
     scheme_num = model%get_scheme_num ()
     call model%basic_init (name, n_par, n_prt, n_vtx)
     if (present (ufo))  model%ufo_model = ufo
     call model%set_scheme_num (scheme_num)
     if (libname /= "") then
        if (.not. os_data%use_testfiles) then
           libpath = os_data%whizard_models_libpath_local
           model%dlname = os_get_dlname ( &
             libpath // "/" // libname, os_data, ignore=.true.)
        end if
        if (model%dlname == "") then
           libpath = os_data%whizard_models_libpath
           model%dlname = os_get_dlname (libpath // "/" // libname, os_data)
        end if
     else
        model%dlname = ""
     end if
     if (model%dlname /= "") then
        if (.not. dlaccess_is_open (model%dlaccess)) then
           if (logging) &
                call msg_message ("Loading model auxiliary library '" &
                // char (libpath) // "/" // char (model%dlname) // "'")
           call dlaccess_init (model%dlaccess, os_data%whizard_models_libpath, &
                model%dlname, os_data)
           if (dlaccess_has_error (model%dlaccess)) then
              call msg_message (char (dlaccess_get_error (model%dlaccess)))
              call msg_fatal ("Loading model auxiliary library '" &
                   // char (model%dlname) // "' failed")
              return
           end if
           c_fptr = dlaccess_get_c_funptr (model%dlaccess, &
                var_str ("init_external_parameters"))
           if (dlaccess_has_error (model%dlaccess)) then
              call msg_message (char (dlaccess_get_error (model%dlaccess)))
              call msg_fatal ("Loading function from auxiliary library '" &
                   // char (model%dlname) // "' failed")
              return
           end if
           call c_f_procpointer (c_fptr, model% init_external_parameters)
        end if
     end if
   end subroutine model_init
 
 @ %def model_init
 @ For a model instance, we do not attempt to load a DL library.  This is the
 core of the full initializer above.
 <<Models: model: TBP>>=
   procedure, private :: basic_init => model_basic_init
 <<Models: procedures>>=
   subroutine model_basic_init (model, name, n_par, n_prt, n_vtx)
     class(model_t), intent(inout) :: model
     type(string_t), intent(in) :: name
     integer, intent(in) :: n_par, n_prt, n_vtx
     allocate (model%par (n_par))
     call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx)
   end subroutine model_basic_init
 
 @ %def model_basic_init
 @ Finalization: The variable list contains allocated pointers, also the parse
 tree.  We also close the DL access object, if any, that enables external
 parameter calculation.
 <<Models: model: TBP>>=
   procedure :: final => model_final
 <<Models: procedures>>=
   subroutine model_final (model)
     class(model_t), intent(inout) :: model
     integer :: i
     if (allocated (model%par)) then
        do i = 1, size (model%par)
           call model%par(i)%final ()
        end do
     end if
     call model%var_list%final (follow_link=.false.)
     if (model%dlname /= "")  call dlaccess_final (model%dlaccess)
     call parse_tree_final (model%parse_tree)
     call model%model_data_t%final ()
   end subroutine model_final
 
 @ %def model_final
 @ Output.  By default, the output is in the form of an input file.  If
 [[verbose]] is true, for each derived parameter the definition (eval
 tree) is displayed, and the vertex hash table is shown.
 <<Models: model: TBP>>=
   procedure :: write => model_write
 <<Models: procedures>>=
   subroutine model_write (model, unit, verbose, &
        show_md5sum, show_variables, show_parameters, &
        show_particles, show_vertices, show_scheme)
     class(model_t), intent(in) :: model
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     logical, intent(in), optional :: show_md5sum
     logical, intent(in), optional :: show_variables
     logical, intent(in), optional :: show_parameters
     logical, intent(in), optional :: show_particles
     logical, intent(in), optional :: show_vertices
     logical, intent(in), optional :: show_scheme
     logical :: verb, show_md5, show_par, show_var
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     verb = .false.;  if (present (verbose))  verb = verbose
     show_md5 = .true.;  if (present (show_md5sum)) &
          show_md5 = show_md5sum
     show_par = .true.;  if (present (show_parameters)) &
          show_par = show_parameters
     show_var = verb;  if (present (show_variables)) &
          show_var = show_variables
     write (u, "(A,A,A)") 'model "', char (model%get_name ()), '"'
     if (show_md5 .and. model%md5sum /= "") &
          write (u, "(1x,A,A,A)") "! md5sum = '", model%md5sum, "'"
     if (model%is_ufo_model ()) then
        write (u, "(1x,A)")  "! model derived from UFO source"
     else if (model%has_schemes ()) then
        write (u, "(1x,A)", advance="no")  "! schemes ="
        do i = 1, size (model%schemes)
           if (i > 1)  write (u, "(',')", advance="no")
           write (u, "(1x,A,A,A)", advance="no") &
                "'", char (model%schemes(i)), "'"
        end do
        write (u, *)
        if (allocated (model%selected_scheme)) then
           write (u, "(1x,A,A,A,I0,A)")  &
                "! selected scheme = '", char (model%get_scheme ()), &
                "' (", model%get_scheme_num (), ")"
        end if
     end if
     if (show_par) then
        write (u, "(A)")
        do i = 1, size (model%par)
           call model%par(i)%write (u, write_defs=verbose)
        end do
     end if
     call model%model_data_t%write (unit, verbose, &
          show_md5sum, show_variables, &
          show_parameters=.false., &
          show_particles=show_particles, &
          show_vertices=show_vertices, &
          show_scheme=show_scheme)
     if (show_var) then
        write (u, "(A)")
        call var_list_write (model%var_list, unit, follow_link=.false.)
     end if
   end subroutine model_write
 
 @ %def model_write
 @ Screen output, condensed form.
 <<Models: model: TBP>>=
   procedure :: show => model_show
 <<Models: procedures>>=
   subroutine model_show (model, unit)
     class(model_t), intent(in) :: model
     integer, intent(in), optional :: unit
     integer :: i, u, l
     u = given_output_unit (unit)
     write (u, "(A,1x,A)")  "Model:", char (model%get_name ())
     if (model%has_schemes ()) then
        write (u, "(2x,A,A,A,I0,A)")  "Scheme: '", &
             char (model%get_scheme ()), "' (", model%get_scheme_num (), ")"
     end if
     l = model%max_field_name_length
     call model%show_fields (l, u)
     l = model%max_par_name_length
     if (any (model%par%type == PAR_INDEPENDENT)) then
        write (u, "(2x,A)")  "Independent parameters:"
        do i = 1, size (model%par)
           call model%par(i)%show (l, u, PAR_INDEPENDENT)
        end do
     end if
     if (any (model%par%type == PAR_DERIVED)) then
        write (u, "(2x,A)")  "Derived parameters:"
        do i = 1, size (model%par)
           call model%par(i)%show (l, u, PAR_DERIVED)
        end do
     end if
     if (any (model%par%type == PAR_EXTERNAL)) then
        write (u, "(2x,A)")  "External parameters:"
        do i = 1, size (model%par)
           call model%par(i)%show (l, u, PAR_EXTERNAL)
        end do
     end if
     if (any (model%par%type == PAR_UNUSED)) then
        write (u, "(2x,A)")  "Unused parameters:"
        do i = 1, size (model%par)
           call model%par(i)%show (l, u, PAR_UNUSED)
        end do
     end if
   end subroutine model_show
 
 @ %def model_show
 @ Show all fields/particles.
 <<Models: model: TBP>>=
   procedure :: show_fields => model_show_fields
 <<Models: procedures>>=
   subroutine model_show_fields (model, l, unit)
     class(model_t), intent(in), target :: model
     integer, intent(in) :: l
     integer, intent(in), optional :: unit
     type(field_data_t), pointer :: field
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(2x,A)")  "Particles:"
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        call field%show (l, u)
     end do
   end subroutine model_show_fields
 
 @ %def model_data_show_fields
 @ Show the list of stable, unstable, polarized, or unpolarized
 particles, respectively.
 <<Models: model: TBP>>=
   procedure :: show_stable => model_show_stable
   procedure :: show_unstable => model_show_unstable
   procedure :: show_polarized => model_show_polarized
   procedure :: show_unpolarized => model_show_unpolarized
 <<Models: procedures>>=
   subroutine model_show_stable (model, unit)
     class(model_t), intent(in), target :: model
     integer, intent(in), optional :: unit
     type(field_data_t), pointer :: field
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(A,1x)", advance="no")  "Stable particles:"
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        if (field%is_stable (.false.)) then
           write (u, "(1x,A)", advance="no")  char (field%get_name (.false.))
        end if
        if (field%has_antiparticle ()) then
           if (field%is_stable (.true.)) then
              write (u, "(1x,A)", advance="no")  char (field%get_name (.true.))
           end if
        end if
     end do
     write (u, *)
   end subroutine model_show_stable
 
   subroutine model_show_unstable (model, unit)
     class(model_t), intent(in), target :: model
     integer, intent(in), optional :: unit
     type(field_data_t), pointer :: field
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(A,1x)", advance="no")  "Unstable particles:"
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        if (.not. field%is_stable (.false.)) then
           write (u, "(1x,A)", advance="no")  char (field%get_name (.false.))
        end if
        if (field%has_antiparticle ()) then
           if (.not. field%is_stable (.true.)) then
              write (u, "(1x,A)", advance="no")  char (field%get_name (.true.))
           end if
        end if
     end do
     write (u, *)
   end subroutine model_show_unstable
 
   subroutine model_show_polarized (model, unit)
     class(model_t), intent(in), target :: model
     integer, intent(in), optional :: unit
     type(field_data_t), pointer :: field
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(A,1x)", advance="no")  "Polarized particles:"
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        if (field%is_polarized (.false.)) then
           write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
        end if
        if (field%has_antiparticle ()) then
           if (field%is_polarized (.true.)) then
              write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
           end if
        end if
     end do
     write (u, *)
   end subroutine model_show_polarized
 
   subroutine model_show_unpolarized (model, unit)
     class(model_t), intent(in), target :: model
     integer, intent(in), optional :: unit
     type(field_data_t), pointer :: field
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(A,1x)", advance="no")  "Unpolarized particles:"
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        if (.not. field%is_polarized (.false.)) then
           write (u, "(1x,A)", advance="no") &
                char (field%get_name (.false.))
        end if
        if (field%has_antiparticle ()) then
           if (.not. field%is_polarized (.true.)) then
              write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
           end if
        end if
     end do
     write (u, *)
   end subroutine model_show_unpolarized
 
 @ %def model_show_stable
 @ %def model_show_unstable
 @ %def model_show_polarized
 @ %def model_show_unpolarized
 @ Retrieve the MD5 sum of a model (actually, of the model file).
 <<Models: model: TBP>>=
   procedure :: get_md5sum => model_get_md5sum
 <<Models: procedures>>=
   function model_get_md5sum (model) result (md5sum)
     character(32) :: md5sum
     class(model_t), intent(in) :: model
     md5sum = model%md5sum
   end function model_get_md5sum
 
 @ %def model_get_md5sum
 @ Parameters are defined by an expression which may be constant or
 arbitrary.
 <<Models: model: TBP>>=
   procedure :: &
        set_parameter_constant => model_set_parameter_constant
   procedure, private :: &
        set_parameter_parse_node => model_set_parameter_parse_node
   procedure :: &
        set_parameter_external => model_set_parameter_external
   procedure :: &
        set_parameter_unused => model_set_parameter_unused
 <<Models: procedures>>=
   subroutine model_set_parameter_constant (model, i, name, value)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name
     real(default), intent(in) :: value
     logical, save, target :: known = .true.
     class(modelpar_data_t), pointer :: par_data
     real(default), pointer :: value_ptr
     par_data => model%get_par_real_ptr (i)
     call model%par(i)%init_independent_value (par_data, name, value)
     value_ptr => par_data%get_real_ptr ()
     call var_list_append_real_ptr (model%var_list, &
          name, value_ptr, &
          is_known=known, intrinsic=.true.)
     model%max_par_name_length = max (model%max_par_name_length, len (name))
   end subroutine model_set_parameter_constant
 
   subroutine model_set_parameter_parse_node (model, i, name, pn, constant)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name
     type(parse_node_t), intent(in), target :: pn
     logical, intent(in) :: constant
     logical, save, target :: known = .true.
     class(modelpar_data_t), pointer :: par_data
     real(default), pointer :: value_ptr
     par_data => model%get_par_real_ptr (i)
     if (constant) then
        call model%par(i)%init_independent (par_data, name, pn)
     else
        call model%par(i)%init_derived (par_data, name, pn, model%var_list)
     end if
     value_ptr => par_data%get_real_ptr ()
     call var_list_append_real_ptr (model%var_list, &
          name, value_ptr, &
          is_known=known, locked=.not.constant, intrinsic=.true.)
     model%max_par_name_length = max (model%max_par_name_length, len (name))
   end subroutine model_set_parameter_parse_node
 
   subroutine model_set_parameter_external (model, i, name)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name
     logical, save, target :: known = .true.
     class(modelpar_data_t), pointer :: par_data
     real(default), pointer :: value_ptr
     par_data => model%get_par_real_ptr (i)
     call model%par(i)%init_external (par_data, name)
     value_ptr => par_data%get_real_ptr ()
     call var_list_append_real_ptr (model%var_list, &
          name, value_ptr, &
          is_known=known, locked=.true., intrinsic=.true.)
     model%max_par_name_length = max (model%max_par_name_length, len (name))
   end subroutine model_set_parameter_external
 
   subroutine model_set_parameter_unused (model, i, name)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name
     class(modelpar_data_t), pointer :: par_data
     par_data => model%get_par_real_ptr (i)
     call model%par(i)%init_unused (par_data, name)
     call var_list_append_real (model%var_list, &
          name, locked=.true., intrinsic=.true.)
     model%max_par_name_length = max (model%max_par_name_length, len (name))
   end subroutine model_set_parameter_unused
 
 @ %def model_set_parameter
 @ Make a copy of a parameter.  We assume that the [[model_data_t]]
 parameter arrays have already been copied, so names and values are
 available in the current model, and can be used as targets.  The eval
 tree should not be copied, since it should refer to the new variable
 list.  The safe solution is to make use of the above initializers,
 which also take care of the building a new variable list.
 <<Models: model: TBP>>=
   procedure, private :: copy_parameter => model_copy_parameter
 <<Models: procedures>>=
   subroutine model_copy_parameter (model, i, par)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(parameter_t), intent(in) :: par
     type(string_t) :: name
     real(default) :: value
     name = par%data%get_name ()
     select case (par%type)
     case (PAR_INDEPENDENT)
        if (associated (par%pn)) then
           call model%set_parameter_parse_node (i, name, par%pn, &
                constant = .true.)
        else
           value = par%data%get_real ()
           call model%set_parameter_constant (i, name, value)
        end if
     case (PAR_DERIVED)
        call model%set_parameter_parse_node (i, name, par%pn, &
             constant = .false.)
     case (PAR_EXTERNAL)
        call model%set_parameter_external (i, name)
     case (PAR_UNUSED)
        call model%set_parameter_unused (i, name)
     end select
   end subroutine model_copy_parameter
 
 @ %def model_copy_parameter
 @ Recalculate all derived parameters.
 <<Models: model: TBP>>=
   procedure :: update_parameters => model_parameters_update
 <<Models: procedures>>=
   subroutine model_parameters_update (model)
     class(model_t), intent(inout) :: model
     integer :: i
     real(default), dimension(:), allocatable :: par
     do i = 1, size (model%par)
        call model%par(i)%reset_derived ()
     end do
     if (associated (model%init_external_parameters)) then
        allocate (par (model%get_n_real ()))
        call model%real_parameters_to_c_array (par)
        call model%init_external_parameters (par)
        call model%real_parameters_from_c_array (par)
        if (model%get_name() == var_str ("SM_tt_threshold")) &
             call set_threshold_parameters ()
     end if
   contains
     subroutine set_threshold_parameters ()
       real(default) :: mpole, wtop
       !!! !!! !!! Workaround for OS-X and BSD which do not load
       !!! !!! !!! the global values created previously. Therefore
       !!! !!! !!! a second initialization for the threshold model,
       !!! !!! !!! where M1S is required to compute the top mass.
       call init_parameters (mpole, wtop, &
            par(20), par(21), par(22), &
            par(19), par(39), par(4), par(1), &
            par(2), par(10), par(24), par(25), &
            par(23), par(26), par(27), par(29), &
            par(30), par(31), par(32), par(33), &
            par(36) > 0._default, par(28))
     end subroutine set_threshold_parameters
   end subroutine model_parameters_update
 
 @ %def model_parameters_update
 @ Initialize field data with PDG long name and PDG code.
 <<Models: model: TBP>>=
   procedure, private :: init_field => model_init_field
 <<Models: procedures>>=
   subroutine model_init_field (model, i, longname, pdg)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: longname
     integer, intent(in) :: pdg
     type(field_data_t), pointer :: field
     field => model%get_field_ptr_by_index (i)
     call field%init (longname, pdg)
   end subroutine model_init_field
 
 @ %def model_init_field
 @ Copy field data for index [[i]] from another particle which serves
 as a template.  The name should be the unique long name.
 <<Models: model: TBP>>=
   procedure, private :: copy_field => model_copy_field
 <<Models: procedures>>=
   subroutine model_copy_field (model, i, name_src)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name_src
     type(field_data_t), pointer :: field_src, field
     field_src => model%get_field_ptr (name_src)
     field => model%get_field_ptr_by_index (i)
     call field%copy_from (field_src)
   end subroutine model_copy_field
 
 @ %def model_copy_field
 @
 \subsection{Model Access via Variables}
 Write the model variable list.
 <<Models: model: TBP>>=
   procedure :: write_var_list => model_write_var_list
 <<Models: procedures>>=
   subroutine model_write_var_list (model, unit, follow_link)
     class(model_t), intent(in) :: model
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: follow_link
     call var_list_write (model%var_list, unit, follow_link)
   end subroutine model_write_var_list
 
 @ %def model_write_var_list
 @ Link a variable list to the model variables.
 <<Models: model: TBP>>=
   procedure :: link_var_list => model_link_var_list
 <<Models: procedures>>=
   subroutine model_link_var_list (model, var_list)
     class(model_t), intent(inout) :: model
     type(var_list_t), intent(in), target :: var_list
     call model%var_list%link (var_list)
   end subroutine model_link_var_list
 
 @ %def model_link_var_list
 @
 Check if the model contains a named variable.
 <<Models: model: TBP>>=
   procedure :: var_exists => model_var_exists
 <<Models: procedures>>=
   function model_var_exists (model, name) result (flag)
     class(model_t), intent(in) :: model
     type(string_t), intent(in) :: name
     logical :: flag
     flag = model%var_list%contains (name, follow_link=.false.)
   end function model_var_exists
 
 @ %def model_var_exists
 @ Check if the model variable is a derived parameter, i.e., locked.
 <<Models: model: TBP>>=
   procedure :: var_is_locked => model_var_is_locked
 <<Models: procedures>>=
   function model_var_is_locked (model, name) result (flag)
     class(model_t), intent(in) :: model
     type(string_t), intent(in) :: name
     logical :: flag
     flag = model%var_list%is_locked (name, follow_link=.false.)
   end function model_var_is_locked
 
 @ %def model_var_is_locked
 @ Set a model parameter via the named variable.  We assume that the
 variable exists and is writable, i.e., non-locked.  We update the
 model and variable list, so independent and derived parameters are
 always synchronized.
 <<Models: model: TBP>>=
   procedure :: set_real => model_var_set_real
 <<Models: procedures>>=
   subroutine model_var_set_real (model, name, rval, verbose, pacified)
     class(model_t), intent(inout) :: model
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in), optional :: verbose, pacified
     call model%var_list%set_real (name, rval, &
          is_known=.true., ignore=.false., &
          verbose=verbose, model_name=model%get_name (), pacified=pacified)
     call model%update_parameters ()
   end subroutine model_var_set_real
 
 @ %def model_var_set_real
 @ Retrieve a model parameter value.
 <<Models: model: TBP>>=
   procedure :: get_rval => model_var_get_rval
 <<Models: procedures>>=
   function model_var_get_rval (model, name) result (rval)
     class(model_t), intent(in) :: model
     type(string_t), intent(in) :: name
     real(default) :: rval
     rval = model%var_list%get_rval (name, follow_link=.false.)
   end function model_var_get_rval
 
 @ %def model_var_get_rval
 @
 [To be deleted] Return a pointer to the variable list.
 <<Models: model: TBP>>=
   procedure :: get_var_list_ptr => model_get_var_list_ptr
 <<Models: procedures>>=
   function model_get_var_list_ptr (model) result (var_list)
     type(var_list_t), pointer :: var_list
     class(model_t), intent(in), target :: model
     var_list => model%var_list
   end function model_get_var_list_ptr
 
 @ %def model_get_var_list_ptr
 @
 \subsection{UFO models}
 A single flag identifies a model as a UFO model.  There is no other
 distinction, but the flag allows us to handle built-in and UFO models
 with the same name in parallel.
 <<Models: model: TBP>>=
   procedure :: is_ufo_model => model_is_ufo_model
 <<Models: procedures>>=
   function model_is_ufo_model (model) result (flag)
     class(model_t), intent(in) :: model
     logical :: flag
     flag = model%ufo_model
   end function model_is_ufo_model
 
 @ %def model_is_ufo_model
 @ Return the UFO path used for fetching the UFO source.
 <<Models: model: TBP>>=
   procedure :: get_ufo_path => model_get_ufo_path
 <<Models: procedures>>=
   function model_get_ufo_path (model) result (path)
     class(model_t), intent(in) :: model
     type(string_t) :: path
     if (model%ufo_model) then
        path = model%ufo_path
     else
        path = ""
     end if
   end function model_get_ufo_path
 
 @ %def model_get_ufo_path
 @
 Call OMega and generate a model file from an UFO source file.  We
 start with a file name; the model name is expected to be the base
 name, stripping extensions.  
 
 The path search either takes [[ufo_path_requested]], or searches first
 in the working directory, then in a hard-coded UFO model directory.
 <<Models: procedures>>=
   subroutine model_generate_ufo (filename, os_data, ufo_path, &
        ufo_path_requested)
     type(string_t), intent(in) :: filename
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(out) :: ufo_path
     type(string_t), intent(in), optional :: ufo_path_requested
     type(string_t) :: model_name, omega_path, ufo_dir, ufo_init
     logical :: exist
     call get_model_name (filename, model_name)
     call msg_message ("Model: Generating model '" // char (model_name) &
          // "' from UFO sources")
     if (present (ufo_path_requested)) then
        call msg_message ("Model: Searching for UFO sources in '" &
             // char (ufo_path_requested) // "'")
        ufo_path = ufo_path_requested
        ufo_dir = ufo_path_requested // "/" // model_name
        ufo_init = ufo_dir // "/" // "__init__.py"
        inquire (file = char (ufo_init), exist = exist)
     else
        call msg_message ("Model: Searching for UFO sources in &
             &working directory")
        ufo_path = "."
        ufo_dir = ufo_path // "/" // model_name
        ufo_init = ufo_dir // "/" // "__init__.py"
        inquire (file = char (ufo_init), exist = exist)
        if (.not. exist) then
           ufo_path = char (os_data%whizard_modelpath_ufo)
           ufo_dir = ufo_path // "/" // model_name
           ufo_init = ufo_dir // "/" // "__init__.py"
           call msg_message ("Model: Searching for UFO sources in '" &
                // char (os_data%whizard_modelpath_ufo) // "'")
           inquire (file = char (ufo_init), exist = exist)
        end if
     end if
     if (exist) then
        call msg_message ("Model: Found UFO sources for model '" &
             // char (model_name) // "'")
     else
        call msg_fatal ("Model: UFO sources for model '" &
             // char (model_name) // "' not found")
     end if
     omega_path = os_data%whizard_omega_binpath // "/omega_UFO.opt"
     call os_system_call (omega_path &
          // " -model:UFO_dir " // ufo_dir &
          // " -model:exec" &
          // " -model:write_WHIZARD" &
          // " > " // filename)
     inquire (file = char (filename), exist = exist)
     if (exist) then
         call msg_message ("Model: Model file '" // char (filename) //&
              "' generated")
     else
         call msg_fatal ("Model: Model file '" // char (filename) &
              // "' could not be generated")
     end if
   contains
     subroutine get_model_name (filename, model_name)
        type(string_t), intent(in) :: filename
        type(string_t), intent(out) :: model_name
        type(string_t) :: string
        string = filename
        call split (string, model_name, ".")
     end subroutine get_model_name
   end subroutine model_generate_ufo
 
 @ %def model_generate_ufo
 @
 \subsection{Scheme handling}
 A model can specify a set of allowed schemes that steer the setup of
 model variables.  The model file can contain scheme-specific
 declarations that are selected by a [[select scheme]] clause.  Scheme
 support is optional.
 
 If enabled, the model object contains a list of allowed schemes, and
 the model reader takes the active scheme as an argument.  After the
 model has been read, the scheme is fixed and can no longer be
 modified.
 
 The model supports schemes if the scheme array is allocated.
 <<Models: model: TBP>>=
   procedure :: has_schemes => model_has_schemes
 <<Models: procedures>>=
   function model_has_schemes (model) result (flag)
     logical :: flag
     class(model_t), intent(in) :: model
     flag = allocated (model%schemes)
   end function model_has_schemes
 
 @ %def model_has_schemes
 @
 Enable schemes: fix the list of allowed schemes.
 <<Models: model: TBP>>=
   procedure :: enable_schemes => model_enable_schemes
 <<Models: procedures>>=
   subroutine model_enable_schemes (model, scheme)
     class(model_t), intent(inout) :: model
     type(string_t), dimension(:), intent(in) :: scheme
     allocate (model%schemes (size (scheme)), source = scheme)
   end subroutine model_enable_schemes
 
 @ %def model_enable_schemes
 @
 Find the scheme.  Check if the scheme is allowed.  The numeric index of the
 selected scheme is stored in the [[model_data_t]] base object.
 
 If no argument is given,
 select the first scheme.  The numeric scheme ID will then be $1$, while a
 model without schemes retains $0$.
 <<Models: model: TBP>>=
   procedure :: set_scheme => model_set_scheme
 <<Models: procedures>>=
   subroutine model_set_scheme (model, scheme)
     class(model_t), intent(inout) :: model
     type(string_t), intent(in), optional :: scheme
     logical :: ok
     integer :: i
     if (model%has_schemes ()) then
        if (present (scheme)) then
           ok = .false.
           CHECK_SCHEME: do i = 1, size (model%schemes)
              if (scheme == model%schemes(i)) then
                 allocate (model%selected_scheme, source = scheme)
                 call model%set_scheme_num (i)
                 ok = .true.
                 exit CHECK_SCHEME
              end if
           end do CHECK_SCHEME
           if (.not. ok) then
              call msg_fatal &
                   ("Model '" // char (model%get_name ()) &
                   // "': scheme '" // char (scheme) // "' not supported")
           end if
        else
           allocate (model%selected_scheme, source = model%schemes(1))
           call model%set_scheme_num (1)
        end if
     else
        if (present (scheme)) then
           call msg_error &
                   ("Model '" // char (model%get_name ()) &
                   // "' does not support schemes")
        end if
     end if
   end subroutine model_set_scheme
 
 @ %def model_set_scheme
 @
 Get the scheme.  Note that the base [[model_data_t]] provides a
 [[get_scheme_num]] getter function.
 <<Models: model: TBP>>=
   procedure :: get_scheme => model_get_scheme
 <<Models: procedures>>=
   function model_get_scheme (model) result (scheme)
     class(model_t), intent(in) :: model
     type(string_t) :: scheme
     if (allocated (model%selected_scheme)) then
        scheme = model%selected_scheme
     else
        scheme = ""
     end if
   end function model_get_scheme
 
 @ %def model_get_scheme
 @
 Check if a model has been set up with a specific name and (if
 applicable) scheme.  This helps in determining whether we need a new
 model object.
 
 A UFO model is considered to be distinct from a non-UFO model.  We assume that
 if [[ufo]] is asked for, there is no scheme argument.  Furthermore,
 if there is an [[ufo_path]] requested, it must coincide with the
 [[ufo_path]] of the model.  If not, the model [[ufo_path]] is not checked.
 <<Models: model: TBP>>=
   procedure :: matches => model_matches
 <<Models: procedures>>=
   function model_matches (model, name, scheme, ufo, ufo_path) result (flag)
     logical :: flag
     class(model_t), intent(in) :: model
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: scheme
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path
     logical :: ufo_model
     ufo_model = .false.;  if (present (ufo))  ufo_model = ufo
     if (name /= model%get_name ()) then
        flag = .false.
     else if (ufo_model .neqv. model%is_ufo_model ()) then
        flag = .false.
     else if (ufo_model) then
        if (present (ufo_path)) then
           flag = model%get_ufo_path () == ufo_path
        else
           flag = .true.
        end if
     else if (model%has_schemes ()) then
        if (present (scheme)) then
           flag = model%get_scheme () == scheme
        else
           flag = model%get_scheme_num () == 1
        end if
     else if (present (scheme)) then
        flag = .false.
     else
        flag = .true.
     end if
   end function model_matches
 
 @ %def model_matches
 @
 \subsection{Reading models from file}
 This procedure defines the model-file syntax for the parser, returning
 an internal file (ifile).
 
 Note that arithmetic operators are defined as keywords in the
 expression syntax, so we exclude them here.
 <<Models: procedures>>=
   subroutine define_model_file_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ model_def = model_name_def " // &
          "scheme_header parameters external_pars particles vertices")
     call ifile_append (ifile, "SEQ model_name_def = model model_name")
     call ifile_append (ifile, "KEY model")
     call ifile_append (ifile, "QUO model_name = '""'...'""'")
     call ifile_append (ifile, "SEQ scheme_header = scheme_decl?")
     call ifile_append (ifile, "SEQ scheme_decl = schemes '=' scheme_list")
     call ifile_append (ifile, "KEY schemes")
     call ifile_append (ifile, "LIS scheme_list = scheme_name+")
     call ifile_append (ifile, "QUO scheme_name = '""'...'""'")
     call ifile_append (ifile, "SEQ parameters = generic_par_def*")
     call ifile_append (ifile, "ALT generic_par_def = &
          &parameter_def | derived_def | unused_def | scheme_block")
     call ifile_append (ifile, "SEQ parameter_def = parameter par_name " // &
-         "'=' any_real_value")
+         "'=' any_real_value slha_annotation?")
     call ifile_append (ifile, "ALT any_real_value = " &
          // "neg_real_value | pos_real_value | real_value")
     call ifile_append (ifile, "SEQ neg_real_value = '-' real_value")
     call ifile_append (ifile, "SEQ pos_real_value = '+' real_value")
     call ifile_append (ifile, "KEY parameter")
     call ifile_append (ifile, "IDE par_name")
     ! call ifile_append (ifile, "KEY '='")          !!! Key already exists
+    call ifile_append (ifile, "SEQ slha_annotation = " // &
+         "slha_entry slha_block_name slha_entry_index")
+    call ifile_append (ifile, "KEY slha_entry")
+    call ifile_append (ifile, "IDE slha_block_name")
+    call ifile_append (ifile, "INT slha_entry_index")
     call ifile_append (ifile, "SEQ derived_def = derived par_name " // &
          "'=' expr")
     call ifile_append (ifile, "KEY derived")
     call ifile_append (ifile, "SEQ unused_def = unused par_name")
     call ifile_append (ifile, "KEY unused")
     call ifile_append (ifile, "SEQ external_pars = external_def*")
     call ifile_append (ifile, "SEQ external_def = external par_name")
     call ifile_append (ifile, "KEY external")
     call ifile_append (ifile, "SEQ scheme_block = &
          &scheme_block_beg scheme_block_body scheme_block_end")
     call ifile_append (ifile, "SEQ scheme_block_beg = select scheme")
     call ifile_append (ifile, "SEQ scheme_block_body = scheme_block_case*")
     call ifile_append (ifile, "SEQ scheme_block_case = &
          &scheme scheme_id parameters")
     call ifile_append (ifile, "ALT scheme_id = scheme_list | other")
     call ifile_append (ifile, "SEQ scheme_block_end = end select")
     call ifile_append (ifile, "KEY select")
     call ifile_append (ifile, "KEY scheme")
     call ifile_append (ifile, "KEY other")
     call ifile_append (ifile, "KEY end")
     call ifile_append (ifile, "SEQ particles = particle_def*")
     call ifile_append (ifile, "SEQ particle_def = particle name_def " // &
          "prt_pdg prt_details")
     call ifile_append (ifile, "KEY particle")
     call ifile_append (ifile, "INT prt_pdg")
     call ifile_append (ifile, "ALT prt_details = prt_src | prt_properties")
     call ifile_append (ifile, "SEQ prt_src = like name_def prt_properties")
     call ifile_append (ifile, "KEY like")
     call ifile_append (ifile, "SEQ prt_properties = prt_property*")
     call ifile_append (ifile, "ALT prt_property = " // &
          "parton | invisible | gauge | left | right | " // &
          "prt_name | prt_anti | prt_tex_name | prt_tex_anti | " // &
          "prt_spin | prt_isospin | prt_charge | " // &
          "prt_color | prt_mass | prt_width")
     call ifile_append (ifile, "KEY parton")
     call ifile_append (ifile, "KEY invisible")
     call ifile_append (ifile, "KEY gauge")
     call ifile_append (ifile, "KEY left")
     call ifile_append (ifile, "KEY right")
     call ifile_append (ifile, "SEQ prt_name = name name_def+")
     call ifile_append (ifile, "SEQ prt_anti = anti name_def+")
     call ifile_append (ifile, "SEQ prt_tex_name = tex_name name_def")
     call ifile_append (ifile, "SEQ prt_tex_anti = tex_anti name_def")
     call ifile_append (ifile, "KEY name")
     call ifile_append (ifile, "KEY anti")
     call ifile_append (ifile, "KEY tex_name")
     call ifile_append (ifile, "KEY tex_anti")
     call ifile_append (ifile, "ALT name_def = name_string | name_id")
     call ifile_append (ifile, "QUO name_string = '""'...'""'")
     call ifile_append (ifile, "IDE name_id")
     call ifile_append (ifile, "SEQ prt_spin = spin frac")
     call ifile_append (ifile, "KEY spin")
     call ifile_append (ifile, "SEQ prt_isospin = isospin frac")
     call ifile_append (ifile, "KEY isospin")
     call ifile_append (ifile, "SEQ prt_charge = charge frac")
     call ifile_append (ifile, "KEY charge")
     call ifile_append (ifile, "SEQ prt_color = color integer_literal")
     call ifile_append (ifile, "KEY color")
     call ifile_append (ifile, "SEQ prt_mass = mass par_name")
     call ifile_append (ifile, "KEY mass")
     call ifile_append (ifile, "SEQ prt_width = width par_name")
     call ifile_append (ifile, "KEY width")
     call ifile_append (ifile, "SEQ vertices = vertex_def*")
     call ifile_append (ifile, "SEQ vertex_def = vertex name_def+")
     call ifile_append (ifile, "KEY vertex")
     call define_expr_syntax (ifile, particles=.false., analysis=.false.)
   end subroutine define_model_file_syntax
 
 @ %def define_model_file_syntax
 @ The model-file syntax and lexer are fixed, therefore stored as
 module variables:
 <<Models: variables>>=
   type(syntax_t), target, save :: syntax_model_file
 
 @ %def syntax_model_file
 <<Models: public>>=
   public :: syntax_model_file_init
 <<Models: procedures>>=
   subroutine syntax_model_file_init ()
     type(ifile_t) :: ifile
     call define_model_file_syntax (ifile)
     call syntax_init (syntax_model_file, ifile)
     call ifile_final (ifile)
   end subroutine syntax_model_file_init
 
 @ %def syntax_model_file_init
 <<Models: procedures>>=
   subroutine lexer_init_model_file (lexer)
     type(lexer_t), intent(out) :: lexer
     call lexer_init (lexer, &
          comment_chars = "#!", &
          quote_chars = '"{', &
          quote_match = '"}', &
          single_chars = ":(),", &
          special_class = [ "+-*/^", "<>=  " ] , &
          keyword_list = syntax_get_keyword_list_ptr (syntax_model_file))
   end subroutine lexer_init_model_file
 
 @ %def lexer_init_model_file
 <<Models: public>>=
   public :: syntax_model_file_final
 <<Models: procedures>>=
   subroutine syntax_model_file_final ()
     call syntax_final (syntax_model_file)
   end subroutine syntax_model_file_final
 
 @ %def syntax_model_file_final
 <<Models: public>>=
   public :: syntax_model_file_write
 <<Models: procedures>>=
   subroutine syntax_model_file_write (unit)
     integer, intent(in), optional :: unit
     call syntax_write (syntax_model_file, unit)
   end subroutine syntax_model_file_write
 
 @ %def syntax_model_file_write
 @
 Read a model from file.  Handle all syntax and respect the provided scheme.
 
 The [[ufo]] flag just says that the model object should be tagged as
 being derived from an UFO model.  The UFO model path may be requested
 by the caller.  If not, we use a standard path search for UFO models.
 There is no difference in the
 contents of the file or the generated model object.
 <<Models: model: TBP>>=
   procedure :: read => model_read
 <<Models: procedures>>=
   subroutine model_read (model, filename, os_data, exist, &
        scheme, ufo, ufo_path_requested, rebuild_mdl)
     class(model_t), intent(out), target :: model
     type(string_t), intent(in) :: filename
     type(os_data_t), intent(in) :: os_data
     logical, intent(out), optional :: exist
     type(string_t), intent(in), optional :: scheme
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path_requested
     logical, intent(in), optional :: rebuild_mdl
     type(string_t) :: file
     type(stream_t), target :: stream
     type(lexer_t) :: lexer
     integer :: unit
     character(32) :: model_md5sum
     type(parse_node_t), pointer :: nd_model_def, nd_model_name_def
     type(parse_node_t), pointer :: nd_schemes, nd_scheme_decl
     type(parse_node_t), pointer :: nd_parameters
     type(parse_node_t), pointer :: nd_external_pars
     type(parse_node_t), pointer :: nd_particles, nd_vertices
     type(string_t) :: model_name, lib_name
     integer :: n_parblock, n_par, i_par, n_ext, n_prt, n_vtx
     type(parse_node_t), pointer :: nd_par_def
     type(parse_node_t), pointer :: nd_ext_def
     type(parse_node_t), pointer :: nd_prt
     type(parse_node_t), pointer :: nd_vtx
     logical :: ufo_model, model_exist, rebuild
     ufo_model = .false.;  if (present (ufo))  ufo_model = ufo
     rebuild = .true.; if (present (rebuild_mdl))  rebuild = rebuild_mdl
     file = filename
     inquire (file=char(file), exist=model_exist)
     if ((.not. model_exist) .and. (.not. os_data%use_testfiles)) then
        file = os_data%whizard_modelpath_local // "/" // filename
        inquire (file = char (file), exist = model_exist)
     end if
     if (.not. model_exist) then
        file = os_data%whizard_modelpath // "/" // filename
        inquire (file = char (file), exist = model_exist)
     end if
     if (ufo_model .and. rebuild) then
        file = filename
        call model_generate_ufo (filename, os_data, model%ufo_path, &
             ufo_path_requested=ufo_path_requested)
        inquire (file = char (file), exist = model_exist)
     end if
     if (.not. model_exist) then
        call msg_fatal ("Model file '" // char (filename) // "' not found")
        if (present (exist))  exist = .false.
        return
     end if
     if (present (exist))  exist = .true.
 
     if (logging) call msg_message ("Reading model file '" // char (file) // "'")
 
     unit = free_unit ()
     open (file=char(file), unit=unit, action="read", status="old")
     model_md5sum = md5sum (unit)
     close (unit)
 
     call lexer_init_model_file (lexer)
     call stream_init (stream, char (file))
     call lexer_assign_stream (lexer, stream)
     call parse_tree_init (model%parse_tree, syntax_model_file, lexer)
     call stream_final (stream)
     call lexer_final (lexer)
 
     nd_model_def => model%parse_tree%get_root_ptr ()
     nd_model_name_def => parse_node_get_sub_ptr (nd_model_def)
     model_name = parse_node_get_string &
          (parse_node_get_sub_ptr (nd_model_name_def, 2))
     nd_schemes => nd_model_name_def%get_next_ptr ()
 
     call find_block &
          ("scheme_header", nd_schemes, nd_scheme_decl, nd_next=nd_parameters)
     call find_block &
          ("parameters", nd_parameters, nd_par_def, n_parblock, nd_external_pars)
     call find_block &
          ("external_pars", nd_external_pars, nd_ext_def, n_ext, nd_particles)
     call find_block &
          ("particles", nd_particles, nd_prt, n_prt, nd_vertices)
     call find_block &
          ("vertices", nd_vertices, nd_vtx, n_vtx)
 
     if (associated (nd_external_pars)) then
        lib_name = "external." // model_name
     else
        lib_name = ""
     end if
 
     if (associated (nd_scheme_decl)) then
        call handle_schemes (nd_scheme_decl, scheme)
     end if
 
     n_par = 0
     call count_parameters (nd_par_def, n_parblock, n_par)
 
     call model%init &
          (model_name, lib_name, os_data, n_par + n_ext, n_prt, n_vtx, ufo)
     model%md5sum = model_md5sum
 
     if (associated (nd_par_def)) then
        i_par = 0
        call handle_parameters (nd_par_def, n_parblock, i_par)
     end if
     if (associated (nd_ext_def)) then
        call handle_external (nd_ext_def, n_par, n_ext)
     end if
     call model%update_parameters ()
     if (associated (nd_prt)) then
        call handle_fields (nd_prt, n_prt)
     end if
     if (associated (nd_vtx)) then
        call handle_vertices (nd_vtx, n_vtx)
     end if
 
     call model%freeze_vertices ()
     call model%append_field_vars ()
 
   contains
 
     subroutine find_block (key, nd, nd_item, n_item, nd_next)
       character(*), intent(in) :: key
       type(parse_node_t), pointer, intent(inout) :: nd
       type(parse_node_t), pointer, intent(out) :: nd_item
       integer, intent(out), optional :: n_item
       type(parse_node_t), pointer, intent(out), optional :: nd_next
       if (associated (nd)) then
          if (nd%get_rule_key () == key) then
             nd_item => nd%get_sub_ptr ()
             if (present (n_item))  n_item = nd%get_n_sub ()
             if (present (nd_next))  nd_next => nd%get_next_ptr ()
          else
             nd_item => null ()
             if (present (n_item))  n_item = 0
             if (present (nd_next))  nd_next => nd
             nd => null ()
          end if
       else
          nd_item => null ()
          if (present (n_item))  n_item = 0
          if (present (nd_next))  nd_next => null ()
       end if
     end subroutine find_block
 
     subroutine handle_schemes (nd_scheme_decl, scheme)
       type(parse_node_t), pointer, intent(in) :: nd_scheme_decl
       type(string_t), intent(in), optional :: scheme
       type(parse_node_t), pointer :: nd_list, nd_entry
       type(string_t), dimension(:), allocatable :: schemes
       integer :: i, n_schemes
       nd_list => nd_scheme_decl%get_sub_ptr (3)
       nd_entry => nd_list%get_sub_ptr ()
       n_schemes = nd_list%get_n_sub ()
       allocate (schemes (n_schemes))
       do i = 1, n_schemes
          schemes(i) = nd_entry%get_string ()
          nd_entry => nd_entry%get_next_ptr ()
       end do
       if (present (scheme)) then
          do i = 1, n_schemes
             if (schemes(i) == scheme)  goto 10   ! block exit
          end do
          call msg_fatal ("Scheme '" // char (scheme) &
               // "' is not supported by model '" // char (model_name) // "'")
       end if
 10    continue
       call model%enable_schemes (schemes)
       call model%set_scheme (scheme)
     end subroutine handle_schemes
 
     subroutine select_scheme (nd_scheme_block, n_parblock_sub, nd_par_def)
       type(parse_node_t), pointer, intent(in) :: nd_scheme_block
       integer, intent(out) :: n_parblock_sub
       type(parse_node_t), pointer, intent(out) :: nd_par_def
       type(parse_node_t), pointer :: nd_scheme_body
       type(parse_node_t), pointer :: nd_scheme_case, nd_scheme_id, nd_scheme
       type(string_t) :: scheme
       integer :: n_cases, i
       scheme = model%get_scheme ()
       nd_scheme_body => nd_scheme_block%get_sub_ptr (2)
       nd_parameters => null ()
       select case (char (nd_scheme_body%get_rule_key ()))
       case ("scheme_block_body")
          n_cases = nd_scheme_body%get_n_sub ()
          FIND_SCHEME: do i = 1, n_cases
             nd_scheme_case => nd_scheme_body%get_sub_ptr (i)
             nd_scheme_id => nd_scheme_case%get_sub_ptr (2)
             select case (char (nd_scheme_id%get_rule_key ()))
             case ("scheme_list")
                nd_scheme => nd_scheme_id%get_sub_ptr ()
                do while (associated (nd_scheme))
                   if (scheme == nd_scheme%get_string ()) then
                      nd_parameters => nd_scheme_id%get_next_ptr ()
                      exit FIND_SCHEME
                   end if
                   nd_scheme => nd_scheme%get_next_ptr ()
                end do
             case ("other")
                nd_parameters => nd_scheme_id%get_next_ptr ()
                exit FIND_SCHEME
             case default
                print *, "'", char (nd_scheme_id%get_rule_key ()), "'"
                call msg_bug ("Model read: impossible scheme rule")
             end select
          end do FIND_SCHEME
       end select
       if (associated (nd_parameters)) then
          select case (char (nd_parameters%get_rule_key ()))
          case ("parameters")
             n_parblock_sub = nd_parameters%get_n_sub ()
             if (n_parblock_sub > 0) then
                nd_par_def => nd_parameters%get_sub_ptr ()
             else
                nd_par_def => null ()
             end if
          case default
             n_parblock_sub = 0
             nd_par_def => null ()
          end select
       else
          n_parblock_sub = 0
          nd_par_def => null ()
       end if
     end subroutine select_scheme
 
     recursive subroutine count_parameters (nd_par_def_in, n_parblock, n_par)
       type(parse_node_t), pointer, intent(in) :: nd_par_def_in
       integer, intent(in) :: n_parblock
       integer, intent(inout) :: n_par
       type(parse_node_t), pointer :: nd_par_def, nd_par_key
       type(parse_node_t), pointer :: nd_par_def_sub
       integer :: n_parblock_sub
       integer :: i
       nd_par_def => nd_par_def_in
       do i = 1, n_parblock
          nd_par_key => nd_par_def%get_sub_ptr ()
          select case (char (nd_par_key%get_rule_key ()))
          case ("parameter", "derived", "unused")
             n_par = n_par + 1
          case ("scheme_block_beg")
             call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub)
             if (n_parblock_sub > 0) then
                call count_parameters (nd_par_def_sub, n_parblock_sub, n_par)
             end if
          case default
             print *, "'", char (nd_par_key%get_rule_key ()), "'"
             call msg_bug ("Model read: impossible parameter rule")
          end select
          nd_par_def => parse_node_get_next_ptr (nd_par_def)
       end do
     end subroutine count_parameters
 
     recursive subroutine handle_parameters (nd_par_def_in, n_parblock, i_par)
       type(parse_node_t), pointer, intent(in) :: nd_par_def_in
       integer, intent(in) :: n_parblock
       integer, intent(inout) :: i_par
       type(parse_node_t), pointer :: nd_par_def, nd_par_key
       type(parse_node_t), pointer :: nd_par_def_sub
       integer :: n_parblock_sub
       integer :: i
       nd_par_def => nd_par_def_in
       do i = 1, n_parblock
          nd_par_key => nd_par_def%get_sub_ptr ()
          select case (char (nd_par_key%get_rule_key ()))
          case ("parameter")
             i_par = i_par + 1
             call model%read_parameter (i_par, nd_par_def)
          case ("derived")
             i_par = i_par + 1
             call model%read_derived (i_par, nd_par_def)
          case ("unused")
             i_par = i_par + 1
             call model%read_unused (i_par, nd_par_def)
          case ("scheme_block_beg")
             call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub)
             if (n_parblock_sub > 0) then
                call handle_parameters (nd_par_def_sub, n_parblock_sub, i_par)
             end if
          end select
          nd_par_def => parse_node_get_next_ptr (nd_par_def)
       end do
     end subroutine handle_parameters
 
     subroutine handle_external (nd_ext_def, n_par, n_ext)
       type(parse_node_t), pointer, intent(inout) :: nd_ext_def
       integer, intent(in) :: n_par, n_ext
       integer :: i
       do i = n_par + 1, n_par + n_ext
          call model%read_external (i, nd_ext_def)
          nd_ext_def => parse_node_get_next_ptr (nd_ext_def)
       end do
 !     real(c_default_float), dimension(:), allocatable :: par
 !       if (associated (model%init_external_parameters)) then
 !          allocate (par (model%get_n_real ()))
 !          call model%real_parameters_to_c_array (par)
 !          call model%init_external_parameters (par)
 !          call model%real_parameters_from_c_array (par)
 !       end if
     end subroutine handle_external
 
     subroutine handle_fields (nd_prt, n_prt)
       type(parse_node_t), pointer, intent(inout) :: nd_prt
       integer, intent(in) :: n_prt
       integer :: i
       do i = 1, n_prt
          call model%read_field (i, nd_prt)
          nd_prt => parse_node_get_next_ptr (nd_prt)
       end do
     end subroutine handle_fields
 
     subroutine handle_vertices (nd_vtx, n_vtx)
       type(parse_node_t), pointer, intent(inout) :: nd_vtx
       integer, intent(in) :: n_vtx
       integer :: i
       do i = 1, n_vtx
          call model%read_vertex (i, nd_vtx)
          nd_vtx => parse_node_get_next_ptr (nd_vtx)
       end do
     end subroutine handle_vertices
 
   end subroutine model_read
 
 @ %def model_read
 @ Parameters are real values (literal) with an optional unit.
 <<Models: model: TBP>>=
   procedure, private :: read_parameter => model_read_parameter
 <<Models: procedures>>=
   subroutine model_read_parameter (model, i, node)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(parse_node_t), intent(in), target :: node
     type(parse_node_t), pointer :: node_name, node_val
     type(string_t) :: name
     node_name => parse_node_get_sub_ptr (node, 2)
     name = parse_node_get_string (node_name)
     node_val => parse_node_get_next_ptr (node_name, 2)
     call model%set_parameter_parse_node (i, name, node_val, constant=.true.)
   end subroutine model_read_parameter
 
 @ %def model_read_parameter
 @ Derived parameters have any numeric expression as their definition.
 Don't evaluate the expression, yet.
 <<Models: model: TBP>>=
   procedure, private :: read_derived => model_read_derived
 <<Models: procedures>>=
   subroutine model_read_derived (model, i, node)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(parse_node_t), intent(in), target :: node
     type(string_t) :: name
     type(parse_node_t), pointer :: pn_expr
     name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
     pn_expr => parse_node_get_sub_ptr (node, 4)
     call model%set_parameter_parse_node (i, name, pn_expr, constant=.false.)
   end subroutine model_read_derived
 
 @ %def model_read_derived
 @ External parameters have no definition; they are handled by an
 external library.
 <<Models: model: TBP>>=
   procedure, private :: read_external => model_read_external
 <<Models: procedures>>=
   subroutine model_read_external (model, i, node)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(parse_node_t), intent(in), target :: node
     type(string_t) :: name
     name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
     call model%set_parameter_external (i, name)
   end subroutine model_read_external
 
 @ %def model_read_external
 @ Ditto for unused parameters, they are there just for reserving the name.
 <<Models: model: TBP>>=
   procedure, private :: read_unused => model_read_unused
 <<Models: procedures>>=
   subroutine model_read_unused (model, i, node)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(parse_node_t), intent(in), target :: node
     type(string_t) :: name
     name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
     call model%set_parameter_unused (i, name)
   end subroutine model_read_unused
 
 @ %def model_read_unused
 <<Models: model: TBP>>=
   procedure, private :: read_field => model_read_field
 <<Models: procedures>>=
   subroutine model_read_field (model, i, node)
     class(model_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(parse_node_t), intent(in) :: node
     type(parse_node_t), pointer :: nd_src, nd_props, nd_prop
     type(string_t) :: longname
     integer :: pdg
     type(string_t) :: name_src
     type(string_t), dimension(:), allocatable :: name
     type(field_data_t), pointer :: field, field_src
     longname = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
     pdg = parse_node_get_integer (parse_node_get_sub_ptr (node, 3))
     field => model%get_field_ptr_by_index (i)
     call field%init (longname, pdg)
     nd_src => parse_node_get_sub_ptr (node, 4)
     if (associated (nd_src)) then
        if (parse_node_get_rule_key (nd_src) == "prt_src") then
           name_src = parse_node_get_string (parse_node_get_sub_ptr (nd_src, 2))
           field_src => model%get_field_ptr (name_src, check=.true.)
           call field%copy_from (field_src)
           nd_props => parse_node_get_sub_ptr (nd_src, 3)
        else
           nd_props => nd_src
        end if
        nd_prop => parse_node_get_sub_ptr (nd_props)
        do while (associated (nd_prop))
           select case (char (parse_node_get_rule_key (nd_prop)))
           case ("invisible")
              call field%set (is_visible=.false.)
           case ("parton")
              call field%set (is_parton=.true.)
           case ("gauge")
              call field%set (is_gauge=.true.)
           case ("left")
              call field%set (is_left_handed=.true.)
           case ("right")
              call field%set (is_right_handed=.true.)
           case ("prt_name")
              call read_names (nd_prop, name)
              call field%set (name=name)
           case ("prt_anti")
              call read_names (nd_prop, name)
              call field%set (anti=name)
           case ("prt_tex_name")
              call field%set ( &
                   tex_name = parse_node_get_string &
                   (parse_node_get_sub_ptr (nd_prop, 2)))
           case ("prt_tex_anti")
              call field%set ( &
                   tex_anti = parse_node_get_string &
                   (parse_node_get_sub_ptr (nd_prop, 2)))
           case ("prt_spin")
              call field%set ( &
                   spin_type = read_frac &
                   (parse_node_get_sub_ptr (nd_prop, 2), 2))
           case ("prt_isospin")
              call field%set ( &
                   isospin_type = read_frac &
                   (parse_node_get_sub_ptr (nd_prop, 2), 2))
           case ("prt_charge")
              call field%set ( &
                   charge_type = read_frac &
                   (parse_node_get_sub_ptr (nd_prop, 2), 3))
           case ("prt_color")
              call field%set ( &
                   color_type = parse_node_get_integer &
                   (parse_node_get_sub_ptr (nd_prop, 2)))
           case ("prt_mass")
              call field%set ( &
                   mass_data = model%get_par_data_ptr &
                   (parse_node_get_string &
                   (parse_node_get_sub_ptr (nd_prop, 2))))
           case ("prt_width")
              call field%set ( &
                   width_data = model%get_par_data_ptr &
                   (parse_node_get_string &
                   (parse_node_get_sub_ptr (nd_prop, 2))))
           case default
              call msg_bug (" Unknown particle property '" &
                   // char (parse_node_get_rule_key (nd_prop)) // "'")
           end select
           if (allocated (name))  deallocate (name)
           nd_prop => parse_node_get_next_ptr (nd_prop)
        end do
     end if
     call field%freeze ()
   end subroutine model_read_field
 
 @ %def model_read_field
 <<Models: model: TBP>>=
   procedure, private :: read_vertex => model_read_vertex
 <<Models: procedures>>=
   subroutine model_read_vertex (model, i, node)
     class(model_t), intent(inout) :: model
     integer, intent(in) :: i
     type(parse_node_t), intent(in) :: node
     type(string_t), dimension(:), allocatable :: name
     call read_names (node, name)
     call model%set_vertex (i, name)
   end subroutine model_read_vertex
 
 @ %def model_read_vertex
 <<Models: procedures>>=
   subroutine read_names (node, name)
     type(parse_node_t), intent(in) :: node
     type(string_t), dimension(:), allocatable, intent(inout) :: name
     type(parse_node_t), pointer :: nd_name
     integer :: n_names, i
     n_names = parse_node_get_n_sub (node) - 1
     allocate (name (n_names))
     nd_name => parse_node_get_sub_ptr (node, 2)
     do i = 1, n_names
        name(i) = parse_node_get_string (nd_name)
        nd_name => parse_node_get_next_ptr (nd_name)
     end do
   end subroutine read_names
 
 @ %def read_names
 <<Models: procedures>>=
   function read_frac (nd_frac, base) result (qn_type)
     integer :: qn_type
     type(parse_node_t), intent(in) :: nd_frac
     integer, intent(in) :: base
     type(parse_node_t), pointer :: nd_num, nd_den
     integer :: num, den
     nd_num => parse_node_get_sub_ptr (nd_frac)
     nd_den => parse_node_get_next_ptr (nd_num)
     select case (char (parse_node_get_rule_key (nd_num)))
     case ("integer_literal")
        num = parse_node_get_integer (nd_num)
     case ("neg_int")
        num = - parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2))
     case ("pos_int")
        num = parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2))
     case default
        call parse_tree_bug (nd_num, "int|neg_int|pos_int")
     end select
     if (associated (nd_den)) then
        den = parse_node_get_integer (parse_node_get_sub_ptr (nd_den, 2))
     else
        den = 1
     end if
     if (den == 1) then
        qn_type = sign (1 + abs (num) * base, num)
     else if (den == base) then
        qn_type = sign (abs (num) + 1, num)
     else
        call parse_node_write_rec (nd_frac)
        call msg_fatal (" Fractional quantum number: wrong denominator")
     end if
   end function read_frac
 
 @ %def read_frac
 @ Append field (PDG-array) variables to the variable list, based on
 the field content.
 <<Models: model: TBP>>=
   procedure, private :: append_field_vars => model_append_field_vars
 <<Models: procedures>>=
   subroutine model_append_field_vars (model)
     class(model_t), intent(inout) :: model
     type(pdg_array_t) :: aval
     type(field_data_t), dimension(:), pointer :: field_array
     type(field_data_t), pointer :: field
     type(string_t) :: name
     type(string_t), dimension(:), allocatable :: name_array
     integer, dimension(:), allocatable :: pdg
     logical, dimension(:), allocatable :: mask
     integer :: i, j
     field_array => model%get_field_array_ptr ()
     aval = UNDEFINED
     call var_list_append_pdg_array &
          (model%var_list, var_str ("particle"), &
           aval, locked = .true., intrinsic=.true.)
     do i = 1, size (field_array)
        aval = field_array(i)%get_pdg ()
        name = field_array(i)%get_longname ()
        call var_list_append_pdg_array &
             (model%var_list, name, aval, locked=.true., intrinsic=.true.)
        call field_array(i)%get_name_array (.false., name_array)
        do j = 1, size (name_array)
           call var_list_append_pdg_array &
                (model%var_list, name_array(j), &
                aval, locked=.true., intrinsic=.true.)
        end do
        model%max_field_name_length = &
             max (model%max_field_name_length, len (name_array(1)))
        aval = - field_array(i)%get_pdg ()
        call field_array(i)%get_name_array (.true., name_array)
        do j = 1, size (name_array)
           call var_list_append_pdg_array &
                (model%var_list, name_array(j), &
                aval, locked=.true., intrinsic=.true.)
        end do
        if (size (name_array) > 0) then
           model%max_field_name_length = &
                max (model%max_field_name_length, len (name_array(1)))
        end if
     end do
     call model%get_all_pdg (pdg)
     allocate (mask (size (pdg)))
     do i = 1, size (pdg)
        field => model%get_field_ptr (pdg(i))
        mask(i) = field%get_charge_type () /= 1
     end do
     aval = pack (pdg, mask)
     call var_list_append_pdg_array &
          (model%var_list, var_str ("charged"), &
           aval, locked = .true., intrinsic=.true.)
     do i = 1, size (pdg)
        field => model%get_field_ptr (pdg(i))
        mask(i) = field%get_charge_type () == 1
     end do
     aval = pack (pdg, mask)
     call var_list_append_pdg_array &
          (model%var_list, var_str ("neutral"), &
           aval, locked = .true., intrinsic=.true.)
     do i = 1, size (pdg)
        field => model%get_field_ptr (pdg(i))
        mask(i) = field%get_color_type () /= 1
     end do
     aval = pack (pdg, mask)
     call var_list_append_pdg_array &
          (model%var_list, var_str ("colored"), &
           aval, locked = .true., intrinsic=.true.)
   end subroutine model_append_field_vars
 
 @ %def model_append_field_vars
 @
 \subsection{Test models}
 <<Models: public>>=
   public :: create_test_model
 <<Models: procedures>>=
   subroutine create_test_model (model_name, test_model)
     type(string_t), intent(in) :: model_name
     type(model_t), intent(out), pointer :: test_model
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     call syntax_model_file_init ()
     call os_data%init ()
     call model_list%read_model &
        (model_name, model_name // var_str (".mdl"), os_data, test_model)
   end subroutine create_test_model
 
 @ %def create_test_model
 @
 \subsection{Model list}
 List of currently active models
 <<Models: types>>=
   type, extends (model_t) :: model_entry_t
      type(model_entry_t), pointer :: next => null ()
   end type model_entry_t
 
 @ %def model_entry_t
 <<Models: public>>=
   public :: model_list_t
 <<Models: types>>=
   type :: model_list_t
      type(model_entry_t), pointer :: first => null ()
      type(model_entry_t), pointer :: last => null ()
      type(model_list_t), pointer :: context => null ()
    contains
    <<Models: model list: TBP>>
   end type model_list_t
 
 @ %def model_list_t
 @ Write an account of the model list.  We write linked lists first, starting
 from the global context.
 <<Models: model list: TBP>>=
   procedure :: write => model_list_write
 <<Models: procedures>>=
   recursive subroutine model_list_write (object, unit, verbose, follow_link)
     class(model_list_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     logical, intent(in), optional :: follow_link
     type(model_entry_t), pointer :: current
     logical :: rec
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     rec = .true.;  if (present (follow_link))  rec = follow_link
     if (rec .and. associated (object%context)) then
        call object%context%write (unit, verbose, follow_link)
     end if
     current => object%first
     if (associated (current)) then
        do while (associated (current))
           call current%write (unit, verbose)
           current => current%next
           if (associated (current))  write (u, *)
        end do
     end if
   end subroutine model_list_write
 
 @ %def model_list_write
 @ Link this list to another one.
 <<Models: model list: TBP>>=
   procedure :: link => model_list_link
 <<Models: procedures>>=
   subroutine model_list_link (model_list, context)
     class(model_list_t), intent(inout) :: model_list
     type(model_list_t), intent(in), target :: context
     model_list%context => context
   end subroutine model_list_link
 
 @ %def model_list_link
 @ (Private, used below:)
 Append an existing model, for which we have allocated a pointer entry, to
 the model list.  The original pointer becomes disassociated, and the model
 should now be considered as part of the list.  We assume that this model is
 not yet part of the list.
 
 If we provide a [[model]] argument, this returns a pointer to the new entry.
 <<Models: model list: TBP>>=
   procedure, private :: import => model_list_import
 <<Models: procedures>>=
   subroutine model_list_import (model_list, current, model)
     class(model_list_t), intent(inout) :: model_list
     type(model_entry_t), pointer, intent(inout) :: current
     type(model_t), optional, pointer, intent(out) :: model
     if (associated (current)) then
        if (associated (model_list%first)) then
           model_list%last%next => current
        else
           model_list%first => current
        end if
        model_list%last => current
        if (present (model))  model => current%model_t
        current => null ()
     end if
   end subroutine model_list_import
 
 @ %def model_list_import
 @ Currently test only:
 
 Add a new model with given [[name]] to the list, if it does not yet
 exist.  If successful, return a pointer to the new model.
 <<Models: model list: TBP>>=
   procedure :: add => model_list_add
 <<Models: procedures>>=
   subroutine model_list_add (model_list, &
        name, os_data, n_par, n_prt, n_vtx, model)
     class(model_list_t), intent(inout) :: model_list
     type(string_t), intent(in) :: name
     type(os_data_t), intent(in) :: os_data
     integer, intent(in) :: n_par, n_prt, n_vtx
     type(model_t), pointer :: model
     type(model_entry_t), pointer :: current
     if (model_list%model_exists (name, follow_link=.false.)) then
        model => null ()
     else
        allocate (current)
        call current%init (name, var_str (""), os_data, &
             n_par, n_prt, n_vtx)
        call model_list%import (current, model)
     end if
   end subroutine model_list_add
 
 @ %def model_list_add
 @ Read a new model from file and add to the list, if it does not yet
 exist.  Finalize the model by allocating the vertex table.  Return a
 pointer to the new model.  If unsuccessful, return the original
 pointer.
 
 The model is always inserted in the last link of a chain of model lists.  This
 way, we avoid loading models twice from different contexts.   When a model is
 modified, we should first allocate a local copy.
 <<Models: model list: TBP>>=
   procedure :: read_model => model_list_read_model
 <<Models: procedures>>=
   subroutine model_list_read_model &
        (model_list, name, filename, os_data, model, &
        scheme, ufo, ufo_path, rebuild_mdl)
     class(model_list_t), intent(inout), target :: model_list
     type(string_t), intent(in) :: name, filename
     type(os_data_t), intent(in) :: os_data
     type(model_t), pointer, intent(inout) :: model
     type(string_t), intent(in), optional :: scheme
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path
     logical, intent(in), optional :: rebuild_mdl
     class(model_list_t), pointer :: global_model_list
     type(model_entry_t), pointer :: current
     logical :: exist
     if (.not. model_list%model_exists (name, &
          scheme, ufo, ufo_path, follow_link=.true.)) then
        allocate (current)
        call current%read (filename, os_data, exist, &
             scheme=scheme, ufo=ufo, ufo_path_requested=ufo_path, &
             rebuild_mdl=rebuild_mdl)
        if (.not. exist)  return
        if (current%get_name () /= name) then
           call msg_fatal ("Model file '" // char (filename) // &
                "' contains model '" // char (current%get_name ()) // &
                "' instead of '" // char (name) // "'")
           call current%final ();  deallocate (current)
           return
        end if
        global_model_list => model_list
        do while (associated (global_model_list%context))
           global_model_list => global_model_list%context
        end do
        call global_model_list%import (current, model)
     else
        model => model_list%get_model_ptr (name, scheme, ufo, ufo_path)
     end if
   end subroutine model_list_read_model
 
 @ %def model_list_read_model
 @ Append a copy of an existing model to a model list.  Optionally, return
 pointer to the new entry.
 <<Models: model list: TBP>>=
   procedure :: append_copy => model_list_append_copy
 <<Models: procedures>>=
   subroutine model_list_append_copy (model_list, orig, model)
     class(model_list_t), intent(inout) :: model_list
     type(model_t), intent(in), target :: orig
     type(model_t), intent(out), pointer, optional :: model
     type(model_entry_t), pointer :: copy
     allocate (copy)
     call copy%init_instance (orig)
     call model_list%import (copy, model)
   end subroutine model_list_append_copy
 
 @ %def model_list_append_copy
 @ Check if a model exists by examining the list.  Check recursively unless
 told otherwise.
 <<Models: model list: TBP>>=
   procedure :: model_exists => model_list_model_exists
 <<Models: procedures>>=
   recursive function model_list_model_exists &
        (model_list, name, scheme, ufo, ufo_path, follow_link) result (exists)
     class(model_list_t), intent(in) :: model_list
     logical :: exists
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: scheme
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path
     logical, intent(in), optional :: follow_link
     type(model_entry_t), pointer :: current
     logical :: rec
     rec = .true.;  if (present (follow_link))  rec = follow_link
     current => model_list%first
     do while (associated (current))
        if (current%matches (name, scheme, ufo, ufo_path)) then
           exists = .true.
           return
        end if
        current => current%next
     end do
     if (rec .and. associated (model_list%context)) then
        exists = model_list%context%model_exists (name, &
             scheme, ufo, ufo_path, follow_link)
     else
        exists = .false.
     end if
   end function model_list_model_exists
 
 @ %def model_list_model_exists
 @ Return a pointer to a named model.  Search recursively unless told otherwise.
 <<Models: model list: TBP>>=
   procedure :: get_model_ptr => model_list_get_model_ptr
 <<Models: procedures>>=
   recursive function model_list_get_model_ptr &
        (model_list, name, scheme, ufo, ufo_path, follow_link) result (model)
     class(model_list_t), intent(in) :: model_list
     type(model_t), pointer :: model
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: scheme
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path
     logical, intent(in), optional :: follow_link
     type(model_entry_t), pointer :: current
     logical :: rec
     rec = .true.;  if (present (follow_link))  rec = follow_link
     current => model_list%first
     do while (associated (current))
        if (current%matches (name, scheme, ufo, ufo_path)) then
           model => current%model_t
           return
        end if
        current => current%next
     end do
     if (rec .and. associated (model_list%context)) then
        model => model_list%context%get_model_ptr (name, &
             scheme, ufo, ufo_path, follow_link)
     else
        model => null ()
     end if
   end function model_list_get_model_ptr
 
 @ %def model_list_get_model_ptr
 @ Delete the list of models.  No recursion.
 <<Models: model list: TBP>>=
   procedure :: final => model_list_final
 <<Models: procedures>>=
   subroutine model_list_final (model_list)
     class(model_list_t), intent(inout) :: model_list
     type(model_entry_t), pointer :: current
     model_list%last => null ()
     do while (associated (model_list%first))
        current => model_list%first
        model_list%first => model_list%first%next
        call current%final ()
        deallocate (current)
     end do
   end subroutine model_list_final
 
 @ %def model_list_final
 @
 \subsection{Model instances}
 A model instance is a copy of a model object.  The parameters are true
 copies.  The particle data and the variable list pointers should point to the
 copy, so modifying the parameters has only a local effect.  Hence, we build
 them up explicitly.  The vertex array is also rebuilt, it contains particle
 pointers.  Finally, the vertex hash table can be copied directly since it
 contains no pointers.
 
 The [[multiplicity]] entry depends on the association of the [[mass_data]]
 entry and therefore has to be set at the end.
 
 The instance must carry the [[target]] attribute.
 
 Parameters: the [[copy_parameter]] method essentially copies the parameter
 decorations (parse node, expression etc.).  The current parameter values are
 part of the [[model_data_t]] base type and are copied afterwards via its
 [[copy_from]] method.
 
 Note: the parameter set is initialized for real parameters only.
 
 In order for the local model to be able to use the correct UFO model
 setup, UFO model information has to be transferred.
 <<Models: model: TBP>>=
   procedure :: init_instance => model_copy
 <<Models: procedures>>=
   subroutine model_copy (model, orig)
     class(model_t), intent(out), target :: model
     type(model_t), intent(in) :: orig
     integer :: n_par, n_prt, n_vtx
     integer :: i
     n_par = orig%get_n_real ()
     n_prt = orig%get_n_field ()
     n_vtx = orig%get_n_vtx ()
     call model%basic_init (orig%get_name (), n_par, n_prt, n_vtx)
     if (allocated (orig%schemes)) then
        model%schemes = orig%schemes
        if (allocated (orig%selected_scheme)) then
           model%selected_scheme = orig%selected_scheme
           call model%set_scheme_num (orig%get_scheme_num ())
        end if
     end if
     model%md5sum = orig%md5sum
     model%ufo_model = orig%ufo_model
     model%ufo_path = orig%ufo_path
     if (allocated (orig%par)) then
        do i = 1, n_par
           call model%copy_parameter (i, orig%par(i))
        end do
     end if
     model%init_external_parameters => orig%init_external_parameters
     call model%model_data_t%copy_from (orig)
     model%max_par_name_length = orig%max_par_name_length
     call model%append_field_vars ()
   end subroutine model_copy
 
 @ %def model_copy
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[models_ut.f90]]>>=
 <<File header>>
 
 module models_ut
   use unit_tests
   use models_uti
 
 <<Standard module head>>
 
 <<Models: public test>>
 
 contains
 
 <<Models: test driver>>
 
 end module models_ut
 @ %def models_ut
 @
 <<[[models_uti.f90]]>>=
 <<File header>>
 
 module models_uti
 
 <<Use kinds>>
 <<Use strings>>
   use file_utils, only: delete_file
   use physics_defs, only: SCALAR, SPINOR
   use os_interface
   use model_data
   use variables
 
   use models
 
 <<Standard module head>>
 
 <<Models: test declarations>>
 
 contains
 
 <<Models: tests>>
 
 end module models_uti
 @ %def models_ut
 @ API: driver for the unit tests below.
 <<Models: public test>>=
   public :: models_test
 <<Models: test driver>>=
   subroutine models_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Models: execute tests>>
   end subroutine models_test
 
 @ %def models_tests
 @
 \subsubsection{Construct a Model}
 Here, we construct a toy model explicitly without referring to a file.
 <<Models: execute tests>>=
   call test (models_1, "models_1", &
        "construct model", &
        u, results)
 <<Models: test declarations>>=
   public :: models_1
 <<Models: tests>>=
   subroutine models_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model
     type(string_t) :: model_name
     type(string_t) :: x_longname
     type(string_t), dimension(2) :: parname
     type(string_t), dimension(2) :: x_name
     type(string_t), dimension(1) :: x_anti
     type(string_t) :: x_tex_name, x_tex_anti
     type(string_t) :: y_longname
     type(string_t), dimension(2) :: y_name
     type(string_t) :: y_tex_name
     type(field_data_t), pointer :: field
 
     write (u, "(A)")  "* Test output: models_1"
     write (u, "(A)")  "*   Purpose: create a model"
     write (u, *)
 
     model_name = "Test model"
     call model_list%add (model_name, os_data, 2, 2, 3, model)
     parname(1) = "mx"
     parname(2) = "coup"
     call model%set_parameter_constant (1, parname(1), 10._default)
     call model%set_parameter_constant (2, parname(2), 1.3_default)
     x_longname = "X_LEPTON"
     x_name(1) = "X"
     x_name(2) = "x"
     x_anti(1) = "Xbar"
     x_tex_name = "X^+"
     x_tex_anti = "X^-"
     field => model%get_field_ptr_by_index (1)
     call field%init (x_longname, 99)
     call field%set ( &
          .true., .false., .false., .false., .false., &
          name=x_name, anti=x_anti, tex_name=x_tex_name, tex_anti=x_tex_anti, &
          spin_type=SPINOR, isospin_type=-3, charge_type=2, &
          mass_data=model%get_par_data_ptr (parname(1)))
     y_longname = "Y_COLORON"
     y_name(1) = "Y"
     y_name(2) = "yc"
     y_tex_name = "Y^0"
     field => model%get_field_ptr_by_index (2)
     call field%init (y_longname, 97)
     call field%set ( &
           .false., .false., .true., .false., .false., &
           name=y_name, tex_name=y_tex_name, &
           spin_type=SCALAR, isospin_type=2, charge_type=1, color_type=8)
     call model%set_vertex (1, [99, 99, 99])
     call model%set_vertex (2, [99, 99, 99, 99])
     call model%set_vertex (3, [99, 97, 99])
     call model_list%write (u)
 
     call model_list%final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_1"
 
   end subroutine models_1
 
 @ %def models_1
 @
 \subsubsection{Read a Model}
 Read a predefined model from file.
 <<Models: execute tests>>=
   call test (models_2, "models_2", &
        "read model", &
        u, results)
 <<Models: test declarations>>=
   public :: models_2
 <<Models: tests>>=
   subroutine models_2 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(var_list_t), pointer :: var_list
     type(model_t), pointer :: model
 
     write (u, "(A)")  "* Test output: models_2"
     write (u, "(A)")  "*   Purpose: read a model from file"
     write (u, *)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
          os_data, model)
     call model_list%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Variable list"
     write (u, *)
 
     var_list => model%get_var_list_ptr ()
     call var_list%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_2"
 
   end subroutine models_2
 
 @ %def models_2
 @
 \subsubsection{Model Instance}
 Read a predefined model from file and create an instance.
 <<Models: execute tests>>=
   call test (models_3, "models_3", &
        "model instance", &
        u, results)
 <<Models: test declarations>>=
   public :: models_3
 <<Models: tests>>=
   subroutine models_3 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model
     type(var_list_t), pointer :: var_list
     type(model_t), pointer :: instance
 
     write (u, "(A)")  "* Test output: models_3"
     write (u, "(A)")  "*   Purpose: create a model instance"
     write (u, *)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
          os_data, model)
     allocate (instance)
     call instance%init_instance (model)
 
     call model%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Variable list"
     write (u, *)
 
     var_list => instance%get_var_list_ptr ()
     call var_list%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call instance%final ()
     deallocate (instance)
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_3"
 
   end subroutine models_3
 
 @ %def models_test
 @
 \subsubsection{Unstable and Polarized Particles}
 Read a predefined model from file and define decays and polarization.
 <<Models: execute tests>>=
   call test (models_4, "models_4", &
        "handle decays and polarization", &
        u, results)
 <<Models: test declarations>>=
   public :: models_4
 <<Models: tests>>=
   subroutine models_4 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model, model_instance
     character(32) :: md5sum
 
     write (u, "(A)")  "* Test output: models_4"
     write (u, "(A)")  "*   Purpose: set and unset decays and polarization"
     write (u, *)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     write (u, "(A)")  "* Read model from file"
 
     call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
          os_data, model)
 
     md5sum = model%get_parameters_md5sum ()
     write (u, *)
     write (u, "(1x,3A)")  "MD5 sum (parameters) = '", md5sum, "'"
 
     write (u, *)
     write (u, "(A)")  "* Set particle decays and polarization"
     write (u, *)
 
     call model%set_unstable (25, [var_str ("dec1"), var_str ("dec2")])
     call model%set_polarized (6)
     call model%set_unstable (-6, [var_str ("fdec")])
 
     call model%write (u)
 
     md5sum = model%get_parameters_md5sum ()
     write (u, *)
     write (u, "(1x,3A)")  "MD5 sum (parameters) = '", md5sum, "'"
 
     write (u, *)
     write (u, "(A)")  "* Create a model instance"
 
     allocate (model_instance)
     call model_instance%init_instance (model)
 
     write (u, *)
     write (u, "(A)")  "* Revert particle decays and polarization"
     write (u, *)
 
     call model%set_stable (25)
     call model%set_unpolarized (6)
     call model%set_stable (-6)
 
     call model%write (u)
 
     md5sum = model%get_parameters_md5sum ()
     write (u, *)
     write (u, "(1x,3A)")  "MD5 sum (parameters) = '", md5sum, "'"
 
     write (u, *)
     write (u, "(A)")  "* Show the model instance"
     write (u, *)
 
     call model_instance%write (u)
 
     md5sum = model_instance%get_parameters_md5sum ()
     write (u, *)
     write (u, "(1x,3A)")  "MD5 sum (parameters) = '", md5sum, "'"
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_instance%final ()
     deallocate (model_instance)
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_4"
 
   end subroutine models_4
 
 @ %def models_4
 @
 \subsubsection{Model Variables}
 Read a predefined model from file and modify some parameters.
 
 Note that the MD5 sum is not modified by this.
 <<Models: execute tests>>=
   call test (models_5, "models_5", &
        "handle parameters", &
        u, results)
 <<Models: test declarations>>=
   public :: models_5
 <<Models: tests>>=
   subroutine models_5 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model, model_instance
     character(32) :: md5sum
 
     write (u, "(A)")  "* Test output: models_5"
     write (u, "(A)")  "*   Purpose: access and modify model variables"
     write (u, *)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     write (u, "(A)")  "* Read model from file"
 
     call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
          os_data, model)
 
     write (u, *)
 
     call model%write (u, &
          show_md5sum = .true., &
          show_variables = .true., &
          show_parameters = .true., &
          show_particles = .false., &
          show_vertices = .false.)
 
     write (u, *)
     write (u, "(A)")  "* Check parameter status"
     write (u, *)
 
     write (u, "(1x,A,L1)") "xy exists = ", model%var_exists (var_str ("xx"))
     write (u, "(1x,A,L1)") "ff exists = ", model%var_exists (var_str ("ff"))
     write (u, "(1x,A,L1)") "mf exists = ", model%var_exists (var_str ("mf"))
     write (u, "(1x,A,L1)") "ff locked = ", model%var_is_locked (var_str ("ff"))
     write (u, "(1x,A,L1)") "mf locked = ", model%var_is_locked (var_str ("mf"))
 
     write (u, *)
     write (u, "(1x,A,F6.2)") "ff = ", model%get_rval (var_str ("ff"))
     write (u, "(1x,A,F6.2)") "mf = ", model%get_rval (var_str ("mf"))
 
     write (u, *)
     write (u, "(A)")  "* Modify parameter"
     write (u, *)
 
     call model%set_real (var_str ("ff"), 1._default)
 
     call model%write (u, &
          show_md5sum = .true., &
          show_variables = .true., &
          show_parameters = .true., &
          show_particles = .false., &
          show_vertices = .false.)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_5"
 
   end subroutine models_5
 
 @ %def models_5
 @
 \subsubsection{Read model with disordered parameters}
 Read a model from file where the ordering of independent and derived
 parameters is non-canonical.
 <<Models: execute tests>>=
   call test (models_6, "models_6", &
        "read model parameters", &
        u, results)
 <<Models: test declarations>>=
   public :: models_6
 <<Models: tests>>=
   subroutine models_6 (u)
     integer, intent(in) :: u
     integer :: um
     character(80) :: buffer
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(var_list_t), pointer :: var_list
     type(model_t), pointer :: model
 
     write (u, "(A)")  "* Test output: models_6"
     write (u, "(A)")  "*   Purpose: read a model from file &
          &with non-canonical parameter ordering"
     write (u, *)
 
     open (newunit=um, file="Test6.mdl", status="replace", action="readwrite")
     write (um, "(A)")  'model "Test6"'
     write (um, "(A)")  '   parameter a =  1.000000000000E+00'
     write (um, "(A)")  '   derived   b =  2 * a'
     write (um, "(A)")  '   parameter c =  3.000000000000E+00'
     write (um, "(A)")  '   unused    d'
 
     rewind (um)
     do
        read (um, "(A)", end=1)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 1   continue
     close (um)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     call model_list%read_model (var_str ("Test6"), var_str ("Test6.mdl"), &
          os_data, model)
 
     write (u, *)
     write (u, "(A)")  "* Variable list"
     write (u, *)
 
     var_list => model%get_var_list_ptr ()
     call var_list%write (u)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_6"
 
   end subroutine models_6
 
 @ %def models_6
 @
 \subsubsection{Read model with schemes}
 Read a model from file which supports scheme selection in the
 parameter list.
 <<Models: execute tests>>=
   call test (models_7, "models_7", &
        "handle schemes", &
        u, results)
 <<Models: test declarations>>=
   public :: models_7
 <<Models: tests>>=
   subroutine models_7 (u)
     integer, intent(in) :: u
     integer :: um
     character(80) :: buffer
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(var_list_t), pointer :: var_list
     type(model_t), pointer :: model
 
     write (u, "(A)")  "* Test output: models_7"
     write (u, "(A)")  "*   Purpose: read a model from file &
          &with scheme selection"
     write (u, *)
 
     open (newunit=um, file="Test7.mdl", status="replace", action="readwrite")
     write (um, "(A)")  'model "Test7"'
     write (um, "(A)")  '  schemes = "foo", "bar", "gee"'
     write (um, "(A)")  ''
     write (um, "(A)")  '  select scheme'
     write (um, "(A)")  '  scheme "foo"'
     write (um, "(A)")  '    parameter a = 1'
     write (um, "(A)")  '    derived   b = 2 * a'
     write (um, "(A)")  '  scheme other'
     write (um, "(A)")  '    parameter b = 4'
     write (um, "(A)")  '    derived   a = b / 2'
     write (um, "(A)")  '  end select'
     write (um, "(A)")  ''
     write (um, "(A)")  '  parameter c = 3'
     write (um, "(A)")  ''
     write (um, "(A)")  '  select scheme'
     write (um, "(A)")  '  scheme "foo", "gee"'
     write (um, "(A)")  '    derived   d = b + c'
     write (um, "(A)")  '  scheme other'
     write (um, "(A)")  '    unused    d'
     write (um, "(A)")  '  end select'
 
     rewind (um)
     do
        read (um, "(A)", end=1)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 1   continue
     close (um)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     write (u, *)
     write (u, "(A)")  "* Model output, default scheme (= foo)"
     write (u, *)
 
     call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
          os_data, model)
     call model%write (u, show_md5sum=.false.)
     call show_var_list ()
     call show_par_array ()
 
     call model_list%final ()
 
     write (u, *)
     write (u, "(A)")  "* Model output, scheme foo"
     write (u, *)
 
     call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
          os_data, model, scheme = var_str ("foo"))
     call model%write (u, show_md5sum=.false.)
     call show_var_list ()
     call show_par_array ()
 
     call model_list%final ()
 
     write (u, *)
     write (u, "(A)")  "* Model output, scheme bar"
     write (u, *)
 
     call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
          os_data, model, scheme = var_str ("bar"))
     call model%write (u, show_md5sum=.false.)
     call show_var_list ()
     call show_par_array ()
 
     call model_list%final ()
 
     write (u, *)
     write (u, "(A)")  "* Model output, scheme gee"
     write (u, *)
 
     call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
          os_data, model, scheme = var_str ("gee"))
     call model%write (u, show_md5sum=.false.)
     call show_var_list ()
     call show_par_array ()
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_7"
 
   contains
 
     subroutine show_var_list ()
       write (u, *)
       write (u, "(A)")  "* Variable list"
       write (u, *)
       var_list => model%get_var_list_ptr ()
       call var_list%write (u)
     end subroutine show_var_list
 
     subroutine show_par_array ()
       real(default), dimension(:), allocatable :: par
       integer :: n
       write (u, *)
       write (u, "(A)")  "* Parameter array"
       write (u, *)
       n = model%get_n_real ()
       allocate (par (n))
       call model%real_parameters_to_array (par)
       write (u, 1)  par
 1     format (1X,F6.3)
     end subroutine show_par_array
 
   end subroutine models_7
 
 @ %def models_7
 @
 \subsubsection{Read and handle UFO model}
 Read a model from file which is considered as an UFO model.  In fact,
 it is a mock model file which just follows our naming convention for
 UFO models.  Compare this to an equivalent non-UFO model.
 <<Models: execute tests>>=
   call test (models_8, "models_8", &
        "handle UFO-derived models", &
        u, results)
 <<Models: test declarations>>=
   public :: models_8
 <<Models: tests>>=
   subroutine models_8 (u)
     integer, intent(in) :: u
     integer :: um
     character(80) :: buffer
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(string_t) :: model_name
     type(model_t), pointer :: model
 
     write (u, "(A)")  "* Test output: models_8"
     write (u, "(A)")  "*   Purpose: distinguish models marked as UFO-derived"
     write (u, *)
 
     call os_data%init ()
 
     call show_model_list_status ()
     model_name = "models_8_M"
 
     write (u, *)
     write (u, "(A)")  "* Write WHIZARD model"
     write (u, *)
 
     open (newunit=um, file=char (model_name // ".mdl"), &
          status="replace", action="readwrite")
     write (um, "(A)")  'model "models_8_M"'
     write (um, "(A)")  '  parameter a = 1'
 
     rewind (um)
     do
        read (um, "(A)", end=1)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 1   continue
     close (um)
 
     write (u, *)
     write (u, "(A)")  "* Write UFO model"
     write (u, *)
 
     open (newunit=um, file=char (model_name // ".ufo.mdl"), &
          status="replace", action="readwrite")
     write (um, "(A)")  'model "models_8_M"'
     write (um, "(A)")  '  parameter a = 2'
 
     rewind (um)
     do
        read (um, "(A)", end=2)  buffer
        write (u, "(A)")  trim (buffer)
     end do
 2   continue
     close (um)
 
     call syntax_model_file_init ()
     call os_data%init ()
 
     write (u, *)
     write (u, "(A)")  "* Read WHIZARD model"
     write (u, *)
 
     call model_list%read_model (model_name, model_name // ".mdl", &
          os_data, model)
     call model%write (u, show_md5sum=.false.)
 
     call show_model_list_status ()
 
     write (u, *)
     write (u, "(A)")  "* Read UFO model"
     write (u, *)
 
     call model_list%read_model (model_name, model_name // ".ufo.mdl", &
          os_data, model, ufo=.true., rebuild_mdl = .false.)
     call model%write (u, show_md5sum=.false.)
 
     call show_model_list_status ()
 
     write (u, *)
     write (u, "(A)")  "* Reload WHIZARD model"
     write (u, *)
 
     call model_list%read_model (model_name, model_name // ".mdl", &
          os_data, model)
     call model%write (u, show_md5sum=.false.)
 
     call show_model_list_status ()
 
     write (u, *)
     write (u, "(A)")  "* Reload UFO model"
     write (u, *)
 
     call model_list%read_model (model_name, model_name // ".ufo.mdl", &
          os_data, model, ufo=.true., rebuild_mdl = .false.)
     call model%write (u, show_md5sum=.false.)
 
     call show_model_list_status ()
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_8"
 
   contains
 
     subroutine show_model_list_status ()
       write (u, "(A)")  "* Model list status"
       write (u, *)
       write (u, "(A,1x,L1)")  "WHIZARD model exists =", &
            model_list%model_exists (model_name)
       write (u, "(A,1x,L1)")  "UFO model exists =", &
            model_list%model_exists (model_name, ufo=.true.)
     end subroutine show_model_list_status
 
   end subroutine models_8
 
 @ %def models_8
 @
 \subsubsection{Generate UFO model file}
 Generate the necessary [[.ufo.mdl]] file from source, calling OMega, and load the model.
 
 Note: There must not be another unit test which works with the same
 UFO model.  The model file is deleted explicitly at the end of this test.
 <<Models: execute tests>>=
   call test (models_9, "models_9", &
        "generate UFO-derived model file", &
        u, results)
 <<Models: test declarations>>=
   public :: models_9
 <<Models: tests>>=
   subroutine models_9 (u)
     integer, intent(in) :: u
     integer :: um
     character(80) :: buffer
     type(os_data_t) :: os_data
     type(model_list_t) :: model_list
     type(string_t) :: model_name, model_file_name
     type(model_t), pointer :: model
 
     write (u, "(A)")  "* Test output: models_9"
     write (u, "(A)")  "*   Purpose: enable the UFO Standard Model (test version)"
     write (u, *)
 
     call os_data%init ()
     call syntax_model_file_init ()
 
     os_data%whizard_modelpath_ufo = "../models/UFO"
 
     model_name = "SM"
     model_file_name = model_name // ".models_9" // ".ufo.mdl"
 
     write (u, "(A)")  "* Generate and read UFO model"
     write (u, *)
 
     call delete_file (char (model_file_name))
 
     call model_list%read_model (model_name, model_file_name, os_data, model, ufo=.true.)
     call model%write (u, show_md5sum=.false.)
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_9"
 
   end subroutine models_9
 
 @ %def models_9
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{The SUSY Les Houches Accord}
 
 The SUSY Les Houches Accord defines a standard interfaces for storing
 the physics data of SUSY models.  Here, we provide the means
 for reading, storing, and writing such data.
 <<[[slha_interface.f90]]>>=
 <<File header>>
 
 module slha_interface
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants
   use string_utils, only: upper_case
   use system_defs, only: VERSION_STRING
   use system_defs, only: EOF
   use diagnostics
   use os_interface
   use ifiles
   use lexers
   use syntax_rules
   use parser
   use variables
   use models
 
 <<Standard module head>>
 
 <<SLHA: public>>
 
 <<SLHA: parameters>>
 
 <<SLHA: variables>>
 
   save
 
 contains
 
 <<SLHA: procedures>>
 
 <<SLHA: tests>>
 
 end module slha_interface
 @ %def slha_interface
 @
 \subsection{Preprocessor}
 SLHA is a mixed-format standard.  It should be read in assuming free
 format (but line-oriented), but it has some fixed-format elements.
 
 To overcome this difficulty, we implement a preprocessing step which
 transforms the SLHA into a format that can be swallowed by our generic
 free-format lexer and parser.  Each line with a blank first character
 is assumed to be a data line.  We prepend a 'DATA' keyword to these lines.
 Furthermore, to enforce line-orientation, each line is appended a '\$'
 key which is recognized by the parser.  To do this properly, we first
 remove trailing comments, and skip lines consisting only of comments.
 
 The preprocessor reads from a stream and puts out an [[ifile]].
 Blocks that are not recognized are skipped.  For some blocks, data
 items are quoted, so they can be read as strings if necessary.
 <<SLHA: parameters>>=
   integer, parameter :: MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2
 
 @ %def MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2
 <<SLHA: procedures>>=
   subroutine slha_preprocess (stream, ifile)
     type(stream_t), intent(inout), target :: stream
     type(ifile_t), intent(out) :: ifile
     type(string_t) :: buffer, line, item
     integer :: iostat
     integer :: mode
     mode = MODE
     SCAN_FILE: do
        call stream_get_record (stream, buffer, iostat)
        select case (iostat)
        case (0)
           call split (buffer, line, "#")
           if (len_trim (line) == 0)  cycle SCAN_FILE
           select case (char (extract (line, 1, 1)))
           case ("B", "b")
              mode = check_block_handling (line)
              call ifile_append (ifile, line // "$")
           case ("D", "d")
              mode = MODE_DATA
              call ifile_append (ifile, line // "$")
           case (" ")
              select case (mode)
              case (MODE_DATA)
                 call ifile_append (ifile, "DATA" // line // "$")
              case (MODE_INFO)
                 line = adjustl (line)
                 call split (line, item, " ")
                 call ifile_append (ifile, "INFO" // " " // item // " " &
                      // '"' // trim (adjustl (line)) // '" $')
              end select
           case default
              call msg_message (char (line))
              call msg_fatal ("SLHA: Incomprehensible line")
           end select
        case (EOF)
           exit SCAN_FILE
        case default
           call msg_fatal ("SLHA: I/O error occured while reading SLHA input")
        end select
     end do SCAN_FILE
   end subroutine slha_preprocess
 
 @ %def slha_preprocess
 @ Return the mode that we should treat this block with.  We need
 to recognize only those blocks that we actually use.
 <<SLHA: procedures>>=
   function check_block_handling (line) result (mode)
     integer :: mode
     type(string_t), intent(in) :: line
     type(string_t) :: buffer, key, block_name
     buffer = trim (line)
     call split (buffer, key, " ")
     buffer = adjustl (buffer)
     call split (buffer, block_name, " ")
     block_name = trim (adjustl (upper_case (block_name)))
     select case (char (block_name))
     case ("MODSEL", "MINPAR", "SMINPUTS")
        mode = MODE_DATA
     case ("MASS")
        mode = MODE_DATA
     case ("NMIX", "UMIX", "VMIX", "STOPMIX", "SBOTMIX", "STAUMIX")
        mode = MODE_DATA
     case ("NMHMIX", "NMAMIX", "NMNMIX", "NMSSMRUN")
        mode = MODE_DATA
     case ("ALPHA", "HMIX")
        mode = MODE_DATA
     case ("AU", "AD", "AE")
        mode = MODE_DATA
     case ("SPINFO", "DCINFO")
        mode = MODE_INFO
     case default
        mode = MODE_SKIP
     end select
   end function check_block_handling
 
 @ %def check_block_handling
 @
 \subsection{Lexer and syntax}
 <<SLHA: variables>>=
   type(syntax_t), target :: syntax_slha
 
 @ %def syntax_slha
 <<SLHA: public>>=
   public :: syntax_slha_init
 <<SLHA: procedures>>=
   subroutine syntax_slha_init ()
     type(ifile_t) :: ifile
     call define_slha_syntax (ifile)
     call syntax_init (syntax_slha, ifile)
     call ifile_final (ifile)
   end subroutine syntax_slha_init
 
 @ %def syntax_slha_init
 <<SLHA: public>>=
   public :: syntax_slha_final
 <<SLHA: procedures>>=
   subroutine syntax_slha_final ()
     call syntax_final (syntax_slha)
   end subroutine syntax_slha_final
 
 @ %def syntax_slha_final
 <<SLHA: public>>=
   public :: syntax_slha_write
 <<SLHA: procedures>>=
   subroutine syntax_slha_write (unit)
     integer, intent(in), optional :: unit
     call syntax_write (syntax_slha, unit)
   end subroutine syntax_slha_write
 
 @ %def syntax_slha_write
 <<SLHA: procedures>>=
   subroutine define_slha_syntax (ifile)
     type(ifile_t), intent(inout) :: ifile
     call ifile_append (ifile, "SEQ slha = chunk*")
     call ifile_append (ifile, "ALT chunk = block_def | decay_def")
     call ifile_append (ifile, "SEQ block_def = " &
          // "BLOCK block_spec '$' block_line*")
     call ifile_append (ifile, "KEY BLOCK")
     call ifile_append (ifile, "SEQ block_spec = block_name qvalue?")
     call ifile_append (ifile, "IDE block_name")
     call ifile_append (ifile, "SEQ qvalue = qname '=' real")
     call ifile_append (ifile, "IDE qname")
     call ifile_append (ifile, "KEY '='")
     call ifile_append (ifile, "REA real")
     call ifile_append (ifile, "KEY '$'")
     call ifile_append (ifile, "ALT block_line = block_data | block_info")
     call ifile_append (ifile, "SEQ block_data = DATA data_line '$'")
     call ifile_append (ifile, "KEY DATA")
     call ifile_append (ifile, "SEQ data_line = data_item+")
     call ifile_append (ifile, "ALT data_item = signed_number | number")
     call ifile_append (ifile, "SEQ signed_number = sign number")
     call ifile_append (ifile, "ALT sign = '+' | '-'")
     call ifile_append (ifile, "ALT number = integer | real")
     call ifile_append (ifile, "INT integer")
     call ifile_append (ifile, "KEY '-'")
     call ifile_append (ifile, "KEY '+'")
     call ifile_append (ifile, "SEQ block_info = INFO info_line '$'")
     call ifile_append (ifile, "KEY INFO")
     call ifile_append (ifile, "SEQ info_line = integer string_literal")
     call ifile_append (ifile, "QUO string_literal = '""'...'""'")
     call ifile_append (ifile, "SEQ decay_def = " &
          // "DECAY decay_spec '$' decay_data*")
     call ifile_append (ifile, "KEY DECAY")
     call ifile_append (ifile, "SEQ decay_spec = pdg_code data_item")
     call ifile_append (ifile, "ALT pdg_code = signed_integer | integer")
     call ifile_append (ifile, "SEQ signed_integer = sign integer")
     call ifile_append (ifile, "SEQ decay_data = DATA decay_line '$'")
     call ifile_append (ifile, "SEQ decay_line = data_item integer pdg_code+")
   end subroutine define_slha_syntax
 
 @ %def define_slha_syntax
 @ The SLHA specification allows for string data items in certain
 places.  Currently, we do not interpret them, but the strings, which
 are not quoted, must be parsed somehow.  The hack for this problem is
 to allow essentially all characters as special characters, so the
 string can be read before it is discarded.
 <<SLHA: public>>=
   public :: lexer_init_slha
 <<SLHA: procedures>>=
   subroutine lexer_init_slha (lexer)
     type(lexer_t), intent(out) :: lexer
     call lexer_init (lexer, &
          comment_chars = "#", &
          quote_chars = '"', &
          quote_match = '"', &
          single_chars = "+-=$", &
          special_class = [ "" ], &
          keyword_list = syntax_get_keyword_list_ptr (syntax_slha), &
          upper_case_keywords = .true.)  ! $
   end subroutine lexer_init_slha
 
 @ %def lexer_init_slha
 @
 \subsection{Interpreter}
 \subsubsection{Find blocks}
 From the parse tree, find the node that represents a particular
 block.  If [[required]] is true, issue an error if not found.
 Since [[block_name]] is always invoked with capital letters, we
 have to capitalize [[pn_block_name]].
 <<SLHA: procedures>>=
   function slha_get_block_ptr &
        (parse_tree, block_name, required) result (pn_block)
     type(parse_node_t), pointer :: pn_block
     type(parse_tree_t), intent(in) :: parse_tree
     type(string_t), intent(in) :: block_name
     logical, intent(in) :: required
     type(parse_node_t), pointer :: pn_root, pn_block_spec, pn_block_name
     pn_root => parse_tree%get_root_ptr ()
     pn_block => parse_node_get_sub_ptr (pn_root)
     do while (associated (pn_block))
        select case (char (parse_node_get_rule_key (pn_block)))
        case ("block_def")
           pn_block_spec => parse_node_get_sub_ptr (pn_block, 2)
           pn_block_name => parse_node_get_sub_ptr (pn_block_spec)
           if (trim (adjustl (upper_case (parse_node_get_string &
                (pn_block_name)))) == block_name) then
              return
           end if
        end select
        pn_block => parse_node_get_next_ptr (pn_block)
     end do
     if (required) then
        call msg_fatal ("SLHA: block '" // char (block_name) // "' not found")
     end if
   end function slha_get_block_ptr
 
 @ %def slha_get_blck_ptr
 @ Scan the file for the first/next DECAY block.
 <<SLHA: procedures>>=
   function slha_get_first_decay_ptr (parse_tree) result (pn_decay)
     type(parse_node_t), pointer :: pn_decay
     type(parse_tree_t), intent(in) :: parse_tree
     type(parse_node_t), pointer :: pn_root
     pn_root => parse_tree%get_root_ptr ()
     pn_decay => parse_node_get_sub_ptr (pn_root)
     do while (associated (pn_decay))
        select case (char (parse_node_get_rule_key (pn_decay)))
        case ("decay_def")
           return
        end select
        pn_decay => parse_node_get_next_ptr (pn_decay)
     end do
   end function slha_get_first_decay_ptr
 
   function slha_get_next_decay_ptr (pn_block) result (pn_decay)
     type(parse_node_t), pointer :: pn_decay
     type(parse_node_t), intent(in), target :: pn_block
     pn_decay => parse_node_get_next_ptr (pn_block)
     do while (associated (pn_decay))
        select case (char (parse_node_get_rule_key (pn_decay)))
        case ("decay_def")
           return
        end select
        pn_decay => parse_node_get_next_ptr (pn_decay)
     end do
   end function slha_get_next_decay_ptr
 
 @ %def slha_get_next_decay_ptr
 @
 \subsubsection{Extract and transfer data from blocks}
 Given the parse node of a block, find the parse node of a particular
 switch or data line.  Return this node and the node of the data item
 following the integer code.
 <<SLHA: procedures>>=
   subroutine slha_find_index_ptr (pn_block, pn_data, pn_item, code)
     type(parse_node_t), intent(in), target :: pn_block
     type(parse_node_t), intent(out), pointer :: pn_data
     type(parse_node_t), intent(out), pointer :: pn_item
     integer, intent(in) :: code
     pn_data => parse_node_get_sub_ptr (pn_block, 4)
     call slha_next_index_ptr (pn_data, pn_item, code)
   end subroutine slha_find_index_ptr
 
   subroutine slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2)
     type(parse_node_t), intent(in), target :: pn_block
     type(parse_node_t), intent(out), pointer :: pn_data
     type(parse_node_t), intent(out), pointer :: pn_item
     integer, intent(in) :: code1, code2
     pn_data => parse_node_get_sub_ptr (pn_block, 4)
     call slha_next_index_pair_ptr (pn_data, pn_item, code1, code2)
   end subroutine slha_find_index_pair_ptr
 
 @ %def slha_find_index_ptr slha_find_index_pair_ptr
 @ Starting from the pointer to a data line, find a data line with the
 given integer code.
 <<SLHA: procedures>>=
   subroutine slha_next_index_ptr (pn_data, pn_item, code)
     type(parse_node_t), intent(inout), pointer :: pn_data
     integer, intent(in) :: code
     type(parse_node_t), intent(out), pointer :: pn_item
     type(parse_node_t), pointer :: pn_line, pn_code
     do while (associated (pn_data))
        pn_line => parse_node_get_sub_ptr (pn_data, 2)
        pn_code => parse_node_get_sub_ptr (pn_line)
        select case (char (parse_node_get_rule_key (pn_code)))
        case ("integer")
           if (parse_node_get_integer (pn_code) == code) then
              pn_item => parse_node_get_next_ptr (pn_code)
              return
           end if
        end select
        pn_data => parse_node_get_next_ptr (pn_data)
     end do
     pn_item => null ()
   end subroutine slha_next_index_ptr
 
 @ %def slha_next_index_ptr
 @ Starting from the pointer to a data line, find a data line with the
 given integer code pair.
 <<SLHA: procedures>>=
   subroutine slha_next_index_pair_ptr (pn_data, pn_item, code1, code2)
     type(parse_node_t), intent(inout), pointer :: pn_data
     integer, intent(in) :: code1, code2
     type(parse_node_t), intent(out), pointer :: pn_item
     type(parse_node_t), pointer :: pn_line, pn_code1, pn_code2
     do while (associated (pn_data))
        pn_line => parse_node_get_sub_ptr (pn_data, 2)
        pn_code1 => parse_node_get_sub_ptr (pn_line)
        select case (char (parse_node_get_rule_key (pn_code1)))
        case ("integer")
           if (parse_node_get_integer (pn_code1) == code1) then
              pn_code2 => parse_node_get_next_ptr (pn_code1)
              if (associated (pn_code2)) then
                 select case (char (parse_node_get_rule_key (pn_code2)))
                 case ("integer")
                    if (parse_node_get_integer (pn_code2) == code2) then
                       pn_item => parse_node_get_next_ptr (pn_code2)
                       return
                    end if
                 end select
              end if
           end if
        end select
        pn_data => parse_node_get_next_ptr (pn_data)
     end do
     pn_item => null ()
   end subroutine slha_next_index_pair_ptr
 
 @ %def slha_next_index_pair_ptr
 @
 \subsubsection{Handle info data}
 Return all strings with index [[i]].  The result is an allocated
 string array.  Since we do not know the number of matching entries in
 advance, we build an intermediate list which is transferred to the
 final array and deleted before exiting.
 <<SLHA: procedures>>=
   subroutine retrieve_strings_in_block (pn_block, code, str_array)
     type(parse_node_t), intent(in), target :: pn_block
     integer, intent(in) :: code
     type(string_t), dimension(:), allocatable, intent(out) :: str_array
     type(parse_node_t), pointer :: pn_data, pn_item
     type :: str_entry_t
        type(string_t) :: str
        type(str_entry_t), pointer :: next => null ()
     end type str_entry_t
     type(str_entry_t), pointer :: first => null ()
     type(str_entry_t), pointer :: current => null ()
     integer :: n
     n = 0
     call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
     if (associated (pn_item)) then
        n = n + 1
        allocate (first)
        first%str = parse_node_get_string (pn_item)
        current => first
        do while (associated (pn_data))
           pn_data => parse_node_get_next_ptr (pn_data)
           call slha_next_index_ptr (pn_data, pn_item, code)
           if (associated (pn_item)) then
              n = n + 1
              allocate (current%next)
              current => current%next
              current%str = parse_node_get_string (pn_item)
           end if
        end do
        allocate (str_array (n))
        n = 0
        do while (associated (first))
           n = n + 1
           current => first
           str_array(n) = current%str
           first => first%next
           deallocate (current)
        end do
     else
        allocate (str_array (0))
     end if
   end subroutine retrieve_strings_in_block
 
 @ %def retrieve_strings_in_block
 @
 \subsubsection{Transfer data from SLHA to variables}
 Extract real parameter with index [[i]].  If it does not
 exist, retrieve it from the variable list, using the given name.
 <<SLHA: procedures>>=
   function get_parameter_in_block (pn_block, code, name, var_list) result (var)
     real(default) :: var
     type(parse_node_t), intent(in), target :: pn_block
     integer, intent(in) :: code
     type(string_t), intent(in) :: name
     type(var_list_t), intent(in), target :: var_list
     type(parse_node_t), pointer :: pn_data, pn_item
     call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
     if (associated (pn_item)) then
        var = get_real_parameter (pn_item)
     else
        var = var_list%get_rval (name)
     end if
   end function get_parameter_in_block
 
 @ %def get_parameter_in_block
 @ Extract a real data item with index [[i]].  If it
 does exist, set it in the variable list, using the given name.  If
 the variable is not present in the variable list, ignore it.
 <<SLHA: procedures>>=
   subroutine set_data_item (pn_block, code, name, var_list)
     type(parse_node_t), intent(in), target :: pn_block
     integer, intent(in) :: code
     type(string_t), intent(in) :: name
     type(var_list_t), intent(inout), target :: var_list
     type(parse_node_t), pointer :: pn_data, pn_item
     call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
     if (associated (pn_item)) then
        call var_list%set_real (name,  get_real_parameter (pn_item), &
              is_known=.true., ignore=.true.)
     end if
   end subroutine set_data_item
 
 @ %def set_data_item
 @ Extract a real matrix element with index [[i,j]].  If it
 does exists, set it in the variable list, using the given name.  If
 the variable is not present in the variable list, ignore it.
 <<SLHA: procedures>>=
   subroutine set_matrix_element (pn_block, code1, code2, name, var_list)
     type(parse_node_t), intent(in), target :: pn_block
     integer, intent(in) :: code1, code2
     type(string_t), intent(in) :: name
     type(var_list_t), intent(inout), target :: var_list
     type(parse_node_t), pointer :: pn_data, pn_item
     call slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2)
     if (associated (pn_item)) then
        call var_list%set_real (name, get_real_parameter (pn_item), &
              is_known=.true., ignore=.true.)
     end if
   end subroutine set_matrix_element
 
 @ %def set_matrix_element
 @
 \subsubsection{Transfer data from variables to SLHA}
 Get a real/integer parameter with index [[i]] from the variable list and write
 it to the current output file.  In the integer case, we account for
 the fact that the variable is type real.  If it does not exist, do nothing.
 <<SLHA: procedures>>=
   subroutine write_integer_data_item (u, code, name, var_list, comment)
     integer, intent(in) :: u
     integer, intent(in) :: code
     type(string_t), intent(in) :: name
     type(var_list_t), intent(in) :: var_list
     character(*), intent(in) :: comment
     integer :: item
     if (var_list%contains (name)) then
        item = nint (var_list%get_rval (name))
        call write_integer_parameter (u, code, item, comment)
     end if
   end subroutine write_integer_data_item
 
   subroutine write_real_data_item (u, code, name, var_list, comment)
     integer, intent(in) :: u
     integer, intent(in) :: code
     type(string_t), intent(in) :: name
     type(var_list_t), intent(in) :: var_list
     character(*), intent(in) :: comment
     real(default) :: item
     if (var_list%contains (name)) then
        item = var_list%get_rval (name)
        call write_real_parameter (u, code, item, comment)
     end if
   end subroutine write_real_data_item
 
 @ %def write_real_data_item
 @ Get a real data item with two integer indices from the variable list
 and write it to the current output file.  If it does not exist, do
 nothing.
 <<SLHA: procedures>>=
   subroutine write_matrix_element (u, code1, code2, name, var_list, comment)
     integer, intent(in) :: u
     integer, intent(in) :: code1, code2
     type(string_t), intent(in) :: name
     type(var_list_t), intent(in) :: var_list
     character(*), intent(in) :: comment
     real(default) :: item
     if (var_list%contains (name)) then
        item = var_list%get_rval (name)
        call write_real_matrix_element (u, code1, code2, item, comment)
     end if
   end subroutine write_matrix_element
 
 @ %def write_matrix_element
 @
 \subsection{Auxiliary function}
 Write a block header.
 <<SLHA: procedures>>=
   subroutine write_block_header (u, name, comment)
     integer, intent(in) :: u
     character(*), intent(in) :: name, comment
     write (u, "(A,1x,A,3x,'#',1x,A)")  "BLOCK", name, comment
   end subroutine write_block_header
 
 @ %def write_block_header
 @ Extract a real parameter that may be defined real or
 integer, signed or unsigned.
 <<SLHA: procedures>>=
   function get_real_parameter (pn_item) result (var)
     real(default) :: var
     type(parse_node_t), intent(in), target :: pn_item
     type(parse_node_t), pointer :: pn_sign, pn_var
     integer :: sign
     select case (char (parse_node_get_rule_key (pn_item)))
     case ("signed_number")
        pn_sign => parse_node_get_sub_ptr (pn_item)
        pn_var  => parse_node_get_next_ptr (pn_sign)
        select case (char (parse_node_get_key (pn_sign)))
        case ("+");  sign = +1
        case ("-");  sign = -1
        end select
     case default
        sign = +1
        pn_var => pn_item
     end select
     select case (char (parse_node_get_rule_key (pn_var)))
     case ("integer");  var = sign * parse_node_get_integer (pn_var)
     case ("real");     var = sign * parse_node_get_real (pn_var)
     end select
   end function get_real_parameter
 
 @ %def get_real_parameter
 @ Auxiliary: Extract an integer parameter that may be defined signed
 or unsigned.  A real value is an error.
 <<SLHA: procedures>>=
   function get_integer_parameter (pn_item) result (var)
     integer :: var
     type(parse_node_t), intent(in), target :: pn_item
     type(parse_node_t), pointer :: pn_sign, pn_var
     integer :: sign
     select case (char (parse_node_get_rule_key (pn_item)))
     case ("signed_integer")
        pn_sign => parse_node_get_sub_ptr (pn_item)
        pn_var  => parse_node_get_next_ptr (pn_sign)
        select case (char (parse_node_get_key (pn_sign)))
        case ("+");  sign = +1
        case ("-");  sign = -1
        end select
     case ("integer")
        sign = +1
        pn_var => pn_item
     case default
        call parse_node_write (pn_var)
        call msg_error ("SLHA: Integer parameter expected")
        var = 0
        return
     end select
     var = sign * parse_node_get_integer (pn_var)
   end function get_integer_parameter
 
 @ %def get_real_parameter
 @ Write an integer parameter with a single index directly to file,
 using the required output format.
 <<SLHA: procedures>>=
   subroutine write_integer_parameter (u, code, item, comment)
     integer, intent(in) :: u
     integer, intent(in) :: code
     integer, intent(in) :: item
     character(*), intent(in) :: comment
 1   format (1x, I9, 3x, 3x, I9, 4x, 3x, '#', 1x, A)
     write (u, 1)  code, item, comment
   end subroutine write_integer_parameter
 
 @ %def write_integer_parameter
 @ Write a real parameter with two indices directly to file,
 using the required output format.
 <<SLHA: procedures>>=
   subroutine write_real_parameter (u, code, item, comment)
     integer, intent(in) :: u
     integer, intent(in) :: code
     real(default), intent(in) :: item
     character(*), intent(in) :: comment
 1   format (1x, I9, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A)
     write (u, 1)  code, item, comment
   end subroutine write_real_parameter
 
 @ %def write_real_parameter
 @ Write a real parameter with a single index directly to file,
 using the required output format.
 <<SLHA: procedures>>=
   subroutine write_real_matrix_element (u, code1, code2, item, comment)
     integer, intent(in) :: u
     integer, intent(in) :: code1, code2
     real(default), intent(in) :: item
     character(*), intent(in) :: comment
 1   format (1x, I2, 1x, I2, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A)
     write (u, 1)  code1, code2, item, comment
   end subroutine write_real_matrix_element
 
 @ %def write_real_matrix_element
 @
 \subsubsection{The concrete SLHA interpreter}
 SLHA codes for particular physics models
 <<SLHA: parameters>>=
   integer, parameter :: MDL_MSSM = 0
   integer, parameter :: MDL_NMSSM = 1
 @ %def MDL_MSSM MDL_NMSSM
 @ Take the parse tree and extract relevant data.  Select the correct
 model and store all data that is present in the appropriate variable
 list.  Finally, update the variable record.
 
 Public for use in unit test.
 <<SLHA: public>>=
   public :: slha_interpret_parse_tree
 <<SLHA: procedures>>=
   subroutine slha_interpret_parse_tree &
        (parse_tree, model, input, spectrum, decays)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     logical, intent(in) :: input, spectrum, decays
     logical :: errors
     integer :: mssm_type
     call slha_handle_MODSEL (parse_tree, model, mssm_type)
     if (input) then
        call slha_handle_SMINPUTS (parse_tree, model)
        call slha_handle_MINPAR (parse_tree, model, mssm_type)
     end if
     if (spectrum) then
        call slha_handle_info_block (parse_tree, "SPINFO", errors)
        if (errors)  return
        call slha_handle_MASS (parse_tree, model)
        call slha_handle_matrix_block (parse_tree, "NMIX", "mn_", 4, 4, model)
        call slha_handle_matrix_block (parse_tree, "NMNMIX", "mixn_", 5, 5, model)
        call slha_handle_matrix_block (parse_tree, "UMIX", "mu_", 2, 2, model)
        call slha_handle_matrix_block (parse_tree, "VMIX", "mv_", 2, 2, model)
        call slha_handle_matrix_block (parse_tree, "STOPMIX", "mt_", 2, 2, model)
        call slha_handle_matrix_block (parse_tree, "SBOTMIX", "mb_", 2, 2, model)
        call slha_handle_matrix_block (parse_tree, "STAUMIX", "ml_", 2, 2, model)
        call slha_handle_matrix_block (parse_tree, "NMHMIX", "mixh0_", 3, 3, model)
        call slha_handle_matrix_block (parse_tree, "NMAMIX", "mixa0_", 2, 3, model)
        call slha_handle_ALPHA (parse_tree, model)
        call slha_handle_HMIX (parse_tree, model)
        call slha_handle_NMSSMRUN (parse_tree, model)
        call slha_handle_matrix_block (parse_tree, "AU", "Au_", 3, 3, model)
        call slha_handle_matrix_block (parse_tree, "AD", "Ad_", 3, 3, model)
        call slha_handle_matrix_block (parse_tree, "AE", "Ae_", 3, 3, model)
     end if
     if (decays) then
        call slha_handle_info_block (parse_tree, "DCINFO", errors)
        if (errors)  return
        call slha_handle_decays (parse_tree, model)
     end if
   end subroutine slha_interpret_parse_tree
 
 @ %def slha_interpret_parse_tree
 @
 \subsubsection{Info blocks}
 Handle the informational blocks SPINFO and DCINFO.  The first two
 items are program name and version.  Items with index 3 are warnings.
 Items with index 4 are errors.  We reproduce these as WHIZARD warnings
 and errors.
 <<SLHA: procedures>>=
   subroutine slha_handle_info_block (parse_tree, block_name, errors)
     type(parse_tree_t), intent(in) :: parse_tree
     character(*), intent(in) :: block_name
     logical, intent(out) :: errors
     type(parse_node_t), pointer :: pn_block
     type(string_t), dimension(:), allocatable :: msg
     integer :: i
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str (block_name), required=.true.)
     if (.not. associated (pn_block)) then
        call msg_error ("SLHA: Missing info block '" &
             // trim (block_name) // "'; ignored.")
        errors = .true.
        return
     end if
     select case (block_name)
     case ("SPINFO")
        call msg_message ("SLHA: SUSY spectrum program info:")
     case ("DCINFO")
        call msg_message ("SLHA: SUSY decay program info:")
     end select
     call retrieve_strings_in_block (pn_block, 1, msg)
     do i = 1, size (msg)
        call msg_message ("SLHA: " // char (msg(i)))
     end do
     call retrieve_strings_in_block (pn_block, 2, msg)
     do i = 1, size (msg)
        call msg_message ("SLHA: " // char (msg(i)))
     end do
     call retrieve_strings_in_block (pn_block, 3, msg)
     do i = 1, size (msg)
        call msg_warning ("SLHA: " // char (msg(i)))
     end do
     call retrieve_strings_in_block (pn_block, 4, msg)
     do i = 1, size (msg)
        call msg_error ("SLHA: " // char (msg(i)))
     end do
     errors = size (msg) > 0
   end subroutine slha_handle_info_block
 
 @ %def slha_handle_info_block
 @
 \subsubsection{MODSEL}
 Handle the overall model definition.  Only certain models are
 recognized.  The soft-breaking model templates that determine the set
 of input parameters:
 <<SLHA: parameters>>=
   integer, parameter :: MSSM_GENERIC = 0
   integer, parameter :: MSSM_SUGRA = 1
   integer, parameter :: MSSM_GMSB = 2
   integer, parameter :: MSSM_AMSB = 3
 
 @ %def MSSM_GENERIC MSSM_MSUGRA MSSM_GMSB MSSM_AMSB
 <<SLHA: procedures>>=
   subroutine slha_handle_MODSEL (parse_tree, model, mssm_type)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(in), target :: model
     integer, intent(out) :: mssm_type
     type(parse_node_t), pointer :: pn_block, pn_data, pn_item
     type(string_t) :: model_name
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("MODSEL"), required=.true.)
     call slha_find_index_ptr (pn_block, pn_data, pn_item, 1)
     if (associated (pn_item)) then
        mssm_type = get_integer_parameter (pn_item)
     else
        mssm_type = MSSM_GENERIC
     end if
     call slha_find_index_ptr (pn_block, pn_data, pn_item, 3)
     if (associated (pn_item)) then
        select case (parse_node_get_integer (pn_item))
        case (MDL_MSSM);  model_name = "MSSM"
        case (MDL_NMSSM); model_name = "NMSSM"
        case default
           call msg_fatal ("SLHA: unknown model code in MODSEL")
           return
        end select
     else
        model_name = "MSSM"
     end if
     call slha_find_index_ptr (pn_block, pn_data, pn_item, 4)
     if (associated (pn_item)) then
       call msg_fatal (" R-parity violation is currently not supported by WHIZARD.")
     end	if
     call slha_find_index_ptr (pn_block, pn_data, pn_item, 5)
     if (associated (pn_item)) then
       call msg_fatal (" CP violation is currently not supported by WHIZARD.")
     end	if
     select case (char (model_name))
     case ("MSSM")
        select case (char (model%get_name ()))
        case ("MSSM","MSSM_CKM","MSSM_Grav","MSSM_Hgg")
           model_name = model%get_name ()
        case default
           call msg_fatal ("Selected model '" &
                // char (model%get_name ()) // "' does not match model '" &
                // char (model_name) // "' in SLHA input file.")
           return
        end select
     case ("NMSSM")
        select case (char (model%get_name ()))
        case ("NMSSM","NMSSM_CKM","NMSSM_Hgg")
           model_name = model%get_name ()
        case default
           call msg_fatal ("Selected model '" &
                // char (model%get_name ()) // "' does not match model '" &
                // char (model_name) // "' in SLHA input file.")
           return
        end select
     case default
        call msg_bug ("SLHA model name '" &
             // char (model_name) // "' not recognized.")
        return
     end select
     call msg_message ("SLHA: Initializing model '" // char (model_name) // "'")
   end subroutine slha_handle_MODSEL
 
 @ %def slha_handle_MODSEL
 @ Write a MODSEL block, based on the contents of the current model.
 <<SLHA: procedures>>=
   subroutine slha_write_MODSEL (u, model, mssm_type)
     integer, intent(in) :: u
     type(model_t), intent(in), target :: model
     integer, intent(out) :: mssm_type
     type(var_list_t), pointer :: var_list
     integer :: model_id
     type(string_t) :: mtype_string
     var_list => model%get_var_list_ptr ()
     if (var_list%contains (var_str ("mtype"))) then
        mssm_type = nint (var_list%get_rval (var_str ("mtype")))
     else
        call msg_error ("SLHA: parameter 'mtype' (SUSY breaking scheme) " &
             // "is unknown in current model, no SLHA output possible")
        mssm_type = -1
        return
     end if
     call write_block_header (u, "MODSEL", "SUSY model selection")
     select case (mssm_type)
     case (0);  mtype_string = "Generic MSSM"
     case (1);  mtype_string = "SUGRA"
     case (2);  mtype_string = "GMSB"
     case (3);  mtype_string = "AMSB"
     case default
        mtype_string = "unknown"
     end select
     call write_integer_parameter (u, 1, mssm_type, &
          "SUSY-breaking scheme: " // char (mtype_string))
     select case (char (model%get_name ()))
     case ("MSSM");  model_id = MDL_MSSM
     case ("NMSSM"); model_id = MDL_NMSSM
     case default
        model_id = 0
     end select
     call write_integer_parameter (u, 3, model_id, &
          "SUSY model type: " // char (model%get_name ()))
   end subroutine slha_write_MODSEL
 
 @ %def slha_write_MODSEL
 @
 \subsubsection{SMINPUTS}
 Read SM parameters and update the variable list accordingly.  If a
 parameter is not defined in the block, we use the previous value from
 the model variable list.  For the basic parameters we have to do a
 small recalculation, since SLHA uses the $G_F$-$\alpha$-$m_Z$ scheme,
 while \whizard\ derives them from $G_F$, $m_W$, and $m_Z$.
 <<SLHA: procedures>>=
   subroutine slha_handle_SMINPUTS (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_block
     real(default) :: alpha_em_i, GF, alphas, mZ
     real(default) :: ee, vv, cw_sw, cw2, mW
     real(default) :: mb, mtop, mtau
     type(var_list_t), pointer :: var_list
     var_list => model%get_var_list_ptr ()
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("SMINPUTS"), required=.true.)
     if (.not. (associated (pn_block)))  return
     alpha_em_i = &
          get_parameter_in_block (pn_block, 1, var_str ("alpha_em_i"), var_list)
     GF = get_parameter_in_block (pn_block, 2, var_str ("GF"), var_list)
     alphas = &
          get_parameter_in_block (pn_block, 3, var_str ("alphas"), var_list)
     mZ   = get_parameter_in_block (pn_block, 4, var_str ("mZ"), var_list)
     mb   = get_parameter_in_block (pn_block, 5, var_str ("mb"), var_list)
     mtop = get_parameter_in_block (pn_block, 6, var_str ("mtop"), var_list)
     mtau = get_parameter_in_block (pn_block, 7, var_str ("mtau"), var_list)
     ee = sqrt (4 * pi / alpha_em_i)
     vv = 1 / sqrt (sqrt (2._default) * GF)
     cw_sw = ee * vv / (2 * mZ)
     if (2*cw_sw <= 1) then
        cw2 = (1 + sqrt (1 - 4 * cw_sw**2)) / 2
        mW = mZ * sqrt (cw2)
        call var_list%set_real (var_str ("GF"), GF, .true.)
        call var_list%set_real (var_str ("mZ"), mZ, .true.)
        call var_list%set_real (var_str ("mW"), mW, .true.)
        call var_list%set_real (var_str ("mtau"), mtau, .true.)
        call var_list%set_real (var_str ("mb"), mb, .true.)
        call var_list%set_real (var_str ("mtop"), mtop, .true.)
        call var_list%set_real (var_str ("alphas"), alphas, .true.)
     else
        call msg_fatal ("SLHA: Unphysical SM parameter values")
        return
     end if
   end subroutine slha_handle_SMINPUTS
 
 @ %def slha_handle_SMINPUTS
 @ Write a SMINPUTS block.
 <<SLHA: procedures>>=
   subroutine slha_write_SMINPUTS (u, model)
     integer, intent(in) :: u
     type(model_t), intent(in), target :: model
     type(var_list_t), pointer :: var_list
     var_list => model%get_var_list_ptr ()
     call write_block_header (u, "SMINPUTS", "SM input parameters")
     call write_real_data_item (u, 1, var_str ("alpha_em_i"), var_list, &
          "Inverse electromagnetic coupling alpha (Z pole)")
     call write_real_data_item (u, 2, var_str ("GF"), var_list, &
          "Fermi constant")
     call write_real_data_item (u, 3, var_str ("alphas"), var_list, &
          "Strong coupling alpha_s (Z pole)")
     call write_real_data_item (u, 4, var_str ("mZ"), var_list, &
          "Z mass")
     call write_real_data_item (u, 5, var_str ("mb"), var_list, &
          "b running mass (at mb)")
     call write_real_data_item (u, 6, var_str ("mtop"), var_list, &
          "top mass")
     call write_real_data_item (u, 7, var_str ("mtau"), var_list, &
          "tau mass")
   end subroutine slha_write_SMINPUTS
 
 @ %def slha_write_SMINPUTS
 @
 \subsubsection{MINPAR}
 The block of SUSY input parameters.  They are accessible to WHIZARD,
 but they only get used when an external spectrum generator is
 invoked.  The precise set of parameters depends on the type of SUSY
 breaking, which by itself is one of the parameters.
 <<SLHA: procedures>>=
   subroutine slha_handle_MINPAR (parse_tree, model, mssm_type)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     integer, intent(in) :: mssm_type
     type(var_list_t), pointer :: var_list
     type(parse_node_t), pointer :: pn_block
     var_list => model%get_var_list_ptr ()
     call var_list%set_real &
          (var_str ("mtype"),  real(mssm_type, default), is_known=.true.)
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("MINPAR"), required=.true.)
     select case (mssm_type)
     case (MSSM_SUGRA)
        call set_data_item (pn_block, 1, var_str ("m_zero"), var_list)
        call set_data_item (pn_block, 2, var_str ("m_half"), var_list)
        call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
        call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
        call set_data_item (pn_block, 5, var_str ("A0"), var_list)
     case (MSSM_GMSB)
        call set_data_item (pn_block, 1, var_str ("Lambda"), var_list)
        call set_data_item (pn_block, 2, var_str ("M_mes"), var_list)
        call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
        call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
        call set_data_item (pn_block, 5, var_str ("N_5"), var_list)
        call set_data_item (pn_block, 6, var_str ("c_grav"), var_list)
     case (MSSM_AMSB)
        call set_data_item (pn_block, 1, var_str ("m_zero"), var_list)
        call set_data_item (pn_block, 2, var_str ("m_grav"), var_list)
        call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
        call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
     case default
        call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
     end select
   end subroutine slha_handle_MINPAR
 
 @ %def slha_handle_MINPAR
 @ Write a MINPAR block as appropriate for the current model type.
 <<SLHA: procedures>>=
   subroutine slha_write_MINPAR (u, model, mssm_type)
     integer, intent(in) :: u
     type(model_t), intent(in), target :: model
     integer, intent(in) :: mssm_type
     type(var_list_t), pointer :: var_list
     var_list => model%get_var_list_ptr ()
     call write_block_header (u, "MINPAR", "Basic SUSY input parameters")
     select case (mssm_type)
     case (MSSM_SUGRA)
        call write_real_data_item (u, 1, var_str ("m_zero"), var_list, &
             "Common scalar mass")
        call write_real_data_item (u, 2, var_str ("m_half"), var_list, &
             "Common gaugino mass")
        call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
             "tan(beta)")
        call write_integer_data_item (u, 4, &
             var_str ("sgn_mu"), var_list, &
             "Sign of mu")
        call write_real_data_item (u, 5, var_str ("A0"), var_list, &
             "Common trilinear coupling")
     case (MSSM_GMSB)
        call write_real_data_item (u, 1, var_str ("Lambda"), var_list, &
             "Soft-breaking scale")
        call write_real_data_item (u, 2, var_str ("M_mes"), var_list, &
             "Messenger scale")
        call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
             "tan(beta)")
        call write_integer_data_item (u, 4, &
             var_str ("sgn_mu"), var_list, &
             "Sign of mu")
        call write_integer_data_item (u, 5, var_str ("N_5"), var_list, &
             "Messenger index")
        call write_real_data_item (u, 6, var_str ("c_grav"), var_list, &
             "Gravitino mass factor")
     case (MSSM_AMSB)
        call write_real_data_item (u, 1, var_str ("m_zero"), var_list, &
             "Common scalar mass")
        call write_real_data_item (u, 2, var_str ("m_grav"), var_list, &
             "Gravitino mass")
        call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
             "tan(beta)")
        call write_integer_data_item (u, 4, &
             var_str ("sgn_mu"), var_list, &
             "Sign of mu")
     case default
        call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
             "tan(beta)")
     end select
   end subroutine slha_write_MINPAR
 
 @ %def slha_write_MINPAR
 @
 \subsubsection{Mass spectrum}
 Set masses.  Since the particles are identified by PDG code, read
 the line and try to set the appropriate particle mass in the current
 model.  At the end, update parameters, just in case the $W$ or $Z$
 mass was included.
 <<SLHA: procedures>>=
   subroutine slha_handle_MASS (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_block, pn_data, pn_line, pn_code
     type(parse_node_t), pointer :: pn_mass
     integer :: pdg
     real(default) :: mass
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("MASS"), required=.true.)
     if (.not. (associated (pn_block)))  return
     pn_data => parse_node_get_sub_ptr (pn_block, 4)
     do while (associated (pn_data))
        pn_line => parse_node_get_sub_ptr (pn_data, 2)
        pn_code => parse_node_get_sub_ptr (pn_line)
        if (associated (pn_code)) then
           pdg = get_integer_parameter (pn_code)
           pn_mass => parse_node_get_next_ptr (pn_code)
           if (associated (pn_mass)) then
              mass = get_real_parameter (pn_mass)
              call model%set_field_mass (pdg, mass)
           else
              call msg_error ("SLHA: Block MASS: Missing mass value")
           end if
        else
           call msg_error ("SLHA: Block MASS: Missing PDG code")
        end if
        pn_data => parse_node_get_next_ptr (pn_data)
     end do
   end subroutine slha_handle_MASS
 
 @ %def slha_handle_MASS
 @
 \subsubsection{Widths}
 Set widths.  For each DECAY block, extract the header, read the PDG
 code and width, and try to set the appropriate particle width in the
 current model.
 <<SLHA: procedures>>=
   subroutine slha_handle_decays (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_decay, pn_decay_spec, pn_code, pn_width
     integer :: pdg
     real(default) :: width
     pn_decay => slha_get_first_decay_ptr (parse_tree)
     do while (associated (pn_decay))
        pn_decay_spec => parse_node_get_sub_ptr (pn_decay, 2)
        pn_code => parse_node_get_sub_ptr (pn_decay_spec)
        pdg = get_integer_parameter (pn_code)
        pn_width => parse_node_get_next_ptr (pn_code)
        width = get_real_parameter (pn_width)
        call model%set_field_width (pdg, width)
        pn_decay => slha_get_next_decay_ptr (pn_decay)
     end do
   end subroutine slha_handle_decays
 
 @ %def slha_handle_decays
 @
 \subsubsection{Mixing matrices}
 Read mixing matrices.  We can treat all matrices by a single
 procedure if we just know the block name, variable prefix, and matrix
 dimension.  The matrix dimension must be less than 10.
 For the pseudoscalar Higgses in NMSSM-type models we need off-diagonal
 matrices, so we generalize the definition.
 <<SLHA: procedures>>=
   subroutine slha_handle_matrix_block &
        (parse_tree, block_name, var_prefix, dim1, dim2, model)
     type(parse_tree_t), intent(in) :: parse_tree
     character(*), intent(in) :: block_name, var_prefix
     integer, intent(in) :: dim1, dim2
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_block
     type(var_list_t), pointer :: var_list
     integer :: i, j
     character(len=len(var_prefix)+2) :: var_name
     var_list => model%get_var_list_ptr ()
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str (block_name), required=.false.)
     if (.not. (associated (pn_block)))  return
     do i = 1, dim1
        do j = 1, dim2
           write (var_name, "(A,I1,I1)")  var_prefix, i, j
           call set_matrix_element (pn_block, i, j, var_str (var_name), var_list)
        end do
     end do
   end subroutine slha_handle_matrix_block
 
 @ %def slha_handle_matrix_block
 @
 \subsubsection{Higgs data}
 Read the block ALPHA which holds just the Higgs mixing angle.
 <<SLHA: procedures>>=
   subroutine slha_handle_ALPHA (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_block, pn_line, pn_data, pn_item
     type(var_list_t), pointer :: var_list
     real(default) :: al_h
     var_list => model%get_var_list_ptr ()
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("ALPHA"), required=.false.)
     if (.not. (associated (pn_block)))  return
     pn_data => parse_node_get_sub_ptr (pn_block, 4)
     pn_line => parse_node_get_sub_ptr (pn_data, 2)
     pn_item => parse_node_get_sub_ptr (pn_line)
     if (associated (pn_item)) then
        al_h = get_real_parameter (pn_item)
        call var_list%set_real (var_str ("al_h"), al_h, &
             is_known=.true., ignore=.true.)
     end if
   end subroutine slha_handle_ALPHA
 
 @ %def slha_handle_matrix_block
 @ Read the block HMIX for the Higgs mixing parameters
 <<SLHA: procedures>>=
   subroutine slha_handle_HMIX (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_block
     type(var_list_t), pointer :: var_list
     var_list => model%get_var_list_ptr ()
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("HMIX"), required=.false.)
     if (.not. (associated (pn_block)))  return
     call set_data_item (pn_block, 1, var_str ("mu_h"), var_list)
     call set_data_item (pn_block, 2, var_str ("tanb_h"), var_list)
   end subroutine slha_handle_HMIX
 
 @ %def slha_handle_HMIX
 @ Read the block NMSSMRUN for the specific NMSSM parameters
 <<SLHA: procedures>>=
   subroutine slha_handle_NMSSMRUN (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
     type(parse_node_t), pointer :: pn_block
     type(var_list_t), pointer :: var_list
     var_list => model%get_var_list_ptr ()
     pn_block => slha_get_block_ptr &
          (parse_tree, var_str ("NMSSMRUN"), required=.false.)
     if (.not. (associated (pn_block)))  return
     call set_data_item (pn_block, 1, var_str ("ls"), var_list)
     call set_data_item (pn_block, 2, var_str ("ks"), var_list)
     call set_data_item (pn_block, 3, var_str ("a_ls"), var_list)
     call set_data_item (pn_block, 4, var_str ("a_ks"), var_list)
     call set_data_item (pn_block, 5, var_str ("nmu"), var_list)
     end subroutine slha_handle_NMSSMRUN
 
 @ %def slha_handle_NMSSMRUN
 @
 \subsection{Parser}
 Read a SLHA file from stream, including preprocessing, and make up a
 parse tree.
 <<SLHA: procedures>>=
   subroutine slha_parse_stream (stream, parse_tree)
     type(stream_t), intent(inout), target :: stream
     type(parse_tree_t), intent(out) :: parse_tree
     type(ifile_t) :: ifile
     type(lexer_t) :: lexer
     type(stream_t), target :: stream_tmp
     call slha_preprocess (stream, ifile)
     call stream_init (stream_tmp, ifile)
     call lexer_init_slha (lexer)
     call lexer_assign_stream (lexer, stream_tmp)
     call parse_tree_init (parse_tree, syntax_slha, lexer)
     call lexer_final (lexer)
     call stream_final (stream_tmp)
     call ifile_final (ifile)
   end subroutine slha_parse_stream
 
 @ %def slha_parse_stream
 @ Read a SLHA file chosen by name.  Check first the current directory,
 then the directory where SUSY input files should be located.
 
 Required for test:
 <<SLHA: public>>=
   public :: slha_parse_file
 <<SLHA: procedures>>=
   subroutine slha_parse_file (file, os_data, parse_tree)
     type(string_t), intent(in) :: file
     type(os_data_t), intent(in) :: os_data
     type(parse_tree_t), intent(out) :: parse_tree
     logical :: exist
     type(string_t) :: filename
     type(stream_t), target :: stream
     call msg_message ("Reading SLHA input file '" // char (file) // "'")
     filename = file
     inquire (file=char(filename), exist=exist)
     if (.not. exist) then
        filename = os_data%whizard_susypath // "/" // file
        inquire (file=char(filename), exist=exist)
        if (.not. exist) then
           call msg_fatal ("SLHA input file '" // char (file) // "' not found")
           return
        end if
     end if
     call stream_init (stream, char (filename))
     call slha_parse_stream (stream, parse_tree)
     call stream_final (stream)
   end subroutine slha_parse_file
 
 @ %def slha_parse_file
 @
 \subsection{API}
 Read the SLHA file, parse it, and interpret the parse tree.  The model
 parameters retrieved from the file will be inserted into the
 appropriate model, which is loaded and modified in the background.
 The pointer to this model is returned as the last argument.
 <<SLHA: public>>=
   public :: slha_read_file
 <<SLHA: procedures>>=
   subroutine slha_read_file &
        (file, os_data, model, input, spectrum, decays)
     type(string_t), intent(in) :: file
     type(os_data_t), intent(in) :: os_data
     type(model_t), intent(inout), target :: model
     logical, intent(in) :: input, spectrum, decays
     type(parse_tree_t) :: parse_tree
     call slha_parse_file (file, os_data, parse_tree)
     if (associated (parse_tree%get_root_ptr ())) then
        call slha_interpret_parse_tree &
             (parse_tree, model, input, spectrum, decays)
        call parse_tree_final (parse_tree)
        call model%update_parameters ()
     end if
   end subroutine slha_read_file
 
 @ %def slha_read_file
 @ Write the SLHA contents, as far as possible, to external file.
 <<SLHA: public>>=
   public :: slha_write_file
 <<SLHA: procedures>>=
   subroutine slha_write_file (file, model, input, spectrum, decays)
     type(string_t), intent(in) :: file
     type(model_t), target, intent(in) :: model
     logical, intent(in) :: input, spectrum, decays
     integer :: mssm_type
     integer :: u
     u = free_unit ()
     call msg_message ("Writing SLHA output file '" // char (file) // "'")
     open (unit=u, file=char(file), action="write", status="replace")
     write (u, "(A)")  "# SUSY Les Houches Accord"
     write (u, "(A)")  "# Output generated by " // trim (VERSION_STRING)
     call slha_write_MODSEL (u, model, mssm_type)
     if (input) then
        call slha_write_SMINPUTS (u, model)
        call slha_write_MINPAR (u, model, mssm_type)
     end if
     if (spectrum) then
        call msg_bug ("SLHA: spectrum output not supported yet")
     end if
     if (decays) then
        call msg_bug ("SLHA: decays output not supported yet")
     end if
     close (u)
   end subroutine slha_write_file
 
 @ %def slha_write_file
 @
 \subsection{Dispatch}
 <<SLHA: public>>=
   public :: dispatch_slha
 <<SLHA: procedures>>=
   subroutine dispatch_slha (var_list, input, spectrum, decays)
     type(var_list_t), intent(inout), target :: var_list
     logical, intent(out) :: input, spectrum, decays
     input = var_list%get_lval (var_str ("?slha_read_input"))
     spectrum = var_list%get_lval (var_str ("?slha_read_spectrum"))
     decays = var_list%get_lval (var_str ("?slha_read_decays"))
   end subroutine dispatch_slha
 
 @ %def dispatch_slha
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[slha_interface_ut.f90]]>>=
 <<File header>>
 
 module slha_interface_ut
   use unit_tests
   use slha_interface_uti
 
 <<Standard module head>>
 
 <<SLHA: public test>>
 
 contains
 
 <<SLHA: test driver>>
 
 end module slha_interface_ut
 @ %def slha_interface_ut
 @
 <<[[slha_interface_uti.f90]]>>=
 <<File header>>
 
 module slha_interface_uti
 
 <<Use strings>>
   use io_units
   use os_interface
   use parser
   use model_data
   use variables
   use models
 
   use slha_interface
 
 <<Standard module head>>
 
 <<SLHA: test declarations>>
 
 contains
 
 <<SLHA: tests>>
 
 end module slha_interface_uti
 @ %def slha_interface_ut
 @ API: driver for the unit tests below.
 <<SLHA: public test>>=
   public :: slha_test
 <<SLHA: test driver>>=
   subroutine slha_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SLHA: execute tests>>
   end subroutine slha_test
 
 @  %def slha_test
 @ Checking the basics of the SLHA interface.
 <<SLHA: execute tests>>=
   call test (slha_1, "slha_1", &
        "check SLHA interface", &
        u, results)
 <<SLHA: test declarations>>=
   public :: slha_1
 <<SLHA: tests>>=
   subroutine slha_1 (u)
     integer, intent(in) :: u
     type(os_data_t), pointer :: os_data => null ()
     type(parse_tree_t), pointer :: parse_tree => null ()
     integer :: u_file, iostat
     character(80) :: buffer
     character(*), parameter :: file_slha = "slha_test.dat"
     type(model_list_t) :: model_list
     type(model_t), pointer :: model => null ()
 
     write (u, "(A)")  "* Test output: SLHA Interface"
     write (u, "(A)")  "*   Purpose: test SLHA file reading and writing"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initializing"
     write (u, "(A)")
 
     allocate (os_data)
     allocate (parse_tree)
     call os_data%init ()
     call syntax_model_file_init ()
     call model_list%read_model &
          (var_str("MSSM"), var_str("MSSM.mdl"), os_data, model)
     call syntax_slha_init ()
 
     write (u, "(A)")  "* Reading SLHA file sps1ap_decays.slha"
     write (u, "(A)")
 
     call slha_parse_file (var_str ("sps1ap_decays.slha"), os_data, parse_tree)
 
     write (u, "(A)")  "* Writing the parse tree:"
     write (u, "(A)")
 
     call parse_tree_write (parse_tree, u)
 
     write (u, "(A)")  "* Interpreting the parse tree"
     write (u, "(A)")
 
     call slha_interpret_parse_tree (parse_tree, model, &
          input=.true., spectrum=.true., decays=.true.)
     call parse_tree_final (parse_tree)
 
     write (u, "(A)")  "* Writing out the list of variables (reals only):"
     write (u, "(A)")
 
     call var_list_write (model%get_var_list_ptr (), &
          only_type = V_REAL, unit = u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Writing SLHA output to '" // file_slha // "'"
     write (u, "(A)")
 
     call slha_write_file (var_str (file_slha), model, input=.true., &
          spectrum=.false., decays=.false.)
     u_file = free_unit ()
     open (u_file, file = file_slha, action = "read", status = "old")
     do
        read (u_file, "(A)", iostat = iostat)  buffer
        if (buffer(1:37) == "# Output generated by WHIZARD version") then
           buffer = "[...]"
        end if
        if (iostat /= 0)  exit
        write (u, "(A)") trim (buffer)
     end do
     close (u_file)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call parse_tree_final (parse_tree)
     deallocate (parse_tree)
     deallocate (os_data)
 
     write (u, "(A)")  "* Test output end: slha_1"
     write (u, "(A)")
 
   end subroutine slha_1
 
 @ %def slha_1
 @
 \subsubsection{SLHA interface}
 This rather trivial sets all input values for the SLHA interface
 to [[false]].
 <<SLHA: execute tests>>=
   call test (slha_2, "slha_2", &
        "SLHA interface", &
        u, results)
 <<SLHA: test declarations>>=
   public :: slha_2
 <<SLHA: tests>>=
   subroutine slha_2 (u)
     integer, intent(in) :: u
     type(var_list_t) :: var_list
     logical :: input, spectrum, decays
 
     write (u, "(A)")  "* Test output: slha_2"
     write (u, "(A)")  "*   Purpose: SLHA interface settings"
     write (u, "(A)")
 
     write (u, "(A)")  "* Default settings"
     write (u, "(A)")
 
     call var_list%init_defaults (0)
     call dispatch_slha (var_list, &
          input = input, spectrum = spectrum, decays = decays)
 
     write (u, "(A,1x,L1)")  " slha_read_input     =", input
     write (u, "(A,1x,L1)")  " slha_read_spectrum  =", spectrum
     write (u, "(A,1x,L1)")  " slha_read_decays    =", decays
 
     call var_list%final ()
     call var_list%init_defaults (0)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set all entries to [false]"
     write (u, "(A)")
 
     call var_list%set_log (var_str ("?slha_read_input"), &
          .false., is_known = .true.)
     call var_list%set_log (var_str ("?slha_read_spectrum"), &
          .false., is_known = .true.)
     call var_list%set_log (var_str ("?slha_read_decays"), &
          .false., is_known = .true.)
 
     call dispatch_slha (var_list, &
          input = input, spectrum = spectrum, decays = decays)
 
     write (u, "(A,1x,L1)")  " slha_read_input     =", input
     write (u, "(A,1x,L1)")  " slha_read_spectrum  =", spectrum
     write (u, "(A,1x,L1)")  " slha_read_decays    =", decays
 
     call var_list%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: slha_2"
 
   end subroutine slha_2
 
 @ %def slha_2