Index: trunk/share/tests/unit_tests/ref-output/rt_data_1.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_1.ref	(revision 8441)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_1.ref	(revision 8442)
@@ -1,427 +1,428 @@
 * Test output: rt_data_1
 *   Purpose: initialize global runtime data
 
 ========================================================================
  Runtime data:
 ========================================================================
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 [undefined] $model_name = [unknown string]
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 [undefined] $library_name = [unknown string]
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
  iterations = 2:5000:"gw", 3:20000
 ========================================================================
  Process library stack: [empty]
 ========================================================================
  Beam structure: [any particles]
 ========================================================================
  Cuts: [undefined]
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event callback: [undefined]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : 'rt_data.log'
 ========================================================================
 
 * Test output end: rt_data_1
Index: trunk/share/tests/unit_tests/ref-output/rt_data_2.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_2.ref	(revision 8441)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_2.ref	(revision 8442)
@@ -1,491 +1,492 @@
 * Test output: rt_data_2
 *   Purpose: initialize global runtime data and fill contents
 
 ========================================================================
  Runtime data:
 ========================================================================
 gy =>  1.000000000000E+00
 ms =>  1.250000000000E+02
 ff =>  1.500000000000E+00
 mf* =>  1.875000000000E+02
 particle* = PDG(0)
 SCALAR* = PDG(25)
 s* = PDG(25)
 FERMION* = PDG(6)
 f* = PDG(6)
 fbar* = PDG(-6)
 F* = PDG(-6)
 charged* = PDG(6, -6)
 neutral* = PDG(25)
 colored* = PDG(6, -6)
 sqrts =  1.000000000000E+03
 luminosity =  3.300000000000E+01
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "Test"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 [undefined] $library_name = [unknown string]
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = "run1"
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
 model "Test"
  ! md5sum = 'DB28187ADA60804A3CFC14A025DED784'
 
    parameter gy =  1.000000000000E+00
    parameter ms =  1.250000000000E+02
    parameter ff =  1.500000000000E+00
    external mf =  1.875000000000E+02
 
    particle SCALAR 25
      name "s"
      spin 0
      mass ms
    particle FERMION 6
      name "f"
      anti "fbar" "F"
      tex_anti "\bar{f}"
      spin 1/2  isospin 1/2  charge 2/3  color 3
      mass mf
 
    vertex "fbar" "f" "s"
    vertex "s" "s" "s"
 ========================================================================
  Process library stack: [empty]
 ========================================================================
  Beam structure: [any particles]
 ========================================================================
  Cuts:
 ------------------------------------------------------------------------
 +  SEQUENCE    <lexpr>  =  <lsinglet>
 +  SEQUENCE    <lsinglet>  =  <lterm>
 |  +  SEQUENCE    <lterm>  =  <all_fun>
 |  |  +  SEQUENCE    <all_fun>  =  all <lexpr> <pargs1>
 |  |  |  +  KEYWORD     all  = [keyword] all
 |  |  |  +  SEQUENCE    <lexpr>  =  <lsinglet>
 |  |  |  |  +  SEQUENCE    <lsinglet>  =  <lterm>
 |  |  |  |  |  +  SEQUENCE    <lterm>  =  <compared_expr>
 |  |  |  |  |  |  +  SEQUENCE    <compared_expr>  =  <expr> <comparison>
 |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <variable>
 |  |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = Pt
 |  |  |  |  |  |  |  +  SEQUENCE    <comparison>  =  '>' <expr>
 |  |  |  |  |  |  |  |  +  KEYWORD     '>'  = [keyword] >
 |  |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <integer_value>
 |  |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <integer_value>  =  <integer_literal>
 |  |  |  |  |  |  |  |  |  |  |  |  +  INTEGER     <integer_literal>  = 100
 |  |  |  +  ARGUMENTS   <pargs1>  =  <pexpr>
 |  |  |  |  +  SEQUENCE    <pexpr>  =  <pterm>
 |  |  |  |  |  +  SEQUENCE    <pterm>  =  <pexpr_src>
 |  |  |  |  |  |  +  SEQUENCE    <pexpr_src>  =  <unspecified_prt>
 |  |  |  |  |  |  |  +  SEQUENCE    <unspecified_prt>  =  <cexpr>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <cexpr>  =  <variable>
 |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = s
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event sample formats = foo_fmt, bar_fmt
 ------------------------------------------------------------------------
  Event callback: [undefined]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : ''
 ========================================================================
 
 * Test output end: rt_data_2
Index: trunk/share/tests/unit_tests/ref-output/rt_data_3.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_3.ref	(revision 8441)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_3.ref	(revision 8442)
@@ -1,1035 +1,1037 @@
 * Test output: rt_data_3
 *   Purpose: initialize global runtime data and fill contents;
 *            copy to local block and back
 
 * Init global data
 
 * Init and modify local data
 
  model associated   = T
  library associated = T
 
 ========================================================================
  Runtime data:
 ========================================================================
 gy =>  1.000000000000E+00
 ms =>  1.500000000000E+02
 ff =>  1.500000000000E+00
 mf* =>  2.250000000000E+02
 particle* = PDG(0)
 SCALAR* = PDG(25)
 s* = PDG(25)
 FERMION* = PDG(6)
 f* = PDG(6)
 fbar* = PDG(-6)
 F* = PDG(-6)
 charged* = PDG(6, -6)
 neutral* = PDG(25)
 colored* = PDG(6, -6)
 $model_name = "Test"
 $fc => "Local compiler"
 $fcflags => "Fortran-flags"
 $integration_method = "midpoint"
 $phs_method = "single"
 $library_name = "library_2"
 sqrts =  1.000000000000E+03
 luminosity =  3.300000000000E+01
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "Test"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "library_1"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = "run1"
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
 model "Test"
  ! md5sum = 'DB28187ADA60804A3CFC14A025DED784'
 
    parameter gy =  1.000000000000E+00
    parameter ms =  1.500000000000E+02
    parameter ff =  1.500000000000E+00
    external mf =  2.250000000000E+02
 
    particle SCALAR 25
      name "s"
      spin 0
      mass ms
    particle FERMION 6
      name "f"
      anti "fbar" "F"
      tex_anti "\bar{f}"
      spin 1/2  isospin 1/2  charge 2/3  color 3
      mass mf
 
    vertex "fbar" "f" "s"
    vertex "s" "s" "s"
 ========================================================================
  Process library stack:
 ------------------------------------------------------------------------
  Process library: library_2
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ------------------------------------------------------------------------
  Process library: library_1
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ========================================================================
  Beam structure: s, s => pdf_builtin
 ========================================================================
  Cuts:
 ------------------------------------------------------------------------
 +  SEQUENCE    <lexpr>  =  <lsinglet>
 +  SEQUENCE    <lsinglet>  =  <lterm>
 |  +  SEQUENCE    <lterm>  =  <all_fun>
 |  |  +  SEQUENCE    <all_fun>  =  all <lexpr> <pargs1>
 |  |  |  +  KEYWORD     all  = [keyword] all
 |  |  |  +  SEQUENCE    <lexpr>  =  <lsinglet>
 |  |  |  |  +  SEQUENCE    <lsinglet>  =  <lterm>
 |  |  |  |  |  +  SEQUENCE    <lterm>  =  <compared_expr>
 |  |  |  |  |  |  +  SEQUENCE    <compared_expr>  =  <expr> <comparison>
 |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <variable>
 |  |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = Pt
 |  |  |  |  |  |  |  +  SEQUENCE    <comparison>  =  '>' <expr>
 |  |  |  |  |  |  |  |  +  KEYWORD     '>'  = [keyword] >
 |  |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <integer_value>
 |  |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <integer_value>  =  <integer_literal>
 |  |  |  |  |  |  |  |  |  |  |  |  +  INTEGER     <integer_literal>  = 100
 |  |  |  +  ARGUMENTS   <pargs1>  =  <pexpr>
 |  |  |  |  +  SEQUENCE    <pexpr>  =  <pterm>
 |  |  |  |  |  +  SEQUENCE    <pterm>  =  <pexpr_src>
 |  |  |  |  |  |  +  SEQUENCE    <pexpr_src>  =  <unspecified_prt>
 |  |  |  |  |  |  |  +  SEQUENCE    <unspecified_prt>  =  <cexpr>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <cexpr>  =  <variable>
 |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = s
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event sample formats = foo_fmt, bar_fmt
 ------------------------------------------------------------------------
  Event callback: NOP
 ========================================================================
  Process stack: [empty]
 ========================================================================
  [Processes from context environment:]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : ''
 ========================================================================
 
 * Restore global data
 
  model associated   = T
  library associated = T
 
 ========================================================================
  Runtime data:
 ========================================================================
 gy =>  1.000000000000E+00
 ms =>  1.250000000000E+02
 ff =>  1.500000000000E+00
 mf* =>  1.875000000000E+02
 particle* = PDG(0)
 SCALAR* = PDG(25)
 s* = PDG(25)
 FERMION* = PDG(6)
 f* = PDG(6)
 fbar* = PDG(-6)
 F* = PDG(-6)
 charged* = PDG(6, -6)
 neutral* = PDG(25)
 colored* = PDG(6, -6)
 sqrts =  1.000000000000E+03
 luminosity =  3.300000000000E+01
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => false
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "Test"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "library_1"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = 307
 real_precision* = 15
 real_epsilon* =  1.000000000000E-16
 real_tiny* =  1.000000000000-300
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = "run1"
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp = false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = true
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 ========================================================================
 model "Test"
  ! md5sum = 'DB28187ADA60804A3CFC14A025DED784'
 
    parameter gy =  1.000000000000E+00
    parameter ms =  1.250000000000E+02
    parameter ff =  1.500000000000E+00
    external mf =  1.875000000000E+02
 
    particle SCALAR 25
      name "s"
      spin 0
      mass ms
    particle FERMION 6
      name "f"
      anti "fbar" "F"
      tex_anti "\bar{f}"
      spin 1/2  isospin 1/2  charge 2/3  color 3
      mass mf
 
    vertex "fbar" "f" "s"
    vertex "s" "s" "s"
 ========================================================================
  Process library stack:
 ------------------------------------------------------------------------
  Process library: library_2
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ------------------------------------------------------------------------
  Process library: library_1
    external        = F
    makefile exists = F
    driver exists   = F
    code status     = o
 
  Process definition list: [empty]
 ========================================================================
  Beam structure: s, s => pdf_builtin
 ========================================================================
  Cuts:
 ------------------------------------------------------------------------
 +  SEQUENCE    <lexpr>  =  <lsinglet>
 +  SEQUENCE    <lsinglet>  =  <lterm>
 |  +  SEQUENCE    <lterm>  =  <all_fun>
 |  |  +  SEQUENCE    <all_fun>  =  all <lexpr> <pargs1>
 |  |  |  +  KEYWORD     all  = [keyword] all
 |  |  |  +  SEQUENCE    <lexpr>  =  <lsinglet>
 |  |  |  |  +  SEQUENCE    <lsinglet>  =  <lterm>
 |  |  |  |  |  +  SEQUENCE    <lterm>  =  <compared_expr>
 |  |  |  |  |  |  +  SEQUENCE    <compared_expr>  =  <expr> <comparison>
 |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <variable>
 |  |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = Pt
 |  |  |  |  |  |  |  +  SEQUENCE    <comparison>  =  '>' <expr>
 |  |  |  |  |  |  |  |  +  KEYWORD     '>'  = [keyword] >
 |  |  |  |  |  |  |  |  +  SEQUENCE    <expr>  =  <term>
 |  |  |  |  |  |  |  |  |  +  SEQUENCE    <term>  =  <factor>
 |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <factor>  =  <integer_value>
 |  |  |  |  |  |  |  |  |  |  |  +  SEQUENCE    <integer_value>  =  <integer_literal>
 |  |  |  |  |  |  |  |  |  |  |  |  +  INTEGER     <integer_literal>  = 100
 |  |  |  +  ARGUMENTS   <pargs1>  =  <pexpr>
 |  |  |  |  +  SEQUENCE    <pexpr>  =  <pterm>
 |  |  |  |  |  +  SEQUENCE    <pterm>  =  <pexpr_src>
 |  |  |  |  |  |  +  SEQUENCE    <pexpr_src>  =  <unspecified_prt>
 |  |  |  |  |  |  |  +  SEQUENCE    <unspecified_prt>  =  <cexpr>
 |  |  |  |  |  |  |  |  +  SEQUENCE    <cexpr>  =  <variable>
 |  |  |  |  |  |  |  |  |  +  IDENTIFIER  <variable>  = s
 ------------------------------------------------------------------------
  Scale: [undefined]
 ------------------------------------------------------------------------
  Factorization scale: [undefined]
 ------------------------------------------------------------------------
  Renormalization scale: [undefined]
 ------------------------------------------------------------------------
  Weight: [undefined]
 ========================================================================
  Event selection: [undefined]
 ------------------------------------------------------------------------
  Event reweighting factor: [undefined]
 ------------------------------------------------------------------------
  Event analysis: [undefined]
 ------------------------------------------------------------------------
  Event sample formats = foo_fmt, bar_fmt
 ------------------------------------------------------------------------
  Event callback: [undefined]
 ========================================================================
  Process stack: [empty]
 ========================================================================
  quit     : F
  quit_code: 0
 ========================================================================
  Logfile  : ''
 ========================================================================
 
 * Cleanup
 
 * Test output end: rt_data_3
Index: trunk/share/tests/functional_tests/ref-output/show_4.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output/show_4.ref	(revision 8441)
+++ trunk/share/tests/functional_tests/ref-output/show_4.ref	(revision 8442)
@@ -1,1166 +1,1169 @@
 ?openmp_logging = false
 [user variable] foo = PDG(11, 13, 15)
 [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00)
 #####################################################
 QED.ee =>  3.028600000000E-01
 QED.me =>  5.110000000000E-04
 QED.mmu =>  1.057000000000E-01
 QED.mtau =>  1.777000000000E+00
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 [undefined] circe1_sqrts = [unknown real]
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 lambda_qcd =  2.000000000000E-01
 helicity_selection_threshold =  1.000000000000E+10
 safety_factor =  1.000000000000E+00
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 tolerance =  0.000000000000E+00
 real_epsilon* = <real_epsilon>
 real_tiny* = <real_tiny>
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_fixed_alphas =  0.000000000000E+00
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 blha_top_yukawa = -1.000000000000E+00
 ellis_sexton_scale = -1.000000000000E+00
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 real_partition_scale =  1.000000000000E+01
 #####################################################
 QED.charged* = PDG(11, 13, 15, -11, -13, -15)
 #####################################################
 [user variable] foo = PDG(11, 13, 15)
 #####################################################
 [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00)
 #####################################################
 $sf_trace_file = ""
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 $pdf_builtin_set = "CTEQ6L"
 $isr_handler_mode = "trivial"
 $epa_mode = "default"
 $epa_handler_mode = "trivial"
 $circe1_acc = "SBAND"
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 [undefined] $beam_events_file = [unknown string]
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 $model_name = "QED"
 $method = "omega"
 $restrictions = ""
 $omega_flags = ""
 $library_name = "show_4_lib"
 $rng_method = "tao"
 $event_file_version = ""
 $polarization_mode = "helicity"
 $out_file = ""
 $integration_method = "vamp"
 $run_id = ""
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 $phs_file = ""
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 $sample = ""
 $sample_normalization = "auto"
 $rescan_input_format = "raw"
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 $dump_extension = "pset.dat"
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 $shower_method = "WHIZARD"
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 $hadronization_method = "PYTHIA6"
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 $blha_ew_scheme = "alpha_internal"
 $openloops_extra_cmd = ""
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 $gosam_fc = ""
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 #####################################################
 ?sf_trace = false
 ?sf_allow_s_mapping = true
 ?hoppet_b_matching = false
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 ?isr_handler_keep_mass = true
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 ?circe1_generate = true
 ?circe1_map = true
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => true
 ?proc_as_run_id = true
 ?report_progress = true
 [user variable] ?me_verbose = false
 ?omega_write_phs_output = false
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 ?unweighted = true
 ?negative_weights = false
 ?resonance_history = false
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 ?polarized_events = false
 ?colorize_subevt = false
 ?pacify = false
 ?out_advance = true
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 ?integration_timer = true
 ?check_grid_file = true
 ?vis_channels = false
 ?check_phs_file = true
 ?phs_only = false
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 ?normalize_bins = false
 ?y_log = false
 ?x_log = false
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 ?analysis_file_only = false
 ?keep_flavors_when_clustering = false
 ?sample_pacify = false
 ?sample_select = true
 ?read_raw = true
 ?write_raw = true
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 ?hepmc_output_cross_section = false
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 ?shower_verbose = false
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 ?openmp_logging = false
 ?mpi_logging = false
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 ?virtual_collinear_resonance_aware = true
 ?openloops_use_cms = true
 ?openloops_switch_off_muon_yukawa = false
 ?disable_subtraction = false
 ?vis_fks_regions = false
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 #####################################################
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => true
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "QED"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "show_4_lib"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = <real_range>
 real_precision* = <real_precision>
 real_epsilon* = <real_epsilon>
 real_tiny* = <real_tiny>
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = false
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 #####################################################
 QED.ee =>  3.028600000000E-01
 QED.me =>  5.110000000000E-04
 QED.mmu =>  1.057000000000E-01
 QED.mtau =>  1.777000000000E+00
 QED.particle* = PDG(0)
 QED.E_LEPTON* = PDG(11)
 QED.e-* = PDG(11)
 QED.e1* = PDG(11)
 QED.e+* = PDG(-11)
 QED.E1* = PDG(-11)
 QED.MU_LEPTON* = PDG(13)
 QED.m-* = PDG(13)
 QED.e2* = PDG(13)
 QED.mu-* = PDG(13)
 QED.m+* = PDG(-13)
 QED.E2* = PDG(-13)
 QED.mu+* = PDG(-13)
 QED.TAU_LEPTON* = PDG(15)
 QED.t-* = PDG(15)
 QED.e3* = PDG(15)
 QED.ta-* = PDG(15)
 QED.tau-* = PDG(15)
 QED.t+* = PDG(-15)
 QED.E3* = PDG(-15)
 QED.ta+* = PDG(-15)
 QED.tau+* = PDG(-15)
 QED.PHOTON* = PDG(22)
 QED.A* = PDG(22)
 QED.gamma* = PDG(22)
 QED.photon* = PDG(22)
 QED.charged* = PDG(11, 13, 15, -11, -13, -15)
 QED.neutral* = PDG(22)
 QED.colored* = PDG()
 [undefined] sqrts = [unknown real]
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging => true
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "QED"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "show_4_lib"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range* = <real_range>
 real_precision* = <real_precision>
 real_epsilon* = <real_epsilon>
 real_tiny* = <real_tiny>
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "default"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm* = 0
 cambridge_algorithm* = 1
 antikt_algorithm* = 2
 genkt_algorithm* = 3
 cambridge_for_passive_algorithm* = 11
 genkt_for_passive_algorithm* = 13
 ee_kt_algorithm* = 50
 ee_genkt_algorithm* = 53
 plugin_algorithm* = 99
 undefined_jet_algorithm* = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active* = false
 openmp_num_threads_default* = 1
 openmp_num_threads = 1
 ?openmp_logging = false
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 [user variable] foo = PDG(11, 13, 15)
 [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00)
 | WHIZARD run finished.
 |=============================================================================|
Index: trunk/share/tests/functional_tests/ref-output/process_log.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output/process_log.ref	(revision 8441)
+++ trunk/share/tests/functional_tests/ref-output/process_log.ref	(revision 8442)
@@ -1,551 +1,552 @@
 ###############################################################################
  Process [scattering]: 'process_log_1_p1'
    Run ID        = ''
    Library name  = 'process_log_lib'
    Process index = 1
    Process components:
      1: 'process_log_1_p1_i1':   e-, e+ => m-, m+ [omega]
 ------------------------------------------------------------------------
 ###############################################################################
    Integral   =  8.3556567814E+03
    Error      =  3.2359019246E+00
    Accuracy   =  1.8972317270E-02
    Chi2       =  5.2032955661E-01
    Efficiency =  7.8315602603E-01
    T(10k evt) =  <time estimate>
 |=============================================================================|
 | It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
 |=============================================================================|
    1        800  8.3525258E+03  6.97E+00    0.08    0.02*  67.98
    2        800  8.3688100E+03  5.46E+00    0.07    0.02*  59.78
    3        800  8.3686236E+03  5.53E+00    0.07    0.02   78.45
 |-----------------------------------------------------------------------------|
    3       2400  8.3648733E+03  3.39E+00    0.04    0.02   78.45    2.06   3
 |-----------------------------------------------------------------------------|
    4        800  8.3602554E+03  5.63E+00    0.07    0.02   78.37
    5        800  8.3525628E+03  5.62E+00    0.07    0.02   78.30
    6        800  8.3541861E+03  5.56E+00    0.07    0.02*  78.32
 |-----------------------------------------------------------------------------|
    6       2400  8.3556568E+03  3.24E+00    0.04    0.02   78.32    0.52   3
 |=============================================================================|
 ###############################################################################
 | Phase-space chain (grove) weight history: (numbers in %)
 | chain |   1
 |=============================================================================|
       1 | 100
       2 | 100
       3 | 100
 |-----------------------------------------------------------------------------|
       4 | 100
       5 | 100
       6 | 100
 |=============================================================================|
 ###############################################################################
  Call statistics (current run):
    total       = 2400
    failed kin. = 0
    failed cuts = 0
    passed cuts = 0
    evaluated   = 2400
 ###############################################################################
  MC Integrator is VAMP
 ------------------------------------------------------------------------
  VAMP history (global):
  Pass #1:
  ------------------------------------------------------------------------------
  [vamp]   it   #calls     integral                 average           chi2  eff.
  [vamp]    1      800*  0.0000E+00(0.00E+00)  8.352526E+03(6.97E+00)  0.0 0.000
  [vamp]    2      800*  0.0000E+00(0.00E+00)  8.368810E+03(5.46E+00)  0.0 0.000
  [vamp]    3      800*  0.0000E+00(0.00E+00)  8.368624E+03(5.53E+00)  0.0 0.000
  ------------------------------------------------------------------------------
  Channel histories: [undefined]
  Pass #2:
  ------------------------------------------------------------------------------
  [vamp]   it   #calls     integral                 average           chi2  eff.
  [vamp]    1      800*  0.0000E+00(0.00E+00)  8.360255E+03(5.63E+00)  0.0 0.000
  [vamp]    2      800*  0.0000E+00(0.00E+00)  8.352563E+03(5.62E+00)  0.0 0.000
  [vamp]    3      800*  0.0000E+00(0.00E+00)  8.354186E+03(5.56E+00)  0.0 0.000
  ------------------------------------------------------------------------------
  Channel histories: [undefined]
 ------------------------------------------------------------------------
  Inequivalent channels:
    Channel 1:    Mult. = 1    Symm. = 1    Invar.: TF
  Equivalence list:
    Equivalent channels: 1 1
      Permutation: 1 2
      Mode:        3 0
 ------------------------------------------------------------------------
  Weights of channel chains (groves):
    1 1.0000000000
 ###############################################################################
  Beam data (collision):
    e-  (mass = 0.0000000E+00 GeV)
    e+  (mass = 0.0000000E+00 GeV)
    sqrts = 1.000000000000E+02 GeV
 ###############################################################################
    No cuts used.
 ------------------------------------------------------------------------
    No scale expression was given.
 ------------------------------------------------------------------------
    No factorization scale expression was given.
 ------------------------------------------------------------------------
    No renormalization scale expression was given.
 ------------------------------------------------------------------------
    No weight expression was given.
 ###############################################################################
  Summary of quantum-number states:
   + sign: allowed and contributing
   no +  : switched off at runtime
 ------------------------------------------------------------------------
  Term #1
    1  [f(11) h(-1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(-1)]
    2  [f(11) h(-1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(1)]
    3  [f(11) h(-1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(-1)]
    4  [f(11) h(-1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(1)]
  + 5  [f(11) h(-1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(-1)]
  + 6  [f(11) h(-1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(1)]
  + 7  [f(11) h(-1) / f(-11) h(1) / f(13) h(1) / f(-13) h(-1)]
  + 8  [f(11) h(-1) / f(-11) h(1) / f(13) h(1) / f(-13) h(1)]
  + 9  [f(11) h(1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(-1)]
  + 10  [f(11) h(1) / f(-11) h(-1) / f(13) h(-1) / f(-13) h(1)]
  + 11  [f(11) h(1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(-1)]
  + 12  [f(11) h(1) / f(-11) h(-1) / f(13) h(1) / f(-13) h(1)]
    13  [f(11) h(1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(-1)]
    14  [f(11) h(1) / f(-11) h(1) / f(13) h(-1) / f(-13) h(1)]
    15  [f(11) h(1) / f(-11) h(1) / f(13) h(1) / f(-13) h(-1)]
    16  [f(11) h(1) / f(-11) h(1) / f(13) h(1) / f(-13) h(1)]
 ###############################################################################
  Variable list:
 ------------------------------------------------------------------------
 ee =  3.000000000000E-01
 me =  0.000000000000E+00
 mmu =  1.000000000000E+01
 mtau =  1.777000000000E+00
 particle = PDG(0)
 E_LEPTON = PDG(11)
 e- = PDG(11)
 e1 = PDG(11)
 e+ = PDG(-11)
 E1 = PDG(-11)
 MU_LEPTON = PDG(13)
 m- = PDG(13)
 e2 = PDG(13)
 mu- = PDG(13)
 m+ = PDG(-13)
 E2 = PDG(-13)
 mu+ = PDG(-13)
 TAU_LEPTON = PDG(15)
 t- = PDG(15)
 e3 = PDG(15)
 ta- = PDG(15)
 tau- = PDG(15)
 t+ = PDG(-15)
 E3 = PDG(-15)
 ta+ = PDG(-15)
 tau+ = PDG(-15)
 PHOTON = PDG(22)
 A = PDG(22)
 gamma = PDG(22)
 photon = PDG(22)
 charged = PDG(11, 13, 15, -11, -13, -15)
 neutral = PDG(22)
 colored = PDG()
 sqrts =  1.000000000000E+02
 luminosity =  0.000000000000E+00
 ?sf_trace = false
 $sf_trace_file = ""
 ?sf_allow_s_mapping = true
 $lhapdf_dir = ""
 $lhapdf_file = ""
 $lhapdf_photon_file = ""
 lhapdf_member = 0
 lhapdf_photon_scheme = 0
 $pdf_builtin_set = "CTEQ6L"
 ?hoppet_b_matching = false
 isr_alpha =  0.000000000000E+00
 isr_q_max =  0.000000000000E+00
 isr_mass =  0.000000000000E+00
 isr_order = 3
 ?isr_recoil = false
 ?isr_keep_energy = false
 ?isr_handler = false
 $isr_handler_mode = "trivial"
 ?isr_handler_keep_mass = true
 $epa_mode = "default"
 epa_alpha =  0.000000000000E+00
 epa_x_min =  0.000000000000E+00
 epa_q_min =  0.000000000000E+00
 epa_q_max =  0.000000000000E+00
 epa_mass =  0.000000000000E+00
 ?epa_recoil = false
 ?epa_keep_energy = false
 ?epa_handler = false
 $epa_handler_mode = "trivial"
 ewa_x_min =  0.000000000000E+00
 ewa_pt_max =  0.000000000000E+00
 ewa_mass =  0.000000000000E+00
 ?ewa_recoil = false
 ?ewa_keep_energy = false
 ?circe1_photon1 = false
 ?circe1_photon2 = false
 [undefined] circe1_sqrts = [unknown real]
 ?circe1_generate = true
 ?circe1_map = true
 circe1_mapping_slope =  2.000000000000E+00
 circe1_eps =  1.000000000000E-05
 circe1_ver = 0
 circe1_rev = 0
 $circe1_acc = "SBAND"
 circe1_chat = 0
 ?circe1_with_radiation = false
 ?circe2_polarized = true
 [undefined] $circe2_file = [unknown string]
 $circe2_design = "*"
 gaussian_spread1 =  0.000000000000E+00
 gaussian_spread2 =  0.000000000000E+00
 [undefined] $beam_events_file = [unknown string]
 ?beam_events_warn_eof = true
 ?energy_scan_normalize = false
 ?logging = true
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 seed = 0
 $model_name = "QED"
 [undefined] process_num_id = [unknown integer]
 ?proc_as_run_id = true
 lcio_run_id = 0
 $method = "omega"
 ?report_progress = true
 [user variable] ?me_verbose = false
 $restrictions = ""
 ?omega_write_phs_output = false
 $omega_flags = ""
 ?read_color_factors = true
 ?slha_read_input = true
 ?slha_read_spectrum = true
 ?slha_read_decays = false
 $library_name = "process_log_lib"
 ?alphas_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
 alphas_order = 0
 alphas_nf = 5
 ?alphas_from_mz = false
 ?alphas_from_lambda_qcd = false
 lambda_qcd =  2.000000000000E-01
 ?fatal_beam_decay = true
 ?helicity_selection_active = true
 helicity_selection_threshold =  1.000000000000E+10
 helicity_selection_cutoff = 1000
 $rng_method = "tao"
 ?vis_diags = false
 ?vis_diags_color = false
 ?check_event_file = true
 $event_file_version = ""
 n_events = 0
 event_index_offset = 0
 ?unweighted = true
 safety_factor =  1.000000000000E+00
 ?negative_weights = false
 ?resonance_history = false
 resonance_on_shell_limit =  4.000000000000E+00
 resonance_on_shell_turnoff =  0.000000000000E+00
 resonance_background_factor =  1.000000000000E+00
 ?keep_beams = false
 ?keep_remnants = true
 ?recover_beams = true
 ?update_event = false
 ?update_sqme = false
 ?update_weight = false
 ?use_alphas_from_file = false
 ?use_scale_from_file = false
 ?allow_decays = true
 ?auto_decays = false
 auto_decays_multiplicity = 2
 ?auto_decays_radiative = false
 ?decay_rest_frame = false
 ?isotropic_decay = false
 ?diagonal_decay = false
 [undefined] decay_helicity = [unknown integer]
 ?polarized_events = false
 $polarization_mode = "helicity"
 ?colorize_subevt = false
 tolerance =  0.000000000000E+00
 checkpoint = 0
 event_callback_interval = 0
 ?pacify = false
 $out_file = ""
 ?out_advance = true
 real_range = <real_range>
 real_precision = <real_precision>
 real_epsilon = <real_epsilon>
 real_tiny = <real_tiny>
 $integration_method = "vamp"
 threshold_calls = 10
 min_calls_per_channel = 10
 min_calls_per_bin = 10
 min_bins = 3
 max_bins = 20
 ?stratified = true
 ?use_vamp_equivalences = true
 ?vamp_verbose = false
 ?vamp_history_global = true
 ?vamp_history_global_verbose = false
 ?vamp_history_channels = false
 ?vamp_history_channels_verbose = false
 $run_id = ""
 n_calls_test = 0
 ?integration_timer = true
 ?check_grid_file = true
 accuracy_goal =  0.000000000000E+00
 error_goal =  0.000000000000E+00
 relative_error_goal =  0.000000000000E+00
 integration_results_verbosity = 1
 error_threshold =  0.000000000000E+00
 channel_weights_power =  2.500000000000E-01
 [undefined] $integrate_workspace = [unknown string]
 $vamp_grid_format = "ascii"
 $phs_method = "wood"
 ?vis_channels = false
 ?check_phs_file = true
 $phs_file = ""
 ?phs_only = false
 phs_threshold_s =  5.000000000000E+01
 phs_threshold_t =  1.000000000000E+02
 phs_off_shell = 2
 phs_t_channel = 6
 phs_e_scale =  1.000000000000E+01
 phs_m_scale =  1.000000000000E+01
 phs_q_scale =  1.000000000000E+01
 ?phs_keep_nonresonant = true
 ?phs_step_mapping = true
 ?phs_step_mapping_exp = true
 ?phs_s_mapping = true
 ?vis_history = false
 n_bins = 20
 ?normalize_bins = false
 $obs_label = ""
 $obs_unit = ""
 $title = ""
 $description = ""
 $x_label = ""
 $y_label = ""
 graph_width_mm = 130
 graph_height_mm = 90
 ?y_log = false
 ?x_log = false
 [undefined] x_min = [unknown real]
 [undefined] x_max = [unknown real]
 [undefined] y_min = [unknown real]
 [undefined] y_max = [unknown real]
 $gmlcode_bg = ""
 $gmlcode_fg = ""
 [undefined] ?draw_histogram = [unknown logical]
 [undefined] ?draw_base = [unknown logical]
 [undefined] ?draw_piecewise = [unknown logical]
 [undefined] ?fill_curve = [unknown logical]
 [undefined] ?draw_curve = [unknown logical]
 [undefined] ?draw_errors = [unknown logical]
 [undefined] ?draw_symbols = [unknown logical]
 [undefined] $fill_options = [unknown string]
 [undefined] $draw_options = [unknown string]
 [undefined] $err_options = [unknown string]
 [undefined] $symbol = [unknown string]
 ?analysis_file_only = false
 kt_algorithm = 0
 cambridge_algorithm = 1
 antikt_algorithm = 2
 genkt_algorithm = 3
 cambridge_for_passive_algorithm = 11
 genkt_for_passive_algorithm = 13
 ee_kt_algorithm = 50
 ee_genkt_algorithm = 53
 plugin_algorithm = 99
 undefined_jet_algorithm = 999
 jet_algorithm = 999
 jet_r =  0.000000000000E+00
 jet_p =  0.000000000000E+00
 jet_ycut =  0.000000000000E+00
+jet_dcut =  0.000000000000E+00
 ?keep_flavors_when_clustering = false
 photon_iso_eps =  1.000000000000E+00
 photon_iso_n =  1.000000000000E+00
 photon_iso_r0 =  4.000000000000E-01
 $sample = ""
 $sample_normalization = "auto"
 ?sample_pacify = false
 ?sample_select = true
 sample_max_tries = 10000
 sample_split_n_evt = 0
 sample_split_n_kbytes = 0
 sample_split_index = 0
 $rescan_input_format = "raw"
 ?read_raw = true
 ?write_raw = true
 $extension_raw = "evx"
 $extension_default = "evt"
 $debug_extension = "debug"
 ?debug_process = true
 ?debug_transforms = true
 ?debug_decay = true
 ?debug_verbose = true
 $dump_extension = "pset.dat"
 ?dump_compressed = false
 ?dump_weights = false
 ?dump_summary = false
 ?dump_screen = false
 ?hepevt_ensure_order = false
 $extension_hepevt = "hepevt"
 $extension_ascii_short = "short.evt"
 $extension_ascii_long = "long.evt"
 $extension_athena = "athena.evt"
 $extension_mokka = "mokka.evt"
 $lhef_version = "2.0"
 $lhef_extension = "lhe"
 ?lhef_write_sqme_prc = true
 ?lhef_write_sqme_ref = false
 ?lhef_write_sqme_alt = true
 $extension_lha = "lha"
 $extension_hepmc = "hepmc"
 ?hepmc_output_cross_section = false
 $hepmc3_mode = "HepMC3"
 $extension_lcio = "slcio"
 $extension_stdhep = "hep"
 $extension_stdhep_up = "up.hep"
 $extension_stdhep_ev4 = "ev4.hep"
 $extension_hepevt_verb = "hepevt.verb"
 $extension_lha_verb = "lha.verb"
 ?allow_shower = true
 ?ps_fsr_active = false
 ?ps_isr_active = false
 ?ps_taudec_active = false
 ?muli_active = false
 $shower_method = "WHIZARD"
 ?shower_verbose = false
 $ps_PYTHIA_PYGIVE = ""
 $ps_PYTHIA8_config = ""
 $ps_PYTHIA8_config_file = ""
 ps_mass_cutoff =  1.000000000000E+00
 ps_fsr_lambda =  2.900000000000E-01
 ps_isr_lambda =  2.900000000000E-01
 ps_max_n_flavors = 5
 ?ps_isr_alphas_running = true
 ?ps_fsr_alphas_running = true
 ps_fixed_alphas =  0.000000000000E+00
 ?ps_isr_pt_ordered = false
 ?ps_isr_angular_ordered = true
 ps_isr_primordial_kt_width =  0.000000000000E+00
 ps_isr_primordial_kt_cutoff =  5.000000000000E+00
 ps_isr_z_cutoff =  9.990000000000E-01
 ps_isr_minenergy =  1.000000000000E+00
 ps_isr_tscalefactor =  1.000000000000E+00
 ?ps_isr_only_onshell_emitted_partons = false
 ?allow_hadronization = true
 ?hadronization_active = false
 $hadronization_method = "PYTHIA6"
 hadron_enhanced_fraction =  1.000000000000E-02
 hadron_enhanced_width =  2.000000000000E+00
 ?ps_tauola_photos = false
 ?ps_tauola_transverse = false
 ?ps_tauola_dec_rad_cor = true
 ps_tauola_dec_mode1 = 0
 ps_tauola_dec_mode2 = 0
 ps_tauola_mh =  1.250000000000E+02
 ps_tauola_mix_angle =  9.000000000000E+01
 ?ps_tauola_pol_vector = false
 ?mlm_matching = false
 mlm_Qcut_ME =  0.000000000000E+00
 mlm_Qcut_PS =  0.000000000000E+00
 mlm_ptmin =  0.000000000000E+00
 mlm_etamax =  0.000000000000E+00
 mlm_Rmin =  0.000000000000E+00
 mlm_Emin =  0.000000000000E+00
 mlm_nmaxMEjets = 0
 mlm_ETclusfactor =  2.000000000000E-01
 mlm_ETclusminE =  5.000000000000E+00
 mlm_etaclusfactor =  1.000000000000E+00
 mlm_Rclusfactor =  1.000000000000E+00
 mlm_Eclusfactor =  1.000000000000E+00
 ?powheg_matching = false
 ?powheg_use_singular_jacobian = false
 powheg_grid_size_xi = 5
 powheg_grid_size_y = 5
 powheg_grid_sampling_points = 500000
 powheg_pt_min =  1.000000000000E+00
 powheg_lambda =  2.000000000000E-01
 ?powheg_test_sudakov = false
 ?powheg_disable_sudakov = false
 ?ckkw_matching = false
 ?omega_openmp => false
 ?openmp_is_active = false
 openmp_num_threads_default = 1
 openmp_num_threads = 1
 ?openmp_logging = false
 ?mpi_logging = false
 $born_me_method = ""
 $loop_me_method = ""
 $correlation_me_method = ""
 $real_tree_me_method = ""
 $dglap_me_method = ""
 ?test_soft_limit = false
 ?test_coll_limit = false
 ?test_anti_coll_limit = false
 $select_alpha_regions = ""
 $virtual_selection = "Full"
 ?virtual_collinear_resonance_aware = true
 blha_top_yukawa = -1.000000000000E+00
 $blha_ew_scheme = "alpha_internal"
 openloops_verbosity = 1
 ?openloops_use_cms = true
 openloops_phs_tolerance = 7
 openloops_stability_log = 0
 ?openloops_switch_off_muon_yukawa = false
 $openloops_extra_cmd = ""
 ellis_sexton_scale = -1.000000000000E+00
 ?disable_subtraction = false
 fks_dij_exp1 =  1.000000000000E+00
 fks_dij_exp2 =  1.000000000000E+00
 fks_xi_min =  0.000000000000E+00
 fks_y_max =  1.000000000000E+00
 ?vis_fks_regions = false
 fks_xi_cut =  1.000000000000E+00
 fks_delta_o =  2.000000000000E+00
 fks_delta_i =  2.000000000000E+00
 $fks_mapping_type = "default"
 $resonances_exclude_particles = "default"
 alpha_power = 2
 alphas_power = 0
 ?combined_nlo_integration = false
 ?fixed_order_nlo_events = false
 ?check_event_weights_against_xsection = false
 ?keep_failed_events = false
 gks_multiplicity = 0
 $gosam_filter_lo = ""
 $gosam_filter_nlo = ""
 $gosam_symmetries = "family,generation"
 form_threads = 2
 form_workspace = 1000
 $gosam_fc = ""
 mult_call_real =  1.000000000000E+00
 mult_call_virt =  1.000000000000E+00
 mult_call_dglap =  1.000000000000E+00
 $dalitz_plot = ""
 $nlo_correction_type = "QCD"
 $exclude_gauge_splittings = "c:b:t:e2:e3"
 ?nlo_use_born_scale = false
 ?nlo_cut_all_real_sqmes = false
 ?nlo_use_real_partition = false
 real_partition_scale =  1.000000000000E+01
 $fc = Fortran-compiler
 $fcflags = Fortran-flags
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 [undefined] num_id(process_log_1_p1) = [unknown integer]
 [undefined] integral(process_log_1_p1) = [unknown real]
 [undefined] error(process_log_1_p1) = [unknown real]
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
  Beam structure: [any particles]
 ###############################################################################
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog	(revision 8441)
+++ trunk/ChangeLog	(revision 8442)
@@ -1,2095 +1,2100 @@
 ChangeLog -- Summary of changes to the WHIZARD package
 
 Use svn log to see detailed changes.
 
 	Version 3.0.0_beta+
 
+2020-09-01
+	Support exclusive jet clustering in ee for Fastjet interface
+
+##################################################################
+
 2020-08-30
 	RELEASE: version 3.0.0_beta
 
 2020-08-27
 	Major revision of NLO distributions and events for
 	   processes with structure functions:
 	- Use parton momenta/flavors (instead of beams) for events
 	- Bug fix for Lorentz boosts and Lorentz frames of momenta
 	- Bug fix: apply cuts to virtual NLO component in correct frame
 	- Correctly assign ISR radiation momenta in data structures
 	- Refactoring on quantum numbers for NLO event data structures
 	- Functional tests for hadron collider NLO distributions
 	- many minor bug fixes regarding NLO hadron collider physics
 
 2020-08-11
 	Bug fix for linking problem with OpenMPI
 
 2020-08-07
 	New WHIZARD API: WHIZARD can be externally linked as a
 	  library, added examples for Fortran, C, C++ programs
 
 ##################################################################
 
 2020-07-08
 	RELEASE: version 2.8.4
 
 2020-07-07
 	Bug fix: steering of UFO Majorana models from WHIZARD
 
 ##################################################################
 
 2020-07-06
 	Combined integration also for hadron collider processes at NLO
 
 2020-07-05
 	Bug fix: correctly steer e+e- FastJet clustering algorithms
 	Major revision of NLO differential distributions and events:
 	- Correctly assign quantum numbers to NLO fixed-order events
 	- Correctly assign weights to NLO fixed-order events for
 	     combined simulation
 	- Cut all NLO fixed-order subevents in event groups individually
 	- Only allow "sigma" normalization for NLO fixed-order events
 	- Use correct PDF setup for NLO counter events
 	- Several technical fixes and updates of the NLO testsuite
 
 ##################################################################
 
 2020-07-03
 	RELEASE: version 2.8.3
 
 2020-07-02
 	Feature-complete UFO implementation for Majorana fermions
 
 2020-06-22
 	Running width scheme supported for O'Mega matrix elements
 
 2020-06-20
 	Adding H-s-s coupling to SM_Higgs(_CKM) models
 
 2020-06-17
 	Completion of ILC 2->6 fermion extended test suite
 
 2020-06-15
 	Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays
 
 2020-06-09
 	Bug fix: correctly update calls for additional VAMP/2 iterations
 	Bug fix: correct assignment for tau spins from PYTHIA6 interface
 
 2020-06-04
 	Bug fix: cascades2 tree merge with empty subtree(s)
 
 2020-05-31
 	Switch $epa_mode for different EPA implementations
 
 2020-05-26
 	Bug fix: spin information transferred for resonance histories
 
 2020-04-13
 	HepMC: correct weighted events for non-xsec event normalizations
 
 2020-04-04
 	Improved HepMC3 interface: HepMC3 Root/RootTree interface
 
 2020-03-24
 	ISR: Fix on-shell kinematics for events with ?isr_handler=true
 	   (set ?isr_handler_keep_mass=false for old behavior)
 
 2020-03-11
 	Beam masses are correctly passed to hard matrix element for CIRCE2
 	EPA with polarized beams: double-counting corrected
 
 ##################################################################
 
 2020-03-03
 	RELEASE: version 3.0.0_alpha
 
 2020-02-25
 	Bug fix: Scale and alphas can be retrieved from internal event format to
 	   external formats
 
 2020-02-17
 	Bug fix: ?keep_failed_events now forces output of actual event data
 	Bug fix: particle-set reconstruction (rescanning events w/o radiation)
 
 2020-01-28
 	Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)
 
 2020-01-23
 	Bug fix for real components of NLO QCD 2->1 processes
 
 2020-01-22
         Bug fix: correct random number sequencing during parallel MPI event
 	   generation with rng_stream
 
 2020-01-21
 	Consistent distribution of events during parallel MPI event generation
 
 2020-01-20
 	Bug fix for configure setup for automake v1.16+
 
 2020-01-18
 	General SLHA parameter files for UFO models supported
 
 2020-01-08
 	Bug fix: correctly register RECOLA processes with flavor sums
 
 2019-12-19
 	Support for UFO customized propagators
 	O'Mega unit tests for fermion-number violating interactions
 
 2019-12-10
 	For distribution building: check for graphviz/dot
 	   version 2.40 or newer
 
 2019-11-21
 	Bug fix: alternate setups now work correctly
 	Infrastructure for accessing alpha_QED event-by-event
 	Guard against tiny numbers that break ASCII event output
 	Enable inverse hyperbolic functions as SINDARIN observables
 	Remove old compiler bug workarounds
 
 2019-11-20
 	Allow quoted -e argument, implemented -f option
 
 2019-11-19
 	Bug fix: resonance histories now work also with UFO models
 	Fix in numerical precision of ASCII VAMP2 grids
 
 2019-11-06
 	Add squared matrix elements to the LCIO event header
 
 2019-11-05
 	Do not include RNG state in MD5 sum for CIRCE1/2
 
 2019-11-04
 	Full CIRCE2 ILC 250 and 500 GeV beam spectra added
 	Minor update on LCIO event header information
 
 2019-10-30
 	NLO QCD for final states completed
 	When using Openloops, v2.1.1+ mandatory
 
 2019-10-25
 	Binary grid files for VAMP2 integrator
 
 ##################################################################
 
 2019-10-24
 	RELEASE: version 2.8.2
 
 2019-10-20
 	Bug fix for HepMC linker flags
 
 2019-10-19
 	Support for spin-2 particles from UFO files
 
 2019-09-27
 	LCIO event format allows rescan and alternate weights
 
 2019-09-24
 	Compatibility fix for OCaml v4.08.0+
 
 ##################################################################
 
 2019-09-21
 	RELEASE: version 2.8.1
 
 2019-09-19
 	Carriage return characters in UFO models can be parsed
 	Mathematica symbols in UFO models possible
 	Unused/undefined parameters in UFO models handled
 
 2019-09-13
 	New extended NLO test suite for ee and pp processes
 
 2019-09-09
 	Photon isolation (separation of perturbative and fragmentation
 	   part a la Frixione)
 
 2019-09-05
 	Major progress on NLO QCD for hadron collisions:
 	- correctly assign flavor structures for alpha regions
 	- fix crossing of particles for initial state splittings
 	- correct assignment for PDF factors for real subtractions
 	- fix kinematics for collinear splittings
 	- bug fix for integrated virtual subtraction terms
 
 2019-09-03
 	b and c jet selection in cuts and analysis
 
 2019-08-27
 	Support for Intel MPI
 
 2019-08-20
 	Complete (preliminary) HepMC3 support (incl.
 	   backwards HepMC2 write/read mode)
 
 2019-08-08
 	Bug fix: handle carriage returns in UFO files (non-Unix OS)
 
 ##################################################################
 
 2019-08-07
 	RELEASE: version 2.8.0
 
 2019-07-31
 	Complete WHIZARD UFO interface:
 	- general Lorentz structures
 	- matrix element support for general color factors
 	- missing features: Majorana fermions and SLHA
 
 2019-07-20
 	Make WHIZARD compatible with OCaml 4.08.0+
 
 2019-07-19
 	Fix version testing for LHAPDF 6.2.3 and newer
 	Minimal required OCaml version is now 4.02.3.
 
 2019-04-18
 	Correctly generate ordered FKS tuples for alpha regions
 	   from all possible underlying Born processes
 
 2019-04-08
 	Extended O'Mega/Recola matrix element test suite
 
 2019-03-29
 	Correct identical particle symmetry factors for FKS subtraction
 
 2019-03-28
 	Correct assertion of spin-correlated matrix
 	   elements for hadron collisions
 
 2019-03-27
 	Bug fix for cut-off parameter delta_i for
 	   collinear plus/minus regions
 
 ##################################################################
 
 2019-03-27
 	RELEASE: version 2.7.1
 
 2019-02-19
 	Further infrastructure for HepMC3 interface (v3.01.00)
 
 2019-02-07
 	Explicit configure option for using debugging options
 	Bug fix for performance by removing unnecessary debug operations
 
 2019-01-29
 	Bug fix for DGLAP remnants with cut-off parameter delta_i
 
 2019-01-24
 	Radiative decay neu2 -> neu1 A added to MSSM_Hgg model
 
 ##################################################################
 
 2019-01-21
 	RELEASE: version 2.7.0
 
 2018-12-18
 	Support RECOLA for integrated und unintegrated subtractions
 
 2018-12-11
 	FCNC top-up sector in model SM_top_anom
 
 2018-12-05
 	Use libtirpc instead of SunRPC on Arch Linux etc.
 
 2018-11-30
 	Display rescaling factor for weighted event samples with cuts
 
 2018-11-29
 	Reintroduce check against different masses in flavor sums
 	Bug fix for wrong couplings in the Littlest Higgs model(s)
 
 2018-11-22
 	Bug fix for rescanning events with beam structure
 
 2018-11-09
 	Major refactoring of internal process data
 
 2018-11-02
 	PYTHIA8 interface
 
 2018-10-29
         Flat phase space parametrization with RAMBO (on diet) implemented
 
 2018-10-17
 	Revise extended test suite
 
 2018-09-27
 	Process container for RECOLA processes
 
 2018-09-15
 	Fixes by M. Berggren for PYTHIA6 interface
 
 2018-09-14
 	First fixes after HepForge modernization
 
 ##################################################################
 
 2018-08-23
 	RELEASE: version 2.6.4
 
 2018-08-09
 	Infrastructure to check colored subevents
 
 2018-07-10
 	Infrastructure for running WHIZARD in batch mode
 
 2018-07-04
 	MPI available from distribution tarball
 
 2018-06-03
 	Support Intel Fortran Compiler under MAC OS X
 
 2018-05-07
 	FKS slicing parameter delta_i (initial state) implementend
 
 2018-05-03
 	Refactor structure function assignment for NLO
 
 2018-05-02
 	FKS slicing parameter xi_cut, delta_0 implemented
 
 2018-04-20
 	Workspace subdirectory for process integration (grid/phs files)
 	Packing/unpacking of files at job end/start
 	Exporting integration results from scan loops
 
 2018-04-13
 	Extended QCD NLO test suite
 
 2018-04-09
 	Bug fix for Higgs Singlet Extension model
 
 2018-04-06
 	Workspace subdirectory for process generation and compilation
 	--job-id option for creating job-specific names
 
 2018-03-20
 	Bug fix for color flow matching in hadron collisions
 	   with identical initial state quarks
 
 2018-03-08
 	Structure functions quantum numbers correctly assigned for NLO
 
 2018-02-24
 	Configure setup includes 'pgfortran' and 'flang'
 
 2018-02-21
 	Include spin-correlated matrix elements in interactions
 
 2018-02-15
 	Separate module for QED ISR structure functions
 
 ##################################################################
 
 2018-02-10
 	RELEASE: version 2.6.3
 
 2018-02-08
 	Improvements in memory management for PS generation
 
 2018-01-31
 	Partial refactoring: quantum number assigment NLO
 	Initial-state QCD splittings for hadron collisions
 
 2018-01-25
 	Bug fix for weighted events with VAMP2
 
 2018-01-17
 	Generalized interface for Recola versions 1.3+  and 2.1+
 
 2018-01-15
 	Channel equivalences also for VAMP2 integrator
 
 2018-01-12
 	Fix for OCaml compiler 4.06 (and newer)
 
 2017-12-19
 	RECOLA matrix elements with flavor sums can be integrated
 
 2017-12-18
 	Bug fix for segmentation fault in empty resonance histories
 
 2017-12-16
 	Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
 	  from transferral between PYTHIA and WHIZARD event records
 
 2017-12-15
 	Event index for multiple processes in event file correct
 
 ##################################################################
 
 2017-12-13
 	RELEASE: version 2.6.2
 
 2017-12-07
 	User can set offset in event numbers
 
 2017-11-29
 	Possibility to have more than one RECOLA process in one file
 
 2017-11-23
 	Transversal/mixed (and unitarized) dim-8 operators
 
 2017-11-16
 	epa_q_max replaces epa_e_max (trivial factor 2)
 
 2017-11-15
 	O'Mega matrix element compilation silent now
 
 2017-11-14
 	Complete expanded P-wave form factor for top threshold
 
 2017-11-10
 	Incoming particles can be accessed in SINDARIN
 
 2017-11-08
 	Improved handling of resonance insertion, additional parameters
 
 2017-11-04
 	Added Higgs-electron coupling (SM_Higgs)
 
 ##################################################################
 
 2017-11-03
 	RELEASE: version 2.6.1
 
 2017-10-20
 	More than 5 NLO components possible at same time
 
 2017-10-19
 	Gaussian cutoff for shower resonance matching
 
 2017-10-12
 	Alternative (more efficient) method to generate
 	   phase space file
 
 2017-10-11
 	Bug fix for shower resonance histories for processes
 	   with multiple components
 
 2017-09-25
 	Bug fix for process libraries in shower resonance histories
 
 2017-09-21
 	Correctly generate pT distribution for EPA remnants
 
 2017-09-20
 	Set branching ratios for unstable particles also by hand
 
 2017-09-14
 	Correctly generate pT distribution for ISR photons
 
 ##################################################################
 
 2017-09-08
 	RELEASE: version 2.6.0
 
 2017-09-05
 	Bug fix for initial state NLO QCD flavor structures
 	Real and virtual NLO QCD hadron collider processes
 	   work with internal interactions
 
 2017-09-04
 	Fully validated MPI integration and event generation
 
 2017-09-01
 	Resonance histories for shower: full support
 	Bug fix in O'Mega model constraints
 	O'Mega allows to output a parsable form of the DAG
 
 2017-08-24
 	Resonance histories in events for transferral
 	   to parton shower (e.g. in ee -> jjjj)
 
 2017-08-01
 	Alpha version of HepMC v3 interface
 	   (not yet really functional)
 
 2017-07-31
 	Beta version for RECOLA OLP support
 
 2017-07-06
 	Radiation generator fix for LHC processes
 
 2017-06-30
 	Fix bug for NLO with structure
 	   functions and/or polarization
 
 2017-06-23
 	Collinear limit for QED corrections works
 
 2017-06-17
 	POWHEG grids generated already during integration
 
 2017-06-12
 	Soft limit for QED corrections works
 
 2017-05-16
 	Beta version of full MPI parallelization (VAMP2)
 	Check consistency of POWHEG grid files
 	Logfile config-summary.log for configure summary
 
 2017-05-12
 	Allow polarization in top threshold
 
 2017-05-09
 	Minimal demand automake 1.12.2
 	Silent rules for make procedures
 
 2017-05-07
 	Major fix for POWHEG damping
 	Correctly initialize FKS ISR phasespace
 
 ##################################################################
 
 2017-05-06
 	RELEASE: version 2.5.0
 
 2017-05-05
 	Full UFO support (SM-like models)
 	Fixed-beam ISR FKS phase space
 
 2017-04-26
 	QED splittings in radiation generator
 
 2017-04-10
 	Retire deprecated O'Mega vertex cache files
 
 ##################################################################
 
 2017-03-24
 	RELEASE: version 2.4.1
 
 2017-03-16
 	Distinguish resonance charge in phase space channels
 	Keep track of resonance histories in phase space
 	Complex mass scheme default for OpenLoops amplitudes
 
 2017-03-13
 	Fix helicities for polarized OpenLoops calculations
 
 2017-03-09
 	Possibility to advance RNG state in rng_stream
 
 2017-03-04
 	General setup for partitioning real emission
 	   phase space
 
 2017-03-06
 	Bug fix on rescan command for converting event files
 
 2017-02-27
 	Alternative multi-channel VEGAS implementation
 	   VAMP2: serial backbone for MPI setup
 	Smoothstep top threshold matching
 
 2017-02-25
 	Single-beam structure function with
 	   s-channel mapping supported
 	Safeguard against invalid process libraries
 
 2017-02-16
 	Radiation generator for photon emission
 
 2017-02-10
 	Fixes for NLO QCD processes (color correlations)
 
 2017-01-16
 	LCIO variable takes precedence over LCIO_DIR
 
 2017-01-13
 	Alternative random number generator
 	   rng_stream (cf. L'Ecuyer et al.)
 
 2017-01-01
 	Fix for multi-flavor BLHA tree
 	   matrix elements
 
 2016-12-31
 	Grid path option for VAMP grids
 
 2016-12-28
 	Alpha version of Recola OLP support
 
 2016-12-27
 	Dalitz plots for FKS phase space
 
 2016-12-14
 	NLO multi-flavor events possible
 
 2016-12-09
 	LCIO event header information added
 
 2016-12-02
 	Alpha version of RECOLA interface
 	Bug fix for generator status in LCIO
 
 ##################################################################
 
 2016-11-28
 	RELEASE: version 2.4.0
 
 2016-11-24
 	Bug fix for OpenLoops interface: EW scheme
 	   is set by WHIZARD
 	Bug fixes for top threshold implementation
 
 2016-11-11
 	Refactoring of dispatching
 
 2016-10-18
 	Bug fix for LCIO output
 
 2016-10-10
 	First implementation for collinear soft terms
 
 2016-10-06
 	First full WHIZARD models from UFO files
 
 2016-10-05
 	WHIZARD does not support legacy gcc 4.7.4 any longer
 
 2016-09-30
 	Major refactoring of process core and NLO components
 
 2016-09-23
 	WHIZARD homogeneous entity: discarding subconfigures
 	  for CIRCE1/2, O'Mega, VAMP subpackages; these are
 	  reconstructable by script projectors
 
 2016-09-06
 	Introduce main configure summary
 
 2016-08-26
 	Fix memory leak in event generation
 
 ##################################################################
 
 2016-08-25
 	RELEASE: version 2.3.1
 
 2016-08-19
 	Bug fix for EW-scheme dependence of gluino propagators
 
 2016-08-01
 	Beta version of complex mass scheme support
 
 2016-07-26
 	Fix bug in POWHEG damping for the matching
 
 ##################################################################
 
 2016-07-21
 	RELEASE: version 2.3.0
 
 2016-07-20
 	UFO file support (alpha version) in O'Mega
 
 2016-07-13
 	New (more) stable of WHIZARD GUI
 	Support for EW schemes for OpenLoops
 	Factorized NLO top decays for threshold model
 
 2016-06-15
 	Passing factorization scale to PYTHIA6
 	Adding charge and neutral observables
 
 2016-06-14
 	Correcting angular distribution/tweaked kinematics in
 	   non-collinear structure functions splittings
 
 2016-05-10
 	Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
 	   (backwards validation of LC CDR/TDR samples)
 
 2016-04-27
 	Within OpenLoops virtuals: support for Collier library
 
 2016-04-25
 	O'Mega vertex tables only loaded at first usage
 
 2016-04-21
 	New CJ15 PDF parameterizations added
 
 2016-04-21
 	Support for hadron collisions at NLO QCD
 
 2016-04-05
 	Support for different (parameter) schemes in model files
 
 2016-03-31
 	Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
 	  into the event record
 
 2016-03-21
 	New internal implementation of polarization
 	  via Bloch vectors, remove pointer constructions
 
 2016-03-13
 	Extension of cascade syntax for processes:
 	  exclude propagators/vertices etc. possible
 
 2016-02-24
 	Full support for OpenLoops QCD NLO matrix
 	  elements, inclusion in test suite
 
 2016-02-12
 	Substantial progress on QCD NLO support
 
 2016-02-02
 	Automated resonance mapping for FKS subtraction
 
 2015-12-17
 	New BSM model WZW for diphoton resonances
 
 ##################################################################
 
 2015-11-22
 	RELEASE: version 2.2.8
 
 2015-11-21
 	Bug fix for fixed-order NLO events
 
 2015-11-20
 	Anomalous FCNC top-charm vertices
 
 2015-11-19
 	StdHEP output via HEPEVT/HEPEV4 supported
 
 2015-11-18
 	Full set of electroweak dim-6 operators included
 
 2015-10-22
 	Polarized one-loop amplitudes supported
 
 2015-10-21
 	Fixes for event formats for showered events
 
 2015-10-14
 	Callback mechanism for event output
 
 2015-09-22
 	Bypass matrix elements in pure event sample rescans
 	StdHep frozen final version v5.06.01 included internally
 
 2015-09-21
 	configure option --with-precision to
 	  demand 64bit, 80bit, or 128bit Fortran
 	  and bind C precision types
 
 2015-09-07
 	More extensive tests of NLO
 	   infrastructure and POWHEG matching
 
 2015-09-01
 	NLO decay infrastructure
 	User-defined squared matrix elements
 	Inclusive FastJet algorithm plugin
 	Numerical improvement for small boosts
 
 ##################################################################
 
 2015-08-11
 	RELEASE: version 2.2.7
 
 2015-08-10
 	Infrastructure for damped POWHEG
 	Massive emitters in POWHEG
 	Born matrix elements via BLHA
 	GoSam filters via SINDARIN
 	Minor running coupling bug fixes
 	Fixed-order NLO events
 
 2015-08-06
 	CT14 PDFs included (LO, NLO, NNLL)
 
 2015-07-07
 	Revalidation of ILC WHIZARD-PYTHIA event chain
 	Extended test suite for showered events
 	Alpha version of massive FSR for POWHEG
 
 2015-06-09
 	Fix memory leak in interaction for long cascades
 	Catch mismatch between beam definition and CIRCE2 spectrum
 
 2015-06-08
 	Automated POWHEG matching: beta version
 	Infrastructure for GKS matching
 	Alpha version of fixed-order NLO events
 	CIRCE2 polarization averaged spectra with
 	   explicitly polarized beams
 
 2015-05-12
 	Abstract matching type: OO structure for matching/merging
 
 2015-05-07
 	Bug fix in event record WHIZARD-PYTHIA6 transferral
 	Gaussian beam spectra for lepton colliders
 
 ##################################################################
 
 2015-05-02
 	RELEASE: version 2.2.6
 
 2015-05-01
 	Models for (unitarized) tensor resonances in VBS
 
 2015-04-28
 	Bug fix in channel weights for event generation.
 
 2015-04-18
 	Improved event record transfer WHIZARD/PYTHIA6
 
 2015-03-19
 	POWHEG matching: alpha version
 
 ##################################################################
 
 2015-02-27
 	RELEASE: version 2.2.5
 
 2015-02-26
 	Abstract types for quantum numbers
 
 2015-02-25
 	Read-in of StdHEP events, self-tests
 
 2015-02-22
 	Bug fix for mother-daughter relations in
 	   showered/hadronized events
 
 2015-02-20
 	Projection on polarization in intermediate states
 
 2015-02-13
 	Correct treatment of beam remnants in
 	   event formats (also LC remnants)
 
 ##################################################################
 
 2015-02-06
 	RELEASE: version 2.2.4
 
 2015-02-06
 	Bug fix in event output
 
 2015-02-05
 	LCIO event format supported
 
 2015-01-30
 	Including state matrices in WHIZARD's internal IO
 	Versioning for WHIZARD's internal IO
 	Libtool update from 2.4.3 to 2.4.5
 	LCIO event output (beta version)
 
 2015-01-27
 	Progress on NLO integration
 	Fixing a bug for multiple processes in a single
 	   event file when using beam event files
 
 2015-01-19
 	Bug fix for spin correlations evaluated in the rest
 	   frame of the mother particle
 
 2015-01-17
 	Regression fix for statically linked processes
 	   from SARAH and FeynRules
 
 2015-01-10
 	NLO: massive FKS emitters supported (experimental)
 
 2015-01-06
 	MMHT2014 PDF sets included
 
 2015-01-05
 	Handling mass degeneracies in auto_decays
 
 2014-12-19
 	Fixing bug in rescan of event files
 
 ##################################################################
 
 2014-11-30
 	RELEASE: version 2.2.3
 
 2014-11-29
 	Beta version of LO continuum/NLL-threshold
 	matched top threshold model for e+e- physics
 
 2014-11-28
 	More internal refactoring: disentanglement of module
 	   dependencies
 
 2014-11-21
 	OVM: O'Mega Virtual Machine, bytecode instructions
 	   instead of compiled Fortran code
 
 2014-11-01
 	Higgs Singlet extension model included
 
 2014-10-18
 	Internal restructuring of code; half-way
 	  WHIZARD main code file disassembled
 
 2014-07-09
 	Alpha version of NLO infrastructure
 
 ##################################################################
 
 2014-07-06
 	RELEASE: version 2.2.2
 
 2014-07-05
 	CIRCE2: correlated LC beam spectra and
 	  GuineaPig Interface to LC machine parameters
 
 2014-07-01
 	Reading LHEF for decayed/factorized/showered/
 	   hadronized events
 
 2014-06-25
 	Configure support for GoSAM/Ninja/Form/QGraf
 
 2014-06-22
 	LHAPDF6 interface
 
 2014-06-18
 	Module for automatic generation of
 	  radiation and loop infrastructure code
 
 2014-06-11
 	Improved internal directory structure
 
 ##################################################################
 
 2014-06-03
 	RELEASE: version 2.2.1
 
 2014-05-30
 	Extensions of internal PDG arrays
 
 2014-05-26
 	FastJet interface
 
 2014-05-24
 	CJ12 PDFs included
 
 2014-05-20
 	Regression fix for external models (via SARAH
 	    or FeynRules)
 
 ##################################################################
 
 2014-05-18
 	RELEASE: version 2.2.0
 
 2014-04-11
 	Multiple components: inclusive process definitions,
 	   syntax: process A + B + ...
 
 2014-03-13
 	Improved PS mappings for e+e- ISR
 	ILC TDR and CLIC spectra included in CIRCE1
 
 2014-02-23
 	New models: AltH w\ Higgs for exclusion purposes,
 	  SM_rx for Dim 6-/Dim-8 operators, SSC for
 	  general strong interactions (w/ Higgs), and
 	  NoH_rx (w\ Higgs)
 
 2014-02-14
 	Improved s-channel mapping, new on-shell
 	  production mapping (e.g. Drell-Yan)
 
 2014-02-03
 	PRE-RELEASE: version 2.2.0_beta
 
 2014-01-26
 	O'Mega: Feynman diagram generation possible (again)
 
 2013-12-16
 	HOPPET interface for b parton matching
 
 2013-11-15
 	PRE-RELEASE: version 2.2.0_alpha-4
 
 2013-10-27
 	LHEF standards 1.0/2.0/3.0 implemented
 
 2013-10-15
 	PRE-RELEASE: version 2.2.0_alpha-3
 
 2013-10-02
 	PRE-RELEASE: version 2.2.0_alpha-2
 
 2013-09-25
 	PRE-RELEASE: version 2.2.0_alpha-1
 
 2013-09-12
 	PRE-RELEASE: version 2.2.0_alpha
 
 2013-09-03
 	General 2HDM implemented
 
 2013-08-18
 	Rescanning/recalculating events
 
 2013-06-07
 	Reconstruction of complete event
 	  from 4-momenta possible
 
 2013-05-06
 	Process library stacks
 
 2013-05-02
 	Process stacks
 
 2013-04-29
 	Single-particle phase space module
 
 2013-04-26
 	Abstract interface for random
 	  number generator
 
 2013-04-24
 	More object-orientation on modules
 	Midpoint-rule integrator
 
 2013-04-05
 	Object-oriented integration and
 	  event generation
 
 2013-03-12
 	Processes recasted object-oriented:
 	  MEs, scales, structure functions
 	First infrastructure for general Lorentz
 	  structures
 
 2013-01-17
 	Object-orientated reworking of library and
 	   process core, more variable internal structure,
 	   unit tests
 
 2012-12-14
 	Update Pythia version to 6.4.27
 
 2012-12-04
 	Fix the phase in HAZ vertices
 
 2012-11-21
 	First O'Mega unit tests, some infrastructure
 
 2012-11-13
 	Bug fix in anom. HVV Lorentz structures
 
 ##################################################################
 
 2012-09-18
 	RELEASE: version 2.1.1
 
 2012-09-11
 	Model MSSM_Hgg with Hgg and HAA vertices
 
 2012-09-10
 	First version of implementation of multiple
 	   interactions in WHIZARD
 
 2012-09-05
 	Infrastructure for internal CKKW matching
 
 2012-09-02
 	C, C++, Python API
 
 2012-07-19
 	Fixing particle numbering in HepMC format
 
 ##################################################################
 
 2012-06-15
 	RELEASE: version 2.1.0
 
 2012-06-14
 	Analytical and kT-ordered shower officially
 	  released
 	PYTHIA interface officially released
 
 2012-05-09
 	Intrisince PDFs can be used for showering
 
 2012-05-04
 	Anomalous Higgs couplings a la hep-ph/9902321
 
 ##################################################################
 
 2012-03-19
 	RELEASE: version 2.0.7
 
 2012-03-15
 	Run IDs are available now
 	More event variables in analysis
 	Modified raw event format (compatibility mode exists)
 
 2012-03-12
 	Bug fix in decay-integration order
 	MLM matching steered completely internally now
 
 2012-03-09
 	Special phase space mapping for narrow resonances
 	  decaying to 4-particle final states with far off-shell
 	  intermediate states
 	Running alphas from PDF collaborations with
 	  builtin PDFs
 
 2012-02-16
 	Bug fix in cascades decay infrastructure
 
 2012-02-04
 	WHIZARD documentation compatible with TeXLive 2011
 
 2012-02-01
 	Bug fix in FeynRules interface with --prefix flag
 
 2012-01-29
 	Bug fix with name clash of O'Mega variable names
 
 2012-01-27
 	Update internal PYTHIA to version 6.4.26
 	Bug fix in LHEF output
 
 2012-01-21
 	Catching stricter automake 1.11.2 rules
 
 2011-12-23
 	Bug fix in decay cascade setup
 
 2011-12-20
 	Bug fix in helicity selection rules
 
 2011-12-16
 	Accuracy goal reimplemented
 
 2011-12-14
 	WHIZARD compatible with TeXLive 2011
 
 2011-12-09
 	Option --user-target added
 
 ##################################################################
 
 2011-12-07
 	RELEASE: version 2.0.6
 
 2011-12-07
 	Bug fixes in SM_top_anom
 	Added missing entries to HepMC format
 
 2011-12-06
 	Allow to pass options to O'Mega
 	Bug fix for HEPEVT block for showered/hadronized events
 
 2011-12-01
 	Reenabled user plug-in for external code for
 	   cuts, structure functions, routines etc.
 
 2011-11-29
 	Changed model SM_Higgs for Higgs phenomenology
 
 2011-11-25
 	Supporting a Y, (B-L) Z' model
 
 2011-11-23
 	Make WHIZARD compatible for MAC OS X Lion/XCode 4
 
 2011-09-25
 	WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742
 
 2011-08-16
 	Model SM_QCD: QCD with one EW insertion
 
 2011-07-19
 	Explicit output channel for dvips avoids printing
 
 2011-07-10
 	Test suite for WHIZARD unit tests
 
 2011-07-01
 	Commands for matrix element tests
 	More OpenMP parallelization of kinematics
 	Added unit tests
 
 2011-06-23
 	Conversion of CIRCE2 from F77 to F90, major
 	  clean-up
 
 2011-06-14
 	Conversion of CIRCE1 from F77 to F90
 
 2011-06-10
 	OpenMP parallelization of channel kinematics
 		(by Matthias Trudewind)
 
 2011-05-31
 	RELEASE: version 1.97
 
 2011-05-24
 	Minor bug fixes: update grids and elsif statement.
 
 ##################################################################
 
 2011-05-10
 	RELEASE: version 2.0.5
 
 2011-05-09
 	Fixed bug in final state flavor sums
 	Minor improvements on phase-space setup
 
 2011-05-05
 	Minor bug fixes
 
 2011-04-15
 	WHIZARD as a precompiled 64-bit binary available
 
 2011-04-06
 	Wall clock instead of cpu time for time estimates
 
 2011-04-05
 	Major improvement on the phase space setup
 
 2011-04-02
 	OpenMP parallelization for helicity loop in O'Mega
 	   matrix elements
 
 2011-03-31
 	Tools for relocating WHIZARD and use in batch
 	environments
 
 2011-03-29
 	Completely static builds possible, profiling options
 
 2011-03-28
 	Visualization of integration history
 
 2011-03-27
 	Fixed broken K-matrix implementation
 
 2011-03-23
 	Including the GAMELAN manual in the distribution
 
 2011-01-26
 	WHIZARD analysis can handle hadronized event files
 
 2011-01-17
 	MSTW2008 and CT10 PDF sets included
 
 2010-12-23
 	Inclusion of NMSSM with Hgg couplings
 
 2010-12-21
 	Advanced options for integration passes
 
 2010-11-16
 	WHIZARD supports CTEQ6 and possibly other PDFs
 	directly; data files included in the distribution
 
 ##################################################################
 
 2010-10-26
 	RELEASE: version 2.0.4
 
 2010-10-06
 	Bug fix in MSSM implementation
 
 2010-10-01
 	Update to libtool 2.4
 
 2010-09-29
 	Support for anomalous top couplings (form factors etc.)
 	Bug fix for running gauge Yukawa SUSY couplings
 
 2010-09-28
 	RELEASE: version 1.96
 
 2010-09-21
 	Beam remnants and pT spectra for lepton collider re-enabled
 	Restructuring subevt class
 
 2010-09-16
 	Shower and matching are disabled by default
 	PYTHIA as a conditional on these two options
 
 2010-09-14
 	Possibility to read in beam spectra re-enabled (e.g. Guinea
 	   Pig)
 
 2010-09-13
 	Energy scan as (pseudo-) structure functions re-implemented
 
 2010-09-10
 	CIRCE2 included again in WHIZARD 2 and validated
 
 2010-09-02
 	Re-implementation of asymmetric beam energies and collision
 	  angles, e-p collisions work, inclusion of a HERA DIS test
 	  case
 
 ##################################################################
 
 2010-10-18
 	RELEASE: version 2.0.3
 
 2010-08-08
 	Bug in CP-violating anomalous triple TGCs fixed
 
 2010-08-06
 	Solving backwards compatibility problem with O'Caml 3.12.0
 
 2010-07-12
 	Conserved quantum numbers speed up O'Mega code generation
 
 2010-07-07
 	Attaching full ISR/FSR parton shower and MPI/ISR
 	   module
 	Added SM model containing Hgg, HAA, HAZ vertices
 
 2010-07-02
 	Matching output available as LHEF and STDHEP
 
 2010-06-30
 	Various bug fixes, missing files, typos
 
 2010-06-26
 	CIRCE1 completely re-enabled
 	Chaining structure functions supported
 
 2010-06-25
 	Partial support for conserved quantum numbers in
 	   O'Mega
 
 2010-06-21
 	Major upgrade of the graphics package: error bars,
 	   smarter SINDARIN steering, documentation, and all that...
 
 2010-06-17
 	MLM matching with PYTHIA shower included
 
 2010-06-16
 	Added full CIRCE1 and CIRCE2 versions including
 	full documentation and miscellanea to the trunk
 
 2010-06-12
 	User file management supported, improved variable
 	and command structure
 
 2010-05-24
 	Improved handling of variables in local command lists
 
 2010-05-20
 	PYTHIA interface re-enabled
 
 2010-05-19
 	ASCII file formats for interfacing ROOT and gnuplot in
 	   data analysis
 
 ##################################################################
 
 2010-05-18
 	RELEASE: version 2.0.2
 
 2010-05-14
 	Reimplementation of visualization of phase space
 	   channels
 	Minor bug fixes
 
 2010-05-12
 	Improved phase space - elimination of redundancies
 
 2010-05-08
 	Interface for polarization completed: polarized beams etc.
 
 2010-05-06
 	Full quantum numbers appear in process log
 	Integration results are usable as user variables
 	Communication with external programs
 
 2010-05-05
 	Split module commands into commands, integration,
 	   simulation modules
 
 2010-05-04
 	FSR+ISR for the first time connected to the WHIZARD 2 core
 
 ##################################################################
 
 2010-04-25
 	RELEASE: version 2.0.1
 
 2010-04-23
 	Automatic compile and integrate if simulate is called
 	Minor bug fixes in O'Mega
 
 2010-04-21
 	Checkpointing for event generation
 	Flush statements to use WHIZARD inside a pipe
 
 2010-04-20
 	Reimplementation of signal handling in WGIZARD 2.0
 
 2010-04-19
 	VAMP is now a separately configurable and installable unit of
 	   WHIZARD, included VAMP self-checks
 	Support again compilation in quadruple precision
 
 2010-04-06
 	Allow for logarithmic plots in GAMELAN, reimplement the
 	   possibility to set the number of bins
 
 2010-04-15
 	Improvement on time estimates for event generation
 
 ##################################################################
 
 2010-04-12
 	RELEASE: version 2.0.0
 
 2010-04-09
 	Per default, the code for the amplitudes is subdivided to allow
 	  faster compiler optimization
 	More advanced and unified and straightforward command language
 	  syntax
 	Final bug fixes
 
 2010-04-07
 	Improvement on SINDARIN syntax; printf, sprintf function
 	  thorugh a C interface
 
 2010-04-05
 	Colorizing DAGs instead of model vertices: speed boost
 	  in colored code generation
 
 2010-03-31
 	Generalized options for normalization of weighted and
 	  unweighted events
 	Grid and weight histories added again to log files
 	Weights can be used in analyses
 
 2010-03-28
 	Cascade decays completely implemented including color and
 	   spin correlations
 
 2010-03-07
 	Added new WHIZARD header with logo
 
 2010-03-05
 	Removed conflict in O'Mega amplitudes between flavour sums
 	   and cascades
 	StdHEP interface re-implemented
 
 2010-03-03
 	RELEASE: version 2.0.0rc3
 	Several bug fixes for preventing abuse in input files
 	OpenMP support for amplitudes
 	Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
 	FeynRules interface successfully passed MSSM test
 
 2010-02-26
 	Eliminating ghost gluons from multi-gluon amplitudes
 
 2010-02-25
 	RELEASE: version 1.95
 	HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2
 
 2010-02-23
 	Running alpha_s implemented in the FeynRules interface
 
 2010-02-19
 	MSSM (semi-) automatized self-tests finalized
 
 2010-02-17
 	RELEASE: version 1.94
 
 2010-02-16
 	Closed memory corruption in WHIZARD 1
 	Fixed problems of old MadGraph and CompHep drivers
 	   with modern compilers
 	Uncolored vertex selection rules for colored amplitudes in
 	   O'Mega
 
 2010-02-15
 	Infrastructure for color correlation computation in O'Mega
 	   finished
 	Forbidden processes are warned about, but treated as non-fatal
 
 2010-02-14
 	Color correlation computation in O'Mega finalized
 
 2010-02-10
 	Improving phase space mappings for identical particles in
 	initial and final states
 	Introduction of more extended multi-line error message
 
 2010-02-08
 	First O'Caml code for computation of color correlations in
 	O'Mega
 
 2010-02-07
 	First MLM matching with e+ e- -> jets
 
 ##################################################################
 
 2010-02-06
 	RELEASE: version 2.0.0rc2
 
 2010-02-05
 	Reconsidered the Makefile structure and more extended tests
 	Catch a crash between WHIZARD and O'Mega for forbidden processes
 	Tensor products of arbitrary color structures in jet definitions
 
 2010-02-04
 	Color correlation computation in O'Mega finalized
 
 ##################################################################
 
 2010-02-03
 	RELEASE: version 2.0.0rc1
 
 ##################################################################
 
 2010-01-31
 	Reimplemented numerical helicity selection rules
 	Phase space functionality of version 1 restored and improved
 
 2009-12-05
 	NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)
 
 2009-12-04
 	RELEASE: version 2.0.0alpha
 
 ##################################################################
 
 2009-04-16
 	RELEASE: version 1.93
 
 2009-04-15
 	Clean-up of Makefiles and configure scripts
 	Reconfiguration of BSM model implementation
 	extended supersymmetric models
 
 2008-12-23
 	New model NMSSM	(Felix Braam)
 	SLHA2 added
 	Bug in LHAPDF interface fixed
 
 2008-08-16
 	Bug fixed in K matrix implementation
 	Gravitino option in the MSSM added
 
 2008-03-20
 	Improved color and flavor sums
 
 ##################################################################
 
 2008-03-12
 	RELEASE: version 1.92
 	LHEF (Les Houches Event File) format added
 	Fortran 2003 command-line interface (if supported by the compiler)
 	Automated interface to colored models
 	More bug fixes and workarounds for compiler compatibility
 
 ##################################################################
 
 2008-03-06
 	RELEASE: version 1.91
 	New model K-matrix (resonances and anom. couplings in WW scattering)
 	EWA spectrum
 	Energy-scan pseudo spectrum
 	Preliminary parton shower module (only from final-state quarks)
 	Cleanup and improvements of configure process
 	Improvements for O'Mega parameter files
 	Quadruple precision works again
 	More plotting options: lines, symbols, errors
 	Documentation with PDF bookmarks enabled
 	Various bug fixes
 
 2007-11-29
 	New model UED
 
 ##################################################################
 
 2007-11-23
 	RELEASE: version 1.90
 	O'Mega now part of the WHIZARD tree
 	Madgraph/CompHEP disabled by default (but still usable)
 	Support for LHAPDF (preliminary)
 	Added new models: SMZprime, SM_km, Template
 	Improved compiler recognition and compatibility
 	Minor bug fixes
 
 ##################################################################
 
 2006-06-15
 	RELEASE: version 1.51
 	Support for anomaly-type Higgs couplings (to gluon and photon/Z)
 	Support for spin 3/2 and spin 2
 	New models: Little Higgs (4 versions), toy models for extra dimensions
           and gravitinos
 	Fixes to the whizard.nw source documentation to run through LaTeX
 	Intel 9.0 bug workaround (deallocation of some arrays)
 
 2006-05-15
 	O'Mega RELEASE: version 0.11
 	merged JRR's O'Mega extensions
 
 ##################################################################
 
 2006-02-07
 	RELEASE: version 1.50
         To avoid confusion: Mention outdated manual example in BUGS file
         O'Mega becomes part of the WHIZARD generator
 
 2006-02-02   [bug fix update]
 	Bug fix: spurious error when writing event files for weighted events
 	Bug fix: 'r' option for omega produced garbage for some particle names
 	Workaround for ifort90 bug (crash when compiling whizard_event)
 	Workaround for ifort90 bug (crash when compiling hepevt_common)
 
 2006-01-27
 	Added process definition files for MSSM 2->2 processes
 	Included beam recoil for EPA (T.Barklow)
 	Updated STDHEP byte counts (for STDHEP 5.04.02)
 	Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
 	Fixed issue with comphep requiring Xlibs on Opteron
 	Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
 	Fixed color-flow code: was broken for omega with option 'c' and 'w'
 	Workaround hacks for g95 compatibility
 
 2005-11-07
 	O'Mega RELEASE: version 0.10
 	O'Mega, merged JRR's and WK's color hack for WHiZard
         O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
 	  a la JRR/WK)
         O'Mega, make JRR's MSSM official
 
 ##################################################################
 
 2005-10-25
 	RELEASE: version 1.43
 	Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
 	  This should be final, since the MSSM results agree now completely
           with Madgraph and Sherpa
 	User-defined lower and upper limits for split event file count
 	Allow for counters (events, bytes) exceeding $2^{31}$
 	Revised checksum treatment and implementation (now MD5)
         Bug fix: missing process energy scale in raw event file
 
 ##################################################################
 
 2005-09-30
 	RELEASE: version 1.42
 	Graphical display of integration history ('make history')
 	Allow for switching off signals even if supported (configure option)
 
 2005-09-29
 	Revised phase space generation code, in particular for flavor sums
 	Negative cut and histogram codes use initial beams instead of
 	  initial parton momenta.  This allows for computing, e.g., E_miss
 	Support constant-width and zero-width options for O'Mega
 	Width options now denoted by w:X (X=f,c,z).  f option obsolescent
 	Bug fix: colorized code: flipped indices could screw up result
 	Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
 	Bug fix: dvips on systems where dvips defaults to lpr
 	Bug fix: integer overflow if too many events are requested
 
 2005-07-29
 	Allow for 2 -> 1 processes (if structure functions are on)
 
 2005-07-26
 	Fixed and expanded the 'test' matrix element:
 	  Unit matrix element with option 'u' / default: normalized phase space
 
 ##################################################################
 
 2005-07-15
 	RELEASE: version 1.41
 	Bug fix: no result for particle decay processes with width=0
 	Bug fix: line breaks in O'Mega files with color decomposition
 
 2005-06-02
 	New self-tests (make test-QED / test-QCD / test-SM)
 	  check lists of 2->2 processes
 	Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)
 
 2005-05-25
 	Revised Makefile structure
 	Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)
 
 2005-05-19
 	Support for color in O'Mega (using color flow decomposition)
 	New model QCD
 	Parameter file changes that correspond to replaced SM module in O'Mega
 	Bug fixes in MSSM (O'Mega) parameter file
 
 2005-05-18
 	New event file formats, useful for LHC applications:
           ATHENA and Les Houches Accord (external fragmentation)
         Naive (i.e., leading 1/N) color factor now implemented both for
           incoming and outgoing partons
 
 2005-01-26
 	include missing HELAS files for bundle
 	pgf90 compatibility issues [note: still internal error in pgf90]
 
 ##################################################################
 
 2004-12-13
 	RELEASE: version 1.40
 	compatibility fix: preprocessor marks in helas code now commented out
 	minor bug fix: format string in madgraph source
 
 2004-12-03
 	support for arbitray beam energies and directions
 	allow for pT kick in structure functions
 	bug fix: rounding error could result in zero cross section
 	  (compiler-dependent)
 
 2004-10-07
 	simulate decay processes
 	list fraction (of total width/cross section) instead of efficiency
           in process summary
 	new cut/analysis parameters AA, AAD, CTA: absolute polar angle
 
 2004-10-04
 	Replaced Madgraph I by Madgraph II.  Main improvement: model no
           longer hardcoded
 	introduced parameter reset_seed_each_process (useful for debugging)
         bug fix: color initialization for some processes was undefined
 
 2004-09-21
 	don't compile unix_args module if it is not required
 
 ##################################################################
 
 2004-09-20
 	RELEASE: version 1.30
 	g95 compatibility issues resolved
 	some (irrelevant) memory leaks closed
 	removed obsolete warning in circe1
 	manual update (essentially) finished
 
 2004-08-03
 	O'Mega RELEASE: version 0.9
 	O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
           the O'Caml 3.08 library (remains compatible with older
           versions).  Implementation of unused functions still
           incomplete.
 
 2004-07-26
 	minor fixes and improvements in make process
 
 2004-06-29
 	workarounds for new Intel compiler bugs ...
 	no rebuild of madgraph/comphep executables after 'make clean'
 	bug fix in phase space routine:
           wrong energy for massive initial particles
         bug fix in (new) model interface: name checks for antiparticles
         pre-run checks for comphep improved
         ww-strong model file extended
         Model files particle name fixes, chep SM vertices included
 
 2004-06-22
 	O'Mega RELEASE: version 0.8
 	O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings
 
 2004-05-05
 	Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
 	NAG compiler: set number of continuation lines to 200 as default
 	Extended format for cross section summary; appears now in whizard.out
 	Fixed 'bundle' feature
 
 2004-04-28
 	Fixed compatibility with revised O'Mega SM_ac model
 	Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
 	Fixed bug in comphep module: Vtb was overlooked
 
 ##################################################################
 
 2004-04-15
 	RELEASE: version 1.28
         Fixed bug: Color factor was missing for O'Mega processes with
           four quarks and more
         Manual partially updated
 
 2004-04-08
 	Support for grid files in binary format
 	New default value show_histories=F (reduce output file size)
 	Revised phase space switches: removed annihilation_lines,
 	  removed s_channel_resonance, changed meaning of
 	  extra_off_shell_lines, added show_deleted_channels
 	Bug fixed which lead to omission of some phase space channels
 	Color flow guessed only if requested by guess_color_flow
 
 2004-03-10
 	New model interface: Only one model name specified in whizard.prc
         All model-dependent files reside in conf/models (modellib removed)
 
 2004-03-03
 	Support for input/output in SUSY Les Houches Accord format
 	Split event files if requested
 	Support for overall time limit
 	Support for CIRCE and CIRCE2 generator mode
 	Support for reading beam events from file
 
 2004-02-05
 	Fixed compiler problems with Intel Fortran 7.1 and 8.0
 	Support for catching signals
 
 ##################################################################
 
 2003-08-06
 	RELEASE: version 1.27
 	User-defined PDF libraries as an alternative to the standard PDFLIB
 
 2003-07-23
 	Revised phase space module: improved mappings for massless particles,
 	  equivalences of phase space channels are exploited
 	Improved mapping for PDF (hadron colliders)
 	Madgraph module: increased max number of color flows from 250 to 1000
 
 ##################################################################
 
 2003-06-23
 	RELEASE: version 1.26
 	CIRCE2 support
 	Fixed problem with 'TC' integer kind [Intel compiler complained]
 
 2003-05-28
 	Support for drawing histograms of grids
 	Bug fixes for MSSM definitions
 
 ##################################################################
 
 2003-05-22
 	RELEASE: version 1.25
 	Experimental MSSM support with ISAJET interface
 	Improved capabilities of generating/analyzing weighted events
 	Optional drawing phase space diagrams using FeynMF
 
 ##################################################################
 
 2003-01-31
 	RELEASE: version 1.24
 	A few more fixes and workarounds (Intel and Lahey compiler)
 
 2003-01-15
 	Fixes and workarounds needed for WHIZARD to run with Intel compiler
 	Command-line option interface for the Lahey compiler
 
 	Bug fix: problem with reading whizard.phs
 
 ##################################################################
 
 2002-12-10
 	RELEASE: version 1.23
 
 	Command-line options (on some systems)
 
 	Allow for initial particles in the event record, ordered:
           [beams, initials] - [remnants] - outgoing partons
 
 	Support for PYTHIA 6.2: Les Houches external process interface
 	String pythia_parameters can be up to 1000 characters long
 	Select color flow states in (internal) analysis
 	Bug fix in color flow content of raw event files
 
 	Support for transversal polarization of fermion beams
 	Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
 	'Test' matrix elements optionally respect polarization
 
 	User-defined code can be inserted for spectra, structure functions
           and fragmentation
 
 	Time limits can be specified for adaptation and simulation
 	User-defined file names and file directory
         Initial weights in input file no longer supported
 
         Bug fix in MadGraph (wave function counter could overflow)
 
 	Bug fix: Gamelan (graphical analysis) was not built if noweb absent
 
 ##################################################################
 
 2002-03-16
 	RELEASE: version 1.22
 	Allow for beam remnants in the event record
 
 2002-03-01
         Handling of aliases in whizard.prc fixed (aliases are whole tokens)
 
 2002-02-28
 	Optimized phase space handling routines
 	  (total execution time reduced by 20-60%, depending on process)
 
 ##################################################################
 
 2002-02-26
 	RELEASE: version 1.21
 	Fixed ISR formula (ISR was underestimated in previous versions).
           New version includes ISR in leading-log approximation up to
           third order.  Parameter ISR_sqrts renamed to ISR_scale.
 
 ##################################################################
 
 2002-02-19
 	RELEASE: version 1.20
 	New process-generating method 'test' (dummy matrix element)
 	Compatibility with autoconf 2.50 and current O'Mega version
 
 2002-02-05
 	Prevent integration channels from being dropped (optionally)
 	New internal mapping for structure functions improves performance
 	Old whizard.phx file deleted after recompiling (could cause trouble)
 
 2002-01-24
 	Support for user-defined cuts and matrix element reweighting
 	STDHEP output now written by write_events_format=20 (was 3)
 
 2002-01-16
 	Improved structure function handling; small changes in user interface:
           new parameter structured_beams in &process_input
           parameter fixed_energy in &beam_input removed
 	Support for multiple initial states
 	Eta-phi (cone) cut possible (hadron collider applications)
 	Fixed bug: Whizard library was not always recompiled when necessary
 	Fixed bug: Default cuts were insufficient in some cases
 	Fixed bug: Unusable phase space mappings generated in some cases
 
 2001-12-06
 	Reorganized document source
 
 2001-12-05
 	Preliminary CIRCE2 support (no functionality yet)
 
 2001-11-27
 	Intel compiler support (does not yet work because of compiler bugs)
 	New cut and analysis mode cos-theta* and related
 	Fixed circular jetset_interface dependency warning
 	Some broadcast routines removed (parallel support disabled anyway)
 	Minor shifts in cleanup targets (Makefiles)
         Modified library search, check for pdflib8*
 
 2001-08-06
 	Fixed bug: I/O unit number could be undefined when reading phase space
 	Fixed bug: Unitialized variable could cause segfault when
                    event generation was disabled
 	Fixed bug: Undefined subroutine in CIRCE replacement module
 	Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
 		   (CompHEP model sm-GF #5, O'Mega model SM_ac)
 	Fixed portability issue: Makefile did rely on PWD environment variable
 	Fixed portability issue: PYTHIA library search ambiguity resolved
 
 2001-08-01
 	Default whizard.prc and whizard.in depend on activated modules
 	Fixed bug: TEX=latex was not properly enabled when making plots
 
 2001-07-20
 	Fixed output settings in PERL script calls
 	Cache enabled in various configure checks
 
 2001-07-13
 	Support for multiple processes in a single WHIZARD run.  The
           integrations are kept separate, but the generated events are mixed
 	The whizard.evx format has changed (incompatible), including now
 	  the color flow information for PYTHIA fragmentation
 	Output files are now process-specific, except for the event file
 	Phase space file whizard.phs (if present) is used only as input,
 	  program-generated phase space is now in whizard.phx
 
 2001-07-10
 	Bug fix: Undefined parameters in parameters_SM_ac.f90 removed
 
 2001-07-04
 	Bug fix: Compiler options for the case OMEGA is disabled
 	Small inconsistencies in whizard.out format fixed
 
 2001-07-01
 	Workaround for missing PDFLIB dummy routines in PYTHIA library
 
 ##################################################################
 
 2001-06-30
 	RELEASE: version 1.13
 	Default path /cern/pro/lib in configure script
 
 2001-06-20
 	New fragmentation option: Interface for PYTHIA with full color flow
           information, beam remnants etc.
 
 2001-06-18
 	Severe bug fixed in madgraph interface: 3-gluon coupling was missing
 	Enabled color flow information in madgraph
 
 2001-06-11
 	VAMP interface module rewritten
 	Revised output format: Multiple VAMP iterations count as one WHIZARD
           iteration in integration passes 1 and 3
 	Improved message and error handling
 	Bug fix in VAMP: handle exceptional cases in rebinning_weights
 
 2001-05-31
 	new parameters for grid adaptation: accuracy_goal and efficiency_goal
 
 ##################################################################
 
 2001-05-29
 	RELEASE: version 1.12
 	bug fixes (compilation problems): deleted/modified unused functions
 
 2001-05-16
 	diagram selection improved and documented
 
 2001-05-06
         allow for disabling packages during configuration
 
 2001-05-03
 	slight changes in whizard.out format; manual extended
 
 ##################################################################
 
 2001-04-20
 	RELEASE: version 1.11
 	fixed some configuration and compilation problems (PDFLIB etc.)
 
 2001-04-18
 	linked PDFLIB: support for quark/gluon structure functions
 
 2001-04-05
 	parameter interface written by PERL script
 	SM_ac model file: fixed error in continuation line
 
 2001-03-13
 	O'Mega, O'Caml 3.01: incompatible changes
 	O'Mega, src/trie.mli: add covariance annotation to T.t
 	  This breaks O'Caml 3.00, but is required for O'Caml 3.01.
 	O'Mega, many instances: replace `sig include Module.T end' by
 	  `Module.T', since the bug is fixed in O'Caml 3.01
 
 2001-02-28
 	O'Mega, src/model.mli:
             new field Model.vertices required for model functors, will
 	    retire Model.fuse2, Model.fuse3, Model.fusen soon.
 
 ##################################################################
 
 2001-03-27
 	RELEASE: version 1.10
 	reorganized the modules as libraries
 	linked PYTHIA: support for parton fragmentation
 
 2000-12-14
 	fixed some configuration problems (if noweb etc. are absent)
 
 ##################################################################
 
 2000-12-01
 	RELEASE of first public version: version 1.00beta
Index: trunk/src/variables/variables.nw
===================================================================
--- trunk/src/variables/variables.nw	(revision 8441)
+++ trunk/src/variables/variables.nw	(revision 8442)
@@ -1,6830 +1,6840 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: variables for processes
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Variables for Processes}
 \includemodulegraph{variables}
 
 This part introduces variables as user-controlled objects that
 influence the behavior of objects and calculations.  Variables contain
 objects of intrinsic type or of a type as introced above.
 \begin{description}
 \item[variables]
   Store values of various kind, used by expressions and accessed by
   the command interface.  This provides an implementation of the [[vars_t]]
   abstract type.
 \item[observables]
   Concrete implementation of observables (functions in the variable tree),
   applicable for \whizard.
   abstract type.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Variables: Implementation}
 The user interface deals with variables that are handled similarly to
 full-flegded programming languages.  The system will add a lot of
 predefined variables (model parameters, flags, etc.) that are
 accessible to the user by the same methods.
 
 Variables can be of various type: logical (boolean/flag), integer,
 real (default precision), subevents (used in cut expressions),
 arrays of PDG codes (aliases for particles), strings.  Furthermore, in
 cut expressions we have unary and binary observables, which are used
 like real parameters but behave like functions.
 <<[[variables.f90]]>>=
 <<File header>>
 
 module variables
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: pac_fmt
   use format_defs, only: FMT_12, FMT_19
   use constants, only: eps0, tiny_07
   use os_interface, only: paths_t
   use physics_defs, only: LAMBDA_QCD_REF
   use system_dependencies
   use fastjet !NODEP!
   use diagnostics
   use pdg_arrays
   use subevents
 
   use var_base
 
 <<Standard module head>>
 
 <<Variables: public>>
 
 <<Variables: parameters>>
 
 <<Variables: types>>
 
 <<Variables: interfaces>>
 
 contains
 
 <<Variables: procedures>>
 
 end module variables
 @ %def variables
 @
 \subsection{Variable list entries}
 Variable (and constant) values can be of one of the following types:
 <<Variables: parameters>>=
   integer, parameter, public :: V_NONE = 0, V_LOG = 1, V_INT = 2, V_REAL = 3
   integer, parameter, public :: V_CMPLX = 4, V_SEV = 5, V_PDG = 6, V_STR = 7
   integer, parameter, public :: V_OBS1_INT = 11, V_OBS2_INT = 12
   integer, parameter, public :: V_OBS1_REAL = 21, V_OBS2_REAL = 22
   integer, parameter, public :: V_UOBS1_INT = 31, V_UOBS2_INT = 32
   integer, parameter, public :: V_UOBS1_REAL = 41, V_UOBS2_REAL = 42
 
 @ %def V_NONE V_LOG V_INT V_REAL V_CMPLX V_PRT V_SEV V_PDG
 @ %def V_OBS1_INT V_OBS2_INT V_OBS1_REAL V_OBS2_REAL
 @ %def V_UOBS1_INT V_UOBS2_INT V_UOBS1_REAL V_UOBS2_REAL
 @
 \subsubsection{The type}
 This is an entry in the variable list.  It can be of any type; in
 each case only one value is allocated.  It may be physically
 allocated upon creation, in which case [[is_allocated]] is true, or
 it may contain just a pointer to a value somewhere else, in which case
 [[is_allocated]] is false.
 
 The flag [[is_defined]] is set when the variable is given a value, even the
 undefined value.  (Therefore it is distinct from [[is_known]].)  This matters
 for variable declaration in the SINDARIN language.  The variable is set up in
 the compilation step and initially marked as defined, but after compilation
 all variables are set undefined.  Each variable becomes defined when it is
 explicitly set.  The difference matters in loops.
 
 [[is_locked]] means that it cannot be given a value using the interface
 routines [[var_list_set_XXX]] below.  It can only be initialized, or change
 automatically due to a side effect.
 
 [[is_copy]] means that this is a local copy of a global variable.  The copy
 has a pointer to the original, which can be used to restore a previous value.
 
 [[is_intrinsic]] means that this variable is defined by the program, not by
 the user.  Intrinsic variables cannot be (re)declared, but their values can be
 reset unless they are locked.  [[is_user_var]] means that the variable has
 been declared by the user.  It could be a new variable, or a local copy of an
 intrinsic variable.
 
 The flag [[is_known]] is a pointer which parallels the use of the
 value pointer.  For pointer variables, it is set if the value should point to
 a known value.  For ordinary variables, it should be true.
 
 The value is implemented as a set of alternative type-specific pointers.  This
 emulates polymorphism, and it allows for actual pointer variables.
 Observable-type variables have function pointers as values, so they behave
 like macros.  The functions make use of the particle objects accessible via
 the pointers [[prt1]] and [[prt2]].
 
 Finally, the [[next]] pointer indicates that we are making lists of
 variables.  A more efficient implementation might switch to hashes or
 similar; the current implementation has $O(N)$ lookup.
 <<Variables: public>>=
   public :: var_entry_t
 <<Variables: types>>=
   type :: var_entry_t
      private
      integer :: type = V_NONE
      type(string_t) :: name
      logical :: is_allocated = .false.
      logical :: is_defined = .false.
      logical :: is_locked = .false.
      logical :: is_intrinsic = .false.
      logical :: is_user_var = .false.
      logical, pointer :: 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 ()
      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 ()
      type(prt_t), pointer :: prt1 => null ()
      type(prt_t), pointer :: prt2 => null ()
      type(var_entry_t), pointer :: next => null ()
      type(var_entry_t), pointer :: previous => null ()
      type(string_t) :: description
   end type var_entry_t
 
 @ %def var_entry_t
 @
 \subsubsection{Interfaces for the observable functions}
 <<Variables: public>>=
   public :: obs_unary_int
   public :: obs_unary_real
   public :: obs_binary_int
   public :: obs_binary_real
 <<Variables: interfaces>>=
   abstract interface
      function obs_unary_int (prt1) result (ival)
        import
        integer :: ival
        type(prt_t), intent(in) :: prt1
      end function obs_unary_int
   end interface
   abstract interface
      function obs_unary_real (prt1) result (rval)
        import
        real(default) :: rval
        type(prt_t), intent(in) :: prt1
      end function obs_unary_real
   end interface
   abstract interface
      function obs_binary_int (prt1, prt2) result (ival)
        import
        integer :: ival
        type(prt_t), intent(in) :: prt1, prt2
      end function obs_binary_int
   end interface
   abstract interface
      function obs_binary_real (prt1, prt2) result (rval)
        import
        real(default) :: rval
        type(prt_t), intent(in) :: prt1, prt2
      end function obs_binary_real
   end interface
 
 @ %def obs_unary_int obs_unary_real obs_binary_real
 @
 \subsubsection{Initialization}
 Initialize an entry, optionally with a physical value.  We also
 allocate the [[is_known]] flag and set it if the value is set.
 <<Variables: public>>=
   public :: var_entry_init_int
 <<Variables: procedures>>=
   subroutine var_entry_init_log (var, name, lval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_LOG
     allocate (var%lval, var%is_known)
     if (present (lval)) then
        var%lval = lval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_log
 
   subroutine var_entry_init_int (var, name, ival, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_INT
     allocate (var%ival, var%is_known)
     if (present (ival)) then
        var%ival = ival
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_int
 
   subroutine var_entry_init_real (var, name, rval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_REAL
     allocate (var%rval, var%is_known)
     if (present (rval)) then
        var%rval = rval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_real
 
   subroutine var_entry_init_cmplx (var, name, cval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_CMPLX
     allocate (var%cval, var%is_known)
     if (present (cval)) then
        var%cval = cval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_cmplx
 
   subroutine var_entry_init_subevt (var, name, pval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_SEV
     allocate (var%pval, var%is_known)
     if (present (pval)) then
        var%pval = pval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_subevt
 
   subroutine var_entry_init_pdg_array (var, name, aval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_PDG
     allocate (var%aval, var%is_known)
     if (present (aval)) then
        var%aval = aval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_pdg_array
 
   subroutine var_entry_init_string (var, name, sval, intrinsic, user)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: sval
     logical, intent(in), optional :: intrinsic, user
     var%name = name
     var%type = V_STR
     allocate (var%sval, var%is_known)
     if (present (sval)) then
        var%sval = sval
        var%is_defined = .true.
        var%is_known = .true.
     else
        var%is_known = .false.
     end if
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     if (present (user))  var%is_user_var = user
     var%is_allocated = .true.
   end subroutine var_entry_init_string
 
 @ %def var_entry_init_log
 @ %def var_entry_init_int
 @ %def var_entry_init_real
 @ %def var_entry_init_cmplx
 @ %def var_entry_init_subevt
 @ %def var_entry_init_pdg_array
 @ %def var_entry_init_string
 @ Initialize an entry with a pointer to the value and, for numeric/logical
 values, a pointer to the [[is_known]] flag.
 <<Variables: procedures>>=
   subroutine var_entry_init_log_ptr (var, name, lval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     logical, intent(in), target :: lval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_LOG
     var%lval => lval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_log_ptr
 
   subroutine var_entry_init_int_ptr (var, name, ival, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in), target :: ival
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_INT
     var%ival => ival
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_int_ptr
 
   subroutine var_entry_init_real_ptr (var, name, rval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     real(default), intent(in), target :: rval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_REAL
     var%rval => rval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_real_ptr
 
   subroutine var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     complex(default), intent(in), target :: cval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_CMPLX
     var%cval => cval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_cmplx_ptr
 
   subroutine var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), target :: aval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_PDG
     var%aval => aval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_pdg_array_ptr
 
   subroutine var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), target :: pval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_SEV
     var%pval => pval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_subevt_ptr
 
   subroutine var_entry_init_string_ptr (var, name, sval, is_known, intrinsic)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     type(string_t), intent(in), target :: sval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: intrinsic
     var%name = name
     var%type = V_STR
     var%sval => sval
     var%is_known => is_known
     if (present (intrinsic))  var%is_intrinsic = intrinsic
     var%is_defined = .true.
   end subroutine var_entry_init_string_ptr
 
 @ %def var_entry_init_log_ptr
 @ %def var_entry_init_int_ptr
 @ %def var_entry_init_real_ptr
 @ %def var_entry_init_cmplx_ptr
 @ %def var_entry_init_pdg_array_ptr
 @ %def var_entry_init_subevt_ptr
 @ %def var_entry_init_string_ptr
 @ Initialize an entry with an observable.  The procedure pointer is
 not yet set.
 <<Variables: procedures>>=
   subroutine var_entry_init_obs (var, name, type, prt1, prt2)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in) :: type
     type(prt_t), intent(in), target :: prt1
     type(prt_t), intent(in), optional, target :: prt2
     var%type = type
     var%name = name
     var%prt1 => prt1
     if (present (prt2))  var%prt2 => prt2
     var%is_intrinsic = .true.
     var%is_defined = .true.
   end subroutine var_entry_init_obs
 
 @ %def var_entry_init_obs
 @ Mark an entry as undefined it it is a user-defined variable object, so force
 re-initialization.
 <<Variables: procedures>>=
   subroutine var_entry_undefine (var)
     type(var_entry_t), intent(inout) :: var
     var%is_defined = .not. var%is_user_var
     var%is_known = var%is_defined .and. var%is_known
   end subroutine var_entry_undefine
 
 @ %def var_entry_undefine
 @ Clear an entry: mark it as unknown.
 <<Variables: procedures>>=
   subroutine var_entry_clear (var)
     type(var_entry_t), intent(inout) :: var
     var%is_known = .false.
   end subroutine var_entry_clear
 
 @ %def var_entry_clear
 @ Lock an entry: forbid resetting the entry after initialization.
 <<Variables: procedures>>=
   subroutine var_entry_lock (var, locked)
     type(var_entry_t), intent(inout) :: var
     logical, intent(in), optional :: locked
     if (present (locked)) then
        var%is_locked = locked
     else
        var%is_locked = .true.
     end if
   end subroutine var_entry_lock
 
 @ %def var_entry_lock
 @
 \subsubsection{Finalizer}
 <<Variables: procedures>>=
   subroutine var_entry_final (var)
     type(var_entry_t), intent(inout) :: var
     if (var%is_allocated) then
        select case (var%type)
        case (V_LOG); deallocate (var%lval)
        case (V_INT); deallocate (var%ival)
        case (V_REAL);deallocate (var%rval)
        case (V_CMPLX);deallocate (var%cval)
        case (V_SEV); deallocate (var%pval)
        case (V_PDG); deallocate (var%aval)
        case (V_STR); deallocate (var%sval)
        end select
        deallocate (var%is_known)
        var%is_allocated = .false.
        var%is_defined = .false.
     end if
   end subroutine var_entry_final
 
 @ %def var_entry_final
 @
 \subsubsection{Output}
 <<Variables: procedures>>=
   recursive subroutine var_entry_write (var, unit, model_name, &
        intrinsic, pacified, descriptions, ascii_output)
     type(var_entry_t), intent(in) :: var
     integer, intent(in), optional :: unit
     type(string_t), intent(in), optional :: model_name
     logical, intent(in), optional :: intrinsic
     logical, intent(in), optional :: pacified
     logical, intent(in), optional :: descriptions
     logical, intent(in), optional :: ascii_output
     type(string_t) :: col_string
     logical :: show_desc, ao
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     show_desc = .false.; if (present (descriptions))  show_desc = descriptions
     ao = .false.; if (present (ascii_output))  ao = ascii_output
     if (show_desc) then
        if (ao) then
           col_string = create_col_string (COL_BLUE)
           if (var%is_locked) then
              write (u, "(A)", advance="no") char (achar(27) // col_string) // &
                   char (var%name) // achar(27) // "[0m" //" fixed-value="
           else
              write (u, "(A)", advance="no") char (achar(27) // col_string) // &
                   char (var%name) // achar(27) // "[0m" //" default="
           end if
           col_string = create_col_string (COL_RED)
           write (u, "(A)", advance="no") char (achar(27) // col_string)
           call var_write_val (var, u, "no", pacified=.true.)
           write (u, "(A)") achar(27) // "[0m"
           write (u, "(A)")  char (var%description)
           return
        else
           write (u, "(A)")  "\item"
           write (u, "(A)", advance="no")  "\ttt{" // char ( &
                replace (replace (var%name, "_", "\_", every=.true.), "$", "\$" )) // &
                "} "
           if (var%is_known) then
              if (var%is_locked) then
                 write (u, "(A)", advance="no")  "\qquad (fixed value: \ttt{"
              else
                 write (u, "(A)", advance="no")  "\qquad (default: \ttt{"
              end if
              call var_write_val (var, u, "no", pacified=.true., escape_tex=.true.)
              write (u, "(A)", advance="no")  "})"
           end if
           write (u, "(A)") " \newline"
           write (u, "(A)") char (var%description)
           write (u, "(A)") "%%%%%"
           return
        end if
     end if
     if (present (intrinsic)) then
        if (var%is_intrinsic .neqv. intrinsic)  return
     end if
     if (.not. var%is_defined) then
        write (u, "(A,1x)", advance="no")  "[undefined]"
     end if
     if (.not. var%is_intrinsic) then
        write (u, "(A,1x)", advance="no")  "[user variable]"
     end if
     if (present (model_name)) then
        write (u, "(A,A)", advance="no")  char(model_name), "."
     end if
     write (u, "(A)", advance="no")  char (var%name)
     if (var%is_locked)  write (u, "(A)", advance="no")  "*"
     if (var%is_allocated) then
        write (u, "(A)", advance="no")  " = "
     else if (var%type /= V_NONE) then
        write (u, "(A)", advance="no")  " => "
     end if
     call var_write_val (var, u, "yes", pacified)
   end subroutine var_entry_write
 
 @ %def var_entry_write
 @
 <<Variables: procedures>>=
   subroutine var_write_val (var, u, advance, pacified, escape_tex)
     type(var_entry_t), intent(in) :: var
     integer, intent(in) :: u
     character(*), intent(in) :: advance
     logical, intent(in), optional :: pacified, escape_tex
     logical :: num_pac, et
     real(default) :: rval
     complex(default) :: cval
     character(len=7) :: fmt
     call pac_fmt (fmt, FMT_19, FMT_12, pacified)
     num_pac = .false.; if (present (pacified))  num_pac = pacified
     et = .false.; if (present (escape_tex))  et = escape_tex
     select case (var%type)
     case (V_NONE); write (u, '()', advance=advance)
     case (V_LOG)
        if (var%is_known) then
           if (var%lval) then
              write (u, "(A)", advance=advance)  "true"
           else
              write (u, "(A)", advance=advance)  "false"
           end if
        else
           write (u, "(A)", advance=advance)  "[unknown logical]"
        end if
     case (V_INT)
        if (var%is_known) then
           write (u, "(I0)", advance=advance)  var%ival
        else
           write (u, "(A)", advance=advance)  "[unknown integer]"
        end if
     case (V_REAL)
        if (var%is_known) then
           rval = var%rval
           if (num_pac) then
              call pacify (rval, 10 * eps0)
           end if
           write (u, "(" // fmt // ")", advance=advance)  rval
        else
           write (u, "(A)", advance=advance)  "[unknown real]"
        end if
     case (V_CMPLX)
        if (var%is_known) then
           cval = var%cval
           if (num_pac) then
              call pacify (cval, 10 * eps0)
           end if
           write (u, "('('," // fmt // ",','," // fmt // ",')')", advance=advance)  cval
        else
           write (u, "(A)", advance=advance)  "[unknown complex]"
        end if
     case (V_SEV)
        if (var%is_known) then
           call subevt_write (var%pval, u, prefix="       ", &
                pacified = pacified)
        else
           write (u, "(A)", advance=advance)  "[unknown subevent]"
        end if
     case (V_PDG)
        if (var%is_known) then
           call pdg_array_write (var%aval, u);  write (u, *)
        else
           write (u, "(A)", advance=advance)  "[unknown PDG array]"
        end if
     case (V_STR)
        if (var%is_known) then
           if (et) then
              write (u, "(A)", advance=advance)  '"' // char (replace ( &
                   replace (var%sval, "_", "\_", every=.true.), "$", "\$" )) // '"'
           else
              write (u, "(A)", advance=advance)  '"' // char (var%sval) // '"'
           end if
        else
           write (u, "(A)", advance=advance)  "[unknown string]"
        end if
     case (V_OBS1_INT);  write (u, "(A)", advance=advance) "[int] = unary observable"
     case (V_OBS2_INT);  write (u, "(A)", advance=advance) "[int] = binary observable"
     case (V_OBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary observable"
     case (V_OBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary observable"
     case (V_UOBS1_INT);  write (u, "(A)", advance=advance) "[int] = unary user observable"
     case (V_UOBS2_INT);  write (u, "(A)", advance=advance) "[int] = binary user observable"
     case (V_UOBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary user observable"
     case (V_UOBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary user observable"
     end select
   end subroutine var_write_val
 
 @ %def procedure
 @
 \subsubsection{Accessing contents}
 <<Variables: procedures>>=
   function var_entry_get_name (var) result (name)
     type(string_t) :: name
     type(var_entry_t), intent(in) :: var
     name = var%name
   end function var_entry_get_name
 
   function var_entry_get_type (var) result (type)
     integer :: type
     type(var_entry_t), intent(in) :: var
     type = var%type
   end function var_entry_get_type
 
 @ %def var_entry_get_name var_entry_get_type
 @ Return true if the variable is defined.  This the case if it is allocated
 and known, or if it is a pointer.
 <<Variables: procedures>>=
   function var_entry_is_defined (var) result (defined)
     logical :: defined
     type(var_entry_t), intent(in) :: var
     defined = var%is_defined
   end function var_entry_is_defined
 
 @ %def var_entry_is_defined
 @ Return true if the variable is locked.  If [[force]] is active,
 always return false.
 <<Variables: procedures>>=
   function var_entry_is_locked (var, force) result (locked)
     logical :: locked
     type(var_entry_t), intent(in) :: var
     logical, intent(in), optional :: force
     if (present (force)) then
        if (force) then
           locked = .false.;  return
        end if
     end if
     locked = var%is_locked
   end function var_entry_is_locked
 
 @ %def var_entry_is_locked
 @ Return true if the variable is intrinsic
 <<Variables: procedures>>=
   function var_entry_is_intrinsic (var) result (flag)
     logical :: flag
     type(var_entry_t), intent(in) :: var
     flag = var%is_intrinsic
   end function var_entry_is_intrinsic
 
 @ %def var_entry_is_intrinsic
 @ Return components
 <<Variables: procedures>>=
   function var_entry_is_known (var) result (flag)
     logical :: flag
     type(var_entry_t), intent(in) :: var
     flag = var%is_known
   end function var_entry_is_known
 
   function var_entry_get_lval (var) result (lval)
     logical :: lval
     type(var_entry_t), intent(in) :: var
     lval = var%lval
   end function var_entry_get_lval
 
   function var_entry_get_ival (var) result (ival)
     integer :: ival
     type(var_entry_t), intent(in) :: var
     ival = var%ival
   end function var_entry_get_ival
 
   function var_entry_get_rval (var) result (rval)
     real(default) :: rval
     type(var_entry_t), intent(in) :: var
     rval = var%rval
   end function var_entry_get_rval
 
   function var_entry_get_cval (var) result (cval)
     complex(default) :: cval
     type(var_entry_t), intent(in) :: var
     cval = var%cval
   end function var_entry_get_cval
 
   function var_entry_get_aval (var) result (aval)
     type(pdg_array_t) :: aval
     type(var_entry_t), intent(in) :: var
     aval = var%aval
   end function var_entry_get_aval
 
   function var_entry_get_pval (var) result (pval)
     type(subevt_t) :: pval
     type(var_entry_t), intent(in) :: var
     pval = var%pval
   end function var_entry_get_pval
 
   function var_entry_get_sval (var) result (sval)
     type(string_t) :: sval
     type(var_entry_t), intent(in) :: var
     sval = var%sval
   end function var_entry_get_sval
 
 @ %def var_entry_get_lval
 @ %def var_entry_get_ival
 @ %def var_entry_get_rval
 @ %def var_entry_get_cval
 @ %def var_entry_get_aval
 @ %def var_entry_get_pval
 @ %def var_entry_get_sval
 @ Return pointers to components.
 <<Variables: procedures>>=
   function var_entry_get_known_ptr (var) result (ptr)
     logical, pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%is_known
   end function var_entry_get_known_ptr
 
   function var_entry_get_lval_ptr (var) result (ptr)
     logical, pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%lval
   end function var_entry_get_lval_ptr
 
   function var_entry_get_ival_ptr (var) result (ptr)
     integer, pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%ival
   end function var_entry_get_ival_ptr
 
   function var_entry_get_rval_ptr (var) result (ptr)
     real(default), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%rval
   end function var_entry_get_rval_ptr
 
   function var_entry_get_cval_ptr (var) result (ptr)
     complex(default), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%cval
   end function var_entry_get_cval_ptr
 
   function var_entry_get_pval_ptr (var) result (ptr)
     type(subevt_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%pval
   end function var_entry_get_pval_ptr
 
   function var_entry_get_aval_ptr (var) result (ptr)
     type(pdg_array_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%aval
   end function var_entry_get_aval_ptr
 
   function var_entry_get_sval_ptr (var) result (ptr)
     type(string_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%sval
   end function var_entry_get_sval_ptr
 
 @ %def var_entry_get_known_ptr
 @ %def var_entry_get_lval_ptr var_entry_get_ival_ptr var_entry_get_rval_ptr
 @ %def var_entry_get_cval_ptr var_entry_get_aval_ptr var_entry_get_pval_ptr
 @ %def var_entry_get_sval_ptr
 @ Furthermore,
 <<Variables: procedures>>=
   function var_entry_get_prt1_ptr (var) result (ptr)
     type(prt_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%prt1
   end function var_entry_get_prt1_ptr
 
   function var_entry_get_prt2_ptr (var) result (ptr)
     type(prt_t), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%prt2
   end function var_entry_get_prt2_ptr
 
 @ %def var_entry_get_prt1_ptr
 @ %def var_entry_get_prt2_ptr
 @ Subroutines might be safer than functions for procedure pointer transfer.
 <<Variables: procedures>>=
   subroutine var_entry_assign_obs1_int_ptr (ptr, var)
     procedure(obs_unary_int), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs1_int
   end subroutine var_entry_assign_obs1_int_ptr
 
   subroutine var_entry_assign_obs1_real_ptr (ptr, var)
     procedure(obs_unary_real), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs1_real
   end subroutine var_entry_assign_obs1_real_ptr
 
   subroutine var_entry_assign_obs2_int_ptr (ptr, var)
     procedure(obs_binary_int), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs2_int
   end subroutine var_entry_assign_obs2_int_ptr
 
   subroutine var_entry_assign_obs2_real_ptr (ptr, var)
     procedure(obs_binary_real), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obs2_real
   end subroutine var_entry_assign_obs2_real_ptr
 
 @ %def var_entry_assign_obs1_int_ptr var_entry_assign_obs1_real_ptr
 @ %def var_entry_assign_obs2_int_ptr var_entry_assign_obs2_real_ptr
 @
 \subsection{Setting values}
 Undefine the value.
 <<Variables: procedures>>=
   subroutine var_entry_clear_value (var)
     type(var_entry_t), intent(inout) :: var
     var%is_known = .false.
   end subroutine var_entry_clear_value
 
 @ %def var_entry_clear_value
 <<Variables: procedures>>=
   recursive subroutine var_entry_set_log &
        (var, lval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     logical, intent(in) :: lval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%lval = lval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_log
 
   recursive subroutine var_entry_set_int &
        (var, ival, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     integer, intent(in) :: ival
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%ival = ival
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_int
 
   recursive subroutine var_entry_set_real &
        (var, rval, is_known, verbose, model_name, pacified)
     type(var_entry_t), intent(inout) :: var
     real(default), intent(in) :: rval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose, pacified
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%rval = rval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write &
                (var, model_name=model_name, pacified = pacified)
           call var_entry_write &
                (var, model_name=model_name, unit=u, pacified = pacified)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_real
 
   recursive subroutine var_entry_set_cmplx &
        (var, cval, is_known, verbose, model_name, pacified)
     type(var_entry_t), intent(inout) :: var
     complex(default), intent(in) :: cval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose, pacified
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%cval = cval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write &
                (var, model_name=model_name, pacified = pacified)
           call var_entry_write &
                (var, model_name=model_name, unit=u, pacified = pacified)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_cmplx
 
   recursive subroutine var_entry_set_pdg_array &
        (var, aval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     type(pdg_array_t), intent(in) :: aval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%aval = aval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_pdg_array
 
   recursive subroutine var_entry_set_subevt &
        (var, pval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     type(subevt_t), intent(in) :: pval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%pval = pval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_subevt
 
   recursive subroutine var_entry_set_string &
        (var, sval, is_known, verbose, model_name)
     type(var_entry_t), intent(inout) :: var
     type(string_t), intent(in) :: sval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: verbose
     type(string_t), intent(in), optional :: model_name
     integer :: u
     u = logfile_unit ()
     var%sval = sval
     var%is_known = is_known
     var%is_defined = .true.
     if (present (verbose)) then
        if (verbose) then
           call var_entry_write (var, model_name=model_name)
           call var_entry_write (var, model_name=model_name, unit=u)
           if (u >= 0) flush (u)
        end if
     end if
   end subroutine var_entry_set_string
 
 @ %def var_entry_set_log
 @ %def var_entry_set_int
 @ %def var_entry_set_real
 @ %def var_entry_set_cmplx
 @ %def var_entry_set_pdg_array
 @ %def var_entry_set_subevt
 @ %def var_entry_set_string
 @
 <<Variables: public>>=
   public :: var_entry_set_description
 <<Variables: procedures>>=
   pure subroutine var_entry_set_description (var_entry, description)
     type(var_entry_t), intent(inout) :: var_entry
     type(string_t), intent(in) :: description
     var_entry%description = description
   end subroutine var_entry_set_description
 
 @ %def var_entry_set_description
 @
 \subsection{Copies and pointer variables}
 Initialize an entry with a copy of an existing variable entry.  The
 copy is physically allocated with the same type as the original.
 <<Variables: procedures>>=
   subroutine var_entry_init_copy (var, original, user)
     type(var_entry_t), intent(out) :: var
     type(var_entry_t), intent(in), target :: original
     logical, intent(in), optional :: user
     type(string_t) :: name
     logical :: intrinsic
     name = var_entry_get_name (original)
     intrinsic = original%is_intrinsic
     select case (original%type)
     case (V_LOG)
        call var_entry_init_log (var, name, intrinsic=intrinsic, user=user)
     case (V_INT)
        call var_entry_init_int (var, name, intrinsic=intrinsic, user=user)
     case (V_REAL)
        call var_entry_init_real (var, name, intrinsic=intrinsic, user=user)
     case (V_CMPLX)
        call var_entry_init_cmplx (var, name, intrinsic=intrinsic, user=user)
     case (V_SEV)
        call var_entry_init_subevt (var, name, intrinsic=intrinsic, user=user)
     case (V_PDG)
        call var_entry_init_pdg_array (var, name, intrinsic=intrinsic, user=user)
     case (V_STR)
        call var_entry_init_string (var, name, intrinsic=intrinsic, user=user)
     end select
   end subroutine var_entry_init_copy
 
 @ %def var_entry_init_copy
 @ Copy the value of an entry.  The target variable entry must be initialized
 correctly.
 <<Variables: procedures>>=
   subroutine var_entry_copy_value (var, original)
     type(var_entry_t), intent(inout) :: var
     type(var_entry_t), intent(in), target :: original
     if (var_entry_is_known (original)) then
        select case (original%type)
        case (V_LOG)
           call var_entry_set_log (var, var_entry_get_lval (original), .true.)
        case (V_INT)
           call var_entry_set_int (var, var_entry_get_ival (original), .true.)
        case (V_REAL)
           call var_entry_set_real (var, var_entry_get_rval (original), .true.)
        case (V_CMPLX)
           call var_entry_set_cmplx (var, var_entry_get_cval (original), .true.)
        case (V_SEV)
           call var_entry_set_subevt (var, var_entry_get_pval (original), .true.)
        case (V_PDG)
           call var_entry_set_pdg_array (var, var_entry_get_aval (original), .true.)
        case (V_STR)
           call var_entry_set_string (var, var_entry_get_sval (original), .true.)
        end select
     else
        call var_entry_clear (var)
     end if
   end subroutine var_entry_copy_value
 
 @ %def var_entry_copy_value
 @
 \subsection{Variable lists}
 \subsubsection{The type}
 Variable lists can be linked together.  No initializer needed.
 They are deleted separately.
 <<Variables: public>>=
   public :: var_list_t
 <<Variables: types>>=
   type, extends (vars_t) :: var_list_t
      private
      type(var_entry_t), pointer :: first => null ()
      type(var_entry_t), pointer :: last => null ()
      type(var_list_t), pointer :: next => null ()
    contains
    <<Variables: var list: TBP>>
   end type var_list_t
 
 @ %def var_list_t
 @
 \subsubsection{Constructors}
 Implementation of the [[link]] deferred method.  The implementation
 restricts itself to var lists of the same type.  We might need to
 relax this constraint.
 <<Variables: var list: TBP>>=
   procedure :: link => var_list_link
 <<Variables: procedures>>=
   subroutine var_list_link (vars, target_vars)
     class(var_list_t), intent(inout) :: vars
     class(vars_t), intent(in), target :: target_vars
     select type (target_vars)
     type is (var_list_t)
        vars%next => target_vars
     class default
        call msg_bug ("var_list_link: unsupported target type")
     end select
   end subroutine var_list_link
 
 @ %def var_list_link
 @ Append a new entry to an existing list.
 <<Variables: procedures>>=
   subroutine var_list_append (var_list, var, verbose)
     type(var_list_t), intent(inout), target :: var_list
     type(var_entry_t), intent(inout), target :: var
     logical, intent(in), optional :: verbose
     if (associated (var_list%last)) then
        var%previous => var_list%last
        var_list%last%next => var
     else
        var%previous => null ()
        var_list%first => var
     end if
     var_list%last => var
     if (present (verbose)) then
        if (verbose)  call var_entry_write (var)
     end if
   end subroutine var_list_append
 
 @ %def var_list_append
 @ Sort a list.
 <<Variables: var list: TBP>>=
   procedure :: sort => var_list_sort
 <<Variables: procedures>>=
   subroutine var_list_sort (var_list)
     class(var_list_t), intent(inout) :: var_list
     type(var_entry_t), pointer :: var, previous
     if (associated (var_list%first)) then
        var => var_list%first
        do while (associated (var))
           previous => var%previous
           do while (associated (previous))
              if (larger_var (previous, var)) then
                 call var_list%swap_with_next (previous)
              end if
              previous => previous%previous
           end do
           var => var%next
        end do
     end if
   end subroutine var_list_sort
 
 @ %def var_list_sort
 @
 <<Variables: procedures>>=
   pure function larger_var (var1, var2) result (larger)
     logical :: larger
     type(var_entry_t), intent(in) :: var1, var2
     type(string_t) :: str1, str2
     str1 = replace (var1%name, "?", "")
     str1 = replace (str1, "$", "")
     str2 = replace (var2%name, "?", "")
     str2 = replace (str2, "$", "")
     larger = str1 > str2
   end function larger_var
 
 @ %def larger_var
 @
 <<Variables: var list: TBP>>=
   procedure :: get_previous => var_list_get_previous
 <<Variables: procedures>>=
   function var_list_get_previous (var_list, var_entry) result (previous)
     type(var_entry_t), pointer :: previous
     class(var_list_t), intent(in) :: var_list
     type(var_entry_t), intent(in) :: var_entry
     previous => var_list%first
     if (previous%name == var_entry%name) then
        previous => null ()
     else
        do while (associated (previous))
           if (previous%next%name == var_entry%name) exit
           previous => previous%next
        end do
     end if
   end function var_list_get_previous
 
 @ %def var_list_get_previous
 @
 <<Variables: var list: TBP>>=
   procedure :: swap_with_next => var_list_swap_with_next
 <<Variables: procedures>>=
   subroutine var_list_swap_with_next (var_list, var_entry)
     class(var_list_t), intent(inout) :: var_list
     type(var_entry_t), intent(in) :: var_entry
     type(var_entry_t), pointer :: previous, this, next, next_next
     previous => var_list%get_previous (var_entry)
     if (.not. associated (previous)) then
        this => var_list%first
     else
        this => previous%next
     end if
     next => this%next
     next_next => next%next
     if (associated (previous)) then
        previous%next => next
        next%previous => previous
     else
        var_list%first => next
        next%previous => null ()
     end if
     this%next => next_next
     if (associated (next_next)) then
        next_next%previous => this
     end if
     next%next => this
     this%previous => next
     if (.not. associated (next%next)) then
        var_list%last => next
     end if
   end subroutine var_list_swap_with_next
 
 @ %def var_list_swap_with_next
 @ Public methods for expanding the variable list (as subroutines)
 <<Variables: var list: TBP>>=
   generic :: append_log => var_list_append_log_s, var_list_append_log_c
   procedure, private :: var_list_append_log_s
   procedure, private :: var_list_append_log_c
   generic :: append_int => var_list_append_int_s, var_list_append_int_c
   procedure, private :: var_list_append_int_s
   procedure, private :: var_list_append_int_c
   generic :: append_real => var_list_append_real_s, var_list_append_real_c
   procedure, private :: var_list_append_real_s
   procedure, private :: var_list_append_real_c
   generic :: append_cmplx => var_list_append_cmplx_s, var_list_append_cmplx_c
   procedure, private :: var_list_append_cmplx_s
   procedure, private :: var_list_append_cmplx_c
   generic :: append_subevt => var_list_append_subevt_s, var_list_append_subevt_c
   procedure, private :: var_list_append_subevt_s
   procedure, private :: var_list_append_subevt_c
   generic :: append_pdg_array => var_list_append_pdg_array_s, var_list_append_pdg_array_c
   procedure, private :: var_list_append_pdg_array_s
   procedure, private :: var_list_append_pdg_array_c
   generic :: append_string => var_list_append_string_s, var_list_append_string_c
   procedure, private :: var_list_append_string_s
   procedure, private :: var_list_append_string_c
 <<Variables: public>>=
   public :: var_list_append_log
   public :: var_list_append_int
   public :: var_list_append_real
   public :: var_list_append_cmplx
   public :: var_list_append_subevt
   public :: var_list_append_pdg_array
   public :: var_list_append_string
 <<Variables: interfaces>>=
   interface var_list_append_log
      module procedure var_list_append_log_s
      module procedure var_list_append_log_c
   end interface
   interface var_list_append_int
      module procedure var_list_append_int_s
      module procedure var_list_append_int_c
   end interface
   interface var_list_append_real
      module procedure var_list_append_real_s
      module procedure var_list_append_real_c
   end interface
   interface var_list_append_cmplx
      module procedure var_list_append_cmplx_s
      module procedure var_list_append_cmplx_c
   end interface
   interface var_list_append_subevt
      module procedure var_list_append_subevt_s
      module procedure var_list_append_subevt_c
   end interface
   interface var_list_append_pdg_array
      module procedure var_list_append_pdg_array_s
      module procedure var_list_append_pdg_array_c
   end interface
   interface var_list_append_string
      module procedure var_list_append_string_s
      module procedure var_list_append_string_c
   end interface
 <<Variables: procedures>>=
   subroutine var_list_append_log_s &
        (var_list, name, lval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_log (var, name, lval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_log_s
 
   subroutine var_list_append_int_s &
        (var_list, name, ival, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_int (var, name, ival, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_int_s
 
   subroutine var_list_append_real_s &
        (var_list, name, rval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_real (var, name, rval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_real_s
 
   subroutine var_list_append_cmplx_s &
        (var_list, name, cval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_cmplx (var, name, cval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_cmplx_s
 
   subroutine var_list_append_subevt_s &
        (var_list, name, pval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_subevt (var, name, pval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_subevt_s
 
   subroutine var_list_append_pdg_array_s &
        (var_list, name, aval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_pdg_array (var, name, aval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_pdg_array_s
 
   subroutine var_list_append_string_s &
        (var_list, name, sval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in), optional :: sval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_string (var, name, sval, intrinsic, user)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_string_s
 
   subroutine var_list_append_log_c &
        (var_list, name, lval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     logical, intent(in), optional :: lval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_log_s &
          (var_list, var_str (name), lval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_log_c
 
   subroutine var_list_append_int_c &
        (var_list, name, ival, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     integer, intent(in), optional :: ival
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_int_s &
          (var_list, var_str (name), ival, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_int_c
 
   subroutine var_list_append_real_c &
        (var_list, name, rval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     real(default), intent(in), optional :: rval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_real_s &
          (var_list, var_str (name), rval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_real_c
 
   subroutine var_list_append_cmplx_c &
        (var_list, name, cval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     complex(default), intent(in), optional :: cval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_cmplx_s &
          (var_list, var_str (name), cval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_cmplx_c
 
   subroutine var_list_append_subevt_c &
        (var_list, name, pval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     type(subevt_t), intent(in), optional :: pval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_subevt_s &
          (var_list, var_str (name), pval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_subevt_c
 
   subroutine var_list_append_pdg_array_c &
        (var_list, name, aval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     type(pdg_array_t), intent(in), optional :: aval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     call var_list_append_pdg_array_s &
          (var_list, var_str (name), aval, locked, verbose, &
          intrinsic, user, description)
   end subroutine var_list_append_pdg_array_c
 
   subroutine var_list_append_string_c &
        (var_list, name, sval, locked, verbose, intrinsic, user, description)
     class(var_list_t), intent(inout) :: var_list
     character(*), intent(in) :: name
     character(*), intent(in), optional :: sval
     logical, intent(in), optional :: locked, verbose, intrinsic, user
     type(string_t), intent(in), optional :: description
     if (present (sval)) then
        call var_list_append_string_s &
             (var_list, var_str (name), var_str (sval), &
             locked, verbose, intrinsic, user, description)
     else
        call var_list_append_string_s &
             (var_list, var_str (name), &
             locked=locked, verbose=verbose, intrinsic=intrinsic, &
             user=user, description=description)
     end if
   end subroutine var_list_append_string_c
 
 @ %def var_list_append_log
 @ %def var_list_append_int
 @ %def var_list_append_real
 @ %def var_list_append_cmplx
 @ %def var_list_append_subevt
 @ %def var_list_append_pdg_array
 @ %def var_list_append_string
 <<Variables: public>>=
   public :: var_list_append_log_ptr
   public :: var_list_append_int_ptr
   public :: var_list_append_real_ptr
   public :: var_list_append_cmplx_ptr
   public :: var_list_append_pdg_array_ptr
   public :: var_list_append_subevt_ptr
   public :: var_list_append_string_ptr
 <<Variables: var list: TBP>>=
   procedure :: append_log_ptr => var_list_append_log_ptr
   procedure :: append_int_ptr => var_list_append_int_ptr
   procedure :: append_real_ptr => var_list_append_real_ptr
   procedure :: append_cmplx_ptr => var_list_append_cmplx_ptr
   procedure :: append_pdg_array_ptr => var_list_append_pdg_array_ptr
   procedure :: append_subevt_ptr => var_list_append_subevt_ptr
   procedure :: append_string_ptr => var_list_append_string_ptr
 <<Variables: procedures>>=
   subroutine var_list_append_log_ptr &
        (var_list, name, lval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in), target :: lval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_log_ptr (var, name, lval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_log_ptr
 
   subroutine var_list_append_int_ptr &
        (var_list, name, ival, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), target :: ival
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_int_ptr (var, name, ival, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_int_ptr
 
   subroutine var_list_append_real_ptr &
        (var_list, name, rval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     real(default), intent(in), target :: rval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_real_ptr (var, name, rval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_real_ptr
 
   subroutine var_list_append_cmplx_ptr &
        (var_list, name, cval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     complex(default), intent(in), target :: cval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_cmplx_ptr
 
   subroutine var_list_append_pdg_array_ptr &
        (var_list, name, aval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in), target :: aval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_pdg_array_ptr
 
   subroutine var_list_append_subevt_ptr &
        (var_list, name, pval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in), target :: pval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_subevt_ptr
 
   subroutine var_list_append_string_ptr &
        (var_list, name, sval, is_known, locked, verbose, intrinsic, description)
     class(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in), target :: sval
     logical, intent(in), target :: is_known
     logical, intent(in), optional :: locked, verbose, intrinsic
     type(string_t), intent(in), optional :: description
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_string_ptr (var, name, sval, is_known, intrinsic)
     if (present (description))  call var_entry_set_description (var, description)
     if (present (locked))  call var_entry_lock (var, locked)
     call var_list_append (var_list, var, verbose)
   end subroutine var_list_append_string_ptr
 
 @ %def var_list_append_log_ptr
 @ %def var_list_append_int_ptr
 @ %def var_list_append_real_ptr
 @ %def var_list_append_cmplx_ptr
 @ %def var_list_append_pdg_array_ptr
 @ %def var_list_append_subevt_ptr
 @
 \subsubsection{Finalizer}
 Finalize, delete the list entry by entry.  The link itself is kept
 intact.  Follow link and delete recursively only if requested
 explicitly.
 <<Variables: var list: TBP>>=
   procedure :: final => var_list_final
 <<Variables: procedures>>=
   recursive subroutine var_list_final (vars, follow_link)
     class(var_list_t), intent(inout) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     vars%last => null ()
     do while (associated (vars%first))
        var => vars%first
        vars%first => var%next
        call var_entry_final (var)
        deallocate (var)
     end do
     if (present (follow_link)) then
        if (follow_link) then
           if (associated (vars%next)) then
              call vars%next%final (follow_link)
              deallocate (vars%next)
           end if
        end if
     end if
   end subroutine var_list_final
 
 @ %def var_list_final
 @
 \subsubsection{Output}
 Show variable list with precise control over options.  E.g.,
 show only variables of a certain type.
 
 Many options, thus not an ordinary [[write]] method.
 <<Variables: public>>=
   public :: var_list_write
 <<Variables: var list: TBP>>=
   procedure :: write => var_list_write
 <<Variables: procedures>>=
   recursive subroutine var_list_write &
        (var_list, unit, follow_link, only_type, prefix, model_name, &
         intrinsic, pacified, descriptions, ascii_output)
     class(var_list_t), intent(in), target :: var_list
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: follow_link
     integer, intent(in), optional :: only_type
     character(*), intent(in), optional :: prefix
     type(string_t), intent(in), optional :: model_name
     logical, intent(in), optional :: intrinsic
     logical, intent(in), optional :: pacified
     logical, intent(in), optional :: descriptions
     logical, intent(in), optional :: ascii_output
     type(var_entry_t), pointer :: var
     integer :: u, length
     logical :: write_this, write_next
     u = given_output_unit (unit);  if (u < 0)  return
     if (present (prefix))  length = len (prefix)
     var => var_list%first
     if (associated (var)) then
        do while (associated (var))
           if (present (only_type)) then
              write_this = only_type == var%type
           else
              write_this = .true.
           end if
           if (write_this .and. present (prefix)) then
              if (prefix /= extract (var%name, 1, length)) &
                   write_this = .false.
           end if
           if (write_this) then
              call var_entry_write &
                   (var, unit, model_name=model_name, &
                    intrinsic=intrinsic, pacified=pacified, &
                    descriptions=descriptions, ascii_output=ascii_output)
           end if
           var => var%next
        end do
     end if
     if (present (follow_link)) then
        write_next = follow_link .and. associated (var_list%next)
     else
        write_next = associated (var_list%next)
     end if
     if (write_next) then
        call var_list_write (var_list%next, &
             unit, follow_link, only_type, prefix, model_name, &
             intrinsic, pacified)
     end if
   end subroutine var_list_write
 
 @ %def var_list_write
 @ Write only a certain variable.
 <<Variables: public>>=
   public :: var_list_write_var
 <<Variables: var list: TBP>>=
   procedure :: write_var => var_list_write_var
 <<Variables: procedures>>=
   recursive subroutine var_list_write_var &
        (var_list, name, unit, type, follow_link, &
        model_name, pacified, defined, descriptions, ascii_output)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: type
     logical, intent(in), optional :: follow_link
     type(string_t), intent(in), optional :: model_name
     logical, intent(in), optional :: pacified
     logical, intent(in), optional :: defined
     logical, intent(in), optional :: descriptions
     logical, intent(in), optional :: ascii_output
     type(var_entry_t), pointer :: var
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     var => var_list_get_var_ptr &
          (var_list, name, type, follow_link=follow_link, defined=defined)
     if (associated (var)) then
        call var_entry_write &
             (var, unit, model_name = model_name, &
             pacified = pacified, &
             descriptions=descriptions, ascii_output=ascii_output)
     else
        write (u, "(A)")  char (name) // " = [undefined]"
     end if
   end subroutine var_list_write_var
 
 @ %def var_list_write_var
 @
 \subsection{Tools}
 Return a pointer to the variable list linked to by the current one.
 <<Variables: procedures>>=
   function var_list_get_next_ptr (var_list) result (next_ptr)
     type(var_list_t), pointer :: next_ptr
     type(var_list_t), intent(in) :: var_list
     next_ptr => var_list%next
   end function var_list_get_next_ptr
 
 @ %def var_list_get_next_ptr
 @ Used by [[eval_trees]]:
 Return a pointer to the variable with the requested name.  If no such
 name exists, return a null pointer.  In that case, try the next list
 if present, unless [[follow_link]] is unset.  If [[defined]] is set, ignore
 entries that exist but are undefined.
 <<Variables: public>>=
   public :: var_list_get_var_ptr
 <<Variables: procedures>>=
   recursive function var_list_get_var_ptr &
        (var_list, name, type, follow_link, defined) result (var)
     type(var_entry_t), pointer :: var
     type(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: type
     logical, intent(in), optional :: follow_link, defined
     logical :: ignore_undef, search_next
     ignore_undef = .true.;  if (present (defined))  ignore_undef = .not. defined
     var => var_list%first
     if (present (type)) then
        do while (associated (var))
           if (var%type == type) then
              if (var%name == name) then
                 if (ignore_undef .or. var%is_defined)  return
              end if
           end if
           var => var%next
        end do
     else
        do while (associated (var))
           if (var%name == name) then
              if (ignore_undef .or. var%is_defined)  return
           end if
           var => var%next
        end do
     end if
     search_next = associated (var_list%next)
     if (present (follow_link)) &
          search_next = search_next .and. follow_link
     if (search_next) &
          var => var_list_get_var_ptr &
               (var_list%next, name, type, defined=defined)
   end function var_list_get_var_ptr
 
 @ %def var_list_get_var_ptr
 @ Return the variable type
 <<Variables: var list: TBP>>=
   procedure :: get_type => var_list_get_type
 <<Variables: procedures>>=
   function var_list_get_type (var_list, name, follow_link) result (type)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: follow_link
     integer :: type
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, follow_link=follow_link)
     if (associated (var)) then
        type = var%type
     else
        type = V_NONE
     end if
   end function var_list_get_type
 
 @ %def var_list_get_type
 @ Return true if the variable exists in the current list.
 <<Variables: var list: TBP>>=
   procedure :: contains => var_list_exists
 <<Variables: procedures>>=
   function var_list_exists (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     lval = associated (var)
   end function var_list_exists
 
 @ %def var_list_exists
 @ Return true if the variable is declared as intrinsic.  (This is not a
 property of the abstract [[vars_t]] type, and therefore the method is
 not inherited.)
 <<Variables: var list: TBP>>=
   procedure :: is_intrinsic => var_list_is_intrinsic
 <<Variables: procedures>>=
   function var_list_is_intrinsic (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        lval = var%is_intrinsic
     else
        lval = .false.
     end if
   end function var_list_is_intrinsic
 
 @ %def var_list_is_intrinsic
 @ Return true if the value is known.
 <<Variables: var list: TBP>>=
   procedure :: is_known => var_list_is_known
 <<Variables: procedures>>=
   function var_list_is_known (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        lval = var%is_known
     else
        lval = .false.
     end if
   end function var_list_is_known
 
 @ %def var_list_is_known
 @ Return true if the value is locked.  (This is not a
 property of the abstract [[vars_t]] type, and therefore the method is
 not inherited.)
 <<Variables: var list: TBP>>=
   procedure :: is_locked => var_list_is_locked
 <<Variables: procedures>>=
   function var_list_is_locked (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        lval = var_entry_is_locked (var)
     else
        lval = .false.
     end if
   end function var_list_is_locked
 
 @ %def var_list_is_locked
 @ Return several properties at once.
 <<Variables: var list: TBP>>=
   procedure :: get_var_properties => var_list_get_var_properties
 <<Variables: procedures>>=
   subroutine var_list_get_var_properties (vars, name, req_type, follow_link, &
        type, is_defined, is_known, is_locked)
     class(var_list_t), intent(in) :: vars
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: req_type
     logical, intent(in), optional :: follow_link
     integer, intent(out), optional :: type
     logical, intent(out), optional :: is_defined, is_known, is_locked
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, type=req_type, follow_link=follow_link)
     if (associated (var)) then
        if (present (type))  type = var_entry_get_type (var)
        if (present (is_defined))  is_defined = var_entry_is_defined (var)
        if (present (is_known))  is_known = var_entry_is_known (var)
        if (present (is_locked))  is_locked = var_entry_is_locked (var)
     else
        if (present (type))  type = V_NONE
        if (present (is_defined))  is_defined = .false.
        if (present (is_known))  is_known = .false.
        if (present (is_locked))  is_locked = .false.
     end if
   end subroutine var_list_get_var_properties
 
 @ %def var_list_get_var_properties
 @ Return the value, assuming that the type is correct.  We consider only
 variable entries that have been [[defined]].
 
 For convenience, allow both variable and fixed-length (literal) strings.
 <<Variables: var list: TBP>>=
   procedure :: get_lval => var_list_get_lval
   procedure :: get_ival => var_list_get_ival
   procedure :: get_rval => var_list_get_rval
   procedure :: get_cval => var_list_get_cval
   procedure :: get_pval => var_list_get_pval
   procedure :: get_aval => var_list_get_aval
   procedure :: get_sval => var_list_get_sval
 <<Variables: procedures>>=
   function var_list_get_lval (vars, name, follow_link) result (lval)
     logical :: lval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_LOG, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           lval = var%lval
        else
           lval = .false.
        end if
     else
        lval = .false.
     end if
   end function var_list_get_lval
 
   function var_list_get_ival (vars, name, follow_link) result (ival)
     integer :: ival
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_INT, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           ival = var%ival
        else
           ival = 0
        end if
     else
        ival = 0
     end if
   end function var_list_get_ival
 
   function var_list_get_rval (vars, name, follow_link) result (rval)
     real(default) :: rval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_REAL, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           rval = var%rval
        else
           rval = 0
        end if
     else
        rval = 0
     end if
   end function var_list_get_rval
 
   function var_list_get_cval (vars, name, follow_link) result (cval)
     complex(default) :: cval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_CMPLX, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           cval = var%cval
        else
           cval = 0
        end if
     else
        cval = 0
     end if
   end function var_list_get_cval
 
   function var_list_get_aval (vars, name, follow_link) result (aval)
     type(pdg_array_t) :: aval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_PDG, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           aval = var%aval
        end if
     end if
   end function var_list_get_aval
 
   function var_list_get_pval (vars, name, follow_link) result (pval)
     type(subevt_t) :: pval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_SEV, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           pval = var%pval
        end if
     end if
   end function var_list_get_pval
 
   function var_list_get_sval (vars, name, follow_link) result (sval)
     type(string_t) :: sval
     type(string_t), intent(in) :: name
     class(var_list_t), intent(in) :: vars
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr &
          (vars, name, V_STR, follow_link, defined=.true.)
     if (associated (var)) then
        if (var_has_value (var)) then
           sval = var%sval
        else
           sval = ""
        end if
     else
        sval = ""
     end if
   end function var_list_get_sval
 
 @ %def var_list_get_lval
 @ %def var_list_get_ival
 @ %def var_list_get_rval
 @ %def var_list_get_cval
 @ %def var_list_get_pval
 @ %def var_list_get_aval
 @ %def var_list_get_sval
 @ Check for a valid value, given a pointer.  Issue error messages if invalid.
 <<Variables: procedures>>=
   function var_has_value (var) result (valid)
     logical :: valid
     type(var_entry_t), pointer :: var
     if (associated (var)) then
        if (var%is_known) then
           valid = .true.
        else
           call msg_error ("The value of variable '" // char (var%name) &
                // "' is unknown but must be known at this point.")
           valid = .false.
        end if
     else
        call msg_error ("Variable '" // char (var%name) &
             // "' is undefined but must have a known value at this point.")
        valid = .false.
     end if
   end function var_has_value
 
 @ %def var_has_value
 @ Return pointers instead of values, including a pointer to the
 [[known]] entry.
 <<Variables: var list: TBP>>=
   procedure :: get_lptr => var_list_get_lptr
   procedure :: get_iptr => var_list_get_iptr
   procedure :: get_rptr => var_list_get_rptr
   procedure :: get_cptr => var_list_get_cptr
   procedure :: get_aptr => var_list_get_aptr
   procedure :: get_pptr => var_list_get_pptr
   procedure :: get_sptr => var_list_get_sptr
 <<Variables: procedures>>=
   subroutine var_list_get_lptr (var_list, name, lptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     logical, pointer, intent(out) :: lptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_LOG)
     if (associated (var)) then
        lptr => var_entry_get_lval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        lptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_lptr
 
   subroutine var_list_get_iptr (var_list, name, iptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     integer, pointer, intent(out) :: iptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_INT)
     if (associated (var)) then
        iptr => var_entry_get_ival_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        iptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_iptr
 
   subroutine var_list_get_rptr (var_list, name, rptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     real(default), pointer, intent(out) :: rptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_REAL)
     if (associated (var)) then
        rptr => var_entry_get_rval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        rptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_rptr
 
   subroutine var_list_get_cptr (var_list, name, cptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     complex(default), pointer, intent(out) :: cptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_CMPLX)
     if (associated (var)) then
        cptr => var_entry_get_cval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        cptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_cptr
 
   subroutine var_list_get_aptr (var_list, name, aptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), pointer, intent(out) :: aptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_PDG)
     if (associated (var)) then
        aptr => var_entry_get_aval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        aptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_aptr
 
   subroutine var_list_get_pptr (var_list, name, pptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), pointer, intent(out) :: pptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_SEV)
     if (associated (var)) then
        pptr => var_entry_get_pval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        pptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_pptr
 
   subroutine var_list_get_sptr (var_list, name, sptr, known)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     type(string_t), pointer, intent(out) :: sptr
     logical, pointer, intent(out), optional :: known
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_STR)
     if (associated (var)) then
        sptr => var_entry_get_sval_ptr (var)
        if (present (known))  known => var_entry_get_known_ptr (var)
     else
        sptr => null ()
        if (present (known))  known => null ()
     end if
   end subroutine var_list_get_sptr
 
 @ %def var_list_get_lptr
 @ %def var_list_get_iptr
 @ %def var_list_get_rptr
 @ %def var_list_get_cptr
 @ %def var_list_get_aptr
 @ %def var_list_get_pptr
 @ %def var_list_get_sptr
 @
 This bunch of methods handles the procedure-pointer cases.
 <<Variables: var list: TBP>>=
   procedure :: get_obs1_iptr => var_list_get_obs1_iptr
   procedure :: get_obs2_iptr => var_list_get_obs2_iptr
   procedure :: get_obs1_rptr => var_list_get_obs1_rptr
   procedure :: get_obs2_rptr => var_list_get_obs2_rptr
 <<Variables: procedures>>=
   subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr
     type(prt_t), pointer, intent(out) :: p1
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS1_INT)
     if (associated (var)) then
        call var_entry_assign_obs1_int_ptr (obs1_iptr, var)
        p1 => var_entry_get_prt1_ptr (var)
     else
        obs1_iptr => null ()
        p1 => null ()
     end if
   end subroutine var_list_get_obs1_iptr
 
   subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr
     type(prt_t), pointer, intent(out) :: p1, p2
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS2_INT)
     if (associated (var)) then
        call var_entry_assign_obs2_int_ptr (obs2_iptr, var)
        p1 => var_entry_get_prt1_ptr (var)
        p2 => var_entry_get_prt2_ptr (var)
     else
        obs2_iptr => null ()
        p1 => null ()
        p2 => null ()
     end if
   end subroutine var_list_get_obs2_iptr
 
   subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr
     type(prt_t), pointer, intent(out) :: p1
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS1_REAL)
     if (associated (var)) then
        call var_entry_assign_obs1_real_ptr (obs1_rptr, var)
        p1 => var_entry_get_prt1_ptr (var)
     else
        obs1_rptr => null ()
        p1 => null ()
     end if
   end subroutine var_list_get_obs1_rptr
 
   subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr
     type(prt_t), pointer, intent(out) :: p1, p2
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBS2_REAL)
     if (associated (var)) then
        call var_entry_assign_obs2_real_ptr (obs2_rptr, var)
        p1 => var_entry_get_prt1_ptr (var)
        p2 => var_entry_get_prt2_ptr (var)
     else
        obs2_rptr => null ()
        p1 => null ()
        p2 => null ()
     end if
   end subroutine var_list_get_obs2_rptr
 
 @ %def var_list_get_obs1_iptr
 @ %def var_list_get_obs2_iptr
 @ %def var_list_get_obs1_rptr
 @ %def var_list_get_obs2_rptr
 @
 \subsection{Process Result Variables}
 These variables are associated to process (integration) runs and their
 results.  Their names contain brackets (so they look like function
 evaluations), therefore we need to special-case them.
 <<Variables: public>>=
   public :: var_list_set_procvar_int
   public :: var_list_set_procvar_real
 <<Variables: procedures>>=
   subroutine var_list_set_procvar_int (var_list, proc_id, name, ival)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: proc_id
     type(string_t), intent(in) :: name
     integer, intent(in), optional :: ival
     type(string_t) :: var_name
     type(var_entry_t), pointer :: var
     var_name = name // "(" // proc_id // ")"
     var => var_list_get_var_ptr (var_list, var_name)
     if (.not. associated (var)) then
        call var_list%append_int (var_name, ival, intrinsic=.true.)
     else if (present (ival)) then
        call var_list%set_int (var_name, ival, is_known=.true.)
     end if
   end subroutine var_list_set_procvar_int
 
   subroutine var_list_set_procvar_real (var_list, proc_id, name, rval)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: proc_id
     type(string_t), intent(in) :: name
     real(default), intent(in), optional :: rval
     type(string_t) :: var_name
     type(var_entry_t), pointer :: var
     var_name = name // "(" // proc_id // ")"
     var => var_list_get_var_ptr (var_list, var_name)
     if (.not. associated (var)) then
        call var_list%append_real (var_name, rval, intrinsic=.true.)
     else if (present (rval)) then
        call var_list%set_real (var_name, rval, is_known=.true.)
     end if
   end subroutine var_list_set_procvar_real
 
 @ %def var_list_set_procvar_int
 @ %def var_list_set_procvar_real
 @
 \subsection{Observable initialization}
 Observables are formally treated as variables, which however are
 evaluated each time the observable is used.  The arguments (pointers)
 to evaluate and the function are part of the variable-list entry.
 <<Variables: public>>=
   public :: var_list_append_obs1_iptr
   public :: var_list_append_obs2_iptr
   public :: var_list_append_obs1_rptr
   public :: var_list_append_obs2_rptr
 <<Variables: procedures>>=
   subroutine var_list_append_obs1_iptr (var_list, name, obs1_iptr, p1)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_int) :: obs1_iptr
     type(prt_t), intent(in), target :: p1
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS1_INT, p1)
     var%obs1_int => obs1_iptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs1_iptr
 
   subroutine var_list_append_obs2_iptr (var_list, name, obs2_iptr, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_int) :: obs2_iptr
     type(prt_t), intent(in), target :: p1, p2
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS2_INT, p1, p2)
     var%obs2_int => obs2_iptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs2_iptr
 
   subroutine var_list_append_obs1_rptr (var_list, name, obs1_rptr, p1)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_unary_real) :: obs1_rptr
     type(prt_t), intent(in), target :: p1
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS1_REAL, p1)
     var%obs1_real => obs1_rptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs1_rptr
 
   subroutine var_list_append_obs2_rptr (var_list, name, obs2_rptr, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_binary_real) :: obs2_rptr
     type(prt_t), intent(in), target :: p1, p2
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs (var, name, V_OBS2_REAL, p1, p2)
     var%obs2_real => obs2_rptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obs2_rptr
 
 @ %def var_list_append_obs1_iptr
 @ %def var_list_append_obs2_iptr
 @ %def var_list_append_obs1_rptr
 @ %def var_list_append_obs2_rptr
 @ User observables: no pointer needs to be stored.
 <<Variables: public>>=
   public :: var_list_append_uobs_int
   public :: var_list_append_uobs_real
 <<Variables: procedures>>=
   subroutine var_list_append_uobs_int (var_list, name, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(prt_t), intent(in), target :: p1
     type(prt_t), intent(in), target, optional :: p2
     type(var_entry_t), pointer :: var
     allocate (var)
     if (present (p2)) then
        call var_entry_init_obs (var, name, V_UOBS2_INT, p1, p2)
     else
        call var_entry_init_obs (var, name, V_UOBS1_INT, p1)
     end if
     call var_list_append (var_list, var)
   end subroutine var_list_append_uobs_int
 
   subroutine var_list_append_uobs_real (var_list, name, p1, p2)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     type(prt_t), intent(in), target :: p1
     type(prt_t), intent(in), target, optional :: p2
     type(var_entry_t), pointer :: var
     allocate (var)
     if (present (p2)) then
        call var_entry_init_obs (var, name, V_UOBS2_REAL, p1, p2)
     else
        call var_entry_init_obs (var, name, V_UOBS1_REAL, p1)
     end if
     call var_list_append (var_list, var)
   end subroutine var_list_append_uobs_real
 
 @ %def var_list_append_uobs_int
 @ %def var_list_append_uobs_real
 @
 \subsection{API for variable lists}
 Set a new value.  If the variable holds a pointer, this pointer is
 followed, e.g., a model parameter is actually set.  If [[ignore]] is
 set, do nothing if the variable does not exist.  If [[verbose]] is
 set, echo the new value.
 
 Clear a variable (all variables), i.e., undefine the value.
 <<Variables: var list: TBP>>=
   procedure :: unset => var_list_clear
 <<Variables: procedures>>=
   subroutine var_list_clear (vars, name, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_clear (var)
     end if
   end subroutine var_list_clear
 
 @ %def var_list_clear
 @
 Setting the value, concise specific versions (implementing deferred TBP):
 <<Variables: var list: TBP>>=
   procedure :: set_ival => var_list_set_ival
   procedure :: set_rval => var_list_set_rval
   procedure :: set_cval => var_list_set_cval
   procedure :: set_lval => var_list_set_lval
   procedure :: set_sval => var_list_set_sval
 <<Variables: procedures>>=
   subroutine var_list_set_ival (vars, name, ival, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     integer, intent(in) :: ival
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_int (var, ival, is_known=.true.)
     end if
   end subroutine var_list_set_ival
 
   subroutine var_list_set_rval (vars, name, rval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_real (var, rval, is_known=.true.)
     end if
   end subroutine var_list_set_rval
 
   subroutine var_list_set_cval (vars, name, cval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: cval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_cmplx (var, cval, is_known=.true.)
     end if
   end subroutine var_list_set_cval
 
   subroutine var_list_set_lval (vars, name, lval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     logical, intent(in) :: lval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_log (var, lval, is_known=.true.)
     end if
   end subroutine var_list_set_lval
 
   subroutine var_list_set_sval (vars, name, sval, follow_link)
     class(var_list_t), intent(inout) :: vars
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: sval
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
     if (associated (var)) then
        call var_entry_set_string (var, sval, is_known=.true.)
     end if
   end subroutine var_list_set_sval
 
 @ %def var_list_set_ival
 @ %def var_list_set_rval
 @ %def var_list_set_cval
 @ %def var_list_set_lval
 @ %def var_list_set_sval
 @
 Setting the value, verbose specific versions (as subroutines):
 <<Variables: var list: TBP>>=
   procedure :: set_log => var_list_set_log
   procedure :: set_int => var_list_set_int
   procedure :: set_real => var_list_set_real
   procedure :: set_cmplx => var_list_set_cmplx
   procedure :: set_subevt => var_list_set_subevt
   procedure :: set_pdg_array => var_list_set_pdg_array
   procedure :: set_string => var_list_set_string
 <<Variables: procedures>>=
   subroutine var_list_set_log &
        (var_list, name, lval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     logical, intent(in) :: lval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_LOG)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_LOG)
              call var_entry_set_log (var, lval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_log
 
   subroutine var_list_set_int &
        (var_list, name, ival, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(in) :: ival
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_INT)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_INT)
              call var_entry_set_int (var, ival, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_int
 
   subroutine var_list_set_real &
        (var_list, name, rval, is_known, ignore, force, &
         verbose, model_name, pacified)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     real(default), intent(in) :: rval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose, pacified
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_REAL)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_REAL)
              call var_entry_set_real &
                   (var, rval, is_known, verbose, model_name, pacified)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_real
 
   subroutine var_list_set_cmplx &
        (var_list, name, cval, is_known, ignore, force, &
         verbose, model_name, pacified)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: cval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose, pacified
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_CMPLX)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_CMPLX)
              call var_entry_set_cmplx &
                   (var, cval, is_known, verbose, model_name, pacified)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_cmplx
 
   subroutine var_list_set_pdg_array &
        (var_list, name, aval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     type(pdg_array_t), intent(in) :: aval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_PDG)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_PDG)
              call var_entry_set_pdg_array &
                   (var, aval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_pdg_array
 
   subroutine var_list_set_subevt &
        (var_list, name, pval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     type(subevt_t), intent(in) :: pval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_SEV)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_SEV)
              call var_entry_set_subevt &
                   (var, pval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_subevt
 
   subroutine var_list_set_string &
        (var_list, name, sval, is_known, ignore, force, verbose, model_name)
     class(var_list_t), intent(inout), target :: var_list
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: sval
     logical, intent(in) :: is_known
     logical, intent(in), optional :: ignore, force, verbose
     type(string_t), intent(in), optional :: model_name
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_STR)
     if (associated (var)) then
        if (.not. var_entry_is_locked (var, force)) then
           select case (var%type)
           case (V_STR)
              call var_entry_set_string &
                   (var, sval, is_known, verbose, model_name)
           case default
              call var_mismatch_error (name)
           end select
        else
           call var_locked_error (name)
        end if
     else
        call var_missing_error (name, ignore)
     end if
   end subroutine var_list_set_string
 
   subroutine var_mismatch_error (name)
     type(string_t), intent(in) :: name
     call msg_fatal ("Type mismatch for variable '" // char (name) // "'")
   end subroutine var_mismatch_error
 
   subroutine var_locked_error (name)
     type(string_t), intent(in) :: name
     call msg_error ("Variable '" // char (name) // "' is not user-definable")
   end subroutine var_locked_error
 
   subroutine var_missing_error (name, ignore)
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: ignore
     logical :: error
     if (present (ignore)) then
        error = .not. ignore
     else
        error = .true.
     end if
     if (error) then
        call msg_fatal ("Variable '" // char (name) // "' has not been declared")
     end if
   end subroutine var_missing_error
 
 @ %def var_list_set_log
 @ %def var_list_set_int
 @ %def var_list_set_real
 @ %def var_list_set_cmplx
 @ %def var_list_set_subevt
 @ %def var_list_set_pdg_array
 @ %def var_list_set_string
 @ %def var_mismatch_error
 @ %def var_missing_error
 @
 Import values for the current variable list from another list.
 <<Variables: public>>=
   public :: var_list_import
 <<Variables: var list: TBP>>=
   procedure :: import => var_list_import
 <<Variables: procedures>>=
   subroutine var_list_import (var_list, src_list)
     class(var_list_t), intent(inout) :: var_list
     type(var_list_t), intent(in) :: src_list
     type(var_entry_t), pointer :: var, src
     var => var_list%first
     do while (associated (var))
        src => var_list_get_var_ptr (src_list, var%name)
        if (associated (src)) then
           call var_entry_copy_value (var, src)
        end if
        var => var%next
     end do
   end subroutine var_list_import
 
 @ %def var_list_import
 @ Mark all entries in the current variable list as undefined.  This is done
 when a local variable list is discarded.  If the local list is used again (by
 a loop), the entries will be re-initialized.
 <<Variables: public>>=
   public :: var_list_undefine
 <<Variables: var list: TBP>>=
   procedure :: undefine => var_list_undefine
 <<Variables: procedures>>=
   recursive subroutine var_list_undefine (var_list, follow_link)
     class(var_list_t), intent(inout) :: var_list
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var
     logical :: rec
     rec = .true.;  if (present (follow_link))  rec = follow_link
     var => var_list%first
     do while (associated (var))
        call var_entry_undefine (var)
        var => var%next
     end do
     if (rec .and. associated (var_list%next)) then
        call var_list_undefine (var_list%next, follow_link=follow_link)
     end if
   end subroutine var_list_undefine
 
 @ %def var_list_undefine
 @ Make a deep copy of a variable list.
 <<Variables: public>>=
   public :: var_list_init_snapshot
 <<Variables: var list: TBP>>=
   procedure :: init_snapshot => var_list_init_snapshot
 <<Variables: procedures>>=
   recursive subroutine var_list_init_snapshot (var_list, vars_in, follow_link)
     class(var_list_t), intent(out) :: var_list
     type(var_list_t), intent(in) :: vars_in
     logical, intent(in), optional :: follow_link
     type(var_entry_t), pointer :: var, var_in
     type(var_list_t), pointer :: var_list_next
     logical :: rec
     rec = .true.;  if (present (follow_link))  rec = follow_link
     var_in => vars_in%first
     do while (associated (var_in))
        allocate (var)
        call var_entry_init_copy (var, var_in)
        call var_entry_copy_value (var, var_in)
        call var_list_append (var_list, var)
        var_in => var_in%next
     end do
     if (rec .and. associated (vars_in%next)) then
        allocate (var_list_next)
        call var_list_init_snapshot (var_list_next, vars_in%next)
        call var_list%link (var_list_next)
     end if
   end subroutine var_list_init_snapshot
 
 @ %def var_list_init_snapshot
 @ Check if a user variable can be set.  The [[new]] flag is set if the user
 variable has an explicit declaration.  If an error occurs, return [[V_NONE]]
 as variable type.
 
 Also determine the actual type of generic numerical variables, which enter the
 procedure with type [[V_NONE]].
 <<Variables: public>>=
   public :: var_list_check_user_var
 <<Variables: var list: TBP>>=
   procedure :: check_user_var => var_list_check_user_var
 <<Variables: procedures>>=
   subroutine var_list_check_user_var (var_list, name, type, new)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(inout) :: type
     logical, intent(in) :: new
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name)
     if (associated (var)) then
        if (type == V_NONE) then
           type = var_entry_get_type (var)
        end if
        if (var_entry_is_locked (var)) then
           call msg_fatal ("Variable '" // char (name) &
                // "' is not user-definable")
           type = V_NONE
           return
        else if (new) then
           if (var_entry_is_intrinsic (var)) then
              call msg_fatal ("Intrinsic variable '" &
                   // char (name) // "' redeclared")
              type = V_NONE
              return
           end if
           if (var_entry_get_type (var) /= type) then
              call msg_fatal ("Variable '" // char (name) // "' " &
                   // "redeclared with different type")
              type = V_NONE
              return
           end if
        end if
     end if
   end subroutine var_list_check_user_var
 
 @ %def var_list_check_user_var
 @
 \subsection{Default values for global var list}
 
 <<Variables: var list: TBP>>=
   procedure :: init_defaults => var_list_init_defaults
 <<Variables: procedures>>=
   subroutine var_list_init_defaults (var_list, seed, paths)
     class(var_list_t), intent(out) :: var_list
     integer, intent(in) :: seed
     type(paths_t), intent(in), optional :: paths
     call var_list%set_beams_defaults (paths)
     call var_list%set_core_defaults (seed)
     call var_list%set_integration_defaults ()
     call var_list%set_phase_space_defaults ()
     call var_list%set_gamelan_defaults ()
     call var_list%set_clustering_defaults ()
     call var_list%set_isolation_defaults ()
     call var_list%set_eio_defaults ()
     call var_list%set_shower_defaults ()
     call var_list%set_hadronization_defaults ()
     call var_list%set_tauola_defaults  ()
     call var_list%set_mlm_matching_defaults ()
     call var_list%set_powheg_matching_defaults ()
     call var_list%append_log (var_str ("?ckkw_matching"), .false., &
             intrinsic=.true., description=var_str ('Master flag that switches ' // &
             'on the CKKW(-L) (LO) matching between hard scattering matrix ' // &
             'elements and QCD parton showers. Note that this is not yet ' // &
             '(completely) implemented in \whizard. (cf. also \ttt{?allow\_shower}, ' // &
             '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})'))
     call var_list%set_openmp_defaults ()
     call var_list%set_mpi_defaults ()
     call var_list%set_nlo_defaults ()
   end subroutine var_list_init_defaults
 
 @ %def var_list_init_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_beams_defaults => var_list_set_beams_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_beams_defaults (var_list, paths)
     type(paths_t), intent(in), optional :: paths
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_real (var_str ("sqrts"), &
           intrinsic=.true., &
           description=var_str ('Real variable in order to set the center-of-mass ' // &
           'energy for the collisions (collider energy $\sqrt{s}$, not ' // &
           'hard interaction energy $\sqrt{\hat{s}}$): \ttt{sqrts = {\em ' // &
           '<num>} [ {\em <phys\_unit>} ]}. The physical unit can be one ' // &
           'of the following \ttt{eV}, \ttt{keV}, \ttt{MeV}, \ttt{GeV}, ' // &
           'and \ttt{TeV}. If absent, \whizard\ takes \ttt{GeV} as its ' // &
           'standard unit. Note that this variable is absolutely mandatory ' // &
           'for integration and simulation of scattering processes.'))
     call var_list%append_real (var_str ("luminosity"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This specifier \ttt{luminosity = {\em ' // &
           '<num>}} sets the integrated luminosity (in inverse femtobarns, ' // &
           'fb${}^{-1}$) for the event generation of the processes in the ' // &
           '\sindarin\ input files. Note that WHIZARD itself chooses the ' // &
           'number from the \ttt{luminosity} or from the \ttt{n\_events} ' // &
           'specifier, whichever would give the larger number of events. ' // &
           'As this depends on the cross section under consideration, it ' // &
           'might be different for different processes in the process list.  ' // &
           '(cf. \ttt{n\_events}, \ttt{\$sample}, \ttt{sample\_format}, \ttt{?unweighted})'))
     call var_list%append_log (var_str ("?sf_trace"), .false., &
           intrinsic=.true., &
           description=var_str ('Debug flag that writes out detailed information ' // &
           'about the structure function setup into the file \ttt{{\em ' // &
           '<proc\_name>}\_sftrace.dat}. This file name can be changed ' // &
           'with ($\to$) \ttt{\$sf\_trace\_file}.'))
     call var_list%append_string (var_str ("$sf_trace_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('\ttt{\$sf\_trace\_file = "{\em <file\_name>}"} ' // &
           'allows to change the detailed structure function information ' // &
           'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // &
           'a different file \ttt{{\em <file\_name>}} than the default ' // &
           '\ttt{{\em <proc\_name>}\_sftrace.dat}.'))
     call var_list%append_log (var_str ("?sf_allow_s_mapping"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that determines whether special mappings ' // &
           'for processes with structure functions and $s$-channel resonances ' // &
           'are applied, e.g. Drell-Yan at hadron colliders, or $Z$ production ' // &
           'at linear colliders with beamstrahlung and ISR.'))
     if (present (paths)) then
        call var_list%append_string (var_str ("$lhapdf_dir"), paths%lhapdfdir, &
              intrinsic=.true., &
              description=var_str ('String variable that tells the path ' // &
              'where the \lhapdf\ library and PDF sets can be found. When ' // &
              'the library has been correctly recognized during configuration, ' // &
              'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // &
              '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
              '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})'))
     else
        call var_list%append_string (var_str ("$lhapdf_dir"), var_str(""), &
              intrinsic=.true., &
              description=var_str ('String variable that tells the path ' // &
              'where the \lhapdf\ library and PDF sets can be found. When ' // &
              'the library has been correctly recognized during configuration, ' // &
              'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // &
              '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
              '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})'))
     end if
     call var_list%append_string (var_str ("$lhapdf_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This string variable \ttt{\$lhapdf\_file ' // &
           '= "{\em <pdf\_set>}"} allows to specify the PDF set \ttt{{\em ' // &
           '<pdf\_set>}} from the external \lhapdf\ library. It must match ' // &
           'the exact name of the PDF set from the \lhapdf\ library. The ' // &
           'default is empty, and the default set from \lhapdf\ is taken. ' // &
           'Only one argument is possible, the PDF set must be identical ' // &
           'for both beams, unless there are fundamentally different beam ' // &
           'particles like proton and photon. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
           '\ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_photon\_scheme}, ' // &
           '\ttt{lhapdf\_member})'))
     call var_list%append_string (var_str ("$lhapdf_photon_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable \ttt{\$lhapdf\_photon\_file ' // &
           '= "{\em <pdf\_set>}"} analagous to ($\to$) \ttt{\$lhapdf\_file} ' // &
           'for photon PDF structure functions from the external \lhapdf\ ' // &
           'library. The name must exactly match the one of the set from ' // &
           '\lhapdf.  (cf. \ttt{beams}, \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
           '\ttt{\$lhapdf\_file}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member}, ' // &
           '\ttt{lhapdf\_photon\_scheme})'))
     call var_list%append_int (var_str ("lhapdf_member"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer variable that specifies the number ' // &
           'of the corresponding PDF set chosen via the command ($\to$) ' // &
           '\ttt{\$lhapdf\_file} or ($\to$) \ttt{\$lhapdf\_photon\_file} ' // &
           'from the external \lhapdf\ library. E.g. error PDF sets can ' // &
           'be chosen by this. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
           '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
           '\ttt{lhapdf\_photon\_scheme})'))
     call var_list%append_int (var_str ("lhapdf_photon_scheme"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that controls the different ' // &
           'available schemes for photon PDFs inside the external \lhapdf\ ' // &
           'library. For more details see the \lhapdf\ manual.  (cf. also ' // &
           '\ttt{lhapdf}, \ttt{\$lhapdf\_dir}, \ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, ' // &
           '\ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member})'))
     call var_list%append_string (var_str ("$pdf_builtin_set"), var_str ("CTEQ6L"), &
          intrinsic=.true., &
          description=var_str ("For \whizard's internal PDF structure functions " // &
          'for hadron colliders, this string variable allows to set the ' // &
          'particular PDF set. (cf. also \ttt{pdf\_builtin}, \ttt{pdf\_builtin\_photon})'))
     call var_list%append_log (var_str ("?hoppet_b_matching"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that switches on the matching between ' // &
           '4- and 5-flavor schemes for hadron collider $b$-parton initiated ' // &
           'processes. Works either with builtin PDFs or with the external ' // &
           '\lhapdf\ interface. Needs the external \ttt{HOPPET} library ' // &
           'to be linked. (cf. \ttt{beams}, \ttt{pdf\_builtin}, \ttt{lhapdf})'))
     call var_list%append_real (var_str ("isr_alpha"), 0._default, &
           intrinsic=.true., &
           description=var_str ('For lepton collider initial-state QED ' // &
           'radiation (ISR), this real parameter sets the value of $\alpha_{em}$ ' // &
           'used in the structure function. If not set, it is taken from ' // &
           'the parameter set of the physics model in use (cf. also \ttt{isr}, ' // &
           '\ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // &
           '\ttt{?isr\_keep\_energy})'))
     call var_list%append_real (var_str ("isr_q_max"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set the ' // &
           'scale of the initial-state QED radiation (ISR) structure function. ' // &
           'If not set, it is taken internally to be $\sqrt{s}$.  (cf. ' // &
           'also \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // &
           '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})'))
     call var_list%append_real (var_str ("isr_mass"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set by hand ' // &
           'the mass of the incoming particle for lepton collider initial-state ' // &
           'QED radiation (ISR). If not set, the mass for the initial beam ' // &
           'particle is taken from the model in use. (cf. also \ttt{isr}, ' // &
           '\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // &
           '\ttt{?isr\_keep\_energy})'))
     call var_list%append_int (var_str ("isr_order"), 3, &
           intrinsic=.true., &
           description=var_str ('For lepton collider initial-state QED ' // &
           'radiation (ISR), this integer parameter allows to set the order ' // &
           'up to which hard-collinear radiation is taken into account. ' // &
           'Default is the highest available, namely third order. (cf. ' // &
           'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // &
           '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})'))
     call var_list%append_log (var_str ("?isr_recoil"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // &
           '$p_T$-kick for the lepton collider initial-state QED radiation ' // &
           '(ISR).  (cf. also \ttt{isr}, \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, ' // &
           '\ttt{isr\_order}, \ttt{isr\_q\_max})'))
     call var_list%append_log (var_str ("?isr_keep_energy"), .false., &
           intrinsic=.true., &
           description=var_str ('As the splitting kinematics for the ISR ' // &
           'structure function violates Lorentz invariance when the recoil ' // &
           'is switched on, this flag forces energy conservation when set ' // &
           'to true, otherwise violating energy conservation.  (cf. also ' // &
           '\ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // &
           '\ttt{?isr\_recoil}, \ttt{?isr\_alpha})'))
     call var_list%append_log (var_str ("?isr_handler"), .false., &
           intrinsic=.true., &
           description=var_str ('Activate ISR ' // &
           'handler for event generation (no effect on integration). ' // &
           'Requires \ttt{isr\_recoil = false}'))
     call var_list%append_string (var_str ("$isr_handler_mode"), &
           var_str ("trivial"), &
           intrinsic=.true., &
           description=var_str ('Operation mode for the ISR ' // &
           'event handler.  Allowed values: \ttt{trivial} (no effect), ' // &
           '\ttt{recoil} (recoil kinematics with two photons)'))
     call var_list%append_log (var_str ("?isr_handler_keep_mass"), .true., &
           intrinsic=.true., &
           description=var_str ('If \ttt{true} (default), force the incoming ' // &
           'partons of the hard process (after radiation) on their mass ' // &
           'shell.  Otherwise, insert massless on-shell momenta.  This ' // &
           'applies only for event generation (no effect on integration, ' // &
           'cf.\ also \ttt{?isr\_handler})'))
     call var_list%append_string (var_str ("$epa_mode"), &
           var_str ("default"), intrinsic=.true., &
           description=var_str ('For the equivalent photon approximation ' // &
           '(EPA), this string variable defines the mode, i.e. the explicit ' // &
           'formula for the EPA distribution. For more details cf. the manual. ' // &
           'Possible are \ttt{default} (\ttt{Budnev\_617}), \ttt{Budnev\_616e}, ' // &
           '\ttt{log\_power}, \ttt{log\_simple}, and \ttt{log}. ' // &
           '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, ' // &
           '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_alpha"), 0._default, &
           intrinsic=.true., &
           description=var_str ('For the equivalent photon approximation ' // &
           '(EPA), this real parameter sets the value of $\alpha_{em}$ ' // &
           'used in the structure function. If not set, it is taken from ' // &
           'the parameter set of the physics model in use (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, \ttt{epa\_q\_min}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_x_min"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the lower cutoff ' // &
           'for the energy fraction in the splitting for the equivalent-photon ' // &
           'approximation (EPA). This parameter has to be set by the user ' // &
           'to a non-zero value smaller than one. (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_e\_max}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
                     '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_q_min"), 0._default, &
           intrinsic=.true., &
           description=var_str ('In the equivalent-photon approximation ' // &
           '(EPA), this real parameters sets the minimal value for the ' // &
           'transferred momentum. Either this parameter or the mass of ' // &
           'the beam particle has to be non-zero.  (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_max}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_q_max"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set the ' // &
           'upper energy cutoff for the equivalent-photon approximation ' // &
           '(EPA). If not set, \whizard\ simply takes the collider energy, ' // &
           '$\sqrt{s}$. (cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, ' // &
           '\ttt{epa\_alpha}, \ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_keep\_energy}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_real (var_str ("epa_mass"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set by hand ' // &
           'the mass of the incoming particle for the equivalent-photon ' // &
           'approximation (EPA). If not set, the mass for the initial beam ' // &
           'particle is taken from the model in use. (cf. also \ttt{epa}, ' // &
           '\ttt{epa\_x\_min}, \ttt{epa\_e\_max}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // &
           '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}. ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_log (var_str ("?epa_recoil"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // &
           '$p_T$-kick for the equivalent-photon approximation (EPA).  ' // &
           '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // &
           '\ttt{epa\_e\_max}, \ttt{epa\_q\_min}, \ttt{?epa\_keep\_energy}, ' // &
           '\ttt{\$epa\_mode}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_log (var_str ("?epa_keep_energy"), .false., &
           intrinsic=.true., &
           description=var_str ('As the splitting kinematics for the EPA ' // &
           'structure function violates Lorentz invariance when the recoil ' // &
           'is switched on, this flag forces energy conservation when set ' // &
           'to true, otherwise violating energy conservation. (cf. also ' // &
           '\ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // &
           '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // &
           '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
     call var_list%append_log (var_str ("?epa_handler"), .false., &
           intrinsic=.true., &
           description=var_str ('Activate EPA ' // &
           'handler for event generation (no effect on integration). ' // &
           'Requires \ttt{epa\_recoil = false}'))
     call var_list%append_string (var_str ("$epa_handler_mode"), &
           var_str ("trivial"), &
           intrinsic=.true., &
           description=var_str ('Operation mode for the EPA ' // &
           'event handler.  Allowed values: \ttt{trivial} (no effect), ' // &
           '\ttt{recoil} (recoil kinematics with two beams)'))
     call var_list%append_real (var_str ("ewa_x_min"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the lower cutoff ' // &
           'for the energy fraction in the splitting for the equivalent ' // &
           '$W$ approximation (EWA). This parameter has to be set by the ' // &
           'user to a non-zero value smaller than one. (cf. also \ttt{ewa}, ' // &
           '\ttt{ewa\_pt\_max}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // &
           '\ttt{?ewa\_recoil})'))
     call var_list%append_real (var_str ("ewa_pt_max"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set the ' // &
           'upper $p_T$ cutoff for the equivalent $W$ approximation (EWA). ' // &
           'If not set, \whizard\ simply takes the collider energy, $\sqrt{s}$. ' // &
           '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // &
           '\ttt{?ewa\_recoil})'))
     call var_list%append_real (var_str ("ewa_mass"), 0._default, &
           intrinsic=.true., &
           description=var_str ('This real parameter allows to set by hand ' // &
           'the mass of the incoming particle for the equivalent $W$ approximation ' // &
           '(EWA). If not set, the mass for the initial beam particle is ' // &
           'taken from the model in use. (cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, ' // &
           '\ttt{ewa\_pt\_max}, \ttt{?ewa\_keep\_energy}, \ttt{?ewa\_recoil})'))
     call var_list%append_log (var_str ("?ewa_recoil"), .false., &
          intrinsic=.true., &
          description=var_str ('For the equivalent $W$ approximation (EWA), ' // &
          'this flag switches on recoil, i.e. non-collinear splitting.  ' // &
          '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max},  ' // &
          '\ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy})'))
     call var_list%append_log (var_str ("?ewa_keep_energy"), .false., &
           intrinsic=.true., &
           description=var_str ('As the splitting kinematics for the equivalent ' // &
           '$W$ approximation (EWA) violates Lorentz invariance when the ' // &
           'recoil is switched on, this flag forces energy conservation ' // &
           'when set to true, otherwise violating energy conservation. ' // &
           '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max},  ' // &
           '\ttt{ewa\_mass}, \ttt{?ewa\_recoil})'))
     call var_list%append_log (var_str ("?circe1_photon1"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to tell \whizard\ to use the photon ' // &
           'of the \circeone\ beamstrahlung structure function as initiator ' // &
           'for the hard scattering process in the first beam. (cf. also ' // &
           '\ttt{circe1}, \ttt{?circe1\_photon2}, \ttt{circe1\_sqrts},  ' // &
           '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
           '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
           '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_photon2"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to tell \whizard\ to use the photon ' // &
           'of the \circeone\ beamstrahlung structure function as initiator ' // &
           'for the hard scattering process in the second beam. (cf. also ' // &
           '\ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{circe1\_sqrts},  ' // &
           '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
           '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // &
           '\newline\ttt{?circe1\_with\_radiation})'))
     call var_list%append_real (var_str ("circe1_sqrts"), &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows to set the ' // &
           'value of the collider energy for the lepton collider beamstrahlung ' // &
           'structure function \circeone. If not set, $\sqrt{s}$ is taken. ' // &
           '(cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2},  ' // &
           '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
           '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
           '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_generate"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that determines whether the \circeone\ ' // &
           'structure function for lepton collider beamstrahlung uses the ' // &
           'generator mode for the spectrum, or a pre-defined (semi-)analytical ' // &
           'parameterization. Default is the generator mode. (cf. also ' // &
           '\ttt{circe1}, \ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2},  ' // &
           '\ttt{circe1\_sqrts}, \ttt{?circe1\_map}, \ttt{circe1\_mapping\_slope}, ' // &
           '\ttt{circe1\_eps}, \newline \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // &
           '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_map"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that determines whether the \circeone\ ' // &
           'structure function for lepton collider beamstrahlung uses special ' // &
           'mappings for $s$-channel resonances. (cf. also \ttt{circe1}, ' // &
           '\ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2},  ' // &
           '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
           '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_eps}, \newline ' // &
           '\ttt{circe1\_ver}, \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, ' // &
           '\ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_real (var_str ("circe1_mapping_slope"), 2._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows to vary the ' // &
           'slope of the mapping function for the \circeone\ structure ' // &
           'function for lepton collider beamstrahlung from the default ' // &
           'value \ttt{2.}. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // &
           '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts},  \ttt{?circe1\_generate}, ' // &
           '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \ttt{circe1\_ver}, ' // &
           '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
           '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_real (var_str ("circe1_eps"), 1e-5_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter, that takes care of the ' // &
           'mapping of the peak in the lepton collider beamstrahlung structure ' // &
           'function spectrum of \circeone.  (cf. also \ttt{circe1}, \ttt{?circe1\_photons}, ' // &
           '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
           '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \newline ' // &
           '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // &
           '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline\ttt{?circe1\_with\_radiation})'))
     call var_list%append_int (var_str ("circe1_ver"), 0, intrinsic=.true., &
          description=var_str ('Integer parameter that sets the internal ' // &
          'versioning number of the \circeone\ structure function for lepton-collider ' // &
          'beamstrahlung. It has to be set by the user explicitly, it takes ' // &
          'values from one to ten.  (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // &
          '\ttt{?circe1\_photon2},  \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
          '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, ' // &
          '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // &
          '\ttt{?circe1\_with\_radiation})'))
     call var_list%append_int (var_str ("circe1_rev"), 0, intrinsic=.true., &
          description=var_str ('Integer parameter that sets the internal ' // &
          'revision number of the \circeone\ structure function for lepton-collider ' // &
          'beamstrahlung. The default \ttt{0} translates always into the ' // &
          'most recent version; older versions have to be accessed through ' // &
          'the explicit revision date. For more details cf.~the \circeone ' // &
          'manual.  (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2},  ' // &
          '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
          '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, \ttt{circe1\_ver}, ' // &
          '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_string (var_str ("$circe1_acc"), var_str ("SBAND"), &
           intrinsic=.true., &
           description=var_str ('String variable that specifies the accelerator ' // &
           'type for the \circeone\ structure function for lepton-collider ' // &
           'beamstrahlung.  (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
           '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
           '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
           '\newline \ttt{circe1\_rev}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_int (var_str ("circe1_chat"), 0, intrinsic=.true., &
          description=var_str ('Chattiness of the \circeone\ structure ' // &
          'function for lepton-collider beamstrahlung. The higher the integer ' // &
          'value, the more information will be given out by the \circeone\ ' // &
          'package. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
          '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
          '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
          '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{?circe1\_with\_radiation})'))
     call var_list%append_log (var_str ("?circe1_with_radiation"), .false., &
          intrinsic=.true., &
          description=var_str ('This logical decides whether the additional photon ' // &
          'or electron ("beam remnant") will be considered in the event record or ' // &
          'not. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
          '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
          '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
          '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc})'))
     call var_list%append_log (var_str ("?circe2_polarized"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag whether the photon spectra from the ' // &
           '\circetwo\ structure function for lepton colliders should be ' // &
           'treated polarized. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, ' // &
           '\ttt{\$circe2\_design})'))
     call var_list%append_string (var_str ("$circe2_file"), &
           intrinsic=.true., &
           description=var_str ('String variable by which the corresponding ' // &
           'photon collider spectrum for the \circetwo\ structure function ' // &
           'can be selected. (cf. also \ttt{circe2}, \ttt{?circe2\_polarized}, ' // &
           '\ttt{\$circe2\_design})'))
     call var_list%append_string (var_str ("$circe2_design"), var_str ("*"), &
           intrinsic=.true., &
           description=var_str ('String variable that sets the collider ' // &
           'design for the \circetwo\ structure function for photon collider ' // &
           'spectra. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, \ttt{?circe2\_polarized})'))
     call var_list%append_real (var_str ("gaussian_spread1"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Parameter that sets the energy spread ' // &
           '($\sigma$ value) of the first beam for a Gaussian spectrum.  ' // &
           '(cf. \ttt{gaussian})'))
      call var_list%append_real (var_str ("gaussian_spread2"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Ditto, for the second beam.'))
     call var_list%append_string (var_str ("$beam_events_file"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           "name of the external file from which a beamstrahlung's spectrum " // &
           'for lepton colliders as pairs of energy fractions is read in. ' // &
           '(cf. also \ttt{beam\_events}, \ttt{?beam\_events\_warn\_eof})'))
     call var_list%append_log (var_str ("?beam_events_warn_eof"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to ' // &
           'issue a warning when in a simulation the end of an external ' // &
           "file for beamstrahlung's spectra for lepton colliders are reached, " // &
           'and energy fractions from the beginning of the file are reused. ' // &
           '(cf. also \ttt{beam\_events}, \ttt{\$beam\_events\_file})'))
     call var_list%append_log (var_str ("?energy_scan_normalize"), .false., &
           intrinsic=.true., &
           description=var_str ('Normalization flag for the energy scan ' // &
           'structure function: if set the total cross section is normalized ' // &
           'to unity. (cf. also \ttt{energy\_scan})'))
   end subroutine var_list_set_beams_defaults
 
 @ %def var_list_set_beams_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_core_defaults => var_list_set_core_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_core_defaults (var_list, seed)
     class(var_list_t), intent(inout) :: var_list
     integer, intent(in) :: seed
     logical, target, save :: known = .true.     !!! ??????
     real(default), parameter :: real_specimen = 1.
     call var_list_append_log_ptr &
          (var_list, var_str ("?logging"), logging, known, &
          intrinsic=.true., &
          description=var_str ('This logical -- when set to \ttt{false} ' // &
          '-- suppresses writing out a logfile (default: \ttt{whizard.log}) ' // &
          'for the whole \whizard\ run, or when \whizard\ is run with the ' // &
          '\ttt{--no-logging} option, to suppress parts of the logging ' // &
          'when setting it to \ttt{true} again at a later part of the ' // &
          '\sindarin\ input file. Mainly for debugging purposes.  ' // &
          '(cf. also \ttt{?openmp\_logging}, \ttt{?mpi\_logging})'))
     call var_list%append_string (var_str ("$job_id"), &
          intrinsic=.true., &
          description=var_str ('Arbitrary string that can be used for ' // &
          'creating unique names.  The variable is initialized with the ' // &
          'value of the \ttt{job\_id} option on startup. (cf. also ' // &
          '\ttt{\$compile\_workspace}, \ttt{\$run\_id})'))
     call var_list%append_string (var_str ("$compile_workspace"), &
          intrinsic=.true., &
          description=var_str ('If set, create process source code ' // &
          'and process-driver library code in a subdirectory with this ' // &
          'name.  If non-existent, the directory will be created. (cf. ' // &
          'also \ttt{\$job\_id}, \ttt{\$run\_id}, \ttt{\$integrate\_workspace})'))
     call var_list%append_int (var_str ("seed"), seed, &
           intrinsic=.true., &
           description=var_str ('Integer variable \ttt{seed = {\em <num>}} ' // &
           'that allows to set a specific random seed \ttt{num}. If not ' // &
           'set, \whizard\ takes the time from the system clock to determine ' // &
           'the random seed.'))
     call var_list%append_string (var_str ("$model_name"), &
           intrinsic=.true., &
           description=var_str ('This variable makes the locally used physics ' // &
           'model available as a string, e.g. as \ttt{show (\$model\_name)}. ' // &
           'However, the user is not able to change the current model by ' // &
           'setting this variable to a different string. (cf. also \ttt{model}, ' // &
           '\ttt{\$library\_name}, \ttt{printf}, \ttt{show})'))
     call var_list%append_int (var_str ("process_num_id"), &
          intrinsic=.true., &
          description=var_str ('Using the integer \ttt{process\_num\_id ' // &
          '= {\em <int\_var>}} one can set a numerical identifier for processes ' // &
          'within a process library. This can be set either just before ' // &
          'the corresponding \ttt{process} definition or as an optional ' // &
          'local argument of the latter. (cf. also \ttt{process}, ' // &
          '\ttt{?proc\_as\_run\_id}, \ttt{lcio\_run\_id})'))
     call var_list%append_log (var_str ("?proc_as_run_id"), .true., &
          intrinsic=.true., &
          description=var_str ('Normally, for LCIO the process ID (cf. ' // &
          '\ttt{process\_num\_id}) is used as run ID, unless this flag is ' // &
          'set to \ttt{false}, cf. also \ttt{process}, \ttt{lcio\_run\_id}.'))
     call var_list%append_int (var_str ("lcio_run_id"), 0, &
          intrinsic=.true., &
          description=var_str ('Allows to set an integer run ID for the LCIO ' // &
          'event format. Normally, the process ID is taken as run ID, unless ' // &
          'the flag (cf.) \ttt{?proc\_as\_run\_id} is set to \ttt{false}, ' // &
          'cf. also \ttt{process}.'))
     call var_list%append_string (var_str ("$method"), var_str ("omega"), &
          intrinsic=.true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation. The default ' // &
          "is the intrinsic \oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // &
          '\ttt{"template\_unity"}, \ttt{"threshold"}. For processes defined ' // &
          '\ttt{"template"}, with \ttt{nlo\_calculation = ...}, please refer to ' // &
          '\ttt{\$born\_me\_method}, \ttt{\$real\_tree\_me\_method}, ' // &
          '\ttt{\$loop\_me\_method} and \ttt{\$correlation\_me\_method}.'))
     call var_list%append_log (var_str ("?report_progress"), .true., &
          intrinsic=.true., &
          description=var_str ('Flag for the \oMega\ matrix element generator ' // &
          'whether to print out status messages about progress during ' // &
          'matrix element generation. (cf. also \ttt{\$method}, \ttt{\$omega\_flags})'))
     call var_list%append_log (var_str ("?me_verbose"), .false., &
          description=var_str ("Flag determining whether " // &
          "the makefile command for generating and compiling the \oMega\ matrix " // &
          "element code is silent or verbose. Default is silent."))
     call var_list%append_string (var_str ("$restrictions"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('This is an optional argument for process ' // &
          'definitions for the matrix element method \ttt{"omega"}. Using ' // &
          'the following construction, it defines a string variable, \ttt{process ' // &
          '\newline {\em <process\_name>} = {\em <particle1>}, {\em <particle2>} ' // &
          '=> {\em <particle3>}, {\em <particle4>}, ... \{ \$restrictions ' // &
          '= "{\em <restriction\_def>}" \}}. The string argument \ttt{{\em ' // &
          '<restriction\_def>}} is directly transferred during the code ' // &
          'generation to the ME generator \oMega. It has to be of the form ' // &
          '\ttt{n1 + n2 + ...  \url{~} {\em <particle (list)>}}, where ' // &
          '\ttt{n1} and so on are the numbers of the particles above in ' // &
          'the process definition. The tilde specifies a certain intermediate ' // &
          'state to be equal to the particle(s) in \ttt{particle (list)}. ' // &
          'An example is \ttt{process eemm\_z =     e1, E1  =>  e2, E2 ' // &
          '\{ \$restrictions = "1+2 \url{~} Z" \} } restricts the code ' // &
          'to be generated for the process $e^- e^+ \to \mu^- \mu^+$ to ' // &
          'the $s$-channel $Z$-boson exchange. For more details see Sec.~\ref{sec:omega_me} ' // &
          '(cf. also \ttt{process})'))
     call var_list%append_log (var_str ("?omega_write_phs_output"), .false., &
          intrinsic=.true., &
          description=var_str ('This flag decides whether a the phase-space ' // &
          'output is produced by the \oMega\ matrix element generator. This ' // &
          'output is written to file(s) and contains the Feynman diagrams ' // &
          'which belong to the process(es) under consideration. The file is ' // &
          'mandatory whenever the variable \ttt{\$phs\_method} has the value ' // &
          '\ttt{fast\_wood}, i.e. if the phase-space file is provided by ' // &
          'cascades2.'))
     call var_list%append_string (var_str ("$omega_flags"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('String variable that allows to pass flags ' // &
          'to the \oMega\ matrix element generator. Normally, \whizard\ ' // &
          'takes care of all flags automatically. Note that for restrictions ' // &
          'of intermediate states, there is a special string variable: ' // &
          '(cf. $\to$) \ttt{\$restrictions}.'))
     call var_list%append_log (var_str ("?read_color_factors"), .true., &
           intrinsic=.true., &
           description=var_str ('This flag decides whether to read QCD ' // &
           'color factors from the matrix element provided by each method, ' // &
           'or to try and calculate the color factors in \whizard\ internally.'))
     call var_list%append_log (var_str ("?slha_read_input"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag which decides whether \whizard\ reads ' // &
           'in the SM and parameter information from the \ttt{SMINPUTS} ' // &
           'and \ttt{MINPAR} common blocks of the SUSY Les Houches Accord ' // &
           'files. (cf. also \ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, ' // &
           '\ttt{?slha\_read\_decays})'))
     call var_list%append_log (var_str ("?slha_read_spectrum"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag which decides whether \whizard\ reads ' // &
           'in the whole spectrum and mixing angle information from the ' // &
           'common blocks of the SUSY Les Houches Accord files. (cf. also ' // &
           '\ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_decays}, ' // &
           '\ttt{?slha\_read\_input})'))
     call var_list%append_log (var_str ("?slha_read_decays"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag which decides whether \whizard\ reads ' // &
           'in the widths and branching ratios from the \ttt{DCINFO} common ' // &
           'block of the SUSY Les Houches Accord files. (cf. also \ttt{read\_slha}, ' // &
           '\ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, \ttt{?slha\_read\_input})'))
     call var_list%append_string (var_str ("$library_name"), &
           intrinsic=.true., &
           description=var_str ('Similar to \ttt{\$model\_name}, this string ' // &
           'variable is used solely to access the name of the active process ' // &
           'library, e.g. in \ttt{printf} statements. (cf. \ttt{compile}, ' // &
           '\ttt{library}, \ttt{printf}, \ttt{show}, \ttt{\$model\_name})'))
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use a non-running ' // &
           '$\alpha_s$. Note that this has to be set explicitly to $\ttt{false}$ ' // &
           'if the user wants to use one of the running $\alpha_s$ options. ' // &
           '(cf. also \ttt{alphas\_order}, \ttt{?alphas\_from\_lhapdf}, ' // &
           '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // &
           '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_lhapdf"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use a running ' // &
           '$\alpha_s$ from the \lhapdf\ library (which has to be correctly ' // &
           'linked). Note that \ttt{?alphas\_is\_fixed} has to be set ' // &
           'explicitly to $\ttt{false}$. (cf. also \ttt{alphas\_order}, ' // &
           '\ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // &
           '\ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_pdf_builtin"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use a running ' // &
           '$\alpha_s$ from the internal PDFs. Note that in that case \ttt{?alphas\_is\_fixed} ' // &
           'has to be set explicitly to $\ttt{false}$. (cf. also ' // &
           '\ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // &
           '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \newline \ttt{?alphas\_from\_lambda\_qcd}, ' // &
           '\ttt{lambda\_qcd})'))
     call var_list%append_int (var_str ("alphas_order"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the order ' // &
           'of the internal evolution for running $\alpha_s$ in \whizard: ' // &
           'the default, \ttt{0}, is LO running, \ttt{1} is NLO, \ttt{2} ' // &
           'is NNLO. (cf. also \ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // &
           '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // &
           '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_int (var_str ("alphas_nf"), 5, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the number ' // &
           'of active quark flavors for the internal evolution for running ' // &
           '$\alpha_s$ in \whizard: the default is \ttt{5}. (cf. also ' // &
           '\ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\ttt{alphas\_order}, \ttt{?alphas\_from\_mz}, \newline ' // &
           '\ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_mz"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use its internal ' // &
           'running $\alpha_s$ from $\alpha_s(M_Z)$. Note that in that ' // &
           'case \ttt{?alphas\_is\_fixed} has to be set explicitly to ' // &
           '$\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // &
           '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
     call var_list%append_log (var_str ("?alphas_from_lambda_qcd"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to use its internal ' // &
           'running $\alpha_s$ from $\alpha_s(\Lambda_{QCD})$. Note that ' // &
           'in that case \ttt{?alphas\_is\_fixed} has  to be set explicitly ' // &
           'to $\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // &
           '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\newline \ttt{?alphas\_from\_mz}, \ttt{lambda\_qcd})'))
     call var_list%append_real (var_str ("lambda_qcd"), 200.e-3_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the value for ' // &
           '$\Lambda_{QCD}$ used in the internal evolution for running ' // &
           '$\alpha_s$ in \whizard. (cf. also \ttt{alphas\_is\_fixed}, ' // &
           '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, ' // &
           '\newline \ttt{?alphas\_from\_pdf\_builtin}, ' // &
           '\ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // &
           '\ttt{alphas\_order})'))
     call var_list%append_log (var_str ("?fatal_beam_decay"), .true., &
           intrinsic=.true., &
           description=var_str ('Logical variable that let the user decide ' // &
           'whether the possibility of a beam decay is treated as a fatal ' // &
           'error or only as a warning. An example is a process $b t \to ' // &
           'X$, where the bottom quark as an inital state particle appears ' // &
           'as a possible decay product of the second incoming particle, ' // &
           'the top quark. This might trigger inconsistencies or instabilities ' // &
           'in the phase space set-up.'))
     call var_list%append_log (var_str ("?helicity_selection_active"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether \whizard\ uses ' // &
           'a numerical selection rule for vanishing helicities: if active, ' // &
           'then, if a certain helicity combination yields an absolute ' // &
           '(\oMega) matrix element smaller than a certain threshold ($\to$ ' // &
           '\ttt{helicity\_selection\_threshold}) more often than a certain ' // &
           'cutoff ($\to$ \ttt{helicity\_selection\_cutoff}), it will be dropped.'))
     call var_list%append_real (var_str ("helicity_selection_threshold"), &
           1E10_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that gives the threshold ' // &
           'for the absolute value of a certain helicity combination of ' // &
           'an (\oMega) amplitude. If a certain number ($\to$ ' // &
           '\ttt{helicity\_selection\_cutoff}) of calls stays below this ' // &
           'threshold, that combination will be dropped from then on. (cf. ' // &
           'also \ttt{?helicity\_selection\_active})'))
     call var_list%append_int (var_str ("helicity_selection_cutoff"), 1000, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that gives the number ' // &
           "a certain helicity combination of an (\oMega) amplitude has " // &
           'to be below a certain threshold ($\to$ \ttt{helicity\_selection\_threshold}) ' // &
           'in order to be dropped from then on. (cf. also \ttt{?helicity\_selection\_active})'))
     call var_list%append_string (var_str ("$rng_method"), var_str ("tao"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'method for the random number generation. Default is Donald ' // &
           "Knuth' RNG method \ttt{TAO}."))
     call var_list%append_log (var_str ("?vis_diags"), .false., &
           intrinsic=.true., &
           description=var_str ('Logical variable that allows to give out ' // &
           "a Postscript or PDF file for the Feynman diagrams for a \oMega\ " // &
           'process.  (cf. \ttt{?vis\_diags\_color}).'))
     call var_list%append_log (var_str ("?vis_diags_color"), .false., &
           intrinsic=.true., &
           description=var_str ('Same as \ttt{?vis\_diags}, but switches ' // &
           'on color flow instead of Feynman diagram generation. (cf. \ttt{?vis\_diags}).'))
     call var_list%append_log (var_str ("?check_event_file"), .true., &
           intrinsic=.true., &
           description=var_str ('Setting this to false turns off all sanity ' // &
           'checks when reading a raw event file with previously generated ' // &
           'events.  Use this at your own risk; the program may return ' // &
           'wrong results or crash if data do not match. (cf. also \ttt{?check\_grid\_file}, ' // &
           '\ttt{?check\_phs\_file})'))
     call var_list%append_string (var_str ("$event_file_version"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'format version of the \whizard\ internal binary event format.'))
     call var_list%append_int (var_str ("n_events"), 0, &
           intrinsic=.true., &
           description=var_str ('This specifier \ttt{n\_events = {\em <num>}} ' // &
           'sets the number of events for the event generation of the processes ' // &
           'in the \sindarin\ input files. Note that WHIZARD itself chooses ' // &
           'the number from the \ttt{n\_events} or from the \ttt{luminosity} ' // &
           'specifier, whichever would give the larger number of events. ' // &
           'As this depends on the cross section under consideration, it ' // &
           'might be different for different processes in the process list.  ' // &
           '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
           '\ttt{?unweighted}, \ttt{event\_index\_offset})'))
     call var_list%append_int (var_str ("event_index_offset"), 0, &
           intrinsic=.true., &
           description=var_str ('The value ' // &
           '\ttt{event\_index\_offset = {\em <num>}} ' // &
           'initializes the event counter for a subsequent ' // &
           'event sample.  By default (value 0), the first event ' // &
           'gets index value 1, incrementing by one for each generated event ' // &
           'within a sample.  The event counter is initialized again ' // &
           'for each new sample (i.e., \ttt{integrate} command). ' // &
           'If events are read from file, and the ' // &
           'event file format supports event numbering, the event numbers ' // &
           'will be taken from file instead, and the value of ' // &
           '\ttt{event\_index\_offset} has no effect. ' // &
           '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
           '\ttt{?unweighted}, \ttt{n\_events})'))
     call var_list%append_log (var_str ("?unweighted"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that distinguishes between unweighted ' // &
           'and weighted event generation. (cf. also \ttt{simulate}, \ttt{n\_events}, ' // &
           '\ttt{luminosity}, \ttt{event\_index\_offset})'))
     call var_list%append_real (var_str ("safety_factor"), 1._default, &
           intrinsic=.true., &
           description=var_str ('This real variable \ttt{safety\_factor ' // &
           '= {\em <num>}} reduces the acceptance probability for unweighting.  ' // &
           'If greater than one, excess events become less likely, but ' // &
           'the reweighting efficiency also drops. (cf. \ttt{simulate}, \ttt{?unweighted})'))
     call var_list%append_log (var_str ("?negative_weights"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that tells \whizard\ to allow negative ' // &
           'weights in integration and simulation. (cf. also \ttt{simulate}, ' // &
           '\ttt{?unweighted})'))
     call var_list%append_log (var_str ("?resonance_history"), .false., &
           intrinsic=.true., &
           description=var_str ( &
           'The logical variable \texttt{?resonance\_history ' // &
           '= true/false} specifies whether during a simulation pass, ' // &
           'the event generator should try to reconstruct intermediate ' // &
           'resonances.  If activated, appropriate resonant subprocess ' // &
           'matrix element code will be automatically generated. '))
     call var_list%append_real (var_str ("resonance_on_shell_limit"), &
           4._default, &
           intrinsic=.true., &
           description=var_str ( &
           'The real variable \texttt{resonance\_on\_shell\_limit ' // &
           '= {\em <num>}} specifies the maximum relative distance from a ' // &
           'resonance peak, such that the kinematical configuration ' // &
           'can still be considered on-shell.  This is relevant only if ' // &
           '\texttt{?resonance\_history = true}.'))
     call var_list%append_real (var_str ("resonance_on_shell_turnoff"), &
           0._default, &
           intrinsic=.true., &
           description=var_str ( &
           'The real variable \texttt{resonance\_on\_shell\_turnoff ' // &
           '= {\em <num>}}, if positive, ' // &
           'controls the smooth transition from resonance-like ' // &
           'to background-like events.  The relative strength of a ' // &
           'resonance is reduced by a Gaussian with width given by this ' // &
           'variable.  In any case, events are treated as background-like ' // &
           'when the off-shellness is greater than ' // &
           '\texttt{resonance\_on\_shell\_limit}.  All of this applies ' // &
           'only if \texttt{?resonance\_history = true}.'))
     call var_list%append_real (var_str ("resonance_background_factor"), &
           1._default, &
           intrinsic=.true., &
           description=var_str ( &
           'The real variable \texttt{resonance\_background\_factor} ' // &
           'controls resonance insertion if a resonance ' // &
           'history applies to a particular event.  In determining '// &
           'whether event kinematics qualifies as resonant or non-resonant, ' //&
           'the non-resonant probability is multiplied by this factor ' // &
           'Setting the factor to zero removes the background ' // &
           'configuration as long as the kinematics qualifies as on-shell ' // &
           'as qualified by \texttt{resonance\_on\_shell\_limit}.'))
      call var_list%append_log (var_str ("?keep_beams"), .false., &
           intrinsic=.true., &
           description=var_str ('The logical variable \ttt{?keep\_beams ' // &
           '= true/false} specifies whether beam particles and beam remnants ' // &
           'are included when writing event files.  For example, in order ' // &
           'to read Les Houches accord event files into \pythia, no beam ' // &
           'particles are allowed.'))
     call var_list%append_log (var_str ("?keep_remnants"), .true., &
           intrinsic=.true., &
           description=var_str ('The logical variable \ttt{?keep\_beams ' // &
           '= true/false} is respected only if \ttt{?keep\_beams} is set.  ' // &
           'If \ttt{true}, beam remnants are tagged as outgoing particles ' // &
           'if they have been neither showered nor hadronized, i.e., have ' // &
           'no children.  If \ttt{false}, beam remnants are also included ' // &
           'in the event record, but tagged as unphysical.  Note that for ' // &
           'ISR and/or beamstrahlung spectra, the radiated photons are ' // &
           'considered as beam remnants.'))
     call var_list%append_log (var_str ("?recover_beams"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the beam particles ' // &
           'should be reconstructed when reading event/rescanning files ' // &
           'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // &
           '\newline \ttt{?update\_weight})'))
     call var_list%append_log (var_str ("?update_event"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the events in ' // &
           'an event file should be rebuilt from the hard process when ' // &
           'reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // &
           '\ttt{?recover\_beams}, \ttt{?update\_sqme}, \ttt{?update\_weight})'))
     call var_list%append_log (var_str ("?update_sqme"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whehter the squared ' // &
           'matrix element in an event file should be updated/recalculated ' // &
           'when reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // &
           '\newline \ttt{?recover\_beams}, \ttt{?update\_event}, \ttt{?update\_weight})'))
     call var_list%append_log (var_str ("?update_weight"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the weights ' // &
           'in an event file should be updated/recalculated when reading ' // &
           'event/rescanning files into \whizard. (cf. \ttt{rescan}, \ttt{?recover\_beams}, ' // &
           '\newline \ttt{?update\_event}, \ttt{?update\_sqme})'))
     call var_list%append_log (var_str ("?use_alphas_from_file"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the current ' // &
           '$\alpha_s$ definition should be used when recalculating matrix ' // &
           'elements for events read from file, or the value that is stored ' // &
           'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // &
           '\ttt{?use\_scale\_from\_file})'))
     call var_list%append_log (var_str ("?use_scale_from_file"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the current ' // &
           'energy-scale expression should be used when recalculating matrix ' // &
           'elements for events read from file, or the value that is stored ' // &
           'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // &
           '\ttt{?use\_alphas\_from\_file})'))
     call var_list%append_log (var_str ("?allow_decays"), .true., &
           intrinsic=.true., &
           description=var_str ('Master flag to switch on cascade decays ' // &
           'for final state particles as an event transform. As a default, ' // &
           'it is switched on. (cf. also \ttt{?auto\_decays}, ' // &
           '\ttt{auto\_decays\_multiplicity}, \ttt{?auto\_decays\_radiative}, ' // &
           '\ttt{?decay\_rest\_frame})'))
     call var_list%append_log (var_str ("?auto_decays"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag, particularly as optional argument of the ($\to$) ' // &
           '\ttt{unstable} command, that tells \whizard\ to automatically ' // &
           'determine the decays of that particle up to the final state ' // &
           'multplicity ($\to$) \ttt{auto\_decays\_multiplicity}. Depending ' // &
           'on the flag ($\to$) \ttt{?auto\_decays\_radiative}, radiative ' // &
           'decays will be taken into account or not. (cf. also \ttt{unstable}, ' // &
           '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay})'))
     call var_list%append_int (var_str ("auto_decays_multiplicity"), 2, &
           intrinsic=.true., &
           description=var_str ('Integer parameter, that sets -- ' // &
           'for the ($\to$) \ttt{?auto\_decays} option to let \whizard\ ' // &
           'automatically determine the decays of a particle set as ($\to$) ' // &
           '\ttt{unstable} -- the maximal final state multiplicity that ' // &
           'is taken into account. The default is \ttt{2}. The flag \ttt{?auto\_decays\_radiative} ' // &
           'decides whether radiative decays are taken into account. (cf.\ ' // &
           'also \ttt{unstable}, \ttt{?auto\_decays})'))
     call var_list%append_log (var_str ("?auto_decays_radiative"), .false., &
           intrinsic=.true., &
           description=var_str ("If \whizard's automatic detection " // &
           'of decay channels are switched on ($\to$ \ttt{?auto\_decays} ' // &
           'for the ($\to$) \ttt{unstable} command, this flags decides ' // &
           'whether radiative decays (e.g. containing additional photon(s)/gluon(s)) ' // &
           'are taken into account or not. (cf. also \ttt{unstable}, \ttt{auto\_decays\_multiplicity})'))
     call var_list%append_log (var_str ("?decay_rest_frame"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that allows to force a particle decay ' // &
           'to be simulated in its rest frame.  This simplifies the calculation ' // &
           'for decays as stand-alone processes, but makes the process ' // &
           'unsuitable for use in a decay chain.'))
     call var_list%append_log (var_str ("?isotropic_decay"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that -- in case of using factorized ' // &
           'production and decays using the ($\to$) \ttt{unstable} command ' // &
           '-- tells \whizard\ to switch off spin correlations completely ' // &
           '(isotropic decay). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // &
           '\ttt{decay\_helicity}, \ttt{?diagonal\_decay})'))
     call var_list%append_log (var_str ("?diagonal_decay"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that -- in case of using factorized ' // &
           'production and decays using the ($\to$) \ttt{unstable} command ' // &
           '-- tells \whizard\ instead of full spin correlations to take ' // &
           'only the diagonal entries in the spin-density matrix (i.e. ' // &
           'classical spin correlations). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // &
           '\ttt{decay\_helicity}, \ttt{?isotropic\_decay})'))
     call var_list%append_int (var_str ("decay_helicity"), &
           intrinsic=.true., &
           description=var_str ('If this parameter is given an integer ' // &
           'value, any particle decay triggered by a subsequent \ttt{unstable} ' // &
           'declaration will receive a projection on the given helicity ' // &
           'state for the unstable particle.  (cf. also \ttt{unstable}, ' // &
           '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay}.  The latter ' // &
           'parameters, if true, take precdence over any \ttt{?decay\_helicity} setting.)'))
     call var_list%append_log (var_str ("?polarized_events"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag that allows to select certain helicity ' // &
             'combinations in final state particles in the event files, ' // &
             'and perform analysis on polarized event samples. (cf. also ' // &
             '\ttt{simulate}, \ttt{polarized}, \ttt{unpolarized})'))
     call var_list%append_string (var_str ("$polarization_mode"), &
          var_str ("helicity"), &
          intrinsic=.true., &
          description=var_str ('String variable that specifies the mode in ' // &
          'which the polarization of particles is handled when polarized events ' // &
          'are written out. Possible options are \ttt{"ignore"}, \ttt{"helicity"}, ' // &
          '\ttt{"factorized"}, and \ttt{"correlated"}. For more details cf. the ' // &
          'detailed section.'))
     call var_list%append_log (var_str ("?colorize_subevt"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag that enables color-index tracking ' // &
             'in the subevent (\ttt{subevt}) objects that are used for ' // &
             'internal event analysis.'))
     call var_list%append_real (var_str ("tolerance"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real variable that defines the absolute ' // &
           'tolerance with which the (logical) function \ttt{expect} accepts ' // &
           'equality or inequality: \ttt{tolerance = {\em <num>}}. This ' // &
           'can e.g. be used for cross-section tests and backwards compatibility ' // &
           'checks.  (cf. also \ttt{expect})'))
     call var_list%append_int (var_str ("checkpoint"), 0, &
          intrinsic = .true., &
          description=var_str ('Setting this integer variable to a positive ' // &
          'integer $n$ instructs simulate to print out a progress summary ' // &
          'every $n$ events.'))
     call var_list%append_int (var_str ("event_callback_interval"), 0, &
          intrinsic = .true., &
          description=var_str ('Setting this integer variable to a positive ' // &
          'integer $n$ instructs simulate to print out a progress summary ' // &
          'every $n$ events.'))
     call var_list%append_log (var_str ("?pacify"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that allows to suppress numerical ' // &
          'noise and give screen and log file output with a lower number ' // &
          'of significant digits. Mainly for debugging purposes. (cf. also ' // &
          '\ttt{?sample\_pacify})'))
     call var_list%append_string (var_str ("$out_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This character variable allows to specify ' // &
           'the name of the data file to which the histogram and plot data ' // &
           'are written (cf. also \ttt{write\_analysis}, \ttt{open\_out}, ' // &
           '\ttt{close\_out})'))
     call var_list%append_log (var_str ("?out_advance"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that sets advancing in the \ttt{printf} ' // &
           'output commands, i.e. continuous printing with no line feed ' // &
           'etc. (cf. also \ttt{printf})'))
      !!! JRR: WK please check (#542)
 !     call var_list%append_log (var_str ("?out_custom"), .false., &
 !           intrinsic=.true.)
 !     call var_list%append_string (var_str ("$out_comment"), var_str ("# "), &
 !           intrinsic=.true.)
 !     call var_list%append_log (var_str ("?out_header"), .true., &
 !           intrinsic=.true.)
 !     call var_list%append_log (var_str ("?out_yerr"), .true., &
 !           intrinsic=.true.)
 !     call var_list%append_log (var_str ("?out_xerr"), .true., &
 !           intrinsic=.true.)
     call var_list%append_int (var_str ("real_range"), &
          range (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This integer gives the decimal exponent ' // &
          'range of the numeric model for the real float type in use. It cannot ' // &
          'be set by the user. (cf. also \ttt{real\_precision}, ' // &
          '\ttt{real\_epsilon}, \ttt{real\_tiny}).'))
     call var_list%append_int (var_str ("real_precision"), &
          precision (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This integer gives the precision of ' // &
          'the numeric model for the real float type in use. It cannot ' // &
          'be set by the user. (cf. also \ttt{real\_range}, ' // &
          '\ttt{real\_epsilon}, \ttt{real\_tiny}).'))
     call var_list%append_real (var_str ("real_epsilon"), &
          epsilon (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This gives the smallest number $E$ ' // &
          'of the same kind as the float type for which $1 + E > 1$. ' // &
          'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // &
          '\ttt{real\_tiny}, \ttt{real\_precision}).'))
     call var_list%append_real (var_str ("real_tiny"), &
          tiny (real_specimen), intrinsic = .true., locked = .true., &
          description=var_str ('This gives the smallest positive (non-zero) ' // &
          'number in the numeric model for the real float type in use. ' // &
          'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // &
          '\ttt{real\_epsilon}, \ttt{real\_precision}).'))
   end subroutine var_list_set_core_defaults
 
 @ %def var_list_set_core_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_integration_defaults => var_list_set_integration_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_integration_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$integration_method"), var_str ("vamp"), &
           intrinsic=.true., &
           description=var_str ('This string variable specifies the method ' // &
           'for performing the multi-dimensional phase-space integration. ' // &
           'The default is the \vamp\ algorithm (\ttt{"vamp"}), other options ' // &
           'are via the numerical midpoint rule (\ttt{"midpoint"}) or an ' // &
           'alternate \vamptwo\ implementation that is MPI-parallelizable ' // &
           '(\ttt{"vamp2"}).'))
     call var_list%append_int (var_str ("threshold_calls"), 10, &
           intrinsic=.true., &
           description=var_str ('This integer variable gives a limit for ' // &
           'the number of calls in a given channel which acts as a lower ' // &
           'threshold for the channel weight. If the number of calls in ' // &
           'that channel falls below this threshold, the weight is not ' // &
           'lowered further but kept at this threshold. (cf. also ' // &
           '\ttt{channel\_weights\_power})'))
     call var_list%append_int (var_str ("min_calls_per_channel"), 10, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the minimal " // &
           'number every channel must be called. If the number of calls ' // &
           'from the iterations is too small, \whizard\ will automatically ' // &
           'increase the number of calls. (cf. \ttt{iterations}, \ttt{min\_calls\_per\_bin}, ' // &
           '\ttt{min\_bins}, \ttt{max\_bins})'))
     call var_list%append_int (var_str ("min_calls_per_bin"), 10, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the minimal " // &
           'number every bin in an integration dimension must be called. ' // &
           'If the number of calls from the iterations is too small, \whizard\ ' // &
           'will automatically increase the number of calls. (cf. \ttt{iterations}, ' // &
           '\ttt{min\_calls\_per\_channel}, \ttt{min\_bins}, \ttt{max\_bins})'))
     call var_list%append_int (var_str ("min_bins"), 3, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the minimal " // &
           'number of bins per integration dimension. (cf. \ttt{iterations}, ' // &
           '\ttt{max\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})'))
     call var_list%append_int (var_str ("max_bins"), 20, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that modifies the settings ' // &
           "of the \vamp\ integrator's grid parameters. It sets the maximal " // &
           'number of bins per integration dimension. (cf. \ttt{iterations}, ' // &
           '\ttt{min\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})'))
     call var_list%append_log (var_str ("?stratified"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that switches between stratified ' // &
           'and importance sampling for the \vamp\ integration method.'))
     call var_list%append_log (var_str ("?use_vamp_equivalences"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether equivalence ' // &
           'relations (symmetries) between different integration channels ' // &
           'are used by the \vamp\ integrator.'))
     call var_list%append_log (var_str ("?vamp_verbose"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that sets the chattiness of the \vamp\ ' // &
          'integrator. If set, not only errors, but also all warnings and ' // &
          'messages will be written out (not the default). (cf. also \newline ' // &
          '\ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_global\_verbose}, ' // &
          '\ttt{?vamp\_history\_channels}, \newline \ttt{?vamp\_history\_channels\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_global"), &
          .true., intrinsic=.true., &
          description=var_str ('Flag that decides whether the global history ' // &
          'of the grid adaptation of the \vamp\ integrator are written ' // &
          'into the process logfiles.  (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // &
          '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_history\_channels\_verbose}, ' // &
          '\ttt{?vamp\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_global_verbose"), &
          .false., intrinsic=.true., &
          description=var_str ('Flag that decides whether the global history ' // &
          'of the grid adaptation of the \vamp\ integrator are written ' // &
          'into the process logfiles in an extended version. Only for debugging ' // &
          'purposes.  (cf. also \ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_channels}, ' // &
          '\ttt{?vamp\_verbose}, \ttt{?vamp\_history\_channels\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_channels"), &
          .false., intrinsic=.true., &
          description=var_str ('Flag that decides whether the history of ' // &
          'the grid adaptation of the \vamp\ integrator for every single ' // &
          'channel are written into the process logfiles. Only for debugging ' // &
          'purposes.  (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // &
          '\ttt{?vamp\_history\_global}, \ttt{?vamp\_verbose}, \newline ' // &
          '\ttt{?vamp\_history\_channels\_verbose})'))
     call var_list%append_log (var_str ("?vamp_history_channels_verbose"), &
          .false., intrinsic=.true., &
          description=var_str ('Flag that decides whether the history of ' // &
          'the grid adaptation of the \vamp\ integrator for every single ' // &
          'channel are written into the process logfiles in an extended ' // &
          'version. Only for debugging purposes.  (cf. also \ttt{?vamp\_history\_global}, ' // &
          '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_verbose}, \ttt{?vamp\_history\_global\_verbose})'))
     call var_list%append_string (var_str ("$run_id"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable \ttt{\$run\_id = "{\em ' // &
           '<id>}"} that allows to set a special ID for a particular process ' // &
           'run, e.g. in a scan. The run ID is then attached to the process ' // &
           'log file: \newline \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
           '<id>}.log}, the \vamp\ grid file: \newline \ttt{{\em <proc\_name>}\_{\em ' // &
           '<proc\_comp>}.{\em <id>}.vg}, and the phase space file: \newline ' // &
           '\ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em <id>}.phs}. ' // &
           'The run ID string distinguishes among several runs for the ' // &
           'same process.  It identifies process instances with respect ' // &
           'to adapted integration grids and similar run-specific data.  ' // &
           'The run ID is kept when copying processes for creating instances, ' // &
           'however, so it does not distinguish event samples. (cf.\ also ' // &
           '\ttt{\$job\_id}, \ttt{\$compile\_workspace}'))
     call var_list%append_int (var_str ("n_calls_test"), 0, &
           intrinsic=.true., &
           description=var_str ('Integer variable that allows to set a ' // &
           'certain number of matrix element sampling test calls without ' // &
           'actually integrating the process under consideration. (cf. ' // &
           '\ttt{integrate})'))
     call var_list%append_log (var_str ("?integration_timer"), .true., &
           intrinsic=.true., &
           description=var_str ('This flag switches the integration timer ' // &
           'on and off, that gives the estimate for the duration of the ' // &
           'generation of 10,000 unweighted events for each integrated ' // &
           'process.'))
     call var_list%append_log (var_str ("?check_grid_file"), .true., &
           intrinsic=.true., &
           description=var_str ('Setting this to false turns off all sanity ' // &
           'checks when reading a grid file with previous integration data.  ' // &
           'Use this at your own risk; the program may return wrong results ' // &
           'or crash if data do not match. (cf. also \ttt{?check\_event\_file}, \ttt{?check\_phs\_file}) '))
     call var_list%append_real (var_str ("accuracy_goal"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows the user to ' // &
           'set a minimal accuracy that should be achieved in the Monte-Carlo ' // &
           'integration of a certain process. If that goal is reached, ' // &
           'grid and weight adapation stop, and this result is used for ' // &
           'simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
           '\ttt{error\_goal}, \ttt{relative\_error\_goal}, ' // &
           '\ttt{error\_threshold})'))
     call var_list%append_real (var_str ("error_goal"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows the user to ' // &
           'set a minimal absolute error that should be achieved in the ' // &
           'Monte-Carlo integration of a certain process. If that goal ' // &
           'is reached, grid and weight adapation stop, and this result ' // &
           'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
           '\ttt{accuracy\_goal}, \ttt{relative\_error\_goal}, \ttt{error\_threshold})'))
     call var_list%append_real (var_str ("relative_error_goal"), 0._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows the user to ' // &
           'set a minimal relative error that should be achieved in the ' // &
           'Monte-Carlo integration of a certain process. If that goal ' // &
           'is reached, grid and weight adaptation stop, and this result ' // &
           'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
           '\ttt{accuracy\_goal}, \ttt{error\_goal}, \ttt{error\_threshold})'))
     call var_list%append_int (var_str ("integration_results_verbosity"), 1, &
           intrinsic=.true., &
           description=var_str ('Integer parameter for the verbosity of ' // &
           'the integration results in the process-specific logfile.'))
     call var_list%append_real (var_str ("error_threshold"), &
          0._default, intrinsic=.true., &
          description=var_str ('The real parameter \ttt{error\_threshold ' // &
          '= {\em <num>}} declares that any error value (in absolute numbers) ' // &
          'smaller than \ttt{{\em <num>}} is to be considered zero. The ' // &
          'units are \ttt{fb} for scatterings and \ttt{GeV} for decays. ' // &
          '(cf. also \ttt{integrate}, \ttt{iterations}, \ttt{accuracy\_goal}, ' // &
          '\ttt{error\_goal}, \ttt{relative\_error\_goal})'))
     call var_list%append_real (var_str ("channel_weights_power"), 0.25_default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that allows to vary the ' // &
           'exponent of the channel weights for the \vamp\ integrator.'))
     call var_list%append_string (var_str ("$integrate_workspace"), &
           intrinsic=.true., &
           description=var_str ('Character string that tells \whizard\ ' // &
           'the subdirectory where to find the run-specific phase-space ' // &
           'configuration and the \vamp\ and \vamptwo\ grid files. ' // &
           'If undefined (as per default), \whizard\ creates them and ' // &
           'searches for them in the ' // &
           'current directory.  (cf. also  \ttt{\$job\_id}, ' // &
           '\ttt{\$run\_id}, \ttt{\$compile\_workspace})'))
     call var_list%append_string (var_str ("$vamp_grid_format"), var_str ("ascii"), &
          intrinsic=.true., &
          description=var_str ('Character string that tells \whizard\ ' // &
          'the file format for \ttt{vamp2} to use for writing and reading ' // &
          'the configuration for the multi-channel integration setup and the ' // &
          '\vamptwo\ (only) grid data. The values can be \ttt{ascii} for a single ' // &
          'human-readable grid file with ending \ttt{.vg2} or \ttt{binary} for two files, ' // &
          'a human-readable header file with ending \ttt{.vg2} and binary file with ending ' // &
          '\ttt{.vgx2} storing the grid data.' // &
          'The main purpose of the binary format is to perform faster I/O, e.g. for HPC runs.' // &
          '\whizard\ can convert between the different file formats automatically.'))
   end subroutine var_list_set_integration_defaults
 
 @ %def var_list_set_integration_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_phase_space_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$phs_method"), var_str ("default"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to choose ' // &
           'the phase-space parameterization method. The default is the ' // &
           '\ttt{"wood"} method that takes into account electroweak/BSM ' // &
           'resonances. Note that this might not be the best choice for ' // &
           '(pure) QCD amplitudes. (cf. also \ttt{\$phs\_file})'))
     call var_list%append_log (var_str ("?vis_channels"), .false., &
           intrinsic=.true., &
           description=var_str ('Optional logical argument for the \ttt{integrate} ' // &
           'command that demands \whizard\ to generate a PDF or postscript ' // &
           'output showing the classification of the found phase space ' // &
           'channels (if the phase space method \ttt{wood} has been used) ' // &
           'according to their properties: \ttt{integrate (foo) \{ iterations=3:10000 ' // &
           '?vis\_channels = true \}}. The default is \ttt{false}.  (cf. ' // &
           'also \ttt{integrate}, \ttt{?vis\_history})'))
     call var_list%append_log (var_str ("?check_phs_file"), .true., &
           intrinsic=.true., &
           description=var_str ('Setting this to false turns off all sanity ' // &
           'checks when reading a previously generated phase-space configuration ' // &
           'file.  Use this at your own risk; the program may return wrong ' // &
           'results or crash if data do not match. (cf. also \ttt{?check\_event\_file}, ' // &
           '\ttt{?check\_grid\_file})'))
     call var_list%append_string (var_str ("$phs_file"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This string variable allows the user to ' // &
           'set an individual file name for the phase space parameterization ' // &
           'for a particular process: \ttt{\$phs\_file = "{\em <file\_name>}"}. ' // &
           'If not set, the default is \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
           '<run\_id>}.phs}. (cf. also \ttt{\$phs\_method})'))
     call var_list%append_log (var_str ("?phs_only"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag (particularly as optional argument ' // &
           'of the $\to$ \ttt{integrate} command) that allows to only generate ' // &
           'the phase space file, but not perform the integration. (cf. ' // &
           'also \ttt{\$phs\_method}, \ttt{\$phs\_file})'))
     call var_list%append_real (var_str ("phs_threshold_s"), 50._default, &
           intrinsic=.true., &
           description=var_str ('For the phase space method \ttt{wood}, ' // &
           'this real parameter sets the threshold below which particles ' // &
           'are assumed to be massless in the $s$-channel like kinematic ' // &
           'regions. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_off\_shell}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // &
           '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_threshold_t"), 100._default, &
           intrinsic=.true., &
           description=var_str ('For the phase space method \ttt{wood}, ' // &
           'this real parameter sets the threshold below which particles ' // &
           'are assumed to be massless in the $t$-channel like kinematic ' // &
           'regions. (cf. also \ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // &
           '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_int (var_str ("phs_off_shell"), 2, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the number ' // &
           'of off-shell (not $t$-channel-like, non-resonant) lines that ' // &
           'are taken into account to find a valid phase-space setup in ' // &
           'the \ttt{wood} phase-space method.  (cf. also \ttt{phs\_threshold\_t}, ' // &
           '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\ttt{?phs\_s\_mapping})'))
     call var_list%append_int (var_str ("phs_t_channel"), 6, &
           intrinsic=.true., &
           description=var_str ('Integer parameter that sets the number ' // &
           'of $t$-channel propagators in multi-peripheral diagrams that ' // &
           'are taken into account to find a valid phase-space setup in ' // &
           'the \ttt{wood} phase-space method.  (cf. also \ttt{phs\_threshold\_t}, ' // &
           '\ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_e_scale"), 10._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the energy scale ' // &
           'that acts as a cutoff for parameterizing radiation-like kinematics ' // &
           'in the \ttt{wood} phase space method. \whizard\ takes the maximum ' // &
           'of this value and the width of the propagating particle as ' // &
           'a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // &
           '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_m_scale"), 10._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the mass scale ' // &
           'that acts as a cutoff for parameterizing collinear and infrared ' // &
           'kinematics in the \ttt{wood} phase space method. \whizard\ ' // &
           'takes the maximum of this value and the mass of the propagating ' // &
           'particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
           '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_real (var_str ("phs_q_scale"), 10._default, &
           intrinsic=.true., &
           description=var_str ('Real parameter that sets the momentum ' // &
           'transfer scale that acts as a cutoff for parameterizing $t$- ' // &
           'and $u$-channel like kinematics in the \ttt{wood} phase space ' // &
           'method. \whizard\ takes the maximum of this value and the mass ' // &
           'of the propagating particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, ' // &
           '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  ' // &
           '\ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_keep_nonresonant"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether the \ttt{wood} ' // &
           'phase space method takes into account also non-resonant contributions.  ' // &
           '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // &
           '\ttt{phs\_q\_scale}, \ttt{phs\_e\_scale}, \ttt{?phs\_step\_mapping}, ' // &
           '\newline \ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_step_mapping"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that switches on (or off) a particular ' // &
           'phase space mapping for resonances, where the mass and width ' // &
           'of the resonance are explicitly set as channel cutoffs. (cf. ' // &
           'also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, ' // &
           '\ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, \newline \ttt{phs\_m\_scale}, ' // &
           '\ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, \ttt{?phs\_step\_mapping\_exp}, ' // &
           '\newline \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_step_mapping_exp"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that switches on (or off) a particular ' // &
           'phase space mapping for resonances, where the mass and width ' // &
           'of the resonance are explicitly set as channel cutoffs. This ' // &
           'is an exponential mapping in contrast to ($\to$) \ttt{?phs\_step\_mapping}. ' // &
           '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
           '\ttt{?phs\_step\_mapping}, \ttt{?phs\_s\_mapping})'))
     call var_list%append_log (var_str ("?phs_s_mapping"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that allows special mapping for $s$-channel ' // &
           'resonances.  (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
           '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell},  \ttt{phs\_e\_scale}, ' // &
           '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, ' // &
           '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp})'))
     call var_list%append_log (var_str ("?vis_history"), .false., &
           intrinsic=.true., &
           description=var_str ('Optional logical argument for the \ttt{integrate} ' // &
           'command that demands \whizard\ to generate a PDF or postscript ' // &
           'output showing the adaptation history of the Monte-Carlo integration ' // &
           'of the process under consideration. (cf. also \ttt{integrate}, ' // &
           '\ttt{?vis\_channels})'))
   end subroutine var_list_set_phase_space_defaults
 
 @ %def var_list_set_phase_space_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_gamelan_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_int (&
          var_str ("n_bins"), 20, &
          intrinsic=.true., &
          description=var_str ("Settings for \whizard's internal graphics " // &
          'output: integer value that sets the number of bins in histograms. ' // &
          '(cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
          '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
          '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, ' // &
          '\ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, ' // &
          '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
          '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
          '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
          '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
          '\ttt{\$symbol})'))
     call var_list%append_log (&
          var_str ("?normalize_bins"), .false., &
          intrinsic=.true., &
          description=var_str ("Settings for \whizard's internal graphics " // &
          'output: flag that determines whether the weights shall be normalized ' // &
          'to the bin width or not. (cf. also \ttt{n\_bins}, \ttt{\$obs\_label}, ' // &
          '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
          '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
          '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
          '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
          '\newline \ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
          '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \newline ' // &
          '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
          '\ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$obs_label"), var_str (""), &
          intrinsic=.true., &
          description=var_str ("Settings for \whizard's internal graphics " // &
          'output: this is a string variable \ttt{\$obs\_label = "{\em ' // &
          '<LaTeX\_Code>}"} that allows to attach a label to a plotted ' // &
          'or histogrammed observable. (cf. also \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // &
          '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
          '\ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
          '\ttt{graph\_height\_mm}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
          '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
          '\ttt{?draw\_histogram}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
          '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
          '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$obs_unit"), var_str (""), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: this is a string variable \ttt{\$obs\_unit = "{\em ' // &
           '<LaTeX\_Code>}"} that allows to attach a \LaTeX\ physical unit ' // &
           'to a plotted or histogrammed observable. (cf. also \ttt{n\_bins}, ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$title"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('This string variable sets the title of ' // &
           'a plot in a \whizard\ analysis setup, e.g. a histogram or an ' // &
           'observable. The syntax is \ttt{\$title = "{\em <your title>}"}. ' // &
           'This title appears as a section header in the analysis file, ' // &
           'but not in the screen output of the analysis.  (cf. also \ttt{n\_bins}, ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \newline \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$description"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to specify ' // &
           'a description text for the analysis, \ttt{\$description = "{\em ' // &
           '<LaTeX analysis descr.>}"}.  This line appears below the title ' // &
           'of a corresponding analysis, on top of the respective plot.  ' // &
           '(cf. also \ttt{analysis}, \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, ' // &
           '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$x_label"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable, \ttt{\$x\_label = "{\em ' // &
           '<LaTeX code>}"}, that sets the $x$ axis label in a plot or ' // &
           'histogram in a \whizard\ analysis.  (cf. also \ttt{analysis}, ' // &
           '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$y\_label}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_string (var_str ("$y_label"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable, \ttt{\$y\_label = "{\em ' // &
           '<LaTeX\_code>}"}, that sets the $y$ axis label in a plot or ' // &
           'histogram in a \whizard\ analysis.  (cf. also \ttt{analysis}, ' // &
           '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{?y\_log}, ' // &
           '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
           '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
     call var_list%append_int (var_str ("graph_width_mm"), 130, &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: integer value that sets the width of a graph or histogram ' // &
           'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // &
           '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_int (var_str ("graph_height_mm"), 90, &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: integer value that sets the height of a graph or histogram ' // &
           'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // &
           '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?y_log"), .false., &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that makes the $y$ axis logarithmic. (cf. also ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
           '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_log (var_str ("?x_log"), .false., &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that makes the $x$ axis logarithmic. (cf. also ' // &
           '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
           '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // &
           '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_real (var_str ("x_min"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the lower limit of the $x$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_real (var_str ("x_max"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the upper limit of the $x$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_min}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_real (var_str ("y_min"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the lower limit of the $y$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_max}, \ttt{y\_max}, \ttt{x\_min}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_real (var_str ("y_max"),  &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: real parameter that sets the upper limit of the $y$ ' // &
           'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{x\_max}, \ttt{x\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$gmlcode_bg"), var_str (""), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: string variable that allows to define a background ' // &
           'for plots and histograms (i.e. it is overwritten by the plot/histogram), ' // &
           'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // &
           'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$gmlcode_fg"), var_str (""), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: string variable that allows to define a foreground ' // &
           'for plots and histograms (i.e. it overwrites the plot/histogram), ' // &
           'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // &
           'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_histogram"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to either plot data as a ' // &
           'histogram or as a continuous line (if $\to$ \ttt{?draw\_curve} ' // &
           'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_base"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to insert a \ttt{base} statement ' // &
           'in the analysis code to calculate the plot data from a data ' // &
           'set. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\ttt{\$symbol}, \newline \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\newline \ttt{\$err\_options})'))
     call var_list%append_log (var_str ("?draw_piecewise"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to data from a data set piecewise, ' // &
           'i.e. histogram style. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit},  \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max},  ' // &
           '\ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg},  ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_base}, \ttt{?fill\_curve}, ' // &
           '\ttt{\$symbol}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options})'))
     call var_list%append_log (var_str ("?fill_curve"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to fill data curves (e.g. ' // &
           'as a histogram). The style can be set with $\to$ \ttt{\$fill\_options ' // &
           '= "{\em <LaTeX\_code>}"}. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_curve"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that tells \whizard\ to either plot data as a ' // &
           'continuous line or as a histogram (if $\to$ \ttt{?draw\_histogram} ' // &
           'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\ttt{?draw\_histogram}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
           '\ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_errors"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that determines whether error bars should be drawn ' // &
           'or not. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\newline \ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_log (var_str ("?draw_symbols"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: flag that determines whether particular symbols (specified ' // &
           'by $\to$ \ttt{\$symbol = "{\em <LaTeX\_code>}"}) should be ' // &
           'used for plotting data points  (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\ttt{?fill\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_curve}, ' // &
           '\ttt{?draw\_errors}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
           '\newline \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$fill_options"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$fill\_options = "{\em <LaTeX\_code>}"} is a ' // &
           'string variable that allows to set fill options when plotting ' // &
           'data as filled curves with the $\to$ \ttt{?fill\_curve} flag. ' // &
           'For more details see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
           '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
           '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
           '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
           '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
           '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
           '\newline \ttt{?draw\_symbols}, \ttt{?fill\_curve}, \ttt{\$draw\_options}, ' // &
           '\ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$draw_options"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$draw\_options = "{\em <LaTeX\_code>}"} is a ' // &
           'string variable that allows to set specific drawing options ' // &
           'for plots and histograms. For more details see the \gamelan\ ' // &
           'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
           '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
           '\ttt{?draw\_histogram}, \ttt{\$err\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$err_options"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$err\_options = "{\em <LaTeX\_code>}"} is a string ' // &
           'variable that allows to set specific drawing options for errors ' // &
           'in plots and histograms. For more details see the \gamelan\ ' // &
           'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
           '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
           '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
           '\ttt{?draw\_histogram}, \ttt{\$draw\_options}, \ttt{\$symbol})'))
     call var_list%append_string (var_str ("$symbol"), &
           intrinsic=.true., &
           description=var_str ("Settings for \whizard's internal graphics " // &
           'output: \ttt{\$symbol = "{\em <LaTeX\_code>}"} is a string ' // &
           'variable for the symbols that should be used for plotting data ' // &
           'points.  (cf. also \ttt{\$obs\_label}, \ttt{?normalize\_bins}, ' // &
           '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
           '\ttt{\$y\_label}, \newline \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
           '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
           '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
           '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
           '\newline \ttt{?draw\_histogram}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
           '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \newline \ttt{\$err\_options}, ' // &
           '\ttt{?draw\_symbols})'))
     call var_list%append_log (&
          var_str ("?analysis_file_only"), .false., &
          intrinsic=.true., &
          description=var_str ('Allows to specify that only \LaTeX\ files ' // &
          "for \whizard's graphical analysis are written out, but not processed. " // &
          '(cf. \ttt{compile\_analysis}, \ttt{write\_analysis})'))
   end subroutine var_list_set_gamelan_defaults
 
 @ %def var_list_set_gamelan_defaults
 @ FastJet parameters and friends
 <<Variables: var list: TBP>>=
   procedure :: set_clustering_defaults => var_list_set_clustering_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_clustering_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_int (&
          var_str ("kt_algorithm"), &
          kt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the ' // &
          'interfaced external \fastjet\ package.  (cf. also ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, ' // &
          '\ttt{plugin\_algorithm}, ' // &
          '\newline\ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("cambridge_algorithm"), &
          cambridge_algorithm, intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("antikt_algorithm"), &
          antikt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("genkt_algorithm"), &
          genkt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_for\_passive\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r}), \ttt{jet\_p}'))
     call var_list%append_int (&
          var_str ("cambridge_for_passive_algorithm"), &
          cambridge_for_passive_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_algorithm}, \ttt{plugin\_algorithm}, \newline ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("genkt_for_passive_algorithm"), &
          genkt_for_passive_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("ee_kt_algorithm"), &
          ee_kt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_genkt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("ee_genkt_algorithm"), &
          ee_genkt_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_kt\_algorithm}, ' // &
          '\ttt{jet\_r}), \ttt{jet\_p})'))
     call var_list%append_int (&
          var_str ("plugin_algorithm"), &
          plugin_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
          '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
          'subevent function. At the moment only available for the interfaced ' // &
          'external \fastjet\ package.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r})'))
     call var_list%append_int (&
          var_str ("undefined_jet_algorithm"), &
          undefined_jet_algorithm, &
          intrinsic = .true., locked = .true., &
          description=var_str ('This is just a place holder for any kind of jet ' // &
          'jet algorithm that is not further specified.  (cf. also \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // &
          '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
          '\ttt{jet\_r}, \ttt{plugin\_algorithm})'))
     call var_list%append_int (&
          var_str ("jet_algorithm"), undefined_jet_algorithm, &
          intrinsic = .true., &
          description=var_str ('Variable that allows to set the type of ' // &
          'jet algorithm when using the external \fastjet\ library. It ' // &
          'accepts one of the following algorithms: ($\to$) \ttt{kt\_algorithm}, ' // &
          '\newline ($\to$) \ttt{cambridge\_[for\_passive\_]algorithm}, ' // &
          '($\to$) \ttt{antikt\_algorithm}, ($\to$) \ttt{plugin\_algorithm}, ' // &
          '($\to$) \ttt{genkt\_[for\_passive\_]algorithm}, ($\to$) ' // &
          '\ttt{ee\_[gen]kt\_algorithm}).  (cf. also \ttt{cluster}, ' // &
          '\ttt{jet\_p}, \ttt{jet\_r}, \ttt{jet\_ycut})'))
     call var_list%append_real (&
          var_str ("jet_r"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the distance measure $R$ used in ' // &
          'some algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_ycut})'))
     call var_list%append_real (&
          var_str ("jet_p"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the exponent of the distance measure $R$ in ' // &
          'the generalized $k_T$ algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r}, \newline\ttt{jet\_ycut})'))
     call var_list%append_real (&
          var_str ("jet_ycut"), 0._default, &
          intrinsic = .true., &
          description=var_str ('Value for the $y$ separation measure used in ' // &
          'the Cambridge-Aachen algorithms that are available via the interface ' // &
          'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
          '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // &
          '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
          '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
          '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})'))
+    call var_list%append_real (&
+         var_str ("jet_dcut"), 0._default, &
+         intrinsic = .true., &
+         description=var_str ('Value for the $d_{ij}$ separation measure used in ' // &
+         'the $e^+e^- k_T$ algorithms that are available via the interface ' // &
+         'to the \fastjet\ package.  (cf. also \ttt{cluster}, \ttt{combine}, ' // &
+         '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // &
+         '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
+         '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
+         '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})'))
     call var_list%append_log (&
          var_str ("?keep_flavors_when_clustering"), .false., &
          intrinsic = .true., &
          description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_clustering ' // &
          '= true/false} specifies whether the flavor of a jet should be ' // &
          'kept during \ttt{cluster} when a jet consists of one quark and ' // &
          'zero or more gluons. Especially useful for cuts on b-tagged ' // &
          'jets (cf. also \ttt{cluster}).'))
   end subroutine var_list_set_clustering_defaults
 
 @ %def var_list_set_clustering_defaults
 @ Frixione isolation parameters and all that:
 <<Variables: var list: TBP>>=
   procedure :: set_isolation_defaults => var_list_set_isolation_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_isolation_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_real (var_str ("photon_iso_eps"), 1._default, &
          intrinsic=.true., &
          description=var_str ('Photon isolation parameter $\epsilon_\gamma$ ' // &
          '(energy fraction) from hep-ph/9801442 (cf. also ' // &
          '\ttt{photon\_iso\_n}, \ttt{photon\_iso\_r0})'))
     call var_list%append_real (var_str ("photon_iso_n"), 1._default, &
          intrinsic=.true., &
          description=var_str ('Photon isolation parameter $n$ ' // &
          '(cone function exponent) from hep-ph/9801442 (cf. also ' // &
          '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_r0})'))
     call var_list%append_real (var_str ("photon_iso_r0"), 0.4_default, &
          intrinsic=.true., &
          description=var_str ('Photon isolation parameter $R_0^\gamma$ ' // &
          '(isolation cone radius) from hep-ph/9801442 (cf. also ' // &
          '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_n})'))
   end subroutine var_list_set_isolation_defaults
 
 @ %def var_list_set_isolation_defaults
 <<Variables: var list: TBP>>=
   procedure :: set_eio_defaults => var_list_set_eio_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_eio_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$sample"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable to set the (base) name ' // &
           'of the event output format, e.g. \ttt{\$sample = "foo"} will ' // &
           'result in an intrinsic binary format event file \ttt{foo.evx}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{simulate}, \ttt{hepevt}, ' // &
           '\ttt{ascii}, \ttt{athena}, \ttt{debug}, \ttt{long}, \ttt{short}, ' // &
           '\ttt{hepmc}, \ttt{lhef}, \ttt{lha}, \ttt{stdhep}, \ttt{stdhep\_up}, ' // &
           '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, \ttt{sample\_max\_tries})'))
     call var_list%append_string (var_str ("$sample_normalization"), var_str ("auto"),&
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'normalization of generated events. There are four options: ' // &
           'option \ttt{"1"} (events normalized to one), \ttt{"1/n"} (sum ' // &
           'of all events in a sample normalized to one), \ttt{"sigma"} ' // &
           '(events normalized to the cross section of the process), and ' // &
           '\ttt{"sigma/n"} (sum of all events normalized to the cross ' // &
           'section). The default is \ttt{"auto"} where unweighted events ' // &
           'are normalized to one, and weighted ones to the cross section. ' // &
           '(cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
           '\ttt{?sample\_pacify}, \ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // &
           '\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_log (var_str ("?sample_pacify"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag, mainly for debugging purposes: suppresses ' // &
           'numerical noise in the output of a simulation. (cf. also \ttt{simulate}, ' // &
           '\ttt{\$sample}, \ttt{sample\_format}, \ttt{\$sample\_normalization}, ' // &
           '\ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // &
           '\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_log (var_str ("?sample_select"), .true., &
           intrinsic=.true., &
           description=var_str ('Logical that determines whether a selection should ' // &
           'be applied to the output event format or not. If set to \ttt{false} a ' // &
           'selection is only considered for the evaluation of observables. (cf. ' // &
           '\ttt{select}, \ttt{selection}, \ttt{analysis})'))
     call var_list%append_int (var_str ("sample_max_tries"), 10000, &
          intrinsic = .true., &
          description=var_str ('Integer variable that sets the maximal ' // &
          'number of tries for generating a single event. The event might ' // &
          'be vetoed because of a very low unweighting efficiency, errors ' // &
          'in the event transforms like decays, shower, matching, hadronization ' // &
          'etc. (cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
          '\ttt{?sample\_pacify}, \ttt{\$sample\_normalization}, ' // &
          '\ttt{sample\_split\_n\_evt}, \newline\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_int (var_str ("sample_split_n_evt"), 0, &
          intrinsic = .true., &
          description=var_str ('When generating events, this integer parameter ' // &
          '\ttt{sample\_split\_n\_evt = {\em <num>}} gives the number \ttt{{\em ' // &
          '<num>}} of breakpoints in the event files, i.e. it splits the ' // &
          'event files into \ttt{{\em <num>} + 1} parts. The parts are ' // &
          'denoted by \ttt{{\em <proc\_name>}.{\em <split\_index>}.{\em ' // &
          '<evt\_extension>}}. Here, \ttt{{\em <split\_index>}} is an integer ' // &
          'running from \ttt{0} to \ttt{{\em <num>}}. The start can be ' // &
          'reset by ($\to$) \ttt{sample\_split\_index}. (cf. also \ttt{simulate}, ' // &
          '\ttt{\$sample}, \ttt{sample\_format}, \ttt{sample\_max\_tries}, ' // &
          '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, ' // &
          '\ttt{sample\_split\_n\_kbytes})'))
     call var_list%append_int (var_str ("sample_split_n_kbytes"), 0, &
          intrinsic = .true., &
          description=var_str ('When generating events, this integer parameter ' // &
          '\ttt{sample\_split\_n\_kbytes = {\em <num>}} limits the file ' // &
          'size of event files.  Whenever an event file has exceeded this ' // &
          'size, counted in kilobytes, the following events will be written ' // &
          'to a new file.  The naming conventions are the same as for ' // &
          '\ttt{sample\_split\_n\_evt}. (cf. also \ttt{simulate}, \ttt{\$sample}, ' // &
          '\ttt{sample\_format}, \ttt{sample\_max\_tries}, \ttt{\$sample\_normalization}, ' // &
          '\ttt{?sample\_pacify})'))
     call var_list%append_int (var_str ("sample_split_index"), 0, &
          intrinsic = .true., &
          description=var_str ('Integer number that gives the starting ' // &
          'index \ttt{sample\_split\_index = {\em <split\_index>}} for ' // &
          'the numbering of event samples \ttt{{\em <proc\_name>}.{\em ' // &
          '<split\_index>}.{\em <evt\_extension>}} split by the \ttt{sample\_split\_n\_evt ' // &
          '= {\em <num>}}. The index runs from \ttt{{\em <split\_index>}} ' // &
          'to \newline \ttt{{\em <split\_index>} + {\em <num>}}. (cf. also \ttt{simulate}, ' // &
          '\ttt{\$sample}, \ttt{sample\_format}, \newline\ttt{\$sample\_normalization}, ' // &
          '\ttt{sample\_max\_tries}, \ttt{?sample\_pacify})'))
     call var_list%append_string (var_str ("$rescan_input_format"), var_str ("raw"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to set the ' // &
           'event format of the event file that is to be rescanned by the ' // &
           '($\to$) \ttt{rescan} command.'))
     call var_list%append_log (var_str ("?read_raw"), .true., &
           intrinsic=.true., &
           description=var_str ('This flag demands \whizard\ to (try to) ' // &
           'read events (from the internal binary format) first before ' // &
           'generating new ones. (cf. \ttt{simulate}, \ttt{?write\_raw}, ' // &
           '\ttt{\$sample}, \ttt{sample\_format})'))
     call var_list%append_log (var_str ("?write_raw"), .true., &
           intrinsic=.true., &
           description=var_str ("Flag to write out events in \whizard's " // &
           'internal binary format. (cf. \ttt{simulate}, \ttt{?read\_raw}, ' // &
           '\ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_raw"), var_str ("evx"), &
          intrinsic=.true., &
          description=var_str ('String variable that allows via \ttt{\$extension\_raw ' // &
          '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
          "to which events in \whizard's internal format are written. If " // &
          'not set, the default file name and suffix is \ttt{{\em <process\_name>}.evx}. ' // &
          '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_default"), var_str ("evt"), &
          intrinsic=.true., &
          description=var_str ('String variable that allows via \ttt{\$extension\_default ' // &
          '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
          'to which events in a the standard \whizard\ verbose ASCII format ' // &
          'are written. If not set, the default file name and suffix is ' // &
          '\ttt{{\em <process\_name>}.evt}. (cf. also \ttt{sample\_format}, ' // &
          '\ttt{\$sample})'))
     call var_list%append_string (var_str ("$debug_extension"), var_str ("debug"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$debug\_extension ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in a long verbose format with debugging information ' // &
           'are written. If not set, the default file name and suffix is ' // &
           '\ttt{{\em <process\_name>}.debug}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{?debug\_process}, \ttt{?debug\_transforms}, ' // &
           '\ttt{?debug\_decay}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_process"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether process information ' // &
           'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // &
           '\ttt{?debug\_decay}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_transforms"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether information ' // &
           'about event transforms will be displayed in the ASCII debug ' // &
           'event format ($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{?debug\_decay}, \ttt{\$debug\_extension}, ' // &
           '\ttt{?debug\_process}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_decay"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether decay information ' // &
           'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // &
           '\ttt{?debug\_process}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})'))
     call var_list%append_log (var_str ("?debug_verbose"), .true., &
           intrinsic=.true., &
           description=var_str ('Flag that decides whether extensive verbose ' // &
           'information will be included in the ASCII debug event format ' // &
           '($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, \ttt{\$sample}, ' // &
           '\ttt{\$debug\_extension}, \ttt{?debug\_decay}, \ttt{?debug\_transforms}, ' // &
           '\ttt{?debug\_process})'))
     call var_list%append_string (var_str ("$dump_extension"), var_str ("pset.dat"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$dump\_extension ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           "to which events in \whizard's internal particle set format " // &
           'are written. If not set, the default file name and suffix is ' // &
           '\ttt{{\em <process\_name>}.pset.dat}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?dump_compressed"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, issues ' // &
           'a very compressed and clear version of the \ttt{dump} ($\to$) ' // &
           'event format. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{\$dump\_extension},  ' // &
           '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?dump_weights"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, includes ' // &
           'cross sections, weights and excess in the \ttt{dump} ($\to$) ' // &
           'event format. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_summary})'))
     call var_list%append_log (var_str ("?dump_summary"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, includes ' // &
           'a summary with momentum sums for incoming and outgoing particles ' // &
           'as well as for beam remnants in the \ttt{dump} ($\to$) ' // &
           'event format. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?dump_screen"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that, if set to \ttt{true}, outputs ' // &
           'events for the \ttt{dump} ($\to$) event format on screen ' // &
           ' instead of to a file. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
           '\ttt{\$dump\_extension}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
     call var_list%append_log (var_str ("?hepevt_ensure_order"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag to ensure that the particle set confirms ' // &
           'the HEPEVT standard. This involves some copying and reordering ' // &
           'to guarantee that mothers and daughters are always next to ' // &
           'each other. Usually this is not necessary.'))
     call var_list%append_string (var_str ("$extension_hepevt"), var_str ("hepevt"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_hepevt ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the \whizard\ version 1 style HEPEVT ASCII ' // &
           'format are written. If not set, the default file name and suffix ' // &
           'is \ttt{{\em <process\_name>}.hepevt}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_ascii_short"), &
           var_str ("short.evt"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_short ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the so called short variant of the \whizard\ ' // &
           'version 1 style HEPEVT ASCII format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.short.evt}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_ascii_long"), &
           var_str ("long.evt"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_long ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the so called long variant of the \whizard\ ' // &
           'version 1 style HEPEVT ASCII format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.long.evt}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_athena"), &
           var_str ("athena.evt"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_athena ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the ATHENA file format are written. If not ' // &
           'set, the default file name and suffix is \ttt{{\em <process\_name>}.athena.evt}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_mokka"), &
            var_str ("mokka.evt"), intrinsic=.true., &
            description=var_str ('String variable that allows via \ttt{\$extension\_mokka ' // &
            '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
            'to which events in the MOKKA format are written. If not set, ' // &
            'the default file name and suffix is \ttt{{\em <process\_name>}.mokka.evt}. ' // &
            '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$lhef_version"), var_str ("2.0"), &
          intrinsic = .true., &
          description=var_str ('Specifier for the Les Houches Accord (LHEF) ' // &
          'event format files with XML headers to discriminate among different ' // &
          'versions of this format.  (cf. also \ttt{\$sample}, \ttt{sample\_format}, ' // &
          '\ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
          '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref}, ' // &
          '\ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_string (var_str ("$lhef_extension"), var_str ("lhe"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$lhef\_extension ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the LHEF format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.lhe}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{lhef}, ' // &
           '\ttt{\$lhef\_extension}, \ttt{\$lhef\_version}, \ttt{?lhef\_write\_sqme\_prc}, ' // &
           '\ttt{?lhef\_write\_sqme\_ref}, \ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_log (var_str ("?lhef_write_sqme_prc"), .true., &
          intrinsic = .true., &
          description=var_str ('Flag that decides whether in the ($\to$) ' // &
          '\ttt{lhef} event format the weights of the squared matrix element ' // &
          'of the corresponding process shall be written in the LHE file. ' // &
          '(cf. also \ttt{\$sample}, \ttt{sample\_format}, \ttt{lhef}, ' // &
          '\ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, \ttt{?lhef\_write\_sqme\_ref}, ' // &
          '\newline \ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_log (var_str ("?lhef_write_sqme_ref"), .false., &
          intrinsic = .true., &
          description=var_str ('Flag that decides whether in the ($\to$) ' // &
          '\ttt{lhef} event format reference weights of the squared matrix ' // &
          'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // &
          '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
          '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_alt})'))
     call var_list%append_log (var_str ("?lhef_write_sqme_alt"), .true., &
          intrinsic = .true., &
          description=var_str ('Flag that decides whether in the ($\to$) ' // &
          '\ttt{lhef} event format alternative weights of the squared matrix ' // &
          'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // &
          '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
          '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref})'))
     call var_list%append_string (var_str ("$extension_lha"), var_str ("lha"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_lha ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the (deprecated) LHA format are written. ' // &
           'If not set, the default file name and suffix is \ttt{{\em <process\_name>}.lha}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_hepmc"), var_str ("hepmc"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_hepmc ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the HepMC format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.hepmc}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_log (var_str ("?hepmc_output_cross_section"), .false., &
          intrinsic = .true., &
          description=var_str ('Flag for the HepMC event format that allows ' // &
          'to write out the cross section (and error) from the integration ' // &
          'together with each HepMC event. This can be used by programs ' // &
          'like Rivet to scale histograms according to the cross section. ' // &
          '(cf.  also \ttt{hepmc})'))
     call var_list%append_string (var_str ("$hepmc3_mode"), var_str ("HepMC3"), &
          intrinsic = .true., &
          description=var_str ('This specifies the writer mode for HepMC3. ' // &
          'Possible values are \ttt{HepMC2}, \ttt{HepMC3} (default),  ' // &
          '\ttt{HepEVT}, \ttt{Root}. and \ttt{RootTree} (cf. also \ttt{hepmc})'))
     call var_list%append_string (var_str ("$extension_lcio"), var_str ("slcio"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_lcio ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the LCIO format are written. If not set, ' // &
           'the default file name and suffix is \ttt{{\em <process\_name>}.slcio}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_stdhep"), var_str ("hep"), &
           intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_stdhep ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the StdHEP format via the HEPEVT common ' // &
           'block are written. If not set, the default file name and suffix ' // &
           'is \ttt{{\em <process\_name>}.hep}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_stdhep_up"), &
           var_str ("up.hep"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_up ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the StdHEP format via the HEPRUP/HEPEUP ' // &
           'common blocks are written. \ttt{{\em <process\_name>}.up.hep} ' // &
           'is the default file name and suffix, if this variable not set. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_stdhep_ev4"), &
           var_str ("ev4.hep"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_ev4 ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the StdHEP format via the HEPEVT/HEPEV4 ' // &
           'common blocks are written. \ttt{{\em <process\_name>}.up.hep} ' // &
           'is the default file name and suffix, if this variable not set. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_hepevt_verb"), &
           var_str ("hepevt.verb"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_hepevt\_verb ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the \whizard\ version 1 style extended or ' // &
           'verbose HEPEVT ASCII format are written. If not set, the default ' // &
           'file name and suffix is \ttt{{\em <process\_name>}.hepevt.verb}. ' // &
           '(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
     call var_list%append_string (var_str ("$extension_lha_verb"), &
           var_str ("lha.verb"), intrinsic=.true., &
           description=var_str ('String variable that allows via \ttt{\$extension\_lha\_verb ' // &
           '= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
           'to which events in the (deprecated) extended or verbose LHA ' // &
           'format are written. If not set, the default file name and suffix ' // &
           'is \ttt{{\em <process\_name>}.lha.verb}. (cf. also \ttt{sample\_format}, ' // &
           '\ttt{\$sample})'))
   end subroutine var_list_set_eio_defaults
 
 @ %def var_list_set_eio_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_shower_defaults => var_list_set_shower_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_shower_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?allow_shower"), .true., &
          intrinsic=.true., &
          description=var_str ('Master flag to switch on (initial and ' // &
          'final state) parton shower, matching/merging as an event ' // &
          'transform. As a default, it is switched on. (cf. also \ttt{?ps\_ ' // &
          '....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_fsr_active"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that switches final-state QCD radiation ' // &
          '(FSR) on.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
          '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_active"), .false., &
          intrinsic=.true., &
          description=var_str ('Flag that switches initial-state QCD ' // &
          'radiation (ISR) on.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_taudec_active"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag to switch on $\tau$ decays, at ' // &
             'the moment only via the included external package \ttt{TAUOLA} ' // &
             'and \ttt{PHOTOS}.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
             '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?muli_active"), .false., &
             intrinsic=.true., &
             description=var_str ("Master flag that switches on \whizard's " // &
             'module for multiple interaction with interleaved QCD parton ' // &
             'showers for hadron colliders. Note that this feature is still ' // &
             'experimental. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
             '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})'))
     call var_list%append_string (var_str ("$shower_method"), var_str ("WHIZARD"), &
             intrinsic=.true., &
             description=var_str ('String variable that allows to specify ' // &
             'which parton shower is being used, the default, \ttt{"WHIZARD"}, ' // &
             'is one of the in-house showers of \whizard. Other possibilities ' // &
             'at the moment are only \ttt{"PYTHIA6"}.'))
     call var_list%append_log (var_str ("?shower_verbose"), .false., &
             intrinsic=.true., &
             description=var_str ('Flag to switch on verbose messages when ' // &
             'using shower and/or hadronization. (cf. also \ttt{?allow\_shower}, ' // &
             '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...},'))
     call var_list%append_string (var_str ("$ps_PYTHIA_PYGIVE"), var_str (""), &
           intrinsic=.true., &
           description=var_str ('String variable that allows to pass options ' // &
           'for tunes etc. to the attached \pythia\ parton shower or hadronization, ' // &
           'e.g.: \ttt{\$ps\_PYTHIA\_PYGIVE = "MSTJ(41)=1"}.  (cf. also ' // &
           '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
           '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_string (var_str ("$ps_PYTHIA8_config"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('String variable that allows to pass options ' // &
          'for tunes etc. to the attached \pythia\ttt{8} parton shower or hadronization, ' // &
          'e.g.: \ttt{\$ps\_PYTHIA8\_config = "PartonLevel:MPI = off"}.  (cf. also ' // &
          '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_string (var_str ("$ps_PYTHIA8_config_file"), var_str (""), &
          intrinsic=.true., &
          description=var_str ('String variable that allows to pass a filename to a ' // &
          '\pythia\ttt{8} configuration file.'))
     call var_list%append_real (&
          var_str ("ps_mass_cutoff"), 1._default, intrinsic = .true., &
          description=var_str ('Real value that sets the QCD parton shower ' // &
          'lower cutoff scale, where hadronization sets in. (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (&
          var_str ("ps_fsr_lambda"), 0.29_default, intrinsic = .true., &
          description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // &
          'used in running $\alpha_s$ for time-like showers is set (except ' // &
          'for showers in the decay of a resonance). (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (&
          var_str ("ps_isr_lambda"), 0.29_default, intrinsic = .true., &
          description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // &
          'used in running $\alpha_s$ for space-like showers is set. (cf. ' // &
          'also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, ' // &
          '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_int (&
          var_str ("ps_max_n_flavors"), 5, intrinsic = .true., &
          description=var_str ('This integer parameter sets the maxmimum ' // &
          'number of flavors that can be produced in a QCD shower $g\to ' // &
          'q\bar q$. It is also used as the maximal number of active flavors ' // &
          'for the running of $\alpha_s$ in the shower (with a minimum ' // &
          'of 3). (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_alphas_running"), .true., &
             intrinsic=.true., &
             description=var_str ('Flag that decides whether a running ' // &
             '$\alpha_s$ is taken in space-like QCD parton showers. (cf. ' // &
             'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
             '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_fsr_alphas_running"), .true., &
             intrinsic=.true., &
             description=var_str ('Flag that decides whether a running ' // &
             '$\alpha_s$ is taken in time-like QCD parton showers. (cf. ' // &
             'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
             '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str ("ps_fixed_alphas"), &
          0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets the value of $\alpha_s$ ' // &
          'if it is (cf. $\to$ \ttt{?ps\_isr\_alphas\_running}, \newline ' // &
          '\ttt{?ps\_fsr\_alphas\_running}) not running in initial and/or ' // &
          'final-state QCD showers.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_pt_ordered"), .false., &
             intrinsic=.true., &
             description=var_str ('By this flag, it can be switched between ' // &
             'the analytic QCD ISR shower (\ttt{false}, default) and the ' // &
             '$p_T$ ISR QCD shower (\ttt{true}). (cf. also \ttt{?allow\_shower}, ' // &
             '\ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str ("?ps_isr_angular_ordered"), .true., &
             intrinsic=.true., &
             description=var_str ('If switched one, this flag forces opening ' // &
             'angles of emitted partons in the QCD ISR shower to be strictly ' // &
             'ordered, i.e. increasing towards the hard interaction.  (cf. ' // &
             'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
             '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_primordial_kt_width"), 0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets the width $\sigma ' // &
          '= \braket{k_T^2}$ for the Gaussian primordial $k_T$ distribution ' // &
          'inside the hadron, given by: $\exp[-k_T^2/\sigma^2] k_T dk_T$.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_primordial_kt_cutoff"), 5._default, intrinsic = .true., &
          description=var_str ('Real parameter that sets the upper cutoff ' // &
          'for the primordial $k_T$ distribution inside a hadron.  (cf. ' // &
          'also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, ' // &
          '\ttt{?hadronization\_active}, \ttt{?mlm\_ ...})'))
     call var_list%append_real (var_str &
          ("ps_isr_z_cutoff"), 0.999_default, intrinsic = .true., &
          description=var_str ('This real parameter allows to set the upper ' // &
          'cutoff on the splitting variable $z$ in space-like QCD parton ' // &
          'showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, ' // &
          '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_minenergy"), 1._default, intrinsic = .true., &
          description=var_str ('By this real parameter, the minimal effective ' // &
          'energy (in the c.m. frame) of a time-like or on-shell-emitted ' // &
          'parton in a space-like QCD shower is set. For a hard subprocess ' // &
          'that is not in the rest frame, this number is roughly reduced ' // &
          'by a boost factor $1/\gamma$ to the rest frame of the hard scattering ' // &
          'process.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_   ...}, ' // &
          '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("ps_isr_tscalefactor"), 1._default, intrinsic = .true., &
          description=var_str ('The $Q^2$ scale of the hard scattering ' // &
          'process is multiplied by this real factor to define the maximum ' // &
          'parton virtuality allowed in time-like QCD showers. This does ' // &
          'only apply to $t$- and $u$-channels, while for $s$-channel resonances ' // &
          'the maximum virtuality is set by $m^2$.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_log (var_str &
          ("?ps_isr_only_onshell_emitted_partons"), .false., intrinsic=.true., &
          description=var_str ('This flag if set true sets all emitted ' // &
          'partons off space-like showers on-shell, i.e. it would not allow ' // &
          'associated time-like showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_   ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
   end subroutine var_list_set_shower_defaults
 
 @ %def var_list_set_shower_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_hadronization_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log &
          (var_str ("?allow_hadronization"), .true., intrinsic=.true., &
          description=var_str ('Master flag to switch on hadronization ' // &
          'as an event transform. As a default, it is switched on. (cf. ' // &
          'also \ttt{?ps\_ ....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, ' // &
          '\ttt{?hadronization\_active})'))
     call var_list%append_log &
          (var_str ("?hadronization_active"), .false., intrinsic=.true., &
          description=var_str ('Master flag to switch hadronization (through ' // &
          'the attached \pythia\ package) on or off. As a default, it is ' // &
          'off. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...})'))
     call var_list%append_string &
          (var_str ("$hadronization_method"), var_str ("PYTHIA6"), intrinsic = .true., &
          description=var_str ("Determines whether \whizard's own " // &
          "hadronization or the (internally included) \pythiasix\ should be used."))
     call var_list%append_real &
          (var_str ("hadron_enhanced_fraction"), 0.01_default, intrinsic = .true., &
          description=var_str ('Fraction of Lund strings that break with enhanced ' // &
          'width. [not yet active]'))
     call var_list%append_real &
          (var_str ("hadron_enhanced_width"), 2.0_default, intrinsic = .true., &
          description=var_str ('Enhancement factor for the width of breaking ' // &
          'Lund strings. [not yet active]'))
   end subroutine var_list_set_hadronization_defaults
 
 @ %def var_list_set_hadronization_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_tauola_defaults => var_list_set_tauola_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_tauola_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (&
          var_str ("?ps_tauola_photos"), .false., intrinsic=.true., &
          description=var_str ('Flag to switch on \ttt{PHOTOS} for photon ' // &
          'showering inside the \ttt{TAUOLA} package.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_log (&
          var_str ("?ps_tauola_transverse"), .false., intrinsic=.true., &
          description=var_str ('Flag to switch transverse $\tau$ polarization ' // &
          'on or off for Higgs decays into $\tau$ leptons.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_log (&
          var_str ("?ps_tauola_dec_rad_cor"), .true., intrinsic=.true., &
          description=var_str ('Flag to switch radiative corrections for ' // &
          '$\tau$ decays in \ttt{TAUOLA} on or off.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_int (&
          var_str ("ps_tauola_dec_mode1"), 0, intrinsic = .true., &
          description=var_str ('Integer code to request a specific $\tau$ ' // &
          'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // &
          'in correlated decays -- for the second $\tau$. For more information ' // &
          'cf. the comments in the code or the \ttt{TAUOLA} manual.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_int (&
          var_str ("ps_tauola_dec_mode2"), 0, intrinsic = .true., &
          description=var_str ('Integer code to request a specific $\tau$ ' // &
          'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // &
          'in correlated decays -- for the second $\tau$. For more information ' // &
          'cf. the comments in the code or the \ttt{TAUOLA} manual.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_real (&
          var_str ("ps_tauola_mh"), 125._default, intrinsic = .true., &
          description=var_str ('Real option to set the Higgs mass for Higgs ' // &
          'decays into $\tau$ leptons in the interface to \ttt{TAUOLA}.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_real (&
          var_str ("ps_tauola_mix_angle"), 90._default, intrinsic = .true., &
          description=var_str ('Option to set the mixing angle between ' // &
          'scalar and pseudoscalar Higgs bosons for Higgs decays into $\tau$ ' // &
          'leptons in the interface to \ttt{TAUOLA}.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
     call var_list%append_log (&
          var_str ("?ps_tauola_pol_vector"), .false., intrinsic = .true., &
          description=var_str ('Flag to decide whether for transverse $\tau$ ' // &
          'polarization, polarization information should be taken from ' // &
          '\ttt{TAUOLA} or not.  The default is just based on random numbers.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
   end subroutine var_list_set_tauola_defaults
 
 @ %def var_list_set_tauola_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_mlm_matching_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?mlm_matching"), .false., &
             intrinsic=.true., &
             description=var_str ('Master flag to switch on MLM (LO) jet ' // &
             'matching between hard matrix elements and the QCD parton ' // &
             'shower. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
             '\ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Qcut_ME"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that in the MLM jet matching ' // &
          'between hard matrix elements and QCD parton shower sets a possible ' // &
          'virtuality cut on jets from the hard matrix element. (cf. also ' // &
          '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // &
          '...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Qcut_PS"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that in the MLM jet matching ' // &
          'between hard matrix elements and QCD parton shower sets a possible ' // &
          'virtuality cut on jets from the parton shower. (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_ptmin"), 0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets a minimal $p_T$ ' // &
          'that enters the $y_{cut}$ jet clustering measure in the MLM ' // &
          'jet matching between hard matrix elements and QCD parton showers.  ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_etamax"), 0._default, intrinsic = .true., &
          description=var_str ('This real parameter sets a maximal pseudorapidity ' // &
          'that enters the MLM jet matching between hard matrix elements ' // &
          'and QCD parton showers.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Rmin"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that sets a minimal $R$ ' // &
          'distance value that enters the $y_{cut}$ jet clustering measure ' // &
          'in the MLM jet matching between hard matrix elements and QCD ' // &
          'parton showers.  (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
          '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Emin"), 0._default, intrinsic = .true., &
          description=var_str ('Real parameter that sets a minimal energy ' // &
          '$E_{min}$ value as an infrared cutoff in the MLM jet matching ' // &
          'between hard matrix elements and QCD parton showers.  (cf. also ' // &
          '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // &
          '...}, \ttt{?hadronization\_active})'))
     call var_list%append_int (var_str &
          ("mlm_nmaxMEjets"), 0, intrinsic = .true., &
          description=var_str ('This integer sets the maximal number of ' // &
          'jets that are available from hard matrix elements in the MLM ' // &
          'jet matching between hard matrix elements and QCD parton shower. ' // &
          '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
          '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_ETclusfactor"), 0.2_default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_ETclusminE"), 5._default, intrinsic = .true., &
          description=var_str ('This real parameter is a minimal energy ' // &
          'that enters the calculation of the $y_{cut}$ measure for jet ' // &
          'clustering after the parton shower in the MLM jet matching between ' // &
          'hard matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_etaclusfactor"), 1._default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Rclusfactor"), 1._default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
     call var_list%append_real (var_str &
          ("mlm_Eclusfactor"), 1._default, intrinsic = .true., &
          description=var_str ('This real parameter is a factor that enters ' // &
          'the calculation of the $y_{cut}$ measure for jet clustering ' // &
          'after the parton shower in the MLM jet matching between hard ' // &
          'matrix elements and QCD parton showers.  (cf. also \ttt{?allow\_shower}, ' // &
          '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
 
   end subroutine var_list_set_mlm_matching_defaults
 
 @ %def var_list_set_mlm_matching_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_powheg_matching_defaults => &
        var_list_set_powheg_matching_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_powheg_matching_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?powheg_matching"), &
          .false., intrinsic = .true., &
          description=var_str ('Activates Powheg matching. Needs to be ' // &
          'combined with the \ttt{?combined\_nlo\_integration}-method.'))
     call var_list%append_log (var_str ("?powheg_use_singular_jacobian"), &
          .false., intrinsic = .true., &
          description=var_str ('This allows to give a different ' // &
          'normalization of the Jacobian, resulting in an alternative ' // &
          'POWHEG damping in the singular regions.'))
     call var_list%append_int (var_str ("powheg_grid_size_xi"), &
          5, intrinsic = .true., &
          description=var_str ('Number of $\xi$ points in the POWHEG grid.'))
     call var_list%append_int (var_str ("powheg_grid_size_y"), &
          5, intrinsic = .true., &
          description=var_str ('Number of $y$ points in the POWHEG grid.'))
     call var_list%append_int (var_str ("powheg_grid_sampling_points"), &
          500000, intrinsic = .true., &
          description=var_str ('Number of calls used to initialize the ' // &
          'POWHEG grid.'))
     call var_list%append_real (var_str ("powheg_pt_min"), &
           1._default, intrinsic = .true., &
           description=var_str ('Lower $p_T$-cut-off for the POWHEG ' // &
           'hardest emission.'))
     call var_list%append_real (var_str ("powheg_lambda"), &
           LAMBDA_QCD_REF, intrinsic = .true., &
           description=var_str ('Reference scale of the $\alpha_s$ evolution ' // &
           'in the POWHEG matching algorithm.'))
     call var_list%append_log (var_str ("?powheg_test_sudakov"), &
           .false., intrinsic = .true., &
           description=var_str ('Performs an internal consistency check ' // &
           'on the POWHEG event generation.'))
     call var_list%append_log (var_str ("?powheg_disable_sudakov"), &
           .false., intrinsic = .true., &
           description=var_str ('This flag allows to set the Sudakov form ' // &
           'factor to one. This effectively results in a version of ' // &
           'the matrix-element method (MEM) at NLO.'))
   end subroutine var_list_set_powheg_matching_defaults
 
 @ %def var_list_set_powheg_matching_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_openmp_defaults => var_list_set_openmp_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_openmp_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?omega_openmp"), &
          openmp_is_active (), &
          intrinsic=.true., &
          description=var_str ('Flag to switch on or off OpenMP multi-threading ' // &
          "for \oMega\ matrix elements. (cf. also \ttt{\$method}, \ttt{\$omega\_flag})"))
     call var_list%append_log (var_str ("?openmp_is_active"), &
          openmp_is_active (), &
          locked=.true., intrinsic=.true., &
          description=var_str ('Flag to switch on or off OpenMP multi-threading ' // &
          'for \whizard. (cf. also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, ' // &
          '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})'))
     call var_list%append_int (var_str ("openmp_num_threads_default"), &
          openmp_get_default_max_threads (), &
          locked=.true., intrinsic=.true., &
          description=var_str ('Integer parameter that shows the number ' // &
          'of default OpenMP threads for multi-threading. Note that this ' // &
          'parameter can only be accessed, but not reset by the user. (cf. ' // &
          'also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, \ttt{?omega\_openmp})'))
     call var_list%append_int (var_str ("openmp_num_threads"), &
          openmp_get_max_threads (), &
          intrinsic=.true., &
          description=var_str ('Integer parameter that sets the number ' // &
          'of OpenMP threads for multi-threading.  (cf. also \ttt{?openmp\_logging}, ' // &
          '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})'))
     call var_list%append_log (var_str ("?openmp_logging"), &
          .true., intrinsic=.true., &
          description=var_str ('This logical -- when set to \ttt{false} ' // &
          '-- suppresses writing out messages about OpenMP parallelization ' // &
          '(number of used threads etc.) on screen and into the logfile ' // &
          '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // &
          'Mainly for debugging purposes.  (cf. also \ttt{?logging}, ' // &
          '\ttt{?mpi\_logging})'))
   end subroutine var_list_set_openmp_defaults
 
 @ %def var_list_set_openmp_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_mpi_defaults => var_list_set_mpi_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_mpi_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_log (var_str ("?mpi_logging"), &
          .false., intrinsic=.true., &
          description=var_str('This logical -- when set to \ttt{false} ' // &
          '-- suppresses writing out messages about MPI parallelization ' // &
          '(number of used workers etc.) on screen and into the logfile ' // &
          '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // &
          'Mainly for debugging purposes.  (cf. also \ttt{?logging}, ' // &
          '\ttt{?openmp\_logging})'))
   end subroutine var_list_set_mpi_defaults
 
 @ %def var_list_set_mpi_defaults
 @
 <<Variables: var list: TBP>>=
   procedure :: set_nlo_defaults => var_list_set_nlo_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_nlo_defaults (var_list)
     class(var_list_t), intent(inout) :: var_list
     call var_list%append_string (var_str ("$born_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ("This string variable specifies the method " // &
          "for the matrix elements to be used in the evaluation of the " // &
          "Born part of the NLO computation. The default is the empty string, " // &
          "i.e. the \ttt{\$method} being the intrinsic \oMega\ matrix element " // &
          'generator (\ttt{"omega"}), other options ' // &
          'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, ' // &
          '\ttt{"template\_unity"}, \ttt{"threshold"}, \ttt{"gosam"}, ' // &
          '\ttt{"openloops"}. Note that this option is inoperative if ' // &
          'no NLO calculation is specified in the process definition. ' // &
          'If you want ot use different matrix element methods in a LO ' // &
          'computation, use the usual \ttt{method} command. (cf. also ' // &
          '\ttt{\$correlation\_me\_method}, ' // &
          '\ttt{\$dglap\_me\_method}, \ttt{\$loop\_me\_method} and ' // &
          '\ttt{\$real\_tree\_me\_method}.)'))
     call var_list%append_string (var_str ("$loop_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation of the ' // &
          'virtual part of the NLO computation. The default is the empty string, ' // &
          'i.e. the same as \ttt{\$method}. Working options are: ' // &
          '\ttt{"threshold"}, \ttt{"openloops"}, \ttt{"recola"}, \ttt{"gosam"}. ' // &
          '(cf. also \ttt{\$real\_tree\_me\_method}, \ttt{\$correlation\_me\_method} ' // &
          'and \ttt{\$born\_me\_method}.)'))
     call var_list%append_string (var_str ("$correlation_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies ' // &
          'the method for the matrix elements to be used in the evaluation ' // &
          'of the color (and helicity) correlated part of the NLO computation. ' // &
          "The default is the same as the \ttt{\$method}, i.e. the intrinsic " // &
          "\oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // &
          '\ttt{"template"}, \ttt{"template\_unity"}, \ttt{"threshold"}, ' // &
          '\ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // &
          '\ttt{\$born\_me\_method}, \ttt{\$dglap\_me\_method}, ' // &
          '\ttt{\$loop\_me\_method} and \newline' // &
          '\ttt{\$real\_tree\_me\_method}.)'))
     call var_list%append_string (var_str ("$real_tree_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation of the ' // &
          'real part of the NLO computation. The default is the same as ' // &
          'the \ttt{\$method}, i.e. the intrinsic ' // &
          "\oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options ' // &
          'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // &
          '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // &
          '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // &
          '\ttt{\$dglap\_me\_method} and \ttt{\$loop\_me\_method}.)'))
     call var_list%append_string (var_str ("$dglap_me_method"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('This string variable specifies the method ' // &
          'for the matrix elements to be used in the evaluation of the ' // &
          'DGLAP remnants of the NLO computation. The default is the same as ' // &
          "\ttt{\$method}, i.e. the \oMega\ matrix element generator " // &
          '(\ttt{"omega"}), other options ' // &
          'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // &
          '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also \newline' // &
          '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // &
          '\ttt{\$loop\_me\_method} and \ttt{\$real\_tree\_me\_method}.)'))
     call var_list%append_log (&
          var_str ("?test_soft_limit"), .false., intrinsic = .true., &
          description=var_str ('Sets the fixed values $\tilde{\xi} = 0.00001$ ' // &
          'and $y = 0.5$ as radiation variables.  This way, only soft, ' // &
          'but non-collinear phase space points are generated, which allows ' // &
          'for testing subtraction in this region.'))
     call var_list%append_log (&
          var_str ("?test_coll_limit"), .false., intrinsic = .true., &
          description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // &
          'and $y = 0.9999999$ as radiation variables.  This way, only collinear, ' // &
          'but non-soft phase space points are generated, which allows ' // &
          'for testing subtraction in this region. Can be combined with ' // &
          '\ttt{?test\_soft\_limit} to probe soft-collinear regions.'))
     call var_list%append_log (&
          var_str ("?test_anti_coll_limit"), .false., intrinsic = .true., &
          description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // &
          'and $y = -0.9999999$ as radiation variables.  This way, only anti-collinear, ' // &
          'but non-soft phase space points are generated, which allows ' // &
          'for testing subtraction in this region. Can be combined with ' // &
          '\ttt{?test\_soft\_limit} to probe soft-collinear regions.'))
     call var_list%append_string (var_str ("$select_alpha_regions"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('Fixes the $\alpha_r$ in the real ' // &
          ' subtraction component. Allows for testing in one individual ' // &
          'singular region.'))
     call var_list%append_string (var_str ("$virtual_selection"), &
          var_str ("Full"), intrinsic = .true., &
          description=var_str ('String variable to select either the full ' // &
          'or only parts of the virtual components of an NLO calculation. ' // &
          'Possible modes are \ttt{"Full"}, \ttt{"OLP"} and ' // &
          '\ttt{"Subtraction."}. Mainly for debugging purposes.'))
     call var_list%append_log (var_str ("?virtual_collinear_resonance_aware"), &
          .true., intrinsic = .true., &
          description=var_str ('This flag allows to switch between two ' // &
          'different implementations of the collinear subtraction in the ' // &
          'resonance-aware FKS setup.'))
     call var_list%append_real (&
          var_str ("blha_top_yukawa"), -1._default, intrinsic = .true., &
          description=var_str ('If this value is set, the given value will ' // &
          'be used as the top Yukawa coupling instead of the top mass. ' // &
          'Note that having different values for $y_t$ and $m_t$ must be ' // &
          'supported by your OLP-library and yield errors if this is not the case.'))
     call var_list%append_string (var_str ("$blha_ew_scheme"), &
          var_str ("alpha_internal"), intrinsic = .true., &
          description=var_str ('String variable that transfers the electroweak ' // &
          'renormalization scheme via BLHA to the one-loop provider. Possible ' // &
          'values are \ttt{GF} or \ttt{Gmu} for the $G_\mu$ scheme, ' // &
          '\ttt{alpha\_internal} (default, $G_\mu$ scheme, but value of ' // &
          '$\alpha_S$ calculated internally by \whizard), \ttt{alpha\_mz} ' // &
          'and \ttt{alpha\_0} (or \ttt{alpha\_thompson}) for different schemes ' // &
          'with $\alpha$ as input.'))
     call var_list%append_int (var_str ("openloops_verbosity"), 1, &
          intrinsic = .true., &
          description=var_str ('Decides how much \openloops\ output is printed. ' // &
          'Can have values 0, 1 and 2, where 2 is the highest verbosity level.'))
     call var_list%append_log (var_str ("?openloops_use_cms"), &
          .true., intrinsic = .true., &
          description=var_str ('Activates the complex mass scheme in ' // &
          '\openloops. (cf. also ' // &
          '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
          '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // &
          '\ttt{openloops\_stability\_log}, \newline' // &
          '\ttt{\$openloops\_extra\_cmd})'))
     call var_list%append_int (var_str ("openloops_phs_tolerance"), 7, &
          intrinsic = .true., &
          description=var_str ('This integer parameter gives via ' // &
          '\ttt{openloops\_phs\_tolerance = <n>} the relative numerical ' // &
          'tolerance $10^{-n}$ for the momentum conservation of the ' // &
          'external particles within \openloops. (cf. also ' // &
          '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
          '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // &
          '\newline\ttt{openloops\_stability\_log}, ' // &
          '\ttt{\$openloops\_extra\_cmd})'))
     call var_list%append_int (var_str ("openloops_stability_log"), 0, &
          intrinsic = .true., &
          description=var_str ('Creates the directory \ttt{stability\_log} ' // &
          'containing information about the performance of the \openloops ' // &
          'matrix elements. Possible values are 0 (No output), 1 (On ' // &
          '\ttt{finish()}-call), 2 (Adaptive) and 3 (Always).'))
     call var_list%append_log (var_str ("?openloops_switch_off_muon_yukawa"), &
          .false., intrinsic = .true., &
          description=var_str ('Sets the Yukawa coupling of muons for ' // &
          '\openloops\ to zero. (cf. also ' // &
          '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
          '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // &
          '\ttt{\$openloops\_extra\_cmd})'))
     call var_list%append_string (var_str ("$openloops_extra_cmd"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('String variable to transfer customized ' // &
          'special commands to \openloops. The three supported examples ' // &
          '\ttt{\$openloops\_extra\_command = "extra approx top/stop/not"} ' // &
          'are for selection of subdiagrams in top production. (cf. also ' // &
          '\ttt{\$method}, \ttt{openloos\_verbosity}, ' // &
          '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // &
          '\ttt{?openloops\_switch\_off\_muon\_yukawa})'))
     call var_list%append_real (var_str ("ellis_sexton_scale"), &
          -1._default, intrinsic = .true., &
          description = var_str ('Real positive paramter for the Ellis-Sexton scale' // &
          '$\mathcal{Q}$ used both in the finite one-loop contribution provided by' // &
          'the OLP and in the virtual counter terms. The NLO cross section is' // &
          'independend of $\mathcal{Q}$. Therefore, this allows for debugging of' // &
          'the implemention of the virtual counter terms. As the default' // &
          '$\mathcal{Q} = \mu_{\rm{R}}$ is chosen. So far, setting this parameter' // &
          'only works for OpenLoops2, otherwise the default behaviour is invoked.'))
     call var_list%append_log (var_str ("?disable_subtraction"), &
          .false., intrinsic = .true., &
          description=var_str ('Disables the subtraction of soft and collinear ' // &
          'divergences from the real matrix element.'))
     call var_list%append_real (var_str ("fks_dij_exp1"), &
          1._default, intrinsic = .true., &
          description=var_str ('Fine-tuning parameters of the FKS ' // &
          'final state partition functions. The exact meaning depends ' // &
          'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp2}, ' // &
          '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})'))
     call var_list%append_real (var_str ("fks_dij_exp2"), &
          1._default, intrinsic = .true., &
          description=var_str ('Fine-tuning parameters of the FKS ' // &
          'initial state partition functions. The exact meaning depends ' // &
          'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp1}, ' // &
          '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})'))
     call var_list%append_real (var_str ("fks_xi_min"), &
          0._default, intrinsic = .true., &
          description=var_str ('Real parameter for the FKS ' // &
          'phase space that sets the numerical lower value of the $\xi$ ' // &
          'variable. Valid for the value range $[\texttt{tiny\_07},1]$, where ' // &
          'value inputs out of bounds will take the value of the closest bound. ' // &
          'Here, $\texttt{tiny\_07} = \texttt{1E0\_default * epsilon (0.\_default)}$, where ' // &
          '\ttt{epsilon} is an intrinsic Fortran function. (cf. also \ttt{fks\_dij\_exp1}, ' // &
          '\ttt{fks\_dij\_exp2}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_y\_max})'))
     call var_list%append_real (var_str ("fks_y_max"), &
          1._default, intrinsic = .true., &
          description=var_str ('Real parameter for the FKS ' // &
          'phase space that sets the numerical upper value of the $\left|y\right|$ ' // &
          'variable. Valid for ranges $[0,1]$, where value inputs out of bounds will take ' // &
          'the value of the closest bound.(cf. also \ttt{fks\_dij\_exp1}, ' // &
          '\ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2}, \ttt{fks\_y\_max})'))
     call var_list%append_log (var_str ("?vis_fks_regions"), &
          .false., intrinsic = .true., &
          description=var_str ('Logical variable that, if set to ' // &
          '\ttt{true}, generates \LaTeX\ code and executes it into a PDF ' // &
          ' to produce a table of all singular FKS regions and their ' // &
          ' flavor structures. The default is \ttt{false}.'))
     call var_list%append_real (var_str ("fks_xi_cut"), &
          1.0_default, intrinsic = .true., &
          description = var_str ('Real paramter for the FKS ' // &
          'phase space that applies a cut to $\xi$ variable with $0 < \xi_{\text{cut}}' // &
          '\leq \xi_{\text{max}}$. The dependence on the parameter vanishes between ' // &
          'real subtraction and integrated subtraction term.'))
     call var_list%append_real (var_str ("fks_delta_o"), &
          2._default, intrinsic = .true., &
          description = var_str ('Real paramter for the FKS ' // &
          'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$. ' // &
          'The dependence on the parameter vanishes between real subtraction and integrated ' // &
          'subtraction term.'))
     call var_list%append_real (var_str ("fks_delta_i"), &
          2._default, intrinsic = .true., &
          description = var_str ('Real paramter for the FKS ' // &
          'phase space that applies a cut to the $y$ variable with ' // &
          '$0 < \delta_{\mathrm{I}} \leq 2$ '// &
          'for initial state singularities only. ' // &
          'The dependence on the parameter vanishes between real subtraction and integrated ' // &
          'subtraction term.'))
     call var_list%append_string (var_str ("$fks_mapping_type"), &
          var_str ("default"), intrinsic = .true., &
          description=var_str ('Sets the FKS mapping type. Possible values ' // &
          'are \ttt{"default"} and \ttt{"resonances"}. The latter option ' // &
          'activates the resonance-aware subtraction mode and induces the ' // &
          'generation of a soft mismatch component. (cf. also ' // &
          '\ttt{fks\_dij\_exp1}, \ttt{fks\_dij\_exp2}, \ttt{fks\_xi\_min}, ' // &
          '\ttt{fks\_y\_max})'))
     call var_list%append_string (var_str ("$resonances_exclude_particles"), &
          var_str ("default"), intrinsic = .true., &
          description=var_str ('Accepts a string of particle names. These ' // &
          'particles will be ignored when the resonance histories are generated. ' // &
          'If \ttt{\$fks\_mapping\_type} is not \ttt{"resonances"}, this ' // &
          'option does nothing.'))
     call var_list%append_int (var_str ("alpha_power"), &
          2, intrinsic = .true., &
          description=var_str ('Fixes the electroweak coupling ' // &
          'powers used by BLHA matrix element generators. Setting these ' // &
          'values is necessary for the correct generation of OLP-files. ' // &
          'Having inconsistent values yields to error messages by the corresponding ' // &
          'OLP-providers.'))
     call var_list%append_int (var_str ("alphas_power"), &
          0, intrinsic = .true., &
          description=var_str ('Fixes the strong coupling ' // &
          'powers used by BLHA matrix element generators. Setting these ' // &
          'values is necessary for the correct generation of OLP-files. ' // &
          'Having inconsistent values yields to error messages by the corresponding ' // &
          'OLP-providers.'))
     call var_list%append_log (var_str ("?combined_nlo_integration"), &
          .false., intrinsic = .true., &
          description=var_str ('When this option is set to \ttt{true}, ' // &
          'the NLO integration will not be performed in the separate components, ' // &
          'but instead the sum of all components will be integrated directly. ' // &
          'When fixed-order NLO events are requested, this integration ' // &
          'mode is possible, but not necessary.  However, it is necessary ' // &
          'for POWHEG events.'))
     call var_list%append_log (var_str ("?fixed_order_nlo_events"), &
          .false., intrinsic = .true., &
          description=var_str ('Induces the generation of fixed-order ' // &
          'NLO events.'))
     call var_list%append_log (var_str ("?check_event_weights_against_xsection"), &
          .false., intrinsic = .true., &
          description=var_str ('Activates an internal recording of event ' // &
          'weights when unweighted events are generated.  At the end of ' // &
          'the simulation, the mean value of the weights and its standard ' // &
          'deviation are displayed. This allows to cross-check event generation ' // &
          'and integration, because the value displayed must be equal to ' // &
          'the integration result.'))
     call var_list%append_log (var_str ("?keep_failed_events"), &
          .false., intrinsic = .true., &
          description=var_str ('In the context of weighted event generation, ' // &
          'if set to \ttt{true}, events with failed kinematics will be ' // &
          'written to the event output with an associated weight of zero. ' // &
          'This way, the total cross section can be reconstructed from the event output.'))
     call var_list%append_int (var_str ("gks_multiplicity"), &
          0, intrinsic = .true., &
          description=var_str ('Jet multiplicity for the GKS merging scheme.'))
     call var_list%append_string (var_str ("$gosam_filter_lo"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('The filter string given to \gosam\ in order to ' // &
          'filter out tree-level diagrams. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // &
          '\ttt{\$gosam\_symmetries})'))
     call var_list%append_string (var_str ("$gosam_filter_nlo"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('The same as \ttt{\$gosam\_filter\_lo}, but for ' // &
          'loop matrix elements. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // &
          '\ttt{\$gosam\_symmetries})'))
     call var_list%append_string (var_str ("$gosam_symmetries"), &
          var_str ("family,generation"), intrinsic = .true., &
          description=var_str ('String variable that is transferred to \gosam\ ' // &
          'configuration file to determine whether certain helicity configurations ' // &
          'are considered to be equal. Possible values are \ttt{flavour}, ' // &
          '\ttt{family} etc. For more info see the \gosam\ manual.'))
     call var_list%append_int (var_str ("form_threads"), &
          2, intrinsic = .true., &
          description=var_str ('The number of threads used by \gosam\ when ' // &
          'matrix elements are evaluated using \ttt{FORM}'))
     call var_list%append_int (var_str ("form_workspace"), &
          1000, intrinsic = .true., &
          description=var_str ('The size of the workspace \gosam\ requires ' // &
          'from \ttt{FORM}. Inside \ttt{FORM}, it corresponds to the heap ' // &
          'size used by the algebra processor.'))
     call var_list%append_string (var_str ("$gosam_fc"), &
          var_str (""), intrinsic = .true., &
          description=var_str ('The Fortran compiler used by \gosam.'))
     call var_list%append_real (&
          var_str ("mult_call_real"), 1._default, &
          intrinsic = .true., &
          description=var_str ('(Real-valued) multiplier for the number ' // &
          'of calls used in the integration of the real subtraction ' // &
          'NLO component. This way, a higher accuracy can be achieved for ' // &
          'the real component, while simultaneously avoiding redundant ' // &
          'integration calls for the other components. (cf. also ' // &
          '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_virt})'))
     call var_list%append_real (&
          var_str ("mult_call_virt"), 1._default, &
          intrinsic = .true., &
          description=var_str ('(Real-valued) multiplier for the number ' // &
          'of calls used in the integration of the virtual NLO ' // &
          'component. This way, a higher accuracy can be achieved for ' // &
          'this component, while simultaneously avoiding redundant ' // &
          'integration calls for the other components. (cf. also ' // &
          '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_real})'))
     call var_list%append_real (&
          var_str ("mult_call_dglap"), 1._default, &
          intrinsic = .true., &
          description=var_str ('(Real-valued) multiplier for the number ' // &
          'of calls used in the integration of the DGLAP remnant NLO ' // &
          'component. This way, a higher accuracy can be achieved for ' // &
          'this component, while simultaneously avoiding redundant ' // &
          'integration calls for the other components. (cf. also ' // &
          '\ttt{mult\_call\_real}, \ttt{mult\_call\_virt})'))
     call var_list%append_string (var_str ("$dalitz_plot"), &
          var_str (''), intrinsic = .true., &
          description=var_str ('This string variable has two purposes: ' // &
          'when different from the empty string, it switches on generation ' // &
          'of the Dalitz plot file (ASCII tables) for the real emitters. ' // &
          'The string variable itself provides the file name.'))
     call var_list%append_string (var_str ("$nlo_correction_type"), &
          var_str ("QCD"), intrinsic = .true., &
          description=var_str ('String variable which sets the NLO correction ' // &
          'type via \ttt{nlo\_correction\_type = "{\em <type>}"} to either ' // &
          '\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{<type>}} ' // &
          'set to \ttt{"Full"}. Must be set before the \texttt{process} statement.'))
     call var_list%append_string (var_str ("$exclude_gauge_splittings"), &
          var_str ("c:b:t:e2:e3"), intrinsic = .true., &
          description=var_str ('String variable that allows via ' // &
          '\ttt{\$exclude\_gauge\_splittings = "{\em <prt1>:<prt2>:\dots}"} ' // &
          'to exclude fermion flavors from gluon/photon splitting into ' // &
          'fermion pairs beyond LO. For example \ttt{\$exclude\_gauge\_splittings ' // &
          '= "c:s:b:t"} would lead to \ttt{gl => u U} and \ttt{gl => d ' // &
          'D} as possible splittings in QCD. It is important to keep in ' // &
          'mind that only the particles listed in the string are excluded! ' // &
          'In QED this string would additionally allow for all splittings into ' // &
          'lepton pairs \ttt{A => l L}. Therefore, once set the variable ' // &
          'acts as a replacement of the default value, not as an addition!  ' // &
          'Note: \ttt{"\em <prt>"} can be both particle or antiparticle. It ' // &
          'will always exclude the corresponding fermion pair. An empty ' // &
          'string allows for all fermion flavors to take part in the splitting! ' // &
          'Also, particles included in an \ttt{alias} are not excluded by ' // &
          '\ttt{\$exclude\_gauge\_splittings}!'))
     call var_list%append_log (var_str ("?nlo_use_born_scale"), &
          .false., intrinsic = .true., &
          description=var_str ('Flag that decides whether a scale expression ' // &
          'defined for the Born component of an NLO process shall be applied ' // &
          'to all other components as well or not. ' // &
          '(cf. also \ttt{?nlo\_cut\_all\_real\_sqmes})'))
     call var_list%append_log (var_str ("?nlo_cut_all_real_sqmes"), &
          .false., intrinsic = .true., &
          description=var_str ('Flag that decides whether in the case that ' // &
          'the real component does not pass a cut, its subtraction term ' // &
          'shall be discarded for that phase space point as well or not. ' // &
          '(cf. also \ttt{?nlo\_use\_born\_scale})'))
     call var_list%append_log (var_str ("?nlo_use_real_partition"), &
          .false., intrinsic = .true., &
          description=var_str (' If set to \ttt{true}, the real matrix ' // &
          'element is split into a finite and a singular part using a ' // &
          'partition function $f$, such that $\mathcal{R} ' // &
          '= [1-f(p_T^2)]\mathcal{R} + f(p_T^2)\mathcal{R} = ' // &
          '\mathcal{R}_{\text{fin}} ' // &
          '+ \mathcal{R}_{\text{sing}}$. The emission ' // &
          'generation is then performed using $\mathcal{R}_{\text{sing}}$, ' // &
          'whereas $\mathcal{R}_{\text{fin}}$ is treated separately. ' // &
          '(cf. also \ttt{real\_partition\_scale})'))
     call var_list%append_real (var_str ("real_partition_scale"), &
          10._default, intrinsic = .true., &
          description=var_str ('This real variable sets the invariant mass ' // &
          'of the FKS pair used as a separator between the singular and the ' // &
          'finite part of the real subtraction terms in an NLO calculation, ' // &
          'e.g. in $e^+e^- \to ' // &
          't\bar tj$. (cf. also \ttt{?nlo\_use\_real\_partition})'))
   end subroutine var_list_set_nlo_defaults
 
 @ %def var_list_set_nlo_defaults
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Observables}
 
 In this module we define concrete variables and operators (observables)
 that we want to support in expressions.
 <<[[observables.f90]]>>=
 <<File header>>
 
 module observables
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use diagnostics
   use lorentz
   use subevents
   use variables
 
 <<Standard module head>>
 
 <<Observables: public>>
 
 contains
 
 <<Observables: procedures>>
 
 end module observables
 @ %def observables
 @
 \subsection{Process-specific variables}
 We allow the user to set a numeric process ID for each declared process.
 <<Observables: public>>=
   public :: var_list_init_num_id
 <<Observables: procedures>>=
   subroutine var_list_init_num_id (var_list, proc_id, num_id)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: proc_id
     integer, intent(in), optional :: num_id
     call var_list_set_procvar_int (var_list, proc_id, &
          var_str ("num_id"), num_id)
   end subroutine var_list_init_num_id
 
 @ %def var_list_init_num_id
 @
 Integration results are stored in special variables.  They are
 initialized by this subroutine.  The values may or may not already
 known.
 
 Note: the values which are accessible are those that are unique for a
 process with multiple MCI records. The rest has been discarded.
 <<Observables: public>>=
   public :: var_list_init_process_results
 <<Observables: procedures>>=
   subroutine var_list_init_process_results (var_list, proc_id, &
        n_calls, integral, error, accuracy, chi2, efficiency)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: proc_id
     integer, intent(in), optional :: n_calls
     real(default), intent(in), optional :: integral, error, accuracy
     real(default), intent(in), optional :: chi2, efficiency
     call var_list_set_procvar_real (var_list, proc_id, &
          var_str ("integral"), integral)
     call var_list_set_procvar_real (var_list, proc_id, &
          var_str ("error"), error)
   end subroutine var_list_init_process_results
 
 @ %def var_list_init_process_results
 @
 \subsection{Observables as Pseudo-Variables}
 Unary and binary observables are different.  Most unary observables
 can be equally well evaluated for particle pairs.  Binary observables
 cannot be evaluated for single particles.
 <<Observables: public>>=
   public :: var_list_set_observables_unary
   public :: var_list_set_observables_binary
 <<Observables: procedures>>=
   subroutine var_list_set_observables_unary (var_list, prt1)
     type(var_list_t), intent(inout) :: var_list
     type(prt_t), intent(in), target :: prt1
     call var_list_append_obs1_iptr &
          (var_list, var_str ("PDG"), obs_pdg1, prt1)
     call var_list_append_obs1_iptr &
          (var_list, var_str ("Hel"), obs_helicity1, prt1)
     call var_list_append_obs1_iptr &
          (var_list, var_str ("Ncol"), obs_n_col1, prt1)
     call var_list_append_obs1_iptr &
          (var_list, var_str ("Nacl"), obs_n_acl1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("M"), obs_signed_mass1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("M2"), obs_mass_squared1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("E"), obs_energy1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Px"), obs_px1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Py"), obs_py1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Pz"), obs_pz1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("P"), obs_p1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Pl"), obs_pl1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Pt"), obs_pt1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Theta"), obs_theta1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Phi"), obs_phi1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Rap"), obs_rap1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Eta"), obs_eta1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Theta_star"), obs_theta_star1, prt1)
     call var_list_append_obs1_rptr &
          (var_list, var_str ("Dist"), obs_dist1, prt1)
     call var_list_append_uobs_real &
          (var_list, var_str ("_User_obs_real"), prt1)
     call var_list_append_uobs_int &
          (var_list, var_str ("_User_obs_int"), prt1)
   end subroutine var_list_set_observables_unary
 
   subroutine var_list_set_observables_binary (var_list, prt1, prt2)
     type(var_list_t), intent(inout) :: var_list
     type(prt_t), intent(in), target :: prt1
     type(prt_t), intent(in), optional, target :: prt2
     call var_list_append_obs2_iptr &
          (var_list, var_str ("PDG"), obs_pdg2, prt1, prt2)
     call var_list_append_obs2_iptr &
          (var_list, var_str ("Hel"), obs_helicity2, prt1, prt2)
     call var_list_append_obs2_iptr &
          (var_list, var_str ("Ncol"), obs_n_col2, prt1, prt2)
     call var_list_append_obs2_iptr &
          (var_list, var_str ("Nacl"), obs_n_acl2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("M"), obs_signed_mass2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("M2"), obs_mass_squared2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("E"), obs_energy2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Px"), obs_px2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Py"), obs_py2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Pz"), obs_pz2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("P"), obs_p2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Pl"), obs_pl2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Pt"), obs_pt2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Theta"), obs_theta2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Phi"), obs_phi2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Rap"), obs_rap2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Eta"), obs_eta2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Theta_star"), obs_theta_star2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("Dist"), obs_dist2, prt1, prt2)
     call var_list_append_obs2_rptr &
          (var_list, var_str ("kT"), obs_ktmeasure, prt1, prt2)
     call var_list_append_uobs_real &
          (var_list, var_str ("_User_obs_real"), prt1, prt2)
     call var_list_append_uobs_int &
          (var_list, var_str ("_User_obs_int"), prt1, prt2)
   end subroutine var_list_set_observables_binary
 
 @ %def var_list_set_observables_unary var_list_set_observables_binary
 @
 \subsection{Checks}
 <<Observables: public>>=
   public :: var_list_check_observable
 <<Observables: procedures>>=
   subroutine var_list_check_observable (var_list, name, type)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(inout) :: type
     if (string_is_observable_id (name)) then
        call msg_fatal ("Variable name '" // char (name) &
             // "' is reserved for an observable")
        type = V_NONE
        return
     end if
   end subroutine var_list_check_observable
 
 @ %def var_list_check_observable
 @
 Check if a variable name is defined as an observable:
 <<Observables: procedures>>=
   function string_is_observable_id (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     select case (char (string))
     case ("PDG", "Hel", "Ncol", &
          "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", &
          "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT")
        flag = .true.
     case default
        flag = .false.
     end select
   end function string_is_observable_id
 
 @ %def string_is_observable_id
 @ Check for result and process variables.
 <<Observables: public>>=
   public :: var_list_check_result_var
 <<Observables: procedures>>=
   subroutine var_list_check_result_var (var_list, name, type)
     class(var_list_t), intent(in), target :: var_list
     type(string_t), intent(in) :: name
     integer, intent(inout) :: type
     if (string_is_integer_result_var (name))  type = V_INT
     if (.not. var_list%contains (name)) then
        if (string_is_result_var (name)) then
           call msg_fatal ("Result variable '" // char (name) // "' " &
                // "set without prior integration")
           type = V_NONE
           return
        else if (string_is_num_id (name)) then
           call msg_fatal ("Numeric process ID '" // char (name) // "' " &
                // "set without process declaration")
           type = V_NONE
           return
        end if
     end if
   end subroutine var_list_check_result_var
 
 @ %def var_list_check_result_var
 @
 Check if a variable name is a result variable of integer type:
 <<Observables: procedures>>=
   function string_is_integer_result_var (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     type(string_t) :: buffer, name, separator
     buffer = string
     call split (buffer, name, "(", separator=separator)  ! ")"
     if (separator == "(") then
        select case (char (name))
        case ("num_id", "n_calls")
           flag = .true.
        case default
           flag = .false.
        end select
     else
        flag = .false.
     end if
   end function string_is_integer_result_var
 
 @ %def string_is_integer_result_var
 @
 Check if a variable name is an integration-result variable:
 <<Observables: procedures>>=
   function string_is_result_var (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     type(string_t) :: buffer, name, separator
     buffer = string
     call split (buffer, name, "(", separator=separator)  ! ")"
     if (separator == "(") then
        select case (char (name))
        case ("integral", "error")
           flag = .true.
        case default
           flag = .false.
        end select
     else
        flag = .false.
     end if
   end function string_is_result_var
 
 @ %def string_is_result_var
 @
 Check if a variable name is a numeric process ID:
 <<Observables: procedures>>=
   function string_is_num_id (string) result (flag)
     logical :: flag
     type(string_t), intent(in) :: string
     type(string_t) :: buffer, name, separator
     buffer = string
     call split (buffer, name, "(", separator=separator)  ! ")"
     if (separator == "(") then
        select case (char (name))
        case ("num_id")
           flag = .true.
        case default
           flag = .false.
        end select
     else
        flag = .false.
     end if
   end function string_is_num_id
 
 @ %def string_is_num_id
 @
 \subsection{Observables}
 These are analogous to the unary and binary numeric functions listed
 above.  An observable takes the [[pval]] component(s) of its one or
 two argument nodes and produces an integer or real value.
 
 \subsubsection{Integer-valued unary observables}
 The PDG code
 <<Observables: procedures>>=
   integer function obs_pdg1 (prt1) result (pdg)
     type(prt_t), intent(in) :: prt1
     pdg = prt_get_pdg (prt1)
   end function obs_pdg1
 
 @ %def obs_pdg
 @ The helicity.  The return value is meaningful only if the particle
 is polarized, otherwise an invalid value is returned (-9).
 <<Observables: procedures>>=
   integer function obs_helicity1 (prt1) result (h)
     type(prt_t), intent(in) :: prt1
     if (prt_is_polarized (prt1)) then
        h = prt_get_helicity (prt1)
     else
        h = -9
     end if
   end function obs_helicity1
 
 @ %def obs_helicity1
 @ The number of open color (anticolor) lines.  The return value is meaningful
 only if the particle is colorized (i.e., the subevent has been given color
 information), otherwise the function returns zero.
 <<Observables: procedures>>=
   integer function obs_n_col1 (prt1) result (n)
     type(prt_t), intent(in) :: prt1
     if (prt_is_colorized (prt1)) then
        n = prt_get_n_col (prt1)
     else
        n = 0
     end if
   end function obs_n_col1
 
   integer function obs_n_acl1 (prt1) result (n)
     type(prt_t), intent(in) :: prt1
     if (prt_is_colorized (prt1)) then
        n = prt_get_n_acl (prt1)
     else
        n = 0
     end if
   end function obs_n_acl1
 
 @ %def obs_n_col1
 @ %def obs_n_acl1
 @
 \subsubsection{Real-valued unary observables}
 The invariant mass squared, obtained from the separately stored value.
 <<Observables: procedures>>=
   real(default) function obs_mass_squared1 (prt1) result (p2)
     type(prt_t), intent(in) :: prt1
     p2 = prt_get_msq (prt1)
   end function obs_mass_squared1
 
 @ %def obs_mass_squared1
 @ The signed invariant mass, which is the signed square root of the
 previous observable.
 <<Observables: procedures>>=
   real(default) function obs_signed_mass1 (prt1) result (m)
     type(prt_t), intent(in) :: prt1
     real(default) :: msq
     msq = prt_get_msq (prt1)
     m = sign (sqrt (abs (msq)), msq)
   end function obs_signed_mass1
 
 @ %def obs_signed_mass1
 @ The particle energy
 <<Observables: procedures>>=
   real(default) function obs_energy1 (prt1) result (e)
     type(prt_t), intent(in) :: prt1
     e = energy (prt_get_momentum (prt1))
   end function obs_energy1
 
 @ %def obs_energy1
 @ Particle momentum (components)
 <<Observables: procedures>>=
   real(default) function obs_px1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = vector4_get_component (prt_get_momentum (prt1), 1)
   end function obs_px1
 
   real(default) function obs_py1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = vector4_get_component (prt_get_momentum (prt1), 2)
   end function obs_py1
 
   real(default) function obs_pz1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = vector4_get_component (prt_get_momentum (prt1), 3)
   end function obs_pz1
 
   real(default) function obs_p1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = space_part_norm (prt_get_momentum (prt1))
   end function obs_p1
 
   real(default) function obs_pl1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = longitudinal_part (prt_get_momentum (prt1))
   end function obs_pl1
 
   real(default) function obs_pt1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = transverse_part (prt_get_momentum (prt1))
   end function obs_pt1
 
 @ %def obs_px1 obs_py1 obs_pz1
 @ %def obs_p1 obs_pl1 obs_pt1
 @ Polar and azimuthal angle (lab frame).
 <<Observables: procedures>>=
   real(default) function obs_theta1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = polar_angle (prt_get_momentum (prt1))
   end function obs_theta1
 
   real(default) function obs_phi1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = azimuthal_angle (prt_get_momentum (prt1))
   end function obs_phi1
 
 @ %def obs_theta1 obs_phi1
 @ Rapidity and pseudorapidity
 <<Observables: procedures>>=
   real(default) function obs_rap1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = rapidity (prt_get_momentum (prt1))
   end function obs_rap1
 
   real(default) function obs_eta1 (prt1) result (p)
     type(prt_t), intent(in) :: prt1
     p = pseudorapidity (prt_get_momentum (prt1))
   end function obs_eta1
 
 @ %def obs_rap1 obs_eta1
 @ Meaningless: Polar angle in the rest frame of the two arguments
 combined.
 <<Observables: procedures>>=
   real(default) function obs_theta_star1 (prt1) result (dist)
     type(prt_t), intent(in) :: prt1
     call msg_fatal (" 'Theta_star' is undefined as unary observable")
     dist = 0
   end function obs_theta_star1
 
 @ %def obs_theta_star1
 @ [Obsolete] Meaningless: Polar angle in the rest frame of the 2nd argument.
 <<XXX Observables: procedures>>=
   real(default) function obs_theta_rf1 (prt1) result (dist)
     type(prt_t), intent(in) :: prt1
     call msg_fatal (" 'Theta_RF' is undefined as unary observable")
     dist = 0
   end function obs_theta_rf1
 
 @ %def obs_theta_rf1
 @ Meaningless: Distance on the $\eta$-$\phi$ cylinder.
 <<Observables: procedures>>=
   real(default) function obs_dist1 (prt1) result (dist)
     type(prt_t), intent(in) :: prt1
     call msg_fatal (" 'Dist' is undefined as unary observable")
     dist = 0
   end function obs_dist1
 
 @ %def obs_dist1
 @
 \subsubsection{Integer-valued binary observables}
 These observables are meaningless as binary functions.
 <<Observables: procedures>>=
   integer function obs_pdg2 (prt1, prt2) result (pdg)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" PDG_Code is undefined as binary observable")
     pdg = 0
   end function obs_pdg2
 
   integer function obs_helicity2 (prt1, prt2) result (h)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" Helicity is undefined as binary observable")
     h = 0
   end function obs_helicity2
 
   integer function obs_n_col2 (prt1, prt2) result (n)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" Ncol is undefined as binary observable")
     n = 0
   end function obs_n_col2
 
   integer function obs_n_acl2 (prt1, prt2) result (n)
     type(prt_t), intent(in) :: prt1, prt2
     call msg_fatal (" Nacl is undefined as binary observable")
     n = 0
   end function obs_n_acl2
 
 @ %def obs_pdg2
 @ %def obs_helicity2
 @ %def obs_n_col2
 @ %def obs_n_acl2
 @
 \subsubsection{Real-valued binary observables}
 The invariant mass squared, obtained from the separately stored value.
 <<Observables: procedures>>=
   real(default) function obs_mass_squared2 (prt1, prt2) result (p2)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p2 = prt_get_msq (prt)
   end function obs_mass_squared2
 
 @ %def obs_mass_squared2
 @ The signed invariant mass, which is the signed square root of the
 previous observable.
 <<Observables: procedures>>=
   real(default) function obs_signed_mass2 (prt1, prt2) result (m)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     real(default) :: msq
     call prt_init_combine (prt, prt1, prt2)
     msq = prt_get_msq (prt)
     m = sign (sqrt (abs (msq)), msq)
   end function obs_signed_mass2
 
 @ %def obs_signed_mass2
 @ The particle energy
 <<Observables: procedures>>=
   real(default) function obs_energy2 (prt1, prt2) result (e)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     e = energy (prt_get_momentum (prt))
   end function obs_energy2
 
 @ %def obs_energy2
 @ Particle momentum (components)
 <<Observables: procedures>>=
   real(default) function obs_px2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = vector4_get_component (prt_get_momentum (prt), 1)
   end function obs_px2
 
   real(default) function obs_py2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = vector4_get_component (prt_get_momentum (prt), 2)
   end function obs_py2
 
   real(default) function obs_pz2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = vector4_get_component (prt_get_momentum (prt), 3)
   end function obs_pz2
 
   real(default) function obs_p2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = space_part_norm (prt_get_momentum (prt))
   end function obs_p2
 
   real(default) function obs_pl2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = longitudinal_part (prt_get_momentum (prt))
   end function obs_pl2
 
   real(default) function obs_pt2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = transverse_part (prt_get_momentum (prt))
   end function obs_pt2
 
 @ %def obs_px2 obs_py2 obs_pz2
 @ %def obs_p2 obs_pl2 obs_pt2
 @ Enclosed angle and azimuthal distance (lab frame).
 <<Observables: procedures>>=
   real(default) function obs_theta2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     p = enclosed_angle (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_theta2
 
   real(default) function obs_phi2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = azimuthal_distance (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_phi2
 
 @ %def obs_theta2 obs_phi2
 @ Rapidity and pseudorapidity distance
 <<Observables: procedures>>=
   real(default) function obs_rap2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     p = rapidity_distance &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_rap2
 
   real(default) function obs_eta2 (prt1, prt2) result (p)
     type(prt_t), intent(in) :: prt1, prt2
     type(prt_t) :: prt
     call prt_init_combine (prt, prt1, prt2)
     p = pseudorapidity_distance &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_eta2
 
 @ %def obs_rap2 obs_eta2
 @ [This doesn't work!  The principle of no common particle for momentum
   combination prohibits us from combining a decay particle with the momentum
   of its parent.] Polar angle in the rest frame of the 2nd argument.
 <<XXX Observables: procedures>>=
   real(default) function obs_theta_rf2 (prt1, prt2) result (theta)
     type(prt_t), intent(in) :: prt1, prt2
     theta = enclosed_angle_rest_frame &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_theta_rf2
 
 @ %def obs_theta_rf2
 @ Polar angle of the first particle in the rest frame of the two particles
 combined.
 <<Observables: procedures>>=
   real(default) function obs_theta_star2 (prt1, prt2) result (theta)
     type(prt_t), intent(in) :: prt1, prt2
     theta = enclosed_angle_rest_frame &
          (prt_get_momentum (prt1), &
          prt_get_momentum (prt1) + prt_get_momentum (prt2))
   end function obs_theta_star2
 
 @ %def obs_theta_star2
 @ Distance on the $\eta$-$\phi$ cylinder.
 <<Observables: procedures>>=
   real(default) function obs_dist2 (prt1, prt2) result (dist)
     type(prt_t), intent(in) :: prt1, prt2
     dist = eta_phi_distance &
          (prt_get_momentum (prt1), prt_get_momentum (prt2))
   end function obs_dist2
 
 @ %def obs_dist2
 @ Durham kT measure.
 <<Observables: procedures>>=
   real(default) function obs_ktmeasure (prt1, prt2) result (kt)
     type(prt_t), intent(in) :: prt1, prt2
     real (default) :: q2, e1, e2
     ! Normalized scale to one for now! (#67)
     q2 = 1
     e1 = energy (prt_get_momentum (prt1))
     e2 = energy (prt_get_momentum (prt2))
     kt = (2/q2) * min(e1**2,e2**2) *  &
          (1 - enclosed_angle_ct(prt_get_momentum (prt1), &
          prt_get_momentum (prt2)))
   end function obs_ktmeasure
 
 @ %def obs_ktmeasure
Index: trunk/src/model_features/model_features.nw
===================================================================
--- trunk/src/model_features/model_features.nw	(revision 8441)
+++ trunk/src/model_features/model_features.nw	(revision 8442)
@@ -1,17216 +1,17226 @@
 % -*- 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 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_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_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 :: jet_dcut => 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
 @
 \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)
        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)
        write (u, "(A,6x,A)", advance="no")  repeat ("|  ", ind), "prt1 ="
        call prt_write (node%prt1, unit)
     case (EN_OBS2_INT, EN_OBS2_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
+    logical :: keep_jets, exclusive
     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)
+    exclusive = .false.
+    select case (en1%jet_algorithm)
+    case (ee_kt_algorithm)
+       exclusive = .true.
+    case (ee_genkt_algorithm)
+       if (en1%jet_r > Pi)  exclusive = .true.
+    end select
+    call subevt_cluster (subevt, en1%pval, en1%jet_dcut, mask1, &
+         jet_def, keep_jets, exclusive)
     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
 @ 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
 @
 \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_ppp
 @ 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 ("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")
        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
 @ 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", "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)
+          call var_list%get_rptr (var_str ("jet_dcut"), en1%jet_dcut)
        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 default
        call parse_node_mismatch ("all_fun|any_fun|" // &
             "no_fun|photon_isolation_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 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 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)
     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 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)
        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_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 | " // &
          "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, "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")
     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")
   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 | " // &
          "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")
   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 [[block_name]] and [[block_index]] values, if nonempty, indicate
 the possibility of reading this parameter from a SLHA-type input file.
 (Within the [[parameter_t]] object, this info is just used for I/O,
 the actual block register is located in the parent [[model_t]]
 object.)
 
 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(string_t) :: block_name
      integer, dimension(:), allocatable :: block_index
      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_INDEPENDENT)
        if (allocated (par%block_index)) then
           write (u, "(1x,A,1x,A,*(1x,I0))") &
                "slha_entry", char (par%block_name), par%block_index
        else
           write (u, "(A)")
        end if
     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{SLHA block register}
 For the optional SLHA interface, the model record contains a register
 of SLHA-type block names together with index values, which point to a
 particular parameter.  These are private types:
 <<Models: types>>=
   type :: slha_entry_t
      integer, dimension(:), allocatable :: block_index
      integer :: i_par = 0
   end type slha_entry_t
   
 @ %def slha_entry_t
 <<Models: types>>=
   type :: slha_block_t
      type(string_t) :: name
      integer :: n_entry = 0
      type(slha_entry_t), dimension(:), allocatable :: entry
   end type slha_block_t
   
 @ %def slha_block_t
 @
 \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 :: n_slha_block = 0
      type(slha_block_t), dimension(:), allocatable :: slha_block
      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
        if (allocated (par%block_index)) then
           model%par(i)%block_name = par%block_name
           model%par(i)%block_index = par%block_index
        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{SLHA-type interface}
 Abusing the original strict SUSY Les Houches Accord (SLHA), we support
 reading parameter data from some custom SLHA-type input file.  To this
 end, the [[model]] object stores a list of model-specific block names
 together with information how to find a parameter in the model record,
 given a block name and index vector.
 
 Check if the model supports custom SLHA block info.  This is the case
 if [[n_slha_block]] is nonzero, i.e., after SLHA block names have been
 parsed and registered.
 <<Models: model: TBP>>=
   procedure :: supports_custom_slha => model_supports_custom_slha
 <<Models: procedures>>=
   function model_supports_custom_slha (model) result (flag)
     class(model_t), intent(in) :: model
     logical :: flag
     
     flag = model%n_slha_block > 0
     
   end function model_supports_custom_slha
 
 @ %def model_supports_custom_slha 
 @ Return the block names for all SLHA block references.
 <<Models: model: TBP>>=
   procedure :: get_custom_slha_blocks => model_get_custom_slha_blocks
 <<Models: procedures>>=
   subroutine model_get_custom_slha_blocks (model, block_name)
     class(model_t), intent(in) :: model
     type(string_t), dimension(:), allocatable :: block_name
     
     integer :: i
     
     allocate (block_name (model%n_slha_block))
     do i = 1, size (block_name)
        block_name(i) = model%slha_block(i)%name
     end do
     
   end subroutine model_get_custom_slha_blocks
   
 @ %def model_get_custom_slha_blocks
 @
 This routine registers a SLHA block reference.  We have the index of a
 (new) parameter entry and a parse node from the model file which
 specifies a block name and an index array.
 <<Models: procedures>>=
   subroutine model_record_slha_block_entry (model, i_par, node)
     class(model_t), intent(inout) :: model
     integer, intent(in) :: i_par
     type(parse_node_t), intent(in), target :: node
 
     type(parse_node_t), pointer :: node_block_name, node_index
     type(string_t) :: block_name
     integer :: n_index, i, i_block
     integer, dimension(:), allocatable :: block_index
 
     node_block_name => node%get_sub_ptr (2)
     block_name = node_block_name%get_string ()
     n_index = node%get_n_sub () - 2
     allocate (block_index (n_index))
     node_index => node_block_name%get_next_ptr ()
     do i = 1, n_index
        block_index(i) = node_index%get_integer ()
        node_index => node_index%get_next_ptr ()
     end do
     i_block = 0
     FIND_BLOCK: do i = 1, model%n_slha_block
        if (model%slha_block(i)%name == block_name) then
           i_block = i
           exit FIND_BLOCK
        end if
     end do FIND_BLOCK
     if (i_block == 0) then
        call model_add_slha_block (model, block_name)
        i_block = model%n_slha_block
     end if
     associate (b => model%slha_block(i_block))
       call add_shla_block_entry (b, block_index, i_par)
     end associate
     model%par(i_par)%block_name = block_name
     model%par(i_par)%block_index = block_index
   end subroutine model_record_slha_block_entry
   
 @ %def model_record_slha_block_entry
 @ Add a new entry to the SLHA block register, increasing the array
 size if necessary
 <<Models: procedures>>=
   subroutine model_add_slha_block (model, block_name)
     class(model_t), intent(inout) :: model
     type(string_t), intent(in) :: block_name
     
     if (.not. allocated (model%slha_block))  allocate (model%slha_block (1))
     if (model%n_slha_block == size (model%slha_block))  call grow
     model%n_slha_block = model%n_slha_block + 1
     associate (b => model%slha_block(model%n_slha_block))
       b%name = block_name
       allocate (b%entry (1))
     end associate
     
   contains
     
     subroutine grow
       type(slha_block_t), dimension(:), allocatable :: b_tmp
       call move_alloc (model%slha_block, b_tmp)
       allocate (model%slha_block (2 * size (b_tmp)))
       model%slha_block(:size (b_tmp)) = b_tmp(:)
     end subroutine grow
      
   end subroutine model_add_slha_block
   
 @ %def model_add_slha_block
 @ Add a new entry to a block-register record.  The entry establishes a
 pointer-target relation between an index array within the SLHA block and a
 parameter-data record.  We increase the entry array as needed.
 <<Models: procedures>>=
   subroutine add_shla_block_entry (b, block_index, i_par)
     type(slha_block_t), intent(inout) :: b
     integer, dimension(:), intent(in) :: block_index
     integer, intent(in) :: i_par
     
     if (b%n_entry == size (b%entry))  call grow
     b%n_entry = b%n_entry + 1
     associate (entry => b%entry(b%n_entry))
       entry%block_index = block_index
       entry%i_par = i_par
     end associate
     
   contains
     
     subroutine grow
       type(slha_entry_t), dimension(:), allocatable :: entry_tmp
       call move_alloc (b%entry, entry_tmp)
       allocate (b%entry (2 * size (entry_tmp)))
       b%entry(:size (entry_tmp)) = entry_tmp(:)
     end subroutine grow
     
   end subroutine add_shla_block_entry
 
 @ %def add_slha_block_entry
 @
 The lookup routine returns a pointer to the appropriate [[par_data]]
 record, if [[block_name]] and [[block_index]] are valid.  The latter
 point to the [[slha_block_t]] register within the [[model_t]] object,
 if it is allocated.
 
 This should only be needed during I/O (i.e., while reading the SLHA
 file), so a simple linear search for each parameter should not be a
 performance problem.
 <<Models: model: TBP>>=
   procedure :: slha_lookup => model_slha_lookup
 <<Models: procedures>>=
   subroutine model_slha_lookup (model, block_name, block_index, par_data)
     class(model_t), intent(in) :: model
     type(string_t), intent(in) :: block_name
     integer, dimension(:), intent(in) :: block_index
     class(modelpar_data_t), pointer, intent(out) :: par_data
     
     integer :: i, j
     
     par_data => null ()
     if (allocated (model%slha_block)) then
        do i = 1, model%n_slha_block
           associate (block => model%slha_block(i))
             if (block%name == block_name) then
                do j = 1, block%n_entry
                   associate (entry => block%entry(j))
                     if (size (entry%block_index) == size (block_index)) then
                        if (all (entry%block_index == block_index)) then
                           par_data => model%par(entry%i_par)%data
                           return
                        end if
                     end if
                   end associate
                end do
             end if
           end associate
        end do
     end if
     
   end subroutine model_slha_lookup
     
 @ %def model_slha_lookup
 @ Modify the value of a parameter, identified by block name and index array.
 <<Models: model: TBP>>=
   procedure :: slha_set_par => model_slha_set_par
 <<Models: procedures>>=
   subroutine model_slha_set_par (model, block_name, block_index, value)
     class(model_t), intent(inout) :: model
     type(string_t), intent(in) :: block_name
     integer, dimension(:), intent(in) :: block_index
     real(default), intent(in) :: value
     
     class(modelpar_data_t), pointer :: par_data
     
     call model%slha_lookup (block_name, block_index, par_data)
     if (associated (par_data)) then
        par_data = value
     end if
 
   end subroutine model_slha_set_par
   
 @ %def model_slha_set_par
 @
 \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 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, node_slha_entry
     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.)
     node_slha_entry => parse_node_get_next_ptr (node_val)
     if (associated (node_slha_entry)) then
        call model_record_slha_block_entry (model, i, node_slha_entry)
     end if
   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
     if (allocated (orig%slha_block)) then
        model%slha_block = orig%slha_block
     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
 @
 \subsubsection{Read model with schemes}
 Read a model from file which contains [[slha_entry]] qualifiers for parameters.
 <<Models: execute tests>>=
   call test (models_10, "models_10", &
        "handle slha_entry option", &
        u, results)
 <<Models: test declarations>>=
   public :: models_10
 <<Models: tests>>=
   subroutine models_10 (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
     type(string_t), dimension(:), allocatable :: slha_block_name
     integer :: i
 
     write (u, "(A)")  "* Test output: models_10"
     write (u, "(A)")  "*   Purpose: read a model from file &
          &with slha_entry options"
     write (u, *)
 
     open (newunit=um, file="Test10.mdl", status="replace", action="readwrite")
     write (um, "(A)")  'model "Test10"'
     write (um, "(A)")  '  parameter a = 1   slha_entry FOO 1'
     write (um, "(A)")  '  parameter b = 4   slha_entry BAR 2 1'
 
     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 ("Test10"), var_str ("Test10.mdl"), &
          os_data, model)
     call model%write (u, show_md5sum=.false.)
 
     write (u, *)
     write (u, "(A)")  "* Check that model contains slha_entry options"
     write (u, *)
 
     write (u, "(A,1x,L1)")  &
          "supports_custom_slha =", model%supports_custom_slha ()
     
     write (u, *)
     write (u, "(A)")  "custom_slha_blocks ="
     call model%get_custom_slha_blocks (slha_block_name)
     do i = 1, size (slha_block_name)
        write (u, "(1x,A)", advance="no")  char (slha_block_name(i))
     end do
     write (u, *)
 
     write (u, *)
     write (u, "(A)")  "* Parameter lookup"
     write (u, *)
 
     call show_slha ("FOO", [1])
     call show_slha ("FOO", [2])
     call show_slha ("BAR", [2, 1])
     call show_slha ("GEE", [3])
 
     write (u, *)
     write (u, "(A)")  "* Modify parameter via SLHA block interface"
     write (u, *)
 
     call model%slha_set_par (var_str ("FOO"), [1], 7._default)
     call show_slha ("FOO", [1])
 
     write (u, *)
     write (u, "(A)")  "* Show var list with modified parameter"
     write (u, *)
 
     call show_var_list ()
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     call model_list%final ()
     call syntax_model_file_final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: models_10"
 
   contains
 
     subroutine show_slha (block_name, block_index)
       character(*), intent(in) :: block_name
       integer, dimension(:), intent(in) :: block_index
       class(modelpar_data_t), pointer :: par_data
       write (u, "(A,*(1x,I0))", advance="no")  block_name, block_index
       write (u, "(' => ')", advance="no")
       call model%slha_lookup (var_str (block_name), block_index, par_data)
       if (associated (par_data)) then
          call par_data%write (u)
          write (u, *)
       else
          write (u, "('-')")
       end if
          
     end subroutine show_slha
 
     subroutine show_var_list ()
       var_list => model%get_var_list_ptr ()
       call var_list%write (u)
     end subroutine show_var_list
 
   end subroutine models_10
 
 @ %def models_10
 @
 \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.
 
 A name clash occurse if the block name is identical to a keyword.
 This can happen for custom SLHA models and files.  In that case, we
 prepend an underscore, which will be silently suppressed where needed.
 <<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, custom_block_name, ifile)
     type(stream_t), intent(inout), target :: stream
     type(string_t), dimension(:), intent(in) :: custom_block_name
     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")
              call check_block_handling (line, custom_block_name, mode)
              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 add the
 [[custom_block_name]] array to the set of supported blocks, which
 otherwise includes only hard-coded block names.  Those custom blocks
 are data blocks.  
 
 Unknown blocks will be skipped altogether.  The standard does not
 specify their internal format at all, so we must not parse their
 content.
 
 If the name of a (custom) block clashes with a keyword of the SLHA
 syntax, we append an underscore to the block name, modifying the
 current line string.  This should be silently suppressed when actually
 parsing block names.
 <<SLHA: procedures>>=
   subroutine check_block_handling (line, custom_block_name, mode)
     type(string_t), intent(inout) :: line
     type(string_t), dimension(:), intent(in) :: custom_block_name
     integer, intent(out) :: mode
     type(string_t) :: buffer, key, block_name
     integer :: i
     buffer = trim (line)
     call split (buffer, key, " ")
     buffer = adjustl (buffer)
     call split (buffer, block_name, " ")
     buffer = adjustl (buffer)
     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
        CHECK_CUSTOM_NAMES: do i = 1, size (custom_block_name)
           if (block_name == custom_block_name(i)) then
              mode = MODE_DATA
              call mangle_keywords (block_name)
              line = key // " " // block_name // " " // trim (buffer)
              exit CHECK_CUSTOM_NAMES
           end if
        end do CHECK_CUSTOM_NAMES
     end select
   end subroutine check_block_handling
 
 @ %def check_block_handling
 @ Append an underscore to specific block names:
 <<SLHA: procedures>>=
   subroutine mangle_keywords (name)
     type(string_t), intent(inout) :: name
     select case (char (name))
     case ("BLOCK", "DATA", "INFO", "DECAY")
        name = name // "_"
     end select
   end subroutine mangle_keywords
   
 @ %def mangle_keywords
 @ Remove the underscore again:
 <<SLHA: procedures>>=
   subroutine demangle_keywords (name)
     type(string_t), intent(inout) :: name
     select case (char (name))
     case ("BLOCK_", "DATA_", "INFO_", "DECAY_")
        name = extract (name, 1, len(name)-1)
     end select
   end subroutine demangle_keywords
   
 @ %def demangle_keywords
 
 @
 \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.
 
 We assume that if the model contains custom SLHA block names, we just
 have to scan those to get complete information.  Block names could
 coincide with the SLHA standard block names, but we do not have to
 assume this.  This will be the situation for an UFO-generated file.
 In particular, an UFO file should contain all expressions necessary
 for computing dependent parameters, so we can forget about the strict
 SLHA standard and its hard-coded conventions.
 
 If there are no custom SLHA block names, we should assume that the
 model is a standard SUSY model, and the parameters and hard-coded
 blocks can be read as specified by the original SLHA standard.  There
 are hard-coded block names and parameter calculations.
 
 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
     if (model%supports_custom_slha ()) then
        call slha_handle_custom_file (parse_tree, model)
     else
        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
     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.
 
 This block used to be required, but for generic UFO model support we
 should allow for its absence.  In that case, [[mssm_type]] will be set
 to a negative value.  If the block is present, the model must be one
 of the following, or parsing ends with an error.
 <<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=.false.)
     if (.not. associated (pn_block)) then
        mssm_type = -1
        return
     end if
     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{Parsing custom SLHA files}
 With the introduction of UFO models, we support custom files in
 generic SLHA format that reset model parameters.  In contrast to
 strict SLHA files, the order and naming of blocks is arbitrary.
 
 We scan the complete file (i.e., preprocessed parse tree), parsing all
 blocks that contain data lines.  For each data line, we identify index
 array and associated value.  Then we set the model parameter
 that is associated with that block name and index array, if it exists.
 <<SLHA: procedures>>=
   subroutine slha_handle_custom_file (parse_tree, model)
     type(parse_tree_t), intent(in) :: parse_tree
     type(model_t), intent(inout), target :: model
 
     type(parse_node_t), pointer :: pn_root, pn_block
     type(parse_node_t), pointer :: pn_block_spec, pn_block_name
     type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item
     type(string_t) :: block_name
     integer, dimension(:), allocatable :: block_index
     integer :: n_index, i
     real(default) :: value
     
     pn_root => parse_tree%get_root_ptr ()
     pn_block => pn_root%get_sub_ptr ()
     HANDLE_BLOCKS: do while (associated (pn_block))
        select case (char (pn_block%get_rule_key ()))
        case ("block_def")
           call slha_handle_custom_block (pn_block, model)
        end select
        pn_block => pn_block%get_next_ptr ()
     end do HANDLE_BLOCKS
 
   end subroutine slha_handle_custom_file
   
 @ %def slha_handle_custom_file
 @
 <<SLHA: procedures>>=
   subroutine slha_handle_custom_block (pn_block, model)
     type(parse_node_t), intent(in), target :: pn_block
     type(model_t), intent(inout), target :: model
     
     type(parse_node_t), pointer :: pn_block_spec, pn_block_name
     type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item
     type(string_t) :: block_name
     integer, dimension(:), allocatable :: block_index
     integer :: n_index, i
     real(default) :: value
 
     pn_block_spec => parse_node_get_sub_ptr (pn_block, 2)
     pn_block_name => parse_node_get_sub_ptr (pn_block_spec)
     block_name = trim (adjustl (upper_case (pn_block_name%get_string ())))
     call demangle_keywords (block_name)
     pn_data => pn_block%get_sub_ptr (4)
     HANDLE_LINES: do while (associated (pn_data))
        select case (char (pn_data%get_rule_key ()))
        case ("block_data")
           pn_line => pn_data%get_sub_ptr (2)
           n_index = pn_line%get_n_sub () - 1
           allocate (block_index (n_index))
           pn_code => pn_line%get_sub_ptr ()
           READ_LINE: do i = 1, n_index
              select case (char (pn_code%get_rule_key ()))
              case ("integer");  block_index(i) = pn_code%get_integer ()
              case default
                 pn_code => null ()
                 exit READ_LINE
              end select
              pn_code => pn_code%get_next_ptr ()
           end do READ_LINE
           if (associated (pn_code)) then
              value = get_real_parameter (pn_code)
              call model%slha_set_par (block_name, block_index, value)
           end if
           deallocate (block_index)
        end select
        pn_data => pn_data%get_next_ptr ()
     end do HANDLE_LINES
     
   end subroutine slha_handle_custom_block
   
 @ %def slha_handle_custom_block
 @
 \subsection{Parser}
 Read a SLHA file from stream, including preprocessing, and make up a
 parse tree.
 <<SLHA: procedures>>=
   subroutine slha_parse_stream (stream, custom_block_name, parse_tree)
     type(stream_t), intent(inout), target :: stream
     type(string_t), dimension(:), intent(in) :: custom_block_name
     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, custom_block_name, 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.
 
 The [[default_mode]] applies to unknown blocks in the SLHA file: this
 is either [[MODE_SKIP]] or [[MODE_DATA]], corresponding to genuine
 SUSY and custom file content, respectively.
 <<SLHA: public>>=
   public :: slha_parse_file
 <<SLHA: procedures>>=
   subroutine slha_parse_file (file, custom_block_name, os_data, parse_tree)
     type(string_t), intent(in) :: file
     type(string_t), dimension(:), intent(in) :: custom_block_name
     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, custom_block_name, 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(string_t), dimension(:), allocatable :: custom_block_name
     type(parse_tree_t) :: parse_tree
     call model%get_custom_slha_blocks (custom_block_name)
     call slha_parse_file (file, custom_block_name, 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 ()
     type(string_t), dimension(0) :: empty_string_array
 
     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"), &
          empty_string_array, 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
Index: trunk/src/fastjet/FastjetWrap.cpp
===================================================================
--- trunk/src/fastjet/FastjetWrap.cpp	(revision 8441)
+++ trunk/src/fastjet/FastjetWrap.cpp	(revision 8442)
@@ -1,158 +1,165 @@
 #include "fastjet/ClusterSequence.hh"
 #include <iostream>
 #include "fastjet/EECambridgePlugin.hh"
 
 using namespace fastjet;
 using namespace std;
 
 extern "C" {
 
   // Tell the caller that this is the true Fastjet library
   bool fastjet_available() {
     return true;
   }
 
   void fastjet_print_banner () {
     ClusterSequence::print_banner ();
   }
 
   PseudoJet* new_pseudojet (const double px_in, const double py_in, const double pz_in, const double E_in) {
     PseudoJet* j = new PseudoJet(px_in, py_in, pz_in, E_in);
     return j;
   }
 
   void pseudojet_delete (PseudoJet *j) {
     delete j;
   }
 
   double pseudojet_get_e (const PseudoJet* j) {
     return j->e();
   }
 
   double pseudojet_get_px (const PseudoJet* j) {
     return j->px();
   }
 
   double pseudojet_get_py (const PseudoJet* j) {
     return j->py();
   }
 
   double pseudojet_get_pz (const PseudoJet* j) {
     return j->pz();
   }
 
   double pseudojet_get_perp (const PseudoJet* j) {
     return j->perp();
   }
 
   double pseudojet_get_rap (const PseudoJet* j) {
     return j->rap();
   }
 
   double pseudojet_get_phi (const PseudoJet* j) {
     return j->phi();
   }
 
   vector<PseudoJet>* pseudojet_get_constituents (const PseudoJet* j) {
     vector<PseudoJet>* cv = new vector<PseudoJet>;
     *cv = j->constituents();
     return cv;
   }
 
   bool pseudojet_contains (const PseudoJet* j, const PseudoJet* p) {
     return j->contains(*p);
   }
 
   vector<PseudoJet>* new_pseudojet_vector (const PseudoJet *j[], const int n) {
     vector<PseudoJet>* jv = new vector<PseudoJet>;
     for (int i = 0; i < n; i++) {
       jv->push_back( *j[i] );
     }
     return jv;
   }
 
   void pseudojet_vector_delete (vector<PseudoJet>* jv) {
     delete jv;
   }
 
   int pseudojet_vector_get_size (const vector<PseudoJet>* jv) {
     return jv->size();
   }
 
   PseudoJet* pseudojet_vector_get_jet (const vector<PseudoJet>* jv, const int i) {
     PseudoJet* j = new PseudoJet;
     *j = (*jv)[i];
     return j;
   }
 
   vector<PseudoJet>* pseudojet_vector_sorted_by_pt (vector<PseudoJet>* jv) {
     vector<PseudoJet>* sjv = new vector<PseudoJet>;
     *sjv = sorted_by_pt(*jv);
     return sjv;
   }
 
   JetDefinition* new_jet_definition (const JetAlgorithm jet_alg, const double R,
       const double p, const double jet_ycut) {
     JetDefinition *  jet_def;
     if (jet_alg==plugin_algorithm) {
       EECambridgePlugin *eec = new EECambridgePlugin (jet_ycut);
       jet_def = new JetDefinition (eec);
     }
     else if ((jet_alg == genkt_algorithm) || (jet_alg == ee_genkt_algorithm)) {
       jet_def = new JetDefinition (jet_alg, R, p);
     }
     else if (jet_alg == ee_kt_algorithm) {
       jet_def = new JetDefinition (jet_alg);
     }
     else{
       jet_def = new JetDefinition (jet_alg, R);
     }
     return jet_def;
   }
 
   void jet_definition_delete (JetDefinition* jet_def) {
     delete jet_def;
   }
 
   int jet_definition_description_strlen (const JetDefinition* jet_def) {
     return jet_def->description().length();
   }
 
   string* jet_definition_get_description (const JetDefinition* jet_def) {
     string* s = new string (jet_def->description());
     return s;
   }
 
   ClusterSequence* new_cluster_sequence (const vector<PseudoJet>* particles,
       JetDefinition* jet_def) {
     // run the clustering, extract the jets
     ClusterSequence* cs = new ClusterSequence (*particles, *jet_def);
     return cs;
   }
 
   void cluster_sequence_delete (ClusterSequence* cs) {
     delete cs;
   }
 
   vector<PseudoJet>* cluster_sequence_get_inclusive_jets (const ClusterSequence *cs) {
     vector<PseudoJet>* jets = new vector<PseudoJet>;
     *jets = cs->inclusive_jets();
     return jets;
   }
 
+  vector<PseudoJet>* cluster_sequence_get_exclusive_jets (const ClusterSequence *cs,
+      const double dcut) {
+    vector<PseudoJet>* jets = new vector<PseudoJet>;
+    *jets = cs->exclusive_jets(dcut);
+    return jets;
+  }
+
   vector<int>* cluster_sequence_get_jet_indices (const ClusterSequence* cs,
       const vector<PseudoJet>* jets) {
     vector<int>* idx = new vector<int>;
     *idx = cs->particle_jet_indices(*jets);
     return idx;
   }
 
   int int_vector_get (const vector<int>* iv, const int i) {
     return (*iv)[i];
   }
 
   void int_vector_delete (vector<int>* iv) {
     delete iv;
   }
 
 }
Index: trunk/src/fastjet/fastjet.f90
===================================================================
--- trunk/src/fastjet/fastjet.f90	(revision 8441)
+++ trunk/src/fastjet/fastjet.f90	(revision 8442)
@@ -1,580 +1,594 @@
 !$Id: fastjet.f90 6133 2014-09-17 14:42:33Z kilian $
 
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !
 ! Copyright (C) 1999-2020 by
 !     Wolfgang Kilian <kilian@physik.uni-siegen.de>
 !     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 !     Juergen Reuter <juergen.reuter@desy.de>
+!
 !     with contributions from
-!     Fabian Bach <fabian.bach@t-online.de>
-!     Christian Speckner <cnspeckn@googlemail.com>
-!     Christian Weiss <christian.weiss@desy.de>
-!     and Hans-Werner Boschmann, Felix Braam,
-!     Sebastian Schmidt, Daniel Wiesler
+!     cf. main AUTHORS file
 !
 ! WHIZARD is free software; you can redistribute it and/or modify it
 ! under the terms of the GNU General Public License as published by
 ! the Free Software Foundation; either version 2, or (at your option)
 ! any later version.
 !
 ! WHIZARD is distributed in the hope that it will be useful, but
 ! WITHOUT ANY WARRANTY; without even the implied warranty of
 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ! GNU General Public License for more details.
 !
 ! You should have received a copy of the GNU General Public License
 ! along with this program; if not, write to the Free Software
 ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 !
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 module fastjet
 
   use, intrinsic :: iso_c_binding
   use kinds
   use lorentz
   use cpp_strings
 
   implicit none
   private
 
   ! Public types
   public :: pseudojet_t
   public :: pseudojet_vector
   public :: pseudojet_vector_t
   public :: jet_definition_t
   public :: cluster_sequence_t
 
   ! Public functions and operations
   public :: fastjet_available
   public :: print_banner
   public :: sorted_by_pt
   public :: assignment(=)
 
   ! Public parameters
   public :: kt_algorithm
   public :: cambridge_algorithm
   public :: antikt_algorithm
   public :: genkt_algorithm
   public :: cambridge_for_passive_algorithm
   public :: genkt_for_passive_algorithm
   public :: ee_kt_algorithm
   public :: ee_genkt_algorithm
   public :: plugin_algorithm
   public :: undefined_jet_algorithm
   enum, bind (C)
      enumerator :: kt_algorithm = 0
      enumerator :: cambridge_algorithm = 1
      enumerator :: antikt_algorithm = 2
      enumerator :: genkt_algorithm = 3
      enumerator :: cambridge_for_passive_algorithm = 11
      enumerator :: genkt_for_passive_algorithm = 13
      enumerator :: ee_kt_algorithm = 50
      enumerator :: ee_genkt_algorithm = 53
      enumerator :: plugin_algorithm = 99
      enumerator :: undefined_jet_algorithm = 999
   end enum
   integer, parameter :: jet_algorithm_kind = c_int
 
 
   ! Type definitions
   type :: pseudojet_t
      private
      type(c_ptr) :: cptr
    contains
      generic :: init => pseudojet_init, pseudojet_init_vector4
      procedure :: pseudojet_init
      procedure :: pseudojet_init_vector4
      procedure :: final => pseudojet_final
      procedure :: e => pseudojet_e
      procedure :: px => pseudojet_px
      procedure :: py => pseudojet_py
      procedure :: pz => pseudojet_pz
      procedure :: perp => pseudojet_perp
      procedure :: rap => pseudojet_rap
      procedure :: phi => pseudojet_phi
      procedure :: constituents => pseudojet_constituents
      procedure :: contains => pseudojet_contains_prt
   end type pseudojet_t
 
   type :: pseudojet_vector_t
      private
      type(c_ptr) :: cptr
    contains
      procedure :: init => pseudojet_vector_init
      procedure :: final => pseudojet_vector_final
      procedure :: size => pseudojet_vector_size
      procedure :: get => pseudojet_vector_get
   end type pseudojet_vector_t
 
   type :: jet_definition_t
      private
      type(c_ptr) :: cptr
      type(cpp_string_t) :: description_str
      integer :: description_strlen = 0
    contains
      procedure :: init => jet_definition_init
      procedure :: final => jet_definition_final
      procedure :: description => jet_definition_description
   end type jet_definition_t
 
   type :: cluster_sequence_t
      private
      type(c_ptr) :: cptr
    contains
      procedure :: init => cluster_sequence_init
      procedure :: final => cluster_sequence_final
      procedure :: inclusive_jets => cluster_sequence_inclusive_jets
+     procedure :: exclusive_jets => cluster_sequence_exclusive_jets
      procedure :: assign_jet_indices => cluster_sequence_assign_jet_indices
   end type cluster_sequence_t
 
 
   ! Interfaces for generic operators
   interface assignment(=)
      module procedure pseudojet_array_from_vector
   end interface assignment(=)
 
 
   ! Interfaces for FastJet C wrapper functions
   interface
      subroutine fastjet_print_banner () bind (C)
      end subroutine fastjet_print_banner
   end interface
 
   interface
      function fastjet_available () bind (C) result (flag)
        import
        logical(c_bool) :: flag
      end function fastjet_available
   end interface
 
   interface
      function new_pseudojet (px, py, pz, e) bind (C) result (j)
        import
        real(c_double), intent(in), value :: px, py, pz, e
        type(c_ptr) :: j
      end function new_pseudojet
   end interface
 
   interface
      subroutine pseudojet_delete (j) bind (C)
        import
        type(c_ptr), value :: j
      end subroutine pseudojet_delete
   end interface
 
   interface
      function pseudojet_get_e (j) bind (C) result (e)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: e
      end function pseudojet_get_e
   end interface
 
   interface
      function pseudojet_get_px (j) bind (C) result (px)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: px
      end function pseudojet_get_px
   end interface
 
   interface
      function pseudojet_get_py (j) bind (C) result (py)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: py
      end function pseudojet_get_py
   end interface
 
   interface
      function pseudojet_get_pz (j) bind (C) result (pz)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: pz
      end function pseudojet_get_pz
   end interface
 
   interface
      function pseudojet_get_perp (j) bind (C) result (p)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: p
      end function pseudojet_get_perp
   end interface
 
   interface
      function pseudojet_get_rap (j) bind (C) result (p)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: p
      end function pseudojet_get_rap
   end interface
 
   interface
      function pseudojet_get_phi (j) bind (C) result (p)
        import
        type(c_ptr), intent(in), value :: j
        real(c_double) :: p
      end function pseudojet_get_phi
   end interface
 
   interface
      function pseudojet_get_constituents (j) bind (C) result (cv)
        import
        type(c_ptr), intent(in), value :: j
        type(c_ptr) :: cv
      end function pseudojet_get_constituents
   end interface
 
   interface
      function pseudojet_contains (j, p) bind (C) result (flag)
        import
        type(c_ptr), intent(in), value :: j, p
        logical(c_bool) :: flag
      end function pseudojet_contains
   end interface
 
 
   interface
      function new_pseudojet_vector (j, n) bind (C) result (jv)
        import
        type(c_ptr), dimension(*), intent(in) :: j
        integer(c_int), intent(in), value :: n
        type(c_ptr) :: jv
      end function new_pseudojet_vector
   end interface
 
   interface
      subroutine pseudojet_vector_delete (jv) bind (C)
        import
        type(c_ptr), value :: jv
      end subroutine pseudojet_vector_delete
   end interface
 
   interface
      function pseudojet_vector_get_size (jv) bind (C) result (n)
        import
        type(c_ptr), intent(in), value :: jv
        integer(c_int) :: n
      end function pseudojet_vector_get_size
   end interface
 
   interface
      function pseudojet_vector_get_jet (jv, i) bind (C) result (cptr)
        import
        type(c_ptr), intent(in), value :: jv
        integer(c_int), intent(in), value :: i
        type(c_ptr) :: cptr
      end function pseudojet_vector_get_jet
   end interface
 
   interface
      function pseudojet_vector_sorted_by_pt (jets) bind (C) result (sorted_jets)
        import
        type(c_ptr), intent(in), value :: jets
        type(c_ptr) :: sorted_jets
      end function pseudojet_vector_sorted_by_pt
   end interface
 
   interface
      function new_jet_definition (jet_alg, r, p, jet_ycut) bind (C) result (jet_def)
        import
        integer(jet_algorithm_kind), intent(in), value :: jet_alg
        real(c_double), intent(in), value :: r
        real(c_double), intent(in), value :: p
        real(c_double), intent(in), value :: jet_ycut
        type(c_ptr) :: jet_def
      end function new_jet_definition
   end interface
 
   interface
      subroutine jet_definition_delete (jet_def) bind (C)
        import
        type(c_ptr), value :: jet_def
      end subroutine jet_definition_delete
   end interface
 
   interface
      function jet_definition_get_description (jet_def) bind (C) result (str)
        import
        type(c_ptr), intent(in), value :: jet_def
        type(c_ptr) :: str
      end function jet_definition_get_description
   end interface
 
   interface
      function new_cluster_sequence (jv, jet_def) bind (C) result (cs)
        import
        type(c_ptr), intent(in), value :: jv
        type(c_ptr), intent(in), value :: jet_def
        type(c_ptr) :: cs
      end function new_cluster_sequence
   end interface
 
   interface
      subroutine cluster_sequence_delete (cs) bind (C)
        import
        type(c_ptr), value :: cs
      end subroutine cluster_sequence_delete
   end interface
 
   interface
      function cluster_sequence_get_inclusive_jets (cs) bind (C) result (jets)
        import
        type(c_ptr), intent(in), value :: cs
        type(c_ptr) :: jets
      end function cluster_sequence_get_inclusive_jets
   end interface
 
   interface
+     function cluster_sequence_get_exclusive_jets (cs, dcut) bind (C) result (jets)
+       import
+       type(c_ptr), intent(in), value :: cs
+       real(c_double), intent(in) :: dcut
+       type(c_ptr) :: jets
+     end function cluster_sequence_get_exclusive_jets
+  end interface
+
+  interface
      function cluster_sequence_get_jet_indices (cs, jets) bind (C) result (idx)
        import
        type(c_ptr), intent(in), value :: cs, jets
        type(c_ptr) :: idx
      end function cluster_sequence_get_jet_indices
   end interface
 
   interface
      function int_vector_get (iv, i) bind (C) result (j)
        import
        type(c_ptr), intent(in), value :: iv
        integer(c_int), intent(in), value :: i
        integer(c_int) :: j
      end function int_vector_get
   end interface
 
   interface
      subroutine int_vector_delete (iv) bind (C)
        import
        type(c_ptr), value :: iv
      end subroutine int_vector_delete
   end interface
 
 contains
 
   ! Fastjet banner, print explicitly to control order of output
   subroutine print_banner ()
     call fastjet_print_banner ()
   end subroutine print_banner
 
   ! Procedures for pseudojets
   subroutine pseudojet_init (j, px, py, pz, E)
     class(pseudojet_t), intent(out) :: j
     real(default), intent(in) :: px, py, pz, E
     real(c_double) :: jx = 0
     real(c_double) :: jy = 0
     real(c_double) :: jz = 0
     real(c_double) :: je = 0
     jx = px
     jy = py
     jz = pz
     je = E
     j%cptr = new_pseudojet (jx, jy, jz, je)
   end subroutine pseudojet_init
 
   subroutine pseudojet_init_vector4 (j, p)
     class(pseudojet_t), intent(out) :: j
     type(vector4_t), intent(in) :: p
     real(c_double) :: jx = 0
     real(c_double) :: jy = 0
     real(c_double) :: jz = 0
     real(c_double) :: je = 0
     jx = vector4_get_component (p, 1)
     jy = vector4_get_component (p, 2)
     jz = vector4_get_component (p, 3)
     je = vector4_get_component (p, 0)
     j%cptr = new_pseudojet (jx, jy, jz, je)
   end subroutine pseudojet_init_vector4
 
   subroutine pseudojet_final (j)
     class(pseudojet_t), intent(inout) :: j
     call pseudojet_delete (j%cptr)
     j%cptr = c_null_ptr
   end subroutine pseudojet_final
 
   function pseudojet_e (j) result (e)
     class(pseudojet_t), intent(in) :: j
     real(default) :: e
     e = pseudojet_get_e (j%cptr)
   end function pseudojet_e
 
   function pseudojet_px (j) result (p)
     class(pseudojet_t), intent(in) :: j
     real(default) :: p
     p = pseudojet_get_px (j%cptr)
   end function pseudojet_px
 
   function pseudojet_py (j) result (p)
     class(pseudojet_t), intent(in) :: j
     real(default) :: p
     p = pseudojet_get_py (j%cptr)
   end function pseudojet_py
 
   function pseudojet_pz (j) result (p)
     class(pseudojet_t), intent(in) :: j
     real(default) :: p
     p = pseudojet_get_pz (j%cptr)
   end function pseudojet_pz
 
   function pseudojet_perp (j) result (p)
     class(pseudojet_t), intent(in) :: j
     real(default) :: p
     p = pseudojet_get_perp (j%cptr)
   end function pseudojet_perp
 
   function pseudojet_rap (j) result (p)
     class(pseudojet_t), intent(in) :: j
     real(default) :: p
     p = pseudojet_get_rap (j%cptr)
   end function pseudojet_rap
 
   function pseudojet_phi (j) result (p)
     class(pseudojet_t), intent(in) :: j
     real(default) :: p
     p = pseudojet_get_phi (j%cptr)
   end function pseudojet_phi
 
   function pseudojet_constituents (j) result (prt)
     class(pseudojet_t), intent(in) :: j
     type(pseudojet_vector_t) :: prt
     prt%cptr = pseudojet_get_constituents (j%cptr)
   end function
 
   function pseudojet_contains_prt (j, prt) result (flag)
     class(pseudojet_t), intent(in) :: j
     type(pseudojet_t), intent(in) :: prt
     logical :: flag
     flag = pseudojet_contains (j%cptr, prt%cptr)
   end function pseudojet_contains_prt
 
 
   ! Procedures for pseudojet vectors
   function pseudojet_vector (j) result (jv)
     type(pseudojet_t), dimension(:), intent(in) :: j
     type(pseudojet_vector_t) :: jv
     call jv%init (j)
   end function pseudojet_vector
 
   subroutine pseudojet_vector_init (jv, j)
     class(pseudojet_vector_t), intent(out) :: jv
     type(pseudojet_t), dimension(:), intent(in) :: j
     type(c_ptr), dimension(:), allocatable :: cptr
     allocate (cptr (size (j)))
     cptr = j%cptr
     jv%cptr = new_pseudojet_vector (cptr, size (j))
   end subroutine pseudojet_vector_init
 
   subroutine pseudojet_vector_final (jv)
     class(pseudojet_vector_t), intent(inout) :: jv
     call pseudojet_vector_delete (jv%cptr)
     jv%cptr = c_null_ptr
   end subroutine pseudojet_vector_final
 
   function pseudojet_vector_size (jv) result (n)
     class(pseudojet_vector_t), intent(in) :: jv
     integer :: n
     n = pseudojet_vector_get_size (jv%cptr)
   end function pseudojet_vector_size
 
   function pseudojet_vector_get (jv, i) result (j)
     class(pseudojet_vector_t), intent(in) :: jv
     integer, intent(in) :: i
     type(pseudojet_t) :: j
     j%cptr = pseudojet_vector_get_jet (jv%cptr, int(i-1, c_int))
   end function pseudojet_vector_get
 
   subroutine pseudojet_array_from_vector (j, jv)
     type(pseudojet_t), dimension(:), allocatable, intent(out) :: j
     type(pseudojet_vector_t), intent(in) :: jv
     integer :: i, n
     n = jv%size ()
     allocate (j (n))
     do i = 1, n
        j(i) = jv%get (i)
     end do
   end subroutine pseudojet_array_from_vector
 
   function sorted_by_pt (jets) result (sorted_jets)
     class(pseudojet_vector_t), intent(in) :: jets
     type(pseudojet_vector_t) :: sorted_jets
     sorted_jets%cptr = pseudojet_vector_sorted_by_pt (jets%cptr)
   end function sorted_by_pt
 
-
   ! Procedures for jet definitions
   subroutine jet_definition_init (jet_def, jet_alg, r, p, jet_ycut)
     class(jet_definition_t), intent(out) :: jet_def
     integer(jet_algorithm_kind), intent(in) :: jet_alg
     real(default), intent(in) :: r
     real(default), intent(in), optional :: p
     real(default), intent(in), optional :: jet_ycut
     type(cpp_string_t) :: description_str
     real(default) :: ycut
     real(default) :: pp
     ycut = -1._default
     pp = -1._default
     if (present (jet_ycut)) then
        ycut = jet_ycut
     end if
     if (present (p)) then
        pp = p
     end if
     jet_def%cptr = new_jet_definition (jet_alg, real (r, c_double), &
          real (pp, c_double), real (ycut, c_double))
     call jet_def%description_str%init &
          (jet_definition_get_description (jet_def%cptr))
     jet_def%description_strlen = len (jet_def%description_str)
   end subroutine jet_definition_init
 
   subroutine jet_definition_final (jet_def)
     class(jet_definition_t), intent(inout) :: jet_def
     call jet_def%description_str%final ()
     jet_def%description_strlen = 0
     call jet_definition_delete (jet_def%cptr)
     jet_def%cptr = c_null_ptr
   end subroutine jet_definition_final
 
   function jet_definition_description (jet_def) result (string)
     class(jet_definition_t), intent(in) :: jet_def
     character(len=jet_def%description_strlen) :: string
     string = char (jet_def%description_str)
   end function jet_definition_description
 
 
   ! Procedures for cluster sequences
   subroutine cluster_sequence_init (cs, jv, jet_def)
     class(cluster_sequence_t), intent(out) :: cs
     type(pseudojet_vector_t), intent(in) :: jv
     type(jet_definition_t), intent(in) :: jet_def
     cs%cptr = new_cluster_sequence (jv%cptr, jet_def%cptr)
   end subroutine cluster_sequence_init
 
   subroutine cluster_sequence_final (cs)
     class(cluster_sequence_t), intent(inout) :: cs
     call cluster_sequence_delete (cs%cptr)
     cs%cptr = c_null_ptr
   end subroutine cluster_sequence_final
 
   function cluster_sequence_inclusive_jets (cs) result (jets)
     class(cluster_sequence_t), intent(in) :: cs
     type(pseudojet_vector_t) :: jets
     jets%cptr = cluster_sequence_get_inclusive_jets (cs%cptr)
   end function cluster_sequence_inclusive_jets
 
+  function cluster_sequence_exclusive_jets (cs, dcut) result (jets)
+    class(cluster_sequence_t), intent(in) :: cs
+    type(pseudojet_vector_t) :: jets
+    real(default), intent(in) :: dcut
+    jets%cptr = cluster_sequence_get_exclusive_jets (cs%cptr, &
+         real (dcut, c_double))
+  end function cluster_sequence_exclusive_jets
+
   subroutine cluster_sequence_assign_jet_indices (cs, jets, idx)
     class(cluster_sequence_t), intent(in) :: cs
     type(pseudojet_vector_t), intent(in) :: jets
     integer, dimension(:), intent(out) :: idx
     type(c_ptr) :: idx_cptr
     integer :: i
     idx_cptr = cluster_sequence_get_jet_indices (cs%cptr, jets%cptr)
     do i = 1, size (idx)
        idx(i) = int_vector_get (idx_cptr, int(i-1, c_int)) + 1
     end do
     call int_vector_delete (idx_cptr)
   end subroutine cluster_sequence_assign_jet_indices
 
 end module fastjet
 
Index: trunk/src/fastjet/FastjetWrap_dummy.f90
===================================================================
--- trunk/src/fastjet/FastjetWrap_dummy.f90	(revision 8441)
+++ trunk/src/fastjet/FastjetWrap_dummy.f90	(revision 8442)
@@ -1,284 +1,294 @@
 ! Tell the caller that this is NOT the true Fastjet library
 logical(c_bool) function fastjet_available () bind(C)
   use iso_c_binding
   fastjet_available = .false.
 end function fastjet_available
 
 ! Dummy implementations for FastJet C wrapper functions
 subroutine fastjet_print_banner () bind (C)
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop         
+  stop
 end subroutine fastjet_print_banner
 
 function new_pseudojet (px, py, pz, e) bind (C) result (j)
   use iso_c_binding
   real(c_double), intent(in), value :: px, py, pz, e
   type(c_ptr) :: j
   j = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function new_pseudojet
 
 subroutine pseudojet_delete (j) bind (C)
   use iso_c_binding
   type(c_ptr), value :: j
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end subroutine pseudojet_delete
 
 function pseudojet_get_e (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_e
 
 function pseudojet_get_px (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_px
 
 function pseudojet_get_py (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_py
 
 function pseudojet_get_pz (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_pz
 
 function pseudojet_get_perp (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_perp
 
 function pseudojet_get_rap (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_rap
 
 function pseudojet_get_phi (j) bind (C) result (p)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   real(c_double) :: p
   p = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_phi
 
 function pseudojet_get_constituents (j) bind (C) result (cv)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j
   type(c_ptr) :: cv
   cv = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_get_constituents
 
 function pseudojet_contains (j, p) bind (C) result (flag)
   use iso_c_binding
   type(c_ptr), intent(in), value :: j, p
   logical(c_bool) :: flag
   flag = .false.
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_contains
 
 function new_pseudojet_vector (j, n) bind (C) result (jv)
   use iso_c_binding
   type(c_ptr), dimension(*), intent(in) :: j
   integer(c_int), intent(in), value :: n
   type(c_ptr) :: jv
   jv = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function new_pseudojet_vector
 
 subroutine pseudojet_vector_delete (jv) bind (C)
   use iso_c_binding
   type(c_ptr), value :: jv
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end subroutine pseudojet_vector_delete
 
 function pseudojet_vector_get_size (jv) bind (C) result (n)
   use iso_c_binding
   type(c_ptr), intent(in), value :: jv
   integer(c_int) :: n
   n = 0
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_vector_get_size
 
 function pseudojet_vector_get_jet (jv, i) bind (C) result (cptr)
   use iso_c_binding
   type(c_ptr), intent(in), value :: jv
   integer(c_int), intent(in), value :: i
   type(c_ptr) :: cptr
   cptr = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_vector_get_jet
 
 function pseudojet_vector_sorted_by_pt (jets) bind (C) result (sorted_jets)
   use iso_c_binding
   type(c_ptr), intent(in), value :: jets
   type(c_ptr) :: sorted_jets
   sorted_jets = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function pseudojet_vector_sorted_by_pt
 
 function new_jet_definition (jet_alg, r, jet_ycut) bind (C) result (jet_def)
   use iso_c_binding
   integer(c_int), intent(in), value :: jet_alg
   real(c_double), intent(in), value :: jet_ycut
   real(c_double), intent(in), value :: r
   type(c_ptr) :: jet_def
   jet_def = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function new_jet_definition
 
 subroutine jet_definition_delete (jet_def) bind (C)
   use iso_c_binding
   type(c_ptr), value :: jet_def
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end subroutine jet_definition_delete
 
 function jet_definition_get_description (jet_def) bind (C) result (str)
   use iso_c_binding
   type(c_ptr), intent(in), value :: jet_def
   type(c_ptr) :: str
   str = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function jet_definition_get_description
 
 function new_cluster_sequence (jv, jet_def) bind (C) result (cs)
   use iso_c_binding
   type(c_ptr), intent(in), value :: jv
   type(c_ptr), intent(in), value :: jet_def
   type(c_ptr) :: cs
   cs = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function new_cluster_sequence
 
 subroutine cluster_sequence_delete (cs) bind (C)
   use iso_c_binding
   type(c_ptr), value :: cs
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end subroutine cluster_sequence_delete
 
 function cluster_sequence_get_inclusive_jets (cs) bind (C) result (jets)
   use iso_c_binding
   type(c_ptr), intent(in), value :: cs
   type(c_ptr) :: jets
   jets = c_null_ptr
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function cluster_sequence_get_inclusive_jets
 
+function cluster_sequence_get_exclusive_jets (cs, dcut) bind (C) result (jets)
+  use iso_c_binding
+  type(c_ptr), intent(in), value :: cs
+  real(c_double), intent(in) :: dcut
+  type(c_ptr) :: jets
+  jets = c_null_ptr
+  write (0, "(A)")  "**************************************************************"
+  write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
+  write (0, "(A)")  "**************************************************************"
+  stop
+end function cluster_sequence_get_exclusive_jets
+
 function cluster_sequence_get_jet_indices (cs, jv) bind (C) result (idx)
   use iso_c_binding
   type(c_ptr), intent(in), value :: cs, jv
   type(c_ptr) :: idx
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function cluster_sequence_get_jet_indices
 
 function int_vector_get (iv, i) bind (C) result (j)
   use iso_c_binding
   type(c_ptr), intent(in), value :: iv
   integer(c_int), intent(in), value :: i
   integer(c_int) :: j
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end function int_vector_get
 
 subroutine int_vector_delete (iv) bind (C)
   use iso_c_binding
   type(c_ptr), value :: iv
   write (0, "(A)")  "**************************************************************"
   write (0, "(A)")  "*** FastJet: Error: library not linked, WHIZARD terminates ***"
   write (0, "(A)")  "**************************************************************"
-  stop           
+  stop
 end subroutine int_vector_delete
-
-  
Index: trunk/src/types/types.nw
===================================================================
--- trunk/src/types/types.nw	(revision 8441)
+++ trunk/src/types/types.nw	(revision 8442)
@@ -1,7934 +1,7940 @@
 %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: common types and objects
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Sindarin Built-In Types}
 \includemodulegraph{types}
 
 Here, we define a couple of types and objects which are useful both
 internally for \whizard, and visible to the user, so they correspond
 to Sindarin types.
 \begin{description}
 \item[particle\_specifiers]
   Expressions for particles and particle alternatives, involving
   particle names.
 \item[pdg\_arrays]
   Integer (PDG) codes for particles.  Useful for particle aliases
   (e.g., 'quark' for $u,d,s$ etc.).
 \item[jets]
   Define (pseudo)jets as objects.  Functional only if the [[fastjet]] library
   is linked.  (This may change in the future.)
 \item[subevents]
   Particle collections built from event records, for use in analysis and other
   Sindarin expressions
 \item[analysis]
   Observables, histograms, and plots.
 \end{description}
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Particle Specifiers}
 In this module we introduce a type for specifying a particle or particle
 alternative.  In addition to the particle specifiers (strings separated by
 colons), the type contains an optional flag [[polarized]] and a string
 [[decay]].  If the [[polarized]] flag is set, particle polarization
 information should be kept when generating events for this process.  If the
 [[decay]] string is set, it is the ID of a decay process which should be
 applied to this particle when generating events.
 
 In input/output form, the [[polarized]] flag is indicated by an asterisk
 [[(*)]] in brackets, and the [[decay]] is indicated by its ID in brackets.
 
 The [[read]] and [[write]] procedures in this module are not type-bound but
 generic procedures which handle scalar and array arguments.
 <<[[particle_specifiers.f90]]>>=
 <<File header>>
 
 module particle_specifiers
 
 <<Use strings>>
   use io_units
   use diagnostics
 
 <<Standard module head>>
 
 <<Particle specifiers: public>>
 
 <<Particle specifiers: types>>
 
 <<Particle specifiers: interfaces>>
 
 contains
 
 <<Particle specifiers: procedures>>
 
 end module particle_specifiers
 @ %def particle_specifiers
 @
 \subsection{Base type}
 This is an abstract type which can hold a single particle or an expression.
 <<Particle specifiers: types>>=
   type, abstract :: prt_spec_expr_t
    contains
    <<Particle specifiers: prt spec expr: TBP>>
   end type prt_spec_expr_t
 
 @ %def prt_expr_t
 @ Output, as a string.
 <<Particle specifiers: prt spec expr: TBP>>=
   procedure (prt_spec_expr_to_string), deferred :: to_string
 <<Particle specifiers: interfaces>>=
   abstract interface
      function prt_spec_expr_to_string (object) result (string)
        import
        class(prt_spec_expr_t), intent(in) :: object
        type(string_t) :: string
      end function prt_spec_expr_to_string
   end interface
 
 @ %def prt_spec_expr_to_string
 @ Call an [[expand]] method for all enclosed subexpressions (before handling
 the current expression).
 <<Particle specifiers: prt spec expr: TBP>>=
   procedure (prt_spec_expr_expand_sub), deferred :: expand_sub
 <<Particle specifiers: interfaces>>=
   abstract interface
      subroutine prt_spec_expr_expand_sub (object)
        import
        class(prt_spec_expr_t), intent(inout) :: object
      end subroutine prt_spec_expr_expand_sub
   end interface
 
 @ %def prt_spec_expr_expand_sub
 @
 \subsection{Wrapper type}
 This wrapper can hold a particle expression of any kind.  We need it so we can
 make variadic arrays.
 <<Particle specifiers: public>>=
   public :: prt_expr_t
 <<Particle specifiers: types>>=
   type :: prt_expr_t
      class(prt_spec_expr_t), allocatable :: x
    contains
    <<Particle specifiers: prt expr: TBP>>
   end type prt_expr_t
 
 @ %def prt_expr_t
 @ Output as a string: delegate.
 <<Particle specifiers: prt expr: TBP>>=
   procedure :: to_string => prt_expr_to_string
 <<Particle specifiers: procedures>>=
   recursive function prt_expr_to_string (object) result (string)
     class(prt_expr_t), intent(in) :: object
     type(string_t) :: string
     if (allocated (object%x)) then
        string = object%x%to_string ()
     else
        string = ""
     end if
   end function prt_expr_to_string
 
 @ %def prt_expr_to_string
 @ Allocate the expression as a particle specifier and copy the value.
 <<Particle specifiers: prt expr: TBP>>=
   procedure :: init_spec => prt_expr_init_spec
 <<Particle specifiers: procedures>>=
   subroutine prt_expr_init_spec (object, spec)
     class(prt_expr_t), intent(out) :: object
     type(prt_spec_t), intent(in) :: spec
     allocate (prt_spec_t :: object%x)
     select type (x => object%x)
     type is (prt_spec_t)
        x = spec
     end select
   end subroutine prt_expr_init_spec
 
 @ %def prt_expr_init_spec
 @ Allocate as a list/sum and allocate for a given length
 <<Particle specifiers: prt expr: TBP>>=
   procedure :: init_list => prt_expr_init_list
   procedure :: init_sum => prt_expr_init_sum
 <<Particle specifiers: procedures>>=
   subroutine prt_expr_init_list (object, n)
     class(prt_expr_t), intent(out) :: object
     integer, intent(in) :: n
     allocate (prt_spec_list_t :: object%x)
     select type (x => object%x)
     type is (prt_spec_list_t)
        allocate (x%expr (n))
     end select
   end subroutine prt_expr_init_list
 
   subroutine prt_expr_init_sum (object, n)
     class(prt_expr_t), intent(out) :: object
     integer, intent(in) :: n
     allocate (prt_spec_sum_t :: object%x)
     select type (x => object%x)
     type is (prt_spec_sum_t)
        allocate (x%expr (n))
     end select
   end subroutine prt_expr_init_sum
 
 @ %def prt_expr_init_list
 @ %def prt_expr_init_sum
 @ Return the number of terms.  This is unity, except if the expression is a
 sum.
 <<Particle specifiers: prt expr: TBP>>=
   procedure :: get_n_terms => prt_expr_get_n_terms
 <<Particle specifiers: procedures>>=
   function prt_expr_get_n_terms (object) result (n)
     class(prt_expr_t), intent(in) :: object
     integer :: n
     if (allocated (object%x)) then
        select type (x => object%x)
        type is (prt_spec_sum_t)
           n = size (x%expr)
        class default
           n = 1
        end select
     else
        n = 0
     end if
   end function prt_expr_get_n_terms
 
 @ %def prt_expr_get_n_terms
 @ Transform one of the terms, as returned by the previous method, to an array
 of particle specifiers.  The array has more than one entry if the selected
 term is a list.  This makes sense only if the expression has been completely
 expanded, so the list contains only atoms.
 <<Particle specifiers: prt expr: TBP>>=
   procedure :: term_to_array => prt_expr_term_to_array
 <<Particle specifiers: procedures>>=
   recursive subroutine prt_expr_term_to_array (object, array, i)
     class(prt_expr_t), intent(in) :: object
     type(prt_spec_t), dimension(:), intent(inout), allocatable :: array
     integer, intent(in) :: i
     integer :: j
     if (allocated (array))  deallocate (array)
     select type (x => object%x)
     type is (prt_spec_t)
        allocate (array (1))
        array(1) = x
     type is (prt_spec_list_t)
        allocate (array (size (x%expr)))
        do j = 1, size (array)
           select type (y => x%expr(j)%x)
           type is (prt_spec_t)
              array(j) = y
           end select
        end do
     type is (prt_spec_sum_t)
        call x%expr(i)%term_to_array (array, 1)
     end select
   end subroutine prt_expr_term_to_array
 
 @ %def prt_expr_term_to_array
 @
 \subsection{The atomic type}
 The trivial case is a single particle, including optional decay and
 polarization attributes.
 
 \subsubsection{Definition}
 The particle is unstable if the [[decay]] array is allocated.  The
 [[polarized]] flag and decays may not be set simultaneously.
 <<Particle specifiers: public>>=
   public :: prt_spec_t
 <<Particle specifiers: types>>=
   type, extends (prt_spec_expr_t) :: prt_spec_t
      private
      type(string_t) :: name
      logical :: polarized = .false.
      type(string_t), dimension(:), allocatable :: decay
    contains
    <<Particle specifiers: prt spec: TBP>>
   end type prt_spec_t
 
 @ %def prt_spec_t
 @
 \subsubsection{I/O}
 Output.  Old-style subroutines.
 <<Particle specifiers: public>>=
   public :: prt_spec_write
 <<Particle specifiers: interfaces>>=
   interface prt_spec_write
      module procedure prt_spec_write1
      module procedure prt_spec_write2
   end interface prt_spec_write
 <<Particle specifiers: procedures>>=
   subroutine prt_spec_write1 (object, unit, advance)
     type(prt_spec_t), intent(in) :: object
     integer, intent(in), optional :: unit
     character(len=*), intent(in), optional :: advance
     character(3) :: adv
     integer :: u
     u = given_output_unit (unit)
     adv = "yes";  if (present (advance))  adv = advance
     write (u, "(A)", advance = adv)  char (object%to_string ())
   end subroutine prt_spec_write1
 
 @ %def prt_spec_write1
 @ Write an array as a list of particle specifiers.
 <<Particle specifiers: procedures>>=
   subroutine prt_spec_write2 (prt_spec, unit, advance)
     type(prt_spec_t), dimension(:), intent(in) :: prt_spec
     integer, intent(in), optional :: unit
     character(len=*), intent(in), optional :: advance
     character(3) :: adv
     integer :: u, i
     u = given_output_unit (unit)
     adv = "yes";  if (present (advance))  adv = advance
     do i = 1, size (prt_spec)
        if (i > 1)  write (u, "(A)", advance="no")  ", "
        call prt_spec_write (prt_spec(i), u, advance="no")
     end do
     write (u, "(A)", advance = adv)
   end subroutine prt_spec_write2
 
 @ %def prt_spec_write2
 @ Read.  Input may be string or array of strings.
 <<Particle specifiers: public>>=
   public :: prt_spec_read
 <<Particle specifiers: interfaces>>=
   interface prt_spec_read
      module procedure prt_spec_read1
      module procedure prt_spec_read2
   end interface prt_spec_read
 @ Read a single particle specifier
 <<Particle specifiers: procedures>>=
   pure subroutine prt_spec_read1 (prt_spec, string)
     type(prt_spec_t), intent(out) :: prt_spec
     type(string_t), intent(in) :: string
     type(string_t) :: arg, buffer
     integer :: b1, b2, c, n, i
     b1 = scan (string, "(")
     b2 = scan (string, ")")
     if (b1 == 0) then
        prt_spec%name = trim (adjustl (string))
     else
        prt_spec%name = trim (adjustl (extract (string, 1, b1-1)))
        arg = trim (adjustl (extract (string, b1+1, b2-1)))
        if (arg == "*") then
           prt_spec%polarized = .true.
        else
           n = 0
           buffer = arg
           do
              if (verify (buffer, " ") == 0)  exit
              n = n + 1
              c = scan (buffer, "+")
              if (c == 0)  exit
              buffer = extract (buffer, c+1)
           end do
           allocate (prt_spec%decay (n))
           buffer = arg
           do i = 1, n
              c = scan (buffer, "+")
              if (c == 0)  c = len (buffer) + 1
              prt_spec%decay(i) = trim (adjustl (extract (buffer, 1, c-1)))
              buffer = extract (buffer, c+1)
           end do
        end if
     end if
   end subroutine prt_spec_read1
 
 @ %def prt_spec_read1
 @ Read a particle specifier array, given as a single string.  The
 array is allocated to the correct size.
 <<Particle specifiers: procedures>>=
   pure subroutine prt_spec_read2 (prt_spec, string)
     type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec
     type(string_t), intent(in) :: string
     type(string_t) :: buffer
     integer :: c, i, n
     n = 0
     buffer = string
     do
        n = n + 1
        c = scan (buffer, ",")
        if (c == 0)  exit
        buffer = extract (buffer, c+1)
     end do
     allocate (prt_spec (n))
     buffer = string
     do i = 1, size (prt_spec)
        c = scan (buffer, ",")
        if (c == 0)  c = len (buffer) + 1
        call prt_spec_read (prt_spec(i), &
             trim (adjustl (extract (buffer, 1, c-1))))
        buffer = extract (buffer, c+1)
     end do
   end subroutine prt_spec_read2
 
 @ %def prt_spec_read2
 @
 \subsubsection{Constructor}
 Initialize a particle specifier.
 <<Particle specifiers: public>>=
   public :: new_prt_spec
 <<Particle specifiers: interfaces>>=
   interface new_prt_spec
      module procedure new_prt_spec
      module procedure new_prt_spec_polarized
      module procedure new_prt_spec_unstable
   end interface new_prt_spec
 <<Particle specifiers: procedures>>=
   elemental function new_prt_spec (name) result (prt_spec)
     type(string_t), intent(in) :: name
     type(prt_spec_t) :: prt_spec
     prt_spec%name = name
   end function new_prt_spec
 
   elemental function new_prt_spec_polarized (name, polarized) result (prt_spec)
     type(string_t), intent(in) :: name
     logical, intent(in) :: polarized
     type(prt_spec_t) :: prt_spec
     prt_spec%name = name
     prt_spec%polarized = polarized
   end function new_prt_spec_polarized
 
   pure function new_prt_spec_unstable (name, decay) result (prt_spec)
     type(string_t), intent(in) :: name
     type(string_t), dimension(:), intent(in) :: decay
     type(prt_spec_t) :: prt_spec
     prt_spec%name = name
     allocate (prt_spec%decay (size (decay)))
     prt_spec%decay = decay
   end function new_prt_spec_unstable
 
 @ %def new_prt_spec
 @
 \subsubsection{Access Methods}
 Return the particle name without qualifiers
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: get_name => prt_spec_get_name
 <<Particle specifiers: procedures>>=
   elemental function prt_spec_get_name (prt_spec) result (name)
     class(prt_spec_t), intent(in) :: prt_spec
     type(string_t) :: name
     name = prt_spec%name
   end function prt_spec_get_name
 
 @ %def prt_spec_get_name
 @ Return the name with qualifiers
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: to_string => prt_spec_to_string
 <<Particle specifiers: procedures>>=
   function prt_spec_to_string (object) result (string)
     class(prt_spec_t), intent(in) :: object
     type(string_t) :: string
     integer :: i
     string = object%name
     if (allocated (object%decay)) then
        string = string // "("
        do i = 1, size (object%decay)
           if (i > 1)  string = string // " + "
           string = string // object%decay(i)
        end do
        string = string // ")"
     else if (object%polarized) then
        string = string // "(*)"
     end if
   end function prt_spec_to_string
 
 @ %def prt_spec_to_string
 @ Return the polarization flag
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: is_polarized => prt_spec_is_polarized
 <<Particle specifiers: procedures>>=
   elemental function prt_spec_is_polarized (prt_spec) result (flag)
     class(prt_spec_t), intent(in) :: prt_spec
     logical :: flag
     flag = prt_spec%polarized
   end function prt_spec_is_polarized
 
 @ %def prt_spec_is_polarized
 @ The particle is unstable if there is a decay array.
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: is_unstable => prt_spec_is_unstable
 <<Particle specifiers: procedures>>=
   elemental function prt_spec_is_unstable (prt_spec) result (flag)
     class(prt_spec_t), intent(in) :: prt_spec
     logical :: flag
     flag = allocated (prt_spec%decay)
   end function prt_spec_is_unstable
 
 @ %def prt_spec_is_unstable
 @ Return the number of decay channels
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: get_n_decays => prt_spec_get_n_decays
 <<Particle specifiers: procedures>>=
   elemental function prt_spec_get_n_decays (prt_spec) result (n)
     class(prt_spec_t), intent(in) :: prt_spec
     integer :: n
     if (allocated (prt_spec%decay)) then
        n = size (prt_spec%decay)
     else
        n = 0
     end if
   end function prt_spec_get_n_decays
 
 @ %def prt_spec_get_n_decays
 @ Return the decay channels
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: get_decays => prt_spec_get_decays
 <<Particle specifiers: procedures>>=
   subroutine prt_spec_get_decays (prt_spec, decay)
     class(prt_spec_t), intent(in) :: prt_spec
     type(string_t), dimension(:), allocatable, intent(out) :: decay
     if (allocated (prt_spec%decay)) then
        allocate (decay (size (prt_spec%decay)))
        decay = prt_spec%decay
     else
        allocate (decay (0))
     end if
   end subroutine prt_spec_get_decays
 
 @ %def prt_spec_get_decays
 @
 \subsubsection{Miscellaneous}
 There is nothing to expand here:
 <<Particle specifiers: prt spec: TBP>>=
   procedure :: expand_sub => prt_spec_expand_sub
 <<Particle specifiers: procedures>>=
   subroutine prt_spec_expand_sub (object)
     class(prt_spec_t), intent(inout) :: object
   end subroutine prt_spec_expand_sub
 
 @ %def prt_spec_expand_sub
 @
 \subsection{List}
 A list of particle specifiers, indicating, e.g., the final state of a
 process.
 <<Particle specifiers: public>>=
   public :: prt_spec_list_t
 <<Particle specifiers: types>>=
   type, extends (prt_spec_expr_t) :: prt_spec_list_t
      type(prt_expr_t), dimension(:), allocatable :: expr
    contains
    <<Particle specifiers: prt spec list: TBP>>
   end type prt_spec_list_t
 
 @ %def prt_spec_list_t
 @ Output: Concatenate the components.  Insert brackets if the component is
 also a list.  The components of the [[expr]] array, if any, should all be
 filled.
 <<Particle specifiers: prt spec list: TBP>>=
   procedure :: to_string => prt_spec_list_to_string
 <<Particle specifiers: procedures>>=
   recursive function prt_spec_list_to_string (object) result (string)
     class(prt_spec_list_t), intent(in) :: object
     type(string_t) :: string
     integer :: i
     string = ""
     if (allocated (object%expr)) then
        do i = 1, size (object%expr)
           if (i > 1)  string = string // ", "
           select type (x => object%expr(i)%x)
           type is (prt_spec_list_t)
              string = string // "(" // x%to_string () // ")"
           class default
              string = string // x%to_string ()
           end select
        end do
     end if
   end function prt_spec_list_to_string
 
 @ %def prt_spec_list_to_string
 @ Flatten: if there is a subexpression which is also a list, include the
 components as direct members of the current list.
 <<Particle specifiers: prt spec list: TBP>>=
   procedure :: flatten => prt_spec_list_flatten
 <<Particle specifiers: procedures>>=
   subroutine prt_spec_list_flatten (object)
     class(prt_spec_list_t), intent(inout) :: object
     type(prt_expr_t), dimension(:), allocatable :: tmp_expr
     integer :: i, n_flat, i_flat
     n_flat = 0
     do i = 1, size (object%expr)
        select type (y => object%expr(i)%x)
        type is (prt_spec_list_t)
           n_flat = n_flat + size (y%expr)
        class default
           n_flat = n_flat + 1
        end select
     end do
     if (n_flat > size (object%expr)) then
        allocate (tmp_expr (n_flat))
        i_flat = 0
        do i = 1, size (object%expr)
           select type (y => object%expr(i)%x)
           type is (prt_spec_list_t)
              tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr
              i_flat = i_flat + size (y%expr)
           class default
              tmp_expr (i_flat + 1) = object%expr(i)
              i_flat = i_flat + 1
           end select
        end do
     end if
     if (allocated (tmp_expr)) &
          call move_alloc (from = tmp_expr, to = object%expr)
   end subroutine prt_spec_list_flatten
 
 @ %def prt_spec_list_flatten
 @ Convert a list of sums into a sum of lists.  (Subexpressions which are not
 sums are left untouched.)
 <<Particle specifiers: procedures>>=
   subroutine distribute_prt_spec_list (object)
     class(prt_spec_expr_t), intent(inout), allocatable :: object
     class(prt_spec_expr_t), allocatable :: new_object
     integer, dimension(:), allocatable :: n, ii
     integer :: k, n_expr, n_terms, i_term
     select type (object)
     type is (prt_spec_list_t)
        n_expr = size (object%expr)
        allocate (n (n_expr), source = 1)
        allocate (ii (n_expr), source = 1)
        do k = 1, size (object%expr)
           select type (y => object%expr(k)%x)
           type is (prt_spec_sum_t)
              n(k) = size (y%expr)
           end select
        end do
        n_terms = product (n)
        if (n_terms > 1) then
           allocate (prt_spec_sum_t :: new_object)
           select type (new_object)
           type is (prt_spec_sum_t)
              allocate (new_object%expr (n_terms))
              do i_term = 1, n_terms
                 allocate (prt_spec_list_t :: new_object%expr(i_term)%x)
                 select type (x => new_object%expr(i_term)%x)
                 type is (prt_spec_list_t)
                    allocate (x%expr (n_expr))
                    do k = 1, n_expr
                       select type (y => object%expr(k)%x)
                       type is (prt_spec_sum_t)
                          x%expr(k) = y%expr(ii(k))
                       class default
                          x%expr(k) = object%expr(k)
                       end select
                    end do
                 end select
                 INCR_INDEX: do k = n_expr, 1, -1
                    if (ii(k) < n(k)) then
                       ii(k) = ii(k) + 1
                       exit INCR_INDEX
                    else
                       ii(k) = 1
                    end if
                 end do INCR_INDEX
              end do
           end select
        end if
     end select
     if (allocated (new_object)) call move_alloc (from = new_object, to = object)
   end subroutine distribute_prt_spec_list
 
 @ %def distribute_prt_spec_list
 @ Apply [[expand]] to all components of the list.
 <<Particle specifiers: prt spec list: TBP>>=
   procedure :: expand_sub => prt_spec_list_expand_sub
 <<Particle specifiers: procedures>>=
   recursive subroutine prt_spec_list_expand_sub (object)
     class(prt_spec_list_t), intent(inout) :: object
     integer :: i
     if (allocated (object%expr)) then
        do i = 1, size (object%expr)
           call object%expr(i)%expand ()
        end do
     end if
   end subroutine prt_spec_list_expand_sub
 
 @ %def prt_spec_list_expand_sub
 @
 \subsection{Sum}
 A sum of particle specifiers, indicating, e.g., a sum of final states.
 <<Particle specifiers: public>>=
   public :: prt_spec_sum_t
 <<Particle specifiers: types>>=
   type, extends (prt_spec_expr_t) :: prt_spec_sum_t
      type(prt_expr_t), dimension(:), allocatable :: expr
    contains
    <<Particle specifiers: prt spec sum: TBP>>
   end type prt_spec_sum_t
 
 @ %def prt_spec_sum_t
 @ Output: Concatenate the components.  Insert brackets if the component is
 a list or also a sum.  The components of the [[expr]] array, if any, should
 all be filled.
 <<Particle specifiers: prt spec sum: TBP>>=
   procedure :: to_string => prt_spec_sum_to_string
 <<Particle specifiers: procedures>>=
   recursive function prt_spec_sum_to_string (object) result (string)
     class(prt_spec_sum_t), intent(in) :: object
     type(string_t) :: string
     integer :: i
     string = ""
     if (allocated (object%expr)) then
        do i = 1, size (object%expr)
           if (i > 1)  string = string // " + "
           select type (x => object%expr(i)%x)
           type is (prt_spec_list_t)
              string = string // "(" // x%to_string () // ")"
           type is (prt_spec_sum_t)
              string = string // "(" // x%to_string () // ")"
           class default
              string = string // x%to_string ()
           end select
        end do
     end if
   end function prt_spec_sum_to_string
 
 @ %def prt_spec_sum_to_string
 @ Flatten: if there is a subexpression which is also a sum, include the
 components as direct members of the current sum.
 
 This is identical to [[prt_spec_list_flatten]] above, except for the type.
 <<Particle specifiers: prt spec sum: TBP>>=
   procedure :: flatten => prt_spec_sum_flatten
 <<Particle specifiers: procedures>>=
   subroutine prt_spec_sum_flatten (object)
     class(prt_spec_sum_t), intent(inout) :: object
     type(prt_expr_t), dimension(:), allocatable :: tmp_expr
     integer :: i, n_flat, i_flat
     n_flat = 0
     do i = 1, size (object%expr)
        select type (y => object%expr(i)%x)
        type is (prt_spec_sum_t)
           n_flat = n_flat + size (y%expr)
           class default
           n_flat = n_flat + 1
        end select
     end do
     if (n_flat > size (object%expr)) then
        allocate (tmp_expr (n_flat))
        i_flat = 0
        do i = 1, size (object%expr)
           select type (y => object%expr(i)%x)
           type is (prt_spec_sum_t)
              tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr
              i_flat = i_flat + size (y%expr)
           class default
              tmp_expr (i_flat + 1) = object%expr(i)
              i_flat = i_flat + 1
           end select
        end do
     end if
     if (allocated (tmp_expr)) &
          call move_alloc (from = tmp_expr, to = object%expr)
   end subroutine prt_spec_sum_flatten
 
 @ %def prt_spec_sum_flatten
 @ Apply [[expand]] to all terms in the sum.
 <<Particle specifiers: prt spec sum: TBP>>=
   procedure :: expand_sub => prt_spec_sum_expand_sub
 <<Particle specifiers: procedures>>=
   recursive subroutine prt_spec_sum_expand_sub (object)
     class(prt_spec_sum_t), intent(inout) :: object
     integer :: i
     if (allocated (object%expr)) then
        do i = 1, size (object%expr)
           call object%expr(i)%expand ()
        end do
     end if
   end subroutine prt_spec_sum_expand_sub
 
 @ %def prt_spec_sum_expand_sub
 @
 \subsection{Expression Expansion}
 The [[expand]] method transforms each particle specifier expression into a sum
 of lists, according to the rules
 \begin{align}
   a, (b, c) &\to a, b, c
 \\
   a + (b + c) &\to a + b + c
 \\
   a, b + c &\to (a, b) + (a, c)
 \end{align}
 Note that the precedence of comma and plus are opposite to this expansion, so
 the parentheses in the final expression are necessary.
 
 We assume that subexpressions are filled, i.e., arrays are allocated.
 <<Particle specifiers: prt expr: TBP>>=
   procedure :: expand => prt_expr_expand
 <<Particle specifiers: procedures>>=
   recursive subroutine prt_expr_expand (expr)
     class(prt_expr_t), intent(inout) :: expr
     if (allocated (expr%x)) then
        call distribute_prt_spec_list (expr%x)
        call expr%x%expand_sub ()
        select type (x => expr%x)
        type is (prt_spec_list_t)
           call x%flatten ()
        type is (prt_spec_sum_t)
           call x%flatten ()
        end select
     end if
   end subroutine prt_expr_expand
 
 @ %def prt_expr_expand
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[particle_specifiers_ut.f90]]>>=
 <<File header>>
 
 module particle_specifiers_ut
   use unit_tests
   use particle_specifiers_uti
 
 <<Standard module head>>
 
 <<Particle specifiers: public test>>
 
 contains
 
 <<Particle specifiers: test driver>>
 
 end module particle_specifiers_ut
 @ %def particle_specifiers_ut
 @
 <<[[particle_specifiers_uti.f90]]>>=
 <<File header>>
 
 module particle_specifiers_uti
 
 <<Use strings>>
 
   use particle_specifiers
 
 <<Standard module head>>
 
 <<Particle specifiers: test declarations>>
 
 contains
 
 <<Particle specifiers: tests>>
 
 end module particle_specifiers_uti
 @ %def particle_specifiers_ut
 @ API: driver for the unit tests below.
 <<Particle specifiers: public test>>=
   public :: particle_specifiers_test
 <<Particle specifiers: test driver>>=
   subroutine particle_specifiers_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Particle specifiers: execute tests>>
   end subroutine particle_specifiers_test
 
 @ %def particle_specifiers_test
 @
 \subsubsection{Particle specifier array}
 Define, read and write an array of particle specifiers.
 <<Particle specifiers: execute tests>>=
   call test (particle_specifiers_1, "particle_specifiers_1", &
        "Handle particle specifiers", &
        u, results)
 <<Particle specifiers: test declarations>>=
   public :: particle_specifiers_1
 <<Particle specifiers: tests>>=
   subroutine particle_specifiers_1 (u)
     integer, intent(in) :: u
     type(prt_spec_t), dimension(:), allocatable :: prt_spec
     type(string_t), dimension(:), allocatable :: decay
     type(string_t), dimension(0) :: no_decay
     integer :: i, j
 
     write (u, "(A)")  "* Test output: particle_specifiers_1"
     write (u, "(A)")  "*   Purpose: Read and write a particle specifier array"
     write (u, "(A)")
 
     allocate (prt_spec (5))
     prt_spec = [ &
          new_prt_spec (var_str ("a")), &
          new_prt_spec (var_str ("b"), .true.), &
          new_prt_spec (var_str ("c"), [var_str ("dec1")]), &
          new_prt_spec (var_str ("d"), [var_str ("dec1"), var_str ("dec2")]), &
          new_prt_spec (var_str ("e"), no_decay) &
          ]
     do i = 1, size (prt_spec)
        write (u, "(A)")  char (prt_spec(i)%to_string ())
     end do
     write (u, "(A)")
 
     call prt_spec_read (prt_spec, &
          var_str (" a, b( *), c( dec1), d (dec1 + dec2 ), e()"))
     call prt_spec_write (prt_spec, u)
 
     do i = 1, size (prt_spec)
        write (u, "(A)")
        write (u, "(A,A)")  char (prt_spec(i)%get_name ()), ":"
        write (u, "(A,L1)")  "polarized = ", prt_spec(i)%is_polarized ()
        write (u, "(A,L1)")  "unstable  = ", prt_spec(i)%is_unstable ()
        write (u, "(A,I0)")  "n_decays  = ", prt_spec(i)%get_n_decays ()
        call prt_spec(i)%get_decays (decay)
        write (u, "(A)", advance="no") "decays    ="
        do j = 1, size (decay)
           write (u, "(1x,A)", advance="no") char (decay(j))
        end do
        write (u, "(A)")
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particle_specifiers_1"
   end subroutine particle_specifiers_1
 
 @ %def particle_specifiers_1
 @
 \subsubsection{Particle specifier expressions}
 Nested expressions (only basic particles, no decay specs).
 <<Particle specifiers: execute tests>>=
   call test (particle_specifiers_2, "particle_specifiers_2", &
        "Particle specifier expressions", &
        u, results)
 <<Particle specifiers: test declarations>>=
   public :: particle_specifiers_2
 <<Particle specifiers: tests>>=
   subroutine particle_specifiers_2 (u)
     integer, intent(in) :: u
     type(prt_spec_t) :: a, b, c, d, e, f
     type(prt_expr_t) :: pe1, pe2, pe3
     type(prt_expr_t) :: pe4, pe5, pe6, pe7, pe8, pe9
     integer :: i
     type(prt_spec_t), dimension(:), allocatable :: pa
 
     write (u, "(A)")  "* Test output: particle_specifiers_2"
     write (u, "(A)")  "*   Purpose: Create and display particle expressions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Basic expressions"
     write (u, *)
 
     a = new_prt_spec (var_str ("a"))
     b = new_prt_spec (var_str ("b"))
     c = new_prt_spec (var_str ("c"))
     d = new_prt_spec (var_str ("d"))
     e = new_prt_spec (var_str ("e"))
     f = new_prt_spec (var_str ("f"))
 
     call pe1%init_spec (a)
     write (u, "(A)")  char (pe1%to_string ())
 
     call pe2%init_sum (2)
     select type (x => pe2%x)
     type is (prt_spec_sum_t)
        call x%expr(1)%init_spec (a)
        call x%expr(2)%init_spec (b)
     end select
     write (u, "(A)")  char (pe2%to_string ())
 
     call pe3%init_list (2)
     select type (x => pe3%x)
     type is (prt_spec_list_t)
        call x%expr(1)%init_spec (a)
        call x%expr(2)%init_spec (b)
     end select
     write (u, "(A)")  char (pe3%to_string ())
 
     write (u, *)
     write (u, "(A)")  "* Nested expressions"
     write (u, *)
 
     call pe4%init_list (2)
     select type (x => pe4%x)
     type is (prt_spec_list_t)
        call x%expr(1)%init_sum (2)
        select type (y => x%expr(1)%x)
        type is (prt_spec_sum_t)
           call y%expr(1)%init_spec (a)
           call y%expr(2)%init_spec (b)
        end select
        call x%expr(2)%init_spec (c)
     end select
     write (u, "(A)")  char (pe4%to_string ())
 
     call pe5%init_list (2)
     select type (x => pe5%x)
     type is (prt_spec_list_t)
        call x%expr(1)%init_list (2)
        select type (y => x%expr(1)%x)
        type is (prt_spec_list_t)
           call y%expr(1)%init_spec (a)
           call y%expr(2)%init_spec (b)
        end select
        call x%expr(2)%init_spec (c)
     end select
     write (u, "(A)")  char (pe5%to_string ())
 
     call pe6%init_sum (2)
     select type (x => pe6%x)
     type is (prt_spec_sum_t)
        call x%expr(1)%init_spec (a)
        call x%expr(2)%init_sum (2)
        select type (y => x%expr(2)%x)
        type is (prt_spec_sum_t)
           call y%expr(1)%init_spec (b)
           call y%expr(2)%init_spec (c)
        end select
     end select
     write (u, "(A)")  char (pe6%to_string ())
 
     call pe7%init_list (2)
     select type (x => pe7%x)
     type is (prt_spec_list_t)
        call x%expr(1)%init_sum (2)
        select type (y => x%expr(1)%x)
        type is (prt_spec_sum_t)
           call y%expr(1)%init_spec (a)
           call y%expr(2)%init_list (2)
           select type (z => y%expr(2)%x)
           type is (prt_spec_list_t)
              call z%expr(1)%init_spec (b)
              call z%expr(2)%init_spec (c)
           end select
        end select
        call x%expr(2)%init_spec (d)
     end select
     write (u, "(A)")  char (pe7%to_string ())
 
     call pe8%init_sum (2)
     select type (x => pe8%x)
     type is (prt_spec_sum_t)
        call x%expr(1)%init_list (2)
        select type (y => x%expr(1)%x)
        type is (prt_spec_list_t)
           call y%expr(1)%init_spec (a)
           call y%expr(2)%init_spec (b)
        end select
        call x%expr(2)%init_list (2)
        select type (y => x%expr(2)%x)
        type is (prt_spec_list_t)
           call y%expr(1)%init_spec (c)
           call y%expr(2)%init_spec (d)
        end select
     end select
     write (u, "(A)")  char (pe8%to_string ())
 
     call pe9%init_list (3)
     select type (x => pe9%x)
     type is (prt_spec_list_t)
        call x%expr(1)%init_sum (2)
        select type (y => x%expr(1)%x)
        type is (prt_spec_sum_t)
           call y%expr(1)%init_spec (a)
           call y%expr(2)%init_spec (b)
        end select
        call x%expr(2)%init_spec (c)
        call x%expr(3)%init_sum (3)
        select type (y => x%expr(3)%x)
        type is (prt_spec_sum_t)
           call y%expr(1)%init_spec (d)
           call y%expr(2)%init_spec (e)
           call y%expr(3)%init_spec (f)
        end select
     end select
     write (u, "(A)")  char (pe9%to_string ())
 
     write (u, *)
     write (u, "(A)")  "* Expand as sum"
     write (u, *)
 
     call pe1%expand ()
     write (u, "(A)")  char (pe1%to_string ())
 
     call pe4%expand ()
     write (u, "(A)")  char (pe4%to_string ())
 
     call pe5%expand ()
     write (u, "(A)")  char (pe5%to_string ())
 
     call pe6%expand ()
     write (u, "(A)")  char (pe6%to_string ())
 
     call pe7%expand ()
     write (u, "(A)")  char (pe7%to_string ())
 
     call pe8%expand ()
     write (u, "(A)")  char (pe8%to_string ())
 
     call pe9%expand ()
     write (u, "(A)")  char (pe9%to_string ())
 
     write (u, *)
     write (u, "(A)")  "* Transform to arrays:"
 
     write (u, "(A)")  "* Atomic specifier"
     do i = 1, pe1%get_n_terms ()
        call pe1%term_to_array (pa, i)
        call prt_spec_write (pa, u)
     end do
 
     write (u, *)
     write (u, "(A)")  "* List"
     do i = 1, pe5%get_n_terms ()
        call pe5%term_to_array (pa, i)
        call prt_spec_write (pa, u)
     end do
 
     write (u, *)
     write (u, "(A)")  "* Sum of atoms"
     do i = 1, pe6%get_n_terms ()
        call pe6%term_to_array (pa, i)
        call prt_spec_write (pa, u)
     end do
 
     write (u, *)
     write (u, "(A)")  "* Sum of lists"
     do i = 1, pe9%get_n_terms ()
        call pe9%term_to_array (pa, i)
        call prt_spec_write (pa, u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particle_specifiers_2"
   end subroutine particle_specifiers_2
 
 @ %def particle_specifiers_2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{PDG arrays}
 
 For defining aliases, we introduce a special type which holds a set of
 (integer) PDG codes.
 <<[[pdg_arrays.f90]]>>=
 <<File header>>
 
 module pdg_arrays
 
   use io_units
   use sorting
   use physics_defs, only: UNDEFINED
 
 <<Standard module head>>
 
 <<PDG arrays: public>>
 
 <<PDG arrays: types>>
 
 <<PDG arrays: interfaces>>
 
 contains
 
 <<PDG arrays: procedures>>
 
 end module pdg_arrays
 @ %def pdg_arrays
 @
 \subsection{Type definition}
 Using an allocatable array eliminates the need for initializer and/or
 finalizer.
 <<PDG arrays: public>>=
   public :: pdg_array_t
 <<PDG arrays: types>>=
   type :: pdg_array_t
      private
      integer, dimension(:), allocatable :: pdg
    contains
    <<PDG arrays: pdg array: TBP>>
   end type pdg_array_t
 
 @ %def pdg_array_t
 @ Output
 <<PDG arrays: public>>=
   public :: pdg_array_write
 <<PDG arrays: pdg array: TBP>>=
   procedure :: write => pdg_array_write
 <<PDG arrays: procedures>>=
   subroutine pdg_array_write (aval, unit)
     class(pdg_array_t), intent(in) :: aval
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A)", advance="no")  "PDG("
     if (allocated (aval%pdg)) then
        do i = 1, size (aval%pdg)
           if (i > 1)  write (u, "(A)", advance="no")  ", "
           write (u, "(I0)", advance="no")  aval%pdg(i)
        end do
     end if
     write (u, "(A)", advance="no")  ")"
   end subroutine pdg_array_write
 
 @ %def pdg_array_write
 @
 <<PDG arrays: public>>=
   public :: pdg_array_write_set
 <<PDG arrays: procedures>>=
   subroutine pdg_array_write_set (aval, unit)
     type(pdg_array_t), intent(in), dimension(:) :: aval
     integer, intent(in), optional :: unit
     integer :: i
     do i = 1, size (aval)
        call aval(i)%write (unit)
        print *, ''
     end do
   end subroutine pdg_array_write_set
 
 @ %def pdg_array_write_set
 @
 \subsection{Basic operations}
 Assignment.  We define assignment from and to an integer array.
 Note that the integer array, if it is the l.h.s., must be declared
 allocatable by the caller.
 <<PDG arrays: public>>=
   public :: assignment(=)
 <<PDG arrays: interfaces>>=
   interface assignment(=)
      module procedure pdg_array_from_int_array
      module procedure pdg_array_from_int
      module procedure int_array_from_pdg_array
   end interface
 
 <<PDG arrays: procedures>>=
   subroutine pdg_array_from_int_array (aval, iarray)
     type(pdg_array_t), intent(out) :: aval
     integer, dimension(:), intent(in) :: iarray
     allocate (aval%pdg (size (iarray)))
     aval%pdg = iarray
   end subroutine pdg_array_from_int_array
 
   elemental subroutine pdg_array_from_int (aval, int)
     type(pdg_array_t), intent(out) :: aval
     integer, intent(in) :: int
     allocate (aval%pdg (1))
     aval%pdg = int
   end subroutine pdg_array_from_int
 
   subroutine int_array_from_pdg_array (iarray, aval)
     integer, dimension(:), allocatable, intent(out) :: iarray
     type(pdg_array_t), intent(in) :: aval
     if (allocated (aval%pdg)) then
        allocate (iarray (size (aval%pdg)))
        iarray = aval%pdg
     else
        allocate (iarray (0))
     end if
   end subroutine int_array_from_pdg_array
   
 @ %def pdg_array_from_int_array pdg_array_from_int int_array_from_pdg_array 
 @ Allocate space for a PDG array
 <<PDG arrays: public>>=
   public :: pdg_array_init
 <<PDG arrays: procedures>>=
   subroutine pdg_array_init (aval, n_elements)
     type(pdg_array_t), intent(inout) :: aval
     integer, intent(in) :: n_elements
     allocate(aval%pdg(n_elements))
   end subroutine pdg_array_init
 
 @ %def pdg_array_init
 @ Deallocate a previously allocated pdg array
 <<PDG arrays: public>>=
   public :: pdg_array_delete
 <<PDG arrays: procedures>>=
   subroutine pdg_array_delete (aval)
     type(pdg_array_t), intent(inout) :: aval
     if (allocated (aval%pdg)) deallocate (aval%pdg)
   end subroutine pdg_array_delete
 
 @ %def pdg_array_delete
 @ Merge two pdg arrays, i.e. append a particle string to another leaving out doublettes
 <<PDG arrays: public>>=
   public :: pdg_array_merge
 <<PDG arrays: procedures>>=
   subroutine pdg_array_merge (aval1, aval2)
     type(pdg_array_t), intent(inout) :: aval1
     type(pdg_array_t), intent(in) :: aval2
     type(pdg_array_t) :: aval
     if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
       if (.not. any (aval1%pdg == aval2%pdg)) aval = aval1 // aval2
     else if (allocated (aval1%pdg)) then
       aval = aval1
     else if (allocated (aval2%pdg)) then
       aval = aval2
     end if
     call pdg_array_delete (aval1)
     aval1 = aval%pdg
   end subroutine pdg_array_merge
 
 @ %def pdg_array_merge
 @ Length of the array.
 <<PDG arrays: public>>=
   public :: pdg_array_get_length
 <<PDG arrays: pdg array: TBP>>=
   procedure :: get_length => pdg_array_get_length
 <<PDG arrays: procedures>>=
   elemental function pdg_array_get_length (aval) result (n)
     class(pdg_array_t), intent(in) :: aval
     integer :: n
     if (allocated (aval%pdg)) then
        n = size (aval%pdg)
     else
        n = 0
     end if
   end function pdg_array_get_length
 
 @ %def pdg_array_get_length
 @ Return the element with index i.
 <<PDG arrays: public>>=
   public :: pdg_array_get
 <<PDG arrays: pdg array: TBP>>=
   procedure :: get => pdg_array_get
 <<PDG arrays: procedures>>=
   elemental function pdg_array_get (aval, i) result (pdg)
     class(pdg_array_t), intent(in) :: aval
     integer, intent(in), optional :: i
     integer :: pdg
     if (present (i)) then
        pdg = aval%pdg(i)
     else
        pdg = aval%pdg(1)
     end if
   end function pdg_array_get
 
 @ %def pdg_array_get
 @ Explicitly set the element with index i.
 <<PDG arrays: pdg array: TBP>>=
   procedure :: set => pdg_array_set
 <<PDG arrays: procedures>>=
   subroutine pdg_array_set (aval, i, pdg)
     class(pdg_array_t), intent(inout) :: aval
     integer, intent(in) :: i
     integer, intent(in) :: pdg
     aval%pdg(i) = pdg
   end subroutine pdg_array_set
 
 @ %def pdg_array_set
 @
 <<PDG arrays: pdg array: TBP>>=
   procedure :: add => pdg_array_add
 <<PDG arrays: procedures>>=
   function pdg_array_add (aval, aval_add) result (aval_out)
     type(pdg_array_t) :: aval_out
     class(pdg_array_t), intent(in) :: aval
     type(pdg_array_t), intent(in) :: aval_add
     integer :: n, n_add, i
     n = size (aval%pdg)
     n_add = size (aval_add%pdg)
     allocate (aval_out%pdg (n + n_add))
     aval_out%pdg(1:n) = aval%pdg
     do i = 1, n_add
        aval_out%pdg(n+i) = aval_add%pdg(i)
     end do
   end function pdg_array_add
 
 @ %def pdg_array_add
 @ Replace element with index [[i]] by a new array of elements.
 <<PDG arrays: public>>=
   public :: pdg_array_replace
 <<PDG arrays: pdg array: TBP>>=
   procedure :: replace => pdg_array_replace
 <<PDG arrays: procedures>>=
   function pdg_array_replace (aval, i, pdg_new) result (aval_new)
     class(pdg_array_t), intent(in) :: aval
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: pdg_new
     type(pdg_array_t) :: aval_new
     integer :: n, l
     n = size (aval%pdg)
     l = size (pdg_new)
     allocate (aval_new%pdg (n + l - 1))
     aval_new%pdg(:i-1) = aval%pdg(:i-1)
     aval_new%pdg(i:i+l-1) = pdg_new
     aval_new%pdg(i+l:) = aval%pdg(i+1:)
   end function pdg_array_replace
 
 @ %def pdg_array_replace
 @ Concatenate two PDG arrays
 <<PDG arrays: public>>=
   public :: operator(//)
 <<PDG arrays: interfaces>>=
   interface operator(//)
      module procedure concat_pdg_arrays
   end interface
 
 <<PDG arrays: procedures>>=
   function concat_pdg_arrays (aval1, aval2) result (aval)
     type(pdg_array_t) :: aval
     type(pdg_array_t), intent(in) :: aval1, aval2
     integer :: n1, n2
     if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
        n1 = size (aval1%pdg)
        n2 = size (aval2%pdg)
        allocate (aval%pdg (n1 + n2))
        aval%pdg(:n1) = aval1%pdg
        aval%pdg(n1+1:) = aval2%pdg
     else if (allocated (aval1%pdg)) then
        aval = aval1
     else if (allocated (aval2%pdg)) then
        aval = aval2
     end if
   end function concat_pdg_arrays
 
 @ %def concat_pdg_arrays
 @
 \subsection{Matching}
 A PDG array matches a given PDG code if the code is present within the
 array.  If either one is zero (UNDEFINED), the match also succeeds.
 <<PDG arrays: public>>=
   public :: operator(.match.)
 <<PDG arrays: interfaces>>=
   interface operator(.match.)
      module procedure pdg_array_match_integer
      module procedure pdg_array_match_pdg_array
   end interface
 
 @ %def .match.
 @ Match a single code against the array.
 <<PDG arrays: procedures>>=
   elemental function pdg_array_match_integer (aval, pdg) result (flag)
     logical :: flag
     type(pdg_array_t), intent(in) :: aval
     integer, intent(in) :: pdg
     if (allocated (aval%pdg)) then
        flag = pdg == UNDEFINED &
             .or. any (aval%pdg == UNDEFINED) &
             .or. any (aval%pdg == pdg)
     else
        flag = .false.
     end if
   end function pdg_array_match_integer
 
 @ %def pdg_array_match_integer
 @ Check if the pdg-number corresponds to a quark
 <<PDG arrays: public>>=
   public :: is_quark
 <<PDG arrays: procedures>>=
   elemental function is_quark (pdg_nr)
     logical :: is_quark
     integer, intent(in) :: pdg_nr
     if (abs (pdg_nr) >= 1 .and. abs (pdg_nr) <= 6) then
        is_quark = .true.
     else
        is_quark = .false.
     end if
   end function is_quark
 
 @ %def is_quark
 @ Check if pdg-number corresponds to a gluon
 <<PDG arrays: public>>=
   public :: is_gluon
 <<PDG arrays: procedures>>=
   elemental function is_gluon (pdg_nr)
     logical :: is_gluon
     integer, intent(in) :: pdg_nr
     if (pdg_nr == 21) then
        is_gluon = .true.
     else
        is_gluon = .false.
     end if
   end function is_gluon
 
 @ %def is_gluon
 @ Check if pdg-number corresponds to a photon
 <<PDG arrays: public>>=
   public :: is_photon
 <<PDG arrays: procedures>>=
   elemental function is_photon (pdg_nr)
     logical :: is_photon
     integer, intent(in) :: pdg_nr
     if (pdg_nr == 22) then
        is_photon = .true.
     else
        is_photon = .false.
     end if
   end function is_photon
 
 @ %def is_photon
 @ Check if pdg-number corresponds to a colored particle
 <<PDG arrays: public>>=
   public :: is_colored
 <<PDG arrays: procedures>>=
   elemental function is_colored (pdg_nr)
     logical :: is_colored
     integer, intent(in) :: pdg_nr
     is_colored = is_quark (pdg_nr) .or. is_gluon (pdg_nr)
   end function is_colored
 
 @ %def is_colored
 @ Check if the pdg-number corresponds to a lepton
 <<PDG arrays: public>>=
   public :: is_lepton
 <<PDG arrays: procedures>>=
   elemental function is_lepton (pdg_nr)
     logical :: is_lepton
     integer, intent(in) :: pdg_nr
     if (abs (pdg_nr) >= 11 .and. abs (pdg_nr) <= 16) then
       is_lepton = .true.
     else
       is_lepton = .false.
     end if
   end function is_lepton
 
 @ %def is_lepton
 @
 <<PDG arrays: public>>=
   public :: is_fermion
 <<PDG arrays: procedures>>=
   elemental function is_fermion (pdg_nr)
     logical :: is_fermion
     integer, intent(in) :: pdg_nr
     is_fermion = is_lepton(pdg_nr) .or. is_quark(pdg_nr)
   end function is_fermion
 
 @ %def is_fermion
 @ Check if the pdg-number corresponds to a massless vector boson
 <<PDG arrays: public>>=
   public :: is_massless_vector
 <<PDG arrays: procedures>>=
   elemental function is_massless_vector (pdg_nr)
     integer, intent(in) :: pdg_nr
     logical :: is_massless_vector
     if (pdg_nr == 21 .or. pdg_nr == 22) then
       is_massless_vector = .true.
     else
       is_massless_vector = .false.
     end if
   end function is_massless_vector
 
 @ %def is_massless_vector
 @ Check if pdg-number corresponds to a massive vector boson
 <<PDG arrays: public>>=
   public :: is_massive_vector
 <<PDG arrays: procedures>>=
   elemental function is_massive_vector (pdg_nr)
     integer, intent(in) :: pdg_nr
     logical :: is_massive_vector
     if (abs (pdg_nr) == 23 .or. abs (pdg_nr) == 24) then
       is_massive_vector = .true.
     else
       is_massive_vector = .false.
     end if
   end function is_massive_vector
 
 @ %def is massive_vector
 @ Check if pdg-number corresponds to a vector boson
 <<PDG arrays: public>>=
   public :: is_vector
 <<PDG arrays: procedures>>=
   elemental function is_vector (pdg_nr)
     integer, intent(in) :: pdg_nr
     logical :: is_vector
     if (is_massless_vector (pdg_nr) .or. is_massive_vector (pdg_nr)) then
       is_vector = .true.
     else
       is_vector = .false.
     end if
   end function is_vector
 
 @ %def is vector
 @ Check if particle is elementary.
 <<PDG arrays: public>>=
   public :: is_elementary
 <<PDG arrays: procedures>>=
   elemental function is_elementary (pdg_nr)
     integer, intent(in) :: pdg_nr
     logical :: is_elementary
     if (is_vector (pdg_nr) .or. is_fermion (pdg_nr) .or. pdg_nr == 25) then
        is_elementary = .true.
     else
        is_elementary = .false.
     end if
   end function is_elementary
 
 @ %def is_elementary
 @ Check if particle is strongly interacting
 <<PDG arrays: pdg array: TBP>>=
   procedure :: has_colored_particles => pdg_array_has_colored_particles
 <<PDG arrays: procedures>>=
   function pdg_array_has_colored_particles (pdg) result (colored)
     class(pdg_array_t), intent(in) :: pdg
     logical :: colored
     integer :: i, pdg_nr
     colored = .false.
     do i = 1, size (pdg%pdg)
       pdg_nr = pdg%pdg(i)
       if (is_quark (pdg_nr) .or. is_gluon (pdg_nr)) then
          colored = .true.
          exit
       end if
     end do
   end function pdg_array_has_colored_particles
 
 @ %def pdg_array_has_colored_particles
 @ Match two arrays.  Succeeds if any pair of entries matches.
 <<PDG arrays: procedures>>=
   function pdg_array_match_pdg_array (aval1, aval2) result (flag)
     logical :: flag
     type(pdg_array_t), intent(in) :: aval1, aval2
     if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
        flag = any (aval1 .match. aval2%pdg)
     else
        flag = .false.
     end if
   end function pdg_array_match_pdg_array
 
 @ %def pdg_array_match_pdg_array
 @ Comparison.  Here, we take the PDG arrays as-is, assuming that they
 are sorted.
 
 The ordering is a bit odd: first, we look only at the absolute values
 of the PDG codes.  If they all match, the particle comes before the
 antiparticle, scanning from left to right.
 <<PDG arrays: public>>=
   public :: operator(<)
   public :: operator(>)
   public :: operator(<=)
   public :: operator(>=)
   public :: operator(==)
   public :: operator(/=)
 <<PDG arrays: interfaces>>=
   interface operator(<)
      module procedure pdg_array_lt
   end interface
   interface operator(>)
      module procedure pdg_array_gt
   end interface
   interface operator(<=)
      module procedure pdg_array_le
   end interface
   interface operator(>=)
      module procedure pdg_array_ge
   end interface
   interface operator(==)
      module procedure pdg_array_eq
   end interface
   interface operator(/=)
      module procedure pdg_array_ne
   end interface
 
 <<PDG arrays: procedures>>=
   elemental function pdg_array_lt (aval1, aval2) result (flag)
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical :: flag
     integer :: i
     if (size (aval1%pdg) /= size (aval2%pdg)) then
        flag = size (aval1%pdg) < size (aval2%pdg)
     else
        do i = 1, size (aval1%pdg)
           if (abs (aval1%pdg(i)) /= abs (aval2%pdg(i))) then
              flag = abs (aval1%pdg(i)) < abs (aval2%pdg(i))
              return
           end if
        end do
        do i = 1, size (aval1%pdg)
           if (aval1%pdg(i) /= aval2%pdg(i)) then
              flag = aval1%pdg(i) > aval2%pdg(i)
              return
           end if
        end do
        flag = .false.
     end if
   end function pdg_array_lt
 
   elemental function pdg_array_gt (aval1, aval2) result (flag)
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical :: flag
     flag = .not. (aval1 < aval2 .or. aval1 == aval2)
   end function pdg_array_gt
 
   elemental function pdg_array_le (aval1, aval2) result (flag)
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical :: flag
     flag = aval1 < aval2 .or. aval1 == aval2
   end function pdg_array_le
 
   elemental function pdg_array_ge (aval1, aval2) result (flag)
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical :: flag
     flag = .not. (aval1 < aval2)
   end function pdg_array_ge
 
   elemental function pdg_array_eq (aval1, aval2) result (flag)
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical :: flag
     if (size (aval1%pdg) /= size (aval2%pdg)) then
        flag = .false.
     else
        flag = all (aval1%pdg == aval2%pdg)
     end if
   end function pdg_array_eq
 
   elemental function pdg_array_ne (aval1, aval2) result (flag)
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical :: flag
     flag = .not. (aval1 == aval2)
   end function pdg_array_ne
 
 @ Equivalence.  Two PDG arrays are equivalent if either one contains
 [[UNDEFINED]] or if each element of array 1 is present in array 2, and
 vice versa.
 <<PDG arrays: public>>=
   public :: operator(.eqv.)
   public :: operator(.neqv.)
 <<PDG arrays: interfaces>>=
   interface operator(.eqv.)
      module procedure pdg_array_equivalent
   end interface
   interface operator(.neqv.)
      module procedure pdg_array_inequivalent
   end interface
 
 <<PDG arrays: procedures>>=
   elemental function pdg_array_equivalent (aval1, aval2) result (eq)
     logical :: eq
     type(pdg_array_t), intent(in) :: aval1, aval2
     logical, dimension(:), allocatable :: match1, match2
     integer :: i
     if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
        eq = any (aval1%pdg == UNDEFINED) &
             .or. any (aval2%pdg == UNDEFINED)
        if (.not. eq) then
           allocate (match1 (size (aval1%pdg)))
           allocate (match2 (size (aval2%pdg)))
           match1 = .false.
           match2 = .false.
           do i = 1, size (aval1%pdg)
              match2 = match2 .or. aval1%pdg(i) == aval2%pdg
           end do
           do i = 1, size (aval2%pdg)
              match1 = match1 .or. aval2%pdg(i) == aval1%pdg
           end do
           eq = all (match1) .and. all (match2)
        end if
     else
        eq = .false.
     end if
   end function pdg_array_equivalent
 
   elemental function pdg_array_inequivalent (aval1, aval2) result (neq)
     logical :: neq
     type(pdg_array_t), intent(in) :: aval1, aval2
     neq = .not. pdg_array_equivalent (aval1, aval2)
   end function pdg_array_inequivalent
 
 @ %def pdg_array_equivalent
 @
 \subsection{Sorting}
 Sort a PDG array by absolute value, particle before antiparticle.  After
 sorting, we eliminate double entries.
 <<PDG arrays: public>>=
   public :: sort_abs
 <<PDG arrays: interfaces>>=
   interface sort_abs
      module procedure pdg_array_sort_abs
   end interface
 
 <<PDG arrays: pdg array: TBP>>=
   procedure :: sort_abs => pdg_array_sort_abs
 <<PDG arrays: procedures>>=
   function pdg_array_sort_abs (aval1, unique) result (aval2)
     class(pdg_array_t), intent(in) :: aval1
     logical, intent(in), optional :: unique
     type(pdg_array_t) :: aval2
     integer, dimension(:), allocatable :: tmp
     logical, dimension(:), allocatable :: mask
     integer :: i, n
     logical :: uni
     uni = .false.;  if (present (unique))  uni = unique
     n = size (aval1%pdg)
     if (uni) then
        allocate (tmp (n), mask(n))
        tmp = sort_abs (aval1%pdg)
        mask(1) = .true.
        do i = 2, n
           mask(i) = tmp(i) /= tmp(i-1)
        end do
        allocate (aval2%pdg (count (mask)))
        aval2%pdg = pack (tmp, mask)
     else
        allocate (aval2%pdg (n))
        aval2%pdg = sort_abs (aval1%pdg)
     end if
   end function pdg_array_sort_abs
 
 @ %def sort_abs
 @
 <<PDG arrays: pdg array: TBP>>=
   procedure :: intersect => pdg_array_intersect
 <<PDG arrays: procedures>>=
   function pdg_array_intersect (aval1, match) result (aval2)
    class(pdg_array_t), intent(in) :: aval1
    integer, dimension(:) :: match
    type(pdg_array_t) :: aval2
    integer, dimension(:), allocatable :: isec
    integer :: i
    isec = pack (aval1%pdg, [(any(aval1%pdg(i) == match), i=1,size(aval1%pdg))])
    aval2 = isec
   end function pdg_array_intersect
 
 @ %def pdg_array_intersect
 @
 <<PDG arrays: pdg array: TBP>>=
   procedure :: search_for_particle => pdg_array_search_for_particle
 <<PDG arrays: procedures>>=
   elemental function pdg_array_search_for_particle (pdg, i_part) result (found)
     class(pdg_array_t), intent(in) :: pdg
     integer, intent(in) :: i_part
     logical :: found
     found = any (pdg%pdg == i_part)
   end function pdg_array_search_for_particle
 
 @ %def pdg_array_search_for_particle
 @
 <<PDG arrays: pdg array: TBP>>=
   procedure :: invert => pdg_array_invert
 <<PDG arrays: procedures>>=
   function pdg_array_invert (pdg) result (pdg_inverse)
     class(pdg_array_t), intent(in) :: pdg
     type(pdg_array_t) :: pdg_inverse
     integer :: i, n
     n = size (pdg%pdg)
     allocate (pdg_inverse%pdg (n))
     do i = 1, n
        select case (pdg%pdg(i))
        case (21, 22, 23, 25)
           pdg_inverse%pdg(i) = pdg%pdg(i)
        case default
           pdg_inverse%pdg(i) = -pdg%pdg(i)
        end select
     end do
   end function pdg_array_invert
 
 @ %def pdg_array_invert
 @
 \subsection{PDG array list}
 A PDG array list, or PDG list, is an array of PDG-array objects with
 some convenience methods.
 <<PDG arrays: public>>=
   public :: pdg_list_t
 <<PDG arrays: types>>=
   type :: pdg_list_t
      type(pdg_array_t), dimension(:), allocatable :: a
    contains
    <<PDG arrays: pdg list: TBP>>
   end type pdg_list_t
 
 @ %def pdg_list_t
 @ Output, as a comma-separated list without advancing I/O.
 <<PDG arrays: pdg list: TBP>>=
   procedure :: write => pdg_list_write
 <<PDG arrays: procedures>>=
   subroutine pdg_list_write (object, unit)
     class(pdg_list_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     if (allocated (object%a)) then
        do i = 1, size (object%a)
           if (i > 1)  write (u, "(A)", advance="no")  ", "
           call object%a(i)%write (u)
        end do
     end if
   end subroutine pdg_list_write
 
 @ %def pdg_list_write
 @ Initialize for a certain size.  The entries are initially empty PDG arrays.
 <<PDG arrays: pdg list: TBP>>=
   generic :: init => pdg_list_init_size
   procedure, private :: pdg_list_init_size
 <<PDG arrays: procedures>>=
   subroutine pdg_list_init_size (pl, n)
     class(pdg_list_t), intent(out) :: pl
     integer, intent(in) :: n
     allocate (pl%a (n))
   end subroutine pdg_list_init_size
 
 @ %def pdg_list_init_size
 @ Initialize with a definite array of PDG codes.  That is, each entry
 in the list becomes a single-particle PDG array.
 <<PDG arrays: pdg list: TBP>>=
   generic :: init => pdg_list_init_int_array
   procedure, private :: pdg_list_init_int_array
 <<PDG arrays: procedures>>=
   subroutine pdg_list_init_int_array (pl, pdg)
     class(pdg_list_t), intent(out) :: pl
     integer, dimension(:), intent(in) :: pdg
     integer :: i
     allocate (pl%a (size (pdg)))
     do i = 1, size (pdg)
        pl%a(i) = pdg(i)
     end do
   end subroutine pdg_list_init_int_array
 
 @ %def pdg_list_init_array
 @ Set one of the entries.  No bounds-check.
 <<PDG arrays: pdg list: TBP>>=
   generic :: set => pdg_list_set_int
   generic :: set => pdg_list_set_int_array
   generic :: set => pdg_list_set_pdg_array
   procedure, private :: pdg_list_set_int
   procedure, private :: pdg_list_set_int_array
   procedure, private :: pdg_list_set_pdg_array
 <<PDG arrays: procedures>>=
   subroutine pdg_list_set_int (pl, i, pdg)
     class(pdg_list_t), intent(inout) :: pl
     integer, intent(in) :: i
     integer, intent(in) :: pdg
     pl%a(i) = pdg
   end subroutine pdg_list_set_int
 
   subroutine pdg_list_set_int_array (pl, i, pdg)
     class(pdg_list_t), intent(inout) :: pl
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: pdg
     pl%a(i) = pdg
   end subroutine pdg_list_set_int_array
 
   subroutine pdg_list_set_pdg_array (pl, i, pa)
     class(pdg_list_t), intent(inout) :: pl
     integer, intent(in) :: i
     type(pdg_array_t), intent(in) :: pa
     pl%a(i) = pa
   end subroutine pdg_list_set_pdg_array
 
 @ %def pdg_list_set
 @ Array size, not the length of individual entries
 <<PDG arrays: pdg list: TBP>>=
   procedure :: get_size => pdg_list_get_size
 <<PDG arrays: procedures>>=
   function pdg_list_get_size (pl) result (n)
     class(pdg_list_t), intent(in) :: pl
     integer :: n
     if (allocated (pl%a)) then
        n = size (pl%a)
     else
        n = 0
     end if
   end function pdg_list_get_size
 
 @ %def pdg_list_get_size
 @ Return an entry, as a PDG array.
 <<PDG arrays: pdg list: TBP>>=
   procedure :: get => pdg_list_get
 <<PDG arrays: procedures>>=
   function pdg_list_get (pl, i) result (pa)
     type(pdg_array_t) :: pa
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: i
     pa = pl%a(i)
   end function pdg_list_get
 
 @ %def pdg_list_get
 @ Check if the list entries are all either mutually disjoint or identical.
 The individual entries (PDG arrays) should already be sorted, so we can test
 for equality.
 <<PDG arrays: pdg list: TBP>>=
   procedure :: is_regular => pdg_list_is_regular
 <<PDG arrays: procedures>>=
   function pdg_list_is_regular (pl) result (flag)
     class(pdg_list_t), intent(in) :: pl
     logical :: flag
     integer :: i, j, s
     s = pl%get_size ()
     flag = .true.
     do i = 1, s
        do j = i + 1, s
           if (pl%a(i) .match. pl%a(j)) then
              if (pl%a(i) /= pl%a(j)) then
                 flag = .false.
                 return
              end if
           end if
        end do
     end do
   end function pdg_list_is_regular
 
 @ %def pdg_list_is_regular
 @ Sort the list.  First, each entry gets sorted, including elimination
 of doublers.  Then, we sort the list, using the first member of each
 PDG array as the marker.  No removal of doublers at this stage.
 
 If [[n_in]] is supplied, we do not reorder the first [[n_in]] particle
 entries.
 <<PDG arrays: pdg list: TBP>>=
   procedure :: sort_abs => pdg_list_sort_abs
 <<PDG arrays: procedures>>=
   function pdg_list_sort_abs (pl, n_in) result (pl_sorted)
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in), optional :: n_in
     type(pdg_list_t) :: pl_sorted
     type(pdg_array_t), dimension(:), allocatable :: pa
     integer, dimension(:), allocatable :: pdg, map
     integer :: i, n0
     call pl_sorted%init (pl%get_size ())
     if (allocated (pl%a)) then
        allocate (pa (size (pl%a)))
        do i = 1, size (pl%a)
           pa(i) = pl%a(i)%sort_abs (unique = .true.)
        end do
        allocate (pdg (size (pa)), source = 0)
        do i = 1, size (pa)
           if (allocated (pa(i)%pdg)) then
              if (size (pa(i)%pdg) > 0) then
                 pdg(i) = pa(i)%pdg(1)
              end if
           end if
        end do
        if (present (n_in)) then
           n0 = n_in
        else
           n0 = 0
        end if
        allocate (map (size (pdg)))
        map(:n0) = [(i, i = 1, n0)]
        map(n0+1:) = n0 + order_abs (pdg(n0+1:))
        do i = 1, size (pa)
           call pl_sorted%set (i, pa(map(i)))
        end do
     end if
   end function pdg_list_sort_abs
 
 @ %def pdg_list_sort_abs
 @ Compare sorted lists: equality.  The result is undefined if some entries
 are not allocated.
 <<PDG arrays: pdg list: TBP>>=
   generic :: operator (==) => pdg_list_eq
   procedure, private :: pdg_list_eq
 <<PDG arrays: procedures>>=
   function pdg_list_eq (pl1, pl2) result (flag)
     class(pdg_list_t), intent(in) :: pl1, pl2
     logical :: flag
     integer :: i
     flag = .false.
     if (allocated (pl1%a) .and. allocated (pl2%a)) then
        if (size (pl1%a) == size (pl2%a)) then
           do i = 1, size (pl1%a)
              associate (a1 => pl1%a(i), a2 => pl2%a(i))
                if (allocated (a1%pdg) .and. allocated (a2%pdg)) then
                   if (size (a1%pdg) == size (a2%pdg)) then
                      if (size (a1%pdg) > 0) then
                         if (a1%pdg(1) /= a2%pdg(1)) return
                      end if
                   else
                      return
                   end if
                else
                   return
                end if
              end associate
           end do
           flag = .true.
        end if
     end if
   end function pdg_list_eq
 
 @ %def pdg_list_eq
 @ Compare sorted lists.  The result is undefined if some entries
 are not allocated.
 
 The ordering is quite complicated.  First, a shorter list comes before
 a longer list.  Comparing entry by entry, a shorter entry comes
 first.  Next, we check the first PDG code within corresponding
 entries.  This is compared by absolute value.  If equal, particle
 comes before antiparticle.  Finally, if all is equal, the result is
 false.
 <<PDG arrays: pdg list: TBP>>=
   generic :: operator (<) => pdg_list_lt
   procedure, private :: pdg_list_lt
 <<PDG arrays: procedures>>=
   function pdg_list_lt (pl1, pl2) result (flag)
     class(pdg_list_t), intent(in) :: pl1, pl2
     logical :: flag
     integer :: i
     flag = .false.
     if (allocated (pl1%a) .and. allocated (pl2%a)) then
        if (size (pl1%a) < size (pl2%a)) then
           flag = .true.;  return
        else if (size (pl1%a) > size (pl2%a)) then
           return
        else
           do i = 1, size (pl1%a)
              associate (a1 => pl1%a(i), a2 => pl2%a(i))
                if (allocated (a1%pdg) .and. allocated (a2%pdg)) then
                   if (size (a1%pdg) < size (a2%pdg)) then
                      flag = .true.;  return
                   else if (size (a1%pdg) > size (a2%pdg)) then
                      return
                   else
                      if (size (a1%pdg) > 0) then
                         if (abs (a1%pdg(1)) < abs (a2%pdg(1))) then
                            flag = .true.;  return
                         else if (abs (a1%pdg(1)) > abs (a2%pdg(1))) then
                            return
                         else if (a1%pdg(1) > 0 .and. a2%pdg(1) < 0) then
                            flag = .true.;  return
                         else if (a1%pdg(1) < 0 .and. a2%pdg(1) > 0) then
                            return
                         end if
                      end if
                   end if
                else
                   return
                end if
              end associate
           end do
           flag = .false.
        end if
     end if
   end function pdg_list_lt
 
 @ %def pdg_list_lt
 @ Replace an entry.  In the result, the entry [[#i]] is replaced by
 the contents of the second argument.  The result is not sorted.
 
 If [[n_in]] is also set and [[i]] is less or equal to [[n_in]],
 replace [[#i]] only by the first entry of [[pl_insert]], and insert
 the remainder after entry [[n_in]].
 <<PDG arrays: pdg list: TBP>>=
   procedure :: replace => pdg_list_replace
 <<PDG arrays: procedures>>=
   function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out)
     type(pdg_list_t) :: pl_out
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: i
     class(pdg_list_t), intent(in) :: pl_insert
     integer, intent(in), optional :: n_in
     integer :: n, n_insert, n_out, k
     n = pl%get_size ()
     n_insert = pl_insert%get_size ()
     n_out = n + n_insert - 1
     call pl_out%init (n_out)
 !    if (allocated (pl%a)) then
        do k = 1, i - 1
           pl_out%a(k) = pl%a(k)
        end do
 !    end if
     if (present (n_in)) then
        pl_out%a(i) = pl_insert%a(1)
        do k = i + 1, n_in
           pl_out%a(k) = pl%a(k)
        end do
        do k = 1, n_insert - 1
           pl_out%a(n_in+k) = pl_insert%a(1+k)
        end do
        do k = 1, n - n_in
           pl_out%a(n_in+k+n_insert-1) = pl%a(n_in+k)
        end do
     else
 !       if (allocated (pl_insert%a)) then
           do k = 1, n_insert
              pl_out%a(i-1+k) = pl_insert%a(k)
           end do
 !       end if
 !       if (allocated (pl%a)) then
           do k = 1, n - i
              pl_out%a(i+n_insert-1+k) = pl%a(i+k)
           end do
        end if
 !    end if
   end function pdg_list_replace
 
 @ %def pdg_list_replace
 @
 <<PDG arrays: pdg list: TBP>>=
   procedure :: fusion => pdg_list_fusion
 <<PDG arrays: procedures>>=
   function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out)
     type(pdg_list_t) :: pl_out
     class(pdg_list_t), intent(in) :: pl
     type(pdg_list_t), intent(in) :: pl_insert
     integer, intent(in) :: i
     logical, intent(in) :: check_if_existing
     integer :: n, n_insert, k, n_out
     logical :: new_pdg
     n = pl%get_size ()
     n_insert = pl_insert%get_size ()
     new_pdg = .not. check_if_existing .or. &
          (.not. any (pl%search_for_particle (pl_insert%a(1)%pdg)))
     call pl_out%init (n + n_insert - 1)
     do k = 1, n
        if (new_pdg .and. k == i) then
           pl_out%a(k) = pl%a(k)%add (pl_insert%a(1))
        else
           pl_out%a(k) = pl%a(k)
        end if
     end do
     do k = n + 1, n + n_insert - 1
        pl_out%a(k) = pl_insert%a(k-n)
     end do
   end function pdg_list_fusion
 
 @ %def pdg_list_fusion
 @
 <<PDG arrays: pdg list: TBP>>=
   procedure :: get_pdg_sizes => pdg_list_get_pdg_sizes
 <<PDG arrays: procedures>>=
   function pdg_list_get_pdg_sizes (pl) result (i_size)
     integer, dimension(:), allocatable :: i_size
     class(pdg_list_t), intent(in) :: pl
     integer :: i, n
     n = pl%get_size ()
     allocate (i_size (n))
     do i = 1, n
        i_size(i) = size (pl%a(i)%pdg)
     end do
   end function pdg_list_get_pdg_sizes
 
 @ %def pdg_list_get_pdg_sizes
 @ Replace the entries of [[pl]] by the matching entries of [[pl_match]], one by
 one.  This is done in-place.  If there is no match, return failure.
 <<PDG arrays: pdg list: TBP>>=
   procedure :: match_replace => pdg_list_match_replace
 <<PDG arrays: procedures>>=
   subroutine pdg_list_match_replace (pl, pl_match, success)
     class(pdg_list_t), intent(inout) :: pl
     class(pdg_list_t), intent(in) :: pl_match
     logical, intent(out) :: success
     integer :: i, j
     success = .true.
     SCAN_ENTRIES: do i = 1, size (pl%a)
        do j = 1, size (pl_match%a)
           if (pl%a(i) .match. pl_match%a(j)) then
              pl%a(i) = pl_match%a(j)
              cycle SCAN_ENTRIES
           end if
        end do
        success = .false.
        return
     end do SCAN_ENTRIES
   end subroutine pdg_list_match_replace
 
 @ %def pdg_list_match_replace
 @ Just check if a PDG array matches any entry in the PDG list.  The second
 version returns the position of the match within the list.  An optional mask
 indicates the list elements that should be checked.
 <<PDG arrays: pdg list: TBP>>=
   generic :: operator (.match.) => pdg_list_match_pdg_array
   procedure, private :: pdg_list_match_pdg_array
   procedure :: find_match => pdg_list_find_match_pdg_array
 <<PDG arrays: procedures>>=
   function pdg_list_match_pdg_array (pl, pa) result (flag)
     class(pdg_list_t), intent(in) :: pl
     type(pdg_array_t), intent(in) :: pa
     logical :: flag
     flag = pl%find_match (pa) /= 0
   end function pdg_list_match_pdg_array
 
   function pdg_list_find_match_pdg_array (pl, pa, mask) result (i)
     class(pdg_list_t), intent(in) :: pl
     type(pdg_array_t), intent(in) :: pa
     logical, dimension(:), intent(in), optional :: mask
     integer :: i
     do i = 1, size (pl%a)
        if (present (mask)) then
           if (.not. mask(i))  cycle
        end if
        if (pl%a(i) .match. pa)  return
     end do
     i = 0
   end function pdg_list_find_match_pdg_array
 
 @ %def pdg_list_match_pdg_array
 @ %def pdg_list_find_match_pdg_array
 @ Some old compilers have problems with allocatable arrays as
 intent(out) or as function result, so be conservative here:
 <<PDG arrays: pdg list: TBP>>=
   procedure :: create_pdg_array => pdg_list_create_pdg_array
 <<PDG arrays: procedures>>=
   subroutine pdg_list_create_pdg_array (pl, pdg)
     class(pdg_list_t), intent(in) :: pl
     type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg
     integer :: n_elements
     integer :: i
     associate (a => pl%a)
       n_elements = size (a)
       if (allocated (pdg))  deallocate (pdg)
       allocate (pdg (n_elements))
       do i = 1, n_elements
          pdg(i) = a(i)
       end do
     end associate
   end subroutine pdg_list_create_pdg_array
 
 @ %def pdg_list_create_pdg_array
 @
 <<PDG arrays: pdg list: TBP>>=
   procedure :: create_antiparticles => pdg_list_create_antiparticles
 <<PDG arrays: procedures>>=
   subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles)
     class(pdg_list_t), intent(in) :: pl
     type(pdg_list_t), intent(out) :: pl_anti
     integer, intent(out) :: n_new_particles
     type(pdg_list_t) :: pl_inverse
     integer :: i, n
     integer :: n_identical
     logical, dimension(:), allocatable :: collect
     n = pl%get_size (); n_identical = 0
     allocate (collect (n)); collect = .true.
     call pl_inverse%init (n)
     do i = 1, n
        pl_inverse%a(i) = pl%a(i)%invert()
     end do
     do i = 1, n
        if (any (pl_inverse%a(i) == pl%a)) then
           collect(i) = .false.
           n_identical = n_identical + 1
        end if
     end do
     n_new_particles = n - n_identical
     if (n_new_particles > 0) then
        call pl_anti%init (n_new_particles)
        do i = 1, n
           if (collect (i)) pl_anti%a(i) = pl_inverse%a(i)
        end do
    end if
   end subroutine pdg_list_create_antiparticles
 
 @ %def pdg_list_create_antiparticles
 @
 <<PDG arrays: pdg list: TBP>>=
   procedure :: search_for_particle => pdg_list_search_for_particle
 <<PDG arrays: procedures>>=
   elemental function pdg_list_search_for_particle (pl, i_part) result (found)
     logical :: found
     class(pdg_list_t), intent(in) :: pl
     integer, intent(in) :: i_part
     integer :: i_pl
     do i_pl = 1, size (pl%a)
        found = pl%a(i_pl)%search_for_particle (i_part)
        if (found)  return
     end do
   end function pdg_list_search_for_particle
 
 @ %def pdg_list_search_for_particle
 @
 <<PDG arrays: pdg list: TBP>>=
   procedure :: contains_colored_particles => pdg_list_contains_colored_particles
 <<PDG arrays: procedures>>=
   function pdg_list_contains_colored_particles (pl) result (colored)
     class(pdg_list_t), intent(in) :: pl
     logical :: colored
     integer :: i
     colored = .false.
     do i = 1, size (pl%a)
        if (pl%a(i)%has_colored_particles()) then
           colored = .true.
           exit
        end if
     end do
   end function pdg_list_contains_colored_particles
 
 @ %def pdg_list_contains_colored_particles
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[pdg_arrays_ut.f90]]>>=
 <<File header>>
 
 module pdg_arrays_ut
   use unit_tests
   use pdg_arrays_uti
 
 <<Standard module head>>
 
 <<PDG arrays: public test>>
 
 contains
 
 <<PDG arrays: test driver>>
 
 end module pdg_arrays_ut
 @ %def pdg_arrays_ut
 @
 <<[[pdg_arrays_uti.f90]]>>=
 <<File header>>
 
 module pdg_arrays_uti
 
   use pdg_arrays
 
 <<Standard module head>>
 
 <<PDG arrays: test declarations>>
 
 contains
 
 <<PDG arrays: tests>>
 
 end module pdg_arrays_uti
 @ %def pdg_arrays_ut
 @ API: driver for the unit tests below.
 <<PDG arrays: public test>>=
   public :: pdg_arrays_test
 <<PDG arrays: test driver>>=
   subroutine pdg_arrays_test (u, results)
     integer, intent(in) :: u
     type (test_results_t), intent(inout) :: results
   <<PDG arrays: execute tests>>
   end subroutine pdg_arrays_test
 
 @ %def pdg_arrays_test
 @ Basic functionality.
 <<PDG arrays: execute tests>>=
   call test (pdg_arrays_1, "pdg_arrays_1", &
        "create and sort PDG array", &
        u, results)
 <<PDG arrays: test declarations>>=
   public :: pdg_arrays_1
 <<PDG arrays: tests>>=
   subroutine pdg_arrays_1 (u)
     integer, intent(in) :: u
 
     type(pdg_array_t) :: pa, pa1, pa2, pa3, pa4, pa5, pa6
     integer, dimension(:), allocatable :: pdg
 
     write (u, "(A)")  "* Test output: pdg_arrays_1"
     write (u, "(A)")  "*   Purpose: create and sort PDG arrays"
     write (u, "(A)")
 
     write (u, "(A)")  "* Assignment"
     write (u, "(A)")
 
     call pa%write (u)
     write (u, *)
     write (u, "(A,I0)")  "length = ", pa%get_length ()
     pdg = pa
     write (u, "(A,3(1x,I0))")  "contents = ", pdg
 
     write (u, *)
     pa = 1
     call pa%write (u)
     write (u, *)
     write (u, "(A,I0)")  "length = ", pa%get_length ()
     pdg = pa
     write (u, "(A,3(1x,I0))")  "contents = ", pdg
 
     write (u, *)
     pa = [1, 2, 3]
     call pa%write (u)
     write (u, *)
     write (u, "(A,I0)")  "length = ", pa%get_length ()
     pdg = pa
     write (u, "(A,3(1x,I0))")  "contents = ", pdg
     write (u, "(A,I0)")  "element #2 = ", pa%get (2)
 
     write (u, *)
     write (u, "(A)")  "* Replace"
     write (u, *)
 
     pa = pa%replace (2, [-5, 5, -7])
     call pa%write (u)
     write (u, *)
 
     write (u, *)
     write (u, "(A)")  "* Sort"
     write (u, *)
 
     pa = [1, -7, 3, -5, 5, 3]
     call pa%write (u)
     write (u, *)
     pa1 = pa%sort_abs ()
     pa2 = pa%sort_abs (unique = .true.)
     call pa1%write (u)
     write (u, *)
     call pa2%write (u)
     write (u, *)
 
     write (u, *)
     write (u, "(A)")  "* Compare"
     write (u, *)
 
     pa1 = [1, 3]
     pa2 = [1, 2, -2]
     pa3 = [1, 2, 4]
     pa4 = [1, 2, 4]
     pa5 = [1, 2, -4]
     pa6 = [1, 2, -3]
 
     write (u, "(A,6(1x,L1))")  "< ", &
          pa1 < pa2, pa2 < pa3, pa3 < pa4, pa4 < pa5, pa5 < pa6, pa6 < pa1
     write (u, "(A,6(1x,L1))")  "> ", &
          pa1 > pa2, pa2 > pa3, pa3 > pa4, pa4 > pa5, pa5 > pa6, pa6 > pa1
     write (u, "(A,6(1x,L1))")  "<=", &
          pa1 <= pa2, pa2 <= pa3, pa3 <= pa4, pa4 <= pa5, pa5 <= pa6, pa6 <= pa1
     write (u, "(A,6(1x,L1))")  ">=", &
          pa1 >= pa2, pa2 >= pa3, pa3 >= pa4, pa4 >= pa5, pa5 >= pa6, pa6 >= pa1
     write (u, "(A,6(1x,L1))")  "==", &
          pa1 == pa2, pa2 == pa3, pa3 == pa4, pa4 == pa5, pa5 == pa6, pa6 == pa1
     write (u, "(A,6(1x,L1))")  "/=", &
          pa1 /= pa2, pa2 /= pa3, pa3 /= pa4, pa4 /= pa5, pa5 /= pa6, pa6 /= pa1
 
     write (u, *)
     pa1 = [0]
     pa2 = [1, 2]
     pa3 = [1, -2]
 
     write (u, "(A,6(1x,L1))")  "eqv ", &
          pa1 .eqv. pa1, pa1 .eqv. pa2, &
          pa2 .eqv. pa2, pa2 .eqv. pa3
 
     write (u, "(A,6(1x,L1))")  "neqv", &
          pa1 .neqv. pa1, pa1 .neqv. pa2, &
          pa2 .neqv. pa2, pa2 .neqv. pa3
 
 
     write (u, *)
     write (u, "(A,6(1x,L1))")  "match", &
          pa1 .match. 0, pa1 .match. 1, &
          pa2 .match. 0, pa2 .match. 1, pa2 .match. 3
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: pdg_arrays_1"
 
   end subroutine pdg_arrays_1
 
 @ %def pdg_arrays_1
 @ PDG array list, i.e., arrays of arrays.
 <<PDG arrays: execute tests>>=
   call test (pdg_arrays_2, "pdg_arrays_2", &
        "create and sort PDG lists", &
        u, results)
 <<PDG arrays: test declarations>>=
   public :: pdg_arrays_2
 <<PDG arrays: tests>>=
   subroutine pdg_arrays_2 (u)
     integer, intent(in) :: u
 
     type(pdg_array_t) :: pa
     type(pdg_list_t) :: pl, pl1
 
     write (u, "(A)")  "* Test output: pdg_arrays_2"
     write (u, "(A)")  "*   Purpose: create and sort PDG lists"
     write (u, "(A)")
 
     write (u, "(A)")  "* Assignment"
     write (u, "(A)")
 
     call pl%init (3)
     call pl%set (1, 42)
     call pl%set (2, [3, 2])
     pa = [5, -5]
     call pl%set (3, pa)
     call pl%write (u)
     write (u, *)
     write (u, "(A,I0)")  "size = ", pl%get_size ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Sort"
     write (u, "(A)")
 
     pl = pl%sort_abs ()
     call pl%write (u)
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract item #3"
     write (u, "(A)")
 
     pa = pl%get (3)
     call pa%write (u)
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Replace item #3"
     write (u, "(A)")
 
     call pl1%init (2)
     call pl1%set (1, [2, 4])
     call pl1%set (2, -7)
 
     pl = pl%replace (3, pl1)
     call pl%write (u)
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: pdg_arrays_2"
 
   end subroutine pdg_arrays_2
 
 @ %def pdg_arrays_2
 @ Check if a (sorted) PDG array lists is regular.  The entries (PDG arrays)
 must not overlap, unless they are identical.
 <<PDG arrays: execute tests>>=
   call test (pdg_arrays_3, "pdg_arrays_3", &
        "check PDG lists", &
        u, results)
 <<PDG arrays: test declarations>>=
   public :: pdg_arrays_3
 <<PDG arrays: tests>>=
   subroutine pdg_arrays_3 (u)
     integer, intent(in) :: u
 
     type(pdg_list_t) :: pl
 
     write (u, "(A)")  "* Test output: pdg_arrays_3"
     write (u, "(A)")  "*   Purpose: check for regular PDG lists"
     write (u, "(A)")
 
     write (u, "(A)")  "* Regular list"
     write (u, "(A)")
 
     call pl%init (4)
     call pl%set (1, [1, 2])
     call pl%set (2, [1, 2])
     call pl%set (3, [5, -5])
     call pl%set (4, 42)
     call pl%write (u)
     write (u, *)
     write (u, "(L1)") pl%is_regular ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Irregular list"
     write (u, "(A)")
 
     call pl%init (4)
     call pl%set (1, [1, 2])
     call pl%set (2, [1, 2])
     call pl%set (3, [2, 5, -5])
     call pl%set (4, 42)
     call pl%write (u)
     write (u, *)
     write (u, "(L1)") pl%is_regular ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: pdg_arrays_3"
 
   end subroutine pdg_arrays_3
 
 @ %def pdg_arrays_3
 @ Compare PDG array lists.  The lists must be regular, i.e., sorted and with
 non-overlapping (or identical) entries.
 <<PDG arrays: execute tests>>=
   call test (pdg_arrays_4, "pdg_arrays_4", &
        "compare PDG lists", &
        u, results)
 <<PDG arrays: test declarations>>=
   public :: pdg_arrays_4
 <<PDG arrays: tests>>=
   subroutine pdg_arrays_4 (u)
     integer, intent(in) :: u
 
     type(pdg_list_t) :: pl1, pl2, pl3
 
     write (u, "(A)")  "* Test output: pdg_arrays_4"
     write (u, "(A)")  "*   Purpose: check for regular PDG lists"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create lists"
     write (u, "(A)")
 
     call pl1%init (4)
     call pl1%set (1, [1, 2])
     call pl1%set (2, [1, 2])
     call pl1%set (3, [5, -5])
     call pl1%set (4, 42)
     write (u, "(I1,1x)", advance = "no")  1
     call pl1%write (u)
     write (u, *)
 
     call pl2%init (2)
     call pl2%set (1, 3)
     call pl2%set (2, [5, -5])
     write (u, "(I1,1x)", advance = "no")  2
     call pl2%write (u)
     write (u, *)
 
     call pl3%init (2)
     call pl3%set (1, 4)
     call pl3%set (2, [5, -5])
     write (u, "(I1,1x)", advance = "no")  3
     call pl3%write (u)
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* a == b"
     write (u, "(A)")
 
     write (u, "(2x,A)")  "123"
     write (u, *)
     write (u, "(I1,1x,4L1)")  1, pl1 == pl1, pl1 == pl2, pl1 == pl3
     write (u, "(I1,1x,4L1)")  2, pl2 == pl1, pl2 == pl2, pl2 == pl3
     write (u, "(I1,1x,4L1)")  3, pl3 == pl1, pl3 == pl2, pl3 == pl3
 
     write (u, "(A)")
     write (u, "(A)")  "* a < b"
     write (u, "(A)")
 
     write (u, "(2x,A)")  "123"
     write (u, *)
     write (u, "(I1,1x,4L1)")  1, pl1 < pl1, pl1 < pl2, pl1 < pl3
     write (u, "(I1,1x,4L1)")  2, pl2 < pl1, pl2 < pl2, pl2 < pl3
     write (u, "(I1,1x,4L1)")  3, pl3 < pl1, pl3 < pl2, pl3 < pl3
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: pdg_arrays_4"
 
   end subroutine pdg_arrays_4
 
 @ %def pdg_arrays_4
 @ Match-replace: translate all entries in the first list into the
 matching entries of the second list, if there is a match.
 <<PDG arrays: execute tests>>=
   call test (pdg_arrays_5, "pdg_arrays_5", &
        "match PDG lists", &
        u, results)
 <<PDG arrays: test declarations>>=
   public :: pdg_arrays_5
 <<PDG arrays: tests>>=
   subroutine pdg_arrays_5 (u)
     integer, intent(in) :: u
 
     type(pdg_list_t) :: pl1, pl2, pl3
     logical :: success
 
     write (u, "(A)")  "* Test output: pdg_arrays_5"
     write (u, "(A)")  "*   Purpose: match-replace"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create lists"
     write (u, "(A)")
 
     call pl1%init (2)
     call pl1%set (1, [1, 2])
     call pl1%set (2, 42)
     call pl1%write (u)
     write (u, *)
     call pl3%init (2)
     call pl3%set (1, [42, -42])
     call pl3%set (2, [1, 2, 3, 4])
     call pl1%match_replace (pl3, success)
     call pl3%write (u)
     write (u, "(1x,A,1x,L1,':',1x)", advance="no")  "=>", success
     call pl1%write (u)
     write (u, *)
 
     write (u, *)
 
     call pl2%init (2)
     call pl2%set (1, 9)
     call pl2%set (2, 42)
     call pl2%write (u)
     write (u, *)
     call pl2%match_replace (pl3, success)
     call pl3%write (u)
     write (u, "(1x,A,1x,L1,':',1x)", advance="no")  "=>", success
     call pl2%write (u)
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: pdg_arrays_5"
 
   end subroutine pdg_arrays_5
 
 @ %def pdg_arrays_5
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Jets}
 
 The FastJet library is linked externally, if available.  The wrapper code is
 also in a separate directory.  Here, we define \whizard-specific procedures
 and tests.
 <<[[jets.f90]]>>=
 <<File header>>
 
 module jets
 
   use fastjet !NODEP!
 
 <<Standard module head>>
 
 <<Jets: public>>
 
 contains
 
 <<Jets: procedures>>
 
 end module jets
 @ %def jets
 @
 \subsection{Re-exported symbols}
 We use this module as a proxy for the FastJet interface, therefore we
 re-export some symbols.
 <<Jets: public>>=
   public :: fastjet_available
   public :: fastjet_init
   public :: jet_definition_t
   public :: pseudojet_t
   public :: pseudojet_vector_t
   public :: cluster_sequence_t
   public :: assignment (=)
 
 @ %def jet_definition_t pseudojet_t pseudojet_vector_t cluster_sequence_t
 @ The initialization routine prints the banner.
 <<Jets: procedures>>=
   subroutine fastjet_init ()
     call print_banner ()
   end subroutine fastjet_init
 
 @ %def fastjet_init
 @ The jet algorithm codes (actually, integers)
 <<Jets: public>>=
   public :: kt_algorithm
   public :: cambridge_algorithm
   public :: antikt_algorithm
   public :: genkt_algorithm
   public :: cambridge_for_passive_algorithm
   public :: genkt_for_passive_algorithm
   public :: ee_kt_algorithm
   public :: ee_genkt_algorithm
   public :: plugin_algorithm
   public :: undefined_jet_algorithm
 
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[jets_ut.f90]]>>=
 <<File header>>
 
 module jets_ut
   use unit_tests
   use jets_uti
 
 <<Standard module head>>
 
 <<Jets: public test>>
 
 contains
 
 <<Jets: test driver>>
 
 end module jets_ut
 @ %def jets_ut
 @
 <<[[jets_uti.f90]]>>=
 <<File header>>
 
 module jets_uti
 
 <<Use kinds>>
   use fastjet !NODEP!
 
   use jets
 
 <<Standard module head>>
 
 <<Jets: test declarations>>
 
 contains
 
 <<Jets: tests>>
 
 end module jets_uti
 @ %def jets_ut
 @ API: driver for the unit tests below.
 <<Jets: public test>>=
   public :: jets_test
 <<Jets: test driver>>=
   subroutine jets_test (u, results)
     integer, intent(in) :: u
     type (test_results_t), intent(inout) :: results
   <<Jets: execute tests>>
   end subroutine jets_test
 
 @ %def jets_test
 @ This test is actually the minimal example from the FastJet manual,
 translated to Fortran.
 
 Note that FastJet creates pseudojet vectors, which we mirror in the
 [[pseudojet_vector_t]], but immediately assign to pseudojet arrays.  Without
 automatic finalization available in the compilers, we should avoid this in
 actual code and rather introduce intermediate variables for those objects,
 which we can finalize explicitly.
 <<Jets: execute tests>>=
   call test (jets_1, "jets_1", &
        "basic FastJet functionality", &
        u, results)
 <<Jets: test declarations>>=
   public :: jets_1
 <<Jets: tests>>=
   subroutine jets_1 (u)
     integer, intent(in) :: u
 
     type(pseudojet_t), dimension(:), allocatable :: prt, jets, constituents
     type(jet_definition_t) :: jet_def
     type(cluster_sequence_t) :: cs
 
     integer, parameter :: dp = default
     integer :: i, j
 
     write (u, "(A)")  "* Test output: jets_1"
     write (u, "(A)")  "*   Purpose: test basic FastJet functionality"
     write (u, "(A)")
 
     write (u, "(A)")  "* Print banner"
     call print_banner ()
 
     write (u, *)
     write (u, "(A)")  "* Prepare input particles"
     allocate (prt (3))
     call prt(1)%init ( 99._dp, 0.1_dp, 0._dp, 100._dp)
     call prt(2)%init (  4._dp,-0.1_dp, 0._dp,   5._dp)
     call prt(3)%init (-99._dp, 0._dp,  0._dp,  99._dp)
 
     write (u, *)
     write (u, "(A)")  "* Define jet algorithm"
     call jet_def%init (antikt_algorithm, 0.7_dp)
 
     write (u, *)
     write (u, "(A)")  "* Cluster particles according to jet algorithm"
 
     write (u, *)
     write (u, "(A,A)")  "Clustering with ", jet_def%description ()
     call cs%init (pseudojet_vector (prt), jet_def)
 
     write (u, *)
     write (u, "(A)")  "* Sort output jets"
     jets = sorted_by_pt (cs%inclusive_jets ())
 
     write (u, *)
     write (u, "(A)")  "* Print jet observables and constituents"
     write (u, *)
     write (u, "(4x,3(7x,A3))") "pt", "y", "phi"
     do i = 1, size (jets)
        write (u, "(A,1x,I0,A,3(1x,F9.5))") &
             "jet", i, ":", jets(i)%perp (), jets(i)%rap (), jets(i)%phi ()
        constituents = jets(i)%constituents ()
        do j = 1, size (constituents)
           write (u, "(4x,A,1x,I0,A,F9.5)") &
                "constituent", j, "'s pt:", constituents(j)%perp ()
        end do
        do j = 1, size (constituents)
           call constituents(j)%final ()
        end do
     end do
 
     write (u, *)
     write (u, "(A)")  "* Cleanup"
 
     do i = 1, size (prt)
        call prt(i)%final ()
     end do
     do i = 1, size (jets)
        call jets(i)%final ()
     end do
     call jet_def%final ()
     call cs%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: jets_1"
 
   end subroutine jets_1
 
 @ %def jets_1
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Subevents}
 
 The purpose of subevents is to store the relevant part of the physical
 event (either partonic or hadronic), and to hold particle selections
 and combinations which are constructed in cut or analysis expressions.
 <<[[subevents.f90]]>>=
 <<File header>>
 
 module subevents
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use kinds>>
   use io_units
   use format_defs, only: FMT_14, FMT_19
   use format_utils, only: pac_fmt
   use physics_defs
   use sorting
   use c_particles
   use lorentz
   use pdg_arrays
   use jets
 
 <<Standard module head>>
 
 <<Subevents: public>>
 
 <<Subevents: parameters>>
 
 <<Subevents: types>>
 
 <<Subevents: interfaces>>
 
 contains
 
 <<Subevents: procedures>>
 
 end module subevents
 @ %def subevents
 @
 \subsection{Particles}
 For the purpose of this module, a particle has a type which can
 indicate a beam, incoming, outgoing, or composite particle, flavor and
 helicity codes (integer, undefined for composite), four-momentum and
 invariant mass squared.  (Other particles types are used in extended
 event types, but also defined here.)  Furthermore, each particle has
 an allocatable array of ancestors -- particle indices which indicate
 the building blocks of a composite particle.  For an incoming/outgoing
 particle, the array contains only the index of the particle itself.
 
 For incoming particles, the momentum is inverted before storing it in
 the particle object.
 <<Subevents: parameters>>=
   integer, parameter, public :: PRT_UNDEFINED = 0
   integer, parameter, public :: PRT_BEAM = -9
   integer, parameter, public :: PRT_INCOMING = 1
   integer, parameter, public :: PRT_OUTGOING = 2
   integer, parameter, public :: PRT_COMPOSITE = 3
   integer, parameter, public :: PRT_VIRTUAL = 4
   integer, parameter, public :: PRT_RESONANT = 5
   integer, parameter, public :: PRT_BEAM_REMNANT = 9
 
 @ %def PRT_UNDEFINED PRT_BEAM
 @ %def PRT_INCOMING PRT_OUTGOING PRT_COMPOSITE
 @ %def PRT_COMPOSITE PRT_VIRTUAL PRT_RESONANT
 @ %def PRT_BEAM_REMNANT
 @
 \subsubsection{The type}
 We initialize only the type here and mark as unpolarized.  The
 initializers below do the rest. The logicals [[is_b_jet]] and
 [[is_c_jet]] are true only if [[prt_t]] comes out of the
 [[subevt_cluster]] routine and fulfils the correct flavor content.
 <<Subevents: public>>=
   public :: prt_t
 <<Subevents: types>>=
   type :: prt_t
      private
      integer :: type = PRT_UNDEFINED
      integer :: pdg
      logical :: polarized = .false.
      logical :: colorized = .false.
      logical :: clustered = .false.
      logical :: is_b_jet = .false.
      logical :: is_c_jet = .false.
      integer :: h
      type(vector4_t) :: p
      real(default) :: p2
      integer, dimension(:), allocatable :: src
      integer, dimension(:), allocatable :: col
      integer, dimension(:), allocatable :: acl
   end type prt_t
 
 @ %def prt_t
 @ Initializers.  Polarization is set separately.  Finalizers are not
 needed.
 <<Subevents: procedures>>=
   subroutine prt_init_beam (prt, pdg, p, p2, src)
     type(prt_t), intent(out) :: prt
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in) :: src
     prt%type = PRT_BEAM
     call prt_set (prt, pdg, - p, p2, src)
   end subroutine prt_init_beam
 
   subroutine prt_init_incoming (prt, pdg, p, p2, src)
     type(prt_t), intent(out) :: prt
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in) :: src
     prt%type = PRT_INCOMING
     call prt_set (prt, pdg, - p, p2, src)
   end subroutine prt_init_incoming
 
   subroutine prt_init_outgoing (prt, pdg, p, p2, src)
     type(prt_t), intent(out) :: prt
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in) :: src
     prt%type = PRT_OUTGOING
     call prt_set (prt, pdg, p, p2, src)
   end subroutine prt_init_outgoing
 
   subroutine prt_init_composite (prt, p, src)
     type(prt_t), intent(out) :: prt
     type(vector4_t), intent(in) :: p
     integer, dimension(:), intent(in) :: src
     prt%type = PRT_COMPOSITE
     call prt_set (prt, 0, p, p**2, src)
   end subroutine prt_init_composite
 
 @ %def prt_init_beam prt_init_incoming prt_init_outgoing prt_init_composite
 @
 This version is for temporary particle objects, so the [[src]] array
 is not set.
 <<Subevents: public>>=
   public :: prt_init_combine
 <<Subevents: procedures>>=
   subroutine prt_init_combine (prt, prt1, prt2)
     type(prt_t), intent(out) :: prt
     type(prt_t), intent(in) :: prt1, prt2
     type(vector4_t) :: p
     integer, dimension(0) :: src
     prt%type = PRT_COMPOSITE
     p = prt1%p + prt2%p
     call prt_set (prt, 0, p, p**2, src)
   end subroutine prt_init_combine
 
 @ %def prt_init_combine
 @ Init from a pseudojet object.
 <<Subevents: procedures>>=
   subroutine prt_init_pseudojet (prt, jet, src, pdg, is_b_jet, is_c_jet)
     type(prt_t), intent(out) :: prt
     type(pseudojet_t), intent(in) :: jet
     integer, dimension(:), intent(in) :: src
     integer, intent(in) :: pdg
     logical, intent(in) :: is_b_jet, is_c_jet
     type(vector4_t) :: p
     prt%type = PRT_COMPOSITE
     p = vector4_moving (jet%e(), &
          vector3_moving ([jet%px(), jet%py(), jet%pz()]))
     call prt_set (prt, pdg, p, p**2, src)
     prt%is_b_jet = is_b_jet
     prt%is_c_jet = is_c_jet
     prt%clustered = .true.
   end subroutine prt_init_pseudojet
 
 @ %def prt_init_pseudojet
 @
 \subsubsection{Accessing contents}
 <<Subevents: public>>=
   public :: prt_get_pdg
 <<Subevents: procedures>>=
   elemental function prt_get_pdg (prt) result (pdg)
     integer :: pdg
     type(prt_t), intent(in) :: prt
     pdg = prt%pdg
   end function prt_get_pdg
 
 @ %def prt_get_pdg
 <<Subevents: public>>=
   public :: prt_get_momentum
 <<Subevents: procedures>>=
   elemental function prt_get_momentum (prt) result (p)
     type(vector4_t) :: p
     type(prt_t), intent(in) :: prt
     p = prt%p
   end function prt_get_momentum
 
 @ %def prt_get_momentum
 <<Subevents: public>>=
   public :: prt_get_msq
 <<Subevents: procedures>>=
   elemental function prt_get_msq (prt) result (msq)
     real(default) :: msq
     type(prt_t), intent(in) :: prt
     msq = prt%p2
   end function prt_get_msq
 
 @ %def prt_get_msq
 <<Subevents: public>>=
   public :: prt_is_polarized
 <<Subevents: procedures>>=
   elemental function prt_is_polarized (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = prt%polarized
   end function prt_is_polarized
 
 @ %def prt_is_polarized
 <<Subevents: public>>=
   public :: prt_get_helicity
 <<Subevents: procedures>>=
   elemental function prt_get_helicity (prt) result (h)
     integer :: h
     type(prt_t), intent(in) :: prt
     h = prt%h
   end function prt_get_helicity
 
 @ %def prt_get_helicity
 <<Subevents: public>>=
   public :: prt_is_colorized
 <<Subevents: procedures>>=
   elemental function prt_is_colorized (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = prt%colorized
   end function prt_is_colorized
 
 @ %def prt_is_colorized
 <<Subevents: public>>=
   public :: prt_is_clustered
 <<Subevents: procedures>>=
   elemental function prt_is_clustered (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = prt%clustered
   end function prt_is_clustered
 
 @ %def prt_is_clustered
 <<Subevents: public>>=
   public :: prt_is_photon
 <<Subevents: procedures>>=
   elemental function prt_is_photon (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = prt%pdg == PHOTON
   end function prt_is_photon
   
 @ %def prt_is_photon
 We do not take the top quark into account here.
 <<Subevents: public>>=
   public :: prt_is_parton
 <<Subevents: procedures>>=
   elemental function prt_is_parton (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = abs(prt%pdg) == DOWN_Q .or. &
            abs(prt%pdg) == UP_Q .or. &
            abs(prt%pdg) == STRANGE_Q .or. &
            abs(prt%pdg) == CHARM_Q .or. &
            abs(prt%pdg) == BOTTOM_Q .or. &
            prt%pdg == GLUON
   end function prt_is_parton
   
 @ %def prt_is_photon
 <<Subevents: public>>=
   public :: prt_is_lepton
 <<Subevents: procedures>>=
   elemental function prt_is_lepton (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = abs(prt%pdg) == ELECTRON .or. &
            abs(prt%pdg) == MUON     .or. &
            abs(prt%pdg) == TAU
   end function prt_is_lepton
   
 @ %def prt_is_lepton
 <<Subevents: public>>=
   public :: prt_is_b_jet
 <<Subevents: procedures>>=
   elemental function prt_is_b_jet (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = prt%is_b_jet
   end function prt_is_b_jet
 
 @ %def prt_is_b_jet
 <<Subevents: public>>=
   public :: prt_is_c_jet
 <<Subevents: procedures>>=
   elemental function prt_is_c_jet (prt) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt
     flag = prt%is_c_jet
   end function prt_is_c_jet
 
 @ %def prt_is_c_jet
 @ The number of open color (anticolor) lines.  We inspect the list of color
 (anticolor) lines and count the entries that do not appear in the list
 of anticolors (colors).  (There is no check against duplicates; we assume that
 color line indices are unique.)
 <<Subevents: public>>=
   public :: prt_get_n_col
   public :: prt_get_n_acl
 <<Subevents: procedures>>=
   elemental function prt_get_n_col (prt) result (n)
     integer :: n
     type(prt_t), intent(in) :: prt
     integer, dimension(:), allocatable :: col, acl
     integer :: i
     n = 0
     if (prt%colorized) then
        do i = 1, size (prt%col)
           if (all (prt%col(i) /= prt%acl)) n = n + 1
        end do
     end if
   end function prt_get_n_col
 
   elemental function prt_get_n_acl (prt) result (n)
     integer :: n
     type(prt_t), intent(in) :: prt
     integer, dimension(:), allocatable :: col, acl
     integer :: i
     n = 0
     if (prt%colorized) then
        do i = 1, size (prt%acl)
           if (all (prt%acl(i) /= prt%col)) n = n + 1
        end do
     end if
   end function prt_get_n_acl
 
 @ %def prt_get_n_col
 @ %def prt_get_n_acl
 @ Return the color and anticolor-flow line indices explicitly.
 <<Subevents: public>>=
   public :: prt_get_color_indices
 <<Subevents: procedures>>=
   subroutine prt_get_color_indices (prt, col, acl)
     type(prt_t), intent(in) :: prt
     integer, dimension(:), allocatable, intent(out) :: col, acl
     if (prt%colorized) then
        col = prt%col
        acl = prt%acl
     else
        col = [integer::]
        acl = [integer::]
     end if
   end subroutine prt_get_color_indices
 
 @ %def prt_get_color_indices
 @
 \subsubsection{Setting data}
 Set the PDG, momentum and momentum squared, and ancestors.  If
 allocate-on-assignment is available, this can be simplified.
 <<Subevents: procedures>>=
   subroutine prt_set (prt, pdg, p, p2, src)
     type(prt_t), intent(inout) :: prt
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in) :: src
     prt%pdg = pdg
     prt%p = p
     prt%p2 = p2
     if (allocated (prt%src)) then
        if (size (src) /= size (prt%src)) then
           deallocate (prt%src)
           allocate (prt%src (size (src)))
        end if
     else
        allocate (prt%src (size (src)))
     end if
     prt%src = src
   end subroutine prt_set
 
 @ %def prt_set
 @ Set the particle PDG code separately.
 <<Subevents: procedures>>=
   elemental subroutine prt_set_pdg (prt, pdg)
     type(prt_t), intent(inout) :: prt
     integer, intent(in) :: pdg
     prt%pdg = pdg
   end subroutine prt_set_pdg
 
 @ %def prt_set_pdg
 @ Set the momentum separately.
 <<Subevents: procedures>>=
   elemental subroutine prt_set_p (prt, p)
     type(prt_t), intent(inout) :: prt
     type(vector4_t), intent(in) :: p
     prt%p = p
   end subroutine prt_set_p
 
 @ %def prt_set_p
 @ Set the squared invariant mass separately.
 <<Subevents: procedures>>=
   elemental subroutine prt_set_p2 (prt, p2)
     type(prt_t), intent(inout) :: prt
     real(default), intent(in) :: p2
     prt%p2 = p2
   end subroutine prt_set_p2
 
 @ %def prt_set_p2
 @ Set helicity (optional).
 <<Subevents: procedures>>=
   subroutine prt_polarize (prt, h)
     type(prt_t), intent(inout) :: prt
     integer, intent(in) :: h
     prt%polarized = .true.
     prt%h = h
   end subroutine prt_polarize
 
 @ %def prt_polarize
 @ Set color-flow indices (optional).
 <<Subevents: procedures>>=
   subroutine prt_colorize (prt, col, acl)
     type(prt_t), intent(inout) :: prt
     integer, dimension(:), intent(in) :: col, acl
     prt%colorized = .true.
     prt%col = col
     prt%acl = acl
   end subroutine prt_colorize
 
 @ %def prt_colorize
 @
 \subsubsection{Conversion}
 Transform a [[prt_t]] object into a [[c_prt_t]] object.
 <<Subevents: public>>=
   public :: c_prt
 <<Subevents: interfaces>>=
   interface c_prt
      module procedure c_prt_from_prt
   end interface
 
 @ %def c_prt
 <<Subevents: procedures>>=
   elemental function c_prt_from_prt (prt) result (c_prt)
     type(c_prt_t) :: c_prt
     type(prt_t), intent(in) :: prt
     c_prt = prt%p
     c_prt%type = prt%type
     c_prt%pdg = prt%pdg
     if (prt%polarized) then
        c_prt%polarized = 1
     else
        c_prt%polarized = 0
     end if
     c_prt%h = prt%h
   end function c_prt_from_prt
 
 @ %def c_prt_from_prt
 @
 \subsubsection{Output}
 <<Subevents: public>>=
   public :: prt_write
 <<Subevents: procedures>>=
   subroutine prt_write (prt, unit, testflag)
     type(prt_t), intent(in) :: prt
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     logical :: pacified
     type(prt_t) :: tmp
     character(len=7) :: fmt
     integer :: u, i
     call pac_fmt (fmt, FMT_19, FMT_14, testflag)
     u = given_output_unit (unit);  if (u < 0)  return
     pacified = .false. ; if (present (testflag))  pacified = testflag
     tmp = prt
     if (pacified) call pacify (tmp)
     write (u, "(1x,A)", advance="no")  "prt("
     select case (prt%type)
     case (PRT_UNDEFINED);    write (u, "('?')", advance="no")
     case (PRT_BEAM);         write (u, "('b:')", advance="no")
     case (PRT_INCOMING);     write (u, "('i:')", advance="no")
     case (PRT_OUTGOING);     write (u, "('o:')", advance="no")
     case (PRT_COMPOSITE);    write (u, "('c:')", advance="no")
     end select
     select case (prt%type)
     case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING)
        if (prt%polarized) then
           write (u, "(I0,'/',I0,'|')", advance="no")  prt%pdg, prt%h
        else
           write (u, "(I0,'|')", advance="no") prt%pdg
        end if
     end select
     select case (prt%type)
     case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE)
        if (prt%colorized) then
           write (u, "(*(I0,:,','))", advance="no")  prt%col
           write (u, "('/')", advance="no")
           write (u, "(*(I0,:,','))", advance="no")  prt%acl
           write (u, "('|')", advance="no")
        end if
     end select
     select case (prt%type)
     case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE)
        write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // &
             FMT_14 // ",','," // FMT_14 // ")", advance="no") tmp%p
        write (u, "('|'," // fmt // ")", advance="no") tmp%p2
     end select
     if (allocated (prt%src)) then
        write (u, "('|')", advance="no")
        do i = 1, size (prt%src)
           write (u, "(1x,I0)", advance="no")  prt%src(i)
        end do
     end if
     if (prt%is_b_jet) then
        write (u, "('|b jet')", advance="no")
     end if
     if (prt%is_c_jet) then
        write (u, "('|c jet')", advance="no")
     end if
     write (u, "(A)")  ")"
   end subroutine prt_write
 
 @ %def prt_write
 @
 \subsubsection{Tools}
 Two particles match if their [[src]] arrays are the same.
 <<Subevents: public>>=
   public :: operator(.match.)
 <<Subevents: interfaces>>=
   interface operator(.match.)
      module procedure prt_match
   end interface
 
 @ %def .match.
 <<Subevents: procedures>>=
   elemental function prt_match (prt1, prt2) result (match)
     logical :: match
     type(prt_t), intent(in) :: prt1, prt2
     if (size (prt1%src) == size (prt2%src)) then
        match = all (prt1%src == prt2%src)
     else
        match = .false.
     end if
   end function prt_match
 
 @ %def prt_match
 @ The combine operation makes a pseudoparticle whose momentum is the
 result of adding (the momenta of) the pair of input particles.  We
 trace the particles from which a particle is built by storing a
 [[src]] array.  Each particle entry in the [[src]] list contains a
 list of indices which indicates its building blocks.  The indices
 refer to an original list of particles.  Index lists are sorted, and
 they contain no element more than once.
 
 We thus require that in a given pseudoparticle, each original particle
 occurs at most once.
 
 The result is intent(inout), so it will not be initialized when the
 subroutine is entered.
 
 If the particles carry color, we recall that the combined particle is a
 composite which is understood as outgoing.  If one of the arguments is an
 incoming particle, is color entries must be reversed.
 <<Subevents: procedures>>=
   subroutine prt_combine (prt, prt_in1, prt_in2, ok)
     type(prt_t), intent(inout) :: prt
     type(prt_t), intent(in) :: prt_in1, prt_in2
     logical :: ok
     integer, dimension(:), allocatable :: src
     integer, dimension(:), allocatable :: col1, acl1, col2, acl2
     call combine_index_lists (src, prt_in1%src, prt_in2%src)
     ok = allocated (src)
     if (ok) then
        call prt_init_composite (prt, prt_in1%p + prt_in2%p, src)
        if (prt_in1%colorized .or. prt_in2%colorized) then
           select case (prt_in1%type)
           case default
              call prt_get_color_indices (prt_in1, col1, acl1)
           case (PRT_BEAM, PRT_INCOMING)
              call prt_get_color_indices (prt_in1, acl1, col1)
           end select
           select case (prt_in2%type)
           case default
              call prt_get_color_indices (prt_in2, col2, acl2)
           case (PRT_BEAM, PRT_INCOMING)
              call prt_get_color_indices (prt_in2, acl2, col2)
           end select
           call prt_colorize (prt, [col1, col2], [acl1, acl2])
        end if
     end if
   end subroutine prt_combine
 
 @ %def prt_combine
 @ This variant does not produce the combined particle, it just checks
 whether the combination is valid (no common [[src]] entry).
 <<Subevents: public>>=
   public :: are_disjoint
 <<Subevents: procedures>>=
   function are_disjoint (prt_in1, prt_in2) result (flag)
     logical :: flag
     type(prt_t), intent(in) :: prt_in1, prt_in2
     flag = index_lists_are_disjoint (prt_in1%src, prt_in2%src)
   end function are_disjoint
 
 @ %def are_disjoint
 @ [[src]] Lists with length $>1$ are built by a [[combine]] operation
 which merges the lists in a sorted manner.  If the result would have a
 duplicate entry, it is discarded, and the result is unallocated.
 <<Subevents: procedures>>=
   subroutine combine_index_lists (res, src1, src2)
     integer, dimension(:), intent(in) :: src1, src2
     integer, dimension(:), allocatable :: res
     integer :: i1, i2, i
     allocate (res (size (src1) + size (src2)))
     if (size (src1) == 0) then
        res = src2
        return
     else if (size (src2) == 0) then
        res = src1
        return
     end if
     i1 = 1
     i2 = 1
     LOOP: do i = 1, size (res)
        if (src1(i1) < src2(i2)) then
           res(i) = src1(i1);  i1 = i1 + 1
           if (i1 > size (src1)) then
              res(i+1:) = src2(i2:)
              exit LOOP
           end if
        else if (src1(i1) > src2(i2)) then
           res(i) = src2(i2);  i2 = i2 + 1
           if (i2 > size (src2)) then
              res(i+1:) = src1(i1:)
              exit LOOP
           end if
        else
           deallocate (res)
           exit LOOP
        end if
     end do LOOP
   end subroutine combine_index_lists
 
 @ %def combine_index_lists
 @ This function is similar, but it does not actually merge the list,
 it just checks whether they are disjoint (no common [[src]] entry).
 <<Subevents: procedures>>=
   function index_lists_are_disjoint (src1, src2) result (flag)
     logical :: flag
     integer, dimension(:), intent(in) :: src1, src2
     integer :: i1, i2, i
     flag = .true.
     i1 = 1
     i2 = 1
     LOOP: do i = 1, size (src1) + size (src2)
        if (src1(i1) < src2(i2)) then
           i1 = i1 + 1
           if (i1 > size (src1)) then
              exit LOOP
           end if
        else if (src1(i1) > src2(i2)) then
           i2 = i2 + 1
           if (i2 > size (src2)) then
              exit LOOP
           end if
        else
           flag = .false.
           exit LOOP
        end if
     end do LOOP
   end function index_lists_are_disjoint
 
 @ %def index_lists_are_disjoint
 @
 \subsection{subevents}
 Particles are collected in subevents.  This type is implemented as a
 dynamically allocated array, which need not be completely filled.  The
 value [[n_active]] determines the number of meaningful entries.
 
 \subsubsection{Type definition}
 <<Subevents: public>>=
   public :: subevt_t
 <<Subevents: types>>=
   type :: subevt_t
      private
      integer :: n_active = 0
      type(prt_t), dimension(:), allocatable :: prt
    contains
    <<Subevents: subevt: TBP>>
   end type subevt_t
 
 @ %def subevt_t
 @ Initialize, allocating with size zero (default) or given size.  The
 number of contained particles is set equal to the size.
 <<Subevents: public>>=
   public :: subevt_init
 <<Subevents: procedures>>=
   subroutine subevt_init (subevt, n_active)
     type(subevt_t), intent(out) :: subevt
     integer, intent(in), optional :: n_active
     if (present (n_active))  subevt%n_active = n_active
     allocate (subevt%prt (subevt%n_active))
   end subroutine subevt_init
 
 @ %def subevt_init
 @ (Re-)allocate the subevent with some given size.  If the size
 is greater than the previous one, do a real reallocation.  Otherwise,
 just reset the recorded size. Contents are untouched, but become
 invalid.
 <<Subevents: public>>=
   public :: subevt_reset
 <<Subevents: procedures>>=
   subroutine subevt_reset (subevt, n_active)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: n_active
     subevt%n_active = n_active
     if (subevt%n_active > size (subevt%prt)) then
        deallocate (subevt%prt)
        allocate (subevt%prt (subevt%n_active))
     end if
   end subroutine subevt_reset
 
 @ %def subevt_reset
 @ Output.  No prefix for the headline 'subevt', because this will usually be
 printed appending to a previous line.
 <<Subevents: public>>=
   public :: subevt_write
 <<Subevents: subevt: TBP>>=
   procedure :: write => subevt_write
 <<Subevents: procedures>>=
   subroutine subevt_write (object, unit, prefix, pacified)
     class(subevt_t), intent(in) :: object
     integer, intent(in), optional :: unit
     character(*), intent(in), optional :: prefix
     logical, intent(in), optional :: pacified
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "subevent:"
     do i = 1, object%n_active
        if (present (prefix))  write (u, "(A)", advance="no") prefix
        write (u, "(1x,I0)", advance="no")  i
        call prt_write (object%prt(i), unit = unit, testflag = pacified)
     end do
   end subroutine subevt_write
 
 @ %def subevt_write
 @ Defined assignment: transfer only meaningful entries.  This is a
 deep copy (as would be default assignment).
 <<Subevents: interfaces>>=
   interface assignment(=)
      module procedure subevt_assign
   end interface
 
 @ %def =
 <<Subevents: procedures>>=
   subroutine subevt_assign (subevt, subevt_in)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: subevt_in
     if (.not. allocated (subevt%prt)) then
        call subevt_init (subevt, subevt_in%n_active)
     else
        call subevt_reset (subevt, subevt_in%n_active)
     end if
     subevt%prt(:subevt%n_active) = subevt_in%prt(:subevt%n_active)
   end subroutine subevt_assign
 
 @ %def subevt_assign
 @
 \subsubsection{Fill contents}
 Store incoming/outgoing particles which are completely defined.
 <<Subevents: public>>=
   public :: subevt_set_beam
   public :: subevt_set_incoming
   public :: subevt_set_outgoing
   public :: subevt_set_composite
 <<Subevents: procedures>>=
   subroutine subevt_set_beam (subevt, i, pdg, p, p2, src)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: i
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in), optional :: src
     if (present (src)) then
        call prt_init_beam (subevt%prt(i), pdg, p, p2, src)
     else
        call prt_init_beam (subevt%prt(i), pdg, p, p2, [i])
     end if
   end subroutine subevt_set_beam
 
   subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: i
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in), optional :: src
     if (present (src)) then
        call prt_init_incoming (subevt%prt(i), pdg, p, p2, src)
     else
        call prt_init_incoming (subevt%prt(i), pdg, p, p2, [i])
     end if
   end subroutine subevt_set_incoming
 
   subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: i
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: p2
     integer, dimension(:), intent(in), optional :: src
     if (present (src)) then
        call prt_init_outgoing (subevt%prt(i), pdg, p, p2, src)
     else
        call prt_init_outgoing (subevt%prt(i), pdg, p, p2, [i])
     end if
   end subroutine subevt_set_outgoing
 
   subroutine subevt_set_composite (subevt, i, p, src)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: i
     type(vector4_t), intent(in) :: p
     integer, dimension(:), intent(in) :: src
     call prt_init_composite (subevt%prt(i), p, src)
   end subroutine subevt_set_composite
 
 @ %def subevt_set_incoming subevt_set_outgoing subevt_set_composite
 @ Separately assign flavors, simultaneously for all incoming/outgoing
 particles.
 <<Subevents: public>>=
   public :: subevt_set_pdg_beam
   public :: subevt_set_pdg_incoming
   public :: subevt_set_pdg_outgoing
 <<Subevents: procedures>>=
   subroutine subevt_set_pdg_beam (subevt, pdg)
     type(subevt_t), intent(inout) :: subevt
     integer, dimension(:), intent(in) :: pdg
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_BEAM) then
           call prt_set_pdg (subevt%prt(i), pdg(j))
           j = j + 1
           if (j > size (pdg))  exit
        end if
     end do
   end subroutine subevt_set_pdg_beam
 
   subroutine subevt_set_pdg_incoming (subevt, pdg)
     type(subevt_t), intent(inout) :: subevt
     integer, dimension(:), intent(in) :: pdg
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_INCOMING) then
           call prt_set_pdg (subevt%prt(i), pdg(j))
           j = j + 1
           if (j > size (pdg))  exit
        end if
     end do
   end subroutine subevt_set_pdg_incoming
 
   subroutine subevt_set_pdg_outgoing (subevt, pdg)
     type(subevt_t), intent(inout) :: subevt
     integer, dimension(:), intent(in) :: pdg
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_OUTGOING) then
           call prt_set_pdg (subevt%prt(i), pdg(j))
           j = j + 1
           if (j > size (pdg))  exit
        end if
     end do
   end subroutine subevt_set_pdg_outgoing
 
 @ %def subevt_set_pdg_beam
 @ %def subevt_set_pdg_incoming
 @ %def subevt_set_pdg_outgoing
 @ Separately assign momenta, simultaneously for all incoming/outgoing
 particles.
 <<Subevents: public>>=
   public :: subevt_set_p_beam
   public :: subevt_set_p_incoming
   public :: subevt_set_p_outgoing
 <<Subevents: procedures>>=
   subroutine subevt_set_p_beam (subevt, p)
     type(subevt_t), intent(inout) :: subevt
     type(vector4_t), dimension(:), intent(in) :: p
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_BEAM) then
           call prt_set_p (subevt%prt(i), p(j))
           j = j + 1
           if (j > size (p))  exit
        end if
     end do
   end subroutine subevt_set_p_beam
 
   subroutine subevt_set_p_incoming (subevt, p)
     type(subevt_t), intent(inout) :: subevt
     type(vector4_t), dimension(:), intent(in) :: p
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_INCOMING) then
           call prt_set_p (subevt%prt(i), p(j))
           j = j + 1
           if (j > size (p))  exit
        end if
     end do
   end subroutine subevt_set_p_incoming
 
   subroutine subevt_set_p_outgoing (subevt, p)
     type(subevt_t), intent(inout) :: subevt
     type(vector4_t), dimension(:), intent(in) :: p
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_OUTGOING) then
           call prt_set_p (subevt%prt(i), p(j))
           j = j + 1
           if (j > size (p))  exit
        end if
     end do
   end subroutine subevt_set_p_outgoing
 
 @ %def subevt_set_p_beam
 @ %def subevt_set_p_incoming
 @ %def subevt_set_p_outgoing
 @ Separately assign the squared invariant mass, simultaneously for all
 incoming/outgoing particles.
 <<Subevents: public>>=
   public :: subevt_set_p2_beam
   public :: subevt_set_p2_incoming
   public :: subevt_set_p2_outgoing
 <<Subevents: procedures>>=
   subroutine subevt_set_p2_beam (subevt, p2)
     type(subevt_t), intent(inout) :: subevt
     real(default), dimension(:), intent(in) :: p2
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_BEAM) then
           call prt_set_p2 (subevt%prt(i), p2(j))
           j = j + 1
           if (j > size (p2))  exit
        end if
     end do
   end subroutine subevt_set_p2_beam
 
   subroutine subevt_set_p2_incoming (subevt, p2)
     type(subevt_t), intent(inout) :: subevt
     real(default), dimension(:), intent(in) :: p2
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_INCOMING) then
           call prt_set_p2 (subevt%prt(i), p2(j))
           j = j + 1
           if (j > size (p2))  exit
        end if
     end do
   end subroutine subevt_set_p2_incoming
 
   subroutine subevt_set_p2_outgoing (subevt, p2)
     type(subevt_t), intent(inout) :: subevt
     real(default), dimension(:), intent(in) :: p2
     integer :: i, j
     j = 1
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_OUTGOING) then
           call prt_set_p2 (subevt%prt(i), p2(j))
           j = j + 1
           if (j > size (p2))  exit
        end if
     end do
   end subroutine subevt_set_p2_outgoing
 
 @ %def subevt_set_p2_beam
 @ %def subevt_set_p2_incoming
 @ %def subevt_set_p2_outgoing
 @ Set polarization for an entry
 <<Subevents: public>>=
   public :: subevt_polarize
 <<Subevents: procedures>>=
   subroutine subevt_polarize (subevt, i, h)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: i, h
     call prt_polarize (subevt%prt(i), h)
   end subroutine subevt_polarize
 
 @ %def subevt_polarize
 @ Set color-flow indices for an entry
 <<Subevents: public>>=
   public :: subevt_colorize
 <<Subevents: procedures>>=
   subroutine subevt_colorize (subevt, i, col, acl)
     type(subevt_t), intent(inout) :: subevt
     integer, intent(in) :: i, col, acl
     if (col > 0 .and. acl > 0) then
        call prt_colorize (subevt%prt(i), [col], [acl])
     else if (col > 0) then
        call prt_colorize (subevt%prt(i), [col], [integer ::])
     else if (acl > 0) then
        call prt_colorize (subevt%prt(i), [integer ::], [acl])
     else
        call prt_colorize (subevt%prt(i), [integer ::], [integer ::])
     end if
   end subroutine subevt_colorize
 
 @ %def subevt_colorize
 @
 \subsubsection{Accessing contents}
 Return true if the subevent has entries.
 <<Subevents: public>>=
   public :: subevt_is_nonempty
 <<Subevents: procedures>>=
   function subevt_is_nonempty (subevt) result (flag)
     logical :: flag
     type(subevt_t), intent(in) :: subevt
     flag = subevt%n_active /= 0
   end function subevt_is_nonempty
 
 @ %def subevt_is_nonempty
 @ Return the number of entries
 <<Subevents: public>>=
   public :: subevt_get_length
 <<Subevents: procedures>>=
   function subevt_get_length (subevt) result (length)
     integer :: length
     type(subevt_t), intent(in) :: subevt
     length = subevt%n_active
   end function subevt_get_length
 
 @ %def subevt_get_length
 @ Return a specific particle.  The index is not checked for validity.
 <<Subevents: public>>=
   public :: subevt_get_prt
 <<Subevents: procedures>>=
   function subevt_get_prt (subevt, i) result (prt)
     type(prt_t) :: prt
     type(subevt_t), intent(in) :: subevt
     integer, intent(in) :: i
     prt = subevt%prt(i)
   end function subevt_get_prt
 
 @ %def subevt_get_prt
 @ Return the partonic energy squared.  We take the particles with flag
 [[PRT_INCOMING]] and compute their total invariant mass.
 <<Subevents: public>>=
   public :: subevt_get_sqrts_hat
 <<Subevents: procedures>>=
   function subevt_get_sqrts_hat (subevt) result (sqrts_hat)
     type(subevt_t), intent(in) :: subevt
     real(default) :: sqrts_hat
     type(vector4_t) :: p
     integer :: i
     do i = 1, subevt%n_active
        if (subevt%prt(i)%type == PRT_INCOMING) then
           p = p + prt_get_momentum (subevt%prt(i))
        end if
     end do
     sqrts_hat = p ** 1
   end function subevt_get_sqrts_hat
 
 @ %def subevt_get_sqrts_hat
 @ Return the number of incoming (outgoing) particles, respectively.
 Beam particles or composites are not counted.
 <<Subevents: public>>=
   public :: subevt_get_n_in
   public :: subevt_get_n_out
 <<Subevents: procedures>>=
   function subevt_get_n_in (subevt) result (n_in)
     type(subevt_t), intent(in) :: subevt
     integer :: n_in
     n_in = count (subevt%prt(:subevt%n_active)%type == PRT_INCOMING)
   end function subevt_get_n_in
 
   function subevt_get_n_out (subevt) result (n_out)
     type(subevt_t), intent(in) :: subevt
     integer :: n_out
     n_out = count (subevt%prt(:subevt%n_active)%type == PRT_OUTGOING)
   end function subevt_get_n_out
 
 @ %def subevt_get_n_in
 @ %def subevt_get_n_out
 @
 <<Subevents: interfaces>>=
   interface c_prt
      module procedure c_prt_from_subevt
      module procedure c_prt_array_from_subevt
   end interface
 
 @ %def c_prt
 <<Subevents: procedures>>=
   function c_prt_from_subevt (subevt, i) result (c_prt)
     type(c_prt_t) :: c_prt
     type(subevt_t), intent(in) :: subevt
     integer, intent(in) :: i
     c_prt = c_prt_from_prt (subevt%prt(i))
   end function c_prt_from_subevt
 
   function c_prt_array_from_subevt (subevt) result (c_prt_array)
     type(subevt_t), intent(in) :: subevt
     type(c_prt_t), dimension(subevt%n_active) :: c_prt_array
     c_prt_array = c_prt_from_prt (subevt%prt(1:subevt%n_active))
   end function c_prt_array_from_subevt
 
 @ %def c_prt_from_subevt
 @ %def c_prt_array_from_subevt
 @
 \subsubsection{Operations with subevents}
 The join operation joins two subevents.  When appending the
 elements of the second list, we check for each particle whether it is
 already in the first list.  If yes, it is discarded.  The result list
 should be initialized already.
 
 If a mask is present, it refers to the second subevent.
 Particles where the mask is not set are discarded.
 <<Subevents: public>>=
   public :: subevt_join
 <<Subevents: procedures>>=
   subroutine subevt_join (subevt, pl1, pl2, mask2)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl1, pl2
     logical, dimension(:), intent(in), optional :: mask2
     integer :: n1, n2, i, n
     n1 = pl1%n_active
     n2 = pl2%n_active
     call subevt_reset (subevt, n1 + n2)
     subevt%prt(:n1)   = pl1%prt(:n1)
     n = n1
     if (present (mask2)) then
        do i = 1, pl2%n_active
           if (mask2(i)) then
              if (disjoint (i)) then
                 n = n + 1
                 subevt%prt(n) = pl2%prt(i)
              end if
           end if
        end do
     else
        do i = 1, pl2%n_active
           if (disjoint (i)) then
              n = n + 1
              subevt%prt(n) = pl2%prt(i)
           end if
        end do
     end if
     subevt%n_active = n
   contains
     function disjoint (i) result (flag)
       integer, intent(in) :: i
       logical :: flag
       integer :: j
       do j = 1, pl1%n_active
          if (.not. are_disjoint (pl1%prt(j), pl2%prt(i))) then
             flag = .false.
             return
          end if
       end do
       flag = .true.
     end function disjoint
   end subroutine subevt_join
 
 @ %def subevt_join
 @ The combine operation makes a subevent whose entries are the
 result of adding (the momenta of) each pair of particles in the input
 lists.  We trace the particles from which a particles is built by
 storing a [[src]] array.  Each particle entry in the [[src]] list
 contains a list of indices which indicates its building blocks.  The
 indices refer to an original list of particles.  Index lists are sorted,
 and they contain no element more than once.
 
 We thus require that in a given pseudoparticle, each original particle
 occurs at most once.
 <<Subevents: public>>=
   public :: subevt_combine
 <<Subevents: procedures>>=
   subroutine subevt_combine (subevt, pl1, pl2, mask12)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl1, pl2
     logical, dimension(:,:), intent(in), optional :: mask12
     integer :: n1, n2, i1, i2, n, j
     logical :: ok
     n1 = pl1%n_active
     n2 = pl2%n_active
     call subevt_reset (subevt, n1 * n2)
     n = 1
     do i1 = 1, n1
        do i2 = 1, n2
           if (present (mask12)) then
              ok = mask12(i1,i2)
           else
              ok = .true.
           end if
           if (ok)  call prt_combine &
                (subevt%prt(n), pl1%prt(i1), pl2%prt(i2), ok)
           if (ok) then
              CHECK_DOUBLES: do j = 1, n - 1
                 if (subevt%prt(n) .match. subevt%prt(j)) then
                    ok = .false.;  exit CHECK_DOUBLES
                 end if
              end do CHECK_DOUBLES
              if (ok)  n = n + 1
           end if
        end do
     end do
     subevt%n_active = n - 1
   end subroutine subevt_combine
 
 @ %def subevt_combine
 @ The collect operation makes a single-entry subevent which
 results from combining (the momenta of) all particles in the input
 list.  As above, the result does not contain an original particle more
 than once; this is checked for each particle when it is collected.
 Furthermore, each entry has a mask; where the mask is false, the entry
 is dropped.
 
 (Thus, if the input particles are already composite, there is some
 chance that the result depends on the order of the input list and is
 not as expected.  This situation should be avoided.)
 <<Subevents: public>>=
   public :: subevt_collect
 <<Subevents: procedures>>=
   subroutine subevt_collect (subevt, pl1, mask1)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl1
     logical, dimension(:), intent(in) :: mask1
     type(prt_t) :: prt
     integer :: i
     logical :: ok
     call subevt_reset (subevt, 1)
     subevt%n_active = 0
     do i = 1, pl1%n_active
        if (mask1(i)) then
           if (subevt%n_active == 0) then
              subevt%n_active = 1
              subevt%prt(1) = pl1%prt(i)
           else
              call prt_combine (prt, subevt%prt(1), pl1%prt(i), ok)
              if (ok)  subevt%prt(1) = prt
           end if
        end if
     end do
   end subroutine subevt_collect
 
 @ %def subevt_collect
 @ The cluster operation is similar to [[collect]], but applies a jet
 algorithm.  The result is a subevent consisting of jets and, possibly,
 unclustered extra particles.  As above, the result does not contain an
 original particle more than once; this is checked for each particle when it is
 collected.  Furthermore, each entry has a mask; where the mask is false, the
 entry is dropped.
 
 The algorithm: first determine the (pseudo)particles that participate in the
 clustering.  They should not overlap, and the mask entry must be set.  We then
 cluster the particles, using the given jet definition.  The result particles are
 retrieved from the cluster sequence.  We still have to determine the source
 indices for each jet: for each input particle, we get the jet index.
 Accumulating the source entries for all particles that are part of a given
 jet, we derive the jet source entries.  Finally, we delete the C structures
 that have been constructed by FastJet and its interface.
 <<Subevents: public>>=
   public :: subevt_cluster
 <<Subevents: procedures>>=
-  subroutine subevt_cluster (subevt, pl1, mask1, jet_def, keep_jets)
+  subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, &
+       keep_jets, exclusive)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl1
+    real(default), intent(in) :: dcut
     logical, dimension(:), intent(in) :: mask1
     type(jet_definition_t), intent(in) :: jet_def
-    logical, intent(in) :: keep_jets
+    logical, intent(in) :: keep_jets, exclusive
     integer, dimension(:), allocatable :: map, jet_index
     type(pseudojet_t), dimension(:), allocatable :: jet_in, jet_out
     type(pseudojet_vector_t) :: jv_in, jv_out
     type(cluster_sequence_t) :: cs
     integer :: i, n_src, n_active
     call map_prt_index (pl1, mask1, n_src, map)
     n_active = count (map /= 0)
     allocate (jet_in (n_active))
     allocate (jet_index (n_active))
     do i = 1, n_active
        call jet_in(i)%init (prt_get_momentum (pl1%prt(map(i))))
     end do
     call jv_in%init (jet_in)
     call cs%init (jv_in, jet_def)
-    jv_out = cs%inclusive_jets ()
+    if (exclusive) then
+       jv_out = cs%exclusive_jets (dcut)
+    else
+       jv_out = cs%inclusive_jets ()
+    end if
     call cs%assign_jet_indices (jv_out, jet_index)
     allocate (jet_out (jv_out%size ()))
     jet_out = jv_out
     call fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map)
     do i = 1, size (jet_out)
        call jet_out(i)%final ()
     end do
     call jv_out%final ()
     call cs%final ()
     call jv_in%final ()
     do i = 1, size (jet_in)
        call jet_in(i)%final ()
     end do
   contains
     ! Uniquely combine sources and add map those new indices to the old ones
     subroutine map_prt_index (pl1, mask1, n_src, map)
       type(subevt_t), intent(in) :: pl1
       logical, dimension(:), intent(in) :: mask1
       integer, intent(out) :: n_src
       integer, dimension(:), allocatable, intent(out) :: map
       integer, dimension(:), allocatable :: src, src_tmp
       integer :: i
       allocate (src(0))
       allocate (map (pl1%n_active), source = 0)
       n_active = 0
       do i = 1, pl1%n_active
          if (.not. mask1(i)) cycle
          call combine_index_lists (src_tmp, src, pl1%prt(i)%src)
          if (.not. allocated (src_tmp)) cycle
          call move_alloc (from=src_tmp, to=src)
          n_active = n_active + 1
          map(n_active) = i
       end do
       n_src = size (src)
     end subroutine map_prt_index
     ! Retrieve source(s) of a jet and fill corresponding subevent
     subroutine fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map)
       type(subevt_t), intent(inout) :: subevt
       type(subevt_t), intent(in) :: pl1
       type(pseudojet_t), dimension(:), intent(in) :: jet_out
       integer, dimension(:), intent(in) :: jet_index
       integer, dimension(:), intent(in) :: map
       integer, intent(in) :: n_src
       integer, dimension(n_src) :: src_fill
       integer :: i, jet, k, combined_pdg, pdg, n_quarks, n_src_fill
       logical :: is_b, is_c
       call subevt_reset (subevt, size (jet_out))
       do jet = 1, size (jet_out)
          pdg = 0; src_fill = 0; n_src_fill = 0; combined_pdg = 0; n_quarks = 0
          is_b = .false.; is_c = .false.
          PARTICLE: do i = 1, size (jet_index)
             if (jet_index(i) /= jet) cycle PARTICLE
             associate (prt => pl1%prt(map(i)), n_src_prt => size(pl1%prt(map(i))%src))
               do k = 1, n_src_prt
                  src_fill(n_src_fill + k) = prt%src(k)
               end do
               n_src_fill = n_src_fill + n_src_prt
               if (is_quark (prt%pdg)) then
                  n_quarks = n_quarks + 1
                  if (.not. is_b) then
                     if (abs (prt%pdg) == 5) then
                        is_b = .true.
                        is_c = .false.
                     else if (abs (prt%pdg) == 4) then
                        is_c = .true.
                     end if
                  end if
                  if (combined_pdg == 0) combined_pdg = prt%pdg
               end if
             end associate
          end do PARTICLE
          if (keep_jets .and. n_quarks == 1) pdg = combined_pdg
          call prt_init_pseudojet (subevt%prt(jet), jet_out(jet), &
               src_fill(:n_src_fill), pdg, is_b, is_c)
       end do
     end subroutine fill_pseudojet
   end subroutine subevt_cluster
 
 @ %def subevt_cluster
 @ Return a list of all particles for which the mask is true.
 <<Subevents: public>>=
   public :: subevt_select
 <<Subevents: procedures>>=
   subroutine subevt_select (subevt, pl, mask1)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl
     logical, dimension(:), intent(in) :: mask1
     integer :: i, n
     call subevt_reset (subevt, pl%n_active)
     n = 0
     do i = 1, pl%n_active
        if (mask1(i)) then
           n = n + 1
           subevt%prt(n) = pl%prt(i)
        end if
     end do
     subevt%n_active = n
   end subroutine subevt_select
 
 @ %def subevt_select
 @ Return a subevent which consists of the single particle with
 specified [[index]].  If [[index]] is negative, count from the end.
 If it is out of bounds, return an empty list.
 <<Subevents: public>>=
   public :: subevt_extract
 <<Subevents: procedures>>=
   subroutine subevt_extract (subevt, pl, index)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl
     integer, intent(in) :: index
     if (index > 0) then
        if (index <= pl%n_active) then
           call subevt_reset (subevt, 1)
           subevt%prt(1) = pl%prt(index)
        else
           call subevt_reset (subevt, 0)
        end if
     else if (index < 0) then
        if (abs (index) <= pl%n_active) then
           call subevt_reset (subevt, 1)
           subevt%prt(1) = pl%prt(pl%n_active + 1 + index)
        else
           call subevt_reset (subevt, 0)
        end if
     else
        call subevt_reset (subevt, 0)
     end if
   end subroutine subevt_extract
 
 @ %def subevt_extract
 @ Return the list of particles sorted according to increasing values
 of the provided integer or real array.  If no array is given, sort by
 PDG value.
 <<Subevents: public>>=
   public :: subevt_sort
 <<Subevents: interfaces>>=
   interface subevt_sort
      module procedure subevt_sort_pdg
      module procedure subevt_sort_int
      module procedure subevt_sort_real
   end interface
 
 <<Subevents: procedures>>=
   subroutine subevt_sort_pdg (subevt, pl)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl
     integer :: n
     n = subevt%n_active
     call subevt_sort_int (subevt, pl, abs (3 * subevt%prt(:n)%pdg - 1))
   end subroutine subevt_sort_pdg
 
   subroutine subevt_sort_int (subevt, pl, ival)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl
     integer, dimension(:), intent(in) :: ival
     call subevt_reset (subevt, pl%n_active)
     subevt%n_active = pl%n_active
     subevt%prt = pl%prt( order (ival) )
   end subroutine subevt_sort_int
 
   subroutine subevt_sort_real (subevt, pl, rval)
     type(subevt_t), intent(inout) :: subevt
     type(subevt_t), intent(in) :: pl
     real(default), dimension(:), intent(in) :: rval
     integer :: i
     integer, dimension(size(rval)) :: idx
     call subevt_reset (subevt, pl%n_active)
     subevt%n_active = pl%n_active
     if (allocated (subevt%prt))  deallocate (subevt%prt)
     allocate (subevt%prt (size(pl%prt)))
     idx = order (rval)
     do i = 1, size (idx)
        subevt%prt(i) = pl%prt (idx(i))
     end do
   end subroutine subevt_sort_real
 
 @ %def subevt_sort
 @ Return the list of particles which have any of the specified PDG
 codes (and optionally particle type: beam, incoming, outgoing).
 <<Subevents: public>>=
   public :: subevt_select_pdg_code
 <<Subevents: procedures>>=
   subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type)
     type(subevt_t), intent(inout) :: subevt
     type(pdg_array_t), intent(in) :: aval
     type(subevt_t), intent(in) :: subevt_in
     integer, intent(in), optional :: prt_type
     integer :: n_active, n_match
     logical, dimension(:), allocatable :: mask
     integer :: i, j
     n_active = subevt_in%n_active
     allocate (mask (n_active))
     forall (i = 1:n_active) &
          mask(i) = aval .match. subevt_in%prt(i)%pdg
     if (present (prt_type)) &
          mask = mask .and. subevt_in%prt(:n_active)%type == prt_type
     n_match = count (mask)
     call subevt_reset (subevt, n_match)
     j = 0
     do i = 1, n_active
        if (mask(i)) then
           j = j + 1
           subevt%prt(j) = subevt_in%prt(i)
        end if
     end do
   end subroutine subevt_select_pdg_code
 
 @ %def subevt_select_pdg_code
 @
 \subsection{Eliminate numerical noise}
 This is useful for testing purposes: set entries to zero that are smaller in
 absolute values than a given tolerance parameter.
 
 Note: instead of setting the tolerance in terms of EPSILON
 (kind-dependent), we fix it to $10^{-16}$, which is the typical value
 for double precision.  The reason is that there are situations where
 intermediate representations (external libraries, files) are limited
 to double precision, even if the main program uses higher precision.
 <<Subevents: public>>=
   public :: pacify
 <<Subevents: interfaces>>=
   interface pacify
      module procedure pacify_prt
      module procedure pacify_subevt
   end interface pacify
 
 @ %def pacify
 <<Subevents: procedures>>=
   subroutine pacify_prt (prt)
     class(prt_t), intent(inout) :: prt
     real(default) :: e
     e = max (1E-10_default * energy (prt%p), 1E-13_default)
     call pacify (prt%p, e)
     call pacify (prt%p2, 1E3_default * e)
   end subroutine pacify_prt
 
   subroutine pacify_subevt (subevt)
     class(subevt_t), intent(inout) :: subevt
     integer :: i
     do i = 1, subevt%n_active
        call pacify (subevt%prt(i))
     end do
   end subroutine pacify_subevt
 
 @ %def pacify_prt
 @ %def pacify_subevt
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Analysis tools}
 
 This module defines structures useful for data analysis.  These
 include observables, histograms, and plots.
 
 Observables are quantities that are calculated and summed up event by
 event.  At the end, one can compute the average and error.
 
 Histograms have their bins in addition to the observable properties.
 Histograms are usually written out in tables and displayed
 graphically.
 
 In plots, each record creates its own entry in a table.  This can be
 used for scatter plots if called event by event, or for plotting
 dependencies on parameters if called once per integration run.
 
 Graphs are container for histograms and plots, which carry their own graphics
 options.
 
 The type layout is still somewhat obfuscated.  This would become much simpler
 if type extension could be used.
 <<[[analysis.f90]]>>=
 <<File header>>
 
 module analysis
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: quote_underscore, tex_format
   use system_defs, only: TAB
   use diagnostics
   use os_interface
   use ifiles
 
 <<Standard module head>>
 
 <<Analysis: public>>
 
 <<Analysis: parameters>>
 
 <<Analysis: types>>
 
 <<Analysis: interfaces>>
 
 <<Analysis: variables>>
 
 contains
 
 <<Analysis: procedures>>
 
 end module analysis
 @ %def analysis
 @
 \subsection{Output formats}
 These formats share a common field width (alignment).
 <<Analysis: parameters>>=
   character(*), parameter, public :: HISTOGRAM_HEAD_FORMAT = "1x,A15,3x"
   character(*), parameter, public :: HISTOGRAM_INTG_FORMAT = "3x,I9,3x"
   character(*), parameter, public :: HISTOGRAM_DATA_FORMAT = "ES19.12"
 
 @ %def HISTOGRAM_HEAD_FORMAT HISTOGRAM_INTG_FORMAT HISTOGRAM_DATA_FORMAT
 @
 \subsection{Graph options}
 These parameters are used for displaying data.  They apply to a whole graph,
 which may contain more than one plot element.
 
 The GAMELAN code chunks are part of both [[graph_options]] and
 [[drawing_options]].  The [[drawing_options]] copy is used in histograms and
 plots, also as graph elements.  The [[graph_options]] copy is used for
 [[graph]] objects as a whole.  Both copies are usually identical.
 <<Analysis: public>>=
   public :: graph_options_t
 <<Analysis: types>>=
   type :: graph_options_t
      private
      type(string_t) :: id
      type(string_t) :: title
      type(string_t) :: description
      type(string_t) :: x_label
      type(string_t) :: y_label
      integer :: width_mm = 130
      integer :: height_mm = 90
      logical :: x_log = .false.
      logical :: y_log = .false.
      real(default) :: x_min = 0
      real(default) :: x_max = 1
      real(default) :: y_min = 0
      real(default) :: y_max = 1
      logical :: x_min_set = .false.
      logical :: x_max_set = .false.
      logical :: y_min_set = .false.
      logical :: y_max_set = .false.
      type(string_t) :: gmlcode_bg
      type(string_t) :: gmlcode_fg
   end type graph_options_t
 
 @ %def graph_options_t
 @ Initialize the record, all strings are empty.  The limits are undefined.
 <<Analysis: public>>=
   public :: graph_options_init
 <<Analysis: procedures>>=
   subroutine graph_options_init (graph_options)
     type(graph_options_t), intent(out) :: graph_options
     graph_options%id = ""
     graph_options%title = ""
     graph_options%description = ""
     graph_options%x_label = ""
     graph_options%y_label = ""
     graph_options%gmlcode_bg = ""
     graph_options%gmlcode_fg = ""
   end subroutine graph_options_init
 
 @ %def graph_options_init
 @ Set individual options.
 <<Analysis: public>>=
   public :: graph_options_set
 <<Analysis: procedures>>=
   subroutine graph_options_set (graph_options, id, &
        title, description, x_label, y_label, width_mm, height_mm, &
        x_log, y_log, x_min, x_max, y_min, y_max, &
        gmlcode_bg, gmlcode_fg)
     type(graph_options_t), intent(inout) :: graph_options
     type(string_t), intent(in), optional :: id
     type(string_t), intent(in), optional :: title
     type(string_t), intent(in), optional :: description
     type(string_t), intent(in), optional :: x_label, y_label
     integer, intent(in), optional :: width_mm, height_mm
     logical, intent(in), optional :: x_log, y_log
     real(default), intent(in), optional :: x_min, x_max, y_min, y_max
     type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
     if (present (id))  graph_options%id = id
     if (present (title))  graph_options%title = title
     if (present (description))  graph_options%description = description
     if (present (x_label))  graph_options%x_label = x_label
     if (present (y_label))  graph_options%y_label = y_label
     if (present (width_mm))   graph_options%width_mm  = width_mm
     if (present (height_mm))  graph_options%height_mm = height_mm
     if (present (x_log))  graph_options%x_log = x_log
     if (present (y_log))  graph_options%y_log = y_log
     if (present (x_min))  graph_options%x_min = x_min
     if (present (x_max))  graph_options%x_max = x_max
     if (present (y_min))  graph_options%y_min = y_min
     if (present (y_max))  graph_options%y_max = y_max
     if (present (x_min))  graph_options%x_min_set = .true.
     if (present (x_max))  graph_options%x_max_set = .true.
     if (present (y_min))  graph_options%y_min_set = .true.
     if (present (y_max))  graph_options%y_max_set = .true.
     if (present (gmlcode_bg))  graph_options%gmlcode_bg = gmlcode_bg
     if (present (gmlcode_fg))  graph_options%gmlcode_fg = gmlcode_fg
   end subroutine graph_options_set
 
 @ %def graph_options_set
 @ Write a simple account of all options.
 <<Analysis: public>>=
   public :: graph_options_write
 <<Analysis: procedures>>=
   subroutine graph_options_write (gro, unit)
     type(graph_options_t), intent(in) :: gro
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
 1   format (A,1x,'"',A,'"')
 2   format (A,1x,L1)
 3   format (A,1x,ES19.12)
 4   format (A,1x,I0)
 5   format (A,1x,'[undefined]')
     write (u, 1)  "title       =", char (gro%title)
     write (u, 1)  "description =", char (gro%description)
     write (u, 1)  "x_label     =", char (gro%x_label)
     write (u, 1)  "y_label     =", char (gro%y_label)
     write (u, 2)  "x_log       =", gro%x_log
     write (u, 2)  "y_log       =", gro%y_log
     if (gro%x_min_set) then
        write (u, 3)  "x_min       =", gro%x_min
     else
        write (u, 5)  "x_min       ="
     end if
     if (gro%x_max_set) then
        write (u, 3)  "x_max       =", gro%x_max
     else
        write (u, 5)  "x_max       ="
     end if
     if (gro%y_min_set) then
        write (u, 3)  "y_min       =", gro%y_min
     else
        write (u, 5)  "y_min       ="
     end if
     if (gro%y_max_set) then
        write (u, 3)  "y_max       =", gro%y_max
     else
        write (u, 5)  "y_max       ="
     end if
     write (u, 4)  "width_mm    =", gro%width_mm
     write (u, 4)  "height_mm   =", gro%height_mm
     write (u, 1)  "gmlcode_bg  =", char (gro%gmlcode_bg)
     write (u, 1)  "gmlcode_fg  =", char (gro%gmlcode_fg)
   end subroutine graph_options_write
 
 @ %def graph_options_write
 @ Write a \LaTeX\ header/footer for the analysis file.
 <<Analysis: procedures>>=
   subroutine graph_options_write_tex_header (gro, unit)
     type(graph_options_t), intent(in) :: gro
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     if (gro%title /= "") then
        write (u, "(A)")
        write (u, "(A)")  "\section{" // char (gro%title) // "}"
     else
        write (u, "(A)")  "\section{" // char (quote_underscore (gro%id)) // "}"
     end if
     if (gro%description /= "") then
        write (u, "(A)")  char (gro%description)
        write (u, *)
        write (u, "(A)")  "\vspace*{\baselineskip}"
     end if
     write (u, "(A)")  "\vspace*{\baselineskip}"
     write (u, "(A)")  "\unitlength 1mm"
     write (u, "(A,I0,',',I0,A)")  &
          "\begin{gmlgraph*}(", &
          gro%width_mm, gro%height_mm, &
          ")[dat]"
   end subroutine graph_options_write_tex_header
 
   subroutine graph_options_write_tex_footer (gro, unit)
     type(graph_options_t), intent(in) :: gro
     integer, intent(in), optional :: unit
     integer :: u, width, height
     width = gro%width_mm - 10
     height = gro%height_mm - 10
     u = given_output_unit (unit)
     write (u, "(A)")  "  begingmleps ""Whizard-Logo.eps"";"
     write (u, "(A,I0,A,I0,A)")  &
          "    base := (", width, "*unitlength,", height, "*unitlength);"
     write (u, "(A)")  "    height := 9.6*unitlength;"
     write (u, "(A)")  "    width := 11.2*unitlength;"
     write (u, "(A)")  "  endgmleps;"
     write (u, "(A)")  "\end{gmlgraph*}"
   end subroutine graph_options_write_tex_footer
 
 @ %def graph_options_write_tex_header
 @ %def graph_options_write_tex_footer
 @ Return the analysis object ID.
 <<Analysis: procedures>>=
   function graph_options_get_id (gro) result (id)
     type(string_t) :: id
     type(graph_options_t), intent(in) :: gro
     id = gro%id
   end function graph_options_get_id
 
 @ %def graph_options_get_id
 @ Create an appropriate [[setup]] command (linear/log).
 <<Analysis: procedures>>=
   function graph_options_get_gml_setup (gro) result (cmd)
     type(string_t) :: cmd
     type(graph_options_t), intent(in) :: gro
     type(string_t) :: x_str, y_str
     if (gro%x_log) then
        x_str = "log"
     else
        x_str = "linear"
     end if
     if (gro%y_log) then
        y_str = "log"
     else
        y_str = "linear"
     end if
     cmd = "setup (" // x_str // ", " // y_str // ");"
   end function graph_options_get_gml_setup
 
 @ %def graph_options_get_gml_setup
 @ Return the labels in GAMELAN form.
 <<Analysis: procedures>>=
   function graph_options_get_gml_x_label (gro) result (cmd)
     type(string_t) :: cmd
     type(graph_options_t), intent(in) :: gro
     cmd = 'label.bot (<' // '<' // gro%x_label // '>' // '>, out);'
   end function graph_options_get_gml_x_label
 
   function graph_options_get_gml_y_label (gro) result (cmd)
     type(string_t) :: cmd
     type(graph_options_t), intent(in) :: gro
     cmd = 'label.ulft (<' // '<' // gro%y_label // '>' // '>, out);'
   end function graph_options_get_gml_y_label
 
 @ %def graph_options_get_gml_x_label
 @ %def graph_options_get_gml_y_label
 @ Create an appropriate [[graphrange]] statement for the given graph options.
 Where the graph options are not set, use the supplied arguments, if any,
 otherwise set the undefined value.
 <<Analysis: procedures>>=
   function graph_options_get_gml_graphrange &
        (gro, x_min, x_max, y_min, y_max) result (cmd)
     type(string_t) :: cmd
     type(graph_options_t), intent(in) :: gro
     real(default), intent(in), optional :: x_min, x_max, y_min, y_max
     type(string_t) :: x_min_str, x_max_str, y_min_str, y_max_str
     character(*), parameter :: fmt = "(ES15.8)"
     if (gro%x_min_set) then
        x_min_str = "#" // trim (adjustl (real2string (gro%x_min, fmt)))
     else if (present (x_min)) then
        x_min_str = "#" // trim (adjustl (real2string (x_min, fmt)))
     else
        x_min_str = "??"
     end if
     if (gro%x_max_set) then
        x_max_str = "#" // trim (adjustl (real2string (gro%x_max, fmt)))
     else if (present (x_max)) then
        x_max_str = "#" // trim (adjustl (real2string (x_max, fmt)))
     else
        x_max_str = "??"
     end if
     if (gro%y_min_set) then
        y_min_str = "#" // trim (adjustl (real2string (gro%y_min, fmt)))
     else if (present (y_min)) then
        y_min_str = "#" // trim (adjustl (real2string (y_min, fmt)))
     else
        y_min_str = "??"
     end if
     if (gro%y_max_set) then
        y_max_str = "#" // trim (adjustl (real2string (gro%y_max, fmt)))
     else if (present (y_max)) then
        y_max_str = "#" // trim (adjustl (real2string (y_max, fmt)))
     else
        y_max_str = "??"
     end if
     cmd = "graphrange (" // x_min_str // ", " // y_min_str // "), " &
          // "(" // x_max_str // ", " // y_max_str // ");"
   end function graph_options_get_gml_graphrange
 
 @ %def graph_options_get_gml_graphrange
 @ Get extra GAMELAN code to be executed before and after the usual drawing
 commands.
 <<Analysis: procedures>>=
   function graph_options_get_gml_bg_command (gro) result (cmd)
     type(string_t) :: cmd
     type(graph_options_t), intent(in) :: gro
     cmd = gro%gmlcode_bg
   end function graph_options_get_gml_bg_command
 
   function graph_options_get_gml_fg_command (gro) result (cmd)
     type(string_t) :: cmd
     type(graph_options_t), intent(in) :: gro
     cmd = gro%gmlcode_fg
   end function graph_options_get_gml_fg_command
 
 @ %def graph_options_get_gml_bg_command
 @ %def graph_options_get_gml_fg_command
 @ Append the header for generic data output in ifile format.  We print only
 labels, not graphics parameters.
 <<Analysis: procedures>>=
   subroutine graph_options_get_header (pl, header, comment)
     type(graph_options_t), intent(in) :: pl
     type(ifile_t), intent(inout) :: header
     type(string_t), intent(in), optional :: comment
     type(string_t) :: c
     if (present (comment)) then
        c = comment
     else
        c = ""
     end if
     call ifile_append (header, &
          c // "ID: " // pl%id)
     call ifile_append (header, &
          c // "title: " // pl%title)
     call ifile_append (header, &
          c // "description: " // pl%description)
     call ifile_append (header, &
          c // "x axis label: " // pl%x_label)
     call ifile_append (header, &
          c // "y axis label: " // pl%y_label)
   end subroutine graph_options_get_header
 
 @ %def graph_options_get_header
 @
 \subsection{Drawing options}
 These options apply to an individual graph element (histogram or plot).
 <<Analysis: public>>=
   public :: drawing_options_t
 <<Analysis: types>>=
   type :: drawing_options_t
      type(string_t) :: dataset
      logical :: with_hbars = .false.
      logical :: with_base = .false.
      logical :: piecewise = .false.
      logical :: fill = .false.
      logical :: draw = .false.
      logical :: err = .false.
      logical :: symbols = .false.
      type(string_t) :: fill_options
      type(string_t) :: draw_options
      type(string_t) :: err_options
      type(string_t) :: symbol
      type(string_t) :: gmlcode_bg
      type(string_t) :: gmlcode_fg
   end type drawing_options_t
 
 @ %def drawing_options_t
 @ Write a simple account of all options.
 <<Analysis: public>>=
   public :: drawing_options_write
 <<Analysis: procedures>>=
   subroutine drawing_options_write (dro, unit)
      type(drawing_options_t), intent(in) :: dro
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
 1   format (A,1x,'"',A,'"')
 2   format (A,1x,L1)
     write (u, 2)  "with_hbars  =", dro%with_hbars
     write (u, 2)  "with_base   =", dro%with_base
     write (u, 2)  "piecewise   =", dro%piecewise
     write (u, 2)  "fill        =", dro%fill
     write (u, 2)  "draw        =", dro%draw
     write (u, 2)  "err         =", dro%err
     write (u, 2)  "symbols     =", dro%symbols
     write (u, 1)  "fill_options=", char (dro%fill_options)
     write (u, 1)  "draw_options=", char (dro%draw_options)
     write (u, 1)  "err_options =", char (dro%err_options)
     write (u, 1)  "symbol      =", char (dro%symbol)
     write (u, 1)  "gmlcode_bg  =", char (dro%gmlcode_bg)
     write (u, 1)  "gmlcode_fg  =", char (dro%gmlcode_fg)
   end subroutine drawing_options_write
 
 @ %def drawing_options_write
 @ Init with empty strings and default options, appropriate for either
 histogram or plot.
 <<Analysis: public>>=
   public :: drawing_options_init_histogram
   public :: drawing_options_init_plot
 <<Analysis: procedures>>=
   subroutine drawing_options_init_histogram (dro)
     type(drawing_options_t), intent(out) :: dro
     dro%dataset = "dat"
     dro%with_hbars = .true.
     dro%with_base = .true.
     dro%piecewise = .true.
     dro%fill = .true.
     dro%draw = .true.
     dro%fill_options = "withcolor col.default"
     dro%draw_options = ""
     dro%err_options = ""
     dro%symbol = "fshape(circle scaled 1mm)()"
     dro%gmlcode_bg = ""
     dro%gmlcode_fg = ""
   end subroutine drawing_options_init_histogram
 
   subroutine drawing_options_init_plot (dro)
     type(drawing_options_t), intent(out) :: dro
     dro%dataset = "dat"
     dro%draw = .true.
     dro%fill_options = "withcolor col.default"
     dro%draw_options = ""
     dro%err_options = ""
     dro%symbol = "fshape(circle scaled 1mm)()"
     dro%gmlcode_bg = ""
     dro%gmlcode_fg = ""
   end subroutine drawing_options_init_plot
 
 @ %def drawing_options_init_histogram
 @ %def drawing_options_init_plot
 @ Set individual options.
 <<Analysis: public>>=
   public :: drawing_options_set
 <<Analysis: procedures>>=
   subroutine drawing_options_set (dro, dataset, &
        with_hbars, with_base, piecewise, fill, draw, err, symbols, &
        fill_options, draw_options, err_options, symbol, &
        gmlcode_bg, gmlcode_fg)
     type(drawing_options_t), intent(inout) :: dro
     type(string_t), intent(in), optional :: dataset
     logical, intent(in), optional :: with_hbars, with_base, piecewise
     logical, intent(in), optional :: fill, draw, err, symbols
     type(string_t), intent(in), optional :: fill_options, draw_options
     type(string_t), intent(in), optional :: err_options, symbol
     type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
     if (present (dataset))  dro%dataset = dataset
     if (present (with_hbars))  dro%with_hbars = with_hbars
     if (present (with_base))  dro%with_base = with_base
     if (present (piecewise))  dro%piecewise = piecewise
     if (present (fill))  dro%fill = fill
     if (present (draw))  dro%draw = draw
     if (present (err))  dro%err = err
     if (present (symbols))  dro%symbols = symbols
     if (present (fill_options))  dro%fill_options = fill_options
     if (present (draw_options))  dro%draw_options = draw_options
     if (present (err_options))  dro%err_options = err_options
     if (present (symbol))  dro%symbol = symbol
     if (present (gmlcode_bg))  dro%gmlcode_bg = gmlcode_bg
     if (present (gmlcode_fg))  dro%gmlcode_fg = gmlcode_fg
   end subroutine drawing_options_set
 
 @ %def drawing_options_set
 @ There are sepate commands for drawing the
 curve and for drawing errors.  The symbols are applied to the latter.  First
 of all, we may have to compute a baseline:
 <<Analysis: procedures>>=
   function drawing_options_get_calc_command (dro) result (cmd)
     type(string_t) :: cmd
     type(drawing_options_t), intent(in) :: dro
     if (dro%with_base) then
        cmd = "calculate " // dro%dataset // ".base (" // dro%dataset // ") " &
             // "(x, #0);"
     else
        cmd = ""
     end if
   end function drawing_options_get_calc_command
 
 @ %def drawing_options_get_calc_command
 @ Return the drawing command.
 <<Analysis: procedures>>=
   function drawing_options_get_draw_command (dro) result (cmd)
     type(string_t) :: cmd
     type(drawing_options_t), intent(in) :: dro
     if (dro%fill) then
        cmd = "fill"
     else if (dro%draw) then
        cmd = "draw"
     else
        cmd = ""
     end if
     if (dro%fill .or. dro%draw) then
        if (dro%piecewise)  cmd = cmd // " piecewise"
        if (dro%draw .and. dro%with_base)  cmd = cmd // " cyclic"
        cmd = cmd // " from (" // dro%dataset
        if (dro%with_base) then
           if (dro%piecewise) then
              cmd = cmd // ", " // dro%dataset // ".base/\"  ! "
           else
              cmd = cmd // " ~ " // dro%dataset // ".base\"  ! "
           end if
        end if
        cmd = cmd // ")"
        if (dro%fill) then
           cmd = cmd // " " // dro%fill_options
           if (dro%draw)  cmd = cmd // " outlined"
        end if
        if (dro%draw)  cmd = cmd // " " // dro%draw_options
        cmd = cmd // ";"
     end if
   end function drawing_options_get_draw_command
 
 @ %def drawing_options_get_draw_command
 @ The error command draws error bars, if any.
 <<Analysis: procedures>>=
   function drawing_options_get_err_command (dro) result (cmd)
     type(string_t) :: cmd
     type(drawing_options_t), intent(in) :: dro
     if (dro%err) then
        cmd = "draw piecewise " &
             // "from (" // dro%dataset // ".err)" &
             // " " // dro%err_options // ";"
     else
        cmd = ""
     end if
   end function drawing_options_get_err_command
 
 @ %def drawing_options_get_err_command
 @ The symbol command draws symbols, if any.
 <<Analysis: procedures>>=
   function drawing_options_get_symb_command (dro) result (cmd)
     type(string_t) :: cmd
     type(drawing_options_t), intent(in) :: dro
     if (dro%symbols) then
        cmd = "phantom" &
             // " from (" // dro%dataset // ")" &
             // " withsymbol (" // dro%symbol // ");"
     else
        cmd = ""
     end if
   end function drawing_options_get_symb_command
 
 @ %def drawing_options_get_symb_command
 @ Get extra GAMELAN code to be executed before and after the usual drawing
 commands.
 <<Analysis: procedures>>=
   function drawing_options_get_gml_bg_command (dro) result (cmd)
     type(string_t) :: cmd
     type(drawing_options_t), intent(in) :: dro
     cmd = dro%gmlcode_bg
   end function drawing_options_get_gml_bg_command
 
   function drawing_options_get_gml_fg_command (dro) result (cmd)
     type(string_t) :: cmd
     type(drawing_options_t), intent(in) :: dro
     cmd = dro%gmlcode_fg
   end function drawing_options_get_gml_fg_command
 
 @ %def drawing_options_get_gml_bg_command
 @ %def drawing_options_get_gml_fg_command
 @
 \subsection{Observables}
 The observable type holds the accumulated observable values and weight
 sums which are necessary for proper averaging.
 <<Analysis: types>>=
   type :: observable_t
      private
      real(default) :: sum_values = 0
      real(default) :: sum_squared_values = 0
      real(default) :: sum_weights = 0
      real(default) :: sum_squared_weights = 0
      integer :: count = 0
      type(string_t) :: obs_label
      type(string_t) :: obs_unit
      type(graph_options_t) :: graph_options
   end type observable_t
 
 @ %def observable_t
 @ Initialize with defined properties
 <<Analysis: procedures>>=
   subroutine observable_init (obs, obs_label, obs_unit, graph_options)
     type(observable_t), intent(out) :: obs
     type(string_t), intent(in), optional :: obs_label, obs_unit
     type(graph_options_t), intent(in), optional :: graph_options
     if (present (obs_label)) then
        obs%obs_label = obs_label
     else
        obs%obs_label = ""
     end if
     if (present (obs_unit)) then
        obs%obs_unit = obs_unit
     else
        obs%obs_unit = ""
     end if
     if (present (graph_options)) then
        obs%graph_options = graph_options
     else
        call graph_options_init (obs%graph_options)
     end if
   end subroutine observable_init
 
 @ %def observable_init
 @ Reset all numeric entries.
 <<Analysis: procedures>>=
   subroutine observable_clear (obs)
     type(observable_t), intent(inout) :: obs
     obs%sum_values = 0
     obs%sum_squared_values = 0
     obs%sum_weights = 0
     obs%sum_squared_weights = 0
     obs%count = 0
   end subroutine observable_clear
 
 @ %def observable_clear
 @ Record a a value.  Always successful for observables.
 <<Analysis: interfaces>>=
   interface observable_record_value
      module procedure observable_record_value_unweighted
      module procedure observable_record_value_weighted
   end interface
 
 <<Analysis: procedures>>=
   subroutine observable_record_value_unweighted (obs, value, success)
     type(observable_t), intent(inout) :: obs
     real(default), intent(in) :: value
     logical, intent(out), optional :: success
     obs%sum_values = obs%sum_values + value
     obs%sum_squared_values = obs%sum_squared_values + value**2
     obs%sum_weights = obs%sum_weights + 1
     obs%sum_squared_weights = obs%sum_squared_weights + 1
     obs%count = obs%count + 1
     if (present (success))  success = .true.
   end subroutine observable_record_value_unweighted
 
   subroutine observable_record_value_weighted (obs, value, weight, success)
     type(observable_t), intent(inout) :: obs
     real(default), intent(in) :: value, weight
     logical, intent(out), optional :: success
     obs%sum_values = obs%sum_values + value * weight
     obs%sum_squared_values = obs%sum_squared_values + value**2 * weight
     obs%sum_weights = obs%sum_weights + abs (weight)
     obs%sum_squared_weights = obs%sum_squared_weights + weight**2
     obs%count = obs%count + 1
     if (present (success))  success = .true.
   end subroutine observable_record_value_weighted
 
 @ %def observable_record_value
 @ Here are the statistics formulas:
 \begin{enumerate}
 \item Unweighted case:
   Given a sample of $n$ values $x_i$, the average is
   \begin{equation}
     \langle x \rangle = \frac{\sum x_i}{n}
   \end{equation}
   and the error estimate
   \begin{align}
     \Delta x &= \sqrt{\frac{1}{n-1}\langle{\sum(x_i - \langle x\rangle)^2}}
     \\
     &= \sqrt{\frac{1}{n-1}
              \left(\frac{\sum x_i^2}{n} - \frac{(\sum x_i)^2}{n^2}\right)}
   \end{align}
 \item Weighted case:
   Instead of weight 1, each event comes with weight $w_i$.
   \begin{equation}
     \langle x \rangle = \frac{\sum x_i w_i}{\sum w_i}
   \end{equation}
   and
   \begin{equation}
     \Delta x
     = \sqrt{\frac{1}{n-1}
             \left(\frac{\sum x_i^2 w_i}{\sum w_i}
                   - \frac{(\sum x_i w_i)^2}{(\sum w_i)^2}\right)}
   \end{equation}
   For $w_i=1$, this specializes to the previous formula.
 \end{enumerate}
 <<Analysis: procedures>>=
   function observable_get_n_entries (obs) result (n)
     integer :: n
     type(observable_t), intent(in) :: obs
     n = obs%count
   end function observable_get_n_entries
 
   function observable_get_average (obs) result (avg)
     real(default) :: avg
     type(observable_t), intent(in) :: obs
     if (obs%sum_weights /= 0) then
        avg = obs%sum_values / obs%sum_weights
     else
        avg = 0
     end if
   end function observable_get_average
 
   function observable_get_error (obs) result (err)
     real(default) :: err
     type(observable_t), intent(in) :: obs
     real(default) :: var, n
     if (obs%sum_weights /= 0) then
        select case (obs%count)
        case (0:1)
           err = 0
        case default
           n = obs%count
           var = obs%sum_squared_values / obs%sum_weights &
                 - (obs%sum_values / obs%sum_weights) ** 2
           err = sqrt (max (var, 0._default) / (n - 1))
        end select
     else
        err = 0
     end if
   end function observable_get_error
 
 @ %def observable_get_n_entries
 @ %def observable_get_sum
 @ %def observable_get_average
 @ %def observable_get_error
 @ Write label and/or physical unit to a string.
 <<Analysis: procedures>>=
   function observable_get_label (obs, wl, wu) result (string)
     type(string_t) :: string
     type(observable_t), intent(in) :: obs
     logical, intent(in) :: wl, wu
     type(string_t) :: obs_label, obs_unit
     if (wl) then
        if (obs%obs_label /= "") then
           obs_label = obs%obs_label
        else
           obs_label = "\textrm{Observable}"
        end if
     else
        obs_label = ""
     end if
     if (wu) then
        if (obs%obs_unit /= "") then
           if (wl) then
              obs_unit = "\;[" // obs%obs_unit // "]"
           else
              obs_unit = obs%obs_unit
           end if
        else
           obs_unit = ""
        end if
     else
        obs_unit = ""
     end if
     string = obs_label // obs_unit
   end function observable_get_label
 
 @ %def observable_get_label
 @
 \subsection{Output}
 <<Analysis: procedures>>=
   subroutine observable_write (obs, unit)
     type(observable_t), intent(in) :: obs
     integer, intent(in), optional :: unit
     real(default) :: avg, err, relerr
     integer :: n
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     avg = observable_get_average (obs)
     err = observable_get_error (obs)
     if (avg /= 0) then
        relerr = err / abs (avg)
     else
        relerr = 0
     end if
     n = observable_get_n_entries (obs)
     if (obs%graph_options%title /= "") then
        write (u, "(A,1x,3A)") &
             "title       =", '"', char (obs%graph_options%title), '"'
     end if
     if (obs%graph_options%title /= "") then
        write (u, "(A,1x,3A)") &
             "description =", '"', char (obs%graph_options%description), '"'
     end if
     write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") &
          "average     =", avg
     call write_unit ()
     write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") &
          "error[abs]  =", err
     call write_unit ()
     write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")") &
          "error[rel]  =", relerr
     write (u, "(A,1x,I0)") &
          "n_entries   =", n
   contains
     subroutine write_unit ()
       if (obs%obs_unit /= "") then
          write (u, "(1x,A)")  char (obs%obs_unit)
       else
          write (u, *)
       end if
     end subroutine write_unit
   end subroutine observable_write
 
 @ %def observable_write
 @ \LaTeX\ output.
 <<Analysis: procedures>>=
   subroutine observable_write_driver (obs, unit, write_heading)
     type(observable_t), intent(in) :: obs
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: write_heading
     real(default) :: avg, err
     integer :: n_digits
     logical :: heading
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     heading = .true.;  if (present (write_heading))  heading = write_heading
     avg = observable_get_average (obs)
     err = observable_get_error (obs)
     if (avg /= 0 .and. err /= 0) then
        n_digits = max (2, 2 - int (log10 (abs (err / real (avg, default)))))
     else if (avg /= 0) then
        n_digits = 100
     else
        n_digits = 1
     end if
     if (heading) then
        write (u, "(A)")
        if (obs%graph_options%title /= "") then
           write (u, "(A)")  "\section{" // char (obs%graph_options%title) &
                // "}"
        else
           write (u, "(A)")  "\section{Observable}"
        end if
        if (obs%graph_options%description /= "") then
           write (u, "(A)")  char (obs%graph_options%description)
           write (u, *)
        end if
        write (u, "(A)")  "\begin{flushleft}"
     end if
     write (u, "(A)", advance="no")  "  $\langle{" ! $ sign
     write (u, "(A)", advance="no")  char (observable_get_label (obs, wl=.true., wu=.false.))
     write (u, "(A)", advance="no")  "}\rangle = "
     write (u, "(A)", advance="no")  char (tex_format (avg, n_digits))
     write (u, "(A)", advance="no")  "\pm"
     write (u, "(A)", advance="no")  char (tex_format (err, 2))
     write (u, "(A)", advance="no")  "\;{"
     write (u, "(A)", advance="no")  char (observable_get_label (obs, wl=.false., wu=.true.))
     write (u, "(A)")  "}"
     write (u, "(A)", advance="no")  "     \quad[n_{\text{entries}} = "
     write (u, "(I0)",advance="no")  observable_get_n_entries (obs)
     write (u, "(A)")  "]$"          ! $ fool Emacs' noweb mode
     if (heading) then
        write (u, "(A)") "\end{flushleft}"
     end if
   end subroutine observable_write_driver
 
 @ %def observable_write_driver
 @
 \subsection{Histograms}
 \subsubsection{Bins}
 <<Analysis: types>>=
   type :: bin_t
      private
      real(default) :: midpoint = 0
      real(default) :: width = 0
      real(default) :: sum_weights = 0
      real(default) :: sum_squared_weights = 0
      real(default) :: sum_excess_weights = 0
      integer :: count = 0
   end type bin_t
 
 @ %def bin_t
 <<Analysis: procedures>>=
   subroutine bin_init (bin, midpoint, width)
     type(bin_t), intent(out) :: bin
     real(default), intent(in) :: midpoint, width
     bin%midpoint = midpoint
     bin%width = width
   end subroutine bin_init
 
 @ %def bin_init
 <<Analysis: procedures>>=
   elemental subroutine bin_clear (bin)
     type(bin_t), intent(inout) :: bin
     bin%sum_weights = 0
     bin%sum_squared_weights = 0
     bin%sum_excess_weights = 0
     bin%count = 0
   end subroutine bin_clear
 
 @ %def bin_clear
 <<Analysis: procedures>>=
   subroutine bin_record_value (bin, normalize, weight, excess)
     type(bin_t), intent(inout) :: bin
     logical, intent(in) :: normalize
     real(default), intent(in) :: weight
     real(default), intent(in), optional :: excess
     real(default) :: w, e
     if (normalize) then
        if (bin%width /= 0) then
           w = weight / bin%width
           if (present (excess))  e = excess / bin%width
        else
           w = 0
           if (present (excess))  e = 0
        end if
     else
        w = weight
        if (present (excess))  e = excess
     end if
     bin%sum_weights = bin%sum_weights + abs (w)
     bin%sum_squared_weights = bin%sum_squared_weights + w ** 2
     if (present (excess)) &
          bin%sum_excess_weights = bin%sum_excess_weights + abs (e)
     bin%count = bin%count + 1
   end subroutine bin_record_value
 
 @ %def bin_record_value
 <<Analysis: procedures>>=
   function bin_get_midpoint (bin) result (x)
     real(default) :: x
     type(bin_t), intent(in) :: bin
     x = bin%midpoint
   end function bin_get_midpoint
 
   function bin_get_width (bin) result (w)
     real(default) :: w
     type(bin_t), intent(in) :: bin
     w = bin%width
   end function bin_get_width
 
   function bin_get_n_entries (bin) result (n)
     integer :: n
     type(bin_t), intent(in) :: bin
     n = bin%count
   end function bin_get_n_entries
 
   function bin_get_sum (bin) result (s)
     real(default) :: s
     type(bin_t), intent(in) :: bin
     s = bin%sum_weights
   end function bin_get_sum
 
   function bin_get_error (bin) result (err)
     real(default) :: err
     type(bin_t), intent(in) :: bin
     err = sqrt (bin%sum_squared_weights)
   end function bin_get_error
 
   function bin_get_excess (bin) result (excess)
     real(default) :: excess
     type(bin_t), intent(in) :: bin
     excess = bin%sum_excess_weights
   end function bin_get_excess
 
 @ %def bin_get_midpoint
 @ %def bin_get_width
 @ %def bin_get_n_entries
 @ %def bin_get_sum
 @ %def bin_get_error
 @ %def bin_get_excess
 <<Analysis: procedures>>=
   subroutine bin_write_header (unit)
     integer, intent(in), optional :: unit
     character(120) :: buffer
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (buffer, "(A,4(1x," //HISTOGRAM_HEAD_FORMAT // "),2x,A)") &
          "#", "bin midpoint", "value    ", "error    ", &
          "excess     ", "n"
     write (u, "(A)")  trim (buffer)
   end subroutine bin_write_header
 
   subroutine bin_write (bin, unit)
     type(bin_t), intent(in) :: bin
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "),2x,I0)") &
          bin_get_midpoint (bin), &
          bin_get_sum (bin), &
          bin_get_error (bin), &
          bin_get_excess (bin), &
          bin_get_n_entries (bin)
   end subroutine bin_write
 
 @ %def bin_write_header
 @ %def bin_write
 @
 \subsubsection{Histograms}
 <<Analysis: types>>=
   type :: histogram_t
      private
      real(default) :: lower_bound = 0
      real(default) :: upper_bound = 0
      real(default) :: width = 0
      integer :: n_bins = 0
      logical :: normalize_bins = .false.
      type(observable_t) :: obs
      type(observable_t) :: obs_within_bounds
      type(bin_t) :: underflow
      type(bin_t), dimension(:), allocatable :: bin
      type(bin_t) :: overflow
      type(graph_options_t) :: graph_options
      type(drawing_options_t) :: drawing_options
   end type histogram_t
 
 @ %def histogram_t
 @
 \subsubsection{Initializer/finalizer}
 Initialize a histogram.  We may provide either the bin width or the
 number of bins.  A finalizer is not needed, since the histogram contains no
 pointer (sub)components.
 <<Analysis: interfaces>>=
   interface histogram_init
      module procedure histogram_init_n_bins
      module procedure histogram_init_bin_width
   end interface
 
 <<Analysis: procedures>>=
   subroutine histogram_init_n_bins (h, id, &
        lower_bound, upper_bound, n_bins, normalize_bins, &
        obs_label, obs_unit, graph_options, drawing_options)
     type(histogram_t), intent(out) :: h
     type(string_t), intent(in) :: id
     real(default), intent(in) :: lower_bound, upper_bound
     integer, intent(in) :: n_bins
     logical, intent(in) :: normalize_bins
     type(string_t), intent(in), optional :: obs_label, obs_unit
     type(graph_options_t), intent(in), optional :: graph_options
     type(drawing_options_t), intent(in), optional :: drawing_options
     real(default) :: bin_width
     integer :: i
     call observable_init (h%obs_within_bounds, obs_label, obs_unit)
     call observable_init (h%obs, obs_label, obs_unit)
     h%lower_bound = lower_bound
     h%upper_bound = upper_bound
     h%n_bins = max (n_bins, 1)
     h%width = h%upper_bound - h%lower_bound
     h%normalize_bins = normalize_bins
     bin_width = h%width / h%n_bins
     allocate (h%bin (h%n_bins))
     call bin_init (h%underflow, h%lower_bound, 0._default)
     do i = 1, h%n_bins
        call bin_init (h%bin(i), &
             h%lower_bound - bin_width/2 + i * bin_width, bin_width)
     end do
     call bin_init (h%overflow, h%upper_bound, 0._default)
     if (present (graph_options)) then
        h%graph_options = graph_options
     else
        call graph_options_init (h%graph_options)
     end if
     call graph_options_set (h%graph_options, id = id)
     if (present (drawing_options)) then
        h%drawing_options = drawing_options
     else
        call drawing_options_init_histogram (h%drawing_options)
     end if
   end subroutine histogram_init_n_bins
 
   subroutine histogram_init_bin_width (h, id, &
        lower_bound, upper_bound, bin_width, normalize_bins, &
        obs_label, obs_unit, graph_options, drawing_options)
     type(histogram_t), intent(out) :: h
     type(string_t), intent(in) :: id
     real(default), intent(in) :: lower_bound, upper_bound, bin_width
     logical, intent(in) :: normalize_bins
     type(string_t), intent(in), optional :: obs_label, obs_unit
     type(graph_options_t), intent(in), optional :: graph_options
     type(drawing_options_t), intent(in), optional :: drawing_options
     integer :: n_bins
     if (bin_width /= 0) then
        n_bins = nint ((upper_bound - lower_bound) / bin_width)
     else
        n_bins = 1
     end if
     call histogram_init_n_bins (h, id, &
          lower_bound, upper_bound, n_bins, normalize_bins, &
          obs_label, obs_unit, graph_options, drawing_options)
   end subroutine histogram_init_bin_width
 
 @ %def histogram_init
 @ Initialize a histogram by copying another one.
 
 Since [[h]] has no pointer (sub)components, intrinsic assignment is
 sufficient.  Optionally, we replace the drawing options.
 <<Analysis: procedures>>=
   subroutine histogram_init_histogram (h, h_in, drawing_options)
     type(histogram_t), intent(out) :: h
     type(histogram_t), intent(in) :: h_in
     type(drawing_options_t), intent(in), optional :: drawing_options
     h = h_in
     if (present (drawing_options)) then
        h%drawing_options = drawing_options
     end if
   end subroutine histogram_init_histogram
 
 @ %def histogram_init_histogram
 @
 \subsubsection{Fill histograms}
 Clear the histogram contents, but do not modify the structure.
 <<Analysis: procedures>>=
   subroutine histogram_clear (h)
     type(histogram_t), intent(inout) :: h
     call observable_clear (h%obs)
     call observable_clear (h%obs_within_bounds)
     call bin_clear (h%underflow)
     if (allocated (h%bin))  call bin_clear (h%bin)
     call bin_clear (h%overflow)
   end subroutine histogram_clear
 
 @ %def histogram_clear
 @ Record a value.  Successful if the value is within bounds, otherwise
 it is recorded as under-/overflow.  Optionally, we may provide an
 excess weight that could be returned by the unweighting procedure.
 <<Analysis: procedures>>=
   subroutine histogram_record_value_unweighted (h, value, excess, success)
     type(histogram_t), intent(inout) :: h
     real(default), intent(in) :: value
     real(default), intent(in), optional :: excess
     logical, intent(out), optional :: success
     integer :: i_bin
     call observable_record_value (h%obs, value)
     if (h%width /= 0) then
        i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1
     else
        i_bin = 0
     end if
     if (i_bin <= 0) then
        call bin_record_value (h%underflow, .false., 1._default, excess)
        if (present (success))  success = .false.
     else if (i_bin <= h%n_bins) then
        call observable_record_value (h%obs_within_bounds, value)
        call bin_record_value &
             (h%bin(i_bin), h%normalize_bins, 1._default, excess)
        if (present (success))  success = .true.
     else
        call bin_record_value (h%overflow, .false., 1._default, excess)
        if (present (success))  success = .false.
     end if
   end subroutine histogram_record_value_unweighted
 
 @ %def histogram_record_value_unweighted
 @ Weighted events: analogous, but no excess weight.
 <<Analysis: procedures>>=
   subroutine histogram_record_value_weighted (h, value, weight, success)
     type(histogram_t), intent(inout) :: h
     real(default), intent(in) :: value, weight
     logical, intent(out), optional :: success
     integer :: i_bin
     call observable_record_value (h%obs, value, weight)
     if (h%width /= 0) then
        i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1
     else
        i_bin = 0
     end if
     if (i_bin <= 0) then
        call bin_record_value (h%underflow, .false., weight)
        if (present (success))  success = .false.
     else if (i_bin <= h%n_bins) then
        call observable_record_value (h%obs_within_bounds, value, weight)
        call bin_record_value (h%bin(i_bin), h%normalize_bins, weight)
        if (present (success))  success = .true.
     else
        call bin_record_value (h%overflow, .false., weight)
        if (present (success))  success = .false.
     end if
   end subroutine histogram_record_value_weighted
 
 @ %def histogram_record_value_weighted
 @
 \subsubsection{Access contents}
 Inherited from the observable component (all-over average etc.)
 <<Analysis: procedures>>=
   function histogram_get_n_entries (h) result (n)
     integer :: n
     type(histogram_t), intent(in) :: h
     n = observable_get_n_entries (h%obs)
   end function histogram_get_n_entries
 
   function histogram_get_average (h) result (avg)
     real(default) :: avg
     type(histogram_t), intent(in) :: h
     avg = observable_get_average (h%obs)
   end function histogram_get_average
 
   function histogram_get_error (h) result (err)
     real(default) :: err
     type(histogram_t), intent(in) :: h
     err = observable_get_error (h%obs)
   end function histogram_get_error
 
 @ %def histogram_get_n_entries
 @ %def histogram_get_average
 @ %def histogram_get_error
 @ Analogous, but applied only to events within bounds.
 <<Analysis: procedures>>=
   function histogram_get_n_entries_within_bounds (h) result (n)
     integer :: n
     type(histogram_t), intent(in) :: h
     n = observable_get_n_entries (h%obs_within_bounds)
   end function histogram_get_n_entries_within_bounds
 
   function histogram_get_average_within_bounds (h) result (avg)
     real(default) :: avg
     type(histogram_t), intent(in) :: h
     avg = observable_get_average (h%obs_within_bounds)
   end function histogram_get_average_within_bounds
 
   function histogram_get_error_within_bounds (h) result (err)
     real(default) :: err
     type(histogram_t), intent(in) :: h
     err = observable_get_error (h%obs_within_bounds)
   end function histogram_get_error_within_bounds
 
 @ %def histogram_get_n_entries_within_bounds
 @ %def histogram_get_average_within_bounds
 @ %def histogram_get_error_within_bounds
 Get the number of bins
 <<Analysis: procedures>>=
   function histogram_get_n_bins (h) result (n)
     type(histogram_t), intent(in) :: h
     integer :: n
     n = h%n_bins
   end function histogram_get_n_bins
 
 @ %def histogram_get_n_bins
 @ Check bins.  If the index is zero or above the limit, return the
 results for underflow or overflow, respectively.
 <<Analysis: procedures>>=
   function histogram_get_n_entries_for_bin (h, i) result (n)
     integer :: n
     type(histogram_t), intent(in) :: h
     integer, intent(in) :: i
     if (i <= 0) then
        n = bin_get_n_entries (h%underflow)
     else if (i <= h%n_bins) then
        n = bin_get_n_entries (h%bin(i))
     else
        n = bin_get_n_entries (h%overflow)
     end if
   end function histogram_get_n_entries_for_bin
 
   function histogram_get_sum_for_bin (h, i) result (avg)
     real(default) :: avg
     type(histogram_t), intent(in) :: h
     integer, intent(in) :: i
     if (i <= 0) then
        avg = bin_get_sum (h%underflow)
     else if (i <= h%n_bins) then
        avg = bin_get_sum (h%bin(i))
     else
        avg = bin_get_sum (h%overflow)
     end if
   end function histogram_get_sum_for_bin
 
   function histogram_get_error_for_bin (h, i) result (err)
     real(default) :: err
     type(histogram_t), intent(in) :: h
     integer, intent(in) :: i
     if (i <= 0) then
        err = bin_get_error (h%underflow)
     else if (i <= h%n_bins) then
        err = bin_get_error (h%bin(i))
     else
        err = bin_get_error (h%overflow)
     end if
   end function histogram_get_error_for_bin
 
   function histogram_get_excess_for_bin (h, i) result (err)
     real(default) :: err
     type(histogram_t), intent(in) :: h
     integer, intent(in) :: i
     if (i <= 0) then
        err = bin_get_excess (h%underflow)
     else if (i <= h%n_bins) then
        err = bin_get_excess (h%bin(i))
     else
        err = bin_get_excess (h%overflow)
     end if
   end function histogram_get_excess_for_bin
 
 @ %def histogram_get_n_entries_for_bin
 @ %def histogram_get_sum_for_bin
 @ %def histogram_get_error_for_bin
 @ %def histogram_get_excess_for_bin
 @ Return a pointer to the graph options.
 <<Analysis: procedures>>=
   function histogram_get_graph_options_ptr (h) result (ptr)
     type(graph_options_t), pointer :: ptr
     type(histogram_t), intent(in), target :: h
     ptr => h%graph_options
   end function histogram_get_graph_options_ptr
 
 @ %def histogram_get_graph_options_ptr
 @ Return a pointer to the drawing options.
 <<Analysis: procedures>>=
   function histogram_get_drawing_options_ptr (h) result (ptr)
     type(drawing_options_t), pointer :: ptr
     type(histogram_t), intent(in), target :: h
     ptr => h%drawing_options
   end function histogram_get_drawing_options_ptr
 
 @ %def histogram_get_drawing_options_ptr
 @
 \subsubsection{Output}
 <<Analysis: procedures>>=
   subroutine histogram_write (h, unit)
     type(histogram_t), intent(in) :: h
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call bin_write_header (u)
     if (allocated (h%bin)) then
        do i = 1, h%n_bins
           call bin_write (h%bin(i), u)
        end do
     end if
     write (u, "(A)")
     write (u, "(A,1x,A)")  "#", "Underflow:"
     call bin_write (h%underflow, u)
     write (u, "(A)")
     write (u, "(A,1x,A)")  "#", "Overflow:"
     call bin_write (h%overflow, u)
     write (u, "(A)")
     write (u, "(A,1x,A)")  "#", "Summary: data within bounds"
     call observable_write (h%obs_within_bounds, u)
     write (u, "(A)")
     write (u, "(A,1x,A)")  "#", "Summary: all data"
     call observable_write (h%obs, u)
     write (u, "(A)")
   end subroutine histogram_write
 
 @ %def histogram_write
 @ Write the GAMELAN reader for histogram contents.
 <<Analysis: procedures>>=
   subroutine histogram_write_gml_reader (h, filename, unit)
     type(histogram_t), intent(in) :: h
     type(string_t), intent(in) :: filename
     integer, intent(in), optional :: unit
     character(*), parameter :: fmt = "(ES15.8)"
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(2x,A)")  'fromfile "' // char (filename) // '":'
     write (u, "(4x,A)")  'key "# Histogram:";'
     write (u, "(4x,A)")  'dx := #' &
          // real2char (h%width / h%n_bins / 2, fmt) // ';'
     write (u, "(4x,A)")  'for i withinblock:'
     write (u, "(6x,A)")  'get x, y, y.d, y.n, y.e;'
     if (h%drawing_options%with_hbars) then
        write (u, "(6x,A)")  'plot (' // char (h%drawing_options%dataset) &
             // ') (x,y) hbar dx;'
     else
        write (u, "(6x,A)")  'plot (' // char (h%drawing_options%dataset) &
             // ') (x,y);'
     end if
     if (h%drawing_options%err) then
        write (u, "(6x,A)")  'plot (' // char (h%drawing_options%dataset) &
          // '.err) ' &
             // '(x,y) vbar y.d;'
     end if
     !!! Future excess options for plots
     ! write (u, "(6x,A)")  'if show_excess: ' // &
     !            & 'plot(dat.e)(x, y plus y.e) hbar dx; fi'
     write (u, "(4x,A)")  'endfor'
     write (u, "(2x,A)")  'endfrom'
   end subroutine histogram_write_gml_reader
 
 @ %def histogram_write_gml_reader
 @ \LaTeX\ and GAMELAN output.
 <<Analysis: procedures>>=
   subroutine histogram_write_gml_driver (h, filename, unit)
     type(histogram_t), intent(in) :: h
     type(string_t), intent(in) :: filename
     integer, intent(in), optional :: unit
     type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call graph_options_write_tex_header (h%graph_options, unit)
     write (u, "(2x,A)")  char (graph_options_get_gml_setup (h%graph_options))
     write (u, "(2x,A)")  char (graph_options_get_gml_graphrange &
          (h%graph_options, x_min=h%lower_bound, x_max=h%upper_bound))
     call histogram_write_gml_reader (h, filename, unit)
     calc_cmd = drawing_options_get_calc_command (h%drawing_options)
     if (calc_cmd /= "")  write (u, "(2x,A)")  char (calc_cmd)
     bg_cmd = drawing_options_get_gml_bg_command (h%drawing_options)
     if (bg_cmd /= "")  write (u, "(2x,A)")  char (bg_cmd)
     draw_cmd = drawing_options_get_draw_command (h%drawing_options)
     if (draw_cmd /= "")  write (u, "(2x,A)")  char (draw_cmd)
     err_cmd = drawing_options_get_err_command (h%drawing_options)
     if (err_cmd /= "")  write (u, "(2x,A)")  char (err_cmd)
     symb_cmd = drawing_options_get_symb_command (h%drawing_options)
     if (symb_cmd /= "")  write (u, "(2x,A)")  char (symb_cmd)
     fg_cmd = drawing_options_get_gml_fg_command (h%drawing_options)
     if (fg_cmd /= "")  write (u, "(2x,A)")  char (fg_cmd)
     write (u, "(2x,A)")  char (graph_options_get_gml_x_label (h%graph_options))
     write (u, "(2x,A)")  char (graph_options_get_gml_y_label (h%graph_options))
     call graph_options_write_tex_footer (h%graph_options, unit)
     write (u, "(A)") "\vspace*{2\baselineskip}"
     write (u, "(A)") "\begin{flushleft}"
     write (u, "(A)") "\textbf{Data within bounds:} \\"
     call observable_write_driver (h%obs_within_bounds, unit, &
                                   write_heading=.false.)
     write (u, "(A)") "\\[0.5\baselineskip]"
     write (u, "(A)") "\textbf{All data:} \\"
     call observable_write_driver (h%obs, unit, write_heading=.false.)
     write (u, "(A)") "\end{flushleft}"
   end subroutine histogram_write_gml_driver
 
 @ %def histogram_write_gml_driver
 @ Return the header for generic data output as an ifile.
 <<Analysis: procedures>>=
   subroutine histogram_get_header (h, header, comment)
     type(histogram_t), intent(in) :: h
     type(ifile_t), intent(inout) :: header
     type(string_t), intent(in), optional :: comment
     type(string_t) :: c
     if (present (comment)) then
        c = comment
     else
        c = ""
     end if
     call ifile_append (header, c // "WHIZARD histogram data")
     call graph_options_get_header (h%graph_options, header, comment)
     call ifile_append (header, &
          c // "range: " // real2string (h%lower_bound) &
          // " - " // real2string (h%upper_bound))
     call ifile_append (header, &
          c // "counts total: " &
          // int2char (histogram_get_n_entries_within_bounds (h)))
     call ifile_append (header, &
          c // "total average: " &
          // real2string (histogram_get_average_within_bounds (h)) // " +- " &
          // real2string (histogram_get_error_within_bounds (h)))
   end subroutine histogram_get_header
 
 @ %def histogram_get_header
 @
 \subsection{Plots}
 \subsubsection{Points}
 <<Analysis: types>>=
   type :: point_t
      private
      real(default) :: x = 0
      real(default) :: y = 0
      real(default) :: yerr = 0
      real(default) :: xerr = 0
      type(point_t), pointer :: next => null ()
   end type point_t
 
 @ %def point_t
 <<Analysis: interfaces>>=
   interface point_init
     module procedure point_init_contents
     module procedure point_init_point
   end interface
 <<Analysis: procedures>>=
   subroutine point_init_contents (point, x, y, yerr, xerr)
     type(point_t), intent(out) :: point
     real(default), intent(in) :: x, y
     real(default), intent(in), optional :: yerr, xerr
     point%x = x
     point%y = y
     if (present (yerr))  point%yerr = yerr
     if (present (xerr))  point%xerr = xerr
   end subroutine point_init_contents
 
   subroutine point_init_point (point, point_in)
     type(point_t), intent(out) :: point
     type(point_t), intent(in) :: point_in
     point%x = point_in%x
     point%y = point_in%y
     point%yerr = point_in%yerr
     point%xerr = point_in%xerr
   end subroutine point_init_point
 
 @ %def point_init
 <<Analysis: procedures>>=
   function point_get_x (point) result (x)
     real(default) :: x
     type(point_t), intent(in) :: point
     x = point%x
   end function point_get_x
 
   function point_get_y (point) result (y)
     real(default) :: y
     type(point_t), intent(in) :: point
     y = point%y
   end function point_get_y
 
   function point_get_xerr (point) result (xerr)
     real(default) :: xerr
     type(point_t), intent(in) :: point
     xerr = point%xerr
   end function point_get_xerr
 
   function point_get_yerr (point) result (yerr)
     real(default) :: yerr
     type(point_t), intent(in) :: point
     yerr = point%yerr
   end function point_get_yerr
 
 @ %def point_get_x
 @ %def point_get_y
 @ %def point_get_xerr
 @ %def point_get_yerr
 <<Analysis: procedures>>=
   subroutine point_write_header (unit)
     integer, intent(in) :: unit
     character(120) :: buffer
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (buffer, "(A,4(1x," // HISTOGRAM_HEAD_FORMAT // "))") &
          "#", "x       ", "y       ", "yerr     ", "xerr     "
     write (u, "(A)")  trim (buffer)
   end subroutine point_write_header
 
   subroutine point_write (point, unit)
     type(point_t), intent(in) :: point
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "))") &
          point_get_x (point), &
          point_get_y (point), &
          point_get_yerr (point), &
          point_get_xerr (point)
   end subroutine point_write
 
 @ %def point_write
 @
 \subsubsection{Plots}
 <<Analysis: types>>=
   type :: plot_t
      private
      type(point_t), pointer :: first => null ()
      type(point_t), pointer :: last => null ()
      integer :: count = 0
      type(graph_options_t) :: graph_options
      type(drawing_options_t) :: drawing_options
   end type plot_t
 
 @ %def plot_t
 @
 \subsubsection{Initializer/finalizer}
 Initialize a plot.  We provide the lower and upper bound in the $x$
 direction.
 <<Analysis: interfaces>>=
   interface plot_init
      module procedure plot_init_empty
      module procedure plot_init_plot
   end interface
 <<Analysis: procedures>>=
   subroutine plot_init_empty (p, id, graph_options, drawing_options)
     type(plot_t), intent(out) :: p
     type(string_t), intent(in) :: id
     type(graph_options_t), intent(in), optional :: graph_options
     type(drawing_options_t), intent(in), optional :: drawing_options
     if (present (graph_options)) then
        p%graph_options = graph_options
     else
        call graph_options_init (p%graph_options)
     end if
     call graph_options_set (p%graph_options, id = id)
     if (present (drawing_options)) then
        p%drawing_options = drawing_options
     else
        call drawing_options_init_plot (p%drawing_options)
     end if
   end subroutine plot_init_empty
 
 @ %def plot_init
 @ Initialize a plot by copying another one, optionally merging in a new
 set of drawing options.
 
 Since [[p]] has pointer (sub)components, we have to explicitly deep-copy the
 original.
 <<Analysis: procedures>>=
   subroutine plot_init_plot (p, p_in, drawing_options)
     type(plot_t), intent(out) :: p
     type(plot_t), intent(in) :: p_in
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(point_t), pointer :: current, new
     current => p_in%first
     do while (associated (current))
        allocate (new)
        call point_init (new, current)
        if (associated (p%last)) then
           p%last%next => new
        else
           p%first => new
        end if
        p%last => new
        current => current%next
     end do
     p%count = p_in%count
     p%graph_options = p_in%graph_options
     if (present (drawing_options)) then
        p%drawing_options = drawing_options
     else
        p%drawing_options = p_in%drawing_options
     end if
   end subroutine plot_init_plot
 
 @ %def plot_init_plot
 @ Finalize the plot by deallocating the list of points.
 <<Analysis: procedures>>=
   subroutine plot_final (plot)
     type(plot_t), intent(inout) :: plot
     type(point_t), pointer :: current
     do while (associated (plot%first))
        current => plot%first
        plot%first => current%next
        deallocate (current)
     end do
     plot%last => null ()
   end subroutine plot_final
 
 @ %def plot_final
 @
 \subsubsection{Fill plots}
 Clear the plot contents, but do not modify the structure.
 <<Analysis: procedures>>=
   subroutine plot_clear (plot)
     type(plot_t), intent(inout) :: plot
     plot%count = 0
     call plot_final (plot)
   end subroutine plot_clear
 
 @ %def plot_clear
 @ Record a value.  Successful if the value is within bounds, otherwise
 it is recorded as under-/overflow.
 <<Analysis: procedures>>=
   subroutine plot_record_value (plot, x, y, yerr, xerr, success)
     type(plot_t), intent(inout) :: plot
     real(default), intent(in) :: x, y
     real(default), intent(in), optional :: yerr, xerr
     logical, intent(out), optional :: success
     type(point_t), pointer :: point
     plot%count = plot%count + 1
     allocate (point)
     call point_init (point, x, y, yerr, xerr)
     if (associated (plot%first)) then
        plot%last%next => point
     else
        plot%first => point
     end if
     plot%last => point
     if (present (success))  success = .true.
   end subroutine plot_record_value
 
 @ %def plot_record_value
 @
 \subsubsection{Access contents}
 The number of points.
 <<Analysis: procedures>>=
   function plot_get_n_entries (plot) result (n)
     integer :: n
     type(plot_t), intent(in) :: plot
     n = plot%count
   end function plot_get_n_entries
 
 @ %def plot_get_n_entries
 @ Return a pointer to the graph options.
 <<Analysis: procedures>>=
   function plot_get_graph_options_ptr (p) result (ptr)
     type(graph_options_t), pointer :: ptr
     type(plot_t), intent(in), target :: p
     ptr => p%graph_options
   end function plot_get_graph_options_ptr
 
 @ %def plot_get_graph_options_ptr
 @ Return a pointer to the drawing options.
 <<Analysis: procedures>>=
   function plot_get_drawing_options_ptr (p) result (ptr)
     type(drawing_options_t), pointer :: ptr
     type(plot_t), intent(in), target :: p
     ptr => p%drawing_options
   end function plot_get_drawing_options_ptr
 
 @ %def plot_get_drawing_options_ptr
 @
 \subsubsection{Output}
 This output format is used by the GAMELAN driver below.
 <<Analysis: procedures>>=
   subroutine plot_write (plot, unit)
     type(plot_t), intent(in) :: plot
     integer, intent(in), optional :: unit
     type(point_t), pointer :: point
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call point_write_header (u)
     point => plot%first
     do while (associated (point))
        call point_write (point, unit)
        point => point%next
     end do
     write (u, *)
     write (u, "(A,1x,A)")  "#", "Summary:"
     write (u, "(A,1x,I0)") &
          "n_entries =", plot_get_n_entries (plot)
     write (u, *)
   end subroutine plot_write
 
 @ %def plot_write
 @ Write the GAMELAN reader for plot contents.
 <<Analysis: procedures>>=
   subroutine plot_write_gml_reader (p, filename, unit)
     type(plot_t), intent(in) :: p
     type(string_t), intent(in) :: filename
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(2x,A)")  'fromfile "' // char (filename) // '":'
     write (u, "(4x,A)")  'key "# Plot:";'
     write (u, "(4x,A)")  'for i withinblock:'
     write (u, "(6x,A)")  'get x, y, y.err, x.err;'
     write (u, "(6x,A)")  'plot (' // char (p%drawing_options%dataset) &
          // ') (x,y);'
     if (p%drawing_options%err) then
        write (u, "(6x,A)")  'plot (' // char (p%drawing_options%dataset) &
             // '.err) (x,y) vbar y.err hbar x.err;'
     end if
     write (u, "(4x,A)")  'endfor'
     write (u, "(2x,A)")  'endfrom'
   end subroutine plot_write_gml_reader
 
 @ %def plot_write_gml_header
 @ \LaTeX\ and GAMELAN output.  Analogous to histogram output.
 <<Analysis: procedures>>=
   subroutine plot_write_gml_driver (p, filename, unit)
     type(plot_t), intent(in) :: p
     type(string_t), intent(in) :: filename
     integer, intent(in), optional :: unit
     type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call graph_options_write_tex_header (p%graph_options, unit)
     write (u, "(2x,A)") &
          char (graph_options_get_gml_setup (p%graph_options))
     write (u, "(2x,A)") &
          char (graph_options_get_gml_graphrange (p%graph_options))
     call plot_write_gml_reader (p, filename, unit)
     calc_cmd = drawing_options_get_calc_command (p%drawing_options)
     if (calc_cmd /= "")  write (u, "(2x,A)")  char (calc_cmd)
     bg_cmd = drawing_options_get_gml_bg_command (p%drawing_options)
     if (bg_cmd /= "")  write (u, "(2x,A)")  char (bg_cmd)
     draw_cmd = drawing_options_get_draw_command (p%drawing_options)
     if (draw_cmd /= "")  write (u, "(2x,A)")  char (draw_cmd)
     err_cmd = drawing_options_get_err_command (p%drawing_options)
     if (err_cmd /= "")  write (u, "(2x,A)")  char (err_cmd)
     symb_cmd = drawing_options_get_symb_command (p%drawing_options)
     if (symb_cmd /= "")  write (u, "(2x,A)")  char (symb_cmd)
     fg_cmd = drawing_options_get_gml_fg_command (p%drawing_options)
     if (fg_cmd /= "")  write (u, "(2x,A)")  char (fg_cmd)
     write (u, "(2x,A)")  char (graph_options_get_gml_x_label (p%graph_options))
     write (u, "(2x,A)")  char (graph_options_get_gml_y_label (p%graph_options))
     call graph_options_write_tex_footer (p%graph_options, unit)
   end subroutine plot_write_gml_driver
 
 @ %def plot_write_driver
 @ Append header for generic data output in ifile format.
 <<Analysis: procedures>>=
   subroutine plot_get_header (plot, header, comment)
     type(plot_t), intent(in) :: plot
     type(ifile_t), intent(inout) :: header
     type(string_t), intent(in), optional :: comment
     type(string_t) :: c
     if (present (comment)) then
        c = comment
     else
        c = ""
     end if
     call ifile_append (header, c // "WHIZARD plot data")
     call graph_options_get_header (plot%graph_options, header, comment)
     call ifile_append (header, &
          c // "number of points: " &
          // int2char (plot_get_n_entries (plot)))
   end subroutine plot_get_header
 
 @ %def plot_get_header
 @
 \subsection{Graphs}
 A graph is a container for several graph elements.  Each graph element is
 either a plot or a histogram.  There is an appropriate base type below
 (the [[analysis_object_t]]), but to avoid recursion, we define a separate base
 type here.  Note that there is no actual recursion: a graph is an analysis
 object, but a graph cannot contain graphs.
 
 (If we could use type extension, the implementation would be much more
 transparent.)
 
 \subsubsection{Graph elements}
 Graph elements cannot be filled by the [[record]] command directly.  The
 contents are always copied from elementary histograms or plots.
 <<Analysis: types>>=
   type :: graph_element_t
      private
      integer :: type = AN_UNDEFINED
      type(histogram_t), pointer :: h => null ()
      type(plot_t), pointer :: p => null ()
   end type graph_element_t
 
 @ %def graph_element_t
 <<Analysis: procedures>>=
   subroutine graph_element_final (el)
     type(graph_element_t), intent(inout) :: el
     select case (el%type)
     case (AN_HISTOGRAM)
        deallocate (el%h)
     case (AN_PLOT)
        call plot_final (el%p)
        deallocate (el%p)
     end select
     el%type = AN_UNDEFINED
   end subroutine graph_element_final
 
 @ %def graph_element_final
 @ Return the number of entries in the graph element:
 <<Analysis: procedures>>=
   function graph_element_get_n_entries (el) result (n)
     integer :: n
     type(graph_element_t), intent(in) :: el
     select case (el%type)
     case (AN_HISTOGRAM);  n = histogram_get_n_entries (el%h)
     case (AN_PLOT);       n = plot_get_n_entries (el%p)
     case default;         n = 0
     end select
   end function graph_element_get_n_entries
 
 @ %def graph_element_get_n_entries
 @ Return a pointer to the graph / drawing options.
 <<Analysis: procedures>>=
   function graph_element_get_graph_options_ptr (el) result (ptr)
     type(graph_options_t), pointer :: ptr
     type(graph_element_t), intent(in) :: el
     select case (el%type)
     case (AN_HISTOGRAM);  ptr => histogram_get_graph_options_ptr (el%h)
     case (AN_PLOT);       ptr => plot_get_graph_options_ptr (el%p)
     case default;         ptr => null ()
     end select
   end function graph_element_get_graph_options_ptr
 
   function graph_element_get_drawing_options_ptr (el) result (ptr)
     type(drawing_options_t), pointer :: ptr
     type(graph_element_t), intent(in) :: el
     select case (el%type)
     case (AN_HISTOGRAM);  ptr => histogram_get_drawing_options_ptr (el%h)
     case (AN_PLOT);       ptr => plot_get_drawing_options_ptr (el%p)
     case default;         ptr => null ()
     end select
   end function graph_element_get_drawing_options_ptr
 
 @ %def graph_element_get_graph_options_ptr
 @ %def graph_element_get_drawing_options_ptr
 @ Output, simple wrapper for the plot/histogram writer.
 <<Analysis: procedures>>=
   subroutine graph_element_write (el, unit)
     type(graph_element_t), intent(in) :: el
     integer, intent(in), optional :: unit
     type(graph_options_t), pointer :: gro
     type(string_t) :: id
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     gro => graph_element_get_graph_options_ptr (el)
     id = graph_options_get_id (gro)
     write (u, "(A,A)")  '#', repeat ("-", 78)
     select case (el%type)
     case (AN_HISTOGRAM)
        write (u, "(A)", advance="no")  "# Histogram: "
        write (u, "(1x,A)")  char (id)
        call histogram_write (el%h, unit)
     case (AN_PLOT)
        write (u, "(A)", advance="no")  "# Plot: "
        write (u, "(1x,A)")  char (id)
        call plot_write (el%p, unit)
     end select
   end subroutine graph_element_write
 
 @ %def graph_element_write
 <<Analysis: procedures>>=
   subroutine graph_element_write_gml_reader (el, filename, unit)
     type(graph_element_t), intent(in) :: el
     type(string_t), intent(in) :: filename
     integer, intent(in), optional :: unit
     select case (el%type)
     case (AN_HISTOGRAM);  call histogram_write_gml_reader (el%h, filename, unit)
     case (AN_PLOT);       call plot_write_gml_reader (el%p, filename, unit)
     end select
   end subroutine graph_element_write_gml_reader
 
 @ %def graph_element_write_gml_reader
 @
 \subsubsection{The graph type}
 The actual graph type contains its own [[graph_options]], which override the
 individual settings.  The [[drawing_options]] are set in the graph elements.
 This distinction motivates the separation of the two types.
 <<Analysis: types>>=
   type :: graph_t
      private
      type(graph_element_t), dimension(:), allocatable :: el
      type(graph_options_t) :: graph_options
   end type graph_t
 
 @ %def graph_t
 @
 \subsubsection{Initializer/finalizer}
 The graph is created with a definite number of elements.  The elements are
 filled one by one, optionally with modified drawing options.
 <<Analysis: procedures>>=
   subroutine graph_init (g, id, n_elements, graph_options)
     type(graph_t), intent(out) :: g
     type(string_t), intent(in) :: id
     integer, intent(in) :: n_elements
     type(graph_options_t), intent(in), optional :: graph_options
     allocate (g%el (n_elements))
     if (present (graph_options)) then
        g%graph_options = graph_options
     else
        call graph_options_init (g%graph_options)
     end if
     call graph_options_set (g%graph_options, id = id)
   end subroutine graph_init
 
 @ %def graph_init
 <<Analysis: procedures>>=
   subroutine graph_insert_histogram (g, i, h, drawing_options)
     type(graph_t), intent(inout), target :: g
     integer, intent(in) :: i
     type(histogram_t), intent(in) :: h
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(graph_options_t), pointer :: gro
     type(drawing_options_t), pointer :: dro
     type(string_t) :: id
     g%el(i)%type = AN_HISTOGRAM
     allocate (g%el(i)%h)
     call histogram_init_histogram (g%el(i)%h, h, drawing_options)
     gro => histogram_get_graph_options_ptr (g%el(i)%h)
     dro => histogram_get_drawing_options_ptr (g%el(i)%h)
     id = graph_options_get_id (gro)
     call drawing_options_set (dro, dataset = "dat." // id)
   end subroutine graph_insert_histogram
 
 @ %def graph_insert_histogram
 <<Analysis: procedures>>=
   subroutine graph_insert_plot (g, i, p, drawing_options)
     type(graph_t), intent(inout) :: g
     integer, intent(in) :: i
     type(plot_t), intent(in) :: p
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(graph_options_t), pointer :: gro
     type(drawing_options_t), pointer :: dro
     type(string_t) :: id
     g%el(i)%type = AN_PLOT
     allocate (g%el(i)%p)
     call plot_init_plot (g%el(i)%p, p, drawing_options)
     gro => plot_get_graph_options_ptr (g%el(i)%p)
     dro => plot_get_drawing_options_ptr (g%el(i)%p)
     id = graph_options_get_id (gro)
     call drawing_options_set (dro, dataset = "dat." // id)
   end subroutine graph_insert_plot
 
 @ %def graph_insert_plot
 @ Finalizer.
 <<Analysis: procedures>>=
   subroutine graph_final (g)
     type(graph_t), intent(inout) :: g
     integer :: i
     do i = 1, size (g%el)
        call graph_element_final (g%el(i))
     end do
     deallocate (g%el)
   end subroutine graph_final
 
 @ %def graph_final
 @
 \subsubsection{Access contents}
 The number of elements.
 <<Analysis: procedures>>=
   function graph_get_n_elements (graph) result (n)
     integer :: n
     type(graph_t), intent(in) :: graph
     n = size (graph%el)
   end function graph_get_n_elements
 
 @ %def graph_get_n_elements
 @ Retrieve a pointer to the drawing options of an element, so they can be
 modified.  (The [[target]] attribute is not actually needed because the
 components are pointers.)
 <<Analysis: procedures>>=
   function graph_get_drawing_options_ptr (g, i) result (ptr)
     type(drawing_options_t), pointer :: ptr
     type(graph_t), intent(in), target :: g
     integer, intent(in) :: i
     ptr => graph_element_get_drawing_options_ptr (g%el(i))
   end function graph_get_drawing_options_ptr
 
 @ %def graph_get_drawing_options_ptr
 @
 \subsubsection{Output}
 The default output format just writes histogram and plot data.
 <<Analysis: procedures>>=
   subroutine graph_write (graph, unit)
     type(graph_t), intent(in) :: graph
     integer, intent(in), optional :: unit
     integer :: i
     do i = 1, size (graph%el)
        call graph_element_write (graph%el(i), unit)
     end do
   end subroutine graph_write
 
 @ %def graph_write
 @ The GAMELAN driver is not a simple wrapper, but it writes the plot/histogram
 contents embedded the complete graph.  First, data are read in, global
 background commands next, then individual elements, then global foreground
 commands.
 <<Analysis: procedures>>=
   subroutine graph_write_gml_driver (g, filename, unit)
     type(graph_t), intent(in) :: g
     type(string_t), intent(in) :: filename
     type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
     integer, intent(in), optional :: unit
     type(drawing_options_t), pointer :: dro
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call graph_options_write_tex_header (g%graph_options, unit)
     write (u, "(2x,A)") &
          char (graph_options_get_gml_setup (g%graph_options))
     write (u, "(2x,A)") &
          char (graph_options_get_gml_graphrange (g%graph_options))
     do i = 1, size (g%el)
        call graph_element_write_gml_reader (g%el(i), filename, unit)
        calc_cmd = drawing_options_get_calc_command &
                        (graph_element_get_drawing_options_ptr (g%el(i)))
        if (calc_cmd /= "")  write (u, "(2x,A)")  char (calc_cmd)
     end do
     bg_cmd = graph_options_get_gml_bg_command (g%graph_options)
     if (bg_cmd /= "")  write (u, "(2x,A)")  char (bg_cmd)
     do i = 1, size (g%el)
        dro => graph_element_get_drawing_options_ptr (g%el(i))
        bg_cmd = drawing_options_get_gml_bg_command (dro)
        if (bg_cmd /= "")  write (u, "(2x,A)")  char (bg_cmd)
        draw_cmd = drawing_options_get_draw_command (dro)
        if (draw_cmd /= "")  write (u, "(2x,A)")  char (draw_cmd)
        err_cmd = drawing_options_get_err_command (dro)
        if (err_cmd /= "")  write (u, "(2x,A)")  char (err_cmd)
        symb_cmd = drawing_options_get_symb_command (dro)
        if (symb_cmd /= "")  write (u, "(2x,A)")  char (symb_cmd)
        fg_cmd = drawing_options_get_gml_fg_command (dro)
        if (fg_cmd /= "")  write (u, "(2x,A)")  char (fg_cmd)
     end do
     fg_cmd = graph_options_get_gml_fg_command (g%graph_options)
     if (fg_cmd /= "")  write (u, "(2x,A)")  char (fg_cmd)
     write (u, "(2x,A)")  char (graph_options_get_gml_x_label (g%graph_options))
     write (u, "(2x,A)")  char (graph_options_get_gml_y_label (g%graph_options))
     call graph_options_write_tex_footer (g%graph_options, unit)
   end subroutine graph_write_gml_driver
 
 @ %def graph_write_gml_driver
 @ Append header for generic data output in ifile format.
 <<Analysis: procedures>>=
   subroutine graph_get_header (graph, header, comment)
     type(graph_t), intent(in) :: graph
     type(ifile_t), intent(inout) :: header
     type(string_t), intent(in), optional :: comment
     type(string_t) :: c
     if (present (comment)) then
        c = comment
     else
        c = ""
     end if
     call ifile_append (header, c // "WHIZARD graph data")
     call graph_options_get_header (graph%graph_options, header, comment)
     call ifile_append (header, &
          c // "number of graph elements: " &
          // int2char (graph_get_n_elements (graph)))
   end subroutine graph_get_header
 
 @ %def graph_get_header
 @
 \subsection{Analysis objects}
 This data structure holds all observables, histograms and such that
 are currently active.  We have one global store; individual items are
 identified by their ID strings.
 
 (This should rather be coded by type extension.)
 <<Analysis: parameters>>=
   integer, parameter :: AN_UNDEFINED = 0
   integer, parameter :: AN_OBSERVABLE = 1
   integer, parameter :: AN_HISTOGRAM = 2
   integer, parameter :: AN_PLOT = 3
   integer, parameter :: AN_GRAPH = 4
 <<Analysis: public>>=
   public :: AN_UNDEFINED, AN_HISTOGRAM, AN_OBSERVABLE, AN_PLOT, AN_GRAPH
 
 @ %def AN_UNDEFINED
 @ %def AN_OBSERVABLE AN_HISTOGRAM AN_PLOT AN_GRAPH
 <<Analysis: types>>=
   type :: analysis_object_t
      private
      type(string_t) :: id
      integer :: type = AN_UNDEFINED
      type(observable_t), pointer :: obs => null ()
      type(histogram_t), pointer :: h => null ()
      type(plot_t), pointer :: p => null ()
      type(graph_t), pointer :: g => null ()
      type(analysis_object_t), pointer :: next => null ()
   end type analysis_object_t
 
 @ %def analysis_object_t
 @
 \subsubsection{Initializer/finalizer}
 Allocate with the correct type but do not fill initial values.
 <<Analysis: procedures>>=
   subroutine analysis_object_init (obj, id, type)
     type(analysis_object_t), intent(out) :: obj
     type(string_t), intent(in) :: id
     integer, intent(in) :: type
     obj%id = id
     obj%type = type
     select case (obj%type)
     case (AN_OBSERVABLE);  allocate (obj%obs)
     case (AN_HISTOGRAM);   allocate (obj%h)
     case (AN_PLOT);        allocate (obj%p)
     case (AN_GRAPH);       allocate (obj%g)
     end select
   end subroutine analysis_object_init
 
 @ %def analysis_object_init
 <<Analysis: procedures>>=
   subroutine analysis_object_final (obj)
     type(analysis_object_t), intent(inout) :: obj
     select case (obj%type)
     case (AN_OBSERVABLE)
        deallocate (obj%obs)
     case (AN_HISTOGRAM)
        deallocate (obj%h)
     case (AN_PLOT)
        call plot_final (obj%p)
        deallocate (obj%p)
     case (AN_GRAPH)
        call graph_final (obj%g)
        deallocate (obj%g)
     end select
     obj%type = AN_UNDEFINED
   end subroutine analysis_object_final
 
 @ %def analysis_object_final
 @ Clear the analysis object, i.e., reset it to its initial state.  Not
 applicable to graphs, which are always combinations of other existing
 objects.
 <<Analysis: procedures>>=
   subroutine analysis_object_clear (obj)
     type(analysis_object_t), intent(inout) :: obj
     select case (obj%type)
     case (AN_OBSERVABLE)
        call observable_clear (obj%obs)
     case (AN_HISTOGRAM)
        call histogram_clear (obj%h)
     case (AN_PLOT)
        call plot_clear (obj%p)
     end select
   end subroutine analysis_object_clear
 
 @ %def analysis_object_clear
 @
 \subsubsection{Fill with data}
 Record data.  The effect depends on the type of analysis object.
 <<Analysis: procedures>>=
   subroutine analysis_object_record_data (obj, &
        x, y, yerr, xerr, weight, excess, success)
     type(analysis_object_t), intent(inout) :: obj
     real(default), intent(in) :: x
     real(default), intent(in), optional :: y, yerr, xerr, weight, excess
     logical, intent(out), optional :: success
     select case (obj%type)
     case (AN_OBSERVABLE)
        if (present (weight)) then
           call observable_record_value_weighted (obj%obs, x, weight, success)
        else
           call observable_record_value_unweighted (obj%obs, x, success)
        end if
     case (AN_HISTOGRAM)
        if (present (weight)) then
           call histogram_record_value_weighted (obj%h, x, weight, success)
        else
           call histogram_record_value_unweighted (obj%h, x, excess, success)
        end if
     case (AN_PLOT)
        if (present (y)) then
           call plot_record_value (obj%p, x, y, yerr, xerr, success)
        else
           if (present (success))  success = .false.
        end if
     case default
        if (present (success))  success = .false.
     end select
   end subroutine analysis_object_record_data
 
 @ %def analysis_object_record_data
 @ Explicitly set the pointer to the next object in the list.
 <<Analysis: procedures>>=
   subroutine analysis_object_set_next_ptr (obj, next)
     type(analysis_object_t), intent(inout) :: obj
     type(analysis_object_t), pointer :: next
     obj%next => next
   end subroutine analysis_object_set_next_ptr
 
 @ %def analysis_object_set_next_ptr
 @
 \subsubsection{Access contents}
 Return a pointer to the next object in the list.
 <<Analysis: procedures>>=
   function analysis_object_get_next_ptr (obj) result (next)
     type(analysis_object_t), pointer :: next
     type(analysis_object_t), intent(in) :: obj
     next => obj%next
   end function analysis_object_get_next_ptr
 
 @ %def analysis_object_get_next_ptr
 @ Return data as appropriate for the object type.
 <<Analysis: procedures>>=
   function analysis_object_get_n_elements (obj) result (n)
     integer :: n
     type(analysis_object_t), intent(in) :: obj
     select case (obj%type)
     case (AN_HISTOGRAM)
        n = 1
     case (AN_PLOT)
        n = 1
     case (AN_GRAPH)
        n = graph_get_n_elements (obj%g)
     case default
        n = 0
     end select
   end function analysis_object_get_n_elements
 
   function analysis_object_get_n_entries (obj, within_bounds) result (n)
     integer :: n
     type(analysis_object_t), intent(in) :: obj
     logical, intent(in), optional :: within_bounds
     logical :: wb
     select case (obj%type)
     case (AN_OBSERVABLE)
        n = observable_get_n_entries (obj%obs)
     case (AN_HISTOGRAM)
        wb = .false.;  if (present (within_bounds)) wb = within_bounds
        if (wb) then
           n = histogram_get_n_entries_within_bounds (obj%h)
        else
           n = histogram_get_n_entries (obj%h)
        end if
     case (AN_PLOT)
        n = plot_get_n_entries (obj%p)
     case default
        n = 0
     end select
   end function analysis_object_get_n_entries
 
   function analysis_object_get_average (obj, within_bounds) result (avg)
     real(default) :: avg
     type(analysis_object_t), intent(in) :: obj
     logical, intent(in), optional :: within_bounds
     logical :: wb
     select case (obj%type)
     case (AN_OBSERVABLE)
        avg = observable_get_average (obj%obs)
     case (AN_HISTOGRAM)
        wb = .false.;  if (present (within_bounds)) wb = within_bounds
        if (wb) then
           avg = histogram_get_average_within_bounds (obj%h)
        else
           avg = histogram_get_average (obj%h)
        end if
     case default
        avg = 0
     end select
   end function analysis_object_get_average
 
   function analysis_object_get_error (obj, within_bounds) result (err)
     real(default) :: err
     type(analysis_object_t), intent(in) :: obj
     logical, intent(in), optional :: within_bounds
     logical :: wb
     select case (obj%type)
     case (AN_OBSERVABLE)
        err = observable_get_error (obj%obs)
     case (AN_HISTOGRAM)
        wb = .false.;  if (present (within_bounds)) wb = within_bounds
        if (wb) then
           err = histogram_get_error_within_bounds (obj%h)
        else
           err = histogram_get_error (obj%h)
        end if
     case default
        err = 0
     end select
   end function analysis_object_get_error
 
 @ %def analysis_object_get_n_elements
 @ %def analysis_object_get_n_entries
 @ %def analysis_object_get_average
 @ %def analysis_object_get_error
 @ Return pointers to the actual contents:
 <<Analysis: procedures>>=
   function analysis_object_get_observable_ptr (obj) result (obs)
     type(observable_t), pointer :: obs
     type(analysis_object_t), intent(in) :: obj
     select case (obj%type)
     case (AN_OBSERVABLE);  obs => obj%obs
     case default;          obs => null ()
     end select
   end function analysis_object_get_observable_ptr
 
   function analysis_object_get_histogram_ptr (obj) result (h)
     type(histogram_t), pointer :: h
     type(analysis_object_t), intent(in) :: obj
     select case (obj%type)
     case (AN_HISTOGRAM);  h => obj%h
     case default;         h => null ()
     end select
   end function analysis_object_get_histogram_ptr
 
   function analysis_object_get_plot_ptr (obj) result (plot)
     type(plot_t), pointer :: plot
     type(analysis_object_t), intent(in) :: obj
     select case (obj%type)
     case (AN_PLOT);  plot => obj%p
     case default;    plot => null ()
     end select
   end function analysis_object_get_plot_ptr
 
   function analysis_object_get_graph_ptr (obj) result (g)
     type(graph_t), pointer :: g
     type(analysis_object_t), intent(in) :: obj
     select case (obj%type)
     case (AN_GRAPH);  g => obj%g
     case default;     g => null ()
     end select
   end function analysis_object_get_graph_ptr
 
 @ %def analysis_object_get_observable_ptr
 @ %def analysis_object_get_histogram_ptr
 @ %def analysis_object_get_plot_ptr
 @ %def analysis_object_get_graph_ptr
 @ Return true if the object has a graphical representation:
 <<Analysis: procedures>>=
   function analysis_object_has_plot (obj) result (flag)
     logical :: flag
     type(analysis_object_t), intent(in) :: obj
     select case (obj%type)
     case (AN_HISTOGRAM);  flag = .true.
     case (AN_PLOT);       flag = .true.
     case (AN_GRAPH);      flag = .true.
     case default;         flag = .false.
     end select
   end function analysis_object_has_plot
 
 @ %def analysis_object_has_plot
 @
 \subsubsection{Output}
 <<Analysis: procedures>>=
   subroutine analysis_object_write (obj, unit, verbose)
     type(analysis_object_t), intent(in) :: obj
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     logical :: verb
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     verb = .false.;  if (present (verbose))  verb = verbose
     write (u, "(A)")  repeat ("#", 79)
     select case (obj%type)
     case (AN_OBSERVABLE)
        write (u, "(A)", advance="no")  "# Observable:"
     case (AN_HISTOGRAM)
        write (u, "(A)", advance="no")  "# Histogram: "
     case (AN_PLOT)
        write (u, "(A)", advance="no")  "# Plot: "
     case (AN_GRAPH)
        write (u, "(A)", advance="no")  "# Graph: "
     case default
        write (u, "(A)") "# [undefined analysis object]"
        return
     end select
     write (u, "(1x,A)")  char (obj%id)
     select case (obj%type)
     case (AN_OBSERVABLE)
        call observable_write (obj%obs, unit)
     case (AN_HISTOGRAM)
        if (verb) then
           call graph_options_write (obj%h%graph_options, unit)
           write (u, *)
           call drawing_options_write (obj%h%drawing_options, unit)
           write (u, *)
        end if
        call histogram_write (obj%h, unit)
     case (AN_PLOT)
        if (verb) then
           call graph_options_write (obj%p%graph_options, unit)
           write (u, *)
           call drawing_options_write (obj%p%drawing_options, unit)
           write (u, *)
        end if
        call plot_write (obj%p, unit)
     case (AN_GRAPH)
        call graph_write (obj%g, unit)
     end select
   end subroutine analysis_object_write
 
 @ %def analysis_object_write
 @ Write the object part of the \LaTeX\ driver file.
 <<Analysis: procedures>>=
   subroutine analysis_object_write_driver (obj, filename, unit)
     type(analysis_object_t), intent(in) :: obj
     type(string_t), intent(in) :: filename
     integer, intent(in), optional :: unit
     select case (obj%type)
     case (AN_OBSERVABLE)
        call observable_write_driver (obj%obs, unit)
     case (AN_HISTOGRAM)
        call histogram_write_gml_driver (obj%h, filename, unit)
     case (AN_PLOT)
        call plot_write_gml_driver (obj%p, filename, unit)
     case (AN_GRAPH)
        call graph_write_gml_driver (obj%g, filename, unit)
     end select
   end subroutine analysis_object_write_driver
 
 @ %def analysis_object_write_driver
 @ Return a data header for external formats, in ifile form.
 <<Analysis: procedures>>=
   subroutine analysis_object_get_header (obj, header, comment)
     type(analysis_object_t), intent(in) :: obj
     type(ifile_t), intent(inout) :: header
     type(string_t), intent(in), optional :: comment
     select case (obj%type)
     case (AN_HISTOGRAM)
        call histogram_get_header (obj%h, header, comment)
     case (AN_PLOT)
        call plot_get_header (obj%p, header, comment)
     end select
   end subroutine analysis_object_get_header
 
 @ %def analysis_object_get_header
 @
 \subsection{Analysis object iterator}
 Analysis objects are containers which have iterable data structures:
 histograms/bins and plots/points.  If they are to be treated on a common
 basis, it is useful to have an iterator which hides the implementation
 details.
 
 The iterator is used only for elementary analysis objects that contain plot
 data: histograms or plots.  It is invalid for meta-objects (graphs) and
 non-graphical objects (observables).
 <<Analysis: public>>=
   public :: analysis_iterator_t
 <<Analysis: types>>=
   type :: analysis_iterator_t
     private
     integer :: type = AN_UNDEFINED
     type(analysis_object_t), pointer :: object => null ()
     integer :: index = 1
     type(point_t), pointer :: point => null ()
   end type
 
 @ %def analysis_iterator_t
 @ The initializer places the iterator at the beginning of the analysis object.
 <<Analysis: procedures>>=
   subroutine analysis_iterator_init (iterator, object)
     type(analysis_iterator_t), intent(out) :: iterator
     type(analysis_object_t), intent(in), target :: object
     iterator%object => object
     if (associated (iterator%object)) then
        iterator%type = iterator%object%type
        select case (iterator%type)
        case (AN_PLOT)
           iterator%point => iterator%object%p%first
        end select
     end if
   end subroutine analysis_iterator_init
 
 @ %def analysis_iterator_init
 @ The iterator is valid as long as it points to an existing entry.  An
 iterator for a data object without array data (observable) is always invalid.
 <<Analysis: public>>=
   public :: analysis_iterator_is_valid
 <<Analysis: procedures>>=
   function analysis_iterator_is_valid (iterator) result (valid)
     logical :: valid
     type(analysis_iterator_t), intent(in) :: iterator
     if (associated (iterator%object)) then
        select case (iterator%type)
        case (AN_HISTOGRAM)
           valid = iterator%index <= histogram_get_n_bins (iterator%object%h)
        case (AN_PLOT)
           valid = associated (iterator%point)
        case default
           valid = .false.
        end select
     else
        valid = .false.
     end if
   end function analysis_iterator_is_valid
 
 @ %def analysis_iterator_is_valid
 @ Advance the iterator.
 <<Analysis: public>>=
   public :: analysis_iterator_advance
 <<Analysis: procedures>>=
   subroutine analysis_iterator_advance (iterator)
     type(analysis_iterator_t), intent(inout) :: iterator
     if (associated (iterator%object)) then
        select case (iterator%type)
        case (AN_PLOT)
           iterator%point => iterator%point%next
        end select
        iterator%index = iterator%index + 1
     end if
   end subroutine analysis_iterator_advance
 
 @ %def analysis_iterator_advance
 @ Retrieve the object type:
 <<Analysis: public>>=
   public :: analysis_iterator_get_type
 <<Analysis: procedures>>=
   function analysis_iterator_get_type (iterator) result (type)
     integer :: type
     type(analysis_iterator_t), intent(in) :: iterator
     type = iterator%type
   end function analysis_iterator_get_type
 
 @ %def analysis_iterator_get_type
 @ Use the iterator to retrieve data.  We implement a common routine which
 takes the data descriptors as optional arguments.  Data which do not occur in
 the selected type trigger to an error condition.
 
 The iterator must point to a valid entry.
 <<Analysis: public>>=
   public :: analysis_iterator_get_data
 <<Analysis: procedures>>=
   subroutine analysis_iterator_get_data (iterator, &
        x, y, yerr, xerr, width, excess, index, n_total)
     type(analysis_iterator_t), intent(in) :: iterator
     real(default), intent(out), optional :: x, y, yerr, xerr, width, excess
     integer, intent(out), optional :: index, n_total
     select case (iterator%type)
     case (AN_HISTOGRAM)
        if (present (x)) &
             x = bin_get_midpoint (iterator%object%h%bin(iterator%index))
        if (present (y)) &
             y = bin_get_sum (iterator%object%h%bin(iterator%index))
        if (present (yerr)) &
             yerr = bin_get_error (iterator%object%h%bin(iterator%index))
        if (present (xerr)) &
             call invalid ("histogram", "xerr")
        if (present (width)) &
             width = bin_get_width (iterator%object%h%bin(iterator%index))
        if (present (excess)) &
             excess = bin_get_excess (iterator%object%h%bin(iterator%index))
        if (present (index)) &
             index = iterator%index
        if (present (n_total)) &
             n_total = histogram_get_n_bins (iterator%object%h)
     case (AN_PLOT)
        if (present (x)) &
             x = point_get_x (iterator%point)
        if (present (y)) &
             y = point_get_y (iterator%point)
        if (present (yerr)) &
             yerr = point_get_yerr (iterator%point)
        if (present (xerr)) &
             xerr = point_get_xerr (iterator%point)
        if (present (width)) &
             call invalid ("plot", "width")
        if (present (excess)) &
             call invalid ("plot", "excess")
        if (present (index)) &
             index = iterator%index
        if (present (n_total)) &
             n_total = plot_get_n_entries (iterator%object%p)
     case default
        call msg_bug ("analysis_iterator_get_data: called " &
             // "for unsupported analysis object type")
     end select
   contains
     subroutine invalid (typestr, objstr)
       character(*), intent(in) :: typestr, objstr
       call msg_bug ("analysis_iterator_get_data: attempt to get '" &
            // objstr // "' for type '" // typestr // "'")
     end subroutine invalid
   end subroutine analysis_iterator_get_data
 
 @ %def analysis_iterator_get_data
 @
 \subsection{Analysis store}
 This data structure holds all observables, histograms and such that
 are currently active.  We have one global store; individual items are
 identified by their ID strings and types.
 <<Analysis: variables>>=
   type(analysis_store_t), save :: analysis_store
 
 @ %def analysis_store
 <<Analysis: types>>=
   type :: analysis_store_t
      private
      type(analysis_object_t), pointer :: first => null ()
      type(analysis_object_t), pointer :: last => null ()
   end type analysis_store_t
 
 @ %def analysis_store_t
 @ Delete the analysis store
 <<Analysis: public>>=
   public :: analysis_final
 <<Analysis: procedures>>=
   subroutine analysis_final ()
     type(analysis_object_t), pointer :: current
     do while (associated (analysis_store%first))
        current => analysis_store%first
        analysis_store%first => current%next
        call analysis_object_final (current)
     end do
     analysis_store%last => null ()
   end subroutine analysis_final
 
 @ %def analysis_final
 @ Append a new analysis object
 <<Analysis: procedures>>=
   subroutine analysis_store_append_object (id, type)
     type(string_t), intent(in) :: id
     integer, intent(in) :: type
     type(analysis_object_t), pointer :: obj
     allocate (obj)
     call analysis_object_init (obj, id, type)
     if (associated (analysis_store%last)) then
        analysis_store%last%next => obj
     else
        analysis_store%first => obj
     end if
     analysis_store%last => obj
   end subroutine analysis_store_append_object
 
 @ %def analysis_store_append_object
 @ Return a pointer to the analysis object with given ID.
 <<Analysis: procedures>>=
   function analysis_store_get_object_ptr (id) result (obj)
     type(string_t), intent(in) :: id
     type(analysis_object_t), pointer :: obj
     obj => analysis_store%first
     do while (associated (obj))
        if (obj%id == id)  return
        obj => obj%next
     end do
   end function analysis_store_get_object_ptr
 
 @ %def analysis_store_get_object_ptr
 @ Initialize an analysis object: either reset it if present, or append
 a new entry.
 <<Analysis: procedures>>=
   subroutine analysis_store_init_object (id, type, obj)
     type(string_t), intent(in) :: id
     integer, intent(in) :: type
     type(analysis_object_t), pointer :: obj, next
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        next => analysis_object_get_next_ptr (obj)
        call analysis_object_final (obj)
        call analysis_object_init (obj, id, type)
        call analysis_object_set_next_ptr (obj, next)
     else
        call analysis_store_append_object (id, type)
        obj => analysis_store%last
     end if
   end subroutine analysis_store_init_object
 
 @ %def analysis_store_init_object
 @ Get the type of a analysis object
 <<Analysis: public>>=
   public :: analysis_store_get_object_type
 <<Analysis: procedures>>=
   function analysis_store_get_object_type (id) result (type)
     type(string_t), intent(in) :: id
     integer :: type
     type(analysis_object_t), pointer :: object
     object => analysis_store_get_object_ptr (id)
     if (associated (object)) then
        type = object%type
     else
        type = AN_UNDEFINED
     end if
   end function analysis_store_get_object_type
 
 @ %def analysis_store_get_object_type
 @ Return the number of objects in the store.
 <<Analysis: procedures>>=
   function analysis_store_get_n_objects () result (n)
     integer :: n
     type(analysis_object_t), pointer :: current
     n = 0
     current => analysis_store%first
     do while (associated (current))
        n = n + 1
        current => current%next
     end do
   end function analysis_store_get_n_objects
 
 @ %def analysis_store_get_n_objects
 @ Allocate an array and fill it with all existing IDs.
 <<Analysis: public>>=
   public :: analysis_store_get_ids
 <<Analysis: procedures>>=
   subroutine analysis_store_get_ids (id)
     type(string_t), dimension(:), allocatable, intent(out) :: id
     type(analysis_object_t), pointer :: current
     integer :: i
     allocate (id (analysis_store_get_n_objects()))
     i = 0
     current => analysis_store%first
     do while (associated (current))
        i = i + 1
        id(i) = current%id
        current => current%next
     end do
   end subroutine analysis_store_get_ids
 
 @ %def analysis_store_get_ids
 @
 \subsection{\LaTeX\ driver file}
 Write a driver file for all objects in the store.
 <<Analysis: procedures>>=
   subroutine analysis_store_write_driver_all (filename_data, unit)
     type(string_t), intent(in) :: filename_data
     integer, intent(in), optional :: unit
     type(analysis_object_t), pointer :: obj
     call analysis_store_write_driver_header (unit)
     obj => analysis_store%first
     do while (associated (obj))
        call analysis_object_write_driver (obj, filename_data, unit)
        obj => obj%next
     end do
     call analysis_store_write_driver_footer (unit)
   end subroutine analysis_store_write_driver_all
 
 @ %def analysis_store_write_driver_all
 @
 Write a driver file for an array of objects.
 <<Analysis: procedures>>=
   subroutine analysis_store_write_driver_obj (filename_data, id, unit)
     type(string_t), intent(in) :: filename_data
     type(string_t), dimension(:), intent(in) :: id
     integer, intent(in), optional :: unit
     type(analysis_object_t), pointer :: obj
     integer :: i
     call analysis_store_write_driver_header (unit)
     do i = 1, size (id)
        obj => analysis_store_get_object_ptr (id(i))
        if (associated (obj))  &
             call analysis_object_write_driver (obj, filename_data, unit)
     end do
     call analysis_store_write_driver_footer (unit)
   end subroutine analysis_store_write_driver_obj
 
 @ %def analysis_store_write_driver_obj
 @ The beginning of the driver file.
 <<Analysis: procedures>>=
   subroutine analysis_store_write_driver_header (unit)
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, '(A)') "\documentclass[12pt]{article}"
     write (u, *)
     write (u, '(A)') "\usepackage{gamelan}"
     write (u, '(A)') "\usepackage{amsmath}"
     write (u, '(A)') "\usepackage{ifpdf}"
     write (u, '(A)') "\ifpdf"
     write (u, '(A)') "   \DeclareGraphicsRule{*}{mps}{*}{}"
     write (u, '(A)') "\else"
     write (u, '(A)') "   \DeclareGraphicsRule{*}{eps}{*}{}"
     write (u, '(A)') "\fi"
     write (u, *)
     write (u, '(A)') "\begin{document}"
     write (u, '(A)') "\begin{gmlfile}"
     write (u, *)
     write (u, '(A)') "\begin{gmlcode}"
     write (u, '(A)') "  color col.default, col.excess;"
     write (u, '(A)') "  col.default = 0.9white;"
     write (u, '(A)') "  col.excess  = red;"
     write (u, '(A)') "  boolean show_excess;"
     !!! Future excess options for plots
     ! if (mcs(1)%plot_excess .and. mcs(1)%unweighted) then
     !    write (u, '(A)') "  show_excess = true;"
     ! else
     write (u, '(A)') "  show_excess = false;"
     ! end if
     write (u, '(A)') "\end{gmlcode}"
     write (u, *)
   end subroutine analysis_store_write_driver_header
 
 @ %def analysis_store_write_driver_header
 @ The end of the driver file.
 <<Analysis: procedures>>=
   subroutine analysis_store_write_driver_footer (unit)
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write(u, *)
     write(u, '(A)') "\end{gmlfile}"
     write(u, '(A)') "\end{document}"
   end subroutine analysis_store_write_driver_footer
 
 @ %def analysis_store_write_driver_footer
 @
 \subsection{API}
 \subsubsection{Creating new objects}
 The specific versions below:
 <<Analysis: public>>=
   public :: analysis_init_observable
 <<Analysis: procedures>>=
   subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options)
     type(string_t), intent(in) :: id
     type(string_t), intent(in), optional :: obs_label, obs_unit
     type(graph_options_t), intent(in), optional :: graph_options
     type(analysis_object_t), pointer :: obj
     type(observable_t), pointer :: obs
     call analysis_store_init_object (id, AN_OBSERVABLE, obj)
     obs => analysis_object_get_observable_ptr (obj)
     call observable_init (obs, obs_label, obs_unit, graph_options)
   end subroutine analysis_init_observable
 
 @ %def analysis_init_observable
 <<Analysis: public>>=
   public :: analysis_init_histogram
 <<Analysis: interfaces>>=
   interface analysis_init_histogram
      module procedure analysis_init_histogram_n_bins
      module procedure analysis_init_histogram_bin_width
   end interface
 
 <<Analysis: procedures>>=
   subroutine analysis_init_histogram_n_bins &
        (id, lower_bound, upper_bound, n_bins, normalize_bins, &
         obs_label, obs_unit, graph_options, drawing_options)
     type(string_t), intent(in) :: id
     real(default), intent(in) :: lower_bound, upper_bound
     integer, intent(in) :: n_bins
     logical, intent(in) :: normalize_bins
     type(string_t), intent(in), optional :: obs_label, obs_unit
     type(graph_options_t), intent(in), optional :: graph_options
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(analysis_object_t), pointer :: obj
     type(histogram_t), pointer :: h
     call analysis_store_init_object (id, AN_HISTOGRAM, obj)
     h => analysis_object_get_histogram_ptr (obj)
     call histogram_init (h, id, &
          lower_bound, upper_bound, n_bins, normalize_bins, &
          obs_label, obs_unit, graph_options, drawing_options)
   end subroutine analysis_init_histogram_n_bins
 
   subroutine analysis_init_histogram_bin_width &
        (id, lower_bound, upper_bound, bin_width, normalize_bins, &
         obs_label, obs_unit, graph_options, drawing_options)
     type(string_t), intent(in) :: id
     real(default), intent(in) :: lower_bound, upper_bound, bin_width
     logical, intent(in) :: normalize_bins
     type(string_t), intent(in), optional :: obs_label, obs_unit
     type(graph_options_t), intent(in), optional :: graph_options
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(analysis_object_t), pointer :: obj
     type(histogram_t), pointer :: h
     call analysis_store_init_object (id, AN_HISTOGRAM, obj)
     h => analysis_object_get_histogram_ptr (obj)
     call histogram_init (h, id, &
          lower_bound, upper_bound, bin_width, normalize_bins, &
          obs_label, obs_unit, graph_options, drawing_options)
   end subroutine analysis_init_histogram_bin_width
 
 @ %def analysis_init_histogram_n_bins
 @ %def analysis_init_histogram_bin_width
 <<Analysis: public>>=
   public :: analysis_init_plot
 <<Analysis: procedures>>=
   subroutine analysis_init_plot (id, graph_options, drawing_options)
     type(string_t), intent(in) :: id
     type(graph_options_t), intent(in), optional :: graph_options
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(analysis_object_t), pointer :: obj
     type(plot_t), pointer :: plot
     call analysis_store_init_object (id, AN_PLOT, obj)
     plot => analysis_object_get_plot_ptr (obj)
     call plot_init (plot, id, graph_options, drawing_options)
   end subroutine analysis_init_plot
 
 @ %def analysis_init_plot
 <<Analysis: public>>=
   public :: analysis_init_graph
 <<Analysis: procedures>>=
   subroutine analysis_init_graph (id, n_elements, graph_options)
     type(string_t), intent(in) :: id
     integer, intent(in) :: n_elements
     type(graph_options_t), intent(in), optional :: graph_options
     type(analysis_object_t), pointer :: obj
     type(graph_t), pointer :: graph
     call analysis_store_init_object (id, AN_GRAPH, obj)
     graph => analysis_object_get_graph_ptr (obj)
     call graph_init (graph, id, n_elements, graph_options)
   end subroutine analysis_init_graph
 
 @ %def analysis_init_graph
 @
 \subsubsection{Recording data}
 This procedure resets an object or the whole store to its initial
 state.
 <<Analysis: public>>=
   public :: analysis_clear
 <<Analysis: interfaces>>=
   interface analysis_clear
      module procedure analysis_store_clear_obj
      module procedure analysis_store_clear_all
   end interface
 
 <<Analysis: procedures>>=
   subroutine analysis_store_clear_obj (id)
     type(string_t), intent(in) :: id
     type(analysis_object_t), pointer :: obj
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        call analysis_object_clear (obj)
     end if
   end subroutine analysis_store_clear_obj
 
   subroutine analysis_store_clear_all ()
     type(analysis_object_t), pointer :: obj
     obj => analysis_store%first
     do while (associated (obj))
        call analysis_object_clear (obj)
        obj => obj%next
     end do
   end subroutine analysis_store_clear_all
 
 @ %def analysis_clear
 @
 There is one generic recording function whose behavior depends on the
 type of analysis object.
 <<Analysis: public>>=
   public :: analysis_record_data
 <<Analysis: procedures>>=
   subroutine analysis_record_data (id, x, y, yerr, xerr, &
        weight, excess, success, exist)
     type(string_t), intent(in) :: id
     real(default), intent(in) :: x
     real(default), intent(in), optional :: y, yerr, xerr, weight, excess
     logical, intent(out), optional :: success, exist
     type(analysis_object_t), pointer :: obj
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        call analysis_object_record_data (obj, x, y, yerr, xerr, &
             weight, excess, success)
        if (present (exist))  exist = .true.
     else
        if (present (success))  success = .false.
        if (present (exist))  exist = .false.
     end if
   end subroutine analysis_record_data
 
 @ %def analysis_record_data
 @
 \subsubsection{Build a graph}
 This routine sets up the array of graph elements by copying the graph elements
 given as input.  The object must exist and already be initialized as a graph.
 <<Analysis: public>>=
   public :: analysis_fill_graph
 <<Analysis: procedures>>=
   subroutine analysis_fill_graph (id, i, id_in, drawing_options)
     type(string_t), intent(in) :: id
     integer, intent(in) :: i
     type(string_t), intent(in) :: id_in
     type(drawing_options_t), intent(in), optional :: drawing_options
     type(analysis_object_t), pointer :: obj
     type(graph_t), pointer :: g
     type(histogram_t), pointer :: h
     type(plot_t), pointer :: p
     obj => analysis_store_get_object_ptr (id)
     g => analysis_object_get_graph_ptr (obj)
     obj => analysis_store_get_object_ptr (id_in)
     if (associated (obj)) then
        select case (obj%type)
        case (AN_HISTOGRAM)
           h => analysis_object_get_histogram_ptr (obj)
           call graph_insert_histogram (g, i, h, drawing_options)
        case (AN_PLOT)
           p => analysis_object_get_plot_ptr (obj)
           call graph_insert_plot (g, i, p, drawing_options)
        case default
           call msg_error ("Graph '" // char (id) // "': Element '" &
                // char (id_in) // "' is neither histogram nor plot.")
        end select
     else
        call msg_error ("Graph '" // char (id) // "': Element '" &
                // char (id_in) // "' is undefined.")
     end if
   end subroutine analysis_fill_graph
 
 @ %def analysis_fill_graph
 @
 \subsubsection{Retrieve generic results}
 Check if a named object exists.
 <<Analysis: public>>=
   public :: analysis_exists
 <<Analysis: procedures>>=
   function analysis_exists (id) result (flag)
     type(string_t), intent(in) :: id
     logical :: flag
     type(analysis_object_t), pointer :: obj
     flag = .true.
     obj => analysis_store%first
     do while (associated (obj))
        if (obj%id == id)  return
        obj => obj%next
     end do
     flag = .false.
   end function analysis_exists
 
 @ %def analysis_exists
 @ The following functions should work for all kinds of analysis object:
 <<Analysis: public>>=
   public :: analysis_get_n_elements
   public :: analysis_get_n_entries
   public :: analysis_get_average
   public :: analysis_get_error
 <<Analysis: procedures>>=
   function analysis_get_n_elements (id) result (n)
     integer :: n
     type(string_t), intent(in) :: id
     type(analysis_object_t), pointer :: obj
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        n = analysis_object_get_n_elements (obj)
     else
        n = 0
     end if
   end function analysis_get_n_elements
 
   function analysis_get_n_entries (id, within_bounds) result (n)
     integer :: n
     type(string_t), intent(in) :: id
     logical, intent(in), optional :: within_bounds
     type(analysis_object_t), pointer :: obj
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        n = analysis_object_get_n_entries (obj, within_bounds)
     else
        n = 0
     end if
   end function analysis_get_n_entries
 
   function analysis_get_average (id, within_bounds) result (avg)
     real(default) :: avg
     type(string_t), intent(in) :: id
     type(analysis_object_t), pointer :: obj
     logical, intent(in), optional :: within_bounds
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        avg = analysis_object_get_average (obj, within_bounds)
     else
        avg = 0
     end if
   end function analysis_get_average
 
   function analysis_get_error (id, within_bounds) result (err)
     real(default) :: err
     type(string_t), intent(in) :: id
     type(analysis_object_t), pointer :: obj
     logical, intent(in), optional :: within_bounds
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        err = analysis_object_get_error (obj, within_bounds)
     else
        err = 0
     end if
   end function analysis_get_error
 
 @ %def analysis_get_n_elements
 @ %def analysis_get_n_entries
 @ %def analysis_get_average
 @ %def analysis_get_error
 @ Return true if any analysis object is graphical
 <<Analysis: public>>=
   public :: analysis_has_plots
 <<Analysis: interfaces>>=
   interface analysis_has_plots
      module procedure analysis_has_plots_any
      module procedure analysis_has_plots_obj
   end interface
 
 <<Analysis: procedures>>=
   function analysis_has_plots_any () result (flag)
     logical :: flag
     type(analysis_object_t), pointer :: obj
     flag = .false.
     obj => analysis_store%first
     do while (associated (obj))
        flag = analysis_object_has_plot (obj)
        if (flag)  return
     end do
   end function analysis_has_plots_any
 
   function analysis_has_plots_obj (id) result (flag)
     logical :: flag
     type(string_t), dimension(:), intent(in) :: id
     type(analysis_object_t), pointer :: obj
     integer :: i
     flag = .false.
     do i = 1, size (id)
        obj => analysis_store_get_object_ptr (id(i))
        if (associated (obj)) then
           flag = analysis_object_has_plot (obj)
           if (flag)  return
        end if
     end do
   end function analysis_has_plots_obj
 
 @ %def analysis_has_plots
 @
 \subsubsection{Iterators}
 Initialize an iterator for the given object.  If the object does not exist or
 has wrong type, the iterator will be invalid.
 <<Analysis: public>>=
   public :: analysis_init_iterator
 <<Analysis: procedures>>=
   subroutine analysis_init_iterator (id, iterator)
     type(string_t), intent(in) :: id
     type(analysis_iterator_t), intent(out) :: iterator
     type(analysis_object_t), pointer :: obj
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj))  call analysis_iterator_init (iterator, obj)
   end subroutine analysis_init_iterator
 
 @ %def analysis_init_iterator
 @
 \subsubsection{Output}
 <<Analysis: public>>=
   public :: analysis_write
 <<Analysis: interfaces>>=
   interface analysis_write
      module procedure analysis_write_object
      module procedure analysis_write_all
   end interface
 
 @ %def interface
 <<Analysis: procedures>>=
   subroutine analysis_write_object (id, unit, verbose)
     type(string_t), intent(in) :: id
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     type(analysis_object_t), pointer :: obj
     obj => analysis_store_get_object_ptr (id)
     if (associated (obj)) then
        call analysis_object_write (obj, unit, verbose)
     else
        call msg_error ("Analysis object '" // char (id) // "' not found")
     end if
   end subroutine analysis_write_object
 
   subroutine analysis_write_all (unit, verbose)
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     type(analysis_object_t), pointer :: obj
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     obj => analysis_store%first
     do while (associated (obj))
        call analysis_object_write (obj, unit, verbose)
        obj => obj%next
     end do
   end subroutine analysis_write_all
 
 @ %def analysis_write_object
 @ %def analysis_write_all
 <<Analysis: public>>=
   public :: analysis_write_driver
 <<Analysis: procedures>>=
   subroutine analysis_write_driver (filename_data, id, unit)
     type(string_t), intent(in) :: filename_data
     type(string_t), dimension(:), intent(in), optional :: id
     integer, intent(in), optional :: unit
     if (present (id)) then
        call analysis_store_write_driver_obj (filename_data, id, unit)
     else
        call analysis_store_write_driver_all (filename_data, unit)
     end if
   end subroutine analysis_write_driver
 
 @ %def analysis_write_driver
 <<Analysis: public>>=
   public :: analysis_compile_tex
 <<Analysis: procedures>>=
   subroutine analysis_compile_tex (file, has_gmlcode, os_data)
     type(string_t), intent(in) :: file
     logical, intent(in) :: has_gmlcode
     type(os_data_t), intent(in) :: os_data
     integer :: status
     if (os_data%event_analysis_ps) then
        call os_system_call ("make compile " // os_data%makeflags // " -f " // &
             char (file) // "_ana.makefile", status)
        if (status /= 0) then
           call msg_error ("Unable to compile analysis output file")
        end if
     else
        call msg_warning ("Skipping results display because " &
             // "latex/mpost/dvips is not available")
     end if
   end subroutine analysis_compile_tex
 
 @ %def analysis_compile_tex
 @ Write header for generic data output to an ifile.
 <<Analysis: public>>=
   public :: analysis_get_header
 <<Analysis: procedures>>=
   subroutine analysis_get_header (id, header, comment)
     type(string_t), intent(in) :: id
     type(ifile_t), intent(inout) :: header
     type(string_t), intent(in), optional :: comment
     type(analysis_object_t), pointer :: object
     object => analysis_store_get_object_ptr (id)
     if (associated (object)) then
        call analysis_object_get_header (object, header, comment)
     end if
   end subroutine analysis_get_header
 
 @ %def analysis_get_header
 @ Write a makefile in order to do the compile steps.
 <<Analysis: public>>=
   public :: analysis_write_makefile
 <<Analysis: procedures>>=
   subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data)
     type(string_t), intent(in) :: filename
     integer, intent(in) :: unit
     logical, intent(in) :: has_gmlcode
     type(os_data_t), intent(in) :: os_data
     write (unit, "(3A)")  "# WHIZARD: Makefile for analysis '", &
          char (filename), "'"
     write (unit, "(A)")  "# Automatically generated file, do not edit"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "# LaTeX setup"
     write (unit, "(A)")  "LATEX = " // char (os_data%latex)
     write (unit, "(A)")  "MPOST = " // char (os_data%mpost)
     write (unit, "(A)")  "GML = " // char (os_data%gml)
     write (unit, "(A)")  "DVIPS = " // char (os_data%dvips)
     write (unit, "(A)")  "PS2PDF = " // char (os_data%ps2pdf)
     write (unit, "(A)")  'TEX_FLAGS = "$$TEXINPUTS:' // &
          char(os_data%whizard_texpath) // '"'
     write (unit, "(A)")  'MP_FLAGS  = "$$MPINPUTS:' // &
          char(os_data%whizard_texpath) // '"'
     write (unit, "(A)")  ""
     write (unit, "(5A)")  "TEX_SOURCES = ", char (filename), ".tex"
     if (os_data%event_analysis_pdf) then
        write (unit, "(5A)")  "TEX_OBJECTS = ", char (filename), ".pdf"
     else
        write (unit, "(5A)")  "TEX_OBJECTS = ", char (filename), ".ps"
     end if
     if (os_data%event_analysis_ps) then
        if (os_data%event_analysis_pdf) then
           write (unit, "(5A)")  char (filename), ".pdf: ", &
                char (filename), ".tex"
        else
           write (unit, "(5A)")  char (filename), ".ps: ", &
                char (filename), ".tex"
        end if
        write (unit, "(5A)")  TAB, "-TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
             char (filename) // ".tex"
        if (has_gmlcode) then
           write (unit, "(5A)")  TAB, "$(GML) " // char (filename)
           write (unit, "(5A)")  TAB, "TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
             char (filename) // ".tex"
        end if
        write (unit, "(5A)")  TAB, "$(DVIPS) -o " // char (filename) // ".ps " // &
             char (filename) // ".dvi"
        if (os_data%event_analysis_pdf) then
           write (unit, "(5A)")  TAB, "$(PS2PDF) " // char (filename) // ".ps"
        end if
     end if
     write (unit, "(A)")
     write (unit, "(A)")  "compile: $(TEX_OBJECTS)"
     write (unit, "(A)")  ".PHONY: compile"
     write (unit, "(A)")
     write (unit, "(5A)")  "CLEAN_OBJECTS = ",  char (filename), ".aux"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".log"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".dvi"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".out"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".[1-9]"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9]"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9][0-9]"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".t[1-9]"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9]"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9][0-9]"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".ltp"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".mp"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".mpx"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".dvi"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".ps"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (filename), ".pdf"
     write (unit, "(A)")
     write (unit, "(A)")  "# Generic cleanup targets"
     write (unit, "(A)")  "clean-objects:"
     write (unit, "(A)")  TAB // "rm -f $(CLEAN_OBJECTS)"
     write (unit, "(A)")  ""
     write (unit, "(A)")  "clean: clean-objects"
     write (unit, "(A)")  ".PHONY: clean"
   end subroutine analysis_write_makefile
 
 @ %def analysis_write_makefile
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[analysis_ut.f90]]>>=
 <<File header>>
 
 module analysis_ut
   use unit_tests
   use analysis_uti
 
 <<Standard module head>>
 
 <<Analysis: public test>>
 
 contains
 
 <<Analysis: test driver>>
 
 end module analysis_ut
 @ %def analysis_ut
 @
 <<[[analysis_uti.f90]]>>=
 <<File header>>
 
 module analysis_uti
 
 <<Use kinds>>
 <<Use strings>>
   use format_defs, only: FMT_19
 
   use analysis
 
 <<Standard module head>>
 
 <<Analysis: test declarations>>
 
 contains
 
 <<Analysis: tests>>
 
 end module analysis_uti
 @ %def analysis_ut
 @ API: driver for the unit tests below.
 <<Analysis: public test>>=
   public :: analysis_test
 <<Analysis: test driver>>=
   subroutine analysis_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Analysis: execute tests>>
   end subroutine analysis_test
 
 @ %def analysis_test
 <<Analysis: execute tests>>=
   call test (analysis_1, "analysis_1", &
        "check elementary analysis building blocks", &
        u, results)
 <<Analysis: test declarations>>=
   public :: analysis_1
 <<Analysis: tests>>=
   subroutine analysis_1 (u)
     integer, intent(in) :: u
     type(string_t) :: id1, id2, id3, id4
     integer :: i
     id1 = "foo"
     id2 = "bar"
     id3 = "hist"
     id4 = "plot"
 
     write (u, "(A)")  "* Test output: Analysis"
     write (u, "(A)")  "*   Purpose: test the analysis routines"
     write (u, "(A)")
 
     call analysis_init_observable (id1)
     call analysis_init_observable (id2)
     call analysis_init_histogram &
          (id3, 0.5_default, 5.5_default, 1._default, normalize_bins=.false.)
     call analysis_init_plot (id4)
     do i = 1, 3
        write (u, "(A,1x," // FMT_19 // ")")  "data = ", real(i,default)
        call analysis_record_data (id1, real(i,default))
        call analysis_record_data (id2, real(i,default), &
                                         weight=real(i,default))
        call analysis_record_data (id3, real(i,default))
        call analysis_record_data (id4, real(i,default), real(i,default)**2)
     end do
     write (u, "(A,10(1x,I5))") "n_entries = ", &
          analysis_get_n_entries (id1), &
          analysis_get_n_entries (id2), &
          analysis_get_n_entries (id3), &
          analysis_get_n_entries (id3, within_bounds = .true.), &
          analysis_get_n_entries (id4), &
          analysis_get_n_entries (id4, within_bounds = .true.)
     write (u, "(A,10(1x," // FMT_19 // "))")  "average   = ", &
          analysis_get_average (id1), &
          analysis_get_average (id2), &
          analysis_get_average (id3), &
          analysis_get_average (id3, within_bounds = .true.)
     write (u, "(A,10(1x," // FMT_19 // "))")  "error     = ", &
          analysis_get_error (id1), &
          analysis_get_error (id2), &
          analysis_get_error (id3), &
          analysis_get_error (id3, within_bounds = .true.)
 
     write (u, "(A)")
     write (u, "(A)") "* Clear analysis #2"
     write (u, "(A)")
 
     call analysis_clear (id2)
     do i = 4, 6
        print *, "data = ", real(i,default)
        call analysis_record_data (id1, real(i,default))
        call analysis_record_data (id2, real(i,default), &
                                         weight=real(i,default))
        call analysis_record_data (id3, real(i,default))
        call analysis_record_data (id4, real(i,default), real(i,default)**2)
     end do
     write (u, "(A,10(1x,I5))")  "n_entries = ", &
          analysis_get_n_entries (id1), &
          analysis_get_n_entries (id2), &
          analysis_get_n_entries (id3), &
          analysis_get_n_entries (id3, within_bounds = .true.), &
          analysis_get_n_entries (id4), &
          analysis_get_n_entries (id4, within_bounds = .true.)
     write (u, "(A,10(1x," // FMT_19 // "))")  "average   = ", &
          analysis_get_average (id1), &
          analysis_get_average (id2), &
          analysis_get_average (id3), &
          analysis_get_average (id3, within_bounds = .true.)
     write (u, "(A,10(1x," // FMT_19 // "))")  "error     = ", &
          analysis_get_error (id1), &
          analysis_get_error (id2), &
          analysis_get_error (id3), &
          analysis_get_error (id3, within_bounds = .true.)
     write (u, "(A)")
     call analysis_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call analysis_clear ()
     call analysis_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: analysis_1"
   end subroutine analysis_1
 
 @ %def analysis_1