Index: trunk/share/tests/functional_tests/ref-output/show_4.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output/show_4.ref	(revision 8766)
+++ trunk/share/tests/functional_tests/ref-output/show_4.ref	(revision 8767)
@@ -1,1190 +1,1202 @@
 ?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
 photon_rec_r0 =  1.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]
 $negative_sf = "default"
 [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"
 $vamp_parallel_method = "simple"
 $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"
 $real_partition_mode = "default"
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 $fclibs => Fortran-libs
 #####################################################
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 ?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
 ?rescan_force = false
 ?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
 ?keep_flavors_when_recombining = true
 ?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_reuse_amplitudes_fks = 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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 $fclibs => Fortran-libs
 ?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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 $fclibs => Fortran-libs
 ?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/vars.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output/vars.ref	(revision 8766)
+++ trunk/share/tests/functional_tests/ref-output/vars.ref	(revision 8767)
@@ -1,383 +1,385 @@
 ?openmp_logging = false
 [user variable] foo = -7.800000000000E-02
 [user variable] bar = 1
 [user variable] a =  2.010000000000E-05
 [user variable] i = 3
 [user variable] foo =  2.922000000000E+00
 [user variable] i = 9
 [user variable] foo =  2.922000000000E+00
 [user variable] bar = 1
 [user variable] i = 9
 [user variable] k = 1
 [user variable] k2 =  1.000000000000E+00
 [user variable] i = -1
 [user variable] k = 2
 [user variable] k2 =  4.000000000000E+00
 [user variable] i = -2
 [user variable] k = 3
 [user variable] k2 =  9.000000000000E+00
 [user variable] i = -3
 [user variable] k = 4
 [user variable] k2 =  1.600000000000E+01
 [user variable] i = -4
 [user variable] k = 8
 [user variable] k2 =  6.400000000000E+01
 [user variable] i = -8
 [user variable] i = 9
 [user variable] MW =  7.980000000000E+01
 [user variable] MW =  7.980000000000E+01
 SM.mtau =>  8.000000000000E-01
 SM.mW =>  8.011900000000E+01
 SM.mW =>  8.011900000000E+01
 SM.sw* =>  4.775372811515E-01
 SM.mW =>  7.500000000000E+01
 SM.sw* =>  5.688014954824E-01
 SM.mW =>  8.000000000000E+01
 SM.sw* =>  4.799305327664E-01
 SM.mW =>  8.050000000000E+01
 SM.sw* =>  4.697684723671E-01
 SM.mW =>  8.100000000000E+01
 SM.sw* =>  4.593162187090E-01
 SM.mW =>  8.150000000000E+01
 SM.sw* =>  4.485534858838E-01
 SM.mW =>  8.200000000000E+01
 SM.sw* =>  4.374573583998E-01
 SM.mW =>  8.300000000000E+01
 SM.sw* =>  4.141569403361E-01
 SM.mW =>  8.469722796445E+01
 SM.sw* =>  3.705366373038E-01
 SM.mW =>  8.642916174533E+01
 SM.sw* =>  3.188332912310E-01
 SM.mW =>  8.819651102555E+01
 SM.sw* =>  2.540459583362E-01
 SM.mW =>  9.000000000000E+01
 SM.sw* =>  1.609055729882E-01
 mW is 80.119 and sw is:   0.4775
 seed = 32
 seed = 32
 seed = 30
 seed = 30
 seed = 28
 seed = 28
 seed = 26
 seed = 26
 seed = 24
 seed = 24
 seed = 22
 seed = 22
 seed = 20
 seed = 20
 seed = 18
 seed = 18
 seed = 16
 seed = 16
 seed = 14
 seed = 14
 seed = 12
 seed = 12
 seed = 10
 seed = 10
 seed = 8
 seed = 8
 seed = 6
 seed = 6
 seed = 4
 seed = 4
 seed = 2
 seed = 2
 [user variable] $str = "foo"
 [user variable] $str = "bar"
 [user variable] ?ok = false
 [user variable] ?ok = false
 [user variable] ?ok = true
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 ?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
 ?rescan_force = false
 ?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
 ?keep_flavors_when_recombining = true
 ?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_reuse_amplitudes_fks = false
 ?rebuild_library = true
 ?recompile_library = false
 ?rebuild_phase_space = true
 ?rebuild_grids = true
 ?rebuild_events = true
 [user variable] ?ok = true
 [user variable] $str = "foo"
 [user variable] $str = "foobar"
 $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]
 $negative_sf = "default"
 [undefined] $job_id = [unknown string]
 [undefined] $compile_workspace = [unknown string]
 $model_name = "SM"
 $method = "omega"
 $restrictions = ""
 $omega_flags = ""
 $library_name = "vars_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"
 $vamp_parallel_method = "simple"
 $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"
 $real_partition_mode = "default"
 $fc => Fortran-compiler
 $fcflags => Fortran-flags
 $fclibs => Fortran-libs
 [user variable] $str = "foobar"
 [user variable] q = PDG(2)
 [user variable] q = PDG(2, 1, -2, -1)
 Q is only local and hence not not defined
 ******************************************************************************
 *** ERROR: show: object 'Q' not found
 ******************************************************************************
 |             (WHIZARD run continues)
 SM.u* = PDG(2)
 [user variable] q = PDG(2, 1, -2, -1)
 [user variable] i = 1
 one = 1
 [user variable] i = 2
 two
 [user variable] i = 3
 three
 [user variable] i = 4
 four
 [user variable] i = -1
 [user variable] $str = "i<=0"
 [user variable] i = 1
 [user variable] $str = "i>0"
 [user variable] i = 2
 [user variable] $str = "i>1"
 Testing the complex calculus
 [user variable] ca = ( 2.000000000000E+00, 1.000000000000E+00)
 [user variable] ca = ( 2.000000000000E+00, 1.000000000000E+00)
 [user variable] ia = 2
 [user variable] ia = 2
 [user variable] ra =  2.000000000000E+00
 [user variable] ra =  2.000000000000E+00
 [user variable] cb = ( 3.000000000000E+00, 4.000000000000E+00)
 [user variable] cb = ( 3.000000000000E+00, 4.000000000000E+00)
 ?pacify = true
 [user variable] cc = ( 1.00000E+00, 0.00000E+00)
 ?pacify = true
 [user variable] cc = ( 1.00000E+00, 0.00000E+00)
 | There were  1 error(s) and no warnings.
 | 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 8766)
+++ trunk/share/tests/functional_tests/ref-output/process_log.ref	(revision 8767)
@@ -1,559 +1,564 @@
 ###############################################################################
  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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc = Fortran-compiler
 $fcflags = Fortran-flags
 $fclibs = Fortran-libs
 ?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/share/tests/unit_tests/ref-output/prc_omega_5.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/prc_omega_5.ref	(revision 8766)
+++ trunk/share/tests/unit_tests/ref-output/prc_omega_5.ref	(revision 8767)
@@ -1,61 +1,60 @@
 * Test output: prc_omega_5
 *   Purpose: create a QCD process with OMega
 *            and check alpha_s dependence
 
 * Initialize a process library with one entry
 
 * Configure and compile process
 
 * Probe library API
 
  is active = T
 
 * Set kinematics
 
  E =   1.000000000000E+02
  P =   0.000000000000E+00  0.000000000000E+00  1.000000000000E+02
  E =   1.000000000000E+02
  P =   0.000000000000E+00  0.000000000000E+00 -1.000000000000E+02
  E =   1.000000000000E+02
  P =   1.000000000000E+02  0.000000000000E+00  0.000000000000E+00
  E =   1.000000000000E+02
  P =  -1.000000000000E+02  0.000000000000E+00  0.000000000000E+00
 
 * Setup QCD data
 
 * Setup process core
 
    O'Mega process core: prc_omega_5_p_i1
    Parameter array:
      1  1.1780000000E-01
      2  0.0000000000E+00
      3  0.0000000000E+00
      4  1.2000000000E-01
      5  1.2500000000E+00
      6  4.2000000000E+00
      7  1.7310000000E+02
      8  1.5230000000E+00
    QCD parameters (running coupling):
      Scale mu  =  9.11880E+01
      alpha(mu) =  1.17800E-01
      LL order  = 0
      N(flv)    = 5
-   QED parameters (fixed coupling):
-     alpha_qed = -1.00000E+00
+   QED parameters (coupling undefined)
 
 * Compute matrix element
 
  renormalization scale = 100.
  |amp (1, 6, 1)| =  0.2435E+00
 
 * Modify renormalization scale and compute matrix element again
 
  renormalization scale = 200.
  |amp (1, 6, 1)| =  0.2217E+00
 
 * Set alpha(QCD) directly and compute matrix element again
 
  alpha_qcd = 0.1000
  |amp (1, 6, 1)| =  0.2094E+00
 
 * Test output end: prc_omega_5
Index: trunk/share/tests/unit_tests/ref-output/dispatch_10.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/dispatch_10.ref	(revision 8766)
+++ trunk/share/tests/unit_tests/ref-output/dispatch_10.ref	(revision 8767)
@@ -1,45 +1,42 @@
 * Test output: dispatch_10
 *   Purpose: select process configuration method,
              allocate process core,
              temporarily reset parameters
 
 * Allocate core as prc_omega_t
 
    O'Mega process core: [undefined]
    Parameter array:
      1  1.0000000000E+00
      2  1.2500000000E+02
      3  1.5000000000E+00
      4  1.8750000000E+02
    QCD parameters (coupling undefined)
-   QED parameters (fixed coupling):
-     alpha_qed = -1.00000E+00
+   QED parameters (coupling undefined)
 
 * Update core with modified model and helicity selection
 
    O'Mega process core: [undefined]
    Parameter array:
      1  2.0000000000E+00
      2  1.2500000000E+02
      3  1.5000000000E+00
      4  1.8750000000E+02
    Helicity selection data:
      threshold = 2.0000000000E+10
      cutoff    = 5
    QCD parameters (coupling undefined)
-   QED parameters (fixed coupling):
-     alpha_qed = -1.00000E+00
+   QED parameters (coupling undefined)
 
 * Restore core from save
 
    O'Mega process core: [undefined]
    Parameter array:
      1  1.0000000000E+00
      2  1.2500000000E+02
      3  1.5000000000E+00
      4  1.8750000000E+02
    QCD parameters (coupling undefined)
-   QED parameters (fixed coupling):
-     alpha_qed = -1.00000E+00
+   QED parameters (coupling undefined)
 
 * Test output end: dispatch_10
Index: trunk/share/tests/unit_tests/ref-output/dispatch_2.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/dispatch_2.ref	(revision 8766)
+++ trunk/share/tests/unit_tests/ref-output/dispatch_2.ref	(revision 8767)
@@ -1,24 +1,23 @@
 * Test output: dispatch_2
 *   Purpose: select process configuration method
              and allocate process core
 
 * Allocate core as test_t
 
    test type implementing prc_test
 
 * Allocate core as prc_omega_t
 
    O'Mega process core: [undefined]
    Parameter array:
      1  1.0000000000E+00
      2  1.2500000000E+02
      3  1.5000000000E+00
      4  1.8750000000E+02
    Helicity selection data:
      threshold = 1.0000000000E+09
      cutoff    = 10
    QCD parameters (coupling undefined)
-   QED parameters (fixed coupling):
-     alpha_qed = -1.00000E+00
+   QED parameters (coupling undefined)
 
 * Test output end: dispatch_2
Index: trunk/share/tests/unit_tests/ref-output/rt_data_1.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/rt_data_1.ref	(revision 8766)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_1.ref	(revision 8767)
@@ -1,435 +1,440 @@
 * 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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 $fclibs => "Fortran-libs"
 ========================================================================
  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/sm_qed_1.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/sm_qed_1.ref	(revision 0)
+++ trunk/share/tests/unit_tests/ref-output/sm_qed_1.ref	(revision 8767)
@@ -0,0 +1,60 @@
+* Test output: sm_qed_1
+*   Purpose: compute running alpha
+
+* Fixed:
+
+   QED parameters (fixed coupling):
+     alpha =  7.29735E-03
+     md5sum = '50D6045515639C33BCE44560769B9DE8'
+
+ alpha (me)     = 0.0072974
+ alpha (10 GeV) = 0.0072974
+ alpha (1 TeV)  = 0.0072974
+
+* Running from me (LO):
+
+   QED parameters (running coupling):
+     Scale mu  =  5.10999E-04
+     alpha(mu) =  7.29735E-03
+     LL order  = 0
+     N(flv)    = 5
+     N(lep)    = 1
+     analytic  = T
+     md5sum = 'A70447D1225DA05453568F238DB1A49C'
+
+ alpha (me)     = 0.0072974
+ alpha (10 GeV) = 0.0078585
+ alpha (1 TeV)  = 0.0081506
+
+* Running from me (NLO, analytic):
+
+   QED parameters (running coupling):
+     Scale mu  =  5.10999E-04
+     alpha(mu) =  7.29735E-03
+     LL order  = 1
+     N(flv)    = 5
+     N(lep)    = 1
+     analytic  = T
+     md5sum = '928911918F1C842E36F8ADF126B9A92E'
+
+ alpha (me)     = 0.0072974
+ alpha (10 GeV) = 0.0078591
+ alpha (1 TeV)  = 0.0081515
+
+* Running from me (NLO, numeric):
+
+   QED parameters (running coupling):
+     Scale mu  =  5.10999E-04
+     alpha(mu) =  7.29735E-03
+     LL order  = 1
+     N(flv)    = 5
+     N(lep)    = 1
+     analytic  = F
+     md5sum = '5441DB17AFA7A6C3B7BD8263F43EC10F'
+
+ alpha (me)     = 0.0072974
+ alpha (10 GeV) = 0.0078591
+ alpha (1 TeV)  = 0.0081515
+
+
+* Test output end: sm_qed_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 8766)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_2.ref	(revision 8767)
@@ -1,499 +1,504 @@
 * 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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 $fclibs => "Fortran-libs"
 ========================================================================
 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 8766)
+++ trunk/share/tests/unit_tests/ref-output/rt_data_3.ref	(revision 8767)
@@ -1,1052 +1,1062 @@
 * 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"
 $fclibs => "Fortran-libs"
 $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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 $fclibs => "Fortran-libs"
 ========================================================================
 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
 $negative_sf = "default"
 ?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
+?alpha_is_fixed = true
 ?alphas_from_lhapdf = false
 ?alphas_from_pdf_builtin = false
+?alpha_evolve_analytic = true
 alphas_order = 0
+alpha_order = 0
 alphas_nf = 5
+alpha_nf = -1
+alpha_nlep = 1
 ?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
 ?rescan_force = false
 ?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_checkpoint = 1
 $vamp_grid_format = "ascii"
 $vamp_parallel_method = "simple"
 $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
 photon_rec_r0 =  1.000000000000E-01
 ?keep_flavors_when_recombining = true
 $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_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
 $real_partition_mode = "default"
 real_partition_scale =  1.000000000000E+01
 ?nlo_reuse_amplitudes_fks = false
 $fc => "Fortran-compiler"
 $fcflags => "Fortran-flags"
 $fclibs => "Fortran-libs"
 ========================================================================
 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/Makefile.am
===================================================================
--- trunk/share/tests/Makefile.am	(revision 8766)
+++ trunk/share/tests/Makefile.am	(revision 8767)
@@ -1,1611 +1,1612 @@
 ## Makefile.am -- Makefile for WHIZARD tests
 ##
 ## Process this file with automake to produce Makefile.in
 ##
 ########################################################################
 #
 # Copyright (C) 1999-2021 by
 #     Wolfgang Kilian <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     with contributions from
 #     cf. main AUTHORS file
 #
 # WHIZARD is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2, or (at your option)
 # any later version.
 #
 # WHIZARD is distributed in the hope that it will be useful, but
 # WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #
 ########################################################################
 
 EXTRA_DIST = \
     $(TESTSUITE_MACROS) $(TESTSUITES_M4) $(TESTSUITES_SIN) \
     $(TESTSUITE_TOOLS) \
     $(REF_OUTPUT_FILES) \
     cascades2_1.fds \
     cascades2_2.fds \
     cascades2_lexer_1.fds \
     ext_tests_nmssm/nmssm.slha \
     functional_tests/structure_2_inc.sin functional_tests/testproc_3.phs \
     functional_tests/susyhit.in \
     functional_tests/ufo_5_test.slha
 
 TESTSUITE_MACROS = testsuite.m4
 TESTSUITE_TOOLS = \
     check-debug-output.py \
     check-debug-output-hadro.py \
     check-hepmc-weights.py \
     compare-histograms.py \
     compare-integrals.py \
     compare-integrals-multi.py \
     compare-methods.py
 
 REF_OUTPUT_FILES = \
     extra_integration_results.dat \
     $(REF_OUTPUT_FILES_BASE) $(REF_OUTPUT_FILES_DOUBLE) \
     $(REF_OUTPUT_FILES_PREC) $(REF_OUTPUT_FILES_EXT) \
     $(REF_OUTPUT_FILES_QUAD)
 
 REF_OUTPUT_FILES_BASE = \
     unit_tests/ref-output/analysis_1.ref \
     unit_tests/ref-output/api_1.ref \
     unit_tests/ref-output/api_2.ref \
     unit_tests/ref-output/api_3.ref \
     unit_tests/ref-output/api_4.ref \
     unit_tests/ref-output/api_5.ref \
     unit_tests/ref-output/api_6.ref \
     unit_tests/ref-output/api_7.ref \
     unit_tests/ref-output/api_8.ref \
     unit_tests/ref-output/api_c_1.ref \
     unit_tests/ref-output/api_c_2.ref \
     unit_tests/ref-output/api_c_3.ref \
     unit_tests/ref-output/api_c_4.ref \
     unit_tests/ref-output/api_c_5.ref \
     unit_tests/ref-output/api_cc_1.ref \
     unit_tests/ref-output/api_cc_2.ref \
     unit_tests/ref-output/api_cc_3.ref \
     unit_tests/ref-output/api_cc_4.ref \
     unit_tests/ref-output/api_cc_5.ref \
     unit_tests/ref-output/api_hepmc2_1.ref \
     unit_tests/ref-output/api_hepmc2_cc_1.ref \
     unit_tests/ref-output/api_hepmc3_1.ref \
     unit_tests/ref-output/api_hepmc3_cc_1.ref \
     unit_tests/ref-output/api_lcio_1.ref \
     unit_tests/ref-output/api_lcio_cc_1.ref \
     unit_tests/ref-output/array_list_1.ref \
     unit_tests/ref-output/auto_components_1.ref \
     unit_tests/ref-output/auto_components_2.ref \
     unit_tests/ref-output/auto_components_3.ref \
     unit_tests/ref-output/beam_1.ref \
     unit_tests/ref-output/beam_2.ref \
     unit_tests/ref-output/beam_3.ref \
     unit_tests/ref-output/beam_structures_1.ref \
     unit_tests/ref-output/beam_structures_2.ref \
     unit_tests/ref-output/beam_structures_3.ref \
     unit_tests/ref-output/beam_structures_4.ref \
     unit_tests/ref-output/beam_structures_5.ref \
     unit_tests/ref-output/beam_structures_6.ref \
     unit_tests/ref-output/binary_tree_1.ref \
     unit_tests/ref-output/blha_1.ref \
     unit_tests/ref-output/blha_2.ref \
     unit_tests/ref-output/blha_3.ref \
     unit_tests/ref-output/bloch_vectors_1.ref \
     unit_tests/ref-output/bloch_vectors_2.ref \
     unit_tests/ref-output/bloch_vectors_3.ref \
     unit_tests/ref-output/bloch_vectors_4.ref \
     unit_tests/ref-output/bloch_vectors_5.ref \
     unit_tests/ref-output/bloch_vectors_6.ref \
     unit_tests/ref-output/bloch_vectors_7.ref \
     unit_tests/ref-output/cascades2_1.ref \
     unit_tests/ref-output/cascades2_2.ref \
     unit_tests/ref-output/cascades2_lexer_1.ref \
     unit_tests/ref-output/cascades_1.ref \
     unit_tests/ref-output/cascades_2.ref \
     unit_tests/ref-output/color_1.ref \
     unit_tests/ref-output/color_2.ref \
     unit_tests/ref-output/commands_1.ref \
     unit_tests/ref-output/commands_2.ref \
     unit_tests/ref-output/commands_3.ref \
     unit_tests/ref-output/commands_4.ref \
     unit_tests/ref-output/commands_5.ref \
     unit_tests/ref-output/commands_6.ref \
     unit_tests/ref-output/commands_7.ref \
     unit_tests/ref-output/commands_8.ref \
     unit_tests/ref-output/commands_9.ref \
     unit_tests/ref-output/commands_10.ref \
     unit_tests/ref-output/commands_11.ref \
     unit_tests/ref-output/commands_12.ref \
     unit_tests/ref-output/commands_13.ref \
     unit_tests/ref-output/commands_14.ref \
     unit_tests/ref-output/commands_15.ref \
     unit_tests/ref-output/commands_16.ref \
     unit_tests/ref-output/commands_17.ref \
     unit_tests/ref-output/commands_18.ref \
     unit_tests/ref-output/commands_19.ref \
     unit_tests/ref-output/commands_20.ref \
     unit_tests/ref-output/commands_21.ref \
     unit_tests/ref-output/commands_22.ref \
     unit_tests/ref-output/commands_23.ref \
     unit_tests/ref-output/commands_24.ref \
     unit_tests/ref-output/commands_25.ref \
     unit_tests/ref-output/commands_26.ref \
     unit_tests/ref-output/commands_27.ref \
     unit_tests/ref-output/commands_28.ref \
     unit_tests/ref-output/commands_29.ref \
     unit_tests/ref-output/commands_30.ref \
     unit_tests/ref-output/commands_31.ref \
     unit_tests/ref-output/commands_32.ref \
     unit_tests/ref-output/commands_33.ref \
     unit_tests/ref-output/commands_34.ref \
     unit_tests/ref-output/compilations_1.ref \
     unit_tests/ref-output/compilations_2.ref \
     unit_tests/ref-output/compilations_3.ref \
     unit_tests/ref-output/compilations_static_1.ref \
     unit_tests/ref-output/compilations_static_2.ref \
     unit_tests/ref-output/cputime_1.ref \
     unit_tests/ref-output/cputime_2.ref \
     unit_tests/ref-output/decays_1.ref \
     unit_tests/ref-output/decays_2.ref \
     unit_tests/ref-output/decays_3.ref \
     unit_tests/ref-output/decays_4.ref \
     unit_tests/ref-output/decays_5.ref \
     unit_tests/ref-output/decays_6.ref \
     unit_tests/ref-output/dispatch_1.ref \
     unit_tests/ref-output/dispatch_2.ref \
     unit_tests/ref-output/dispatch_7.ref \
     unit_tests/ref-output/dispatch_8.ref \
     unit_tests/ref-output/dispatch_10.ref \
     unit_tests/ref-output/dispatch_11.ref \
     unit_tests/ref-output/dispatch_mci_1.ref \
     unit_tests/ref-output/dispatch_phs_1.ref \
     unit_tests/ref-output/dispatch_phs_2.ref \
     unit_tests/ref-output/dispatch_rng_1.ref \
     unit_tests/ref-output/dispatch_transforms_1.ref \
     unit_tests/ref-output/dispatch_transforms_2.ref \
     unit_tests/ref-output/eio_ascii_1.ref \
     unit_tests/ref-output/eio_ascii_2.ref \
     unit_tests/ref-output/eio_ascii_3.ref \
     unit_tests/ref-output/eio_ascii_4.ref \
     unit_tests/ref-output/eio_ascii_5.ref \
     unit_tests/ref-output/eio_ascii_6.ref \
     unit_tests/ref-output/eio_ascii_7.ref \
     unit_tests/ref-output/eio_ascii_8.ref \
     unit_tests/ref-output/eio_ascii_9.ref \
     unit_tests/ref-output/eio_ascii_10.ref \
     unit_tests/ref-output/eio_ascii_11.ref \
     unit_tests/ref-output/eio_base_1.ref \
     unit_tests/ref-output/eio_checkpoints_1.ref \
     unit_tests/ref-output/eio_data_1.ref \
     unit_tests/ref-output/eio_data_2.ref \
     unit_tests/ref-output/eio_direct_1.ref \
     unit_tests/ref-output/eio_dump_1.ref \
     unit_tests/ref-output/eio_hepmc2_1.ref \
     unit_tests/ref-output/eio_hepmc2_2.ref \
     unit_tests/ref-output/eio_hepmc2_3.ref \
     unit_tests/ref-output/eio_hepmc3_1.ref \
     unit_tests/ref-output/eio_hepmc3_2.ref \
     unit_tests/ref-output/eio_hepmc3_3.ref \
     unit_tests/ref-output/eio_lcio_1.ref \
     unit_tests/ref-output/eio_lcio_2.ref \
     unit_tests/ref-output/eio_lhef_1.ref \
     unit_tests/ref-output/eio_lhef_2.ref \
     unit_tests/ref-output/eio_lhef_3.ref \
     unit_tests/ref-output/eio_lhef_4.ref \
     unit_tests/ref-output/eio_lhef_5.ref \
     unit_tests/ref-output/eio_lhef_6.ref \
     unit_tests/ref-output/eio_raw_1.ref \
     unit_tests/ref-output/eio_raw_2.ref \
     unit_tests/ref-output/eio_stdhep_1.ref \
     unit_tests/ref-output/eio_stdhep_2.ref \
     unit_tests/ref-output/eio_stdhep_3.ref \
     unit_tests/ref-output/eio_stdhep_4.ref \
     unit_tests/ref-output/eio_weights_1.ref \
     unit_tests/ref-output/eio_weights_2.ref \
     unit_tests/ref-output/eio_weights_3.ref \
     unit_tests/ref-output/epa_handler_1.ref \
     unit_tests/ref-output/epa_handler_2.ref \
     unit_tests/ref-output/epa_handler_3.ref \
     unit_tests/ref-output/evaluator_1.ref \
     unit_tests/ref-output/evaluator_2.ref \
     unit_tests/ref-output/evaluator_3.ref \
     unit_tests/ref-output/evaluator_4.ref \
     unit_tests/ref-output/event_streams_1.ref \
     unit_tests/ref-output/event_streams_2.ref \
     unit_tests/ref-output/event_streams_3.ref \
     unit_tests/ref-output/event_streams_4.ref \
     unit_tests/ref-output/event_transforms_1.ref \
     unit_tests/ref-output/events_1.ref \
     unit_tests/ref-output/events_2.ref \
     unit_tests/ref-output/events_3.ref \
     unit_tests/ref-output/events_4.ref \
     unit_tests/ref-output/events_5.ref \
     unit_tests/ref-output/events_6.ref \
     unit_tests/ref-output/events_7.ref \
     unit_tests/ref-output/expressions_1.ref \
     unit_tests/ref-output/expressions_2.ref \
     unit_tests/ref-output/expressions_3.ref \
     unit_tests/ref-output/expressions_4.ref \
     unit_tests/ref-output/fks_regions_1.ref \
     unit_tests/ref-output/fks_regions_2.ref \
     unit_tests/ref-output/fks_regions_3.ref \
     unit_tests/ref-output/fks_regions_4.ref \
     unit_tests/ref-output/fks_regions_5.ref \
     unit_tests/ref-output/fks_regions_6.ref \
     unit_tests/ref-output/fks_regions_7.ref \
     unit_tests/ref-output/fks_regions_8.ref \
     unit_tests/ref-output/format_1.ref \
     unit_tests/ref-output/grids_1.ref \
     unit_tests/ref-output/grids_2.ref \
     unit_tests/ref-output/grids_3.ref \
     unit_tests/ref-output/grids_4.ref \
     unit_tests/ref-output/grids_5.ref \
     unit_tests/ref-output/hep_events_1.ref \
     unit_tests/ref-output/hepmc2_interface_1.ref \
     unit_tests/ref-output/hepmc3_interface_1.ref \
     unit_tests/ref-output/integration_results_1.ref \
     unit_tests/ref-output/integration_results_2.ref \
     unit_tests/ref-output/integration_results_3.ref \
     unit_tests/ref-output/integration_results_4.ref \
     unit_tests/ref-output/integration_results_5.ref \
     unit_tests/ref-output/integrations_1.ref \
     unit_tests/ref-output/integrations_2.ref \
     unit_tests/ref-output/integrations_3.ref \
     unit_tests/ref-output/integrations_4.ref \
     unit_tests/ref-output/integrations_5.ref \
     unit_tests/ref-output/integrations_6.ref \
     unit_tests/ref-output/integrations_7.ref \
     unit_tests/ref-output/integrations_8.ref \
     unit_tests/ref-output/integrations_9.ref \
     unit_tests/ref-output/integrations_history_1.ref \
     unit_tests/ref-output/interaction_1.ref \
     unit_tests/ref-output/isr_handler_1.ref \
     unit_tests/ref-output/isr_handler_2.ref \
     unit_tests/ref-output/isr_handler_3.ref \
     unit_tests/ref-output/iterations_1.ref \
     unit_tests/ref-output/iterations_2.ref \
     unit_tests/ref-output/iterator_1.ref \
     unit_tests/ref-output/jets_1.ref \
     unit_tests/ref-output/lcio_interface_1.ref \
     unit_tests/ref-output/lexer_1.ref \
     unit_tests/ref-output/mci_base_1.ref \
     unit_tests/ref-output/mci_base_2.ref \
     unit_tests/ref-output/mci_base_3.ref \
     unit_tests/ref-output/mci_base_4.ref \
     unit_tests/ref-output/mci_base_5.ref \
     unit_tests/ref-output/mci_base_6.ref \
     unit_tests/ref-output/mci_base_7.ref \
     unit_tests/ref-output/mci_base_8.ref \
     unit_tests/ref-output/mci_midpoint_1.ref \
     unit_tests/ref-output/mci_midpoint_2.ref \
     unit_tests/ref-output/mci_midpoint_3.ref \
     unit_tests/ref-output/mci_midpoint_4.ref \
     unit_tests/ref-output/mci_midpoint_5.ref \
     unit_tests/ref-output/mci_midpoint_6.ref \
     unit_tests/ref-output/mci_midpoint_7.ref \
     unit_tests/ref-output/mci_none_1.ref \
     unit_tests/ref-output/mci_vamp2_1.ref \
     unit_tests/ref-output/mci_vamp2_2.ref \
     unit_tests/ref-output/mci_vamp2_3.ref \
     unit_tests/ref-output/mci_vamp_1.ref \
     unit_tests/ref-output/mci_vamp_2.ref \
     unit_tests/ref-output/mci_vamp_3.ref \
     unit_tests/ref-output/mci_vamp_4.ref \
     unit_tests/ref-output/mci_vamp_5.ref \
     unit_tests/ref-output/mci_vamp_6.ref \
     unit_tests/ref-output/mci_vamp_7.ref \
     unit_tests/ref-output/mci_vamp_8.ref \
     unit_tests/ref-output/mci_vamp_9.ref \
     unit_tests/ref-output/mci_vamp_10.ref \
     unit_tests/ref-output/mci_vamp_11.ref \
     unit_tests/ref-output/mci_vamp_12.ref \
     unit_tests/ref-output/mci_vamp_13.ref \
     unit_tests/ref-output/mci_vamp_14.ref \
     unit_tests/ref-output/mci_vamp_15.ref \
     unit_tests/ref-output/mci_vamp_16.ref \
     unit_tests/ref-output/md5_1.ref \
     unit_tests/ref-output/models_1.ref \
     unit_tests/ref-output/models_2.ref \
     unit_tests/ref-output/models_3.ref \
     unit_tests/ref-output/models_4.ref \
     unit_tests/ref-output/models_5.ref \
     unit_tests/ref-output/models_6.ref \
     unit_tests/ref-output/models_7.ref \
     unit_tests/ref-output/models_8.ref \
     unit_tests/ref-output/models_9.ref \
     unit_tests/ref-output/models_10.ref \
     unit_tests/ref-output/os_interface_1.ref \
     unit_tests/ref-output/parse_1.ref \
     unit_tests/ref-output/particle_specifiers_1.ref \
     unit_tests/ref-output/particle_specifiers_2.ref \
     unit_tests/ref-output/particles_1.ref \
     unit_tests/ref-output/particles_2.ref \
     unit_tests/ref-output/particles_3.ref \
     unit_tests/ref-output/particles_4.ref \
     unit_tests/ref-output/particles_5.ref \
     unit_tests/ref-output/particles_6.ref \
     unit_tests/ref-output/particles_7.ref \
     unit_tests/ref-output/particles_8.ref \
     unit_tests/ref-output/particles_9.ref \
     unit_tests/ref-output/parton_states_1.ref \
     unit_tests/ref-output/pdg_arrays_1.ref \
     unit_tests/ref-output/pdg_arrays_2.ref \
     unit_tests/ref-output/pdg_arrays_3.ref \
     unit_tests/ref-output/pdg_arrays_4.ref \
     unit_tests/ref-output/pdg_arrays_5.ref \
     unit_tests/ref-output/phs_base_1.ref \
     unit_tests/ref-output/phs_base_2.ref \
     unit_tests/ref-output/phs_base_3.ref \
     unit_tests/ref-output/phs_base_4.ref \
     unit_tests/ref-output/phs_base_5.ref \
     unit_tests/ref-output/phs_fks_generator_1.ref \
     unit_tests/ref-output/phs_fks_generator_2.ref \
     unit_tests/ref-output/phs_fks_generator_3.ref \
     unit_tests/ref-output/phs_fks_generator_4.ref \
     unit_tests/ref-output/phs_fks_generator_5.ref \
     unit_tests/ref-output/phs_fks_generator_6.ref \
     unit_tests/ref-output/phs_fks_generator_7.ref \
     unit_tests/ref-output/phs_forest_1.ref \
     unit_tests/ref-output/phs_forest_2.ref \
     unit_tests/ref-output/phs_none_1.ref \
     unit_tests/ref-output/phs_points_1.ref \
     unit_tests/ref-output/phs_rambo_1.ref \
     unit_tests/ref-output/phs_rambo_2.ref \
     unit_tests/ref-output/phs_rambo_3.ref \
     unit_tests/ref-output/phs_rambo_4.ref \
     unit_tests/ref-output/phs_single_1.ref \
     unit_tests/ref-output/phs_single_2.ref \
     unit_tests/ref-output/phs_single_3.ref \
     unit_tests/ref-output/phs_single_4.ref \
     unit_tests/ref-output/phs_tree_1.ref \
     unit_tests/ref-output/phs_tree_2.ref \
     unit_tests/ref-output/phs_wood_1.ref \
     unit_tests/ref-output/phs_wood_2.ref \
     unit_tests/ref-output/phs_wood_3.ref \
     unit_tests/ref-output/phs_wood_4.ref \
     unit_tests/ref-output/phs_wood_5.ref \
     unit_tests/ref-output/phs_wood_6.ref \
     unit_tests/ref-output/phs_wood_vis_1.ref \
     unit_tests/ref-output/polarization_1.ref \
     unit_tests/ref-output/polarization_2.ref \
     unit_tests/ref-output/prc_omega_1.ref \
     unit_tests/ref-output/prc_omega_2.ref \
     unit_tests/ref-output/prc_omega_3.ref \
     unit_tests/ref-output/prc_omega_4.ref \
     unit_tests/ref-output/prc_omega_5.ref \
     unit_tests/ref-output/prc_omega_6.ref \
     unit_tests/ref-output/prc_omega_diags_1.ref \
     unit_tests/ref-output/prc_recola_1.ref \
     unit_tests/ref-output/prc_recola_2.ref \
     unit_tests/ref-output/prc_template_me_1.ref \
     unit_tests/ref-output/prc_template_me_2.ref \
     unit_tests/ref-output/prc_test_1.ref \
     unit_tests/ref-output/prc_test_2.ref \
     unit_tests/ref-output/prc_test_3.ref \
     unit_tests/ref-output/prc_test_4.ref \
     unit_tests/ref-output/prclib_interfaces_1.ref \
     unit_tests/ref-output/prclib_interfaces_2.ref \
     unit_tests/ref-output/prclib_interfaces_3.ref \
     unit_tests/ref-output/prclib_interfaces_4.ref \
     unit_tests/ref-output/prclib_interfaces_5.ref \
     unit_tests/ref-output/prclib_interfaces_6.ref \
     unit_tests/ref-output/prclib_interfaces_7.ref \
     unit_tests/ref-output/prclib_stacks_1.ref \
     unit_tests/ref-output/prclib_stacks_2.ref \
     unit_tests/ref-output/process_configurations_1.ref \
     unit_tests/ref-output/process_configurations_2.ref \
     unit_tests/ref-output/process_libraries_1.ref \
     unit_tests/ref-output/process_libraries_2.ref \
     unit_tests/ref-output/process_libraries_3.ref \
     unit_tests/ref-output/process_libraries_4.ref \
     unit_tests/ref-output/process_libraries_5.ref \
     unit_tests/ref-output/process_libraries_6.ref \
     unit_tests/ref-output/process_libraries_7.ref \
     unit_tests/ref-output/process_libraries_8.ref \
     unit_tests/ref-output/process_stacks_1.ref \
     unit_tests/ref-output/process_stacks_2.ref \
     unit_tests/ref-output/process_stacks_3.ref \
     unit_tests/ref-output/process_stacks_4.ref \
     unit_tests/ref-output/processes_1.ref \
     unit_tests/ref-output/processes_2.ref \
     unit_tests/ref-output/processes_3.ref \
     unit_tests/ref-output/processes_4.ref \
     unit_tests/ref-output/processes_5.ref \
     unit_tests/ref-output/processes_6.ref \
     unit_tests/ref-output/processes_7.ref \
     unit_tests/ref-output/processes_8.ref \
     unit_tests/ref-output/processes_9.ref \
     unit_tests/ref-output/processes_10.ref \
     unit_tests/ref-output/processes_11.ref \
     unit_tests/ref-output/processes_12.ref \
     unit_tests/ref-output/processes_13.ref \
     unit_tests/ref-output/processes_14.ref \
     unit_tests/ref-output/processes_15.ref \
     unit_tests/ref-output/processes_16.ref \
     unit_tests/ref-output/processes_17.ref \
     unit_tests/ref-output/processes_18.ref \
     unit_tests/ref-output/processes_19.ref \
     unit_tests/ref-output/radiation_generator_1.ref \
     unit_tests/ref-output/radiation_generator_2.ref \
     unit_tests/ref-output/radiation_generator_3.ref \
     unit_tests/ref-output/radiation_generator_4.ref \
     unit_tests/ref-output/real_subtraction_1.ref \
     unit_tests/ref-output/recoil_kinematics_1.ref \
     unit_tests/ref-output/recoil_kinematics_2.ref \
     unit_tests/ref-output/recoil_kinematics_3.ref \
     unit_tests/ref-output/recoil_kinematics_4.ref \
     unit_tests/ref-output/recoil_kinematics_5.ref \
     unit_tests/ref-output/recoil_kinematics_6.ref \
     unit_tests/ref-output/resonance_insertion_1.ref \
     unit_tests/ref-output/resonance_insertion_2.ref \
     unit_tests/ref-output/resonance_insertion_3.ref \
     unit_tests/ref-output/resonance_insertion_4.ref \
     unit_tests/ref-output/resonance_insertion_5.ref \
     unit_tests/ref-output/resonance_insertion_6.ref \
     unit_tests/ref-output/resonances_1.ref \
     unit_tests/ref-output/resonances_2.ref \
     unit_tests/ref-output/resonances_3.ref \
     unit_tests/ref-output/resonances_4.ref \
     unit_tests/ref-output/resonances_5.ref \
     unit_tests/ref-output/resonances_6.ref \
     unit_tests/ref-output/resonances_7.ref \
     unit_tests/ref-output/restricted_subprocesses_1.ref \
     unit_tests/ref-output/restricted_subprocesses_2.ref \
     unit_tests/ref-output/restricted_subprocesses_3.ref \
     unit_tests/ref-output/restricted_subprocesses_4.ref \
     unit_tests/ref-output/restricted_subprocesses_5.ref \
     unit_tests/ref-output/restricted_subprocesses_6.ref \
     unit_tests/ref-output/rng_base_1.ref \
     unit_tests/ref-output/rng_base_2.ref \
     unit_tests/ref-output/rng_stream_1.ref \
     unit_tests/ref-output/rng_stream_2.ref \
     unit_tests/ref-output/rng_stream_3.ref \
     unit_tests/ref-output/rng_tao_1.ref \
     unit_tests/ref-output/rng_tao_2.ref \
     unit_tests/ref-output/rt_data_1.ref \
     unit_tests/ref-output/rt_data_2.ref \
     unit_tests/ref-output/rt_data_3.ref \
     unit_tests/ref-output/rt_data_4.ref \
     unit_tests/ref-output/rt_data_5.ref \
     unit_tests/ref-output/rt_data_6.ref \
     unit_tests/ref-output/rt_data_7.ref \
     unit_tests/ref-output/rt_data_8.ref \
     unit_tests/ref-output/rt_data_9.ref \
     unit_tests/ref-output/rt_data_10.ref \
     unit_tests/ref-output/rt_data_11.ref \
     unit_tests/ref-output/selectors_1.ref \
     unit_tests/ref-output/selectors_2.ref \
     unit_tests/ref-output/sf_aux_1.ref \
     unit_tests/ref-output/sf_aux_2.ref \
     unit_tests/ref-output/sf_aux_3.ref \
     unit_tests/ref-output/sf_aux_4.ref \
     unit_tests/ref-output/sf_base_1.ref \
     unit_tests/ref-output/sf_base_2.ref \
     unit_tests/ref-output/sf_base_3.ref \
     unit_tests/ref-output/sf_base_4.ref \
     unit_tests/ref-output/sf_base_5.ref \
     unit_tests/ref-output/sf_base_6.ref \
     unit_tests/ref-output/sf_base_7.ref \
     unit_tests/ref-output/sf_base_8.ref \
     unit_tests/ref-output/sf_base_9.ref \
     unit_tests/ref-output/sf_base_10.ref \
     unit_tests/ref-output/sf_base_11.ref \
     unit_tests/ref-output/sf_base_12.ref \
     unit_tests/ref-output/sf_base_13.ref \
     unit_tests/ref-output/sf_base_14.ref \
     unit_tests/ref-output/sf_beam_events_1.ref \
     unit_tests/ref-output/sf_beam_events_2.ref \
     unit_tests/ref-output/sf_beam_events_3.ref \
     unit_tests/ref-output/sf_circe1_1.ref \
     unit_tests/ref-output/sf_circe1_2.ref \
     unit_tests/ref-output/sf_circe1_3.ref \
     unit_tests/ref-output/sf_circe2_1.ref \
     unit_tests/ref-output/sf_circe2_2.ref \
     unit_tests/ref-output/sf_circe2_3.ref \
     unit_tests/ref-output/sf_epa_1.ref \
     unit_tests/ref-output/sf_epa_2.ref \
     unit_tests/ref-output/sf_epa_3.ref \
     unit_tests/ref-output/sf_epa_4.ref \
     unit_tests/ref-output/sf_epa_5.ref \
     unit_tests/ref-output/sf_escan_1.ref \
     unit_tests/ref-output/sf_escan_2.ref \
     unit_tests/ref-output/sf_ewa_1.ref \
     unit_tests/ref-output/sf_ewa_2.ref \
     unit_tests/ref-output/sf_ewa_3.ref \
     unit_tests/ref-output/sf_ewa_4.ref \
     unit_tests/ref-output/sf_ewa_5.ref \
     unit_tests/ref-output/sf_gaussian_1.ref \
     unit_tests/ref-output/sf_gaussian_2.ref \
     unit_tests/ref-output/sf_isr_1.ref \
     unit_tests/ref-output/sf_isr_2.ref \
     unit_tests/ref-output/sf_isr_3.ref \
     unit_tests/ref-output/sf_isr_4.ref \
     unit_tests/ref-output/sf_isr_5.ref \
     unit_tests/ref-output/sf_lhapdf5_1.ref \
     unit_tests/ref-output/sf_lhapdf5_2.ref \
     unit_tests/ref-output/sf_lhapdf5_3.ref \
     unit_tests/ref-output/sf_lhapdf6_1.ref \
     unit_tests/ref-output/sf_lhapdf6_2.ref \
     unit_tests/ref-output/sf_lhapdf6_3.ref \
     unit_tests/ref-output/sf_mappings_1.ref \
     unit_tests/ref-output/sf_mappings_2.ref \
     unit_tests/ref-output/sf_mappings_3.ref \
     unit_tests/ref-output/sf_mappings_4.ref \
     unit_tests/ref-output/sf_mappings_5.ref \
     unit_tests/ref-output/sf_mappings_6.ref \
     unit_tests/ref-output/sf_mappings_7.ref \
     unit_tests/ref-output/sf_mappings_8.ref \
     unit_tests/ref-output/sf_mappings_9.ref \
     unit_tests/ref-output/sf_mappings_10.ref \
     unit_tests/ref-output/sf_mappings_11.ref \
     unit_tests/ref-output/sf_mappings_12.ref \
     unit_tests/ref-output/sf_mappings_13.ref \
     unit_tests/ref-output/sf_mappings_14.ref \
     unit_tests/ref-output/sf_mappings_15.ref \
     unit_tests/ref-output/sf_mappings_16.ref \
     unit_tests/ref-output/sf_pdf_builtin_1.ref \
     unit_tests/ref-output/sf_pdf_builtin_2.ref \
     unit_tests/ref-output/sf_pdf_builtin_3.ref \
     unit_tests/ref-output/shower_1.ref \
     unit_tests/ref-output/shower_2.ref \
     unit_tests/ref-output/shower_base_1.ref \
     unit_tests/ref-output/simulations_1.ref \
     unit_tests/ref-output/simulations_2.ref \
     unit_tests/ref-output/simulations_3.ref \
     unit_tests/ref-output/simulations_4.ref \
     unit_tests/ref-output/simulations_5.ref \
     unit_tests/ref-output/simulations_6.ref \
     unit_tests/ref-output/simulations_7.ref \
     unit_tests/ref-output/simulations_8.ref \
     unit_tests/ref-output/simulations_9.ref \
     unit_tests/ref-output/simulations_10.ref \
     unit_tests/ref-output/simulations_11.ref \
     unit_tests/ref-output/simulations_12.ref \
     unit_tests/ref-output/simulations_13.ref \
     unit_tests/ref-output/simulations_14.ref \
     unit_tests/ref-output/simulations_15.ref \
     unit_tests/ref-output/slha_1.ref \
     unit_tests/ref-output/slha_2.ref \
     unit_tests/ref-output/sm_physics_1.ref \
     unit_tests/ref-output/sm_physics_2.ref \
     unit_tests/ref-output/sm_qcd_1.ref \
+    unit_tests/ref-output/sm_qed_1.ref \
     unit_tests/ref-output/solver_1.ref \
     unit_tests/ref-output/sorting_1.ref \
     unit_tests/ref-output/state_matrix_1.ref \
     unit_tests/ref-output/state_matrix_2.ref \
     unit_tests/ref-output/state_matrix_3.ref \
     unit_tests/ref-output/state_matrix_4.ref \
     unit_tests/ref-output/state_matrix_5.ref \
     unit_tests/ref-output/state_matrix_6.ref \
     unit_tests/ref-output/state_matrix_7.ref \
     unit_tests/ref-output/su_algebra_1.ref \
     unit_tests/ref-output/su_algebra_2.ref \
     unit_tests/ref-output/su_algebra_3.ref \
     unit_tests/ref-output/su_algebra_4.ref \
     unit_tests/ref-output/subevt_expr_1.ref \
     unit_tests/ref-output/subevt_expr_2.ref \
     unit_tests/ref-output/ttv_formfactors_1.ref \
     unit_tests/ref-output/ttv_formfactors_2.ref \
     unit_tests/ref-output/vamp2_1.ref \
     unit_tests/ref-output/vamp2_2.ref \
     unit_tests/ref-output/vamp2_3.ref \
     unit_tests/ref-output/vamp2_4.ref \
     unit_tests/ref-output/vamp2_5.ref \
     unit_tests/ref-output/vegas_1.ref \
     unit_tests/ref-output/vegas_2.ref \
     unit_tests/ref-output/vegas_3.ref \
     unit_tests/ref-output/vegas_4.ref \
     unit_tests/ref-output/vegas_5.ref \
     unit_tests/ref-output/vegas_6.ref \
     unit_tests/ref-output/vegas_7.ref \
     unit_tests/ref-output/whizard_lha_1.ref \
     unit_tests/ref-output/xml_1.ref \
     unit_tests/ref-output/xml_2.ref \
     unit_tests/ref-output/xml_3.ref \
     unit_tests/ref-output/xml_4.ref \
     functional_tests/ref-output/alphas.ref \
     functional_tests/ref-output/analyze_1.ref \
     functional_tests/ref-output/analyze_2.ref \
     functional_tests/ref-output/analyze_3.ref \
     functional_tests/ref-output/analyze_4.ref \
     functional_tests/ref-output/analyze_5.ref \
     functional_tests/ref-output/analyze_6.ref \
     functional_tests/ref-output/beam_events_1.ref \
     functional_tests/ref-output/beam_events_4.ref \
     functional_tests/ref-output/beam_setup_1.ref \
     functional_tests/ref-output/beam_setup_2.ref \
     functional_tests/ref-output/beam_setup_3.ref \
     functional_tests/ref-output/beam_setup_4.ref \
     functional_tests/ref-output/bjet_cluster.ref \
     functional_tests/ref-output/br_redef_1.ref \
     functional_tests/ref-output/cascades2_phs_1.ref \
     functional_tests/ref-output/cascades2_phs_2.ref \
     functional_tests/ref-output/circe1_1.ref \
     functional_tests/ref-output/circe1_2.ref \
     functional_tests/ref-output/circe1_3.ref \
     functional_tests/ref-output/circe1_6.ref \
     functional_tests/ref-output/circe1_10.ref \
     functional_tests/ref-output/circe1_errors_1.ref \
     functional_tests/ref-output/circe2_1.ref \
     functional_tests/ref-output/circe2_2.ref \
     functional_tests/ref-output/circe2_3.ref \
     functional_tests/ref-output/cmdline_1.ref \
     functional_tests/ref-output/colors.ref \
     functional_tests/ref-output/colors_hgg.ref \
     functional_tests/ref-output/cuts.ref \
     functional_tests/ref-output/decay_err_1.ref \
     functional_tests/ref-output/decay_err_2.ref \
     functional_tests/ref-output/decay_err_3.ref \
     functional_tests/ref-output/energy_scan_1.ref \
     functional_tests/ref-output/ep_3.ref \
     functional_tests/ref-output/epa_1.ref \
     functional_tests/ref-output/epa_2.ref \
     functional_tests/ref-output/epa_3.ref \
     functional_tests/ref-output/epa_4.ref \
     functional_tests/ref-output/event_dump_1.ref \
     functional_tests/ref-output/event_dump_2.ref \
     functional_tests/ref-output/event_eff_1.ref \
     functional_tests/ref-output/event_eff_2.ref \
     functional_tests/ref-output/event_failed_1.ref \
     functional_tests/ref-output/event_weights_1.ref \
     functional_tests/ref-output/event_weights_2.ref \
     functional_tests/ref-output/ewa_4.ref \
     functional_tests/ref-output/extpar.ref \
     functional_tests/ref-output/fatal.ref \
     functional_tests/ref-output/fatal_beam_decay.ref \
     functional_tests/ref-output/fks_res_2.ref \
     functional_tests/ref-output/flvsum_1.ref \
     functional_tests/ref-output/gaussian_1.ref \
     functional_tests/ref-output/gaussian_2.ref \
     functional_tests/ref-output/hadronize_1.ref \
     functional_tests/ref-output/hepmc_1.ref \
     functional_tests/ref-output/hepmc_2.ref \
     functional_tests/ref-output/hepmc_3.ref \
     functional_tests/ref-output/hepmc_4.ref \
     functional_tests/ref-output/hepmc_5.ref \
     functional_tests/ref-output/hepmc_6.ref \
     functional_tests/ref-output/hepmc_7.ref \
     functional_tests/ref-output/hepmc_9.ref \
     functional_tests/ref-output/hepmc_10.ref \
     functional_tests/ref-output/isr_1.ref \
     functional_tests/ref-output/isr_epa_1.ref \
     functional_tests/ref-output/jets_xsec.ref \
     functional_tests/ref-output/job_id_1.ref \
     functional_tests/ref-output/job_id_2.ref \
     functional_tests/ref-output/job_id_3.ref \
     functional_tests/ref-output/job_id_4.ref \
     functional_tests/ref-output/lcio_1.ref \
     functional_tests/ref-output/lcio_3.ref \
     functional_tests/ref-output/lcio_4.ref \
     functional_tests/ref-output/lcio_5.ref \
     functional_tests/ref-output/lcio_6.ref \
     functional_tests/ref-output/lcio_8.ref \
     functional_tests/ref-output/lcio_9.ref \
     functional_tests/ref-output/lcio_10.ref \
     functional_tests/ref-output/lcio_11.ref \
     functional_tests/ref-output/lhef_1.ref \
     functional_tests/ref-output/lhef_2.ref \
     functional_tests/ref-output/lhef_3.ref \
     functional_tests/ref-output/lhef_4.ref \
     functional_tests/ref-output/lhef_5.ref \
     functional_tests/ref-output/lhef_6.ref \
     functional_tests/ref-output/lhef_9.ref \
     functional_tests/ref-output/lhef_10.ref \
     functional_tests/ref-output/lhef_11.ref \
     functional_tests/ref-output/libraries_1.ref \
     functional_tests/ref-output/libraries_2.ref \
     functional_tests/ref-output/libraries_4.ref \
     functional_tests/ref-output/method_ovm_1.ref \
     functional_tests/ref-output/mlm_matching_fsr.ref \
     functional_tests/ref-output/mlm_pythia6_isr.ref \
     functional_tests/ref-output/model_change_1.ref \
     functional_tests/ref-output/model_change_2.ref \
     functional_tests/ref-output/model_change_3.ref \
     functional_tests/ref-output/model_scheme_1.ref \
     functional_tests/ref-output/model_test.ref \
     functional_tests/ref-output/mssmtest_1.ref \
     functional_tests/ref-output/mssmtest_2.ref \
     functional_tests/ref-output/mssmtest_3.ref \
     functional_tests/ref-output/multi_comp_4.ref \
     functional_tests/ref-output/nlo_1.ref \
     functional_tests/ref-output/nlo_2.ref \
     functional_tests/ref-output/nlo_6.ref \
     functional_tests/ref-output/nlo_decay_1.ref \
     functional_tests/ref-output/observables_1.ref \
     functional_tests/ref-output/openloops_1.ref \
     functional_tests/ref-output/openloops_2.ref \
     functional_tests/ref-output/openloops_4.ref \
     functional_tests/ref-output/openloops_5.ref \
     functional_tests/ref-output/openloops_6.ref \
     functional_tests/ref-output/openloops_7.ref \
     functional_tests/ref-output/openloops_8.ref \
     functional_tests/ref-output/openloops_9.ref \
     functional_tests/ref-output/openloops_10.ref \
     functional_tests/ref-output/openloops_11.ref \
     functional_tests/ref-output/pack_1.ref \
     functional_tests/ref-output/parton_shower_1.ref \
     functional_tests/ref-output/photon_isolation_1.ref \
     functional_tests/ref-output/photon_isolation_2.ref \
     functional_tests/ref-output/polarized_1.ref \
     functional_tests/ref-output/process_log.ref \
     functional_tests/ref-output/pythia6_1.ref \
     functional_tests/ref-output/pythia6_2.ref \
     functional_tests/ref-output/qcdtest_4.ref \
     functional_tests/ref-output/qcdtest_5.ref \
     functional_tests/ref-output/qcdtest_6.ref \
     functional_tests/ref-output/qedtest_1.ref \
     functional_tests/ref-output/qedtest_2.ref \
     functional_tests/ref-output/qedtest_5.ref \
     functional_tests/ref-output/qedtest_6.ref \
     functional_tests/ref-output/qedtest_7.ref \
     functional_tests/ref-output/qedtest_8.ref \
     functional_tests/ref-output/qedtest_9.ref \
     functional_tests/ref-output/qedtest_10.ref \
     functional_tests/ref-output/rambo_vamp_1.ref \
     functional_tests/ref-output/rambo_vamp_2.ref \
     functional_tests/ref-output/real_partition_1.ref \
     functional_tests/ref-output/rebuild_2.ref \
     functional_tests/ref-output/rebuild_3.ref \
     functional_tests/ref-output/rebuild_4.ref \
     functional_tests/ref-output/recola_1.ref \
     functional_tests/ref-output/recola_2.ref \
     functional_tests/ref-output/recola_3.ref \
     functional_tests/ref-output/recola_4.ref \
     functional_tests/ref-output/recola_5.ref \
     functional_tests/ref-output/recola_6.ref \
     functional_tests/ref-output/recola_7.ref \
     functional_tests/ref-output/recola_8.ref \
     functional_tests/ref-output/recola_9.ref \
     functional_tests/ref-output/resonances_5.ref \
     functional_tests/ref-output/resonances_6.ref \
     functional_tests/ref-output/resonances_7.ref \
     functional_tests/ref-output/resonances_8.ref \
     functional_tests/ref-output/resonances_9.ref \
     functional_tests/ref-output/resonances_12.ref \
     functional_tests/ref-output/restrictions.ref \
     functional_tests/ref-output/reweight_1.ref \
     functional_tests/ref-output/reweight_2.ref \
     functional_tests/ref-output/reweight_3.ref \
     functional_tests/ref-output/reweight_4.ref \
     functional_tests/ref-output/reweight_5.ref \
     functional_tests/ref-output/reweight_6.ref \
     functional_tests/ref-output/reweight_7.ref \
     functional_tests/ref-output/reweight_8.ref \
     functional_tests/ref-output/reweight_9.ref \
     functional_tests/ref-output/reweight_10.ref \
     functional_tests/ref-output/select_1.ref \
     functional_tests/ref-output/select_2.ref \
     functional_tests/ref-output/show_1.ref \
     functional_tests/ref-output/show_2.ref \
     functional_tests/ref-output/show_3.ref \
     functional_tests/ref-output/show_4.ref \
     functional_tests/ref-output/show_5.ref \
     functional_tests/ref-output/shower_err_1.ref \
     functional_tests/ref-output/sm_cms_1.ref \
     functional_tests/ref-output/smtest_1.ref \
     functional_tests/ref-output/smtest_3.ref \
     functional_tests/ref-output/smtest_4.ref \
     functional_tests/ref-output/smtest_5.ref \
     functional_tests/ref-output/smtest_6.ref \
     functional_tests/ref-output/smtest_7.ref \
     functional_tests/ref-output/smtest_9.ref \
     functional_tests/ref-output/smtest_10.ref \
     functional_tests/ref-output/smtest_11.ref \
     functional_tests/ref-output/smtest_12.ref \
     functional_tests/ref-output/smtest_13.ref \
     functional_tests/ref-output/smtest_14.ref \
     functional_tests/ref-output/smtest_15.ref \
     functional_tests/ref-output/smtest_16.ref \
     functional_tests/ref-output/smtest_17.ref \
     functional_tests/ref-output/spincor_1.ref \
     functional_tests/ref-output/static_1.ref \
     functional_tests/ref-output/static_2.ref \
     functional_tests/ref-output/stdhep_1.ref \
     functional_tests/ref-output/stdhep_2.ref \
     functional_tests/ref-output/stdhep_3.ref \
     functional_tests/ref-output/stdhep_4.ref \
     functional_tests/ref-output/stdhep_5.ref \
     functional_tests/ref-output/stdhep_6.ref \
     functional_tests/ref-output/structure_1.ref \
     functional_tests/ref-output/structure_2.ref \
     functional_tests/ref-output/structure_3.ref \
     functional_tests/ref-output/structure_4.ref \
     functional_tests/ref-output/structure_5.ref \
     functional_tests/ref-output/structure_6.ref \
     functional_tests/ref-output/structure_7.ref \
     functional_tests/ref-output/structure_8.ref \
     functional_tests/ref-output/susyhit.ref \
     functional_tests/ref-output/template_me_1.ref \
     functional_tests/ref-output/template_me_2.ref \
     functional_tests/ref-output/testproc_1.ref \
     functional_tests/ref-output/testproc_2.ref \
     functional_tests/ref-output/testproc_3.ref \
     functional_tests/ref-output/testproc_4.ref \
     functional_tests/ref-output/testproc_5.ref \
     functional_tests/ref-output/testproc_6.ref \
     functional_tests/ref-output/testproc_7.ref \
     functional_tests/ref-output/testproc_8.ref \
     functional_tests/ref-output/testproc_9.ref \
     functional_tests/ref-output/testproc_10.ref \
     functional_tests/ref-output/testproc_11.ref \
     functional_tests/ref-output/ufo_1.ref \
     functional_tests/ref-output/ufo_2.ref \
     functional_tests/ref-output/ufo_3.ref \
     functional_tests/ref-output/ufo_4.ref \
     functional_tests/ref-output/ufo_5.ref \
     functional_tests/ref-output/ufo_6.ref \
     functional_tests/ref-output/user_prc_threshold_1.ref \
     functional_tests/ref-output/user_prc_threshold_2.ref \
     functional_tests/ref-output/vamp2_1.ref \
     functional_tests/ref-output/vamp2_2.ref \
     functional_tests/ref-output/vamp2_3.ref \
     functional_tests/ref-output/vars.ref \
     ext_tests_nlo/ref-output/nlo_ee4j.ref \
     ext_tests_nlo/ref-output/nlo_ee4t.ref \
     ext_tests_nlo/ref-output/nlo_ee5j.ref \
     ext_tests_nlo/ref-output/nlo_eejj.ref \
     ext_tests_nlo/ref-output/nlo_eejjj.ref \
     ext_tests_nlo/ref-output/nlo_eett.ref \
     ext_tests_nlo/ref-output/nlo_eetth.ref \
     ext_tests_nlo/ref-output/nlo_eetthh.ref \
     ext_tests_nlo/ref-output/nlo_eetthj.ref \
     ext_tests_nlo/ref-output/nlo_eetthz.ref \
     ext_tests_nlo/ref-output/nlo_eettwjj.ref \
     ext_tests_nlo/ref-output/nlo_eettww.ref \
     ext_tests_nlo/ref-output/nlo_eettz.ref \
     ext_tests_nlo/ref-output/nlo_eettzj.ref \
     ext_tests_nlo/ref-output/nlo_eettzjj.ref \
     ext_tests_nlo/ref-output/nlo_eettzz.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_real_partition.ref \
     ext_tests_nlo/ref-output/nlo_pptttt.ref \
     ext_tests_nlo/ref-output/nlo_ppw.ref \
     ext_tests_nlo/ref-output/nlo_ppz.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_1.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_2.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_3.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_4.ref \
     ext_tests_nlo/ref-output/nlo_ppzw.ref \
     ext_tests_nlo/ref-output/nlo_ppzz.ref \
     ext_tests_nlo/ref-output/nlo_ppee_ew.ref \
     ext_tests_nlo/ref-output/nlo_pphee_ew.ref \
     ext_tests_nlo/ref-output/nlo_pphjj_ew.ref \
     ext_tests_nlo/ref-output/nlo_pphz_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppllll_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppllnn_ew.ref \
     ext_tests_nlo/ref-output/nlo_pptj_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppwhh_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppww_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppwzh_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppz_ew.ref \
     ext_tests_nlo/ref-output/nlo_ppzzz_ew.ref
 
 # Reference files that depend on the numerical precision
 REF_OUTPUT_FILES_DOUBLE = \
     functional_tests/ref-output-double/beam_events_2.ref \
     functional_tests/ref-output-double/beam_events_3.ref \
     functional_tests/ref-output-double/beam_setup_5.ref \
     functional_tests/ref-output-double/circe1_4.ref \
     functional_tests/ref-output-double/circe1_5.ref \
     functional_tests/ref-output-double/circe1_7.ref \
     functional_tests/ref-output-double/circe1_8.ref \
     functional_tests/ref-output-double/circe1_9.ref \
     functional_tests/ref-output-double/circe1_photons_1.ref \
     functional_tests/ref-output-double/circe1_photons_2.ref \
     functional_tests/ref-output-double/circe1_photons_3.ref \
     functional_tests/ref-output-double/circe1_photons_4.ref \
     functional_tests/ref-output-double/circe1_photons_5.ref \
     functional_tests/ref-output-double/colors_2.ref \
     functional_tests/ref-output-double/defaultcuts.ref \
     functional_tests/ref-output-double/ep_1.ref \
     functional_tests/ref-output-double/ep_2.ref \
     functional_tests/ref-output-double/ewa_1.ref \
     functional_tests/ref-output-double/ewa_2.ref \
     functional_tests/ref-output-double/ewa_3.ref \
     functional_tests/ref-output-double/fks_res_1.ref \
     functional_tests/ref-output-double/fks_res_3.ref \
     functional_tests/ref-output-double/helicity.ref \
     functional_tests/ref-output-double/hepmc_8.ref \
     functional_tests/ref-output-double/ilc.ref \
     functional_tests/ref-output-double/isr_2.ref \
     functional_tests/ref-output-double/isr_3.ref \
     functional_tests/ref-output-double/isr_4.ref \
     functional_tests/ref-output-double/isr_5.ref \
     functional_tests/ref-output-double/isr_6.ref \
     functional_tests/ref-output-double/lcio_2.ref \
     functional_tests/ref-output-double/lcio_7.ref \
     functional_tests/ref-output-double/lcio_12.ref \
     functional_tests/ref-output-double/lhapdf5.ref \
     functional_tests/ref-output-double/lhapdf6.ref \
     functional_tests/ref-output-double/lhef_7.ref \
     functional_tests/ref-output-double/mlm_matching_isr.ref \
     functional_tests/ref-output-double/multi_comp_1.ref \
     functional_tests/ref-output-double/multi_comp_2.ref \
     functional_tests/ref-output-double/multi_comp_3.ref \
     functional_tests/ref-output-double/testproc_12.ref \
     functional_tests/ref-output-double/nlo_3.ref \
     functional_tests/ref-output-double/nlo_4.ref \
     functional_tests/ref-output-double/nlo_5.ref \
     functional_tests/ref-output-double/nlo_7.ref \
     functional_tests/ref-output-double/nlo_8.ref \
     functional_tests/ref-output-double/nlo_9.ref \
     functional_tests/ref-output-double/nlo_10.ref \
     functional_tests/ref-output-double/observables_2.ref \
     functional_tests/ref-output-double/openloops_3.ref \
     functional_tests/ref-output-double/openloops_12.ref \
     functional_tests/ref-output-double/openloops_13.ref \
     functional_tests/ref-output-double/openloops_14.ref \
     functional_tests/ref-output-double/parton_shower_2.ref \
     functional_tests/ref-output-double/pdf_builtin.ref \
     functional_tests/ref-output-double/powheg_1.ref \
     functional_tests/ref-output-double/pythia6_3.ref \
     functional_tests/ref-output-double/pythia6_4.ref \
     functional_tests/ref-output-double/qcdtest_1.ref \
     functional_tests/ref-output-double/qcdtest_2.ref \
     functional_tests/ref-output-double/qcdtest_3.ref \
     functional_tests/ref-output-double/qedtest_3.ref \
     functional_tests/ref-output-double/qedtest_4.ref \
     functional_tests/ref-output-double/resonances_1.ref \
     functional_tests/ref-output-double/resonances_2.ref \
     functional_tests/ref-output-double/resonances_3.ref \
     functional_tests/ref-output-double/resonances_4.ref \
     functional_tests/ref-output-double/resonances_10.ref \
     functional_tests/ref-output-double/resonances_11.ref \
     functional_tests/ref-output-double/resonances_13.ref \
     functional_tests/ref-output-double/resonances_14.ref \
     functional_tests/ref-output-double/resonances_15.ref \
     functional_tests/ref-output-double/smtest_2.ref \
     functional_tests/ref-output-double/smtest_8.ref \
     functional_tests/ref-output-double/tauola_1.ref \
     functional_tests/ref-output-double/tauola_2.ref \
     functional_tests/ref-output-double/tauola_3.ref
 
 REF_OUTPUT_FILES_PREC = \
     functional_tests/ref-output-prec/beam_setup_5.ref \
     functional_tests/ref-output-prec/circe1_9.ref \
     functional_tests/ref-output-prec/circe1_photons_1.ref \
     functional_tests/ref-output-prec/circe1_photons_2.ref \
     functional_tests/ref-output-prec/circe1_photons_3.ref \
     functional_tests/ref-output-prec/circe1_photons_4.ref \
     functional_tests/ref-output-prec/circe1_photons_5.ref \
     functional_tests/ref-output-prec/colors_2.ref \
     functional_tests/ref-output-prec/defaultcuts.ref \
     functional_tests/ref-output-prec/ep_1.ref \
     functional_tests/ref-output-prec/ep_2.ref \
     functional_tests/ref-output-prec/ewa_1.ref \
     functional_tests/ref-output-prec/fks_res_1.ref \
     functional_tests/ref-output-prec/fks_res_3.ref \
     functional_tests/ref-output-prec/helicity.ref \
     functional_tests/ref-output-prec/ilc.ref \
     functional_tests/ref-output-prec/lhapdf5.ref \
     functional_tests/ref-output-prec/lhapdf6.ref \
     functional_tests/ref-output-prec/lhef_7.ref \
     functional_tests/ref-output-prec/multi_comp_1.ref \
     functional_tests/ref-output-prec/multi_comp_2.ref \
     functional_tests/ref-output-prec/multi_comp_3.ref \
     functional_tests/ref-output-prec/testproc_12.ref \
     functional_tests/ref-output-prec/nlo_3.ref \
     functional_tests/ref-output-prec/nlo_4.ref \
     functional_tests/ref-output-prec/parton_shower_2.ref \
     functional_tests/ref-output-prec/pdf_builtin.ref \
     functional_tests/ref-output-prec/qcdtest_1.ref \
     functional_tests/ref-output-prec/qcdtest_2.ref \
     functional_tests/ref-output-prec/qcdtest_3.ref \
     functional_tests/ref-output-prec/qedtest_3.ref \
     functional_tests/ref-output-prec/qedtest_4.ref \
     functional_tests/ref-output-prec/smtest_2.ref \
     functional_tests/ref-output-prec/smtest_8.ref
 
 REF_OUTPUT_FILES_EXT = \
     functional_tests/ref-output-ext/beam_events_2.ref \
     functional_tests/ref-output-ext/beam_events_3.ref \
     functional_tests/ref-output-ext/circe1_4.ref \
     functional_tests/ref-output-ext/circe1_5.ref \
     functional_tests/ref-output-ext/circe1_7.ref \
     functional_tests/ref-output-ext/circe1_8.ref \
     functional_tests/ref-output-ext/ewa_2.ref \
     functional_tests/ref-output-ext/ewa_3.ref \
     functional_tests/ref-output-ext/hepmc_8.ref \
     functional_tests/ref-output-ext/isr_2.ref \
     functional_tests/ref-output-ext/isr_3.ref \
     functional_tests/ref-output-ext/isr_4.ref \
     functional_tests/ref-output-ext/isr_5.ref \
     functional_tests/ref-output-ext/isr_6.ref \
     functional_tests/ref-output-ext/lcio_2.ref \
     functional_tests/ref-output-ext/lcio_7.ref \
     functional_tests/ref-output-ext/lcio_12.ref \
     functional_tests/ref-output-ext/mlm_matching_isr.ref \
     functional_tests/ref-output-ext/nlo_5.ref \
     functional_tests/ref-output-ext/nlo_7.ref \
     functional_tests/ref-output-ext/nlo_8.ref \
     functional_tests/ref-output-ext/nlo_9.ref \
     functional_tests/ref-output-ext/nlo_10.ref \
     functional_tests/ref-output-ext/observables_2.ref \
     functional_tests/ref-output-ext/openloops_3.ref \
     functional_tests/ref-output-ext/openloops_12.ref \
     functional_tests/ref-output-ext/openloops_13.ref \
     functional_tests/ref-output-ext/openloops_14.ref \
     functional_tests/ref-output-ext/powheg_1.ref \
     functional_tests/ref-output-ext/pythia6_3.ref \
     functional_tests/ref-output-ext/pythia6_4.ref \
     functional_tests/ref-output-ext/resonances_1.ref \
     functional_tests/ref-output-ext/resonances_2.ref \
     functional_tests/ref-output-ext/resonances_3.ref \
     functional_tests/ref-output-ext/resonances_4.ref \
     functional_tests/ref-output-ext/resonances_10.ref \
     functional_tests/ref-output-ext/resonances_11.ref \
     functional_tests/ref-output-ext/resonances_13.ref \
     functional_tests/ref-output-ext/resonances_14.ref \
     functional_tests/ref-output-ext/resonances_15.ref \
     functional_tests/ref-output-ext/tauola_1.ref \
     functional_tests/ref-output-ext/tauola_2.ref \
     functional_tests/ref-output-ext/tauola_3.ref
 
 REF_OUTPUT_FILES_QUAD = \
     functional_tests/ref-output-quad/beam_events_2.ref \
     functional_tests/ref-output-quad/beam_events_3.ref \
     functional_tests/ref-output-quad/circe1_4.ref \
     functional_tests/ref-output-quad/circe1_5.ref \
     functional_tests/ref-output-quad/circe1_7.ref \
     functional_tests/ref-output-quad/circe1_8.ref \
     functional_tests/ref-output-quad/ewa_2.ref \
     functional_tests/ref-output-quad/ewa_3.ref \
     functional_tests/ref-output-quad/hepmc_8.ref \
     functional_tests/ref-output-quad/isr_2.ref \
     functional_tests/ref-output-quad/isr_3.ref \
     functional_tests/ref-output-quad/isr_4.ref \
     functional_tests/ref-output-quad/isr_5.ref \
     functional_tests/ref-output-quad/isr_6.ref \
     functional_tests/ref-output-quad/lcio_2.ref \
     functional_tests/ref-output-quad/lcio_7.ref \
     functional_tests/ref-output-quad/lcio_12.ref \
     functional_tests/ref-output-quad/mlm_matching_isr.ref \
     functional_tests/ref-output-quad/nlo_5.ref \
     functional_tests/ref-output-quad/nlo_7.ref \
     functional_tests/ref-output-quad/nlo_8.ref \
     functional_tests/ref-output-quad/nlo_9.ref \
     functional_tests/ref-output-quad/nlo_10.ref \
     functional_tests/ref-output-quad/observables_2.ref \
     functional_tests/ref-output-quad/openloops_3.ref \
     functional_tests/ref-output-quad/openloops_12.ref \
     functional_tests/ref-output-quad/openloops_13.ref \
     functional_tests/ref-output-quad/openloops_14.ref \
     functional_tests/ref-output-quad/powheg_1.ref \
     functional_tests/ref-output-quad/pythia6_3.ref \
     functional_tests/ref-output-quad/pythia6_4.ref \
     functional_tests/ref-output-quad/resonances_1.ref \
     functional_tests/ref-output-quad/resonances_2.ref \
     functional_tests/ref-output-quad/resonances_3.ref \
     functional_tests/ref-output-quad/resonances_4.ref \
     functional_tests/ref-output-quad/resonances_10.ref \
     functional_tests/ref-output-quad/resonances_11.ref \
     functional_tests/ref-output-quad/resonances_13.ref \
     functional_tests/ref-output-quad/resonances_14.ref \
     functional_tests/ref-output-quad/resonances_15.ref \
     functional_tests/ref-output-quad/tauola_1.ref \
     functional_tests/ref-output-quad/tauola_2.ref \
     functional_tests/ref-output-quad/tauola_3.ref
 
 TESTSUITES_M4 = \
     $(MISC_TESTS_M4) \
     $(EXT_MSSM_M4) \
     $(EXT_NMSSM_M4)
 
 TESTSUITES_SIN = \
     $(MISC_TESTS_SIN) \
     $(EXT_ILC_SIN) \
     $(EXT_MSSM_SIN) \
     $(EXT_NMSSM_SIN) \
     $(EXT_SHOWER_SIN) \
     $(EXT_NLO_SIN) \
     $(EXT_NLO_ADD_SIN)
 
 
 MISC_TESTS_M4 =
 
 MISC_TESTS_SIN = \
     functional_tests/alphas.sin \
     functional_tests/analyze_1.sin \
     functional_tests/analyze_2.sin \
     functional_tests/analyze_3.sin \
     functional_tests/analyze_4.sin \
     functional_tests/analyze_5.sin \
     functional_tests/analyze_6.sin \
     functional_tests/beam_events_1.sin \
     functional_tests/beam_events_2.sin \
     functional_tests/beam_events_3.sin \
     functional_tests/beam_events_4.sin \
     functional_tests/beam_setup_1.sin \
     functional_tests/beam_setup_2.sin \
     functional_tests/beam_setup_3.sin \
     functional_tests/beam_setup_4.sin \
     functional_tests/beam_setup_5.sin \
     functional_tests/bjet_cluster.sin \
     functional_tests/br_redef_1.sin \
     functional_tests/cascades2_phs_1.sin \
     functional_tests/cascades2_phs_2.sin \
     functional_tests/circe1_1.sin \
     functional_tests/circe1_2.sin \
     functional_tests/circe1_3.sin \
     functional_tests/circe1_4.sin \
     functional_tests/circe1_5.sin \
     functional_tests/circe1_6.sin \
     functional_tests/circe1_7.sin \
     functional_tests/circe1_8.sin \
     functional_tests/circe1_9.sin \
     functional_tests/circe1_10.sin \
     functional_tests/circe1_errors_1.sin \
     functional_tests/circe1_photons_1.sin \
     functional_tests/circe1_photons_2.sin \
     functional_tests/circe1_photons_3.sin \
     functional_tests/circe1_photons_4.sin \
     functional_tests/circe1_photons_5.sin \
     functional_tests/circe2_1.sin \
     functional_tests/circe2_2.sin \
     functional_tests/circe2_3.sin \
     functional_tests/cmdline_1.sin \
     functional_tests/cmdline_1_a.sin \
     functional_tests/cmdline_1_b.sin \
     functional_tests/colors.sin \
     functional_tests/colors_2.sin \
     functional_tests/colors_hgg.sin \
     functional_tests/cuts.sin \
     functional_tests/decay_err_1.sin \
     functional_tests/decay_err_2.sin \
     functional_tests/decay_err_3.sin \
     functional_tests/defaultcuts.sin \
     functional_tests/empty.sin \
     functional_tests/energy_scan_1.sin \
     functional_tests/ep_1.sin \
     functional_tests/ep_2.sin \
     functional_tests/ep_3.sin \
     functional_tests/epa_1.sin \
     functional_tests/epa_2.sin \
     functional_tests/epa_3.sin \
     functional_tests/epa_4.sin \
     functional_tests/event_dump_1.sin \
     functional_tests/event_dump_2.sin \
     functional_tests/event_eff_1.sin \
     functional_tests/event_eff_2.sin \
     functional_tests/event_failed_1.sin \
     functional_tests/event_weights_1.sin \
     functional_tests/event_weights_2.sin \
     functional_tests/ewa_1.sin \
     functional_tests/ewa_2.sin \
     functional_tests/ewa_3.sin \
     functional_tests/ewa_4.sin \
     functional_tests/extpar.sin \
     functional_tests/fatal.sin \
     functional_tests/fatal_beam_decay.sin \
     functional_tests/fks_res_1.sin \
     functional_tests/fks_res_2.sin \
     functional_tests/fks_res_3.sin \
     functional_tests/flvsum_1.sin \
     functional_tests/gaussian_1.sin \
     functional_tests/gaussian_2.sin \
     functional_tests/hadronize_1.sin \
     functional_tests/helicity.sin \
     functional_tests/hepmc_1.sin \
     functional_tests/hepmc_2.sin \
     functional_tests/hepmc_3.sin \
     functional_tests/hepmc_4.sin \
     functional_tests/hepmc_5.sin \
     functional_tests/hepmc_6.sin \
     functional_tests/hepmc_7.sin \
     functional_tests/hepmc_8.sin \
     functional_tests/hepmc_9.sin \
     functional_tests/hepmc_10.sin \
     functional_tests/ilc.sin \
     functional_tests/isr_1.sin \
     functional_tests/isr_2.sin \
     functional_tests/isr_3.sin \
     functional_tests/isr_4.sin \
     functional_tests/isr_5.sin \
     functional_tests/isr_6.sin \
     functional_tests/isr_epa_1.sin \
     functional_tests/jets_xsec.sin \
     functional_tests/job_id_1.sin \
     functional_tests/job_id_2.sin \
     functional_tests/job_id_3.sin \
     functional_tests/job_id_4.sin \
     functional_tests/lcio_1.sin \
     functional_tests/lcio_2.sin \
     functional_tests/lcio_3.sin \
     functional_tests/lcio_4.sin \
     functional_tests/lcio_5.sin \
     functional_tests/lcio_6.sin \
     functional_tests/lcio_7.sin \
     functional_tests/lcio_8.sin \
     functional_tests/lcio_9.sin \
     functional_tests/lcio_10.sin \
     functional_tests/lcio_11.sin \
     functional_tests/lcio_12.sin \
     functional_tests/lhapdf5.sin \
     functional_tests/lhapdf6.sin \
     functional_tests/lhef_1.sin \
     functional_tests/lhef_2.sin \
     functional_tests/lhef_3.sin \
     functional_tests/lhef_4.sin \
     functional_tests/lhef_5.sin \
     functional_tests/lhef_6.sin \
     functional_tests/lhef_7.sin \
     functional_tests/lhef_8.sin \
     functional_tests/lhef_9.sin \
     functional_tests/lhef_10.sin \
     functional_tests/lhef_11.sin \
     functional_tests/libraries_1.sin \
     functional_tests/libraries_2.sin \
     functional_tests/libraries_3.sin \
     functional_tests/libraries_4.sin \
     functional_tests/method_ovm_1.sin \
     functional_tests/mlm_matching_fsr.sin \
     functional_tests/mlm_matching_isr.sin \
     functional_tests/mlm_pythia6_isr.sin \
     functional_tests/model_change_1.sin \
     functional_tests/model_change_2.sin \
     functional_tests/model_change_3.sin \
     functional_tests/model_scheme_1.sin \
     functional_tests/model_test.sin \
     functional_tests/mssmtest_1.sin \
     functional_tests/mssmtest_2.sin \
     functional_tests/mssmtest_3.sin \
     functional_tests/multi_comp_1.sin \
     functional_tests/multi_comp_2.sin \
     functional_tests/multi_comp_3.sin \
     functional_tests/multi_comp_4.sin \
     functional_tests/nlo_1.sin \
     functional_tests/nlo_2.sin \
     functional_tests/nlo_3.sin \
     functional_tests/nlo_4.sin \
     functional_tests/nlo_5.sin \
     functional_tests/nlo_6.sin \
     functional_tests/nlo_7.sin \
     functional_tests/nlo_8.sin \
     functional_tests/nlo_9.sin \
     functional_tests/nlo_10.sin \
     functional_tests/nlo_decay_1.sin \
     functional_tests/observables_1.sin \
     functional_tests/observables_2.sin \
     functional_tests/openloops_1.sin \
     functional_tests/openloops_2.sin \
     functional_tests/openloops_3.sin \
     functional_tests/openloops_4.sin \
     functional_tests/openloops_5.sin \
     functional_tests/openloops_6.sin \
     functional_tests/openloops_7.sin \
     functional_tests/openloops_8.sin \
     functional_tests/openloops_9.sin \
     functional_tests/openloops_10.sin \
     functional_tests/openloops_11.sin \
     functional_tests/openloops_12.sin \
     functional_tests/openloops_13.sin \
     functional_tests/openloops_14.sin \
     functional_tests/pack_1.sin \
     functional_tests/parton_shower_1.sin \
     functional_tests/parton_shower_2.sin \
     functional_tests/pdf_builtin.sin \
     functional_tests/photon_isolation_1.sin \
     functional_tests/photon_isolation_2.sin \
     functional_tests/polarized_1.sin \
     functional_tests/powheg_1.sin \
     functional_tests/process_log.sin \
     functional_tests/pythia6_1.sin \
     functional_tests/pythia6_2.sin \
     functional_tests/pythia6_3.sin \
     functional_tests/pythia6_4.sin \
     functional_tests/pythia8_1.sin \
     functional_tests/pythia8_2.sin \
     functional_tests/qcdtest_1.sin \
     functional_tests/qcdtest_2.sin \
     functional_tests/qcdtest_3.sin \
     functional_tests/qcdtest_4.sin \
     functional_tests/qcdtest_5.sin \
     functional_tests/qcdtest_6.sin \
     functional_tests/qedtest_1.sin \
     functional_tests/qedtest_2.sin \
     functional_tests/qedtest_3.sin \
     functional_tests/qedtest_4.sin \
     functional_tests/qedtest_5.sin \
     functional_tests/qedtest_6.sin \
     functional_tests/qedtest_7.sin \
     functional_tests/qedtest_8.sin \
     functional_tests/qedtest_9.sin \
     functional_tests/qedtest_10.sin \
     functional_tests/rambo_vamp_1.sin \
     functional_tests/rambo_vamp_2.sin \
     functional_tests/real_partition_1.sin \
     functional_tests/rebuild_1.sin \
     functional_tests/rebuild_2.sin \
     functional_tests/rebuild_3.sin \
     functional_tests/rebuild_4.sin \
     functional_tests/rebuild_5.sin \
     functional_tests/recola_1.sin \
     functional_tests/recola_2.sin \
     functional_tests/recola_3.sin \
     functional_tests/recola_4.sin \
     functional_tests/recola_5.sin \
     functional_tests/recola_6.sin \
     functional_tests/recola_7.sin \
     functional_tests/recola_8.sin \
     functional_tests/recola_9.sin \
     functional_tests/resonances_1.sin \
     functional_tests/resonances_2.sin \
     functional_tests/resonances_3.sin \
     functional_tests/resonances_4.sin \
     functional_tests/resonances_5.sin \
     functional_tests/resonances_6.sin \
     functional_tests/resonances_7.sin \
     functional_tests/resonances_8.sin \
     functional_tests/resonances_9.sin \
     functional_tests/resonances_10.sin \
     functional_tests/resonances_11.sin \
     functional_tests/resonances_12.sin \
     functional_tests/resonances_13.sin \
     functional_tests/resonances_14.sin \
     functional_tests/resonances_15.sin \
     functional_tests/restrictions.sin \
     functional_tests/reweight_1.sin \
     functional_tests/reweight_2.sin \
     functional_tests/reweight_3.sin \
     functional_tests/reweight_4.sin \
     functional_tests/reweight_5.sin \
     functional_tests/reweight_6.sin \
     functional_tests/reweight_7.sin \
     functional_tests/reweight_8.sin \
     functional_tests/reweight_9.sin \
     functional_tests/reweight_10.sin \
     functional_tests/select_1.sin \
     functional_tests/select_2.sin \
     functional_tests/show_1.sin \
     functional_tests/show_2.sin \
     functional_tests/show_3.sin \
     functional_tests/show_4.sin \
     functional_tests/show_5.sin \
     functional_tests/shower_err_1.sin \
     functional_tests/sm_cms_1.sin \
     functional_tests/smtest_1.sin \
     functional_tests/smtest_2.sin \
     functional_tests/smtest_3.sin \
     functional_tests/smtest_4.sin \
     functional_tests/smtest_5.sin \
     functional_tests/smtest_6.sin \
     functional_tests/smtest_7.sin \
     functional_tests/smtest_8.sin \
     functional_tests/smtest_9.sin \
     functional_tests/smtest_10.sin \
     functional_tests/smtest_11.sin \
     functional_tests/smtest_12.sin \
     functional_tests/smtest_13.sin \
     functional_tests/smtest_14.sin \
     functional_tests/smtest_15.sin \
     functional_tests/smtest_16.sin \
     functional_tests/smtest_17.sin \
     functional_tests/spincor_1.sin \
     functional_tests/static_1.exe.sin \
     functional_tests/static_1.sin \
     functional_tests/static_2.exe.sin \
     functional_tests/static_2.sin \
     functional_tests/stdhep_1.sin \
     functional_tests/stdhep_2.sin \
     functional_tests/stdhep_3.sin \
     functional_tests/stdhep_4.sin \
     functional_tests/stdhep_5.sin \
     functional_tests/stdhep_6.sin \
     functional_tests/structure_1.sin \
     functional_tests/structure_2.sin \
     functional_tests/structure_3.sin \
     functional_tests/structure_4.sin \
     functional_tests/structure_5.sin \
     functional_tests/structure_6.sin \
     functional_tests/structure_7.sin \
     functional_tests/structure_8.sin \
     functional_tests/susyhit.sin \
     functional_tests/tauola_1.sin \
     functional_tests/tauola_2.sin \
     functional_tests/tauola_3.sin \
     functional_tests/template_me_1.sin \
     functional_tests/template_me_2.sin \
     functional_tests/testproc_1.sin \
     functional_tests/testproc_2.sin \
     functional_tests/testproc_3.sin \
     functional_tests/testproc_4.sin \
     functional_tests/testproc_5.sin \
     functional_tests/testproc_6.sin \
     functional_tests/testproc_7.sin \
     functional_tests/testproc_8.sin \
     functional_tests/testproc_9.sin \
     functional_tests/testproc_10.sin \
     functional_tests/testproc_11.sin \
     functional_tests/testproc_12.sin \
     functional_tests/ufo_1.sin \
     functional_tests/ufo_2.sin \
     functional_tests/ufo_3.sin \
     functional_tests/ufo_4.sin \
     functional_tests/ufo_5.sin \
     functional_tests/ufo_6.sin \
     functional_tests/user_prc_threshold_1.sin \
     functional_tests/user_prc_threshold_2.sin \
     functional_tests/vamp2_1.sin \
     functional_tests/vamp2_2.sin \
     functional_tests/vamp2_3.sin \
     functional_tests/vars.sin
 
 EXT_MSSM_M4 = \
     ext_tests_mssm/mssm_ext-aa.m4 \
     ext_tests_mssm/mssm_ext-bb.m4 \
     ext_tests_mssm/mssm_ext-bt.m4 \
     ext_tests_mssm/mssm_ext-dd.m4 \
     ext_tests_mssm/mssm_ext-dd2.m4 \
     ext_tests_mssm/mssm_ext-ddckm.m4 \
     ext_tests_mssm/mssm_ext-dg.m4 \
     ext_tests_mssm/mssm_ext-ee.m4 \
     ext_tests_mssm/mssm_ext-ee2.m4 \
     ext_tests_mssm/mssm_ext-en.m4 \
     ext_tests_mssm/mssm_ext-ga.m4 \
     ext_tests_mssm/mssm_ext-gg.m4 \
     ext_tests_mssm/mssm_ext-gw.m4 \
     ext_tests_mssm/mssm_ext-gz.m4 \
     ext_tests_mssm/mssm_ext-tn.m4 \
     ext_tests_mssm/mssm_ext-tt.m4 \
     ext_tests_mssm/mssm_ext-ug.m4 \
     ext_tests_mssm/mssm_ext-uu.m4 \
     ext_tests_mssm/mssm_ext-uu2.m4 \
     ext_tests_mssm/mssm_ext-uuckm.m4 \
     ext_tests_mssm/mssm_ext-wa.m4 \
     ext_tests_mssm/mssm_ext-ww.m4 \
     ext_tests_mssm/mssm_ext-wz.m4 \
     ext_tests_mssm/mssm_ext-za.m4 \
     ext_tests_mssm/mssm_ext-zz.m4
 
 EXT_NMSSM_M4 = \
     ext_tests_nmssm/nmssm_ext-aa.m4  \
     ext_tests_nmssm/nmssm_ext-bb1.m4 \
     ext_tests_nmssm/nmssm_ext-bb2.m4 \
     ext_tests_nmssm/nmssm_ext-bt.m4  \
     ext_tests_nmssm/nmssm_ext-dd1.m4 \
     ext_tests_nmssm/nmssm_ext-dd2.m4 \
     ext_tests_nmssm/nmssm_ext-ee1.m4 \
     ext_tests_nmssm/nmssm_ext-ee2.m4 \
     ext_tests_nmssm/nmssm_ext-en.m4  \
     ext_tests_nmssm/nmssm_ext-ga.m4  \
     ext_tests_nmssm/nmssm_ext-gg.m4  \
     ext_tests_nmssm/nmssm_ext-gw.m4  \
     ext_tests_nmssm/nmssm_ext-gz.m4  \
     ext_tests_nmssm/nmssm_ext-qg.m4  \
     ext_tests_nmssm/nmssm_ext-tn.m4  \
     ext_tests_nmssm/nmssm_ext-tt1.m4 \
     ext_tests_nmssm/nmssm_ext-tt2.m4 \
     ext_tests_nmssm/nmssm_ext-uu1.m4 \
     ext_tests_nmssm/nmssm_ext-uu2.m4 \
     ext_tests_nmssm/nmssm_ext-wa.m4  \
     ext_tests_nmssm/nmssm_ext-ww1.m4 \
     ext_tests_nmssm/nmssm_ext-ww2.m4 \
     ext_tests_nmssm/nmssm_ext-wz.m4  \
     ext_tests_nmssm/nmssm_ext-za.m4  \
     ext_tests_nmssm/nmssm_ext-zz1.m4 \
     ext_tests_nmssm/nmssm_ext-zz2.m4
 
 EXT_MSSM_SIN = $(EXT_MSSM_M4:.m4=.sin)
 EXT_NMSSM_SIN = $(EXT_NMSSM_M4:.m4=.sin)
 
 EXT_ILC_SIN = \
     ext_tests_ilc/ilc_settings.sin \
     ext_tests_ilc/ilc_top_pair_360.sin \
     ext_tests_ilc/ilc_top_pair_500.sin \
     ext_tests_ilc/ilc_vbf_higgs_360.sin \
     ext_tests_ilc/ilc_vbf_higgs_500.sin \
     ext_tests_ilc/ilc_vbf_no_higgs_360.sin \
     ext_tests_ilc/ilc_vbf_no_higgs_500.sin \
     ext_tests_ilc/ilc_higgs_strahlung_360.sin \
     ext_tests_ilc/ilc_higgs_strahlung_500.sin \
     ext_tests_ilc/ilc_higgs_strahlung_background_360.sin \
     ext_tests_ilc/ilc_higgs_strahlung_background_500.sin \
     ext_tests_ilc/ilc_higgs_coupling_360.sin \
     ext_tests_ilc/ilc_higgs_coupling_500.sin \
     ext_tests_ilc/ilc_higgs_coupling_background_360.sin \
     ext_tests_ilc/ilc_higgs_coupling_background_500.sin
 
 EXT_SHOWER_SIN = \
     ext_tests_shower/shower_1_norad.sin \
     ext_tests_shower/shower_2_aall.sin \
     ext_tests_shower/shower_3_bb.sin \
     ext_tests_shower/shower_3_jj.sin \
     ext_tests_shower/shower_3_qqqq.sin \
     ext_tests_shower/shower_3_tt.sin \
     ext_tests_shower/shower_3_z_nu.sin \
     ext_tests_shower/shower_3_z_tau.sin \
     ext_tests_shower/shower_4_ee.sin \
     ext_tests_shower/shower_5.sin \
     ext_tests_shower/shower_6.sin
 
 EXT_NLO_SIN = \
     ext_tests_nlo/nlo_ee4b.sin \
     ext_tests_nlo/nlo_ee4j.sin \
     ext_tests_nlo/nlo_ee4t.sin \
     ext_tests_nlo/nlo_ee4tj.sin \
     ext_tests_nlo/nlo_ee5j.sin \
     ext_tests_nlo/nlo_eebb.sin \
     ext_tests_nlo/nlo_eebbj.sin \
     ext_tests_nlo/nlo_eebbjj.sin \
     ext_tests_nlo/nlo_eejj.sin \
     ext_tests_nlo/nlo_eejjj.sin \
     ext_tests_nlo/nlo_eett.sin \
     ext_tests_nlo/nlo_eetta.sin \
     ext_tests_nlo/nlo_eettaa.sin \
     ext_tests_nlo/nlo_eettah.sin \
     ext_tests_nlo/nlo_eettaj.sin \
     ext_tests_nlo/nlo_eettajj.sin \
     ext_tests_nlo/nlo_eettaz.sin \
     ext_tests_nlo/nlo_eettbb.sin \
     ext_tests_nlo/nlo_eetth.sin \
     ext_tests_nlo/nlo_eetthh.sin \
     ext_tests_nlo/nlo_eetthj.sin \
     ext_tests_nlo/nlo_eetthjj.sin \
     ext_tests_nlo/nlo_eetthz.sin \
     ext_tests_nlo/nlo_eettj.sin \
     ext_tests_nlo/nlo_eettjj.sin \
     ext_tests_nlo/nlo_eettjjj.sin \
     ext_tests_nlo/nlo_eettwjj.sin \
     ext_tests_nlo/nlo_eettww.sin \
     ext_tests_nlo/nlo_eettz.sin \
     ext_tests_nlo/nlo_eettzj.sin \
     ext_tests_nlo/nlo_eettzjj.sin \
     ext_tests_nlo/nlo_eettzz.sin \
     ext_tests_nlo/nlo_ppzj_real_partition.sin \
     ext_tests_nlo/nlo_pptttt.sin \
     ext_tests_nlo/nlo_ppw.sin \
     ext_tests_nlo/nlo_ppz.sin \
     ext_tests_nlo/nlo_ppzj_sim_1.sin \
     ext_tests_nlo/nlo_ppzj_sim_2.sin \
     ext_tests_nlo/nlo_ppzj_sim_3.sin \
     ext_tests_nlo/nlo_ppzj_sim_4.sin \
     ext_tests_nlo/nlo_ppzw.sin \
     ext_tests_nlo/nlo_ppzz.sin \
     ext_tests_nlo/nlo_ppee_ew.sin \
     ext_tests_nlo/nlo_pphee_ew.sin \
     ext_tests_nlo/nlo_pphjj_ew.sin \
     ext_tests_nlo/nlo_pphz_ew.sin \
     ext_tests_nlo/nlo_ppllll_ew.sin \
     ext_tests_nlo/nlo_ppllnn_ew.sin \
     ext_tests_nlo/nlo_pptj_ew.sin \
     ext_tests_nlo/nlo_ppwhh_ew.sin \
     ext_tests_nlo/nlo_ppww_ew.sin \
     ext_tests_nlo/nlo_ppwzh_ew.sin \
     ext_tests_nlo/nlo_ppz_ew.sin \
     ext_tests_nlo/nlo_ppzzz_ew.sin \
     ext_tests_nlo/nlo_settings.sin \
     ext_tests_nlo/nlo_settings_ew.sin
 
 EXT_NLO_ADD_SIN = \
     ext_tests_nlo_add/nlo_decay_tbw.sin \
     ext_tests_nlo_add/nlo_fks_delta_i_ppee.sin \
     ext_tests_nlo_add/nlo_fks_delta_o_eejj.sin \
     ext_tests_nlo_add/nlo_jets.sin \
     ext_tests_nlo_add/nlo_methods_gosam.sin \
     ext_tests_nlo_add/nlo_qq_powheg.sin \
     ext_tests_nlo_add/nlo_threshold_factorized.sin \
     ext_tests_nlo_add/nlo_threshold.sin \
     ext_tests_nlo_add/nlo_tt_powheg_sudakov.sin \
     ext_tests_nlo_add/nlo_tt_powheg.sin \
     ext_tests_nlo_add/nlo_tt.sin \
     ext_tests_nlo_add/nlo_uu_powheg.sin \
     ext_tests_nlo_add/nlo_uu.sin
 
 all-local: $(TESTSUITES_SIN)
 
 if M4_AVAILABLE
 SUFFIXES = .m4 .sin
 .m4.sin:
 	case "$@" in \
 	*/*) \
 		mkdir -p `sed 's,/.[^/]*$$,,g' <<< "$@"` ;; \
 	esac
 	$(M4) $(srcdir)/$(TESTSUITE_MACROS) $< > $@
 endif M4_AVAILABLE
Index: trunk/tests/unit_tests/Makefile.am
===================================================================
--- trunk/tests/unit_tests/Makefile.am	(revision 8766)
+++ trunk/tests/unit_tests/Makefile.am	(revision 8767)
@@ -1,452 +1,453 @@
 ## Makefile.am -- Makefile for executable WHIZARD test scripts
 ##
 ## Process this file with automake to produce Makefile.in
 ##
 ########################################################################
 #
 # Copyright (C) 1999-2021 by 
 #     Wolfgang Kilian <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     with contributions from
 #     cf. main AUTHORS file
 #
 # WHIZARD is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2, or (at your option)
 # any later version.
 #
 # WHIZARD is distributed in the hope that it will be useful, but
 # WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #
 ########################################################################
 
 WHIZARD_UT_DRIVER = run_whizard_ut.sh
 WHIZARD_C_TEST_DRIVER = run_whizard_c_test.sh
 WHIZARD_CC_TEST_DRIVER = run_whizard_cc_test.sh
 
 UNIT_TESTS = \
     analysis.run \
     commands.run \
     pdg_arrays.run \
     expressions.run \
     beams.run \
     su_algebra.run \
     bloch_vectors.run \
     polarizations.run \
     binary_tree.run \
     array_list.run \
     iterator.run \
     md5.run \
     cputime.run \
     lexers.run \
     parser.run \
     color.run \
     os_interface.run \
     evaluators.run \
     formats.run \
     sorting.run \
     grids.run \
     solver.run \
     state_matrices.run \
     interactions.run \
     xml.run \
     phs_points.run \
     sm_qcd.run \
+    sm_qed.run \
     sm_physics.run \
     models.run \
     auto_components.run \
     radiation_generator.run \
     blha.run \
     particles.run \
     beam_structures.run \
     sf_aux.run \
     sf_mappings.run \
     sf_base.run \
     sf_pdf_builtin.run \
     sf_isr.run \
     sf_epa.run \
     sf_ewa.run \
     sf_circe1.run \
     sf_circe2.run \
     sf_gaussian.run \
     sf_beam_events.run \
     sf_escan.run \
     phs_base.run \
     phs_none.run \
     phs_single.run \
     phs_rambo.run \
     resonances.run \
     phs_trees.run \
     phs_forests.run \
     phs_wood.run \
     phs_fks_generator.run \
     fks_regions.run \
     real_subtraction.run \
     rng_base.run \
     rng_tao.run \
     rng_stream.run \
     selectors.run \
     vegas.run \
     vamp2.run \
     mci_base.run \
     mci_none.run \
     mci_midpoint.run \
     mci_vamp.run \
     mci_vamp2.run \
     integration_results.run \
     prclib_interfaces.run \
     particle_specifiers.run \
     process_libraries.run \
     prclib_stacks.run \
     slha_interface.run \
     prc_test.run \
     prc_template_me.run \
     parton_states.run \
     subevt_expr.run \
     processes.run \
     process_stacks.run \
     cascades.run \
     cascades2_lexer.run \
     cascades2.run \
     event_transforms.run \
     resonance_insertion.run \
     recoil_kinematics.run \
     isr_handler.run \
     epa_handler.run \
     decays.run \
     shower.run \
     shower_base.run \
     events.run \
     hep_events.run \
     whizard_lha.run \
     pythia8.run \
     eio_data.run \
     eio_base.run \
     eio_direct.run \
     eio_raw.run \
     eio_checkpoints.run \
     eio_lhef.run \
     eio_stdhep.run \
     eio_ascii.run \
     eio_weights.run \
     eio_dump.run \
     iterations.run \
     rt_data.run \
     dispatch.run \
     dispatch_rng.run \
     dispatch_mci.run \
     dispatch_phs.run \
     dispatch_transforms.run \
     process_configurations.run \
     event_streams.run \
     integrations.run \
     ttv_formfactors.run
 
 XFAIL_UNIT_TESTS =
 
 UNIT_TESTS_REQ_EV_ANA = \
 		phs_wood_vis.run \
 		prc_omega_diags.run \
 		integrations_history.run
 
 UNIT_TESTS_REQ_FASTJET = \
 		jets.run
 
 UNIT_TESTS_REQ_HEPMC2 = \
     hepmc2.run \
     eio_hepmc2.run \
     api_hepmc2.run
 
 UNIT_TESTS_REQ_HEPMC3 = \
     hepmc3.run \
     eio_hepmc3.run \
     api_hepmc3.run
 
 UNIT_TESTS_REQ_LCIO = \
     lcio.run \
     eio_lcio.run \
     api_lcio.run
 
 UNIT_TESTS_REQ_OCAML = \
     prc_omega.run \
     compilations.run \
     compilations_static.run \
     restricted_subprocesses.run \
     simulations.run \
     api.run \
     api_c.run \
     api_cc.run
 
 UNIT_TESTS_REQ_RECOLA = \
 	 prc_recola.run
 
 UNIT_TESTS_REQ_LHAPDF5 = \
 		sf_lhapdf5.run
 UNIT_TESTS_REQ_LHAPDF6 = \
 		sf_lhapdf6.run
 
 TEST_DRIVERS_RUN = \
     $(UNIT_TESTS) \
     $(UNIT_TESTS_REQ_HEPMC2) \
     $(UNIT_TESTS_REQ_HEPMC3) \
     $(UNIT_TESTS_REQ_LCIO) \
     $(UNIT_TESTS_REQ_FASTJET) \
     $(UNIT_TESTS_REQ_LHAPDF5) \
     $(UNIT_TESTS_REQ_LHAPDF6) \
     $(UNIT_TESTS_REQ_OCAML) \
     $(UNIT_TESTS_REQ_RECOLA)
 TEST_DRIVERS_SH = $(TEST_DRIVERS_RUN:.run=.sh)
 
 ########################################################################
 
 TESTS =
 XFAIL_TESTS =
 TESTS_SRC =
 
 UNIT_TESTS += $(UNIT_TESTS_REQ_FASTJET)
 UNIT_TESTS += $(UNIT_TESTS_REQ_HEPMC2)
 UNIT_TESTS += $(UNIT_TESTS_REQ_HEPMC3)
 UNIT_TESTS += $(UNIT_TESTS_REQ_LCIO)
 UNIT_TESTS += $(UNIT_TESTS_REQ_LHAPDF5)
 UNIT_TESTS += $(UNIT_TESTS_REQ_LHAPDF6)
 UNIT_TESTS += $(UNIT_TESTS_REQ_OCAML)
 UNIT_TESTS += $(UNIT_TESTS_REQ_EV_ANA)
 UNIT_TESTS += $(UNIT_TESTS_REQ_RECOLA)
 
 TESTS += $(UNIT_TESTS)
 XFAIL_TESTS += $(XFAIL_UNIT_TESTS)
 
 
 EXTRA_DIST = $(TEST_DRIVERS_SH)
 		$(TESTS_SRC)
 
 ########################################################################
 # Force building the whizard_ut executable in the main src directory.
 # This depends on the unit-test libraries which will be built recursively.
 
 WHIZARD_UT = ../../src/whizard_ut
 
 $(TEST_DRIVERS_RUN): $(WHIZARD_UT)
 
 $(WHIZARD_UT):
 	$(MAKE) -C ../../src check
 
 ########################################################################
 # Force building the whizard_c_test executable in the main src directory.
 # This depends on the unit-test libraries which will be built recursively.
 
 WHIZARD_C_TEST = ../../src/whizard_c_test
 
 $(TEST_DRIVERS_RUN): $(WHIZARD_C_TEST)
 
 $(WHIZARD_C_TEST): $(WHIZARD_UT)
 
 ########################################################################
 # Force building the whizard_c_test executable in the main src directory.
 # This depends on the unit-test libraries which will be built recursively.
 
 WHIZARD_CC_TEST = ../../src/whizard_cc_test
 
 $(TEST_DRIVERS_RUN): $(WHIZARD_CC_TEST)
 
 $(WHIZARD_CC_TEST): $(WHIZARD_C_TEST)
 
 ########################################################################
 
 VPATH = $(srcdir)
 
 SUFFIXES = .sh .run
 
 .sh.run:
 	@rm -f $@
 	@cp $< $@
 	@chmod +x $@
 
 sf_beam_events.run: test_beam_events.dat
 test_beam_events.dat: $(top_builddir)/share/beam-sim/test_beam_events.dat
 	cp $< $@
 
 cascades2_lexer.run: cascades2_lexer_1.fds
 cascades2_lexer_1.fds: $(top_srcdir)/share/tests/cascades2_lexer_1.fds
 	cp $< $@
 cascades2.run: cascades2_1.fds cascades2_2.fds
 cascades2_1.fds: $(top_srcdir)/share/tests/cascades2_1.fds
 	cp $< $@
 cascades2_2.fds: $(top_srcdir)/share/tests/cascades2_2.fds
 	cp $< $@
 
 WT_OCAML_NATIVE_EXT=opt
 
 if MPOST_AVAILABLE
 commands.run: gamelan.sty sps1ap_decays.slha
 gamelan.sty: $(top_builddir)/src/gamelan/gamelan.sty
 	cp $< $@
 
 $(top_builddir)/src/gamelan/gamelan.sty:
 	$(MAKE) -C $(top_builddir)/src/gamelan gamelan.sty
 else
 commands.run: sps1ap_decays.slha
 endif
 
 sps1ap_decays.slha: $(top_builddir)/share/susy/sps1ap_decays.slha
 	cp $< $@
 
 if OCAML_AVAILABLE
 
 UFO_TAG_FILE = __init__.py
 UFO_MODELPATH = ../models/UFO
 
 models.run: $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE)
 
 $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE): $(top_srcdir)/omega/tests/UFO/SM/$(UFO_TAG_FILE)
 	$(MAKE) -C $(UFO_MODELPATH)/SM all
 
 endif
 
 BUILT_SOURCES = \
     TESTFLAG  \
     HEPMC2_FLAG \
     HEPMC3_FLAG \
     LCIO_FLAG \
     FASTJET_FLAG \
     LHAPDF5_FLAG \
     LHAPDF6_FLAG \
     EVENT_ANALYSIS_FLAG \
     OCAML_FLAG \
     RECOLA_FLAG \
     PYTHIA6_FLAG \
     PYTHIA8_FLAG \
     STATIC_FLAG \
     ref-output \
     err-output
 
 # If this file is found in the working directory, WHIZARD
 # will use the paths for the uninstalled version (source/build tree),
 # otherwise it uses the installed version
 TESTFLAG:
 	touch $@
 
 FASTJET_FLAG:
 if FASTJET_AVAILABLE
 	touch $@
 endif
 
 HEPMC2_FLAG:
 if HEPMC2_AVAILABLE
 	touch $@
 endif
 
 HEPMC3_FLAG:
 if HEPMC3_AVAILABLE
 	touch $@
 endif
 
 LCIO_FLAG:
 if LCIO_AVAILABLE
 	touch $@
 endif
 
 LHAPDF5_FLAG:
 if LHAPDF5_AVAILABLE
 	touch $@
 endif
 
 LHAPDF6_FLAG:
 if LHAPDF6_AVAILABLE
 	touch $@
 endif
 
 OCAML_FLAG:
 if OCAML_AVAILABLE
 	touch $@
 endif
 
 RECOLA_FLAG:
 if RECOLA_AVAILABLE
 	touch $@
 endif
 
 PYTHIA6_FLAG:
 if PYTHIA6_AVAILABLE
 	touch $@
 endif
 
 PYTHIA8_FLAG:
 if PYTHIA8_AVAILABLE
 	touch $@
 endif
 
 EVENT_ANALYSIS_FLAG:
 if EVENT_ANALYSIS_AVAILABLE
 	touch $@
 endif
 
 STATIC_FLAG:
 if STATIC_AVAILABLE
 	touch $@
 endif
 
 # The reference output files are in the source directory.  Copy them here.
 ref-output: $(top_srcdir)/share/tests/unit_tests/ref-output
 	mkdir -p ref-output
 	for f in $</*.ref; do cp $$f $@; done
 
 # The output files from self tests go here.
 err-output:
 	mkdir -p err-output
 
 ## installcheck runs the test scripts with the TESTFLAG removed.
 ## NOTE: disabled for unit tests, because whizard_ut will not be installed.
 installcheck-local:
 #installcheck-local: notestflag check-am
 notestflag:
 	rm -f TESTFLAG
 .PHONY: notestflag
 
 ### Remove DWARF debug information on MAC OS X
 clean-macosx:
 	-rm -rf compilations_static_1.dSYM
 	-rm -rf compilations_static_2.dSYM
 .PHONY: clean-macosx
 
 ## Remove generated files
 clean-local: clean-macosx
 	rm -f gamelan.sty
 	rm -f TESTFLAG 
 	rm -f OCAML_FLAG FASTJET_FLAG HEPMC2_FLAG HEPMC3_FLAG LCIO_FLAG 
 	rm -f RECOLA_FLAG EVENT_ANALYSIS_FLAG PYTHIA6_FLAG PYTHIA8_FLAG 
 	rm -f LHAPDF5_FLAG LHAPDF6_FLAG STATIC_FLAG static_1.exe
 	rm -f *.run *.log slha_test.out
 	rm -f core* 
 	rm -f *.f90 *.c *.$(FCMOD) *.o *.la
 	rm -f *.makefile
 	rm -f *.grid output.rcl
 	rm -rf err-output
 	rm -rf ref-output
 	rm -f *.sin *.hbc *_fks_regions.out
 	rm -f *.phs *.vg *.vgb *.evt *.evx *.lhe *.hepmc *.dat *.debug *.mdl
 	rm -f *.tmp *.hepevt *.hepevt.verb *.lha *.lha.verb *.slcio
 	rm -f prc_omega_diags_1_p_i1_diags.out prc_omega_diags_1_p_i1_diags.toc
 	rm -f *.hep *.up.hep *.hep.out *.[1-9] *.[1-9][0-9] *.[1-9][0-9][0-9]
 	rm -f *.tex *.mp *.mpx *.t[1-9] *.t[1-9][0-9] *.t[1-9][0-9][0-9]
 	rm -f *.ltp *.aux *.dvi *.ps *.pdf so_test.*
 	rm -f *.tbl sps1ap_decays.slha bar structure_6[a-b].out
 	rm -f *.fds api_*.out
 	rm -f *.vg2 *.vegas *.grids grids_2_test
 	rm -rf output_cll
 	rm -rf *.dSYM
 if FC_SUBMODULES
 	rm -f *.smod
 endif
 
 ## Remove backup files
 maintainer-clean-local: maintainer-clean-fc
 	-rm -f *~
 .PHONY: maintainer-clean-local
Index: trunk/tests/unit_tests/sm_qcd.sh
===================================================================
--- trunk/tests/unit_tests/sm_qcd.sh	(revision 8766)
+++ trunk/tests/unit_tests/sm_qcd.sh	(revision 8767)
@@ -1,4 +1,4 @@
 #!/bin/sh
-### Check WHIZARD module sm_physics
+### Check WHIZARD module sm_qcd
 echo "Running script $0"
 exec ./run_whizard_ut.sh --check sm_qcd
Index: trunk/tests/unit_tests/sm_qed.sh
===================================================================
--- trunk/tests/unit_tests/sm_qed.sh	(revision 0)
+++ trunk/tests/unit_tests/sm_qed.sh	(revision 8767)
@@ -0,0 +1,4 @@
+#!/bin/sh
+### Check WHIZARD module sm_qed
+echo "Running script $0"
+exec ./run_whizard_ut.sh --check sm_qed
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog	(revision 8766)
+++ trunk/ChangeLog	(revision 8767)
@@ -1,2287 +1,2290 @@
 ChangeLog -- Summary of changes to the WHIZARD package
 
 Use svn log to see detailed changes.
 
 	Version 3.0.2+
 
+2021-12-16
+	Implementation of running QED coupling alpha
+
 2021-12-10
 	Independent variations of renormalization/factorization scale
 
 ##################################################################
 
 2021-11-23
 	RELEASE: version 3.0.2
 
 2021-11-19
 	Support for a wide class of mixed NLO QCD/EW processes
 
 2021-11-18
 	Add pp processes for NLO EW corrections to testsuite
 
 2021-11-11
 	Output numerically critical values with LCIO 2.17+ as double
 
 2021-11-05
 	Minor refactoring on phase space points and kinematics
 
 2021-10-21
 	NLO (QCD) differential distributions supported for full
 	  lepton collider setup: polarization, QED ISR, beamstrahlung
 
 2021-10-15
 	SINDARIN now has a sum and product function of expressions,
 	SINDARIN supports observables defined on full (sub)events
 	First application: transverse mass
 	Bug fix: 2HDM did not allow H+, H- as external particles
 
 2021-10-14
 	CT18 PDFs included (NLO, NNLO)
 
 2021-09-30
 	Bug fix: keep non-recombined photons in the event record
 
 2021-09-13
 	Modular NLO event generation with real partition
 
 2021-08-20
 	Bug fix: correctly reading in NLO fixed order events
 
 2021-08-06
         Generalize optional partitioning of the NLO real phase space
 
 ##################################################################
 
 2021-07-08
 	RELEASE: version 3.0.1
 
 2021-07-06
 	MPI parallelization now comes with two incarnations:
 	- standard MPI parallelization ("simple", default)
 	- MPI with load balancer ("load")
 
 2021-07-05
 	Bug fix for C++17 default compilers w/ HepMC3/ROOT interface
 
 2021-07-02
 	Improvement for POWHEG matching:
 	- implement massless recoil case
 	- enable reading in existing POWHEG grids
 	- support kinematic cuts at generator level
 
 2021-07-01
 	Distinguish different cases of photons in NLO EW corrections
 
 2021-06-21
 	Option to keep negative PDF entries or set them zero
 
 2021-05-31
 	Full LCIO MC production files can be properly recasted
 
 2021-05-24
         Use defaults for UFO models without propagators.py
 
 2021-05-21
 	Bug fix: prevent invalid code for UFO models containing hyphens
 
 2021-05-20
 	UFO files with scientific notation float constants allowed
 	UFO files: max. n-arity of vertices bound by process multiplicity
 
 ##################################################################
 
 2021-04-27
 	RELEASE: version 3.0.0
 
 2021-04-20
 	Minimal required OCaml version is now 4.05.0.
 	Bug fix for tau polarization from stau decays
 
 2021-04-19
 	NLO EW splitting functions and collinear remnants completed
 	Photon recombination implemented
 
 2021-04-14
 	Bug fix for vertices/status codes with HepMC2/3 event format
 
 2021-04-08
 	Correct Lorentz statistics for UFO model with Majorana fermions
 
 2021-04-06
 	Bug fix for rare script failure in system_dependencies.f90.in
 	Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model
 
 2021-04-04
 	Support for UFO extensions in SMEFTSim 3.0
 
 2021-02-25
 	Enable VAMP and VAMP2 channel equivalences for NLO integrations
 
 2021-02-04
 	Bug fix if user does not set a prefix at configuration
 
 2020-12-10
 	Generalize NLO calculations to non-CMS lab frames
 
 2020-12-08
 	Bug fix in expanded p-wave form factor for top threshold
 
 2020-12-06
 	Patch for macOS Big Sur shared library handling due to libtool;
 	   the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5
 
 2020-12-04
 	O'Mega only inserts non-vanishing couplings from UFO models
 
 2020-11-21
 	Bug fix for fractional hypercharges in UFO models
 
 2020-11-11
 	Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)
 
 2020-11-09
 	Correct flavor assignment for NLO fixed-order events
 
 2020-11-05
 	Bug fix for ISR handler not working with unstable particles
 
 2020-10-08
 	Bug fix in LHAPDF interface for photon PDFs
 
 2020-10-07
 	Bug fix for structure function setup with asymmetric beams
 
 2020-10-02
 	Python/Cython layer for WHIZARD API
 
 2020-09-30
 	Allow mismatches of Python and name attributes in UFO models
 
 2020-09-26
 	Support for negative PDG particles from certain UFO models
 
 2020-09-24
 	Allow for QNUMBERS blocks in BSM SLHA files
 
 2020-09-22
 	Full support for compilation with clang(++) on Darwin/macOS
 	More documentation in the manual
 	Minor clean-ups
 
 2020-09-16
 	Bug fix enables reading LCIO events with LCIO v2.15+
 
 ##################################################################
 
 2020-09-16
 	RELEASE: version 2.8.5
 
 2020-09-11
 	Bug fix for H->tau tau transverse polarization with PYTHIA6
 	   (thanks to Junping Tian / Akiya Miyamoto)
 
 2020-09-09
 	Fix a long standing bug (since 2.0) in the calculation of color
 	factors when particles of different color were combined in a
 	particle class.  NB: O'Mega never produced a wrong number,
 	it only declared all processes as invalid.
 
 2020-09-08
 	Enable Openloops matrix element equivalences for optimization
 
 2020-09-02
 	Compatibility fix for PYTHIA v8.301+ interface
 
 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/openloops/openloops.nw
===================================================================
--- trunk/src/openloops/openloops.nw	(revision 8766)
+++ trunk/src/openloops/openloops.nw	(revision 8767)
@@ -1,747 +1,748 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: interface to OpenLoops 1-loop library
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{OpenLoops Interface}
 \includemodulegraph{openloops}
 
 The interface to OpenLoops.
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 <<[[prc_openloops.f90]]>>=
 <<File header>>
 
 module prc_openloops
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
   use io_units
 <<Use strings>>
   use string_utils, only: str
   use constants
   use numeric_utils
   use diagnostics
 <<Use debug>>
   use system_dependencies
   use physics_defs
   use variables
   use os_interface
   use lorentz
   use interactions
   use sm_qcd
   use sm_physics, only: top_width_sm_lo, top_width_sm_qcd_nlo_jk
   use model_data
 
   use prclib_interfaces
   use prc_core_def
   use prc_core
 
   use blha_config
   use blha_olp_interfaces
 <<Use mpi f08>>
 
 <<Standard module head>>
 
 <<prc openloops: public>>
 
 <<prc openloops: parameters>>
 
 <<prc openloops: types>>
 
 <<prc openloops: interfaces>>
 
 contains
 
 <<prc openloops: procedures>>
 
 end module prc_openloops
 @ %def module prc_openloops
 @
 <<prc openloops: parameters>>=
   real(default), parameter :: openloops_default_bmass = 0._default
   real(default), parameter :: openloops_default_topmass = 172._default
   real(default), parameter :: openloops_default_topwidth = 0._default
   real(default), parameter :: openloops_default_wmass = 80.399_default
   real(default), parameter :: openloops_default_wwidth = 0._default
   real(default), parameter :: openloops_default_zmass = 91.1876_default
   real(default), parameter :: openloops_default_zwidth = 0._default
   real(default), parameter :: openloops_default_higgsmass = 125._default
   real(default), parameter :: openloops_default_higgswidth = 0._default
 
   integer :: N_EXTERNAL = 0
 
 @ %def openloops default parameter
 @
 <<prc openloops: interfaces>>=
   abstract interface
      subroutine ol_evaluate_scpowheg (id, pp, emitter, res, resmunu) bind(C)
        import
        integer(kind = c_int), value :: id, emitter
        real(kind = c_double), intent(in) :: pp(5 * N_EXTERNAL)
        real(kind = c_double), intent(out) :: res, resmunu(16)
      end subroutine ol_evaluate_scpowheg
   end interface
 
 @ %def ol_evaluate_scpowheg interface
 @
 <<prc openloops: interfaces>>=
   abstract interface
      subroutine ol_getparameter_double (variable_name, value) bind(C)
        import
        character(kind = c_char,len = 1), intent(in) :: variable_name
        real(kind = c_double), intent(out) :: value
      end subroutine ol_getparameter_double
   end interface
 
 @ %def ol_getparameter_double interface
 @
 <<prc openloops: types>>=
   type, extends (prc_blha_writer_t) :: openloops_writer_t
   contains
   <<prc openloops: openloops writer: TBP>>
   end type openloops_writer_t
 
 @ %def openloops_writer_t
 @
 <<prc openloops: public>>=
   public :: openloops_def_t
 <<prc openloops: types>>=
   type, extends (blha_def_t) :: openloops_def_t
      integer :: verbosity
   contains
   <<prc openloops: openloops def: TBP>>
   end type openloops_def_t
 
 @ %def openloops_def_t
 @
 <<prc openloops: types>>=
   type, extends (blha_driver_t) :: openloops_driver_t
     integer :: n_external = 0
     type(string_t) :: olp_file
     procedure(ol_evaluate_scpowheg), nopass, pointer :: &
          evaluate_spin_correlations_powheg => null ()
     procedure(ol_getparameter_double), nopass, pointer :: &
          get_parameter_double => null ()
   contains
   <<prc openloops: openloops driver: TBP>>
   end type openloops_driver_t
 
 @ %def openloops_driver_t
 @
 <<prc openloops: types>>=
   type :: openloops_threshold_data_t
     logical :: nlo = .true.
     real(default) :: alpha_ew
     real(default) :: sinthw
     real(default) :: m_b, m_W
     real(default) :: vtb
   contains
   <<prc openloops: openloops threshold data: TBP>>
   end type openloops_threshold_data_t
 
 @ %def openloops_threshold_data_t
 @
 <<prc openloops: openloops threshold data: TBP>>=
   procedure :: compute_top_width => &
        openloops_threshold_data_compute_top_width
 <<prc openloops: procedures>>=
   function openloops_threshold_data_compute_top_width &
        (data, mtop, alpha_s) result (wtop)
     real(default) :: wtop
     class(openloops_threshold_data_t), intent(in) :: data
     real(default), intent(in) :: mtop, alpha_s
     if (data%nlo) then
        wtop = top_width_sm_qcd_nlo_jk (data%alpha_ew, data%sinthw, &
               data%vtb, mtop, data%m_W, data%m_b, alpha_s)
     else
        wtop = top_width_sm_lo (data%alpha_ew, data%sinthw, data%vtb, &
               mtop, data%m_W, data%m_b)
     end if
   end function openloops_threshold_data_compute_top_width
 
 @ %def openloops_threshold_data_compute_top_width
 @
 <<prc openloops: public>>=
   public :: openloops_state_t
 <<prc openloops: types>>=
   type, extends (blha_state_t) :: openloops_state_t
     type(openloops_threshold_data_t), allocatable :: threshold_data
   contains
   <<prc openloops: openloops state: TBP>>
   end type openloops_state_t
 
 @ %def openloops_state_t
 @
 <<prc openloops: openloops state: TBP>>=
   procedure :: init_threshold => openloops_state_init_threshold
 <<prc openloops: procedures>>=
   subroutine openloops_state_init_threshold (object, model)
     class(openloops_state_t), intent(inout) :: object
     type(model_data_t), intent(in) :: model
     if (model%get_name () == "SM_tt_threshold") then
        allocate (object%threshold_data)
        associate (data => object%threshold_data)
           data%nlo = btest (int (model%get_real (var_str ('offshell_strategy'))), 0)
           data%alpha_ew = one / model%get_real (var_str ('alpha_em_i'))
           data%sinthw = model%get_real (var_str ('sw'))
           data%m_b = model%get_real (var_str ('mb'))
           data%m_W = model%get_real (var_str ('mW'))
           data%vtb = model%get_real (var_str ('Vtb'))
        end associate
     end if
   end subroutine openloops_state_init_threshold
 
 @ %def openloops_state_init_threshold
 @
 <<prc openloops: public>>=
   public :: prc_openloops_t
 <<prc openloops: types>>=
   type, extends (prc_blha_t) :: prc_openloops_t
   contains
   <<prc openloops: prc openloops: TBP>>
   end type prc_openloops_t
 
 @ %def prc_openloops_t
 @
 <<prc openloops: openloops writer: TBP>>=
   procedure, nopass :: type_name => openloops_writer_type_name
 <<prc openloops: procedures>>=
   function openloops_writer_type_name () result (string)
     type(string_t) :: string
     string = "openloops"
   end function openloops_writer_type_name
 
 @
 @ %def openloops_writer_type_name
 <<prc openloops: openloops def: TBP>>=
   procedure :: init => openloops_def_init
 <<prc openloops: procedures>>=
   subroutine openloops_def_init (object, basename, model_name, &
      prt_in, prt_out, nlo_type, restrictions, var_list)
     class(openloops_def_t), intent(inout) :: object
     type(string_t), intent(in) :: basename, model_name
     type(string_t), dimension(:), intent(in) :: prt_in, prt_out
     integer, intent(in) :: nlo_type
     type(string_t), intent(in), optional :: restrictions
     type(var_list_t), intent(in) :: var_list
   <<prc openloops: openloops def init: variables>>
     object%basename = basename
     allocate (openloops_writer_t :: object%writer)
     select case (nlo_type)
     case (BORN)
        object%suffix = '_BORN'
     case (NLO_REAL)
        object%suffix = '_REAL'
     case (NLO_VIRTUAL)
        object%suffix = '_LOOP'
     case (NLO_SUBTRACTION, NLO_MISMATCH)
        object%suffix = '_SUB'
     case (NLO_DGLAP)
        object%suffix = '_DGLAP'
     end select
   <<prc openloops: openloops def init: suffix>>
     select type (writer => object%writer)
     class is (prc_blha_writer_t)
        call writer%init (model_name, prt_in, prt_out, restrictions)
     end select
     object%verbosity = var_list%get_ival (var_str ("openloops_verbosity"))
   end subroutine openloops_def_init
 
 @ %def openloops_def_init
 @ Add additional suffix for each rank of the communicator, such that the
 filenames do not clash.
 <<MPI: prc openloops: openloops def init: variables>>=
   integer :: n_size, rank
 <<MPI: prc openloops: openloops def init: suffix>>=
   call MPI_comm_rank (MPI_COMM_WORLD, rank)
   call MPI_Comm_size (MPI_COMM_WORLD, n_size)
   if (n_size > 1) then
      object%suffix = object%suffix // var_str ("_") // str (rank)
   end if
 @
 <<prc openloops: openloops def: TBP>>=
   procedure, nopass :: type_string => openloops_def_type_string
 <<prc openloops: procedures>>=
   function openloops_def_type_string () result (string)
     type(string_t) :: string
     string = "openloops"
   end function openloops_def_type_string
 
 @
 @ %def openloops_def_type_string
 <<prc openloops: openloops def: TBP>>=
   procedure :: write => openloops_def_write
 <<prc openloops: procedures>>=
   subroutine openloops_def_write (object, unit)
     class(openloops_def_t), intent(in) :: object
     integer, intent(in) :: unit
     select type (writer => object%writer)
     type is (openloops_writer_t)
        call writer%write (unit)
     end select
   end subroutine openloops_def_write
 
 @
 @ %def openloops_def_write
 <<prc openloops: openloops driver: TBP>>=
   procedure :: init_dlaccess_to_library => openloops_driver_init_dlaccess_to_library
 <<prc openloops: procedures>>=
   subroutine openloops_driver_init_dlaccess_to_library &
      (object, os_data, dlaccess, success)
     class(openloops_driver_t), intent(in) :: object
     type(os_data_t), intent(in) :: os_data
     type(dlaccess_t), intent(out) :: dlaccess
     logical, intent(out) :: success
     type(string_t) :: ol_library, msg_buffer
     ol_library = OPENLOOPS_DIR // '/lib/libopenloops.' // &
          os_data%shrlib_ext
     msg_buffer = "One-Loop-Provider: Using OpenLoops"
     call msg_message (char(msg_buffer))
     msg_buffer = "Loading library: " // ol_library
     call msg_message (char(msg_buffer))
     if (os_file_exist (ol_library)) then
        call dlaccess_init (dlaccess, var_str (""), ol_library, os_data)
     else
        call msg_fatal ("Link OpenLoops: library not found")
     end if
     success = .not. dlaccess_has_error (dlaccess)
   end subroutine openloops_driver_init_dlaccess_to_library
 
 @ %def openloops_driver_init_dlaccess_to_library
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure :: set_alpha_s => openloops_driver_set_alpha_s
 <<prc openloops: procedures>>=
   subroutine openloops_driver_set_alpha_s (driver, alpha_s)
     class(openloops_driver_t), intent(in) :: driver
     real(default), intent(in) :: alpha_s
     integer :: ierr
     if (associated (driver%blha_olp_set_parameter)) then
        call driver%blha_olp_set_parameter &
             (c_char_'alphas'//c_null_char, &
              dble (alpha_s), 0._double, ierr)
     else
        call msg_fatal ("blha_olp_set_parameter not associated!")
     end if
     if (ierr == 0) call parameter_error_message (var_str ('alphas'), &
          var_str ('openloops_driver_set_alpha_s'))
   end subroutine openloops_driver_set_alpha_s
 
 @ %def openloops_driver_set_alpha_s
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure :: set_alpha_qed => openloops_driver_set_alpha_qed
 <<prc openloops: procedures>>=
   subroutine openloops_driver_set_alpha_qed (driver, alpha)
     class(openloops_driver_t), intent(inout) :: driver
     real(default), intent(in) :: alpha
     integer :: ierr
     call driver%blha_olp_set_parameter &
        (c_char_'alpha_qed'//c_null_char, &
         dble (alpha), 0._double, ierr)
     if (ierr == 0) call ew_parameter_error_message (var_str ('alpha_qed'))
   end subroutine openloops_driver_set_alpha_qed
 
 @ %def openloops_driver_set_alpha_qed
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure :: set_GF => openloops_driver_set_GF
 <<prc openloops: procedures>>=
   subroutine openloops_driver_set_GF (driver, GF)
     class(openloops_driver_t), intent(inout) :: driver
     real(default), intent(in) :: GF
     integer :: ierr
     call driver%blha_olp_set_parameter &
        (c_char_'Gmu'//c_null_char, &
         dble(GF), 0._double, ierr)
     if (ierr == 0) call ew_parameter_error_message (var_str ('Gmu'))
   end subroutine openloops_driver_set_GF
 
 @ %def openloops_driver_set_GF
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure :: set_weinberg_angle => openloops_driver_set_weinberg_angle
 <<prc openloops: procedures>>=
   subroutine openloops_driver_set_weinberg_angle (driver, sw2)
     class(openloops_driver_t), intent(inout) :: driver
     real(default), intent(in) :: sw2
     integer :: ierr
     call driver%blha_olp_set_parameter &
        (c_char_'sw2'//c_null_char, &
         dble(sw2), 0._double, ierr)
     if (ierr == 0) call ew_parameter_error_message (var_str ('sw2'))
   end subroutine openloops_driver_set_weinberg_angle
 
 @ %def openloops_driver_set_weinberg_angle
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure :: print_alpha_s => openloops_driver_print_alpha_s
 <<prc openloops: procedures>>=
   subroutine openloops_driver_print_alpha_s (object)
     class(openloops_driver_t), intent(in) :: object
     call object%blha_olp_print_parameter (c_char_'alphas'//c_null_char)
   end subroutine openloops_driver_print_alpha_s
 
 @ %def openloops_driver_print_alpha_s
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure, nopass :: type_name => openloops_driver_type_name
 <<prc openloops: procedures>>=
   function openloops_driver_type_name () result (type)
     type(string_t) :: type
     type = "OpenLoops"
   end function openloops_driver_type_name
 
 @ %def openloops_driver_type_name
 @
 <<prc openloops: openloops driver: TBP>>=
   procedure :: load_procedures => openloops_driver_load_procedures
 <<prc openloops: procedures>>=
   subroutine openloops_driver_load_procedures (object, os_data, success)
     class(openloops_driver_t), intent(inout) :: object
     type(os_data_t), intent(in) :: os_data
     logical, intent(out) :: success
     type(dlaccess_t) :: dlaccess
     type(c_funptr) :: c_fptr
     logical :: init_success
 
     call object%init_dlaccess_to_library (os_data, dlaccess, init_success)
 
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("ol_evaluate_scpowheg"))
     call c_f_procpointer (c_fptr, object%evaluate_spin_correlations_powheg)
     call check_for_error (var_str ("ol_evaluate_scpowheg"))
     c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("ol_getparameter_double"))
     call c_f_procpointer (c_fptr, object%get_parameter_double)
     call check_for_error (var_str ("ol_getparameter_double"))
     success = .true.
 
     contains
       subroutine check_for_error (function_name)
         type(string_t), intent(in) :: function_name
         if (dlaccess_has_error (dlaccess)) &
            call msg_fatal (char ("Loading of " // function_name // " failed!"))
      end subroutine check_for_error
   end subroutine openloops_driver_load_procedures
 
 @ %def openloops_driver_load_procedures
 @
 <<prc openloops: openloops def: TBP>>=
   procedure :: read => openloops_def_read
 <<prc openloops: procedures>>=
   subroutine openloops_def_read (object, unit)
     class(openloops_def_t), intent(out) :: object
     integer, intent(in) :: unit
   end subroutine openloops_def_read
 
 @ %def openloops_def_read
 @
 <<prc openloops: openloops def: TBP>>=
   procedure :: allocate_driver => openloops_def_allocate_driver
 <<prc openloops: procedures>>=
   subroutine openloops_def_allocate_driver (object, driver, basename)
     class(openloops_def_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     if (.not. allocated (driver)) allocate (openloops_driver_t :: driver)
   end subroutine openloops_def_allocate_driver
 
 @
 @ %def openloops_def_allocate_driver
 <<prc openloops: openloops state: TBP>>=
   procedure :: write => openloops_state_write
 <<prc openloops: procedures>>=
   subroutine openloops_state_write (object, unit)
     class(openloops_state_t), intent(in) :: object
     integer, intent(in), optional :: unit
   end subroutine openloops_state_write
 
 @ %def prc_openloops_state_write
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: allocate_workspace => prc_openloops_allocate_workspace
 <<prc openloops: procedures>>=
   subroutine prc_openloops_allocate_workspace (object, core_state)
     class(prc_openloops_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     allocate (openloops_state_t :: core_state)
   end subroutine prc_openloops_allocate_workspace
 
 @ %def prc_openloops_allocate_workspace
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: init_driver => prc_openloops_init_driver
 <<prc openloops: procedures>>=
   subroutine prc_openloops_init_driver (object, os_data)
     class(prc_openloops_t), intent(inout) :: object
     type(os_data_t), intent(in) :: os_data
     type(string_t) :: olp_file, olc_file
     type(string_t) :: suffix
 
     select type (def => object%def)
     type is (openloops_def_t)
        suffix = def%suffix
        olp_file = def%basename // suffix // '.olp'
        olc_file = def%basename // suffix // '.olc'
     class default
        call msg_bug ("prc_openloops_init_driver: core_def should be openloops-type")
     end select
 
     select type (driver => object%driver)
     type is (openloops_driver_t)
        driver%olp_file = olp_file
        driver%contract_file = olc_file
        driver%nlo_suffix = suffix
     end select
   end subroutine prc_openloops_init_driver
 
 @ %def prc_openloops_init_driver
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: write => prc_openloops_write
 <<prc openloops: procedures>>=
   subroutine prc_openloops_write (object, unit)
     class(prc_openloops_t), intent(in) :: object
     integer, intent(in), optional :: unit
     call msg_message (unit = unit, string = "OpenLoops")
   end subroutine prc_openloops_write
 
 @
 @ %def prc_openloops_write
 <<prc openloops: prc openloops: TBP>>=
   procedure :: write_name => prc_openloops_write_name
 <<prc openloops: procedures>>=
   subroutine prc_openloops_write_name (object, unit)
     class(prc_openloops_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(1x,A)") "Core: OpenLoops"
   end subroutine prc_openloops_write_name
 
 @
 @ %def prc_openloops_write_name
 
 <<prc openloops: prc openloops: TBP>>=
   procedure :: prepare_library => prc_openloops_prepare_library
 <<prc openloops: procedures>>=
   subroutine prc_openloops_prepare_library (object, os_data, model)
     class(prc_openloops_t), intent(inout) :: object
     type(os_data_t), intent(in) :: os_data
     type(model_data_t), intent(in), target :: model
     call object%load_driver (os_data)
     call object%reset_parameters ()
     call object%set_particle_properties (model)
     select type(def => object%def)
     type is (openloops_def_t)
        call object%set_verbosity (def%verbosity)
     end select
   end subroutine prc_openloops_prepare_library
 
 @ %def prc_openloops_prepare_library
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: load_driver => prc_openloops_load_driver
 <<prc openloops: procedures>>=
   subroutine prc_openloops_load_driver (object, os_data)
     class(prc_openloops_t), intent(inout) :: object
     type(os_data_t), intent(in) :: os_data
     logical :: success
     select type (driver => object%driver)
     type is (openloops_driver_t)
        call driver%load (os_data, success)
        call driver%load_procedures (os_data, success)
     end select
   end subroutine prc_openloops_load_driver
 
 @ %def prc_openloops_load_driver
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: start => prc_openloops_start
 <<prc openloops: procedures>>=
   subroutine prc_openloops_start (object)
     class(prc_openloops_t), intent(inout) :: object
     integer :: ierr
     select type (driver => object%driver)
     type is (openloops_driver_t)
        call driver%blha_olp_start (char (driver%olp_file)//c_null_char, ierr)
     end select
   end subroutine prc_openloops_start
 
 @ %def prc_openloops_start
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: set_n_external => prc_openloops_set_n_external
 <<prc openloops: procedures>>=
   subroutine prc_openloops_set_n_external (object, n)
     class(prc_openloops_t), intent(inout) :: object
     integer, intent(in) :: n
     N_EXTERNAL = n
   end subroutine prc_openloops_set_n_external
 
 @ %def prc_openloops_set_n_external
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: reset_parameters => prc_openloops_reset_parameters
 <<prc openloops: procedures>>=
   subroutine prc_openloops_reset_parameters (object)
     class(prc_openloops_t), intent(inout) :: object
     integer :: ierr
     select type (driver => object%driver)
     type is (openloops_driver_t)
        call driver%blha_olp_set_parameter ('mass(5)'//c_null_char, &
             dble(openloops_default_bmass), 0._double, ierr)
        call driver%blha_olp_set_parameter ('mass(6)'//c_null_char, &
             dble(openloops_default_topmass), 0._double, ierr)
        call driver%blha_olp_set_parameter ('width(6)'//c_null_char, &
             dble(openloops_default_topwidth), 0._double, ierr)
        call driver%blha_olp_set_parameter ('mass(23)'//c_null_char, &
             dble(openloops_default_zmass), 0._double, ierr)
        call driver%blha_olp_set_parameter ('width(23)'//c_null_char, &
             dble(openloops_default_zwidth), 0._double, ierr)
        call driver%blha_olp_set_parameter ('mass(24)'//c_null_char, &
             dble(openloops_default_wmass), 0._double, ierr)
        call driver%blha_olp_set_parameter ('width(24)'//c_null_char, &
             dble(openloops_default_wwidth), 0._double, ierr)
        call driver%blha_olp_set_parameter ('mass(25)'//c_null_char, &
             dble(openloops_default_higgsmass), 0._double, ierr)
        call driver%blha_olp_set_parameter ('width(25)'//c_null_char, &
             dble(openloops_default_higgswidth), 0._double, ierr)
     end select
   end subroutine prc_openloops_reset_parameters
 
 @ %def prc_openloops_reset_parameters
 @ Set the verbosity level for openloops. The different levels are as follows:
 \begin{itemize}
   \item[0] minimal output (startup message et.al.)
   \item[1] show which libraries are loaded
   \item[2] show debug information of the library loader, but not during run time
   \item[3] show debug information during run time
   \item[4] output for each call of [[set_parameters]].
 \end{itemize}
 <<prc openloops: prc openloops: TBP>>=
   procedure :: set_verbosity => prc_openloops_set_verbosity
 <<prc openloops: procedures>>=
   subroutine prc_openloops_set_verbosity (object, verbose)
     class(prc_openloops_t), intent(inout) :: object
     integer, intent(in) :: verbose
     integer :: ierr
     select type (driver => object%driver)
     type is (openloops_driver_t)
        call driver%blha_olp_set_parameter ('verbose'//c_null_char, &
             dble(verbose), 0._double, ierr)
     end select
   end subroutine prc_openloops_set_verbosity
 
 @ %def prc_openloops_set_verbosity
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: prepare_external_code => &
        prc_openloops_prepare_external_code
 <<prc openloops: procedures>>=
   subroutine prc_openloops_prepare_external_code &
        (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo)
     class(prc_openloops_t), intent(inout) :: core
     integer, intent(in), dimension(:,:), allocatable :: flv_states
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: i_core
     logical, intent(in) :: is_nlo
     integer :: ierr
     core%sqme_tree_pos = 1
     call core%set_n_external (core%data%get_n_tot ())
     call core%prepare_library (os_data, model)
     call core%start ()
     call core%set_electroweak_parameters (model)
     select type (driver => core%driver)
     type is (openloops_driver_t)
        !!! We have to set the external vector boson wavefunction to the MadGraph convention
        !!! in order to be consistent with our calculation of the spin correlated contributions.
        call driver%blha_olp_set_parameter ('wf_v_select'//c_null_char, &
             3._double, 0._double, ierr)
        if (ierr == 0) call parameter_error_message (var_str ('wf_v_select'), &
             var_str ('prc_openloops_prepare_external_code'))
     end select
     call core%read_contract_file (flv_states)
     call core%print_parameter_file (i_core)
   end subroutine prc_openloops_prepare_external_code
 
 @ %def prc_openloops_prepare_external_code
 @ Computes a spin-correlated matrix element from an interface to an
 external one-loop provider. The output of [[blha_olp_eval2]] is
 an array of [[dimension(16)]]. The current interface does not
 give out an accuracy, so that [[bad_point]] is always [[.false.]].
 OpenLoops includes a factor of 1 / [[n_hel]] in the
 amplitudes, which we have to undo if polarized matrix elements
 are requested.
 <<prc openloops: prc openloops: TBP>>=
   procedure :: compute_sqme_spin_c => prc_openloops_compute_sqme_spin_c
 <<prc openloops: procedures>>=
   subroutine prc_openloops_compute_sqme_spin_c (object, &
        i_flv, i_hel, em, p, ren_scale, sqme_spin_c, bad_point)
     class(prc_openloops_t), intent(inout) :: object
     integer, intent(in) :: i_flv, i_hel
     integer, intent(in) :: em
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale
     real(default), intent(out), dimension(6) :: sqme_spin_c
     logical, intent(out) :: bad_point
     real(default), dimension(16) :: sqme_spin_c_tmp
     real(double), dimension(5*N_EXTERNAL) :: mom
     real(double) :: res
     real(double), dimension(16) :: res_munu
     real(default) :: alpha_s
     if (object%i_spin_c(i_flv, i_hel) >= 0) then
        mom = object%create_momentum_array (p)
        if (vanishes (ren_scale)) call msg_fatal &
             ("prc_openloops_compute_sqme_spin_c: ren_scale vanishes")
        alpha_s = object%qcd%alpha%get (ren_scale)
        select type (driver => object%driver)
        type is (openloops_driver_t)
           call driver%set_alpha_s (alpha_s)
           call driver%evaluate_spin_correlations_powheg &
                (object%i_spin_c(i_flv, i_hel), mom, em, res, res_munu)
        end select
        sqme_spin_c_tmp = res_munu
        bad_point = .false.
        if (object%includes_polarization ()) &
             sqme_spin_c_tmp = object%n_hel * sqme_spin_c_tmp
        if (debug_on) then
           if (sum(sqme_spin_c_tmp) == 0) then
              call msg_debug(D_SUBTRACTION,'Spin-correlated matrix elements provided by OpenLoops are zero!')
           end if
        end if
     else
        sqme_spin_c_tmp = zero
     end if
     !!! Using symmetry of the 4x4 matrix of spin correlated squared Born MEs and
     !!! the fact that we multiply only with vectors with E=0. We thus store the
     !!! upper triangle of the lower 3x3 matrix as columns in a 1-dim array
     sqme_spin_c(1:2) = sqme_spin_c_tmp(6:7)
     sqme_spin_c(3) = sqme_spin_c_tmp(11)
     sqme_spin_c(4) = sqme_spin_c_tmp(8)
     sqme_spin_c(5) = sqme_spin_c_tmp(12)
     sqme_spin_c(6) = sqme_spin_c_tmp(16)
   end subroutine prc_openloops_compute_sqme_spin_c
 
 @ %def prc_openloops_compute_sqme_spin_c
 @
 <<prc openloops: prc openloops: TBP>>=
   procedure :: get_alpha_qed => prc_openloops_get_alpha_qed
 <<prc openloops: procedures>>=
-  function prc_openloops_get_alpha_qed (object) result (alpha_qed)
+  function prc_openloops_get_alpha_qed (object, core_state) result (alpha_qed)
     class(prc_openloops_t), intent(in) :: object
+    class(prc_core_state_t), intent(in), allocatable :: core_state
     real(double) :: value
     real(default) :: alpha_qed
     select type (driver => object%driver)
     type is (openloops_driver_t)
        call driver%get_parameter_double ('alpha_qed'//c_null_char, value)
        alpha_qed = value
        return
     end select
     call msg_fatal ("prc_openloops_get_alpha_qed: called by wrong driver, only supported for OpenLoops!")
   end function prc_openloops_get_alpha_qed
 
 @ %def prc_openloops_get_alpha_qed
Index: trunk/src/physics/physics.nw
===================================================================
--- trunk/src/physics/physics.nw	(revision 8766)
+++ trunk/src/physics/physics.nw	(revision 8767)
@@ -1,5604 +1,6101 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: physics and such
 \chapter{Physics}
 \includemodulegraph{physics}
 
 Here we collect definitions and functions that we need for (particle)
 physics in general, to make them available for the more specific needs
 of WHIZARD.
 \begin{description}
 \item[physics\_defs]
   Physical constants.
 \item[c\_particles]
   A simple data type for particles which is C compatible.
 \item[lorentz]
   Define three-vectors, four-vectors and Lorentz
   transformations and common operations for them.
 \item[phs\_point]
   Collections of Lorentz vectors.
 \item[sm\_physics]
   Here, running functions are stored for special kinematical setup like
   running coupling constants, Catani-Seymour dipoles, or Sudakov factors.
 \item[sm\_qcd]
   Definitions and methods for dealing with the running QCD coupling.
 \item[shower\_algorithms]
   Algorithms typically used in Parton Showers as well as in their
   matching to NLO computations, e.g. with the POWHEG method.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Physics Constants}
 There is also the generic [[constants]] module.  The constants listed
 here are more specific for particle physics.
 <<[[physics_defs.f90]]>>=
 <<File header>>
 
 module physics_defs
 
 <<Use kinds>>
 <<Use strings>>
   use constants, only: one, two, three
 
 <<Standard module head>>
 
 <<Physics defs: public parameters>>
 
 <<Physics defs: public>>
 
 <<Physics defs: interfaces>>
 
 contains
 
 <<Physics defs: procedures>>
 
 end module physics_defs
 @ %def physics_defs
 @
 \subsection{Units}
 Conversion from energy units to cross-section units.
 <<Physics defs: public parameters>>=
   real(default), parameter, public :: &
        conv = 0.38937966e12_default
 @
 Conversion from millimeter to nanoseconds for lifetimes.
 <<Physics defs: public parameters>>=
   real(default), parameter, public :: &
        ns_per_mm = 1.e6_default / 299792458._default
 @
 Rescaling factor.
 <<Physics defs: public parameters>>=
   real(default), parameter, public :: &
        pb_per_fb = 1.e-3_default
 @
 String for the default energy and cross-section units.
 <<Physics defs: public parameters>>=
   character(*), parameter, public :: &
        energy_unit = "GeV"
   character(*), parameter, public :: &
        cross_section_unit = "fb"
 @
 \subsection{SM and QCD constants}
 <<Physics defs: public parameters>>=
   real(default), parameter, public :: &
        NC = three, &
        CF = (NC**2 - one) / two / NC, &
        CA = NC, &
        TR = one / two
 @
 \subsection{Parameter Reference values}
 These are used exclusively in the context of
 running QCD parameters.  In other contexts, we rely on the uniform
 parameter set as provided by the model definition, modifiable by the
 user.
 <<Physics defs: public parameters>>=
   real(default), public, parameter :: MZ_REF = 91.188_default
+  real(default), public, parameter :: ME_REF = 0.000510998928_default
   real(default), public, parameter :: ALPHA_QCD_MZ_REF = 0.1178_default
+  real(default), public, parameter :: ALPHA_QED_ME_REF = 0.0072973525693_default
   real(default), public, parameter :: LAMBDA_QCD_REF = 200.e-3_default
 @ %def alpha_s_mz_ref mz_ref lambda_qcd_ref
 @
 \subsection{Particle codes}
 Let us define a few particle codes independent of the model.
 
 We need an UNDEFINED value:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: UNDEFINED = 0
 
 @ %def UNDEFINED
 @ SM fermions:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: DOWN_Q = 1
   integer, parameter, public :: UP_Q = 2
   integer, parameter, public :: STRANGE_Q = 3
   integer, parameter, public :: CHARM_Q = 4
   integer, parameter, public :: BOTTOM_Q = 5
   integer, parameter, public :: TOP_Q = 6
   integer, parameter, public :: ELECTRON = 11
   integer, parameter, public :: ELECTRON_NEUTRINO = 12
   integer, parameter, public :: MUON = 13
   integer, parameter, public :: MUON_NEUTRINO = 14
   integer, parameter, public :: TAU = 15
   integer, parameter, public :: TAU_NEUTRINO = 16
 
 @ %def ELECTRON MUON TAU
 @ Gauge bosons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: GLUON = 21
   integer, parameter, public :: PHOTON = 22
   integer, parameter, public :: PHOTON_OFFSHELL = -2002
   integer, parameter, public :: PHOTON_ONSHELL = 2002
   integer, parameter, public :: Z_BOSON = 23
   integer, parameter, public :: W_BOSON = 24
 
 @ %def GLUON PHOTON Z_BOSON W_BOSON
 @ Light mesons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: PION = 111
   integer, parameter, public :: PIPLUS = 211
   integer, parameter, public :: PIMINUS = - PIPLUS
 
 @ %def PION PIPLUS PIMINUS
 @ Di-Quarks:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: UD0 = 2101
   integer, parameter, public :: UD1 = 2103
   integer, parameter, public :: UU1 = 2203
 
 @ %def UD0 UD1 UU1
 @ Mesons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: K0L = 130
   integer, parameter, public :: K0S = 310
   integer, parameter, public :: K0 = 311
   integer, parameter, public :: KPLUS = 321
   integer, parameter, public :: DPLUS = 411
   integer, parameter, public :: D0 = 421
   integer, parameter, public :: B0 = 511
   integer, parameter, public :: BPLUS = 521
 
 @ %def K0L K0S K0 KPLUS DPLUS D0 B0 BPLUS
 @ Light baryons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: PROTON = 2212
   integer, parameter, public :: NEUTRON = 2112
   integer, parameter, public :: DELTAPLUSPLUS = 2224
   integer, parameter, public :: DELTAPLUS = 2214
   integer, parameter, public :: DELTA0 = 2114
   integer, parameter, public :: DELTAMINUS = 1114
 
 @ %def PROTON NEUTRON DELTAPLUSPLUS DELTAPLUS DELTA0 DELTAMINUS
 @ Strange baryons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: SIGMAPLUS = 3222
   integer, parameter, public :: SIGMA0 = 3212
   integer, parameter, public :: SIGMAMINUS = 3112
 
 @ %def SIGMAPLUS SIGMA0 SIGMAMINUS
 @ Charmed baryons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: SIGMACPLUSPLUS = 4222
   integer, parameter, public :: SIGMACPLUS = 4212
   integer, parameter, public :: SIGMAC0 = 4112
 
 @ %def SIGMACPLUSPLUS SIGMACPLUS SIGMAC0
 @ Bottom baryons:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: SIGMAB0 = 5212
   integer, parameter, public :: SIGMABPLUS = 5222
 
 @ %def SIGMAB0 SIGMABPLUS
 @ 81-100 are reserved for internal codes. Hadron and beam remnants:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: BEAM_REMNANT = 9999
   integer, parameter, public :: HADRON_REMNANT = 90
   integer, parameter, public :: HADRON_REMNANT_SINGLET = 91
   integer, parameter, public :: HADRON_REMNANT_TRIPLET = 92
   integer, parameter, public :: HADRON_REMNANT_OCTET = 93
 
 @ %def BEAM_REMNANT HADRON_REMNANT
 @ %def HADRON_REMNANT_SINGLET HADRON_REMNANT_TRIPLET HADRON_REMNANT_OCTET
 @
 Further particle codes for internal use:
 <<Physics defs: public parameters>>=
   integer, parameter, public :: INTERNAL = 94
   integer, parameter, public :: INVALID = 97
 
   integer, parameter, public :: COMPOSITE = 99
 
 @ %def INTERNAL INVALID COMPOSITE
 @
 \subsection{Spin codes}
 Somewhat redundant, but for better readability we define named
 constants for spin types.  If the mass is nonzero, this is equal to
 the number of degrees of freedom.
 <<Physics defs: public parameters>>=
   integer, parameter, public:: UNKNOWN = 0
   integer, parameter, public :: SCALAR = 1, SPINOR = 2, VECTOR = 3, &
                                 VECTORSPINOR = 4, TENSOR = 5
 
 @ %def UNKNOWN SCALAR SPINOR VECTOR VECTORSPINOR TENSOR
 @ Isospin types and charge types are counted in an analogous way,
 where charge type 1 is charge 0, 2 is charge 1/3, and so on. Zero
 always means unknown. Note that charge and isospin types have an
 explicit sign.
 
 Color types are defined as the dimension of the representation.
 
 \subsection{NLO status codes}
 Used to specify whether a [[term_instance_t]] of a
 [[process_instance_t]] is associated with a Born, real-subtracted,
 virtual-subtracted or subtraction-dummy matrix element.
 <<Physics defs: public parameters>>=
   integer, parameter, public :: BORN = 0
   integer, parameter, public :: NLO_REAL = 1
   integer, parameter, public :: NLO_VIRTUAL = 2
   integer, parameter, public :: NLO_MISMATCH = 3
   integer, parameter, public :: NLO_DGLAP = 4
   integer, parameter, public :: NLO_SUBTRACTION = 5
   integer, parameter, public :: NLO_FULL = 6
   integer, parameter, public :: GKS = 7
   integer, parameter, public :: COMPONENT_UNDEFINED = 99
 
 @ % def BORN, NLO_REAL, NLO_VIRTUAL, NLO_SUBTRACTION, GKS
 @ [[NLO_FULL]] is not strictly a component status code but having it is
 convenient.
 We define the number of additional subtractions for beam-involved NLO calculations.
 Each subtraction refers to a rescaling of one of two beams.
 Obviously, this approach is not flexible enough to support setups with just a
 single beam described by a structure function.
 <<Physics defs: public parameters>>=
   integer, parameter, public :: n_beams_rescaled = 2
 
 @ %def n_beams_rescaled
 @
 <<Physics defs: public>>=
   public :: component_status
 <<Physics defs: interfaces>>=
   interface component_status
      module procedure component_status_of_string
      module procedure component_status_to_string
   end interface
 <<Physics defs: procedures>>=
   elemental function component_status_of_string (string) result (i)
     integer :: i
     type(string_t), intent(in) :: string
     select case (char(string))
     case ("born")
        i = BORN
     case ("real")
        i = NLO_REAL
     case ("virtual")
        i = NLO_VIRTUAL
     case ("mismatch")
        i = NLO_MISMATCH
     case ("dglap")
        i = NLO_DGLAP
     case ("subtraction")
        i = NLO_SUBTRACTION
     case ("full")
        i = NLO_FULL
     case ("GKS")
        i = GKS
     case default
        i = COMPONENT_UNDEFINED
     end select
   end function component_status_of_string
 
   elemental function component_status_to_string (i) result (string)
     type(string_t) :: string
     integer, intent(in) :: i
     select case (i)
     case (BORN)
        string = "born"
     case (NLO_REAL)
        string = "real"
     case (NLO_VIRTUAL)
        string = "virtual"
     case (NLO_MISMATCH)
        string = "mismatch"
     case (NLO_DGLAP)
        string = "dglap"
     case (NLO_SUBTRACTION)
        string = "subtraction"
     case (NLO_FULL)
        string = "full"
     case (GKS)
        string = "GKS"
     case default
        string = "undefined"
     end select
   end function component_status_to_string
 
 @ %def component_status
 @
 <<Physics defs: public>>=
   public :: is_nlo_component
 <<Physics defs: procedures>>=
   elemental function is_nlo_component (comp) result (is_nlo)
     logical :: is_nlo
     integer, intent(in) :: comp
     select case (comp)
     case (BORN : GKS)
        is_nlo = .true.
     case default
        is_nlo = .false.
     end select
   end function is_nlo_component
 
 @ %def is_nlo_component
 @
 <<Physics defs: public>>=
   public :: is_subtraction_component
 <<Physics defs: procedures>>=
   function is_subtraction_component (emitter, nlo_type) result (is_subtraction)
     logical :: is_subtraction
     integer, intent(in) :: emitter, nlo_type
     is_subtraction = nlo_type == NLO_REAL .and. emitter < 0
   end function is_subtraction_component
 
 @ %def is_subtraction_component
 @
 \subsection{Threshold}
 Some commonly used variables for the threshold computation
 <<Physics defs: public parameters>>=
   integer, parameter, public :: THR_POS_WP = 3
   integer, parameter, public :: THR_POS_WM = 4
   integer, parameter, public :: THR_POS_B = 5
   integer, parameter, public :: THR_POS_BBAR = 6
   integer, parameter, public :: THR_POS_GLUON = 7
 
   integer, parameter, public :: THR_EMITTER_OFFSET = 4
 
   integer, parameter, public :: NO_FACTORIZATION = 0
   integer, parameter, public :: FACTORIZATION_THRESHOLD = 1
 
   integer, dimension(2), parameter, public :: ass_quark = [5, 6]
   integer, dimension(2), parameter, public :: ass_boson = [3, 4]
 
   integer, parameter, public :: PROC_MODE_UNDEFINED = 0
   integer, parameter, public :: PROC_MODE_TT = 1
   integer, parameter, public :: PROC_MODE_WBWB = 2
 
 @
 @
 <<Physics defs: public>>=
   public :: thr_leg
 <<Physics defs: procedures>>=
   function thr_leg (emitter) result (leg)
     integer :: leg
     integer, intent(in) :: emitter
     leg = emitter - THR_EMITTER_OFFSET
   end function thr_leg
 
 @ %def thr_leg
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{C-compatible Particle Type}
 For easy communication with C code, we introduce a simple C-compatible
 type for particles.   The components are either default C integers or
 default C doubles.
 
 The [[c_prt]] type is transparent, and its contents should be regarded
 as part of the interface.
 <<[[c_particles.f90]]>>=
 <<File header>>
 
 module c_particles
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use io_units
   use format_defs, only: FMT_14, FMT_19
 
 <<Standard module head>>
 
 <<C Particles: public>>
 
 <<C Particles: types>>
 
 contains
 
 <<C Particles: procedures>>
 end module c_particles
 @ %def c_particles
 @
 <<C Particles: public>>=
   public :: c_prt_t
 <<C Particles: types>>=
   type, bind(C) :: c_prt_t
      integer(c_int) :: type = 0
      integer(c_int) :: pdg = 0
      integer(c_int) :: polarized = 0
      integer(c_int) :: h = 0
      real(c_double) :: pe = 0
      real(c_double) :: px = 0
      real(c_double) :: py = 0
      real(c_double) :: pz = 0
      real(c_double) :: p2 = 0
   end type c_prt_t
 
 @ %def c_prt_t
 @ This is for debugging only, there is no C binding.  It is a
 simplified version of [[prt_write]].
 <<C Particles: public>>=
   public :: c_prt_write
 <<C Particles: procedures>>=
   subroutine c_prt_write (prt, unit)
     type(c_prt_t), intent(in) :: prt
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)", advance="no")  "prt("
     write (u, "(I0,':')", advance="no")  prt%type
     if (prt%polarized /= 0) then
        write (u, "(I0,'/',I0,'|')", advance="no")  prt%pdg, prt%h
     else
        write (u, "(I0,'|')", advance="no") prt%pdg
     end if
     write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // &
          FMT_14 // ",','," // FMT_14 // ")", advance="no") &
          prt%pe, prt%px, prt%py, prt%pz
     write (u, "('|'," // FMT_19 // ")", advance="no")  prt%p2
     write (u, "(A)")  ")"
   end subroutine c_prt_write
 
 @ %def c_prt_write
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Lorentz algebra}
 Define Lorentz vectors, three-vectors, boosts, and some functions to
 manipulate them.
 
 To make maximum use of this, all functions, if possible, are declared
 elemental (or pure, if this is not possible).
 <<[[lorentz.f90]]>>=
 <<File header>>
 
 module lorentz
 
 <<Use kinds with double>>
   use numeric_utils
   use io_units
   use constants, only: pi, twopi, degree, zero, one, two, eps0, tiny_07
   use format_defs, only: FMT_11, FMT_13, FMT_15, FMT_19
   use format_utils, only: pac_fmt
   use diagnostics
   use c_particles
 
 <<Standard module head>>
 
 <<Lorentz: public>>
 
 <<Lorentz: public operators>>
 
 <<Lorentz: public functions>>
 
 <<Lorentz: types>>
 
 <<Lorentz: parameters>>
 
 <<Lorentz: interfaces>>
 
 contains
 
 <<Lorentz: procedures>>
 end module lorentz
 @ %def lorentz
 @
 \subsection{Three-vectors}
 First of all, let us introduce three-vectors in a trivial way.  The
 functions and overloaded elementary operations clearly are too much
 overhead, but we like to keep the interface for three-vectors and
 four-vectors exactly parallel.  By the way, we might attach a label to
 a vector by extending the type definition later.
 <<Lorentz: public>>=
   public :: vector3_t
 <<Lorentz: types>>=
   type :: vector3_t
      real(default), dimension(3) :: p
   end type vector3_t
 
 @ %def vector3_t
 @ Output a vector
 <<Lorentz: public>>=
   public :: vector3_write
 <<Lorentz: procedures>>=
   subroutine vector3_write (p, unit, testflag)
     type(vector3_t), intent(in) :: p
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     character(len=7) :: fmt
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     call pac_fmt (fmt, FMT_19, FMT_15, testflag)
     write(u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p
   end subroutine vector3_write
 
 @ %def vector3_write
 @ This is a three-vector with zero components
 <<Lorentz: public>>=
   public :: vector3_null
 <<Lorentz: parameters>>=
   type(vector3_t), parameter :: vector3_null = &
        vector3_t ([ zero, zero, zero ])
 
 @ %def vector3_null
 @ Canonical three-vector:
 <<Lorentz: public>>=
   public :: vector3_canonical
 <<Lorentz: procedures>>=
   elemental function vector3_canonical (k) result (p)
     type(vector3_t) :: p
     integer, intent(in) :: k
     p = vector3_null
     p%p(k) = 1
   end function vector3_canonical
 
 @ %def vector3_canonical
 @ A moving particle ($k$-axis, or arbitrary axis).  Note that the
 function for the generic momentum cannot be elemental.
 <<Lorentz: public>>=
   public :: vector3_moving
 <<Lorentz: interfaces>>=
   interface vector3_moving
      module procedure vector3_moving_canonical
      module procedure vector3_moving_generic
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_moving_canonical (p, k) result(q)
     type(vector3_t) :: q
     real(default), intent(in) :: p
     integer, intent(in) :: k
     q = vector3_null
     q%p(k) = p
   end function vector3_moving_canonical
   pure function vector3_moving_generic (p) result(q)
     real(default), dimension(3), intent(in) :: p
     type(vector3_t) :: q
     q%p = p
   end function vector3_moving_generic
 
 @ %def vector3_moving
 @ Equality and inequality
 <<Lorentz: public operators>>=
   public :: operator(==), operator(/=)
 <<Lorentz: interfaces>>=
   interface operator(==)
      module procedure vector3_eq
   end interface
   interface operator(/=)
      module procedure vector3_neq
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_eq (p, q) result (r)
     logical :: r
     type(vector3_t), intent(in) :: p,q
     r = all (abs (p%p - q%p) < eps0)
   end function vector3_eq
   elemental function vector3_neq (p, q) result (r)
     logical :: r
     type(vector3_t), intent(in) :: p,q
     r = any (abs(p%p - q%p) > eps0)
   end function vector3_neq
 
 @ %def == /=
 @ Define addition and subtraction
 <<Lorentz: public operators>>=
   public :: operator(+), operator(-)
 <<Lorentz: interfaces>>=
   interface operator(+)
      module procedure add_vector3
   end interface
   interface operator(-)
      module procedure sub_vector3
   end interface
 <<Lorentz: procedures>>=
   elemental function add_vector3 (p, q) result (r)
     type(vector3_t) :: r
     type(vector3_t), intent(in) :: p,q
     r%p = p%p + q%p
   end function add_vector3
   elemental function sub_vector3 (p, q) result (r)
     type(vector3_t) :: r
     type(vector3_t), intent(in) :: p,q
     r%p = p%p - q%p
   end function sub_vector3
 
 @ %def + -
 @ The multiplication sign is overloaded with scalar multiplication;
 similarly division:
 <<Lorentz: public operators>>=
   public :: operator(*), operator(/)
 <<Lorentz: interfaces>>=
   interface operator(*)
      module procedure prod_integer_vector3, prod_vector3_integer
      module procedure prod_real_vector3, prod_vector3_real
   end interface
   interface operator(/)
      module procedure div_vector3_real, div_vector3_integer
   end interface
 <<Lorentz: procedures>>=
   elemental function prod_real_vector3 (s, p) result (q)
     type(vector3_t) :: q
     real(default), intent(in) :: s
     type(vector3_t), intent(in) :: p
     q%p = s * p%p
   end function prod_real_vector3
   elemental function prod_vector3_real (p, s) result (q)
     type(vector3_t) :: q
     real(default), intent(in) :: s
     type(vector3_t), intent(in) :: p
     q%p = s * p%p
   end function prod_vector3_real
   elemental function div_vector3_real (p, s) result (q)
     type(vector3_t) :: q
     real(default), intent(in) :: s
     type(vector3_t), intent(in) :: p
     q%p = p%p/s
   end function div_vector3_real
   elemental function prod_integer_vector3 (s, p) result (q)
     type(vector3_t) :: q
     integer, intent(in) :: s
     type(vector3_t), intent(in) :: p
     q%p = s * p%p
   end function prod_integer_vector3
   elemental function prod_vector3_integer (p, s) result (q)
     type(vector3_t) :: q
     integer, intent(in) :: s
     type(vector3_t), intent(in) :: p
     q%p = s * p%p
   end function prod_vector3_integer
   elemental function div_vector3_integer (p, s) result (q)
     type(vector3_t) :: q
     integer, intent(in) :: s
     type(vector3_t), intent(in) :: p
     q%p = p%p/s
   end function div_vector3_integer
 
 @ %def * /
 @ The multiplication sign can also indicate scalar products:
 <<Lorentz: interfaces>>=
   interface operator(*)
      module procedure prod_vector3
   end interface
 <<Lorentz: procedures>>=
   elemental function prod_vector3 (p, q) result (s)
     real(default) :: s
     type(vector3_t), intent(in) :: p,q
     s = dot_product (p%p, q%p)
   end function prod_vector3
 
 @ %def *
 <<Lorentz: public functions>>=
   public :: cross_product
 <<Lorentz: interfaces>>=
   interface cross_product
      module procedure vector3_cross_product
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_cross_product (p, q) result (r)
     type(vector3_t) :: r
     type(vector3_t), intent(in) :: p,q
     integer :: i
     do i=1,3
        r%p(i) = dot_product (p%p, matmul(epsilon_three(i,:,:), q%p))
     end do
   end function vector3_cross_product
 
 @ %def cross_product
 @ Exponentiation is defined only for integer powers.  Odd powers mean
 take the square root; so [[p**1]] is the length of [[p]].
 <<Lorentz: public operators>>=
   public :: operator(**)
 <<Lorentz: interfaces>>=
   interface operator(**)
      module procedure power_vector3
   end interface
 <<Lorentz: procedures>>=
   elemental function power_vector3 (p, e) result (s)
     real(default) :: s
     type(vector3_t), intent(in) :: p
     integer, intent(in) :: e
     s = dot_product (p%p, p%p)
     if (e/=2) then
        if (mod(e,2)==0) then
           s = s**(e/2)
        else
           s = sqrt(s)**e
        end if
     end if
   end function power_vector3
 
 @ %def **
 @ Finally, we need a negation.
 <<Lorentz: interfaces>>=
   interface operator(-)
      module procedure negate_vector3
   end interface
 <<Lorentz: procedures>>=
   elemental function negate_vector3 (p) result (q)
     type(vector3_t) :: q
     type(vector3_t), intent(in) :: p
     integer :: i
     do i = 1, 3
        if (abs (p%p(i)) < eps0) then
           q%p(i) = 0
        else
           q%p(i) = -p%p(i)
        end if
     end do
   end function negate_vector3
 
 @ %def -
 @ The sum function can be useful:
 <<Lorentz: public functions>>=
   public :: sum
 <<Lorentz: interfaces>>=
   interface sum
      module procedure sum_vector3
   end interface
 @ %def sum
 @
 <<Lorentz: public>>=
   public :: vector3_set_component
 <<Lorentz: procedures>>=
   subroutine vector3_set_component (p, i, value)
     type(vector3_t), intent(inout) :: p
     integer, intent(in) :: i
     real(default), intent(in) :: value
     p%p(i) = value
   end subroutine vector3_set_component
 
 @ %def vector3_set_component
 @
 <<Lorentz: procedures>>=
   pure function sum_vector3 (p) result (q)
     type(vector3_t) :: q
     type(vector3_t), dimension(:), intent(in) :: p
     integer :: i
     do i=1, 3
        q%p(i) = sum (p%p(i))
     end do
   end function sum_vector3
 
 @ %def sum
 @ Any component:
 <<Lorentz: public>>=
   public :: vector3_get_component
 @ %def component
 <<Lorentz: procedures>>=
   elemental function vector3_get_component (p, k) result (c)
     type(vector3_t), intent(in) :: p
     integer, intent(in) :: k
     real(default) :: c
     c = p%p(k)
   end function vector3_get_component
 
 @ %def vector3_get_component
 @ Extract all components.  This is not elemental.
 <<Lorentz: public>>=
   public :: vector3_get_components
 <<Lorentz: procedures>>=
   pure function vector3_get_components (p) result (a)
     type(vector3_t), intent(in) :: p
     real(default), dimension(3) :: a
     a = p%p
   end function vector3_get_components
 
 @ %def vector3_get_components
 @ This function returns the direction of a three-vector, i.e., a
 normalized three-vector.  If the vector is null, we return a null vector.
 <<Lorentz: public functions>>=
   public :: direction
 <<Lorentz: interfaces>>=
   interface direction
      module procedure vector3_get_direction
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_get_direction (p) result (q)
     type(vector3_t) :: q
     type(vector3_t), intent(in) :: p
     real(default) :: pp
     pp = p**1
     if (pp > eps0) then
        q%p = p%p / pp
     else
        q%p = 0
     end if
   end function vector3_get_direction
 
 @ %def direction
 @
 \subsection{Four-vectors}
 In four-vectors the zero-component needs special treatment, therefore
 we do not use the standard operations.  Sure, we pay for the extra
 layer of abstraction by losing efficiency; so we have to assume that
 the time-critical applications do not involve four-vector operations.
 <<Lorentz: public>>=
   public :: vector4_t
 <<Lorentz: types>>=
   type :: vector4_t
      real(default), dimension(0:3) :: p = &
         [zero, zero, zero, zero]
   contains
   <<Lorentz: vector4: TBP>>
   end type vector4_t
 @ %def vector4_t
 @ Output a vector
 <<Lorentz: public>>=
   public :: vector4_write
 <<Lorentz: vector4: TBP>>=
   procedure :: write => vector4_write
 <<Lorentz: procedures>>=
   subroutine vector4_write &
          (p, unit, show_mass, testflag, compressed, ultra)
     class(vector4_t), intent(in) :: p
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_mass, testflag, compressed, ultra
     logical :: comp, sm, tf, extreme
     integer :: u
     character(len=7) :: fmt
     real(default) :: m
     comp = .false.; if (present (compressed))  comp = compressed
     sm = .false.;  if (present (show_mass))  sm = show_mass
     tf = .false.;  if (present (testflag))  tf = testflag
     extreme = .false.; if (present (ultra))  extreme = ultra
     if (extreme) then
        call pac_fmt (fmt, FMT_19, FMT_11, testflag)
     else
        call pac_fmt (fmt, FMT_19, FMT_13, testflag)
     end if
     u = given_output_unit (unit);  if (u < 0)  return
     if (comp) then
        write (u, "(4(F12.3,1X))", advance="no")  p%p(0:3)
     else
        write (u, "(1x,A,1x," // fmt // ")") 'E = ', p%p(0)
        write (u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p(1:)
        if (sm) then
           m = p**1
           if (tf)  call pacify (m, tolerance = 1E-6_default)
           write (u, "(1x,A,1x," // fmt // ")") 'M = ', m
        end if
     end if
   end subroutine vector4_write
 
 @ %def vector4_write
 @ Binary I/O
 <<Lorentz: public>>=
   public :: vector4_write_raw
   public :: vector4_read_raw
 <<Lorentz: procedures>>=
   subroutine vector4_write_raw (p, u)
     type(vector4_t), intent(in) :: p
     integer, intent(in) :: u
     write (u) p%p
   end subroutine vector4_write_raw
 
   subroutine vector4_read_raw (p, u, iostat)
     type(vector4_t), intent(out) :: p
     integer, intent(in) :: u
     integer, intent(out), optional :: iostat
     read (u, iostat=iostat) p%p
   end subroutine vector4_read_raw
 
 @ %def vector4_write_raw vector4_read_raw
 @ This is a four-vector with zero components
 <<Lorentz: public>>=
   public :: vector4_null
 <<Lorentz: parameters>>=
   type(vector4_t), parameter :: vector4_null = &
        vector4_t ([ zero, zero, zero, zero ])
 
 @ %def vector4_null
 @ Canonical four-vector:
 <<Lorentz: public>>=
   public :: vector4_canonical
 <<Lorentz: procedures>>=
   elemental function vector4_canonical (k) result (p)
     type(vector4_t) :: p
     integer, intent(in) :: k
     p = vector4_null
     p%p(k) = 1
   end function vector4_canonical
 
 @ %def vector4_canonical
 @ A particle at rest:
 <<Lorentz: public>>=
   public :: vector4_at_rest
 <<Lorentz: procedures>>=
   elemental function vector4_at_rest (m) result (p)
     type(vector4_t) :: p
     real(default), intent(in) :: m
     p = vector4_t ([ m, zero, zero, zero ])
   end function vector4_at_rest
 
 @ %def vector4_at_rest
 @ A moving particle ($k$-axis, or arbitrary axis)
 <<Lorentz: public>>=
   public :: vector4_moving
 <<Lorentz: interfaces>>=
   interface vector4_moving
      module procedure vector4_moving_canonical
      module procedure vector4_moving_generic
   end interface
 <<Lorentz: procedures>>=
   elemental function vector4_moving_canonical (E, p, k) result (q)
     type(vector4_t) :: q
     real(default), intent(in) :: E, p
     integer, intent(in) :: k
     q = vector4_at_rest(E)
     q%p(k) = p
   end function vector4_moving_canonical
   elemental function vector4_moving_generic (E, p) result (q)
     type(vector4_t) :: q
     real(default), intent(in) :: E
     type(vector3_t), intent(in) :: p
     q%p(0) = E
     q%p(1:) = p%p
   end function vector4_moving_generic
 
 @ %def vector4_moving
 @ Equality and inequality
 <<Lorentz: interfaces>>=
   interface operator(==)
      module procedure vector4_eq
   end interface
   interface operator(/=)
      module procedure vector4_neq
   end interface
 <<Lorentz: procedures>>=
   elemental function vector4_eq (p, q) result (r)
     logical :: r
     type(vector4_t), intent(in) :: p,q
     r = all (abs (p%p - q%p) < eps0)
   end function vector4_eq
   elemental function vector4_neq (p, q) result (r)
     logical :: r
     type(vector4_t), intent(in) :: p,q
     r = any (abs (p%p - q%p) > eps0)
   end function vector4_neq
 
 @ %def == /=
 @ Addition and subtraction:
 <<Lorentz: interfaces>>=
   interface operator(+)
      module procedure add_vector4
   end interface
   interface operator(-)
      module procedure sub_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function add_vector4 (p,q) result (r)
     type(vector4_t) :: r
     type(vector4_t), intent(in) :: p,q
     r%p = p%p + q%p
   end function add_vector4
   elemental function sub_vector4 (p,q) result (r)
     type(vector4_t) :: r
     type(vector4_t), intent(in) :: p,q
     r%p = p%p - q%p
   end function sub_vector4
 
 @ %def + -
 @ We also need scalar multiplication and division:
 <<Lorentz: interfaces>>=
   interface operator(*)
      module procedure prod_real_vector4, prod_vector4_real
      module procedure prod_integer_vector4, prod_vector4_integer
   end interface
   interface operator(/)
      module procedure div_vector4_real
      module procedure div_vector4_integer
   end interface
 <<Lorentz: procedures>>=
   elemental function prod_real_vector4 (s, p) result (q)
     type(vector4_t) :: q
     real(default), intent(in) :: s
     type(vector4_t), intent(in) :: p
     q%p = s * p%p
   end function prod_real_vector4
   elemental function prod_vector4_real (p, s) result (q)
     type(vector4_t) :: q
     real(default), intent(in) :: s
     type(vector4_t), intent(in) :: p
     q%p = s * p%p
   end function prod_vector4_real
   elemental function div_vector4_real (p, s) result (q)
     type(vector4_t) :: q
     real(default), intent(in) :: s
     type(vector4_t), intent(in) :: p
     q%p = p%p/s
   end function div_vector4_real
   elemental function prod_integer_vector4 (s, p) result (q)
     type(vector4_t) :: q
     integer, intent(in) :: s
     type(vector4_t), intent(in) :: p
     q%p = s * p%p
   end function prod_integer_vector4
   elemental function prod_vector4_integer (p, s) result (q)
     type(vector4_t) :: q
     integer, intent(in) :: s
     type(vector4_t), intent(in) :: p
     q%p = s * p%p
   end function prod_vector4_integer
   elemental function div_vector4_integer (p, s) result (q)
     type(vector4_t) :: q
     integer, intent(in) :: s
     type(vector4_t), intent(in) :: p
     q%p = p%p/s
   end function div_vector4_integer
 
 @ %def * /
 @ Scalar products and squares in the Minkowski sense:
 <<Lorentz: interfaces>>=
   interface operator(*)
      module procedure prod_vector4
   end interface
   interface operator(**)
      module procedure power_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function prod_vector4 (p, q) result (s)
     real(default) :: s
     type(vector4_t), intent(in) :: p,q
     s = p%p(0)*q%p(0) - dot_product(p%p(1:), q%p(1:))
   end function prod_vector4
 
 @ %def *
 @ The power operation for four-vectors is signed, i.e., [[p**1]] is
 positive for timelike and negative for spacelike vectors.  Note that
 [[(p**1)**2]] is not necessarily equal to [[p**2]].
 <<Lorentz: procedures>>=
   elemental function power_vector4 (p, e) result (s)
     real(default) :: s
     type(vector4_t), intent(in) :: p
     integer, intent(in) :: e
     s = p * p
     if (e /= 2) then
        if (mod(e, 2) == 0) then
           s = s**(e / 2)
        else if (s >= 0) then
           s = sqrt(s)**e
        else
           s = -(sqrt(abs(s))**e)
        end if
     end if
   end function power_vector4
 
 @ %def **
 @ Finally, we introduce a negation
 <<Lorentz: interfaces>>=
   interface operator(-)
      module procedure negate_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function negate_vector4 (p) result (q)
     type(vector4_t) :: q
     type(vector4_t), intent(in) :: p
     integer :: i
     do i = 0, 3
        if (abs (p%p(i)) < eps0) then
           q%p(i) = 0
        else
           q%p(i) = -p%p(i)
        end if
     end do
   end function negate_vector4
 
 @ %def -
 @ The sum function can be useful:
 <<Lorentz: interfaces>>=
   interface sum
      module procedure sum_vector4, sum_vector4_mask
   end interface
 @ %def sum
 @
 <<Lorentz: procedures>>=
   pure function sum_vector4 (p) result (q)
     type(vector4_t) :: q
     type(vector4_t), dimension(:), intent(in) :: p
     integer :: i
     do i = 0, 3
        q%p(i) = sum (p%p(i))
     end do
   end function sum_vector4
 
   pure function sum_vector4_mask (p, mask) result (q)
     type(vector4_t) :: q
     type(vector4_t), dimension(:), intent(in) :: p
     logical, dimension(:), intent(in) :: mask
     integer :: i
     do i = 0, 3
        q%p(i) = sum (p%p(i), mask=mask)
     end do
   end function sum_vector4_mask
 
 @ %def sum
 @
 \subsection{Conversions}
 Manually set a component of the four-vector:
 <<Lorentz: public>>=
   public :: vector4_set_component
 <<Lorentz: procedures>>=
   subroutine vector4_set_component (p, k, c)
     type(vector4_t), intent(inout) :: p
     integer, intent(in) :: k
     real(default), intent(in) :: c
     p%p(k) = c
   end subroutine vector4_set_component
 
 @ %def vector4_get_component
 Any component:
 <<Lorentz: public>>=
   public :: vector4_get_component
 <<Lorentz: procedures>>=
   elemental function vector4_get_component (p, k) result (c)
     real(default) :: c
     type(vector4_t), intent(in) :: p
     integer, intent(in) :: k
     c = p%p(k)
   end function vector4_get_component
 
 @ %def vector4_get_component
 @ Extract all components.  This is not elemental.
 <<Lorentz: public>>=
   public :: vector4_get_components
 <<Lorentz: procedures>>=
   pure function vector4_get_components (p) result (a)
     real(default), dimension(0:3) :: a
     type(vector4_t), intent(in) :: p
     a = p%p
   end function vector4_get_components
 
 @ %def vector4_get_components
 @ This function returns the space part of a four-vector, such that we
 can apply three-vector operations on it:
 <<Lorentz: public functions>>=
   public :: space_part
 <<Lorentz: interfaces>>=
   interface space_part
      module procedure vector4_get_space_part
   end interface
 <<Lorentz: procedures>>=
   elemental function vector4_get_space_part (p) result (q)
     type(vector3_t) :: q
     type(vector4_t), intent(in) :: p
     q%p = p%p(1:)
   end function vector4_get_space_part
 
 @ %def space_part
 @ This function returns the direction of a four-vector, i.e., a
 normalized three-vector.  If the four-vector has zero space part, we
 return a null vector.
 <<Lorentz: interfaces>>=
   interface direction
      module procedure vector4_get_direction
   end interface
 <<Lorentz: procedures>>=
   elemental function vector4_get_direction (p) result (q)
     type(vector3_t) :: q
     type(vector4_t), intent(in) :: p
     real(default) :: qq
     q%p = p%p(1:)
     qq = q**1
     if (abs(qq) > eps0) then
        q%p = q%p / qq
     else
        q%p = 0
     end if
   end function vector4_get_direction
 
 @ %def direction
 @ Change the sign of the spatial part of a four-vector
 <<Lorentz: public>>=
   public :: vector4_invert_direction
 <<Lorentz: procedures>>=
   elemental subroutine vector4_invert_direction (p)
     type(vector4_t), intent(inout) :: p
     p%p(1:3) = -p%p(1:3)
   end subroutine vector4_invert_direction
 
 @ %def vector4_invert_direction
 @ This function returns the four-vector as an ordinary array.  A
 second version for an array of four-vectors.
 <<Lorentz: public>>=
   public :: assignment (=)
 <<Lorentz: interfaces>>=
   interface assignment (=)
      module procedure array_from_vector4_1, array_from_vector4_2, &
             array_from_vector3_1, array_from_vector3_2, &
             vector4_from_array, vector3_from_array
   end interface
 <<Lorentz: procedures>>=
   pure subroutine array_from_vector4_1 (a, p)
     real(default), dimension(:), intent(out) :: a
     type(vector4_t), intent(in) :: p
     a = p%p
   end subroutine array_from_vector4_1
 
   pure subroutine array_from_vector4_2 (a, p)
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), dimension(:,:), intent(out) :: a
     integer :: i
     forall (i=1:size(p))
        a(:,i) = p(i)%p
     end forall
   end subroutine array_from_vector4_2
 
   pure subroutine array_from_vector3_1 (a, p)
     real(default), dimension(:), intent(out) :: a
     type(vector3_t), intent(in) :: p
     a = p%p
   end subroutine array_from_vector3_1
 
   pure subroutine array_from_vector3_2 (a, p)
     type(vector3_t), dimension(:), intent(in) :: p
     real(default), dimension(:,:), intent(out) :: a
     integer :: i
     forall (i=1:size(p))
        a(:,i) = p(i)%p
     end forall
   end subroutine array_from_vector3_2
 
   pure subroutine vector4_from_array (p, a)
     type(vector4_t), intent(out) :: p
     real(default), dimension(:), intent(in) :: a
     p%p(0:3) = a
   end subroutine vector4_from_array
 
   pure subroutine vector3_from_array (p, a)
     type(vector3_t), intent(out) :: p
     real(default), dimension(:), intent(in) :: a
     p%p(1:3) = a
   end subroutine vector3_from_array
 
 @ %def array_from_vector4 array_from_vector3
 @
 <<Lorentz: public>>=
   public :: vector4
 <<Lorentz: procedures>>=
   pure function vector4 (a) result (p)
     type(vector4_t) :: p
     real(default), intent(in), dimension(4) :: a
     p%p = a
   end function vector4
 
 @ %def vector4
 @
 <<Lorentz: vector4: TBP>>=
   procedure :: to_pythia6 => vector4_to_pythia6
 <<Lorentz: procedures>>=
   pure function vector4_to_pythia6 (vector4, m) result (p)
     real(double), dimension(1:5) :: p
     class(vector4_t), intent(in) :: vector4
     real(default), intent(in), optional :: m
     p(1:3) = vector4%p(1:3)
     p(4) = vector4%p(0)
     if (present (m)) then
        p(5) = m
     else
        p(5) = vector4 ** 1
     end if
   end function vector4_to_pythia6
 
 @ %def vector4_to_pythia6
 @
 \subsection{Interface to [[c_prt]]}
 Transform the momentum of a [[c_prt]] object into a four-vector and
 vice versa:
 <<Lorentz: interfaces>>=
   interface assignment (=)
      module procedure vector4_from_c_prt, c_prt_from_vector4
   end interface
 <<Lorentz: procedures>>=
   pure subroutine vector4_from_c_prt (p, c_prt)
     type(vector4_t), intent(out) :: p
     type(c_prt_t), intent(in) :: c_prt
     p%p(0) = c_prt%pe
     p%p(1) = c_prt%px
     p%p(2) = c_prt%py
     p%p(3) = c_prt%pz
   end subroutine vector4_from_c_prt
 
   pure subroutine c_prt_from_vector4 (c_prt, p)
     type(c_prt_t), intent(out) :: c_prt
     type(vector4_t), intent(in) :: p
     c_prt%pe = p%p(0)
     c_prt%px = p%p(1)
     c_prt%py = p%p(2)
     c_prt%pz = p%p(3)
     c_prt%p2 = p ** 2
   end subroutine c_prt_from_vector4
 
 @ %def vector4_from_c_prt c_prt_from_vector4
 @ Initialize a [[c_prt_t]] object with the components of a four-vector
 as its kinematical entries.  Compute the invariant mass, or use the
 optional mass-squared value instead.
 <<Lorentz: public>>=
   public :: vector4_to_c_prt
 <<Lorentz: procedures>>=
   elemental function vector4_to_c_prt (p, p2) result (c_prt)
     type(c_prt_t) :: c_prt
     type(vector4_t), intent(in) :: p
     real(default), intent(in), optional :: p2
     c_prt%pe = p%p(0)
     c_prt%px = p%p(1)
     c_prt%py = p%p(2)
     c_prt%pz = p%p(3)
     if (present (p2)) then
        c_prt%p2 = p2
     else
        c_prt%p2 = p ** 2
     end if
   end function vector4_to_c_prt
 
 @ %def vector4_to_c_prt
 @
 \subsection{Angles}
 Return the angles in a canonical system.  The angle $\phi$ is defined
 between $0\leq\phi<2\pi$.  In degenerate cases, return zero.
 <<Lorentz: public functions>>=
   public :: azimuthal_angle
 <<Lorentz: interfaces>>=
   interface azimuthal_angle
      module procedure vector3_azimuthal_angle
      module procedure vector4_azimuthal_angle
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_azimuthal_angle (p) result (phi)
     real(default) :: phi
     type(vector3_t), intent(in) :: p
     if (any (abs (p%p(1:2)) > 0)) then
        phi = atan2(p%p(2), p%p(1))
        if (phi < 0) phi = phi + twopi
     else
        phi = 0
     end if
   end function vector3_azimuthal_angle
   elemental function vector4_azimuthal_angle (p) result (phi)
     real(default) :: phi
     type(vector4_t), intent(in) :: p
     phi = vector3_azimuthal_angle (space_part (p))
   end function vector4_azimuthal_angle
 
 @ %def azimuthal_angle
 @ Azimuthal angle in degrees
 <<Lorentz: public functions>>=
   public :: azimuthal_angle_deg
 <<Lorentz: interfaces>>=
   interface azimuthal_angle_deg
      module procedure vector3_azimuthal_angle_deg
      module procedure vector4_azimuthal_angle_deg
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_azimuthal_angle_deg (p) result (phi)
     real(default) :: phi
     type(vector3_t), intent(in) :: p
     phi = vector3_azimuthal_angle (p) / degree
   end function vector3_azimuthal_angle_deg
   elemental function vector4_azimuthal_angle_deg (p) result (phi)
     real(default) :: phi
     type(vector4_t), intent(in) :: p
     phi = vector4_azimuthal_angle (p) / degree
   end function vector4_azimuthal_angle_deg
 
 @ %def azimuthal_angle_deg
 @ The azimuthal distance of two vectors.  This is the difference of
 the azimuthal angles, but cannot be larger than $\pi$: The result is
 between $-\pi<\Delta\phi\leq\pi$.
 <<Lorentz: public functions>>=
   public :: azimuthal_distance
 <<Lorentz: interfaces>>=
   interface azimuthal_distance
      module procedure vector3_azimuthal_distance
      module procedure vector4_azimuthal_distance
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_azimuthal_distance (p, q) result (dphi)
     real(default) :: dphi
     type(vector3_t), intent(in) :: p,q
     dphi = vector3_azimuthal_angle (q) - vector3_azimuthal_angle (p)
     if (dphi <= -pi) then
        dphi = dphi + twopi
     else if (dphi > pi) then
        dphi = dphi - twopi
     end if
   end function vector3_azimuthal_distance
   elemental function vector4_azimuthal_distance (p, q) result (dphi)
     real(default) :: dphi
     type(vector4_t), intent(in) :: p,q
     dphi = vector3_azimuthal_distance &
          (space_part (p), space_part (q))
   end function vector4_azimuthal_distance
 
 @ %def azimuthal_distance
 @ The same in degrees:
 <<Lorentz: public functions>>=
   public :: azimuthal_distance_deg
 <<Lorentz: interfaces>>=
   interface azimuthal_distance_deg
      module procedure vector3_azimuthal_distance_deg
      module procedure vector4_azimuthal_distance_deg
   end interface
 <<Lorentz: procedures>>=
   elemental function vector3_azimuthal_distance_deg (p, q) result (dphi)
     real(default) :: dphi
     type(vector3_t), intent(in) :: p,q
     dphi = vector3_azimuthal_distance (p, q) / degree
   end function vector3_azimuthal_distance_deg
   elemental function vector4_azimuthal_distance_deg (p, q) result (dphi)
     real(default) :: dphi
     type(vector4_t), intent(in) :: p,q
     dphi = vector4_azimuthal_distance (p, q) / degree
   end function vector4_azimuthal_distance_deg
 
 @ %def azimuthal_distance_deg
 @ The polar angle is defined $0\leq\theta\leq\pi$.  Note that
 [[ATAN2]] has the reversed order of arguments: [[ATAN2(Y,X)]].  Here,
 $x$ is the 3-component while $y$ is the transverse momentum which is
 always nonnegative.  Therefore, the result is nonnegative as well.
 <<Lorentz: public functions>>=
   public :: polar_angle
 <<Lorentz: interfaces>>=
   interface polar_angle
      module procedure polar_angle_vector3
      module procedure polar_angle_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function polar_angle_vector3 (p) result (theta)
     real(default) :: theta
     type(vector3_t), intent(in) :: p
     if (any (abs (p%p) > 0)) then
        theta = atan2 (sqrt(p%p(1)**2 + p%p(2)**2), p%p(3))
     else
        theta = 0
     end if
   end function polar_angle_vector3
   elemental function polar_angle_vector4 (p) result (theta)
     real(default) :: theta
     type(vector4_t), intent(in) :: p
     theta = polar_angle (space_part (p))
   end function polar_angle_vector4
 
 @ %def polar_angle
 @ This is the cosine of the polar angle: $-1\leq\cos\theta\leq 1$.
 <<Lorentz: public functions>>=
   public :: polar_angle_ct
 <<Lorentz: interfaces>>=
   interface polar_angle_ct
      module procedure polar_angle_ct_vector3
      module procedure polar_angle_ct_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function polar_angle_ct_vector3 (p) result (ct)
     real(default) :: ct
     type(vector3_t), intent(in) :: p
     if (any (abs (p%p) > 0)) then
        ct = p%p(3) / p**1
     else
        ct = 1
     end if
   end function polar_angle_ct_vector3
   elemental function polar_angle_ct_vector4 (p) result (ct)
     real(default) :: ct
     type(vector4_t), intent(in) :: p
     ct = polar_angle_ct (space_part (p))
   end function polar_angle_ct_vector4
 
 @ %def polar_angle_ct
 @ The polar angle in degrees.
 <<Lorentz: public functions>>=
   public :: polar_angle_deg
 <<Lorentz: interfaces>>=
   interface polar_angle_deg
      module procedure polar_angle_deg_vector3
      module procedure polar_angle_deg_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function polar_angle_deg_vector3 (p) result (theta)
     real(default) :: theta
     type(vector3_t), intent(in) :: p
     theta = polar_angle (p) / degree
   end function polar_angle_deg_vector3
   elemental function polar_angle_deg_vector4 (p) result (theta)
     real(default) :: theta
     type(vector4_t), intent(in) :: p
     theta = polar_angle (p) / degree
   end function polar_angle_deg_vector4
 
 @ %def polar_angle_deg
 @ This is the angle enclosed between two three-momenta.  If one of the
 momenta is zero, we return an angle of zero.  The range of the result
 is $0\leq\theta\leq\pi$.  If there is only one argument, take the
 positive $z$ axis as reference.
 <<Lorentz: public functions>>=
   public :: enclosed_angle
 <<Lorentz: interfaces>>=
   interface enclosed_angle
      module procedure enclosed_angle_vector3
      module procedure enclosed_angle_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function enclosed_angle_vector3 (p, q) result (theta)
     real(default) :: theta
     type(vector3_t), intent(in) :: p, q
     theta = acos (enclosed_angle_ct (p, q))
   end function enclosed_angle_vector3
   elemental function enclosed_angle_vector4 (p, q) result (theta)
     real(default) :: theta
     type(vector4_t), intent(in) :: p, q
     theta = enclosed_angle (space_part (p), space_part (q))
   end function enclosed_angle_vector4
 
 @ %def enclosed_angle
 @ The cosine of the enclosed angle.
 <<Lorentz: public functions>>=
   public :: enclosed_angle_ct
 <<Lorentz: interfaces>>=
   interface enclosed_angle_ct
      module procedure enclosed_angle_ct_vector3
      module procedure enclosed_angle_ct_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function enclosed_angle_ct_vector3 (p, q) result (ct)
     real(default) :: ct
     type(vector3_t), intent(in) :: p, q
     if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then
        ct = p*q / (p**1 * q**1)
        if (ct>1) then
           ct = 1
        else if (ct<-1) then
           ct = -1
        end if
     else
        ct = 1
     end if
   end function enclosed_angle_ct_vector3
   elemental function enclosed_angle_ct_vector4 (p, q) result (ct)
     real(default) :: ct
     type(vector4_t), intent(in) :: p, q
     ct = enclosed_angle_ct (space_part (p), space_part (q))
   end function enclosed_angle_ct_vector4
 
 @ %def enclosed_angle_ct
 @ The enclosed angle in degrees.
 <<Lorentz: public functions>>=
   public :: enclosed_angle_deg
 <<Lorentz: interfaces>>=
   interface enclosed_angle_deg
      module procedure enclosed_angle_deg_vector3
      module procedure enclosed_angle_deg_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function enclosed_angle_deg_vector3 (p, q) result (theta)
     real(default) :: theta
     type(vector3_t), intent(in) :: p, q
     theta = enclosed_angle (p, q) / degree
   end function enclosed_angle_deg_vector3
   elemental function enclosed_angle_deg_vector4 (p, q) result (theta)
     real(default) :: theta
     type(vector4_t), intent(in) :: p, q
     theta = enclosed_angle (p, q) / degree
   end function enclosed_angle_deg_vector4
 
 @ %def enclosed_angle
 @ The polar angle of the first momentum w.r.t.\ the second momentum,
 evaluated in the rest frame of the second momentum.  If the second
 four-momentum is not timelike, return zero.
 <<Lorentz: public functions>>=
   public :: enclosed_angle_rest_frame
   public :: enclosed_angle_ct_rest_frame
   public :: enclosed_angle_deg_rest_frame
 <<Lorentz: interfaces>>=
   interface enclosed_angle_rest_frame
      module procedure enclosed_angle_rest_frame_vector4
   end interface
   interface enclosed_angle_ct_rest_frame
      module procedure enclosed_angle_ct_rest_frame_vector4
   end interface
   interface enclosed_angle_deg_rest_frame
      module procedure enclosed_angle_deg_rest_frame_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function enclosed_angle_rest_frame_vector4 (p, q) result (theta)
     type(vector4_t), intent(in) :: p, q
     real(default) :: theta
     theta = acos (enclosed_angle_ct_rest_frame (p, q))
   end function enclosed_angle_rest_frame_vector4
   elemental function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct)
     type(vector4_t), intent(in) :: p, q
     real(default) :: ct
     if (invariant_mass(q) > 0) then
        ct = enclosed_angle_ct ( &
             space_part (boost(-q, invariant_mass (q)) * p), &
             space_part (q))
     else
        ct = 1
     end if
   end function enclosed_angle_ct_rest_frame_vector4
   elemental function enclosed_angle_deg_rest_frame_vector4 (p, q) &
        result (theta)
     type(vector4_t), intent(in) :: p, q
     real(default) :: theta
     theta = enclosed_angle_rest_frame (p, q) / degree
   end function enclosed_angle_deg_rest_frame_vector4
 
 @ %def enclosed_angle_rest_frame
 @ %def enclosed_angle_ct_rest_frame
 @ %def enclosed_angle_deg_rest_frame
 @
 \subsection{More kinematical functions (some redundant)}
 The scalar transverse momentum (assuming the $z$ axis is longitudinal)
 <<Lorentz: public functions>>=
   public :: transverse_part
 <<Lorentz: interfaces>>=
   interface transverse_part
      module procedure transverse_part_vector4_beam_axis
      module procedure transverse_part_vector4_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function transverse_part_vector4_beam_axis (p) result (pT)
     real(default) :: pT
     type(vector4_t), intent(in) :: p
     pT = sqrt(p%p(1)**2 + p%p(2)**2)
   end function transverse_part_vector4_beam_axis
 
   elemental function transverse_part_vector4_vector4 (p1, p2) result (pT)
     real(default) :: pT
     type(vector4_t), intent(in) :: p1, p2
     real(default) :: p1_norm, p2_norm, p1p2, pT2
     p1_norm = space_part_norm(p1)**2
     p2_norm = space_part_norm(p2)**2
 !    p1p2 = p1%p(1:3)*p2%p(1:3)
     p1p2 = vector4_get_space_part(p1) * vector4_get_space_part(p2)
     pT2 = (p1_norm*p2_norm - p1p2)/p1_norm
     pT = sqrt (pT2)
   end function transverse_part_vector4_vector4
 
 @ %def transverse_part
 @ The scalar longitudinal momentum (assuming the $z$ axis is
 longitudinal).  Identical to [[momentum_z_component]].
 <<Lorentz: public functions>>=
   public :: longitudinal_part
 <<Lorentz: interfaces>>=
   interface longitudinal_part
      module procedure longitudinal_part_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function longitudinal_part_vector4 (p) result (pL)
     real(default) :: pL
     type(vector4_t), intent(in) :: p
     pL = p%p(3)
   end function longitudinal_part_vector4
 
 @ %def longitudinal_part
 @ Absolute value of three-momentum
 <<Lorentz: public functions>>=
   public :: space_part_norm
 <<Lorentz: interfaces>>=
   interface space_part_norm
      module procedure space_part_norm_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function space_part_norm_vector4 (p) result (p3)
     real(default) :: p3
     type(vector4_t), intent(in) :: p
     p3 = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2)
   end function space_part_norm_vector4
 
 @ %def momentum
 @ The energy (the zeroth component)
 <<Lorentz: public functions>>=
   public :: energy
 <<Lorentz: interfaces>>=
   interface energy
      module procedure energy_vector4
      module procedure energy_vector3
      module procedure energy_real
   end interface
 <<Lorentz: procedures>>=
   elemental function energy_vector4 (p) result (E)
     real(default) :: E
     type(vector4_t), intent(in) :: p
     E = p%p(0)
   end function energy_vector4
 
 @ Alternative: The energy corresponding to a given momentum and mass.
 If the mass is omitted, it is zero
 <<Lorentz: procedures>>=
   elemental function energy_vector3 (p, mass) result (E)
     real(default) :: E
     type(vector3_t), intent(in) :: p
     real(default), intent(in), optional :: mass
     if (present (mass)) then
        E = sqrt (p**2 + mass**2)
     else
        E = p**1
     end if
   end function energy_vector3
 
   elemental function energy_real (p, mass) result (E)
     real(default) :: E
     real(default), intent(in) :: p
     real(default), intent(in), optional :: mass
     if (present (mass)) then
        E = sqrt (p**2 + mass**2)
     else
        E = abs (p)
     end if
   end function energy_real
 
 @ %def energy
 @ The invariant mass of four-momenta.  Zero for lightlike, negative for
 spacelike momenta.
 <<Lorentz: public functions>>=
   public :: invariant_mass
 <<Lorentz: interfaces>>=
   interface invariant_mass
      module procedure invariant_mass_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function invariant_mass_vector4 (p) result (m)
     real(default) :: m
     type(vector4_t), intent(in) :: p
     real(default) :: msq
     msq = p*p
     if (msq >= 0) then
        m = sqrt (msq)
     else
        m = - sqrt (abs (msq))
     end if
   end function invariant_mass_vector4
 @ %def invariant_mass
 
 @ The invariant mass squared.  Zero for lightlike, negative for
 spacelike momenta.
 <<Lorentz: public functions>>=
   public :: invariant_mass_squared
 <<Lorentz: interfaces>>=
   interface invariant_mass_squared
      module procedure invariant_mass_squared_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function invariant_mass_squared_vector4 (p) result (msq)
     real(default) :: msq
     type(vector4_t), intent(in) :: p
     msq = p*p
   end function invariant_mass_squared_vector4
 
 @ %def invariant_mass_squared
 @ The transverse mass.  If the mass squared is negative, this value
 also is negative.
 <<Lorentz: public functions>>=
   public :: transverse_mass
 <<Lorentz: interfaces>>=
   interface transverse_mass
      module procedure transverse_mass_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function transverse_mass_vector4 (p) result (m)
     real(default) :: m
     type(vector4_t), intent(in) :: p
     real(default) :: msq
     msq = p%p(0)**2 - p%p(1)**2 - p%p(2)**2
     if (msq >= 0) then
        m = sqrt (msq)
     else
        m = - sqrt (abs (msq))
     end if
   end function transverse_mass_vector4
 
 @ %def transverse_mass
 @ The rapidity (defined if particle is massive or $p_\perp>0$)
 <<Lorentz: public functions>>=
   public :: rapidity
 <<Lorentz: interfaces>>=
   interface rapidity
      module procedure rapidity_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function rapidity_vector4 (p) result (y)
     real(default) :: y
     type(vector4_t), intent(in) :: p
     y = .5 * log( (energy (p) + longitudinal_part (p)) &
          &       /(energy (p) - longitudinal_part (p)))
   end function rapidity_vector4
 
 @ %def rapidity
 @ The pseudorapidity (defined if $p_\perp>0$)
 <<Lorentz: public functions>>=
   public :: pseudorapidity
 <<Lorentz: interfaces>>=
   interface pseudorapidity
      module procedure pseudorapidity_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function pseudorapidity_vector4 (p) result (eta)
     real(default) :: eta
     type(vector4_t), intent(in) :: p
     eta = -log( tan (.5 * polar_angle (p)))
   end function pseudorapidity_vector4
 
 @ %def pseudorapidity
 @ The rapidity distance (defined if both $p_\perp>0$)
 <<Lorentz: public functions>>=
   public :: rapidity_distance
 <<Lorentz: interfaces>>=
   interface rapidity_distance
      module procedure rapidity_distance_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function rapidity_distance_vector4 (p, q) result (dy)
     type(vector4_t), intent(in) :: p, q
     real(default) :: dy
     dy = rapidity (q) - rapidity (p)
   end function rapidity_distance_vector4
 
 @ %def rapidity_distance
 @ The pseudorapidity distance (defined if both $p_\perp>0$)
 <<Lorentz: public functions>>=
   public :: pseudorapidity_distance
 <<Lorentz: interfaces>>=
   interface pseudorapidity_distance
      module procedure pseudorapidity_distance_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function pseudorapidity_distance_vector4 (p, q) result (deta)
     real(default) :: deta
     type(vector4_t), intent(in) :: p, q
     deta = pseudorapidity (q) - pseudorapidity (p)
   end function pseudorapidity_distance_vector4
 
 @ %def pseudorapidity_distance
 @ The distance on the $\eta-\phi$ cylinder:
 <<Lorentz: public functions>>=
   public :: eta_phi_distance
 <<Lorentz: interfaces>>=
   interface eta_phi_distance
      module procedure eta_phi_distance_vector4
   end interface
 <<Lorentz: procedures>>=
   elemental function eta_phi_distance_vector4 (p, q) result (dr)
     type(vector4_t), intent(in) :: p, q
     real(default) :: dr
     dr = sqrt ( &
          pseudorapidity_distance (p, q)**2 &
          + azimuthal_distance (p, q)**2)
   end function eta_phi_distance_vector4
 
 @ %def eta_phi_distance
 @
 \subsection{Lorentz transformations}
 <<Lorentz: public>>=
   public :: lorentz_transformation_t
 <<Lorentz: types>>=
   type :: lorentz_transformation_t
      private
      real(default), dimension(0:3, 0:3) :: L
    contains
    <<Lorentz: lorentz transformation: TBP>>
   end type lorentz_transformation_t
 
 @ %def lorentz_transformation_t
 @ Output:
 <<Lorentz: public>>=
   public :: lorentz_transformation_write
 <<Lorentz: lorentz transformation: TBP>>=
   procedure :: write => lorentz_transformation_write
 <<Lorentz: procedures>>=
   subroutine lorentz_transformation_write (L, unit, testflag, ultra)
     class(lorentz_transformation_t), intent(in) :: L
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag, ultra
     integer :: u, i
     logical :: ult
     character(len=7) :: fmt
     ult = .false.; if (present (ultra)) ult = ultra
     if (ult) then
        call pac_fmt (fmt, FMT_19, FMT_11, ultra)
     else
        call pac_fmt (fmt, FMT_19, FMT_13, testflag)
     end if
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A,3(1x," // fmt // "))")  "L00 = ", L%L(0,0)
     write (u, "(1x,A,3(1x," // fmt // "))")  "L0j = ", L%L(0,1:3)
     do i = 1, 3
        write (u, "(1x,A,I0,A,3(1x," // fmt // "))")  &
             "L", i, "0 = ", L%L(i,0)
        write (u, "(1x,A,I0,A,3(1x," // fmt // "))")  &
             "L", i, "j = ", L%L(i,1:3)
     end do
   end subroutine lorentz_transformation_write
 
 @ %def lorentz_transformation_write
 @ Extract all components:
 <<Lorentz: public>>=
   public :: lorentz_transformation_get_components
 <<Lorentz: procedures>>=
   pure function lorentz_transformation_get_components (L) result (a)
     type(lorentz_transformation_t), intent(in) :: L
     real(default), dimension(0:3,0:3) :: a
     a = L%L
   end function lorentz_transformation_get_components
 
 @ %def lorentz_transformation_get_components
 @
 \subsection{Functions of Lorentz transformations}
 For the inverse, we make use of the fact that
 $\Lambda^{\mu\nu}\Lambda_{\mu\rho}=\delta^\nu_\rho$.  So, lowering the
 indices and transposing is sufficient.
 <<Lorentz: public functions>>=
   public :: inverse
 <<Lorentz: interfaces>>=
   interface inverse
      module procedure lorentz_transformation_inverse
   end interface
 <<Lorentz: procedures>>=
   elemental function lorentz_transformation_inverse (L) result (IL)
     type(lorentz_transformation_t) :: IL
     type(lorentz_transformation_t), intent(in) :: L
     IL%L(0,0) = L%L(0,0)
     IL%L(0,1:) = -L%L(1:,0)
     IL%L(1:,0) = -L%L(0,1:)
     IL%L(1:,1:) = transpose(L%L(1:,1:))
   end function lorentz_transformation_inverse
 
 @ %def lorentz_transformation_inverse
 @ %def inverse
 @
 \subsection{Invariants}
 These are used below.  The first array index is varying fastest in
 [[FORTRAN]]; therefore the extra minus in the odd-rank tensor
 epsilon.
 <<Lorentz: parameters>>=
   integer, dimension(3,3), parameter :: delta_three = &
        & reshape( source = [ 1,0,0, 0,1,0, 0,0,1 ], &
        &          shape  = [3,3] )
   integer, dimension(3,3,3), parameter :: epsilon_three = &
        & reshape( source = [ 0, 0,0,  0,0,-1,   0,1,0, &
        &                     0, 0,1,  0,0, 0,  -1,0,0, &
        &                     0,-1,0,  1,0, 0,   0,0,0 ],&
        &          shape = [3,3,3] )
 @ %def delta_three epsilon_three
 @ This could be of some use:
 <<Lorentz: public>>=
   public :: identity
 <<Lorentz: parameters>>=
   type(lorentz_transformation_t), parameter :: &
        & identity = &
        & lorentz_transformation_t ( &
        & reshape( source = [ one, zero, zero, zero, &
        &                     zero, one, zero, zero, &
        &                     zero, zero, one, zero, &
        &                     zero, zero, zero, one ],&
        &          shape = [4,4] ) )
 @ %def identity
 <<Lorentz: public>>=
   public :: space_reflection
 <<Lorentz: parameters>>=
   type(lorentz_transformation_t), parameter :: &
        & space_reflection = &
        & lorentz_transformation_t ( &
        & reshape( source = [ one, zero, zero, zero, &
        &                     zero,-one, zero, zero, &
        &                     zero, zero,-one, zero, &
        &                     zero, zero, zero,-one ],&
        &          shape = [4,4] ) )
 @ %def space_reflection
 @ Builds a unit vector orthogal to the input vector in the xy-plane.
 <<Lorentz: public functions>>=
   public :: create_orthogonal
 <<Lorentz: procedures>>=
   function create_orthogonal (p_in) result (p_out)
     type(vector3_t), intent(in) :: p_in
     type(vector3_t) :: p_out
     real(default) :: ab
     ab = sqrt (p_in%p(1)**2 + p_in%p(2)**2)
     if (abs (ab) < eps0) then
       p_out%p(1) = 1
       p_out%p(2) = 0
       p_out%p(3) = 0
     else
       p_out%p(1) = p_in%p(2)
       p_out%p(2) = -p_in%p(1)
       p_out%p(3) = 0
       p_out = p_out / ab
     end if
   end function create_orthogonal
 
 @ %def create_orthogonal
 @
 <<Lorentz: public functions>>=
   public :: create_unit_vector
 <<Lorentz: procedures>>=
   function create_unit_vector (p_in) result (p_out)
     type(vector4_t), intent(in) :: p_in
     type(vector3_t) :: p_out
     p_out%p = p_in%p(1:3) / space_part_norm (p_in)
   end function create_unit_vector
 
 @ %def create_unit_vector
 @
 <<Lorentz: public functions>>=
   public :: normalize
 <<Lorentz: procedures>>=
   function normalize(p) result (p_norm)
     type(vector3_t) :: p_norm
     type(vector3_t), intent(in) :: p
     real(default) :: abs
     abs = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2)
     p_norm = p / abs
   end function normalize
 
 @ %def normalize
 @ Computes the invariant mass of the momenta sum given by the indices in
 [[i_res_born]] and the optional argument [[i_emitter]].
 <<Lorentz: public>>=
   public :: compute_resonance_mass
 <<Lorentz: procedures>>=
   pure function compute_resonance_mass (p, i_res_born, i_gluon) result (m)
     real(default) :: m
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), dimension(:) :: i_res_born
     integer, intent(in), optional :: i_gluon
     type(vector4_t) :: p_res
     p_res = get_resonance_momentum (p, i_res_born, i_gluon)
     m = p_res**1
   end function compute_resonance_mass
 
 @ %def compute_resonance_mass
 @
 <<Lorentz: public>>=
   public :: get_resonance_momentum
 <<Lorentz: procedures>>=
   pure function get_resonance_momentum (p, i_res_born, i_gluon) result (p_res)
     type(vector4_t) :: p_res
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), dimension(:) :: i_res_born
     integer, intent(in), optional :: i_gluon
     integer :: i
     p_res = vector4_null
     do i = 1, size (i_res_born)
        p_res = p_res + p (i_res_born(i))
     end do
     if (present (i_gluon)) p_res = p_res + p (i_gluon)
   end function get_resonance_momentum
 
 @ %def get_resonance_momentum
 @
 <<Lorentz: public>>=
   public :: create_two_particle_decay
 <<Lorentz: procedures>>=
   function create_two_particle_decay (s, p1, p2) result (p_rest)
     type(vector4_t), dimension(3) :: p_rest
     real(default), intent(in) :: s
     type(vector4_t), intent(in) :: p1, p2
     real(default) :: m1_sq, m2_sq
     real(default) :: E1, E2, p
     m1_sq = p1**2; m2_sq = p2**2
     p = sqrt (lambda (s, m1_sq, m2_sq)) / (two * sqrt (s))
     E1 = sqrt (m1_sq + p**2); E2 = sqrt (m2_sq + p**2)
     p_rest(1)%p = [sqrt (s), zero, zero, zero]
     p_rest(2)%p(0) = E1
     p_rest(2)%p(1:3) = p * p1%p(1:3) / space_part_norm (p1)
     p_rest(3)%p(0) = E2; p_rest(3)%p(1:3) = -p_rest(2)%p(1:3)
   end function create_two_particle_decay
 
 @ %def create_two_particle_decay
 @ This function creates a phase-space point for a $1 \to 3$ decay in
 the decaying particle's rest frame. There are three rest frames for
 this system, corresponding to $s$-, $t$,- and $u$-channel momentum
 exchange, also referred to as Gottfried-Jackson frames. Below, we choose
 the momentum with index 1 to be aligned along the $z$-axis. We then
 have
 \begin{align*}
   s_1 &= \left(p_1 + p_2\right)^2, \\
   s_2 &= \left(p_2 + p_3\right)^2, \\
   s_3 &= \left(p_1 + p_3\right)^2, \\
   s_1 + s_2 + s_3 &= s + m_1^2 + m_2^2 + m_3^2.
 \end{align*}
 From these we can construct
 \begin{align*}
   E_1^{R23} = \frac{s - s_2 - m_1^2}{2\sqrt{s_2}} &\quad P_1^{R23} = \frac{\lambda^{1/2}(s, s_2, m_1^2)}{2\sqrt{s_2}},\\
   E_2^{R23} = \frac{s_2 + m_2^2 - m_3^2}{2\sqrt{s_2}} &\quad P_2^{R23} = \frac{\lambda^{1/2}(s_2, m_2^2, m_3^2)}{2\sqrt{s_2}},\\
   E_3^{R23} = \frac{s_2 + m_3^2 - m_2^2}{2\sqrt{s_2}} &\quad P_3^{R23} = P_2^{R23},
 \end{align*}
 where $R23$ denotes the Gottfried-Jackson frame of our choice. Finally, the scattering angle $\theta_{12}^{R23}$ between
 momentum $1$ and $2$ can be determined to be
 \begin{equation*}
   \cos\theta_{12}^{R23} = \frac{(s - s_2 - m_1^2)(s_2 + m_2^2 - m_3^2) + 2s_2 (m_1^2 + m_2^2 - s_1)}
                                {\lambda^{1/2}(s, s_2, m_1^2) \lambda^{1/2}(s_2, m_2^2, m_3^2)}
 \end{equation*}
 <<Lorentz: public>>=
   public :: create_three_particle_decay
 <<Lorentz: procedures>>=
   function create_three_particle_decay (p1, p2, p3) result (p_rest)
     type(vector4_t), dimension(4) :: p_rest
     type(vector4_t), intent(in) :: p1, p2, p3
     real(default) :: E1, E2, E3
     real(default) :: pr1, pr2, pr3
     real(default) :: s, s1, s2, s3
     real(default) :: m1_sq, m2_sq, m3_sq
     real(default) :: cos_theta_12
     type(vector3_t) :: v3_unit
     type(lorentz_transformation_t) :: rot
     m1_sq = p1**2
     m2_sq = p2**2
     m3_sq = p3**2
     s1 = (p1 + p2)**2
     s2 = (p2 + p3)**2
     s3 = (p3 + p1)**2
     s = s1 + s2 + s3 - m1_sq - m2_sq - m3_sq
     E1 = (s - s2 - m1_sq) / (two * sqrt (s2))
     E2 = (s2 + m2_sq - m3_sq) / (two * sqrt (s2))
     E3 = (s2 + m3_sq - m2_sq) / (two * sqrt (s2))
     pr1 = sqrt (lambda (s, s2, m1_sq)) / (two * sqrt (s2))
     pr2 = sqrt (lambda (s2, m2_sq, m3_sq)) / (two * sqrt(s2))
     pr3 = pr2
     cos_theta_12 = ((s - s2 - m1_sq) * (s2 + m2_sq - m3_sq) + two * s2 * (m1_sq + m2_sq - s1)) / &
          sqrt (lambda (s, s2, m1_sq) * lambda (s2, m2_sq, m3_sq))
     v3_unit%p = [zero, zero, one]
     p_rest(1)%p(0) = E1
     p_rest(1)%p(1:3) = v3_unit%p * pr1
     p_rest(2)%p(0) = E2
     p_rest(2)%p(1:3) = v3_unit%p * pr2
     p_rest(3)%p(0) = E3
     p_rest(3)%p(1:3) = v3_unit%p * pr3
     p_rest(4)%p(0) = (s + s2 - m1_sq) / (2 * sqrt (s2))
     p_rest(4)%p(1:3) = - p_rest(1)%p(1:3)
     rot = rotation (cos_theta_12, sqrt (one - cos_theta_12**2), 2)
     p_rest(2) = rot * p_rest(2)
     p_rest(3)%p(1:3) = - p_rest(2)%p(1:3)
   end function create_three_particle_decay
 
 @ %def create_three_particle_decay
 @
 <<Lorentz: public>>=
   public :: evaluate_one_to_two_splitting_special
 <<Lorentz: interfaces>>=
   abstract interface
      subroutine evaluate_one_to_two_splitting_special (p_origin, &
           p1_in, p2_in, p1_out, p2_out, msq_in, jac)
        import
        type(vector4_t), intent(in) :: p_origin
        type(vector4_t), intent(in) :: p1_in, p2_in
        type(vector4_t), intent(inout) :: p1_out, p2_out
        real(default), intent(in), optional :: msq_in
        real(default), intent(inout), optional :: jac
      end subroutine evaluate_one_to_two_splitting_special
   end interface
 
 @ %def evaluate_one_to_two_splitting_special
 @
 <<Lorentz: public>>=
   public :: generate_on_shell_decay
 <<Lorentz: procedures>>=
   recursive subroutine generate_on_shell_decay (p_dec, &
       p_in, p_out, i_real, msq_in, jac, evaluate_special)
     type(vector4_t), intent(in) :: p_dec
     type(vector4_t), intent(in), dimension(:) :: p_in
     type(vector4_t), intent(inout), dimension(:) :: p_out
     integer, intent(in) :: i_real
     real(default), intent(in), optional :: msq_in
     real(default), intent(inout), optional :: jac
     procedure(evaluate_one_to_two_splitting_special), intent(in), &
           pointer, optional :: evaluate_special
     type(vector4_t) :: p_dec_new
     integer :: n_recoil
     n_recoil = size (p_in) - 1
     if (n_recoil > 1) then
        if (present (evaluate_special)) then
           call evaluate_special (p_dec, p_in(1), sum (p_in (2 : n_recoil + 1)), &
                p_out(i_real), p_dec_new)
           call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, &
                i_real + 1, msq_in, jac, evaluate_special)
        else
           call evaluate_one_to_two_splitting (p_dec, p_in(1), &
                sum (p_in (2 : n_recoil + 1)), p_out(i_real), p_dec_new, msq_in, jac)
           call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, &
                i_real + 1, msq_in, jac)
        end if
     else
        call evaluate_one_to_two_splitting (p_dec, p_in(1), p_in(2), &
             p_out(i_real), p_out(i_real + 1), msq_in, jac)
     end if
 
   end subroutine generate_on_shell_decay
 
   subroutine evaluate_one_to_two_splitting (p_origin, &
       p1_in, p2_in, p1_out, p2_out, msq_in, jac)
     type(vector4_t), intent(in) :: p_origin
     type(vector4_t), intent(in) :: p1_in, p2_in
     type(vector4_t), intent(inout) :: p1_out, p2_out
     real(default), intent(in), optional :: msq_in
     real(default), intent(inout), optional :: jac
     type(lorentz_transformation_t) :: L
     type(vector4_t) :: p1_rest, p2_rest
     real(default) :: m, msq, msq1, msq2
     real(default) :: E1, E2, p
     real(default) :: lda, rlda_soft
 
     call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest)
 
     msq = p_origin**2; m = sqrt(msq)
     msq1 = p1_in**2; msq2 = p2_in**2
 
     lda = lambda (msq, msq1, msq2)
     if (lda < zero) then
        print *, 'Encountered lambda < 0 in 1 -> 2 splitting! '
        print *, 'lda: ', lda
        print *, 'm: ', m, 'msq: ', msq
        print *, 'm1: ', sqrt (msq1), 'msq1: ', msq1
        print *, 'm2: ', sqrt (msq2), 'msq2: ', msq2
        stop
     end if
     p = sqrt (lda) / (two * m)
 
     E1 = sqrt (msq1 + p**2)
     E2 = sqrt (msq2 + p**2)
 
     p1_out = shift_momentum (p1_rest, E1, p)
     p2_out = shift_momentum (p2_rest, E2, p)
 
     L = boost (p_origin, p_origin**1)
     p1_out = L  * p1_out
     p2_out = L  * p2_out
 
     if (present (jac) .and. present (msq_in)) then
        jac = jac * sqrt(lda) / msq
        rlda_soft = sqrt (lambda (msq_in, msq1, msq2))
        !!! We have to undo the Jacobian which has already been
        !!! supplied by the Born phase space.
        jac = jac * msq_in / rlda_soft
     end if
 
   contains
 
    subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out)
      type(vector4_t), intent(in) :: p1_in, p2_in
      type(vector4_t), intent(out) :: p1_out, p2_out
      type(lorentz_transformation_t) :: L
      L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1))
      p1_out = L * p1_in; p2_out = L * p2_in
    end subroutine get_rest_frame
 
    function shift_momentum (p_in, E, p) result (p_out)
      type(vector4_t) :: p_out
      type(vector4_t), intent(in) :: p_in
      real(default), intent(in) :: E, p
      type(vector3_t) :: vec
      vec = p_in%p(1:3) / space_part_norm (p_in)
      p_out = vector4_moving (E, p * vec)
    end function shift_momentum
 
   end subroutine evaluate_one_to_two_splitting
 
 @ %def generate_on_shell_decay
 @
 \subsection{Boosts}
 We build Lorentz transformations from boosts and rotations.  In both
 cases we can supply a three-vector which defines the axis and (hyperbolic)
 angle.  For a boost, this is the vector $\vec\beta=\vec p/E$,
 such that a particle at rest with mass $m$ is boosted to a particle
 with three-vector $\vec p$.  Here, we have
 \begin{equation}
   \beta = \tanh\chi = p/E, \qquad
   \gamma = \cosh\chi = E/m, \qquad
   \beta\gamma = \sinh\chi = p/m
 \end{equation}
 <<Lorentz: public functions>>=
   public :: boost
 <<Lorentz: interfaces>>=
   interface boost
      module procedure boost_from_rest_frame
      module procedure boost_from_rest_frame_vector3
      module procedure boost_generic
      module procedure boost_canonical
   end interface
 @ %def boost
 @ In the first form, the argument is some four-momentum, the space
 part of which determines a direction, and the associated mass (which
 is not checked against the four-momentum).  The boost vector
 $\gamma\vec\beta$ is then given by $\vec p/m$.  This boosts from the
 rest frame of a particle to the current frame.  To be explicit, if
 $\vec p$ is the momentum of a particle and $m$ its mass, $L(\vec p/m)$
 is the transformation that turns $(m;\vec 0)$ into $(E;\vec p)$.
 Conversely, the inverse transformation boosts a vector \emph{into} the
 rest frame of a particle, in particular $(E;\vec p)$ into $(m;\vec
 0)$.
 <<Lorentz: procedures>>=
   elemental function boost_from_rest_frame (p, m) result (L)
     type(lorentz_transformation_t) :: L
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: m
     L = boost_from_rest_frame_vector3 (space_part (p), m)
   end function boost_from_rest_frame
   elemental function boost_from_rest_frame_vector3 (p, m) result (L)
     type(lorentz_transformation_t) :: L
     type(vector3_t), intent(in) :: p
     real(default), intent(in) :: m
     type(vector3_t) :: beta_gamma
     real(default) :: bg2, g, c
     integer :: i,j
     if (m > eps0) then
        beta_gamma = p / m
        bg2 = beta_gamma**2
     else
        bg2 = 0
        L = identity
        return
     end if
     if (bg2 > eps0) then
        g = sqrt(1 + bg2);  c = (g-1)/bg2
     else
        g = one + bg2 / two
        c = one / two
     end if
     L%L(0,0)  = g
     L%L(0,1:) = beta_gamma%p
     L%L(1:,0) = L%L(0,1:)
     do i=1,3
        do j=1,3
           L%L(i,j) = delta_three(i,j) + c*beta_gamma%p(i)*beta_gamma%p(j)
        end do
     end do
   end function boost_from_rest_frame_vector3
 @ %def boost_from_rest_frame
 @ A canonical boost is a boost along one of the coordinate axes, which
 we may supply as an integer argument.  Here, $\gamma\beta$ is scalar.
 <<Lorentz: procedures>>=
   elemental function boost_canonical (beta_gamma, k) result (L)
     type(lorentz_transformation_t) :: L
     real(default), intent(in) :: beta_gamma
     integer, intent(in) :: k
     real(default) :: g
     g = sqrt(1 + beta_gamma**2)
     L = identity
     L%L(0,0) = g
     L%L(0,k) = beta_gamma
     L%L(k,0) = L%L(0,k)
     L%L(k,k) = L%L(0,0)
   end function boost_canonical
 @ %def boost_canonical
 @ Instead of a canonical axis, we can supply an arbitrary axis which
 need not be normalized.  If it is zero, return the unit matrix.
 <<Lorentz: procedures>>=
   elemental function boost_generic (beta_gamma, axis) result (L)
     type(lorentz_transformation_t) :: L
     real(default), intent(in) :: beta_gamma
     type(vector3_t), intent(in) :: axis
     if (any (abs (axis%p) > 0)) then
        L = boost_from_rest_frame_vector3 (beta_gamma * axis, axis**1)
     else
        L = identity
     end if
   end function boost_generic
 
 @ %def boost_generic
 @
 \subsection{Rotations}
 For a rotation, the vector defines the rotation axis, and its length
 the rotation angle. All of these rotations rotate counterclockwise
 in a right-handed coordinate system.
 <<Lorentz: public functions>>=
   public :: rotation
 <<Lorentz: interfaces>>=
   interface rotation
      module procedure rotation_generic
      module procedure rotation_canonical
      module procedure rotation_generic_cs
      module procedure rotation_canonical_cs
   end interface
 @ %def rotation
 @ If $\cos\phi$ and $\sin\phi$ is already known, we do not have to
 calculate them.  Of course, the user has to ensure that
 $\cos^2\phi+\sin^2\phi=1$, and that the given axis [[n]] is normalized to
 one.  In the second form, the length of [[axis]] is the rotation
 angle.
 <<Lorentz: procedures>>=
   elemental function rotation_generic_cs (cp, sp, axis) result (R)
     type(lorentz_transformation_t) :: R
     real(default), intent(in) :: cp, sp
     type(vector3_t), intent(in) :: axis
     integer :: i,j
     R = identity
     do i=1,3
        do j=1,3
           R%L(i,j) = cp*delta_three(i,j) + (1-cp)*axis%p(i)*axis%p(j)  &
                &   - sp*dot_product(epsilon_three(i,j,:), axis%p)
        end do
     end do
   end function rotation_generic_cs
   elemental function rotation_generic (axis) result (R)
     type(lorentz_transformation_t) :: R
     type(vector3_t), intent(in) :: axis
     real(default) :: phi
     if (any (abs(axis%p) > 0)) then
        phi = abs(axis**1)
        R = rotation_generic_cs (cos(phi), sin(phi), axis/phi)
     else
        R = identity
     end if
   end function rotation_generic
 @ %def rotation_generic_cs rotation_generic
 @ Alternatively, give just the angle and label the coordinate axis by
 an integer.
 <<Lorentz: procedures>>=
   elemental function rotation_canonical_cs (cp, sp, k) result (R)
     type(lorentz_transformation_t) :: R
     real(default), intent(in) :: cp, sp
     integer, intent(in) :: k
     integer :: i,j
     R = identity
     do i=1,3
        do j=1,3
           R%L(i,j) = -sp*epsilon_three(i,j,k)
        end do
        R%L(i,i) = cp
     end do
     R%L(k,k) = 1
   end function rotation_canonical_cs
   elemental function rotation_canonical (phi, k) result (R)
     type(lorentz_transformation_t) :: R
     real(default), intent(in) :: phi
     integer, intent(in) :: k
     R = rotation_canonical_cs(cos(phi), sin(phi), k)
   end function rotation_canonical
 @ %def rotation_canonical_cs rotation_canonical
 @
 This is viewed as a method for the first argument (three-vector):
 Reconstruct the rotation that rotates it into the second three-vector.
 <<Lorentz: public functions>>=
   public :: rotation_to_2nd
 <<Lorentz: interfaces>>=
   interface rotation_to_2nd
      module procedure rotation_to_2nd_generic
      module procedure rotation_to_2nd_canonical
   end interface
 <<Lorentz: procedures>>=
   elemental function rotation_to_2nd_generic (p, q) result (R)
     type(lorentz_transformation_t) :: R
     type(vector3_t), intent(in) :: p, q
     type(vector3_t) :: a, b, ab
     real(default) :: ct, st
     if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then
        a = direction (p)
        b = direction (q)
        ab = cross_product(a,b)
        ct = a * b;  st = ab**1
        if (abs(st) > eps0) then
           R = rotation_generic_cs (ct, st, ab / st)
        else if (ct < 0) then
           R = space_reflection
        else
           R = identity
        end if
     else
        R = identity
     end if
   end function rotation_to_2nd_generic
 @ %def rotation_to_2nd_generic
 @
 The same for a canonical axis: The function returns the transformation that
 rotates the $k$-axis into the direction of $p$.
 <<Lorentz: procedures>>=
   elemental function rotation_to_2nd_canonical (k, p) result (R)
     type(lorentz_transformation_t) :: R
     integer, intent(in) :: k
     type(vector3_t), intent(in) :: p
     type(vector3_t) :: b, ab
     real(default) :: ct, st
     integer :: i, j
     if (any (abs (p%p) > 0)) then
        b = direction (p)
        ab%p = 0
        do i = 1, 3
           do j = 1, 3
              ab%p(j) = ab%p(j) + b%p(i) * epsilon_three(i,j,k)
           end do
        end do
        ct = b%p(k);  st = ab**1
        if (abs(st) > eps0) then
           R = rotation_generic_cs (ct, st, ab / st)
        else if (ct < 0) then
           R = space_reflection
        else
           R = identity
        end if
     else
        R = identity
     end if
   end function rotation_to_2nd_canonical
 
 @ %def rotation_to_2nd_canonical
 @
 \subsection{Composite Lorentz transformations}
 This function returns the transformation that, given a pair of vectors
 $p_{1,2}$, (a) boosts from the rest frame of the c.m. system (with
 invariant mass $m$) into the lab frame where $p_i$ are defined, and
 (b) turns the given axis (or the canonical vectors $\pm
 e_k$) in the rest frame into the directions of $p_{1,2}$ in the lab frame.
 Note that the energy components are not used; for a
 consistent result one should have $(p_1+p_2)^2 = m^2$.
 <<Lorentz: public functions>>=
   public :: transformation
 <<Lorentz: interfaces>>=
   interface transformation
      module procedure transformation_rec_generic
      module procedure transformation_rec_canonical
   end interface
 @ %def transformation
 <<Lorentz: procedures>>=
   elemental function transformation_rec_generic (axis, p1, p2, m) result (L)
     type(vector3_t), intent(in) :: axis
     type(vector4_t), intent(in) :: p1, p2
     real(default), intent(in) :: m
     type(lorentz_transformation_t) :: L
     L = boost (p1 + p2, m)
     L = L * rotation_to_2nd (axis, space_part (inverse (L) * p1))
   end function transformation_rec_generic
   elemental function transformation_rec_canonical (k, p1, p2, m) result (L)
     integer, intent(in) :: k
     type(vector4_t), intent(in) :: p1, p2
     real(default), intent(in) :: m
     type(lorentz_transformation_t) :: L
     L = boost (p1 + p2, m)
     L = L * rotation_to_2nd (k, space_part (inverse (L) * p1))
   end function transformation_rec_canonical
 @ %def transformation_rec_generic transformation_rec_canonical
 @
 \subsection{Applying Lorentz transformations}
 Multiplying vectors and Lorentz transformations is straightforward.
 <<Lorentz: interfaces>>=
   interface operator(*)
      module procedure prod_LT_vector4
      module procedure prod_LT_LT
      module procedure prod_vector4_LT
   end interface
 <<Lorentz: procedures>>=
   elemental function prod_LT_vector4 (L, p) result (np)
     type(vector4_t) :: np
     type(lorentz_transformation_t), intent(in) :: L
     type(vector4_t), intent(in) :: p
     np%p = matmul (L%L, p%p)
   end function prod_LT_vector4
   elemental function prod_LT_LT (L1, L2) result (NL)
     type(lorentz_transformation_t) :: NL
     type(lorentz_transformation_t), intent(in) :: L1,L2
     NL%L = matmul (L1%L, L2%L)
   end function prod_LT_LT
   elemental function prod_vector4_LT (p, L) result (np)
     type(vector4_t) :: np
     type(vector4_t), intent(in) :: p
     type(lorentz_transformation_t), intent(in) :: L
     np%p = matmul (p%p, L%L)
   end function prod_vector4_LT
 
 @ %def *
 @
 \subsection{Special Lorentz transformations}
 These routines have their application in the generation and extraction
 of angles in the phase-space sampling routine.  Since this part of the
 program is time-critical, we calculate the composition of
 transformations directly instead of multiplying rotations and boosts.
 
 This Lorentz transformation is the composition of a rotation by $\phi$
 around the $3$ axis, a rotation by $\theta$ around the $2$ axis, and a
 boost along the $3$ axis:
 \begin{equation}
   L = B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)
 \end{equation}
 Instead of the angles we provide sine and cosine.
 <<Lorentz: public functions>>=
   public :: LT_compose_r3_r2_b3
 <<Lorentz: procedures>>=
   elemental function LT_compose_r3_r2_b3 &
        (cp, sp, ct, st, beta_gamma) result (L)
     type(lorentz_transformation_t) :: L
     real(default), intent(in) :: cp, sp, ct, st, beta_gamma
     real(default) :: gamma
     if (abs(beta_gamma) < eps0) then
        L%L(0,0)  = 1
        L%L(1:,0) = 0
        L%L(0,1:) = 0
        L%L(1,1:) = [  ct*cp, -ct*sp, st ]
        L%L(2,1:) = [     sp,     cp,  zero ]
        L%L(3,1:) = [ -st*cp,  st*sp, ct ]
     else
        gamma = sqrt(1 + beta_gamma**2)
        L%L(0,0)  = gamma
        L%L(1,0)  = 0
        L%L(2,0)  = 0
        L%L(3,0)  = beta_gamma
        L%L(0,1:) = beta_gamma * [ -st*cp,  st*sp, ct ]
        L%L(1,1:) =              [  ct*cp, -ct*sp, st ]
        L%L(2,1:) =              [     sp,     cp, zero ]
        L%L(3,1:) = gamma      * [ -st*cp,  st*sp, ct ]
     end if
   end function LT_compose_r3_r2_b3
 
 @ %def LT_compose_r3_r2_b3
 @ Different ordering:
 \begin{equation}
   L = B_3(\beta\gamma)\,R_3(\phi)\,R_2(\theta)
 \end{equation}
 <<Lorentz: public functions>>=
   public :: LT_compose_r2_r3_b3
 <<Lorentz: procedures>>=
   elemental function LT_compose_r2_r3_b3 &
        (ct, st, cp, sp, beta_gamma) result (L)
     type(lorentz_transformation_t) :: L
     real(default), intent(in) :: ct, st, cp, sp, beta_gamma
     real(default) :: gamma
     if (abs(beta_gamma) < eps0) then
        L%L(0,0)  = 1
        L%L(1:,0) = 0
        L%L(0,1:) = 0
        L%L(1,1:) = [  ct*cp,    -sp,     st*cp ]
        L%L(2,1:) = [  ct*sp,     cp,     st*sp ]
        L%L(3,1:) = [ -st   ,   zero,     ct    ]
     else
        gamma = sqrt(1 + beta_gamma**2)
        L%L(0,0)  = gamma
        L%L(1,0)  = 0
        L%L(2,0)  = 0
        L%L(3,0)  = beta_gamma
        L%L(0,1:) = beta_gamma * [ -st   ,   zero,     ct    ]
        L%L(1,1:) =              [  ct*cp,    -sp,     st*cp ]
        L%L(2,1:) =              [  ct*sp,     cp,     st*sp ]
        L%L(3,1:) = gamma      * [ -st   ,   zero,     ct    ]
     end if
   end function LT_compose_r2_r3_b3
 
 @ %def LT_compose_r2_r3_b3
 @ This function returns the previous Lorentz transformation applied to
 an arbitrary four-momentum and extracts the space part of the result:
 \begin{equation}
   \vec n = [B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)\,p]_{\rm space\ part}
 \end{equation}
 The second variant applies if there is no rotation
 <<Lorentz: public functions>>=
   public :: axis_from_p_r3_r2_b3, axis_from_p_b3
 <<Lorentz: procedures>>=
   elemental function axis_from_p_r3_r2_b3 &
        (p, cp, sp, ct, st, beta_gamma) result (n)
     type(vector3_t) :: n
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: cp, sp, ct, st, beta_gamma
     real(default) :: gamma, px, py
     px = cp * p%p(1) - sp * p%p(2)
     py = sp * p%p(1) + cp * p%p(2)
     n%p(1) =  ct * px + st * p%p(3)
     n%p(2) = py
     n%p(3) = -st * px + ct * p%p(3)
     if (abs(beta_gamma) > eps0) then
        gamma = sqrt(1 + beta_gamma**2)
        n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma
     end if
   end function axis_from_p_r3_r2_b3
 
   elemental function axis_from_p_b3 (p, beta_gamma) result (n)
     type(vector3_t) :: n
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: beta_gamma
     real(default) :: gamma
     n%p = p%p(1:3)
     if (abs(beta_gamma) > eps0) then
        gamma = sqrt(1 + beta_gamma**2)
        n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma
     end if
   end function axis_from_p_b3
 
 @ %def axis_from_p_r3_r2_b3 axis_from_p_b3
 @
 \subsection{Special functions}
 The K\"all\'en function, mostly used for the phase space.
 This is equivalent to $\lambda(x,y,z)=x^2+y^2+z^2-2xy-2xz-2yz$.
 <<Lorentz: public functions>>=
   public :: lambda
 <<Lorentz: procedures>>=
   elemental function lambda (m1sq, m2sq, m3sq)
     real(default) :: lambda
     real(default), intent(in) :: m1sq, m2sq, m3sq
     lambda = (m1sq - m2sq - m3sq)**2 - 4*m2sq*m3sq
   end function lambda
 
 @ %def lambda
 @ Return a pair of head-to-head colliding momenta, given the collider
 energy, particle masses, and optionally the momentum of the
 c.m. system.
 <<Lorentz: public functions>>=
   public :: colliding_momenta
 <<Lorentz: procedures>>=
   function colliding_momenta (sqrts, m, p_cm) result (p)
     type(vector4_t), dimension(2) :: p
     real(default), intent(in) :: sqrts
     real(default), dimension(2), intent(in), optional :: m
     real(default), intent(in), optional :: p_cm
     real(default), dimension(2) :: dmsq
     real(default) :: ch, sh
     real(default), dimension(2) :: E0, p0
     integer, dimension(2), parameter :: sgn = [1, -1]
     if (abs(sqrts) < eps0) then
        call msg_fatal (" Colliding beams: sqrts is zero (please set sqrts)")
        p = vector4_null;  return
     else if (sqrts <= 0) then
        call msg_fatal (" Colliding beams: sqrts is negative")
        p = vector4_null;  return
     end if
     if (present (m)) then
        dmsq = sgn * (m(1)**2-m(2)**2)
        E0 = (sqrts + dmsq/sqrts) / 2
        if (any (E0 < m)) then
           call msg_fatal &
                (" Colliding beams: beam energy is less than particle mass")
           p = vector4_null;  return
        end if
        p0 = sgn * sqrt (E0**2 - m**2)
     else
        E0 = sqrts / 2
        p0 = sgn * E0
     end if
     if (present (p_cm)) then
        sh = p_cm / sqrts
        ch = sqrt (1 + sh**2)
        p = vector4_moving (E0 * ch + p0 * sh, E0 * sh + p0 * ch, 3)
     else
        p = vector4_moving (E0, p0, 3)
     end if
   end function colliding_momenta
 
 @ %def colliding_momenta
 @ This subroutine is for the purpose of numerical checks and
 comparisons.  The idea is to set a number to zero if it is numerically
 equivalent with zero.  The equivalence is established by comparing
 with a [[tolerance]] argument.  We implement this for vectors and
 transformations.
 <<Lorentz: public functions>>=
   public :: pacify
 <<Lorentz: interfaces>>=
   interface pacify
      module procedure pacify_vector3
      module procedure pacify_vector4
      module procedure pacify_LT
   end interface pacify
 
 <<Lorentz: procedures>>=
   elemental subroutine pacify_vector3 (p, tolerance)
     type(vector3_t), intent(inout) :: p
     real(default), intent(in) :: tolerance
     where (abs (p%p) < tolerance)  p%p = zero
   end subroutine pacify_vector3
 
   elemental subroutine pacify_vector4 (p, tolerance)
     type(vector4_t), intent(inout) :: p
     real(default), intent(in) :: tolerance
     where (abs (p%p) < tolerance)  p%p = zero
   end subroutine pacify_vector4
 
   elemental subroutine pacify_LT (LT, tolerance)
     type(lorentz_transformation_t), intent(inout) :: LT
     real(default), intent(in) :: tolerance
     where (abs (LT%L) < tolerance)  LT%L = zero
   end subroutine pacify_LT
 
 @ %def pacify
 @
 <<Lorentz: public>>=
   public :: vector_set_reshuffle
 <<Lorentz: procedures>>=
   subroutine vector_set_reshuffle (p1, list, p2)
     type(vector4_t), intent(in), dimension(:), allocatable :: p1
     integer, intent(in), dimension(:), allocatable :: list
     type(vector4_t), intent(out), dimension(:), allocatable :: p2
     integer :: n, n_p
     n_p = size (p1)
     if (size (list) /= n_p) return
     allocate (p2 (n_p))
     do n = 1, n_p
       p2(n) = p1(list(n))
     end do
   end subroutine vector_set_reshuffle
 
 @ %def vector_set_reshuffle
 @
 <<Lorentz: public>>=
   public :: vector_set_is_cms
 <<Lorentz: procedures>>=
   function vector_set_is_cms (p, n_in) result (is_cms)
     logical :: is_cms
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: n_in
     integer :: i
     type(vector4_t) :: p_sum
     p_sum%p = 0._default
     do i = 1, n_in
        p_sum = p_sum + p(i)
     end do
     is_cms = all (abs (p_sum%p(1:3)) < tiny_07)
   end function vector_set_is_cms
 
 @ %def vector_set_is_cms
 @
 <<Lorentz: public>>=
   public :: vector_set_is_lab
 <<Lorentz: procedures>>=
   function vector_set_is_lab (p, n_in) result (is_lab)
     logical :: is_lab
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: n_in
     is_lab = .not. vector_set_is_cms (p, n_in)
   end function vector_set_is_lab
 
 @ %def vector_set_is_lab
 @
 <<Lorentz: public>>=
   public :: vector4_write_set
 <<Lorentz: procedures>>=
   subroutine vector4_write_set (p, unit, show_mass, testflag, &
         check_conservation, ultra, n_in)
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_mass
     logical, intent(in), optional :: testflag, ultra
     logical, intent(in), optional :: check_conservation
     integer, intent(in), optional :: n_in
     logical :: extreme
     integer :: i, j
     real(default), dimension(0:3) :: p_tot
     character(len=7) :: fmt
     integer :: u
     logical :: yorn, is_test
     integer :: n
     extreme = .false.; if (present (ultra))  extreme = ultra
     is_test = .false.; if (present (testflag)) is_test = testflag
     u = given_output_unit (unit);  if (u < 0)  return
     n = 2; if (present (n_in)) n = n_in
     p_tot = 0
     yorn = .false.; if (present (check_conservation)) yorn = check_conservation
     do i = 1, size (p)
       if (yorn .and. i > n) then
          forall (j=0:3) p_tot(j) = p_tot(j) - p(i)%p(j)
       else
          forall (j=0:3) p_tot(j) = p_tot(j) + p(i)%p(j)
       end if
       call vector4_write (p(i), u, show_mass=show_mass, &
            testflag=testflag, ultra=ultra)
     end do
     if (extreme) then
        call pac_fmt (fmt, FMT_19, FMT_11, testflag)
     else
        call pac_fmt (fmt, FMT_19, FMT_15, testflag)
     end if
     if (is_test)  call pacify (p_tot, 1.E-9_default)
     if (.not. is_test) then
        write (u, "(A5)") 'Total: '
        write (u, "(1x,A,1x," // fmt // ")")    "E = ", p_tot(0)
        write (u, "(1x,A,3(1x," // fmt // "))") "P = ", p_tot(1:)
     end if
   end subroutine vector4_write_set
 
 @ %def vector4_write_set
 @
 <<Lorentz: public>>=
   public :: vector4_check_momentum_conservation
 <<Lorentz: procedures>>=
   subroutine vector4_check_momentum_conservation (p, n_in, unit, &
      abs_smallness, rel_smallness, verbose)
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: n_in
     integer, intent(in), optional :: unit
     real(default), intent(in), optional :: abs_smallness, rel_smallness
     logical, intent(in), optional :: verbose
     integer :: u, i
     type(vector4_t) :: psum_in, psum_out
     logical, dimension(0:3) :: p_diff
     logical :: verb
     u = given_output_unit (unit);  if (u < 0)  return
     verb = .false.; if (present (verbose)) verb = verbose
     psum_in = vector4_null
     do i = 1, n_in
        psum_in = psum_in + p(i)
     end do
     psum_out = vector4_null
     do i = n_in + 1, size (p)
        psum_out = psum_out + p(i)
     end do
     p_diff = vanishes (psum_in%p - psum_out%p, &
          abs_smallness = abs_smallness, rel_smallness = rel_smallness)
     if (.not. all (p_diff)) then
        call msg_warning ("Momentum conservation: FAIL", unit = u)
        if (verb) then
           write (u, "(A)") "Incoming:"
           call vector4_write (psum_in, u)
           write (u, "(A)") "Outgoing:"
           call vector4_write (psum_out, u)
        end if
     else
        if (verb) then
           write (u, "(A)") "Momentum conservation: CHECK"
        end if
     end if
   end subroutine vector4_check_momentum_conservation
 
 @ %def vector4_check_momentum_conservation
 @ This computes the quantities
 \begin{align*}
   \langle ij \rangle &= \sqrt{|S_{ij}|} e^{i\phi_{ij}},
   [ij] &= \sqrt{|S_{ij}|} e^{\i\tilde{\phi}_{ij}},
 \end{align*}
 with $S_{ij} = \left(p_i + p_j\right)^2$. The phase space factor
 $\phi_{ij}$ is determined by
 \begin{align*}
   \cos\phi_{ij} &= \frac{p_i^1p_j^+ - p_j^1p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}},
   \sin\phi_{ij} &= \frac{p_i^2p_j^+ - p_j^2p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}.
 \end{align*}
 After $\langle ij \rangle$ has been computed according to these
 formulae, $[ij]$ can be obtained by using the relation $S_{ij} =
 \langle ij \rangle [ji]$ and taking into account that $[ij] =
 -[ji]$. Thus, a minus-sign has to be applied.
 <<Lorentz: public>>=
   public :: spinor_product
 <<Lorentz: procedures>>=
   subroutine spinor_product (p1, p2, prod1, prod2)
     type(vector4_t), intent(in) :: p1, p2
     complex(default), intent(out) :: prod1, prod2
     real(default) :: sij
     complex(default) :: phase
     real(default) :: pp_1, pp_2
     pp_1 = p1%p(0) + p1%p(3)
     pp_2 = p2%p(0) + p2%p(3)
     sij = (p1+p2)**2
     phase = cmplx ((p1%p(1)*pp_2 - p2%p(1)*pp_1)/sqrt (sij*pp_1*pp_2), &
                    (p1%p(2)*pp_2 - p2%p(2)*pp_1)/sqrt (sij*pp_1*pp_2), &
                     default)
     !!! <ij>
     prod1 = sqrt (sij) * phase
     !!! [ij]
     if (abs(prod1) > 0) then
        prod2 = - sij / prod1
     else
        prod2 = 0
     end if
   end subroutine spinor_product
 
 @ %def spinor_product
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Collections of Lorentz Vectors}
 The [[phs_point]] type is a container for an array of Lorentz vectors.  This
 allows us to transfer Lorentz-vector arrays more freely, and to collect vector
 arrays of non-uniform size.
 <<[[phs_points.f90]]>>=
 <<File header>>
 
 module phs_points
 
 <<Use kinds>>
   use lorentz, only: vector4_t
   use lorentz, only: vector4_null
   use lorentz, only: vector4_write_set
   use lorentz, only: lorentz_transformation_t
   use lorentz, only: operator(==)
   use lorentz, only: operator(*)
   use lorentz, only: operator(**)
   use lorentz, only: sum
 
 <<Standard module head>>
 
 <<PHS points: public>>
 
 <<PHS points: types>>
 
 <<PHS points: interfaces>>
 
 contains
 
 <<PHS points: procedures>>
 
 end module phs_points
 @ %def phs_points
 @
 \subsection{PHS point definition}
 This is a trivial container for an array of momenta.  The main
 application is to store a non-uniform array of phase-space points.
 <<PHS points: public>>=
   public :: phs_point_t
 <<PHS points: types>>=
   type :: phs_point_t
      private
      type(vector4_t), dimension(:), allocatable :: p
   contains
   <<PHS points: phs point: TBP>>
   end type phs_point_t
 
 @ %def phs_point_t
 @
 \subsection{PHS point: basic tools}
 Output.  This is instrumented with options, which have to be
 provided by the caller.
 <<PHS points: phs point: TBP>>=
   procedure :: write => phs_point_write
 <<PHS points: procedures>>=
   subroutine phs_point_write (phs_point, unit, show_mass, testflag, &
       check_conservation, ultra, n_in)
     class(phs_point_t), intent(in) :: phs_point
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_mass
     logical, intent(in), optional :: testflag, ultra
     logical, intent(in), optional :: check_conservation
     integer, intent(in), optional :: n_in
     if (allocated (phs_point%p)) then
        call vector4_write_set (phs_point%p, &
             unit = unit, &
             show_mass = show_mass, &
             testflag = testflag, &
             check_conservation = check_conservation, &
             ultra = ultra, &
             n_in = n_in)
     end if
   end subroutine phs_point_write
 
 @ %def phs_point_write
 @ Non-intrinsic assignment
 <<PHS points: public>>=
   public :: assignment(=)
 <<PHS points: interfaces>>=
   interface assignment(=)
      module procedure phs_point_from_n
      module procedure phs_point_from_vector4
      module procedure vector4_from_phs_point
   end interface
 @ Initialize with zero momenta but fixed size
 <<PHS points: procedures>>=
   pure subroutine phs_point_from_n (phs_point, n_particles)
     type(phs_point_t), intent(out) :: phs_point
     integer, intent(in) :: n_particles
     allocate (phs_point%p (n_particles), source = vector4_null)
   end subroutine phs_point_from_n
 
 @ %def phs_point_init_from_n
 @ Transform from/to plain vector array
 <<PHS points: procedures>>=
   pure subroutine phs_point_from_vector4 (phs_point, p)
     type(phs_point_t), intent(out) :: phs_point
     type(vector4_t), dimension(:), intent(in) :: p
     phs_point%p = p
   end subroutine phs_point_from_vector4
 
   pure subroutine vector4_from_phs_point (p, phs_point)
     class(phs_point_t), intent(in) :: phs_point
     type(vector4_t), dimension(:), allocatable, intent(out) :: p
     if (allocated (phs_point%p))  p = phs_point%p
   end subroutine vector4_from_phs_point
 
 @ %def phs_point_from_vector4
 @ %def vector4_from_phs_point
 @ Query the size of the momentum array (assuming it is allocated).
 <<PHS points: public>>=
   public :: size
 <<PHS points: interfaces>>=
   interface size
      module procedure phs_point_size
   end interface size
 <<PHS points: procedures>>=
   pure function phs_point_size (phs_point) result (s)
     class(phs_point_t), intent(in) :: phs_point
     integer :: s
     if (allocated (phs_point%p)) then
        s = size (phs_point%p)
     else
        s = 0
     end if
   end function phs_point_size
   
 @ %def phs_point_size
 @ Equality, implemented only for valid points.
 <<PHS points: public>>=
   public :: operator(==)
 <<PHS points: interfaces>>=
   interface operator(==)
      module procedure phs_point_eq
   end interface operator(==)
 <<PHS points: procedures>>=
   elemental function phs_point_eq (phs_point_1, phs_point_2) result (flag)
     class(phs_point_t), intent(in) :: phs_point_1, phs_point_2
     logical :: flag
     if (allocated (phs_point_1%p) .and. (allocated (phs_point_2%p))) then
        flag = all (phs_point_1%p == phs_point_2%p)
     else
        flag = .false.
     end if
   end function phs_point_eq
 
 @ %def phs_point_eq
 @ Extract all momenta, as a method
 <<PHS points: phs point: TBP>>=
   procedure :: get => phs_point_get
 <<PHS points: procedures>>=
   pure function phs_point_get (phs_point) result (p)
     class(phs_point_t), intent(in) :: phs_point
     type(vector4_t), dimension(:), allocatable :: p
     if (allocated (phs_point%p)) then
        p = phs_point%p
     else
        allocate (p (0))
     end if
   end function phs_point_get
 
 @ %def phs_point_select
 @ Extract a subset of all momenta.
 <<PHS points: phs point: TBP>>=
   procedure :: select => phs_point_select
 <<PHS points: procedures>>=
   elemental function phs_point_select (phs_point, i) result (p)
     class(phs_point_t), intent(in) :: phs_point
     integer, intent(in) :: i
     type(vector4_t) :: p
     if (allocated (phs_point%p)) then
        p = phs_point%p(i)
     else
        p = vector4_null
     end if
   end function phs_point_select
 
 @ %def phs_point_select
 @ Return the invariant mass squared for a subset of momenta
 <<PHS points: phs point: TBP>>=
   procedure :: get_msq => phs_point_get_msq
 <<PHS points: procedures>>=
   pure function phs_point_get_msq (phs_point, iarray) result (msq)
     class(phs_point_t), intent(in) :: phs_point
     integer, dimension(:), intent(in) :: iarray
     real(default) :: msq
     if (allocated (phs_point%p)) then
        msq = (sum (phs_point%p(iarray)))**2
     else
        msq = 0
     end if
   end function phs_point_get_msq
 
 @ %def phs_point_get_msq
 
 @
 \subsection{Lorentz algebra pieces}
 Lorentz transformation.
 <<PHS points: public>>=
   public :: operator(*)
 <<PHS points: interfaces>>=
   interface operator(*)
      module procedure prod_LT_phs_point
   end interface operator(*)
 <<PHS points: procedures>>=
   elemental function prod_LT_phs_point (L, phs_point) result (phs_point_LT)
     type(lorentz_transformation_t), intent(in) :: L
     type(phs_point_t), intent(in) :: phs_point
     type(phs_point_t) :: phs_point_LT
     if (allocated (phs_point%p))  phs_point_LT%p = L * phs_point%p
   end function prod_LT_phs_point
 
 @ %def prod_LT_phs_point
 @ Compute momentum sum, analogous to the standard [[sum]] function
 (mask), and additionally using an index array.
 <<PHS points: public>>=
   public :: sum
 <<PHS points: interfaces>>=
   interface sum
      module procedure phs_point_sum
      module procedure phs_point_sum_iarray
   end interface sum
 <<PHS points: procedures>>=
   pure function phs_point_sum (phs_point, mask) result (p)
     class(phs_point_t), intent(in) :: phs_point
     logical, dimension(:), intent(in), optional :: mask
     type(vector4_t) :: p
     if (allocated (phs_point%p)) then
        p = sum (phs_point%p, mask)
     else
        p = vector4_null
     end if
   end function phs_point_sum
   
   pure function phs_point_sum_iarray (phs_point, iarray) result (p)
     class(phs_point_t), intent(in) :: phs_point
     integer, dimension(:), intent(in) :: iarray
     type(vector4_t) :: p
     logical, dimension(:), allocatable :: mask
     integer :: i
     allocate (mask (size (phs_point)), source = .false.)
     mask(iarray) = .true.
     p = sum (phs_point, mask)
   end function phs_point_sum_iarray
 
 @ %def phs_point_sum
 @
 \subsection{Methods for specific applications}
 Convenience method: compute the pair of energy fractions w.r.t.\ the
 specified beam energy.  We assume that the momenta represent a
 scattering process (two incoming particles) in the c.m.\ frame.
 <<PHS points: phs point: TBP>>=
   procedure :: get_x => phs_point_get_x
 <<PHS points: procedures>>=
   pure function phs_point_get_x (phs_point, E_beam) result (x) 
     class(phs_point_t), intent(in) :: phs_point
     real(default), dimension(2) :: x
     real(default), intent(in) :: E_beam
     x = phs_point%p(1:2)%p(0) / E_beam
   end function phs_point_get_x
 
 @ %def phs_point_get_x
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_points_ut.f90]]>>=
 <<File header>>
 
 module phs_points_ut
   use unit_tests
   use phs_points_uti
 
 <<Standard module head>>
 
 <<PHS points: public test>>
 
 contains
 
 <<PHS points: test driver>>
 
 end module phs_points_ut
 @ %def phs_points_ut
 @
 <<[[phs_points_uti.f90]]>>=
 <<File header>>
 
 module phs_points_uti
 
 <<Use kinds>>
   use phs_points
 
 <<Standard module head>>
 
 <<PHS points: test declarations>>
 
 contains
 
 <<PHS points: tests>>
 
 end module phs_points_uti
 @ %def phs_points_ut
 @ API: driver for the unit tests below.
 <<PHS points: public test>>=
   public :: phs_points_test
 <<PHS points: test driver>>=
   subroutine phs_points_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS points: execute tests>>
   end subroutine phs_points_test
 
 @ %def phs_points_test
 @
 \subsubsection{Splitting functions}
 <<PHS points: execute tests>>=
   call test (phs_points_1, "phs_points_1", &
        "Dummy test", &
        u, results)
 <<PHS points: test declarations>>=
   public :: phs_points_1
 <<PHS points: tests>>=
   subroutine phs_points_1 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: phs_points_1"
     write (u, "(A)")  "*   Purpose: none yet"
     write (u, "(A)")
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_points_1"
 
   end subroutine phs_points_1
 
 @ %def phs_points_1
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Special Physics functions}
 Here, we declare functions that are specific for the Standard Model,
 including QCD: fixed and running $\alpha_s$, Catani-Seymour
 dipole terms, loop functions, etc.
 
 To make maximum use of this, all functions, if possible, are declared
 elemental (or pure, if this is not possible).
 <<[[sm_physics.f90]]>>=
 <<File header>>
 
 module sm_physics
 
 <<Use kinds>>
   use io_units
   use constants
   use numeric_utils
   use diagnostics
   use physics_defs
   use lorentz
 
 <<Standard module head>>
 
 <<SM physics: public>>
 
 <<SM physics: parameters>>
 
 contains
 
 <<SM physics: procedures>>
 
 end module sm_physics
 @ %def sm_physics
 @
 \subsection{Running $\alpha_s$}
 @ Then we define the coefficients of the beta function of QCD (as a
 reference cf. the Particle Data Group), where $n_f$ is the number of
 active flavors in two different schemes:
 \begin{align}
   \beta_0 &=\; 11 - \frac23 n_f \\
   \beta_1 &=\; 51 - \frac{19}{3} n_f \\
   \beta_2 &=\; 2857 - \frac{5033}{9} n_f + \frac{325}{27} n_f^2
 \end{align}
 \begin{align}
   b_0 &=\; \frac{1}{12 \pi} \left( 11 C_A  - 2 n_f \right) \\
   b_1 &=\; \frac{1}{24 \pi^2} \left( 17 C_A^2 - 5 C_A n_f - 3 C_F n_f \right) \\
   b_2 &=\; \frac{1}{(4\pi)^3} \biggl( \frac{2857}{54} C_A^3 -
   \frac{1415}{54} * C_A^2 n_f - \frac{205}{18} C_A C_F n_f + C_F^2 n_f
   + \frac{79}{54} C_A n_f**2 + \frac{11}{9} C_F n_f**2 \biggr)
 \end{align}
+The functions [[sumQ2q]] and [[sumQ4q]] provide the sum of the squared
+and quartic electric charges of a number [[nf]] of active quark flavors.
 <<SM physics: public>>=
-  public :: beta0, beta1, beta2, coeff_b0, coeff_b1, coeff_b2
+  public :: beta0, beta1, beta2
+  public :: coeff_b0, coeff_b1, coeff_b2, coeffqed_b0, coeffqed_b1
+  public :: sumQ2q, sumQ4q
 <<SM physics: procedures>>=
   pure function beta0 (nf)
     real(default), intent(in) :: nf
     real(default) :: beta0
     beta0 = 11.0_default - two/three * nf
   end function beta0
 
   pure function beta1 (nf)
     real(default), intent(in) :: nf
     real(default) :: beta1
     beta1 = 51.0_default - 19.0_default/three * nf
   end function beta1
 
   pure function beta2 (nf)
     real(default), intent(in) :: nf
     real(default) :: beta2
     beta2 = 2857.0_default - 5033.0_default / 9.0_default * &
                     nf + 325.0_default/27.0_default * nf**2
   end function beta2
 
   pure function coeff_b0 (nf)
     real(default), intent(in) :: nf
     real(default) :: coeff_b0
     coeff_b0 = (11.0_default * CA - two * nf) / (12.0_default * pi)
   end function coeff_b0
 
   pure function coeff_b1 (nf)
     real(default), intent(in) :: nf
     real(default) :: coeff_b1
     coeff_b1 = (17.0_default * CA**2 - five * CA * nf - three * CF * nf) / &
                (24.0_default * pi**2)
   end function coeff_b1
 
   pure function coeff_b2 (nf)
     real(default), intent(in) :: nf
     real(default) :: coeff_b2
     coeff_b2 = (2857.0_default/54.0_default * CA**3 - &
                     1415.0_default/54.0_default * &
                     CA**2 * nf - 205.0_default/18.0_default * CA*CF*nf &
                     + 79.0_default/54.0_default * CA*nf**2 + &
                     11.0_default/9.0_default * CF * nf**2) / (four*pi)**3
   end function coeff_b2
 
+  pure function coeffqed_b0 (nf, nlep)
+    integer, intent(in) :: nf, nlep
+    real(default) :: n_lep, coeffqed_b0
+    n_lep = real(nlep, kind=default)
+    coeffqed_b0 = - (three * sumQ2q (nf) + n_lep) / (three*pi)
+  end function coeffqed_b0
+
+  pure function coeffqed_b1 (nf, nlep)
+    integer, intent(in) :: nf, nlep
+    real(default) :: n_lep, coeffqed_b1
+    n_lep = real(nlep, kind=default)
+    coeffqed_b1 = - (three * sumQ4q (nf) + n_lep) / (four*pi**2)
+  end function coeffqed_b1
+
+  pure function sumQ2q (nf)
+    integer, intent(in) :: nf
+    real(default) :: sumQ2q
+    select case (nf)
+    case (0)
+       sumQ2q = zero
+    case (1)
+       sumQ2q = 1.0_default/9.0_default
+    case (2)
+       sumQ2q = 5.0_default/9.0_default
+    case (3)
+       sumQ2q = 2.0_default/3.0_default
+    case (4)
+       sumQ2q = 10.0_default/9.0_default
+    case (5)
+       sumQ2q = 11.0_default/9.0_default
+    case (6:)
+       sumQ2q = 5.0_default/3.0_default
+    end select
+  end function sumQ2q
+
+  pure function sumQ4q (nf)
+    integer, intent(in) :: nf
+    real(default) :: sumQ4q
+    select case (nf)
+    case (0)
+       sumQ4q = zero
+    case (1)
+       sumQ4q = 1.0_default/81.0_default
+    case (2)
+       sumQ4q = 17.0_default/81.0_default
+    case (3)
+       sumQ4q = 2.0_default/9.0_default
+    case (4)
+       sumQ4q = 34.0_default/81.0_default
+    case (5)
+       sumQ4q = 35.0_default/81.0_default
+    case (6:)
+       sumQ4q = 17.0_default/27.0_default
+    end select
+  end function sumQ4q
+
 @ %def beta0 beta1 beta2
-@ %def coeff_b0 coeff_b1 coeff_b2
+@ %def coeff_b0 coeff_b1 coeff_b2 coeffqed_b0 coeffqed_b1
+@ %def sumQ2q sumQ4q
 @ There should be two versions of running $\alpha_s$, one which takes
 the scale and $\Lambda_{\text{QCD}}$ as input, and one which takes the
 scale and e.g. $\alpha_s(m_Z)$ as input. Here, we take the one which
 takes the QCD scale and scale as inputs from the PDG book.
 <<SM physics: public>>=
-  public :: running_as, running_as_lam
+  public :: running_as, running_as_lam, running_alpha, running_alpha_num
 <<SM physics: procedures>>=
   pure function running_as (scale, al_mz, mz, order, nf) result (ascale)
     real(default), intent(in) :: scale
     real(default), intent(in), optional :: al_mz, nf, mz
     integer, intent(in), optional :: order
     integer :: ord
     real(default) :: az, m_z, as_log, n_f, b0, b1, b2, ascale
     real(default) :: as0, as1
     if (present (mz)) then
        m_z = mz
     else
        m_z = MZ_REF
     end if
     if (present (order)) then
        ord = order
     else
        ord = 0
     end if
     if (present (al_mz)) then
        az = al_mz
     else
        az = ALPHA_QCD_MZ_REF
     end if
     if (present (nf)) then
        n_f = nf
     else
        n_f = 5
     end if
     b0 = coeff_b0 (n_f)
     b1 = coeff_b1 (n_f)
     b2 = coeff_b2 (n_f)
     as_log = one + b0 * az * log(scale**2/m_z**2)
     as0 = az / as_log
     as1 = as0 - as0**2 * b1/b0 * log(as_log)
     select case (ord)
     case (0)
        ascale = as0
     case (1)
        ascale = as1
     case (2)
        ascale = as1 + as0**3 * (b1**2/b0**2 * ((log(as_log))**2 - &
             log(as_log) + as_log - one) - b2/b0 * (as_log - one))
     case default
        ascale = as0
     end select
   end function running_as
 
   pure function running_as_lam (nf, scale, lambda, order) result (ascale)
     real(default), intent(in) :: nf, scale
     real(default), intent(in), optional :: lambda
     integer, intent(in), optional :: order
     real(default) :: lambda_qcd
     real(default) :: as0, as1, logmul, b0, b1, b2, ascale
     integer :: ord
     if (present (lambda)) then
        lambda_qcd = lambda
     else
        lambda_qcd = LAMBDA_QCD_REF
     end if
     if (present (order)) then
        ord = order
     else
        ord = 0
     end if
     b0 = beta0(nf)
     logmul = log(scale**2/lambda_qcd**2)
     as0 = four*pi / b0 / logmul
     if (ord > 0) then
        b1 = beta1(nf)
        as1 = as0 * (one - two* b1 / b0**2 * log(logmul) / logmul)
     end if
     select case (ord)
     case (0)
        ascale = as0
     case (1)
        ascale = as1
     case (2)
        b2 = beta2(nf)
        ascale = as1 + as0 * four * b1**2/b0**4/logmul**2 * &
             ((log(logmul) - 0.5_default)**2 + &
              b2*b0/8.0_default/b1**2 - five/four)
     case default
        ascale = as0
     end select
   end function running_as_lam
 
+  pure function running_alpha &
+       (scale, al_me, me, order, nf, nlep) result (ascale)
+    real(default), intent(in) :: scale
+    real(default), intent(in), optional :: al_me, me
+    integer, intent(in), optional :: order, nf, nlep
+    integer :: ord, n_f, n_lep
+    real(default) :: ae, m_e, a_log, b0, b1, ascale
+    real(default) :: a0, a1
+    if (present (me)) then
+       m_e = me
+    else
+       m_e = ME_REF
+    end if
+    if (present (order)) then
+       ord = order
+    else
+       ord = 0
+    end if
+    if (present (al_me)) then
+       ae = al_me
+    else
+       ae = ALPHA_QED_ME_REF
+    end if
+    if (present (nf)) then
+       n_f = nf
+    else
+       n_f = 5
+    end if
+    if (present (nlep)) then
+       n_lep = nlep
+    else
+       n_lep = 1
+    end if
+    b0 = coeffqed_b0 (n_f, n_lep)
+    b1 = coeffqed_b1 (n_f, n_lep)
+    a_log = one + b0 * ae * log(scale**2/m_e**2)
+    a0 = ae / a_log
+    a1 = ae / (a_log + ae * b1/b0 * &
+         log((a_log + ae * b1/b0)/(one + ae * b1/b0)))
+    select case (ord)
+    case (0)
+       ascale = a0
+    case (1)
+       ascale = a1
+    case default
+       ascale = a0
+    end select
+  end function running_alpha
+
+  pure function running_alpha_num &
+       (scale, al_me, me, order, nf, nlep) result (ascale)
+    real(default), intent(in) :: scale
+    real(default), intent(in), optional :: al_me, me
+    integer, intent(in), optional :: order, nf, nlep
+    integer, parameter :: n_steps = 20
+    integer :: ord, n_f, n_lep, k1
+    real(default), parameter :: sxth = 1._default/6._default
+    real(default) :: ae, ascale, m_e, log_q, dlr, &
+         b0, b1, xk0, xk1, xk2, xk3
+    if (present (order)) then
+       ord = order
+    else
+       ord = 0
+    end if
+    if (present (al_me)) then
+       ae = al_me
+    else
+       ae = ALPHA_QED_ME_REF
+    end if
+    if (present (me)) then
+       m_e = me
+    else
+       m_e = ME_REF
+    end if
+    if (present (nf)) then
+       n_f = nf
+    else
+       n_f = 5
+    end if
+    if (present (nlep)) then
+       n_lep = nlep
+    else
+       n_lep = 1
+    end if
+    ascale = ae
+    log_q = log (scale**2/m_e**2)
+    dlr = log_q / n_steps
+    b0 = coeffqed_b0 (n_f, n_lep)
+    b1 = coeffqed_b1 (n_f, n_lep)
+    ! ..Solution of the evolution equation depending on ORD
+    !   (fourth-order Runge-Kutta beyond the leading order)
+    select case (ord)
+    case (0)
+       ascale = ae / (one + b0 * ae * log_q)
+    case (1:)
+       do k1 = 1, n_steps
+          xk0 = dlr * beta_qed (ascale)
+          xk1 = dlr * beta_qed (ascale + 0.5 * xk0)
+          xk2 = dlr * beta_qed (ascale + 0.5 * xk1)
+          xk3 = dlr * beta_qed (ascale + xk2)
+          ascale = ascale + sxth * (xk0 + 2._default * xk1 + &
+               2._default * xk2 + xk3)
+       end do
+    end select
+  contains
+    pure function beta_qed (alpha)
+      real(default), intent(in) :: alpha
+      real(default) :: beta_qed
+      beta_qed = - alpha**2 * (b0 + alpha * b1)
+    end function beta_qed
+  end function running_alpha_num
+
 @ %def running_as
 @ %def running_as_lam
+@ %def running_alpha running_alpha_num
 @
 \subsection{Catani-Seymour Parameters}
 These are fundamental constants of the Catani-Seymour dipole formalism.
 Since the corresponding parameters for the gluon case depend on the
 number of flavors which is treated as an argument, there we do have
 functions and not parameters.
 \begin{equation}
   \gamma_q = \gamma_{\bar q} = \frac{3}{2} C_F \qquad \gamma_g =
   \frac{11}{6} C_A - \frac{2}{3} T_R N_f
 \end{equation}
 \begin{equation}
   K_q = K_{\bar q} = \left(  \frac{7}{2} - \frac{\pi^2}{6} \right) C_F \qquad
   K_g = \left( \frac{67}{18} - \frac{\pi^2}{6} \right) C_A -
   \frac{10}{9} T_R N_f
 \end{equation}
 <<SM physics: parameters>>=
   real(kind=default), parameter, public ::  gamma_q = three/two * CF, &
      k_q = (7.0_default/two - pi**2/6.0_default) * CF
 
 @ %def gamma_q
 @
 <<SM physics: public>>=
   public :: gamma_g, k_g
 <<SM physics: procedures>>=
   elemental function gamma_g (nf) result (gg)
      real(kind=default), intent(in) :: nf
      real(kind=default) :: gg
      gg = 11.0_default/6.0_default * CA - two/three * TR * nf
   end function gamma_g
 
   elemental function k_g (nf) result (kg)
      real(kind=default), intent(in) :: nf
      real(kind=default) :: kg
      kg = (67.0_default/18.0_default - pi**2/6.0_default) * CA - &
                 10.0_default/9.0_default * TR * nf
   end function k_g
 
 @ %def gamma_g
 @ %def k_g
 @
 \subsection{Mathematical Functions}
 The dilogarithm.  This simplified version is bound to double
 precision, and restricted to argument values less or equal to unity,
 so we do not need complex algebra.  The wrapper converts it to default
 precision (which is, of course, a no-op if double=default).
 
 The routine calculates the dilogarithm through mapping on the area
 where there is a quickly convergent series (adapted from an F77
 routine by Hans Kuijf, 1988): Map $x$ such that $x$ is not in the
 neighbourhood of $1$.  Note that $|z|=-\ln(1-x)$ is always smaller
 than $1.10$, but $\frac{1.10^{19}}{19!}{\rm Bernoulli}_{19}=2.7\times
 10^{-15}$.
 <<SM physics: public>>=
   public :: Li2
 <<SM physics: procedures>>=
   elemental function Li2 (x)
       use kinds, only: double
       real(default), intent(in) :: x
       real(default) :: Li2
       Li2 = real( Li2_double (real(x, kind=double)), kind=default)
   end function Li2
 
 @ %def: Li2
 @
 <<SM physics: procedures>>=
   elemental function Li2_double (x)  result (Li2)
     use kinds, only: double
     real(kind=double), intent(in) :: x
     real(kind=double) :: Li2
     real(kind=double), parameter :: pi2_6 = pi**2/6
     if (abs(1-x) < tiny_07) then
        Li2 = pi2_6
     else if (abs(1-x) <  0.5_double) then
        Li2 = pi2_6 - log(1-x) * log(x) - Li2_restricted (1-x)
     else if (abs(x) > 1.d0) then
        ! Li2 = 0
        ! call msg_bug (" Dilogarithm called outside of defined range.")
        !!! Reactivate Dilogarithm identity
         Li2 = -pi2_6 - 0.5_default * log(-x) * log(-x) - Li2_restricted (1/x)
     else
        Li2 = Li2_restricted (x)
     end if
   contains
     elemental function Li2_restricted (x) result (Li2)
       real(kind=double), intent(in) :: x
       real(kind=double) :: Li2
       real(kind=double) :: tmp, z, z2
       z = - log (1-x)
       z2 = z**2
 ! Horner's rule for the powers z^3 through z^19
       tmp = 43867._double/798._double
       tmp = tmp * z2 /342._double - 3617._double/510._double
       tmp = tmp * z2 /272._double + 7._double/6._double
       tmp = tmp * z2 /210._double - 691._double/2730._double
       tmp = tmp * z2 /156._double + 5._double/66._double
       tmp = tmp * z2 /110._double - 1._double/30._double
       tmp = tmp * z2 / 72._double + 1._double/42._double
       tmp = tmp * z2 / 42._double - 1._double/30._double
       tmp = tmp * z2 / 20._double + 1._double/6._double
 ! The first three terms of the power series
       Li2 = z2 * z * tmp / 6._double - 0.25_double * z2 + z
     end function Li2_restricted
   end function Li2_double
 
 @ %def Li2_double
 @
 \subsection{Loop Integrals}
 These functions appear in the calculation of the effective one-loop coupling of
 a (pseudo)scalar to a vector boson pair.
 <<SM physics: public>>=
   public :: faux
 <<SM physics: procedures>>=
   elemental function faux (x) result (y)
     real(default), intent(in) :: x
     complex(default) :: y
     if (1 <= x) then
        y = asin(sqrt(1/x))**2
     else
        y = - 1/4.0_default * (log((1 + sqrt(1 - x))/ &
             (1 - sqrt(1 - x))) - cmplx (0.0_default, pi, kind=default))**2
     end if
   end function faux
 
 @ %def faux
 @
 <<SM physics: public>>=
   public :: fonehalf
 <<SM physics: procedures>>=
   elemental function fonehalf (x) result (y)
     real(default), intent(in) :: x
     complex(default) :: y
     if (abs(x) < eps0) then
        y = 0
     else
        y = - 2.0_default * x * (1 + (1 - x) * faux(x))
     end if
   end function fonehalf
 
 @ %def fonehalf
 @
 <<SM physics: public>>=
   public :: fonehalf_pseudo
 <<SM physics: procedures>>=
   function fonehalf_pseudo (x) result (y)
     real(default), intent(in) :: x
     complex(default) :: y
     if (abs(x) < eps0) then
        y = 0
     else
        y = - 2.0_default * x * faux(x)
     end if
   end function fonehalf_pseudo
 
 @ %def fonehalf_pseudo
 @
 <<SM physics: public>>=
   public :: fone
 <<SM physics: procedures>>=
   elemental function fone (x) result  (y)
     real(default), intent(in) :: x
     complex(default) :: y
     if (abs(x) < eps0) then
        y = 2.0_default
     else
        y = 2.0_default + 3.0_default * x + &
             3.0_default * x * (2.0_default - x) * &
             faux(x)
     end if
   end function fone
 
 @ %def fone
 @
 <<SM physics: public>>=
   public :: gaux
 <<SM physics: procedures>>=
   elemental function gaux (x) result (y)
     real(default), intent(in) :: x
     complex(default) :: y
     if (1 <= x) then
        y = sqrt(x - 1) * asin(sqrt(1/x))
     else
        y = sqrt(1 - x) * (log((1 + sqrt(1 - x)) / &
             (1 - sqrt(1 - x))) - &
             cmplx (0.0_default, pi, kind=default)) / 2.0_default
     end if
   end function gaux
 
 @ %def gaux
 @
 <<SM physics: public>>=
   public :: tri_i1
 <<SM physics: procedures>>=
   elemental function tri_i1 (a,b) result (y)
     real(default), intent(in) :: a,b
     complex(default) :: y
     if (a < eps0 .or. b < eps0) then
        y = 0
     else
        y = a*b/2.0_default/(a-b) + a**2 * b**2/2.0_default/(a-b)**2 * &
             (faux(a) - faux(b)) + &
             a**2 * b/(a-b)**2 * (gaux(a) - gaux(b))
     end if
   end function tri_i1
 
 @ %def tri_i1
 @
 <<SM physics: public>>=
   public :: tri_i2
 <<SM physics: procedures>>=
   elemental function tri_i2 (a,b) result (y)
     real(default), intent(in) :: a,b
     complex(default) :: y
     if (a < eps0 .or. b < eps0) then
        y = 0
     else
        y = - a * b / 2.0_default / (a-b) * (faux(a) - faux(b))
     end if
   end function tri_i2
 
 @ %def tri_i2
 @
 \subsection{More on $\alpha_s$}
 These functions are for the running of the strong coupling constants,
 $\alpha_s$.
 <<SM physics: public>>=
   public :: run_b0
 <<SM physics: procedures>>=
   elemental function run_b0 (nf) result (bnull)
     integer, intent(in) :: nf
     real(default) :: bnull
     bnull = 33.0_default - 2.0_default * nf
   end function run_b0
 
 @ %def run_b0
 @
 <<SM physics: public>>=
   public :: run_b1
 <<SM physics: procedures>>=
   elemental function run_b1 (nf) result (bone)
       integer, intent(in) :: nf
       real(default) :: bone
       bone = 6.0_default * (153.0_default - 19.0_default * nf)/run_b0(nf)**2
   end function run_b1
 
 @ %def run_b1
 @
 <<SM physics: public>>=
   public :: run_aa
 <<SM physics: procedures>>=
   elemental function run_aa (nf) result (aaa)
       integer, intent(in) :: nf
       real(default) :: aaa
       aaa = 12.0_default * PI / run_b0(nf)
   end function run_aa
 
 @ %def run_aa
 @
 <<SM physics: pubic functions>>=
   public :: run_bb
 <<SM physics: procedures>>=
   elemental function run_bb (nf) result (bbb)
     integer, intent(in) :: nf
     real(default) :: bbb
     bbb = run_b1(nf) / run_aa(nf)
   end function run_bb
 
 @ %def run_bb
 @
 \subsection{Functions for Catani-Seymour dipoles}
 
 For the automated Catani-Seymour dipole subtraction, we need the
 following functions.
 
 <<SM physics: public>>=
   public :: ff_dipole
 <<SM physics: procedures>>=
   pure subroutine ff_dipole (v_ijk,y_ijk,p_ij,pp_k,p_i,p_j,p_k)
       type(vector4_t), intent(in) :: p_i, p_j, p_k
       type(vector4_t), intent(out) :: p_ij, pp_k
       real(kind=default), intent(out) :: y_ijk
       real(kind=default) :: z_i
       real(kind=default), intent(out) :: v_ijk
       z_i   = (p_i*p_k) / ((p_k*p_j) + (p_k*p_i))
       y_ijk = (p_i*p_j) / ((p_i*p_j) + (p_i*p_k) + (p_j*p_k))
       p_ij  = p_i + p_j - y_ijk/(1.0_default - y_ijk) * p_k
       pp_k  = (1.0/(1.0_default - y_ijk)) * p_k
       !!! We don't multiply by alpha_s right here:
       v_ijk = 8.0_default * PI * CF * &
            (2.0 / (1.0 - z_i*(1.0 - y_ijk)) - (1.0 + z_i))
   end subroutine ff_dipole
 
 @ %def ff_dipole
 @
 <<SM physics: public>>=
   public :: fi_dipole
 <<SM physics: procedures>>=
   pure subroutine fi_dipole (v_ija,x_ija,p_ij,pp_a,p_i,p_j,p_a)
      type(vector4_t), intent(in) :: p_i, p_j, p_a
      type(vector4_t), intent(out) :: p_ij, pp_a
      real(kind=default), intent(out) :: x_ija
      real(kind=default) :: z_i
      real(kind=default), intent(out) :: v_ija
      z_i   = (p_i*p_a) / ((p_a*p_j) + (p_a*p_i))
      x_ija = ((p_i*p_a) + (p_j*p_a) - (p_i*p_j)) &
           / ((p_i*p_a) + (p_j*p_a))
      p_ij  = p_i + p_j - (1.0_default - x_ija) * p_a
      pp_a  = x_ija * p_a
      !!! We don't not multiply by alpha_s right here:
      v_ija = 8.0_default * PI * CF * &
           (2.0 / (1.0 - z_i + (1.0 - x_ija)) - (1.0 + z_i)) / x_ija
   end subroutine fi_dipole
 
 @ %def fi_dipole
 @
 <<SM physics: public>>=
   public :: if_dipole
 <<SM physics: procedures>>=
   pure subroutine if_dipole (v_kja,u_j,p_aj,pp_k,p_k,p_j,p_a)
      type(vector4_t), intent(in) :: p_k, p_j, p_a
      type(vector4_t), intent(out) :: p_aj, pp_k
      real(kind=default), intent(out) :: u_j
      real(kind=default) :: x_kja
      real(kind=default), intent(out) :: v_kja
      u_j   = (p_a*p_j) / ((p_a*p_j) + (p_a*p_k))
      x_kja = ((p_a*p_k) + (p_a*p_j) - (p_j*p_k)) &
           / ((p_a*p_j) + (p_a*p_k))
      p_aj  = x_kja * p_a
      pp_k  = p_k + p_j - (1.0_default - x_kja) * p_a
      v_kja = 8.0_default * PI * CF * &
           (2.0 / (1.0 - x_kja + u_j) - (1.0 + x_kja)) / x_kja
   end subroutine if_dipole
 
 @ %def if_dipole
 @ This function depends on a variable number of final state particles
 whose kinematics all get changed by the initial-initial dipole insertion.
 <<SM physics: public>>=
   public :: ii_dipole
 <<SM physics: procedures>>=
   pure subroutine ii_dipole (v_jab,v_j,p_in,p_out,flag_1or2)
       type(vector4_t), dimension(:), intent(in) :: p_in
       type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out
       logical, intent(in) :: flag_1or2
       real(kind=default), intent(out) :: v_j
       real(kind=default), intent(out) :: v_jab
       type(vector4_t) :: p_a, p_b, p_j
       type(vector4_t) :: k, kk
       type(vector4_t) :: p_aj
       real(kind=default) :: x_jab
       integer :: i
       !!! flag_1or2 decides whether this a 12 or 21 dipole
       if (flag_1or2) then
          p_a = p_in(1)
          p_b = p_in(2)
       else
          p_b = p_in(1)
          p_a = p_in(2)
       end if
       !!! We assume that the unresolved particle has always the last
       !!! momentum
       p_j = p_in(size(p_in))
       x_jab = ((p_a*p_b) - (p_a*p_j) - (p_b*p_j)) / (p_a*p_b)
       v_j = (p_a*p_j) / (p_a * p_b)
       p_aj  = x_jab * p_a
       k     = p_a + p_b - p_j
       kk    = p_aj + p_b
       do i = 3, size(p_in)-1
          p_out(i) = p_in(i) - 2.0*((k+kk)*p_in(i))/((k+kk)*(k+kk)) * (k+kk) + &
               (2.0 * (k*p_in(i)) / (k*k)) * kk
       end do
       if (flag_1or2) then
          p_out(1) = p_aj
          p_out(2) = p_b
       else
          p_out(1) = p_b
          p_out(2) = p_aj
       end if
       v_jab = 8.0_default * PI * CF * &
            (2.0 / (1.0 - x_jab) - (1.0 + x_jab)) / x_jab
   end subroutine ii_dipole
 @ %def ii_dipole
 @
 \subsection{Distributions for integrated dipoles and such}
 Note that the following formulae are only meaningful for
 $0 \leq x \leq 1$.
 
 The Dirac delta distribution, modified for Monte-Carlo sampling,
 centered at $x=1-\frac{\epsilon}{2}$:
 
 <<SM physics: public>>=
   public :: delta
 <<SM physics: procedures>>=
   elemental function delta (x,eps) result (z)
      real(kind=default), intent(in) :: x, eps
      real(kind=default) :: z
      if (x > one - eps) then
         z = one / eps
      else
         z = 0
      end if
   end function delta
 
 @ %def delta
 @ The $+$-distribution, $P_+(x) = \left( \frac{1}{1-x}\right)_+$, for
 the regularization of soft-collinear singularities. The constant part
 for the Monte-Carlo sampling is the integral over the splitting
 function divided by the weight for the WHIZARD numerical integration
 over the interval.
 <<SM physics: public>>=
   public :: plus_distr
 <<SM physics: procedures>>=
   elemental function plus_distr (x,eps) result (plusd)
      real(kind=default), intent(in) :: x, eps
      real(kind=default) :: plusd
      if (x > one - eps) then
         plusd = log(eps) / eps
      else
         plusd = one / (one - x)
      end if
   end function plus_distr
 
 @ %def plus_distr
 @ The splitting function in $D=4$ dimensions, regularized as
 $+$-distributions if necessary:
 \begin{align}
   P^{qq} (x) = P^{\bar q\bar q} (x) &= \; C_F \cdot \left( \frac{1 +
       x^2}{1-x} \right)_+ \\
   P^{qg} (x) = P^{\bar q g}     (x) &= \; C_F  \cdot \frac{1 + (1-x)^2}{x}\\
   P^{gq} (x) = P^{g \bar q}     (x) &= \; T_R \cdot \left[ x^2 + (1-x)^2
   \right] \\
   P^{gg} (x) &= \; 2 C_A \biggl[ \left( \frac{1}{1-x} \right)_+ +
                  \frac{1-x}{x} - 1 + x(1-x) \biggl] \notag{}\\
              &\quad + \delta(1-x) \left( \frac{11}{6} C_A -
                                           \frac{2}{3} N_f T_R \right)
 \end{align}
 Since the number of flavors summed over in the gluon splitting
 function might depend on the physics case under consideration, it is
 implemented as an input variable.
 <<SM physics: public>>=
   public :: pqq
 <<SM physics: procedures>>=
   elemental function pqq (x,eps) result (pqqx)
      real(kind=default), intent(in) :: x, eps
      real(kind=default) :: pqqx
      if (x > (1.0_default - eps)) then
         pqqx = (eps - one) / two + two * log(eps) / eps - &
              three * (eps - one) / eps / two
      else
         pqqx = (one + x**2) / (one - x)
      end if
      pqqx = CF * pqqx
   end function pqq
 
 @ %def pqq
 @
 <<SM physics: public>>=
   public :: pgq
 <<SM physics: procedures>>=
   elemental function pgq (x) result (pgqx)
      real(kind=default), intent(in) :: x
      real(kind=default) :: pgqx
      pgqx = TR * (x**2 + (one - x)**2)
   end function pgq
 
 @ %def pgq
 @
 <<SM physics: public>>=
   public :: pqg
 <<SM physics: procedures>>=
   elemental function pqg (x) result (pqgx)
      real(kind=default), intent(in) :: x
      real(kind=default) :: pqgx
      pqgx = CF * (one + (one - x)**2) / x
   end function pqg
 
 @ %def pqg
 @
 <<SM physics: public>>=
   public :: pgg
 <<SM physics: procedures>>=
   elemental function pgg (x, nf, eps) result (pggx)
     real(kind=default), intent(in) :: x, nf, eps
     real(kind=default) :: pggx
     pggx = two * CA * ( plus_distr (x, eps) + (one-x)/x - one + &
                    x*(one-x)) + delta (x, eps)  * gamma_g(nf)
   end function pgg
 
 @ %def pgg
 @ For the $qq$ and $gg$ cases, there exist ``regularized'' versions of
 the splitting functions:
 \begin{align}
   P^{qq}_{\text{reg}} (x) &= - C_F \cdot (1 + x) \\
   P^{gg}_{\text{reg}} (x) &= 2 C_A \left[ \frac{1-x}{x} - 1 + x(1-x) \right]
 \end{align}
 <<SM physics: public>>=
   public :: pqq_reg
 <<SM physics: procedures>>=
   elemental function pqq_reg (x) result (pqqregx)
      real(kind=default), intent(in) :: x
      real(kind=default) :: pqqregx
      pqqregx = - CF * (one + x)
   end function pqq_reg
 
 @ %def pqq_reg
 @
 <<SM physics: public>>=
   public :: pgg_reg
 <<SM physics: procedures>>=
   elemental function pgg_reg (x) result (pggregx)
      real(kind=default), intent(in) :: x
      real(kind=default) :: pggregx
      pggregx = two * CA * ((one - x)/x - one + x*(one - x))
   end function pgg_reg
 
 @ %def pgg_reg
 @ Here, we collect the expressions needed for integrated
 Catani-Seymour dipoles, and the so-called flavor kernels. We always
 distinguish between the ``ordinary'' Catani-Seymour version, and the
 one including a phase-space slicing parameter, $\alpha$.
 
 The standard flavor kernels $\overline{K}^{ab}$ are:
 \begin{align}
   \overline{K}^{qg} (x) = \overline{K}^{\bar q g} (x) & = \;
   P^{qg} (x) \log ((1-x)/x) + CF \times x \\
   %%%
   \overline{K}^{gq} (x) = \overline{K}^{g \bar q} (x) & = \;
   P^{gq} (x) \log ((1-x)/x) + TR \times 2x(1-x) \\
   %%%
   \overline{K}^{qq} &=\; C_F \biggl[ \left( \frac{2}{1-x} \log
   \frac{1-x}{x} \right)_+ - (1+x) \log ((1-x)/x)  +
   (1-x) \biggr] \notag{}\\
                     &\quad - (5 - \pi^2) \cdot C_F \cdot \delta(1-x) \\
   %%%
   \overline{K}^{gg} &=\; 2 C_A \biggl[ \left( \frac{1}{1-x} \log
     \frac{1-x}{x} \right)_+ + \left( \frac{1-x}{x} - 1 + x(1-x)
   \right) \log((1-x)/x) \biggr] \notag{}\\
                     &\quad - \delta(1-x) \biggl[ \left(
     \frac{50}{9} - \pi^2 \right) C_A - \frac{16}{9} T_R N_f \biggr]
 \end{align}
 <<SM physics: public>>=
   public :: kbarqg
 <<SM physics: procedures>>=
   function kbarqg (x) result (kbarqgx)
     real(kind=default), intent(in) :: x
     real(kind=default) :: kbarqgx
     kbarqgx = pqg(x) * log((one-x)/x) + CF * x
   end function kbarqg
 
 @ %def kbarqg
 @
 <<SM physics: public>>=
   public :: kbargq
 <<SM physics: procedures>>=
   function kbargq (x) result (kbargqx)
     real(kind=default), intent(in) :: x
     real(kind=default) :: kbargqx
     kbargqx = pgq(x) * log((one-x)/x) + two * TR * x * (one - x)
   end function kbargq
 
 @ %def kbarqg
 @
 <<SM physics: public>>=
   public :: kbarqq
 <<SM physics: procedures>>=
   function kbarqq (x,eps) result (kbarqqx)
     real(kind=default), intent(in) :: x, eps
     real(kind=default) :: kbarqqx
     kbarqqx = CF*(log_plus_distr(x,eps) - (one+x) * log((one-x)/x) + (one - &
          x) - (five - pi**2) * delta(x,eps))
   end function kbarqq
 
 @ %def kbarqq
 @
 <<SM physics: public>>=
   public :: kbargg
 <<SM physics: procedures>>=
   function kbargg (x,eps,nf) result (kbarggx)
     real(kind=default), intent(in) :: x, eps, nf
     real(kind=default) :: kbarggx
     kbarggx = CA * (log_plus_distr(x,eps) + two * ((one-x)/x - one + &
                          x*(one-x) * log((1-x)/x))) - delta(x,eps) * &
                          ((50.0_default/9.0_default - pi**2) * CA - &
                          16.0_default/9.0_default * TR * nf)
   end function kbargg
 
 @ %def kbargg
 @ The $\tilde{K}$ are used when two identified hadrons participate:
 \begin{equation}
     \tilde{K}^{ab} (x) = P^{ab}_{\text{reg}} (x) \cdot \log (1-x) +
     \delta^{ab} \mathbf{T}_a^2 \biggl[ \left( \frac{2}{1-x} \log (1-x)
     \right)_+ - \frac{\pi^2}{3} \delta(1-x) \biggr]
 \end{equation}
 
 <<SM physics: public>>=
   public :: ktildeqq
 <<SM physics: procedures>>=
   function ktildeqq (x,eps) result (ktildeqqx)
     real(kind=default), intent(in) :: x, eps
     real(kind=default) :: ktildeqqx
     ktildeqqx = pqq_reg (x) * log(one-x) + CF * ( - log2_plus_distr (x,eps) &
                           - pi**2/three * delta(x,eps))
   end function ktildeqq
 
 @ %def ktildeqq
 @
 <<SM physics: public>>=
   public :: ktildeqg
 <<SM physics: procedures>>=
   function ktildeqg (x,eps) result (ktildeqgx)
     real(kind=default), intent(in) :: x, eps
     real(kind=default) :: ktildeqgx
     ktildeqgx = pqg (x) * log(one-x)
   end function ktildeqg
 
 @ %def ktildeqg
 @
 <<SM physics: public>>=
   public :: ktildegq
 <<SM physics: procedures>>=
   function ktildegq (x,eps) result (ktildegqx)
     real(kind=default), intent(in) :: x, eps
     real(kind=default) :: ktildegqx
     ktildegqx = pgq (x) * log(one-x)
   end function ktildegq
 
 @ %def ktildeqg
 @
 <<SM physics: public>>=
   public :: ktildegg
 <<SM physics: procedures>>=
   function ktildegg (x,eps) result (ktildeggx)
     real(kind=default), intent(in) :: x, eps
     real(kind=default) :: ktildeggx
     ktildeggx = pgg_reg (x) * log(one-x) + CA * ( - &
        log2_plus_distr (x,eps) - pi**2/three * delta(x,eps))
   end function ktildegg
 
 @ %def ktildegg
 @ The insertion operator might not be necessary for a GOLEM interface
 but is demanded by the Les Houches NLO accord. It is a
 three-dimensional array, where the index always gives the inverse
 power of the DREG expansion parameter, $\epsilon$.
 <<SM physics: public>>=
   public :: insert_q
 <<SM physics: procedures>>=
   pure function insert_q ()
     real(kind=default), dimension(0:2) :: insert_q
     insert_q(0) = gamma_q + k_q - pi**2/three * CF
     insert_q(1) = gamma_q
     insert_q(2) = CF
   end function insert_q
 
 @ %def insert_q
 @
 <<SM physics: public>>=
   public :: insert_g
 <<SM physics: procedures>>=
   pure function insert_g (nf)
     real(kind=default), intent(in) :: nf
     real(kind=default), dimension(0:2) :: insert_g
     insert_g(0) = gamma_g (nf) + k_g (nf) - pi**2/three * CA
     insert_g(1) = gamma_g (nf)
     insert_g(2) = CA
   end function insert_g
 
 @ %def insert_g
 @ For better convergence, one can exclude regions of phase space with
 a slicing parameter from the dipole subtraction procedure. First of
 all, the $K$ functions get modified:
 \begin{equation}
   K_i (\alpha) = K_i - \mathbf{T}_i^2 \log^2 \alpha + \gamma_i (
   \alpha - 1 - \log\alpha)
 \end{equation}
 <<SM physics: public>>=
   public :: k_q_al, k_g_al
 <<SM physics: procedures>>=
   pure function k_q_al (alpha)
     real(kind=default), intent(in) :: alpha
     real(kind=default) :: k_q_al
     k_q_al = k_q - CF * (log(alpha))**2 + gamma_q * &
                       (alpha - one - log(alpha))
   end function k_q_al
 
   pure function k_g_al (alpha, nf)
     real(kind=default), intent(in) :: alpha, nf
     real(kind=default) :: k_g_al
     k_g_al = k_g (nf) - CA * (log(alpha))**2 + gamma_g (nf) * &
                      (alpha - one - log(alpha))
   end function k_g_al
 
 @ %def k_q_al
 @ %def k_g_al
 @ The $+$-distribution, but with a phase-space slicing parameter,
 $\alpha$,  $P_{1-\alpha}(x) = \left( \frac{1}{1-x}
 \right)_{1-x}$. Since we need the fatal error message here, this
 function cannot be elemental.
 <<SM physics: public>>=
   public :: plus_distr_al
 <<SM physics: procedures>>=
   function plus_distr_al (x,alpha,eps) result (plusd_al)
      real(kind=default), intent(in) :: x,  eps, alpha
      real(kind=default) :: plusd_al
      if ((one - alpha) >= (one - eps)) then
         plusd_al = zero
         call msg_fatal ('sm_physics, plus_distr_al: alpha and epsilon chosen wrongly')
      elseif (x < (1.0_default - alpha)) then
         plusd_al = 0
      else if (x > (1.0_default - eps)) then
         plusd_al = log(eps/alpha)/eps
      else
         plusd_al = one/(one-x)
      end if
    end function plus_distr_al
 
 @ %def plus_distr_al
 @ Introducing phase-space slicing parameters, these standard flavor
 kernels $\overline{K}^{ab}$ become:
 \begin{align}
   \overline{K}^{qg}_\alpha (x) = \overline{K}^{\bar q g}_\alpha (x) & = \;
   P^{qg} (x) \log (\alpha (1-x)/x) + C_F \times x \\
   %%%
   \overline{K}^{gq}_\alpha (x) = \overline{K}^{g \bar q}_\alpha (x) & = \;
   P^{gq} (x) \log (\alpha (1-x)/x) + T_R \times 2x(1-x) \\
   %%%
   \overline{K}^{qq}_\alpha &=
       C_F  (1 - x) + P^{qq}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x}
       \notag{}\\           &\quad
       + C_F \delta (1 - x) \log^2 \alpha
       + C_F \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ \notag{}\\
                            &\quad
       - \left( \gamma_q + K_q(\alpha) - \frac56 \pi^2 C_F \right) \cdot
       \delta(1-x) \; C_F \Bigl[ + \frac{2}{1-x}  \log \left(
       \frac{\alpha (2-x)}{1+\alpha-x} \right)
       - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log
       \frac{2-x}{1-x} \right) \Bigr] \\
   %%%
   \overline{K}^{gg}_\alpha &=\;
        P^{gg}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x}
       + C_A \delta (1 - x) \log^2 \alpha  \notag{}\\
                            &\quad
       + C_A \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+
        - \left( \gamma_g + K_g(\alpha) - \frac56 \pi^2 C_A \right) \cdot
        \delta(1-x) \; C_A \Bigl[ + \frac{2}{1-x}  \log \left(
        \frac{\alpha (2-x)}{1+\alpha-x} \right)
       - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log
       \frac{2-x}{1-x} \right) \Bigr]
 \end{align}
 <<SM physics: public>>=
   public :: kbarqg_al
 <<SM physics: procedures>>=
   function kbarqg_al (x,alpha,eps) result (kbarqgx)
     real(kind=default), intent(in) :: x, alpha, eps
     real(kind=default) :: kbarqgx
     kbarqgx = pqg (x) * log(alpha*(one-x)/x) + CF * x
   end function kbarqg_al
 @ %def kbarqg_al
 @
 
 <<SM physics: public>>=
   public :: kbargq_al
 <<SM physics: procedures>>=
   function kbargq_al (x,alpha,eps) result (kbargqx)
     real(kind=default), intent(in) :: x, alpha, eps
     real(kind=default) :: kbargqx
     kbargqx = pgq (x) * log(alpha*(one-x)/x) + two * TR * x * (one-x)
   end function kbargq_al
 @ %def kbargq_al
 @
 
 <<SM physics: public>>=
   public :: kbarqq_al
 <<SM physics: procedures>>=
   function kbarqq_al (x,alpha,eps) result (kbarqqx)
      real(kind=default), intent(in) :: x, alpha, eps
      real(kind=default) :: kbarqqx
      kbarqqx = CF * (one - x) + pqq_reg(x) * log(alpha*(one-x)/x) &
               + CF * log_plus_distr(x,eps) &
              - (gamma_q + k_q_al(alpha) - CF * &
               five/6.0_default  * pi**2 - CF * (log(alpha))**2) * &
               delta(x,eps) + &
               CF * two/(one -x)*log(alpha*(two-x)/(one+alpha-x))
      if (x < (one-alpha)) then
         kbarqqx = kbarqqx - CF * two/(one-x) * log((two-x)/(one-x))
      end if
   end function kbarqq_al
 
 @ %def kbarqq_al
 <<SM physics: public>>=
   public :: kbargg_al
 <<SM physics: procedures>>=
   function kbargg_al (x,alpha,eps,nf) result (kbarggx)
      real(kind=default), intent(in) :: x, alpha, eps, nf
      real(kind=default) :: kbarggx
      kbarggx = pgg_reg(x) * log(alpha*(one-x)/x) &
               + CA * log_plus_distr(x,eps) &
              - (gamma_g(nf) + k_g_al(alpha,nf) - CA * &
               five/6.0_default  * pi**2 - CA * (log(alpha))**2) * &
               delta(x,eps) + &
               CA * two/(one -x)*log(alpha*(two-x)/(one+alpha-x))
      if (x < (one-alpha)) then
         kbarggx = kbarggx - CA * two/(one-x) * log((two-x)/(one-x))
      end if
   end function kbargg_al
 
 @ %def kbargg_al
 @ The $\tilde{K}$ flavor kernels in the presence of a phase-space slicing
 parameter, are:
 \begin{equation}
   \tilde{K}^{ab} (x,\alpha) = P^{qq, \text{reg}} (x)
   \log\frac{1-x}{\alpha} + ..........
 \end{equation}
 <<SM physics: public>>=
   public :: ktildeqq_al
 <<SM physics: procedures>>=
   function ktildeqq_al (x,alpha,eps) result (ktildeqqx)
     real(kind=default), intent(in) :: x, eps, alpha
     real(kind=default) :: ktildeqqx
     ktildeqqx = pqq_reg(x) * log((one-x)/alpha) + CF*( &
          - log2_plus_distr_al(x,alpha,eps) - Pi**2/three * delta(x,eps) &
          + (one+x**2)/(one-x) * log(min(one,(alpha/(one-x)))) &
          + two/(one-x) * log((one+alpha-x)/alpha))
     if (x > (one-alpha)) then
        ktildeqqx = ktildeqqx - CF*two/(one-x)*log(two-x)
     end if
   end function ktildeqq_al
 
 @ %def ktildeqq_al
 @ This is a logarithmic $+$-distribution, $\left(
   \frac{\log((1-x)/x)}{1-x} \right)_+$. For the sampling, we need the
 integral over this function over the incomplete sampling interval
 $[0,1-\epsilon]$, which is $\log^2(x) + 2 Li_2(x) -
 \frac{\pi^2}{3}$. As this function is negative definite for $\epsilon
 > 0.1816$, we take a hard upper limit for that sampling parameter,
 irrespective of the fact what the user chooses.
 <<SM physics: public>>=
   public :: log_plus_distr
 <<SM physics: procedures>>=
   function log_plus_distr (x,eps) result (lpd)
      real(kind=default), intent(in) :: x, eps
      real(kind=default) :: lpd, eps2
      eps2 = min (eps, 0.1816_default)
      if (x > (1.0_default - eps2)) then
         lpd = ((log(eps2))**2 + two*Li2(eps2) - pi**2/three)/eps2
      else
         lpd = two*log((one-x)/x)/(one-x)
      end if
   end function log_plus_distr
 
 @ %def log_plus_distr
 @ Logarithmic $+$-distribution, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_+$.
 <<SM physics: public>>=
   public :: log2_plus_distr
 <<SM physics: procedures>>=
   function log2_plus_distr (x,eps) result (lpd)
       real(kind=default), intent(in) :: x, eps
       real(kind=default) :: lpd
       if (x > (1.0_default - eps)) then
          lpd = - (log(eps))**2/eps
       else
          lpd = two*log(one/(one-x))/(one-x)
       end if
   end function log2_plus_distr
 
 @ %def log2_plus_distr
 @ Logarithmic $+$-distribution with phase-space slicing parameter, $2
 \left( \frac{\log(1/(1-x))}{1-x} \right)_{1-\alpha}$.
 <<SM physics: public>>=
   public :: log2_plus_distr_al
 <<SM physics: procedures>>=
   function log2_plus_distr_al (x,alpha,eps) result (lpd_al)
     real(kind=default), intent(in) :: x, eps, alpha
     real(kind=default) :: lpd_al
     if ((one - alpha) >= (one - eps)) then
        lpd_al = zero
        call msg_fatal ('alpha and epsilon chosen wrongly')
     elseif (x < (one - alpha)) then
        lpd_al = 0
     elseif (x > (1.0_default - eps)) then
        lpd_al = - ((log(eps))**2 - (log(alpha))**2)/eps
     else
        lpd_al = two*log(one/(one-x))/(one-x)
     end if
   end function log2_plus_distr_al
 
 @ %def log2_plus_distr_al
 @
 \subsection{Splitting Functions}
 @ Analogue to the regularized distributions of the last subsection, we
 give here the unregularized splitting functions, relevant for the parton
 shower algorithm. We can use this unregularized version since there will
 be a cut-off $\epsilon$ that ensures that $\{z,1-z\}>\epsilon(t)$. This
 cut-off seperates resolvable from unresolvable emissions.
 
 [[p_xxx]] are the kernels that are summed over helicity:
 <<SM physics: public>>=
   public :: p_qqg
   public :: p_gqq
   public :: p_ggg
 @ $q\to q g$
 <<SM physics: procedures>>=
   elemental function p_qqg (z) result (P)
     real(default), intent(in) :: z
     real(default) :: P
     P = CF * (one + z**2) / (one - z)
   end function p_qqg
 @ $g\to q \bar{q}$
 <<SM physics: procedures>>=
   elemental function p_gqq (z) result (P)
     real(default), intent(in) :: z
     real(default) :: P
     P = TR * (z**2 + (one - z)**2)
   end function p_gqq
 @ $g\to g g$
 <<SM physics: procedures>>=
   elemental function p_ggg (z) result (P)
     real(default), intent(in) :: z
     real(default) :: P
     P = NC * ((one - z) / z + z / (one - z) + z * (one - z))
   end function p_ggg
 
 @ %def p_qqg p_gqq p_ggg
 @ Analytically integrated splitting kernels:
 <<SM physics: public>>=
   public :: integral_over_p_qqg
   public :: integral_over_p_gqq
   public :: integral_over_p_ggg
 <<SM physics: procedures>>=
   pure function integral_over_p_qqg (zmin, zmax) result (integral)
     real(default), intent(in) :: zmin, zmax
     real(default) :: integral
     integral = (two / three) * (- zmax**2 + zmin**2 - &
          two * (zmax - zmin) + four * log((one - zmin) / (one - zmax)))
   end function integral_over_p_qqg
 
   pure function integral_over_p_gqq (zmin, zmax) result (integral)
     real(default), intent(in) :: zmin, zmax
     real(default) :: integral
     integral = 0.5_default * ((two / three) * &
          (zmax**3 - zmin**3) - (zmax**2 - zmin**2) + (zmax - zmin))
   end function integral_over_p_gqq
 
   pure function integral_over_p_ggg (zmin, zmax) result (integral)
     real(default), intent(in) :: zmin, zmax
     real(default) :: integral
     integral = three * ((log(zmax) - two * zmax - &
          log(one - zmax) + zmax**2 / two - zmax**3 / three) - &
          (log(zmin) - zmin - zmin - log(one - zmin) + zmin**2 &
          / two - zmin**3 / three) )
   end function integral_over_p_ggg
 
 @ %def integral_over_p_gqq integral_over_p_ggg integral_over_p_qqg
 @ We can also use (massless) helicity dependent splitting functions:
 <<SM physics: public>>=
   public :: p_qqg_pol
 @ $q_a\to q_b g_c$, the helicity of the quark is not changed by gluon
 emission and the gluon is preferably polarized in the branching plane
 ($l_c=1$):
 <<SM physics: procedures>>=
   elemental function p_qqg_pol (z, l_a, l_b, l_c) result (P)
     real(default), intent(in) :: z
     integer, intent(in) :: l_a, l_b, l_c
     real(default) :: P
     if (l_a /= l_b) then
        P = zero
        return
     end if
     if (l_c == -1) then
        P = one - z
     else
        P = (one + z)**2 / (one - z)
     end if
     P = P * CF
   end function p_qqg_pol
 
 @
 \subsection{Top width}
 In order to produce sensible results, the widths have to be recomputed
 for each parameter and order.
 We start with the LO-expression for the top width given by the decay
 $t\,\to\,W^+,b$, cf. [[doi:10.1016/0550-3213(91)90530-B]]:\\
 The analytic formula given there is
 \begin{equation*}
   \Gamma = \frac{G_F m_t^2}{16\sqrt{2}\pi}
   \left[\mathcal{F}_0(\varepsilon, \xi^{-1/2}) -
     \frac{2\alpha_s}{3\pi} \mathcal{F}_1 (\varepsilon, \xi^{-1/2})\right],
 \end{equation*}
 with
 \begin{align*}
   \mathcal{F}_0 &= \frac{\sqrt{\lambda}}{2} f_0, \\
   f_0 &= 4\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 2w^4\right], \\
   \lambda = 1 + w^4 + \varepsilon^4 - 2(w^2 + \varepsilon^2 + w^2\varepsilon^2).
 \end{align*}
 Defining
 \begin{equation*}
   u_q = \frac{1 + \varepsilon^2 - w^2 - \lambda^{1/2}}{1 +
     \varepsilon^2 - w^2 + \lambda^{1/2}}
 \end{equation*}
 and
 \begin{equation*}
   u_w = \frac{1 - \varepsilon^2 + w^2 - \lambda^{1/2}}{1 -
     \varepsilon^2 + w^2 + \lambda^{1/2}}
 \end{equation*}
 the factor $\mathcal{F}_1$ can be expressed as
 \begin{align*}
   \mathcal{F}_1 = \frac{1}{2}f_0(1+\varepsilon^2-w^2)
   & \left[\pi^2 + 2Li_2(u_w) - 2Li_2(1-u_w) - 4Li_2(u_q) \right. \\
     & -4Li_2(u_q u_w) + \log\left(\frac{1-u_q}{w^2}\right)\log(1-u_q)
     - \log^2(1-u_q u_w) \\
     & \left.+\frac{1}{4}\log^2\left(\frac{w^2}{u_w}\right) - \log(u_w)
     \log\left[\frac{(1-u_q u_w)^2}{1-u_q}\right]
     -2\log(u_q)\log\left[(1-u_q)(1-u_q u_w)\right]\right] \\
   & -\sqrt{\lambda}f_0(2\log(w) + 3\log(\varepsilon) - 2\log{\lambda}) \\
   &  +4(1-\varepsilon^2)\left[(1-\varepsilon^2)^2 +
     w^2(1+\varepsilon^2) - 4w^4\right]\log(u_w) \\
   & \left[(3 - \varepsilon^2 + 11\varepsilon^4 - \varepsilon^6)
     + w^2(6 - 12\varepsilon^2 +2\varepsilon^4) - w^4(21 +
     5\varepsilon^2) + 12w^6\right] \log(u_q) \\
   & 6\sqrt{\lambda} (1-\varepsilon^2) (1 + \varepsilon^2 - w^2)
   \log(\varepsilon)
   + \sqrt{\lambda}\left[-5 + 22\varepsilon^2 - 5\varepsilon^4 -
     9w^2(1+\varepsilon^2) + 6w^4\right].
 \end{align*}
 @
 <<SM physics: public>>=
   public :: top_width_sm_lo
 <<SM physics: procedures>>=
   elemental function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) &
          result (gamma)
     real(default) :: gamma
     real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb
     real(default) :: kappa
     kappa = sqrt ((mtop**2 - (mw + mb)**2) * (mtop**2 - (mw - mb)**2))
     gamma = alpha / four * mtop / (two * sinthw**2) * &
          vtb**2 * kappa / mtop**2 * &
          ((mtop**2 + mb**2) / (two * mtop**2) + &
           (mtop**2 - mb**2)**2 / (two * mtop**2 * mw**2) - &
            mw**2 / mtop**2)
   end function top_width_sm_lo
 
 @ %def top_width_sm_lo
 @
 <<SM physics: public>>=
   public :: g_mu_from_alpha
 <<SM physics: procedures>>=
   elemental function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu)
     real(default) :: g_mu
     real(default), intent(in) :: alpha, mw, sinthw
     g_mu = pi * alpha / sqrt(two) / mw**2 / sinthw**2
   end function g_mu_from_alpha
 
 @ %def g_mu_from_alpha
 @
 <<SM physics: public>>=
   public :: alpha_from_g_mu
 <<SM physics: procedures>>=
   elemental function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha)
     real(default) :: alpha
     real(default), intent(in) :: g_mu, mw, sinthw
     alpha = g_mu * sqrt(two) / pi * mw**2 * sinthw**2
   end function alpha_from_g_mu
 
 @ %def alpha_from_g_mu
 @ Cf. (3.3)-(3.7) in [[1207.5018]].
 <<SM physics: public>>=
   public :: top_width_sm_qcd_nlo_massless_b
 <<SM physics: procedures>>=
   elemental function top_width_sm_qcd_nlo_massless_b &
          (alpha, sinthw, vtb, mtop, mw, alphas) result (gamma)
     real(default) :: gamma
     real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas
     real(default) :: prefac, g_mu, w2
     g_mu = g_mu_from_alpha (alpha, mw, sinthw)
     prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi)
     w2 = mw**2 / mtop**2
     gamma = prefac * (f0 (w2) - (two * alphas) / (3 * Pi) * f1 (w2))
   end function top_width_sm_qcd_nlo_massless_b
 
 @ %def top_width_sm_qcd_nlo_massless_b
 @
 <<SM physics: public>>=
   public :: f0
 <<SM physics: procedures>>=
   elemental function f0 (w2) result (f)
     real(default) :: f
     real(default), intent(in) :: w2
     f = two * (one - w2)**2 * (1 + 2 * w2)
   end function f0
 
 @ %def f0
 @
 <<SM physics: public>>=
   public :: f1
 <<SM physics: procedures>>=
   elemental function f1 (w2) result (f)
     real(default) :: f
     real(default), intent(in) :: w2
     f = f0 (w2) * (pi**2 + two * Li2 (w2) - two * Li2 (one - w2)) &
          + four * w2 * (one - w2 - two * w2**2) * log (w2) &
          + two * (one - w2)**2 * (five + four * w2) * log (one - w2) &
          - (one - w2) * (five + 9 * w2 - 6 * w2**2)
   end function f1
 
 @ %def f1
 @ Basically, the same as above but with $m_b$ dependence,
 cf. Jezabek / Kuehn 1989.
 <<SM physics: public>>=
   public :: top_width_sm_qcd_nlo_jk
 <<SM physics: procedures>>=
   elemental function top_width_sm_qcd_nlo_jk &
          (alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma)
     real(default) :: gamma
     real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas
     real(default) :: prefac, g_mu, eps2, i_xi
     g_mu = g_mu_from_alpha (alpha, mw, sinthw)
     prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi)
     eps2 = (mb / mtop)**2
     i_xi = (mw / mtop)**2
     gamma = prefac * (ff0 (eps2, i_xi) - &
          (two * alphas) / (3 * Pi) * ff1 (eps2, i_xi))
   end function top_width_sm_qcd_nlo_jk
 
 @ %def top_width_sm_qcd_nlo_jk
 @ Same as above, $m_b > 0$, with the slightly different implementation
 (2.6) of arXiv:1204.1513v1 by Campbell and Ellis.
 <<SM physics: public>>=
   public :: top_width_sm_qcd_nlo_ce
 <<SM physics: procedures>>=
   elemental function top_width_sm_qcd_nlo_ce &
        (alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma)
     real(default) :: gamma
     real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s
     real(default) :: pm, pp, p0, p3
     real(default) :: yw, yp
     real(default) :: W0, Wp, Wm, w2
     real(default) :: beta2
     real(default) :: f
     real(default) :: g_mu, gamma0
     beta2 = (mb / mtop)**2
     w2 = (mw / mtop)**2
     p0 = (one - w2 + beta2) / two
     p3 = sqrt (lambda (one, w2, beta2)) / two
     pp = p0 + p3
     pm = p0 - p3
     W0 = (one + w2 - beta2) / two
     Wp = W0 + p3
     Wm = W0 - p3
     yp = log (pp / pm) / two
     yw = log (Wp / Wm) / two
     f = (one - beta2)**2 + w2 * (one + beta2) - two * w2**2
     g_mu = g_mu_from_alpha (alpha, mw, sinthw)
     gamma0 = g_mu * mtop**3 * vtb**2 / (8 * pi * sqrt(two))
     gamma = gamma0 * alpha_s / twopi * CF * &
          (8 * f * p0 * (Li2(one - pm) - Li2(one - pp) - two * Li2(one - pm / pp) &
          + yp * log((four * p3**2) / (pp**2 * Wp)) + yw * log (pp)) &
          + four * (one - beta2) * ((one - beta2)**2 + w2 * (one + beta2) - four * w2**2) * yw &
          + (3 - beta2 + 11 * beta2**2 - beta2**3 + w2 * (6 - 12 * beta2 + two * beta2**2) &
          - w2**2 * (21 + 5 * beta2) + 12 * w2**3) * yp &
          + 8 * f * p3 * log (sqrt(w2) / (four * p3**2)) &
          + 6 * (one - four * beta2 + 3 * beta2**2 + w2 * (3 + beta2) - four * w2**2) * p3 * log(sqrt(beta2)) &
          + (5 - 22 * beta2 + 5 * beta2**2 + 9 * w2 * (one + beta2) - 6 * w2**2) * p3)
   end function top_width_sm_qcd_nlo_ce
 
 @ %def top_width_sm_qcd_nlo_ce
 @
 <<SM physics: public>>=
   public :: ff0
 <<SM physics: procedures>>=
   elemental function ff0 (eps2, w2) result (f)
     real(default) :: f
     real(default), intent(in) :: eps2, w2
     f = one / two * sqrt(ff_lambda (eps2, w2)) * ff_f0 (eps2, w2)
   end function ff0
 
 @ %def ff0
 @
 <<SM physics: public>>=
   public :: ff_f0
 <<SM physics: procedures>>=
   elemental function ff_f0 (eps2, w2) result (f)
     real(default) :: f
     real(default), intent(in) :: eps2, w2
     f = four * ((1 - eps2)**2 + w2 * (1 + eps2) - 2 * w2**2)
   end function ff_f0
 
 @ %def ff_f0
 @
 <<SM physics: public>>=
   public :: ff_lambda
 <<SM physics: procedures>>=
   elemental function ff_lambda (eps2, w2) result (l)
     real(default) :: l
     real(default), intent(in) :: eps2, w2
     l = one + w2**2 + eps2**2 - two * (w2 + eps2 + w2 * eps2)
   end function ff_lambda
 
 @ %def ff_lambda
 @
 <<SM physics: public>>=
   public :: ff1
 <<SM physics: procedures>>=
   elemental function ff1 (eps2, w2) result (f)
     real(default) :: f
     real(default), intent(in) :: eps2, w2
     real(default) :: uq, uw, sq_lam, fff
     sq_lam = sqrt (ff_lambda (eps2, w2))
     fff = ff_f0 (eps2, w2)
     uw = (one - eps2 + w2 - sq_lam) / &
          (one - eps2 + w2 + sq_lam)
     uq = (one + eps2 - w2 - sq_lam) / &
          (one + eps2 - w2 + sq_lam)
     f = one / two * fff * (one + eps2 - w2) * &
          (pi**2 + two * Li2 (uw) - two * Li2 (one - uw) - four * Li2 (uq) &
           - four * Li2 (uq * uw) + log ((one - uq) / w2) * log (one - uq) &
           - log (one - uq * uw)**2 + one / four * log (w2 / uw)**2 &
           - log (uw) * log ((one - uq * uw)**2 / (one - uq)) &
           - two * log (uq) * log ((one - uq) * (one - uq * uw))) &
           - sq_lam * fff * (two * log (sqrt (w2)) &
           + three * log (sqrt (eps2)) - two * log (sq_lam**2)) &
           + four * (one - eps2) * ((one - eps2)**2 + w2 * (one + eps2) &
           - four * w2**2) * log (uw) &
           + (three - eps2 + 11 * eps2**2 - eps2**3 + w2 * &
             (6 - 12 * eps2 + 2 * eps2**2) - w2**2 * (21 + five * eps2) &
           + 12 * w2**3) * log (uq) &
           + 6 * sq_lam * (one - eps2) * &
             (one + eps2 - w2) * log (sqrt (eps2)) &
           + sq_lam * (- five + 22 * eps2 - five * eps2**2 - 9 * w2 * &
             (one + eps2) + 6 * w2**2)
   end function ff1
 
 @ %def ff1
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sm_physics_ut.f90]]>>=
 <<File header>>
 
 module sm_physics_ut
   use unit_tests
   use sm_physics_uti
 
 <<Standard module head>>
 
 <<SM physics: public test>>
 
 contains
 
 <<SM physics: test driver>>
 
 end module sm_physics_ut
 @ %def sm_physics_ut
 @
 <<[[sm_physics_uti.f90]]>>=
 <<File header>>
 
 module sm_physics_uti
 
 <<Use kinds>>
   use numeric_utils
   use format_defs, only: FMT_15
   use constants
 
   use sm_physics
 
 <<Standard module head>>
 
 <<SM physics: test declarations>>
 
 contains
 
 <<SM physics: tests>>
 
 end module sm_physics_uti
 @ %def sm_physics_ut
 @ API: driver for the unit tests below.
 <<SM physics: public test>>=
   public :: sm_physics_test
 <<SM physics: test driver>>=
   subroutine sm_physics_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SM physics: execute tests>>
   end subroutine sm_physics_test
 
 @ %def sm_physics_test
 @
 \subsubsection{Splitting functions}
 <<SM physics: execute tests>>=
   call test (sm_physics_1, "sm_physics_1", &
        "Splitting functions", &
        u, results)
 <<SM physics: test declarations>>=
   public :: sm_physics_1
 <<SM physics: tests>>=
   subroutine sm_physics_1 (u)
     integer, intent(in) :: u
     real(default) :: z = 0.75_default
 
     write (u, "(A)")  "* Test output: sm_physics_1"
     write (u, "(A)")  "*   Purpose: check analytic properties"
     write (u, "(A)")
 
     write (u, "(A)")  "* Splitting functions:"
     write (u, "(A)")
 
     call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)), "+-+")
     call assert (u, vanishes (p_qqg_pol (z, +1, -1, -1)), "+--")
     call assert (u, vanishes (p_qqg_pol (z, -1, +1, +1)), "-++")
     call assert (u, vanishes (p_qqg_pol (z, -1, +1, -1)), "-+-")
 
     !call assert (u, nearly_equal ( &
          !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), &
          !p_qqg (z)), "pol sum")
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sm_physics_1"
 
   end subroutine sm_physics_1
 
 @ %def sm_physics_1
 @
 \subsubsection{Top width}
 <<SM physics: execute tests>>=
   call test(sm_physics_2, "sm_physics_2", &
             "Top width", u, results)
 <<SM physics: test declarations>>=
   public :: sm_physics_2
 <<SM physics: tests>>=
   subroutine sm_physics_2 (u)
     integer, intent(in) :: u
     real(default) :: mtop, mw, mz, mb, g_mu, sinthw, alpha, vtb, gamma0
     real(default) :: w2, alphas, alphas_mz, gamma1
     write (u, "(A)")  "* Test output: sm_physics_2"
     write (u, "(A)")  "*   Purpose: Check different top width computations"
     write (u, "(A)")
 
     write (u, "(A)")  "*   Values from [[1207.5018]] (massless b)"
     mtop = 172.0
     mw = 80.399
     mz = 91.1876
     mb = zero
     mb = 0.00001
     g_mu = 1.16637E-5
     sinthw = sqrt(one - mw**2 / mz**2)
     alpha = alpha_from_g_mu (g_mu, mw, sinthw)
     vtb = one
     w2 = mw**2 / mtop**2
 
     write (u, "(A)")  "*   Check Li2 implementation"
     call assert_equal (u, Li2(w2), 0.2317566263959552_default, &
          "Li2(w2)", rel_smallness=1.0E-6_default)
     call assert_equal (u, Li2(one - w2), 1.038200378935867_default, &
          "Li2(one - w2)", rel_smallness=1.0E-6_default)
 
     write (u, "(A)")  "*   Check LO Width"
     gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb)
     call assert_equal (u, gamma0, 1.4655_default, &
          "top_width_sm_lo", rel_smallness=1.0E-5_default)
     alphas = zero
     gamma0 = top_width_sm_qcd_nlo_massless_b &
          (alpha, sinthw, vtb, mtop, mw, alphas)
     call assert_equal (u, gamma0, 1.4655_default, &
          "top_width_sm_qcd_nlo_massless_b", rel_smallness=1.0E-5_default)
     gamma0 = top_width_sm_qcd_nlo_jk &
          (alpha, sinthw, vtb, mtop, mw, mb, alphas)
     call assert_equal (u, gamma0, 1.4655_default, &
          "top_width_sm_qcd_nlo", rel_smallness=1.0E-5_default)
 
     write (u, "(A)")  "*   Check NLO Width"
     alphas_mz = 0.1202      ! MSTW2008 NLO fit
     alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default)
     gamma1 = top_width_sm_qcd_nlo_massless_b &
          (alpha, sinthw, vtb, mtop, mw, alphas)
     call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-4_default)
     gamma1 = top_width_sm_qcd_nlo_jk &
          (alpha, sinthw, vtb, mtop, mw, mb, alphas)
     ! It would be nice to get one more significant digit but the
     ! expression is numerically rather unstable for mb -> 0
     call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-3_default)
 
     write (u, "(A)")  "*   Values from threshold validation (massive b)"
     alpha = one / 125.924
     ! ee = 0.315901
     ! cw = 0.881903
     ! v = 240.024
     mtop = 172.0 ! This is the value for M1S !!!
     mb = 4.2
     sinthw = 0.47143
     mz = 91.188
     mw = 80.419
     call assert_equal (u, sqrt(one - mw**2 / mz**2), sinthw, &
          "sinthw", rel_smallness=1.0E-6_default)
 
     write (u, "(A)")  "*   Check LO Width"
     gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb)
     call assert_equal (u, gamma0, 1.5386446_default, &
          "gamma0", rel_smallness=1.0E-7_default)
     alphas = zero
     gamma0 = top_width_sm_qcd_nlo_jk &
          (alpha, sinthw, vtb, mtop, mw, mb, alphas)
     call assert_equal (u, gamma0, 1.5386446_default, &
          "gamma0", rel_smallness=1.0E-7_default)
 
     write (u, "(A)")  "*   Check NLO Width"
     alphas_mz = 0.118 !(Z pole, NLL running to mu_h)
     alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default)
     write (u, "(A," // FMT_15 // ")")  "*   alphas = ", alphas
     gamma1 = top_width_sm_qcd_nlo_jk &
          (alpha, sinthw, vtb, mtop, mw, mb, alphas)
     write (u, "(A," // FMT_15 // ")")  "*   Gamma1 = ", gamma1
 
     mb = zero
     gamma1 = top_width_sm_qcd_nlo_massless_b &
          (alpha, sinthw, vtb, mtop, mw, alphas)
     alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default)
     write (u, "(A," // FMT_15 // ")")  "*   Gamma1(mb=0) = ", gamma1
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sm_physics_2"
   end subroutine sm_physics_2
 
 @ %def sm_physics_2
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{QCD Coupling}
 We provide various distinct implementations of the QCD coupling.  In
 this module, we define an abstract data type and three
 implementations: fixed, running with $\alpha_s(M_Z)$ as input, and
 running with $\Lambda_{\text{QCD}}$ as input.  We use the functions
 defined above in the module [[sm_physics]] but provide a common
 interface.  Later modules may define additional implementations.
 <<[[sm_qcd.f90]]>>=
 <<File header>>
 
 module sm_qcd
 
 <<Use kinds>>
   use io_units
   use format_defs, only: FMT_12
   use numeric_utils
   use diagnostics
   use md5
   use physics_defs
   use sm_physics
 
 <<Standard module head>>
 
 <<SM qcd: public>>
 
 <<SM qcd: types>>
 
 <<SM qcd: interfaces>>
 
 contains
 
 <<SM qcd: procedures>>
 
 end module sm_qcd
 @ %def sm_qcd
 @
 \subsection{Coupling: Abstract Data Type}
 This is the abstract version of the QCD coupling implementation.
 <<SM qcd: public>>=
   public :: alpha_qcd_t
 <<SM qcd: types>>=
   type, abstract :: alpha_qcd_t
    contains
    <<SM qcd: alpha qcd: TBP>>
   end type alpha_qcd_t
 
 @ %def alpha_qcd_t
 @ There must be an output routine.
 <<SM qcd: alpha qcd: TBP>>=
   procedure (alpha_qcd_write), deferred :: write
 <<SM qcd: interfaces>>=
   abstract interface
      subroutine alpha_qcd_write (object, unit)
        import
        class(alpha_qcd_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine alpha_qcd_write
   end interface
 
 @ %def alpha_qcd_write
 @ This method computes the running coupling, given a certain scale.  All
 parameters (reference value, order of the approximation, etc.) must be
 set before calling this.
 <<SM qcd: alpha qcd: TBP>>=
   procedure (alpha_qcd_get), deferred :: get
 <<SM qcd: interfaces>>=
   abstract interface
      function alpha_qcd_get (alpha_qcd, scale) result (alpha)
        import
        class(alpha_qcd_t), intent(in) :: alpha_qcd
        real(default), intent(in) :: scale
        real(default) :: alpha
      end function alpha_qcd_get
   end interface
 
 @ %def alpha_qcd_get
 @
 \subsection{Fixed Coupling}
 In this version, the $\alpha_s$ value is fixed, the [[scale]] argument
 of the [[get]] method is ignored.  There is only one parameter, the
 value.  By default, this is the value at $M_Z$.
 <<SM qcd: public>>=
   public :: alpha_qcd_fixed_t
 <<SM qcd: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_fixed_t
      real(default) :: val = ALPHA_QCD_MZ_REF
    contains
    <<SM qcd: alpha qcd fixed: TBP>>
   end type alpha_qcd_fixed_t
 
 @ %def alpha_qcd_fixed_t
 @ Output.
 <<SM qcd: alpha qcd fixed: TBP>>=
   procedure :: write => alpha_qcd_fixed_write
 <<SM qcd: procedures>>=
   subroutine alpha_qcd_fixed_write (object, unit)
     class(alpha_qcd_fixed_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(3x,A)")  "QCD parameters (fixed coupling):"
     write (u, "(5x,A," // FMT_12 // ")")  "alpha = ", object%val
   end subroutine alpha_qcd_fixed_write
 
 @ %def alpha_qcd_fixed_write
 @ Calculation: the scale is ignored in this case.
 <<SM qcd: alpha qcd fixed: TBP>>=
   procedure :: get => alpha_qcd_fixed_get
 <<SM qcd: procedures>>=
   function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     alpha = alpha_qcd%val
   end function alpha_qcd_fixed_get
 
 @ %def alpha_qcd_fixed_get
 @
 \subsection{Running Coupling}
 In this version, the $\alpha_s$ value runs relative to the value at a
 given reference scale.  There are two parameters: the value of this
 scale (default: $M_Z$), the value of $\alpha_s$ at this scale, and the
 number of effective flavors.  Furthermore, we have the order of the
 approximation.
 <<SM qcd: public>>=
   public :: alpha_qcd_from_scale_t
 <<SM qcd: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_from_scale_t
      real(default) :: mu_ref = MZ_REF
      real(default) :: ref = ALPHA_QCD_MZ_REF
      integer :: order = 0
      integer :: nf = 5
    contains
    <<SM qcd: alpha qcd from scale: TBP>>
   end type alpha_qcd_from_scale_t
 
 @ %def alpha_qcd_from_scale_t
 @ Output.
 <<SM qcd: alpha qcd from scale: TBP>>=
   procedure :: write => alpha_qcd_from_scale_write
 <<SM qcd: procedures>>=
   subroutine alpha_qcd_from_scale_write (object, unit)
     class(alpha_qcd_from_scale_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(3x,A)")  "QCD parameters (running coupling):"
     write (u, "(5x,A," // FMT_12 // ")")  "Scale mu  = ", object%mu_ref
     write (u, "(5x,A," // FMT_12 // ")")  "alpha(mu) = ", object%ref
     write (u, "(5x,A,I0)")      "LL order  = ", object%order
     write (u, "(5x,A,I0)")      "N(flv)    = ", object%nf
   end subroutine alpha_qcd_from_scale_write
 
 @ %def alpha_qcd_from_scale_write
 @ Calculation: here, we call the function for running $\alpha_s$ that
 was defined in [[sm_physics]] above.  The function does not take into
 account thresholds, so the number of flavors should be the correct one
 for the chosen scale.  Normally, this should be the $Z$ boson mass.
 <<SM qcd: alpha qcd from scale: TBP>>=
   procedure :: get => alpha_qcd_from_scale_get
 <<SM qcd: procedures>>=
   function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     alpha = running_as (scale, alpha_qcd%ref, alpha_qcd%mu_ref, &
          alpha_qcd%order, real (alpha_qcd%nf, kind=default))
   end function alpha_qcd_from_scale_get
 
 @ %def alpha_qcd_from_scale_get
 @
 \subsection{Running Coupling, determined by $\Lambda_{\text{QCD}}$}
 In this version, the inputs are the value $\Lambda_{\text{QCD}}$ and
 the order of the approximation.
 <<SM qcd: public>>=
   public :: alpha_qcd_from_lambda_t
 <<SM qcd: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_from_lambda_t
      real(default) :: lambda = LAMBDA_QCD_REF
      integer :: order = 0
      integer :: nf = 5
    contains
    <<SM qcd: alpha qcd from lambda: TBP>>
   end type alpha_qcd_from_lambda_t
 
 @ %def alpha_qcd_from_lambda_t
 @ Output.
 <<SM qcd: alpha qcd from lambda: TBP>>=
   procedure :: write => alpha_qcd_from_lambda_write
 <<SM qcd: procedures>>=
   subroutine alpha_qcd_from_lambda_write (object, unit)
     class(alpha_qcd_from_lambda_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(3x,A)")  "QCD parameters (Lambda_QCD as input):"
     write (u, "(5x,A," // FMT_12 // ")")  "Lambda_QCD = ", object%lambda
     write (u, "(5x,A,I0)")      "LL order   = ", object%order
     write (u, "(5x,A,I0)")      "N(flv)     = ", object%nf
   end subroutine alpha_qcd_from_lambda_write
 
 @ %def alpha_qcd_from_lambda_write
 @ Calculation: here, we call the second function for running $\alpha_s$ that
 was defined in [[sm_physics]] above.  The $\Lambda$ value should be
 the one that is appropriate for the chosen number of effective
 flavors.  Again, thresholds are not incorporated.
 <<SM qcd: alpha qcd from lambda: TBP>>=
   procedure :: get => alpha_qcd_from_lambda_get
 <<SM qcd: procedures>>=
   function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     alpha = running_as_lam (real (alpha_qcd%nf, kind=default), scale, &
          alpha_qcd%lambda, alpha_qcd%order)
   end function alpha_qcd_from_lambda_get
 
 @ %def alpha_qcd_from_lambda_get
 @
 \subsection{QCD Wrapper type}
 We could get along with a polymorphic QCD type, but a monomorphic wrapper type
 with a polymorphic component is easier to handle and probably safer
 (w.r.t.\ compiler bugs).  However, we keep the object transparent, so we can
 set the type-specific parameters directly (by a [[dispatch]] routine).
 <<SM qcd: public>>=
   public :: qcd_t
 <<SM qcd: types>>=
   type :: qcd_t
      class(alpha_qcd_t), allocatable :: alpha
      character(32) :: md5sum = ""
      integer :: n_f = -1
    contains
    <<SM qcd: qcd: TBP>>
   end type qcd_t
 
 @ %def qcd_t
 @ Output.  We first print the polymorphic [[alpha]] which contains a headline,
 then any extra components.
 <<SM qcd: qcd: TBP>>=
   procedure :: write => qcd_write
 <<SM qcd: procedures>>=
   subroutine qcd_write (qcd, unit, show_md5sum)
     class(qcd_t), intent(in) :: qcd
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_md5sum
     logical :: show_md5
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     show_md5 = .true.;  if (present (show_md5sum))  show_md5 = show_md5sum
     if (allocated (qcd%alpha)) then
        call qcd%alpha%write (u)
     else
        write (u, "(3x,A)")  "QCD parameters (coupling undefined)"
     end if
     if (show_md5 .and. qcd%md5sum /= "") &
          write (u, "(5x,A,A,A)") "md5sum = '", qcd%md5sum, "'"
   end subroutine qcd_write
 
 @ %def qcd_write
 @ Compute an MD5 sum for the [[alpha_s]] setup.  This is
 done by writing them to a temporary file, using a standard format.
 <<SM qcd: qcd: TBP>>=
   procedure :: compute_alphas_md5sum => qcd_compute_alphas_md5sum
 <<SM qcd: procedures>>=
   subroutine qcd_compute_alphas_md5sum (qcd)
     class(qcd_t), intent(inout) :: qcd
     integer :: unit
     if (allocated (qcd%alpha)) then
        unit = free_unit ()
        open (unit, status="scratch", action="readwrite")
        call qcd%alpha%write (unit)
        rewind (unit)
        qcd%md5sum = md5sum (unit)
        close (unit)
     end if
   end subroutine qcd_compute_alphas_md5sum
 
 @ %def qcd_compute_alphas_md5sum
 @
 @ Retrieve the MD5 sum of the qcd setup.
 <<SM qcd: qcd: TBP>>=
   procedure :: get_md5sum => qcd_get_md5sum
 <<SM qcd: procedures>>=
   function qcd_get_md5sum (qcd) result (md5sum)
     character(32) :: md5sum
     class(qcd_t), intent(inout) :: qcd
     md5sum = qcd%md5sum
   end function qcd_get_md5sum
 
 @ %def qcd_get_md5sum
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sm_qcd_ut.f90]]>>=
 <<File header>>
 
 module sm_qcd_ut
   use unit_tests
   use sm_qcd_uti
 
 <<Standard module head>>
 
 <<SM qcd: public test>>
 
 contains
 
 <<SM qcd: test driver>>
 
 end module sm_qcd_ut
 @ %def sm_qcd_ut
 @
 <<[[sm_qcd_uti.f90]]>>=
 <<File header>>
 
 module sm_qcd_uti
 
 <<Use kinds>>
   use physics_defs, only: MZ_REF
 
   use sm_qcd
 
 <<Standard module head>>
 
 <<SM qcd: test declarations>>
 
 contains
 
 <<SM qcd: tests>>
 
 end module sm_qcd_uti
 @ %def sm_qcd_ut
 @ API: driver for the unit tests below.
 <<SM qcd: public test>>=
   public :: sm_qcd_test
 <<SM qcd: test driver>>=
   subroutine sm_qcd_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SM qcd: execute tests>>
   end subroutine sm_qcd_test
 
 @ %def sm_qcd_test
 @
 \subsubsection{QCD Coupling}
 We check two different implementations of the abstract QCD coupling.
 <<SM qcd: execute tests>>=
   call test (sm_qcd_1, "sm_qcd_1", &
        "running alpha_s", &
        u, results)
 <<SM qcd: test declarations>>=
   public :: sm_qcd_1
 <<SM qcd: tests>>=
   subroutine sm_qcd_1 (u)
     integer, intent(in) :: u
     type(qcd_t) :: qcd
 
     write (u, "(A)")  "* Test output: sm_qcd_1"
     write (u, "(A)")  "*   Purpose: compute running alpha_s"
     write (u, "(A)")
 
     write (u, "(A)")  "* Fixed:"
     write (u, "(A)")
 
     allocate (alpha_qcd_fixed_t :: qcd%alpha)
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
     write (u, *)
     deallocate (qcd%alpha)
 
     write (u, "(A)")  "* Running from MZ (LO):"
     write (u, "(A)")
 
     allocate (alpha_qcd_from_scale_t :: qcd%alpha)
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
     write (u, *)
 
     write (u, "(A)")  "* Running from MZ (NLO):"
     write (u, "(A)")
 
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_from_scale_t)
        alpha%order = 1
     end select
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
     write (u, *)
 
     write (u, "(A)")  "* Running from MZ (NNLO):"
     write (u, "(A)")
 
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_from_scale_t)
        alpha%order = 2
     end select
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
     write (u, *)
 
     deallocate (qcd%alpha)
     write (u, "(A)")  "* Running from Lambda_QCD (LO):"
     write (u, "(A)")
 
     allocate (alpha_qcd_from_lambda_t :: qcd%alpha)
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
     write (u, *)
 
     write (u, "(A)")  "* Running from Lambda_QCD (NLO):"
     write (u, "(A)")
 
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_from_lambda_t)
        alpha%order = 1
     end select
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
     write (u, *)
 
     write (u, "(A)")  "* Running from Lambda_QCD (NNLO):"
     write (u, "(A)")
 
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_from_lambda_t)
        alpha%order = 2
     end select
     call qcd%compute_alphas_md5sum ()
 
     call qcd%write (u)
     write (u, *)
     write (u, "(1x,A,F10.7)")  "alpha_s (mz)    =", &
          qcd%alpha%get (MZ_REF)
     write (u, "(1x,A,F10.7)")  "alpha_s (1 TeV) =", &
          qcd%alpha%get (1000._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sm_qcd_1"
 
   end subroutine sm_qcd_1
 
 @ %def sm_qcd_1
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{QED Coupling}
 On the surface similar to the QCD coupling module but much simpler.
 Only a fixed QED couping $\alpha_\text{em}$ is allowed.
 Can be extended later if we want to enable a running of
 $\alpha_\text{em}$ as well.
 <<[[sm_qed.f90]]>>=
 <<File header>>
 
 module sm_qed
 
 <<Use kinds>>
   use io_units
   use format_defs, only: FMT_12
+  use md5
+  use physics_defs
+  use sm_physics
 
 <<Standard module head>>
 
 <<SM qed: public>>
 
 <<SM qed: types>>
 
+<<SM qed: interfaces>>
+
 contains
 
 <<SM qed: procedures>>
 
 end module sm_qed
 @ %def sm_qed
 @
+\subsection{Coupling: Abstract Data Type}
+This is the abstract version of the QCD coupling implementation.
+<<SM qed: public>>=
+  public :: alpha_qed_t
+<<SM qed: types>>=
+  type, abstract :: alpha_qed_t
+   contains
+   <<SM qed: alpha qed: TBP>>
+  end type alpha_qed_t
+
+@ %def alpha_qed_t
+@ There must be an output routine.
+<<SM qed: alpha qed: TBP>>=
+  procedure (alpha_qed_write), deferred :: write
+<<SM qed: interfaces>>=
+  abstract interface
+     subroutine alpha_qed_write (object, unit)
+       import
+       class(alpha_qed_t), intent(in) :: object
+       integer, intent(in), optional :: unit
+     end subroutine alpha_qed_write
+  end interface
+
+@ %def alpha_qed_write
+@ This method computes the running coupling, given a certain scale.  All
+parameters (reference value, order of the approximation, etc.) must be
+set before calling this.
+<<SM qed: alpha qed: TBP>>=
+  procedure (alpha_qed_get), deferred :: get
+<<SM qed: interfaces>>=
+  abstract interface
+     function alpha_qed_get (alpha_qed, scale) result (alpha)
+       import
+       class(alpha_qed_t), intent(in) :: alpha_qed
+       real(default), intent(in) :: scale
+       real(default) :: alpha
+     end function alpha_qed_get
+  end interface
+
+@ %def alpha_qed_get
+@
+\subsection{Fixed Coupling}
+In this version, the $\alpha$ value is fixed, the [[scale]] argument
+of the [[get]] method is ignored.  There is only one parameter, the
+value. The default depends on the electroweak scheme chosen in the
+model.
+<<SM qed: public>>=
+  public :: alpha_qed_fixed_t
+<<SM qed: types>>=
+  type, extends (alpha_qed_t) :: alpha_qed_fixed_t
+     real(default) :: val = ALPHA_QED_ME_REF
+   contains
+   <<SM qed: alpha qed fixed: TBP>>
+  end type alpha_qed_fixed_t
+
+@ %def alpha_qed_fixed_t
+@ Output.
+<<SM qed: alpha qed fixed: TBP>>=
+  procedure :: write => alpha_qed_fixed_write
+<<SM qed: procedures>>=
+  subroutine alpha_qed_fixed_write (object, unit)
+    class(alpha_qed_fixed_t), intent(in) :: object
+    integer, intent(in), optional :: unit
+    integer :: u
+    u = given_output_unit (unit);  if (u < 0)  return
+    write (u, "(3x,A)")  "QED parameters (fixed coupling):"
+    write (u, "(5x,A," // FMT_12 // ")")  "alpha = ", object%val
+  end subroutine alpha_qed_fixed_write
+
+@ %def alpha_qed_fixed_write
+@ Calculation: the scale is ignored in this case.
+<<SM qed: alpha qed fixed: TBP>>=
+  procedure :: get => alpha_qed_fixed_get
+<<SM qed: procedures>>=
+  function alpha_qed_fixed_get (alpha_qed, scale) result (alpha)
+    class(alpha_qed_fixed_t), intent(in) :: alpha_qed
+    real(default), intent(in) :: scale
+    real(default) :: alpha
+    alpha = alpha_qed%val
+  end function alpha_qed_fixed_get
+
+@ %def alpha_qed_fixed_get
+@
+\subsection{Running Coupling}
+In this version, the $\alpha$ value runs relative to the value at a
+given reference scale.  There are two parameters: the value of this
+scale (default: $M_Z$), the value of $\alpha$ at this scale, and the
+number of effective flavors.  Furthermore, we have the order of the
+approximation.
+<<SM qed: public>>=
+  public :: alpha_qed_from_scale_t
+<<SM qed: types>>=
+  type, extends (alpha_qed_t) :: alpha_qed_from_scale_t
+     real(default) :: mu_ref = ME_REF
+     real(default) :: ref = ALPHA_QED_ME_REF
+     integer :: order = 0
+     integer :: nf = 5
+     integer :: nlep = 1
+     logical :: analytic = .true.
+   contains
+   <<SM qed: alpha qed from scale: TBP>>
+  end type alpha_qed_from_scale_t
+
+@ %def alpha_qed_from_scale_t
+@ Output.
+<<SM qed: alpha qed from scale: TBP>>=
+  procedure :: write => alpha_qed_from_scale_write
+<<SM qed: procedures>>=
+  subroutine alpha_qed_from_scale_write (object, unit)
+    class(alpha_qed_from_scale_t), intent(in) :: object
+    integer, intent(in), optional :: unit
+    integer :: u
+    u = given_output_unit (unit);  if (u < 0)  return
+    write (u, "(3x,A)")  "QED parameters (running coupling):"
+    write (u, "(5x,A," // FMT_12 // ")")  "Scale mu  = ", object%mu_ref
+    write (u, "(5x,A," // FMT_12 // ")")  "alpha(mu) = ", object%ref
+    write (u, "(5x,A,I0)")      "LL order  = ", object%order
+    write (u, "(5x,A,I0)")      "N(flv)    = ", object%nf
+    write (u, "(5x,A,I0)")      "N(lep)    = ", object%nlep
+    write (u, "(5x,A,L1)")      "analytic  = ", object%analytic
+  end subroutine alpha_qed_from_scale_write
+
+@ %def alpha_qed_from_scale_write
+@ Calculation: here, we call the function for running $\alpha_s$ that
+was defined in [[sm_physics]] above.  The function does not take into
+account thresholds, so the number of flavors should be the correct one
+for the chosen scale.  Normally, this should be the $Z$ boson mass.
+<<SM qed: alpha qed from scale: TBP>>=
+  procedure :: get => alpha_qed_from_scale_get
+<<SM qed: procedures>>=
+  function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha)
+    class(alpha_qed_from_scale_t), intent(in) :: alpha_qed
+    real(default), intent(in) :: scale
+    real(default) :: alpha
+    if (alpha_qed%analytic) then
+       alpha = running_alpha (scale, alpha_qed%ref, alpha_qed%mu_ref, &
+            alpha_qed%order, alpha_qed%nf, alpha_qed%nlep)
+    else
+       alpha = running_alpha_num (scale, alpha_qed%ref, alpha_qed%mu_ref, &
+            alpha_qed%order, alpha_qed%nf, alpha_qed%nlep)
+    end if
+  end function alpha_qed_from_scale_get
+
+@ %def alpha_qed_from_scale_get
+@
 \subsection{QED type}
-Slightly similar to [[qcd_t]] but way simpler. It just needs to store [[alpha_em]].
+This module is similar to [[qcd_t]], defining the type [[qed_t]]. 
+It stores the [[alpha_qed_t]] type which is either constant or a running $\alpha$ 
+with different options.
 <<SM qed: public>>=
   public :: qed_t
 <<SM qed: types>>=
   type :: qed_t
-     private
-     real(default) :: alpha_qed = -1
+     class(alpha_qed_t), allocatable :: alpha
+     character(32) :: md5sum = ""
+     integer :: n_f = -1
+     integer :: n_lep = -1
    contains
-   <<SM qed: TBP>>
+   <<SM qed: qed: TBP>>
   end type qed_t
 
 @ %def qed_t
-@ Output routine
-<<SM qed: TBP>>=
+Output.  We first print the polymorphic [[alpha]] which contains a headline,
+then any extra components.
+<<SM qed: qed: TBP>>=
   procedure :: write => qed_write
 <<SM qed: procedures>>=
-  subroutine qed_write (qed, unit)
+  subroutine qed_write (qed, unit, show_md5sum)
     class(qed_t), intent(in) :: qed
     integer, intent(in), optional :: unit
+    logical, intent(in), optional :: show_md5sum
+    logical :: show_md5
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
-    write (u, "(3x,A)")  "QED parameters (fixed coupling):"
-    write (u, "(5x,A," // FMT_12 // ")")  "alpha_qed = ", qed%alpha_qed
+    show_md5 = .true.;  if (present (show_md5sum))  show_md5 = show_md5sum
+    if (allocated (qed%alpha)) then
+       call qed%alpha%write (u)
+    else
+       write (u, "(3x,A)")  "QED parameters (coupling undefined)"
+    end if
+    if (show_md5 .and. qed%md5sum /= "") &
+         write (u, "(5x,A,A,A)") "md5sum = '", qed%md5sum, "'"
   end subroutine qed_write
 
 @ % def qed_write
-@ Setter for [[alpha_qed]]
-<<SM qed: TBP>>=
-  procedure :: set_alpha_qed => qed_set_alpha_qed
+@ Compute an MD5 sum for the [[alpha]] setup.  This is
+done by writing them to a temporary file, using a standard format.
+<<SM qed: qed: TBP>>=
+  procedure :: compute_alpha_md5sum => qed_compute_alpha_md5sum
 <<SM qed: procedures>>=
-  subroutine qed_set_alpha_qed (qed, alpha_qed_in)
+  subroutine qed_compute_alpha_md5sum (qed)
     class(qed_t), intent(inout) :: qed
-    real(default), intent(in) :: alpha_qed_in
-    qed%alpha_qed = alpha_qed_in
-  end subroutine qed_set_alpha_qed
-
-@ % def set_alpha_qed
-@ Getter for [[alpha_qed]]
-<<SM qed: TBP>>=
-  procedure :: get_alpha_qed => qed_get_alpha_qed
+    integer :: unit
+    if (allocated (qed%alpha)) then
+       unit = free_unit ()
+       open (unit, status="scratch", action="readwrite")
+       call qed%alpha%write (unit)
+       rewind (unit)
+       qed%md5sum = md5sum (unit)
+       close (unit)
+    end if
+  end subroutine qed_compute_alpha_md5sum
+
+@ %def qed_compute_alphas_md5sum
+@
+@ Retrieve the MD5 sum of the qed setup.
+<<SM qed: qed: TBP>>=
+  procedure :: get_md5sum => qed_get_md5sum
 <<SM qed: procedures>>=
-  function qed_get_alpha_qed (qed) result (alpha_qed_out)
-    class(qed_t), intent(in) :: qed
-    real(default) :: alpha_qed_out
-    alpha_qed_out = qed%alpha_qed
-  end function qed_get_alpha_qed
+  function qed_get_md5sum (qed) result (md5sum)
+    character(32) :: md5sum
+    class(qed_t), intent(inout) :: qed
+    md5sum = qed%md5sum
+  end function qed_get_md5sum
+
+@ %def qed_get_md5sum
+@
+\subsection{Unit tests}
+Test module, followed by the corresponding implementation module.
+<<[[sm_qed_ut.f90]]>>=
+<<File header>>
+
+module sm_qed_ut
+  use unit_tests
+  use sm_qed_uti
+
+<<Standard module head>>
+
+<<SM qed: public test>>
+
+contains
+
+<<SM qed: test driver>>
+
+end module sm_qed_ut
+@ %def sm_qed_ut
+@
+<<[[sm_qed_uti.f90]]>>=
+<<File header>>
+
+module sm_qed_uti
+
+<<Use kinds>>
+  use physics_defs, only: ME_REF
+
+  use sm_qed
+
+<<Standard module head>>
+
+<<SM qed: test declarations>>
+
+contains
+
+<<SM qed: tests>>
+
+end module sm_qed_uti
+@ %def sm_qed_ut
+@ API: driver for the unit tests below.
+<<SM qed: public test>>=
+  public :: sm_qed_test
+<<SM qed: test driver>>=
+  subroutine sm_qed_test (u, results)
+    integer, intent(in) :: u
+    type(test_results_t), intent(inout) :: results
+  <<SM qed: execute tests>>
+  end subroutine sm_qed_test
+
+@ %def sm_qed_test
+@
+\subsubsection{QED Coupling}
+We check two different implementations of the abstract QED coupling.
+<<SM qed: execute tests>>=
+  call test (sm_qed_1, "sm_qed_1", &
+       "running alpha_s", &
+       u, results)
+<<SM qed: test declarations>>=
+  public :: sm_qed_1
+<<SM qed: tests>>=
+  subroutine sm_qed_1 (u)
+    integer, intent(in) :: u
+    type(qed_t) :: qed
+
+    write (u, "(A)")  "* Test output: sm_qed_1"
+    write (u, "(A)")  "*   Purpose: compute running alpha"
+    write (u, "(A)")
+
+    write (u, "(A)")  "* Fixed:"
+    write (u, "(A)")
+
+    allocate (alpha_qed_fixed_t :: qed%alpha)
+    call qed%compute_alpha_md5sum ()
+
+    call qed%write (u)
+    write (u, *)
+    write (u, "(1x,A,F10.7)")  "alpha (me)     =", &
+         qed%alpha%get (ME_REF)
+    write (u, "(1x,A,F10.7)")  "alpha (10 GeV) =", &
+         qed%alpha%get (10._default)
+    write (u, "(1x,A,F10.7)")  "alpha (1 TeV)  =", &
+         qed%alpha%get (1000._default)
+    write (u, *)
+    deallocate (qed%alpha)
+
+    write (u, "(A)")  "* Running from me (LO):"
+    write (u, "(A)")
+
+    allocate (alpha_qed_from_scale_t :: qed%alpha)
+    call qed%compute_alpha_md5sum ()
+
+    call qed%write (u)
+    write (u, *)
+    write (u, "(1x,A,F10.7)")  "alpha (me)     =", &
+         qed%alpha%get (ME_REF)
+    write (u, "(1x,A,F10.7)")  "alpha (10 GeV) =", &
+         qed%alpha%get (10._default)
+    write (u, "(1x,A,F10.7)")  "alpha (1 TeV)  =", &
+         qed%alpha%get (1000._default)
+    write (u, *)
+
+    write (u, "(A)")  "* Running from me (NLO, analytic):"
+    write (u, "(A)")
+
+    select type (alpha => qed%alpha)
+    type is (alpha_qed_from_scale_t)
+       alpha%order = 1
+    end select
+    call qed%compute_alpha_md5sum ()
+
+    call qed%write (u)
+    write (u, *)
+    write (u, "(1x,A,F10.7)")  "alpha (me)     =", &
+         qed%alpha%get (ME_REF)
+    write (u, "(1x,A,F10.7)")  "alpha (10 GeV) =", &
+         qed%alpha%get (10._default)
+    write (u, "(1x,A,F10.7)")  "alpha (1 TeV)  =", &
+         qed%alpha%get (1000._default)
+    write (u, *)
+
+    write (u, "(A)")  "* Running from me (NLO, numeric):"
+    write (u, "(A)")
+
+    select type (alpha => qed%alpha)
+    type is (alpha_qed_from_scale_t)
+       alpha%order = 1
+       alpha%analytic = .false.
+    end select
+    call qed%compute_alpha_md5sum ()
+
+    call qed%write (u)
+    write (u, *)
+    write (u, "(1x,A,F10.7)")  "alpha (me)     =", &
+         qed%alpha%get (ME_REF)
+    write (u, "(1x,A,F10.7)")  "alpha (10 GeV) =", &
+         qed%alpha%get (10._default)
+    write (u, "(1x,A,F10.7)")  "alpha (1 TeV)  =", &
+         qed%alpha%get (1000._default)
+    write (u, *)
+    deallocate (qed%alpha)
+
+    write (u, "(A)")
+    write (u, "(A)")  "* Test output end: sm_qed_1"
+
+  end subroutine sm_qed_1
 
-@ % def get_alpha_qed
+@ %def sm_qed_1
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Shower algorithms}
 <<[[shower_algorithms.f90]]>>=
 <<File header>>
 
 module shower_algorithms
 
 <<Use kinds>>
   use diagnostics
   use constants
 
 <<Standard module head>>
 
 <<shower algorithms: public>>
 
 <<shower algorithms: interfaces>>
 
 contains
 
 <<shower algorithms: procedures>>
 
 <<shower algorithms: tests>>
 
 end module shower_algorithms
 @ %def shower_algorithms
 @ We want to generate emission variables [[x]]$\in\mathds{R}^d$
 proportional to
 \begin{align}
   &\quad f(x)\; \Delta(f, h(x)) \quad\text{with}\\
   \Delta(f, H) &= \exp\left\{-\int\text{d}^d x'f(x') \Theta(h(x') -
                 H)\right\}
 \end{align}
 The [[true_function]] $f$ is however too complicated and we are only
 able to generate [[x]] according to the [[overestimator]] $F$.  This
 algorithm is described in Appendix B of 0709.2092 and is proven e.g.~in
 1211.7204 and hep-ph/0606275.  Intuitively speaking, we overestimate the
 emission probability and can therefore set [[scale_max = scale]] if the
 emission is rejected.
 <<shower algorithms: procedures>>=
   subroutine generate_vetoed (x, overestimator, true_function, &
          sudakov, inverse_sudakov, scale_min)
     real(default), dimension(:), intent(out) :: x
     !class(rng_t), intent(inout) :: rng
     procedure(XXX_function), pointer, intent(in) :: overestimator, true_function
     procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov
     real(default), intent(in) :: scale_min
     real(default) :: random, scale_max, scale
     scale_max = inverse_sudakov (one)
     do while (scale_max > scale_min)
        !call rng%generate (random)
        scale = inverse_sudakov (random * sudakov (scale_max))
        call generate_on_hypersphere (x, overestimator, scale)
        !call rng%generate (random)
        if (random < true_function (x) / overestimator (x)) then
           return !!! accept x
        end if
        scale_max = scale
     end do
   end subroutine generate_vetoed
 
 @ %def generate_vetoed
 @
 <<shower algorithms: procedures>>=
   subroutine generate_on_hypersphere (x, overestimator, scale)
     real(default), dimension(:), intent(out) :: x
     procedure(XXX_function), pointer, intent(in) :: overestimator
     real(default), intent(in) :: scale
     call msg_bug ("generate_on_hypersphere: not implemented")
   end subroutine generate_on_hypersphere
 
 @ %def generate_on_hypersphere
 @
 <<shower algorithms: interfaces>>=
   interface
     pure function XXX_function (x)
       import
       real(default) :: XXX_function
       real(default), dimension(:), intent(in) :: x
     end function XXX_function
   end interface
   interface
     pure function sudakov_p (x)
       import
       real(default) :: sudakov_p
       real(default), intent(in) :: x
     end function sudakov_p
   end interface
 @
 \subsection{Unit tests}
 (Currently unused.)
 <<XXX shower algorithms: public>>=
   public :: shower_algorithms_test
 <<XXX shower algorithms: tests>>=
   subroutine shower_algorithms_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<shower algorithms: execute tests>>
   end subroutine shower_algorithms_test
 
 @ %def shower_algorithms_test
 @
 \subsubsection{Splitting functions}
 <<XXX shower algorithms: execute tests>>=
   call test (shower_algorithms_1, "shower_algorithms_1", &
        "veto technique", &
        u, results)
 <<XXX shower algorithms: tests>>=
   subroutine shower_algorithms_1 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: shower_algorithms_1"
     write (u, "(A)")  "*   Purpose: check veto technique"
     write (u, "(A)")
 
     write (u, "(A)")  "* Splitting functions:"
     write (u, "(A)")
 
     !call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)))
     !call assert (u, nearly_equal ( &
          !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1),
          !p_qqg (z))
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: shower_algorithms_1"
 
   end subroutine shower_algorithms_1
 
 @ %def shower_algorithms_1
Index: trunk/src/physics/Makefile.am
===================================================================
--- trunk/src/physics/Makefile.am	(revision 8766)
+++ trunk/src/physics/Makefile.am	(revision 8767)
@@ -1,202 +1,203 @@
 ## Makefile.am -- Makefile for WHIZARD
 ##
 ## Process this file with automake to produce Makefile.in
 #
 # Copyright (C) 1999-2021 by
 #     Wolfgang Kilian <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     with contributions from
 #     cf. main AUTHORS file
 #
 # WHIZARD is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2, or (at your option)
 # any later version.
 #
 # WHIZARD is distributed in the hope that it will be useful, but
 # WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #
 ########################################################################
 
 ## The files in this directory implement physics definitions and functions
 ## for use in the WHIZARD generator.
 
 ## We create a library which is still to be combined with auxiliary libs.
 noinst_LTLIBRARIES = libphysics.la
 check_LTLIBRARIES = libphysics_ut.la
 
 libphysics_la_SOURCES = \
   physics_defs.f90 \
   c_particles.f90 \
   lorentz.f90 \
   phs_points.f90 \
   sm_physics.f90 \
   sm_qcd.f90 \
   sm_qed.f90 \
   shower_algorithms.f90
 
 libphysics_ut_la_SOURCES = \
   sm_physics_uti.f90 sm_physics_ut.f90 \
   sm_qcd_uti.f90 sm_qcd_ut.f90 \
+  sm_qed_uti.f90 sm_qed_ut.f90 \
   phs_points_uti.f90 phs_points_ut.f90
 
 ## Omitting this would exclude it from the distribution
 dist_noinst_DATA = physics.nw
 
 # Modules and installation
 # Dump module names into file Modules
 execmoddir = $(fmoddir)/whizard
 nodist_execmod_HEADERS = \
   ${libphysics_la_SOURCES:.f90=.$(FCMOD)}
 
 libphysics_Modules = \
   ${libphysics_la_SOURCES:.f90=} \
   ${libphysics_ut_la_SOURCES:.f90=}
 Modules: Makefile
 	@for module in $(libphysics_Modules); do \
           echo $$module >> $@.new; \
         done
 	@if diff $@ $@.new -q >/dev/null; then \
           rm $@.new; \
 	else \
           mv $@.new $@; echo "Modules updated"; \
         fi
 BUILT_SOURCES = Modules
 
 ## Fortran module dependencies
 # Get module lists from other directories
 module_lists = \
   ../basics/Modules \
   ../utilities/Modules \
   ../testing/Modules \
   ../system/Modules \
   ../combinatorics/Modules
 
 $(module_lists):
 	$(MAKE) -C `dirname $@` Modules
 
 Module_dependencies.sed: $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES)
 Module_dependencies.sed: $(module_lists)
 	@rm -f $@
 	echo 's/, *only:.*//' >> $@
 	echo 's/, *&//' >> $@
 	echo 's/, *.*=>.*//' >> $@
 	echo 's/$$/.lo/' >> $@
 	for list in $(module_lists); do \
 		dir="`dirname $$list`"; \
 		for mod in `cat $$list`; do \
 			echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
 		done \
 	done
 
 DISTCLEANFILES = Module_dependencies.sed
 
 # The following line just says
 #    include Makefile.depend
 # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
 @am__include@ @am__quote@Makefile.depend@am__quote@
 
 Makefile.depend: Module_dependencies.sed
 Makefile.depend: $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES)
 	@rm -f $@
 	for src in $^; do \
 	  module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
 	  grep '^ *use ' $$src \
 	    | grep -v '!NODEP!' \
 	    | sed -e 's/^ *use */'$$module'.lo: /' \
 	          -f Module_dependencies.sed; \
 	done > $@
 
 DISTCLEANFILES += Makefile.depend
 
 # Fortran90 module files are generated at the same time as object files
 .lo.$(FCMOD):
 	@:
 #	touch $@
 
 AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics
 
 
 ########################################################################
 ## Default Fortran compiler options
 
 ## Profiling
 if FC_USE_PROFILING
 AM_FCFLAGS += $(FCFLAGS_PROFILING)
 endif
 
 ## OpenMP
 if FC_USE_OPENMP
 AM_FCFLAGS += $(FCFLAGS_OPENMP)
 endif
 
 # MPI
 if FC_USE_MPI
 AM_FCFLAGS += $(FCFLAGS_MPI)
 endif
 
 ########################################################################
 ## Non-standard targets and dependencies
 
 ## (Re)create F90 sources from NOWEB source.
 if NOWEB_AVAILABLE
 
 PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
 POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
 
 physics.stamp: $(PRELUDE) $(srcdir)/physics.nw $(POSTLUDE)
 	@rm -f physics.tmp
 	@touch physics.tmp
 	for src in $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES); do \
 	  $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
         done
 	@mv -f physics.tmp physics.stamp
 
 $(libphysics_la_SOURCES) $(libphysics_ut_la_SOURCES): physics.stamp
 ## Recover from the removal of $@
 	@if test -f $@; then :; else \
 	  rm -f physics.stamp; \
 	  $(MAKE) $(AM_MAKEFLAGS) physics.stamp; \
 	fi
 
 endif
 
 
 ########################################################################
 ## Non-standard cleanup tasks
 ## Remove sources that can be recreated using NOWEB
 if NOWEB_AVAILABLE
 maintainer-clean-noweb:
 	-rm -f *.f90 *.c
 endif
 .PHONY: maintainer-clean-noweb
 
 ## Remove those sources also if builddir and srcdir are different
 if NOWEB_AVAILABLE
 clean-noweb:
 	test "$(srcdir)" != "." && rm -f *.f90 *.c || true
 endif
 .PHONY: clean-noweb
 
 ## Remove F90 module files
 clean-local: clean-noweb
 	-rm -f physics.stamp physics.tmp
 	-rm -f *.$(FCMOD)
 if FC_SUBMODULES
 	-rm -f *.smod
 endif
 
 ## Remove backup files
 maintainer-clean-backup:
 	-rm -f *~
 .PHONY: maintainer-clean-backup
 
 ## Register additional clean targets
 maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/main/main.nw
===================================================================
--- trunk/src/main/main.nw	(revision 8766)
+++ trunk/src/main/main.nw	(revision 8767)
@@ -1,2313 +1,2322 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD main code as NOWEB source
 \includemodulegraph{main}
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Main Program}
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Tools for the command line}
 
 We do not intent to be very smart here, but this module provides a few
 small tools that simplify dealing with the command line.
 
 The [[unquote_value]] subroutine handles an option value that begins with a
 single/double quote character.  It swallows extra option strings until it
 finds a value that ends with another quote character.  The returned string
 consists of all argument strings between quotes, concatenated by blanks (with
 a leading blank).  Note that more complex patterns, such as quoted or embedded
 quotes, or multiple blanks, are not accounted for.
 <<[[cmdline_options.f90]]>>=
 <<File header>>
 
 module cmdline_options
 
 <<Use strings>>
   use diagnostics
 
 <<Standard module head>>
 
   public :: init_options
   public :: no_option_value
   public :: get_option_value
 
 <<Main: cmdline arg len declaration>>
 
   abstract interface
      subroutine msg
      end subroutine msg
   end interface
 
   procedure (msg), pointer :: print_usage => null ()
 
 contains
 
   subroutine init_options (usage_msg)
     procedure (msg) :: usage_msg
     print_usage => usage_msg
   end subroutine init_options
 
   subroutine no_option_value (option, value)
     type(string_t), intent(in) :: option, value
     if (value /= "") then
        call msg_error (" Option '" // char (option) // "' should have no value")
     end if
   end subroutine no_option_value
 
   function get_option_value (i, option, value) result (string)
     type(string_t) :: string
     integer, intent(inout) :: i
     type(string_t), intent(in) :: option
     type(string_t), intent(in), optional :: value
     character(CMDLINE_ARG_LEN) :: arg_value
     integer :: arg_len, arg_status
     logical :: has_value
     if (present (value)) then
        has_value = value /= ""
     else
        has_value = .false.
     end if
     if (has_value) then
        call unquote_value (i, option, value, string)
     else
        i = i + 1
        call get_command_argument (i, arg_value, arg_len, arg_status)
        select case (arg_status)
        case (0)
        case (-1)
           call msg_error (" Option value truncated: '" // arg_value // "'")
        case default
           call print_usage ()
           call msg_fatal (" Option '" // char (option) // "' needs a value")
        end select
        select case (arg_value(1:1))
        case ("-")
           call print_usage ()
           call msg_fatal (" Option '" // char (option) // "' needs a value")
        end select
        call unquote_value (i, option, var_str (trim (arg_value)), string)
     end if
   end function get_option_value
 
   subroutine unquote_value (i, option, value, string)
     integer, intent(inout) :: i
     type(string_t), intent(in) :: option
     type(string_t), intent(in) :: value
     type(string_t), intent(out) :: string
     character(1) :: quote
     character(CMDLINE_ARG_LEN) :: arg_value
     integer :: arg_len, arg_status
     quote = extract (value, 1, 1)
     select case (quote)
     case ("'", '"')
        string = ""
        arg_value = extract (value, 2)
        arg_len = len_trim (value)
        APPEND_QUOTED: do
           if (extract (arg_value, arg_len, arg_len) == quote) then
              string = string // " " // extract (arg_value, 1, arg_len-1)
              exit APPEND_QUOTED
           else
              string = string // " " // trim (arg_value)
              i = i + 1
              call get_command_argument (i, arg_value, arg_len, arg_status)
              select case (arg_status)
              case (0)
              case (-1)
                 call msg_error (" Quoted option value truncated: '" &
                      // char (string) // "'")
              case default
                 call print_usage ()
                 call msg_fatal (" Option '" // char (option) &
                      // "': unterminated quoted value")
              end select
           end if
        end do APPEND_QUOTED
     case default
        string = value
     end select
   end subroutine unquote_value
 
 end module cmdline_options
 
 @ %def init_options
 @ %def no_option_value
 @ %def get_option_value
 @ %def cmdline_options
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Driver program}
 The main program handles command options, initializes the environment,
 and runs WHIZARD in a particular mode (interactive, file, standard
 input).
 
 This is also used in the C interface:
 <<Main: cmdline arg len declaration>>=
   integer, parameter :: CMDLINE_ARG_LEN = 1000
 @ %def CMDLINE_ARG_LEN
 @
 The actual main program:
 <<[[main.f90]]>>=
 <<File header>>
 
 program main
 
 <<Use strings>>
   use system_dependencies
   use diagnostics
   use ifiles
   use os_interface
   use rt_data, only: show_description_of_string, show_tex_descriptions
   use whizard
 
   use cmdline_options
   use features
 
 <<Use mpi f08>>
 
   implicit none
 
 <<Main: cmdline arg len declaration>>
 
 !!! (WK 02/2016) Interface for the separate external routine below
   interface
      subroutine print_usage ()
      end subroutine print_usage
   end interface
 
 ! Main program variable declarations
   character(CMDLINE_ARG_LEN) :: arg
   character(2) :: option
   type(string_t) :: long_option, value
   integer :: i, j, arg_len, arg_status
   logical :: look_for_options
   logical :: interactive
   logical :: banner
   type(string_t) :: job_id, files, this, model, default_lib, library, libraries
   type(string_t) :: logfile, query_string
   type(paths_t) :: paths
   type(string_t) :: pack_arg, unpack_arg
   type(string_t), dimension(:), allocatable :: pack_args, unpack_args
   type(string_t), dimension(:), allocatable :: tmp_strings
   logical :: rebuild_library
   logical :: rebuild_phs, rebuild_grids, rebuild_events
   logical :: recompile_library
   type(ifile_t) :: commands
   type(string_t) :: command, cmdfile
   integer :: cmdfile_unit
   logical :: cmdfile_exists
 
   type(whizard_options_t), allocatable :: options
   type(whizard_t), allocatable, target :: whizard_instance
 
   ! Exit status
   logical :: quit = .false.
   integer :: quit_code = 0
 
   ! Initial values
   look_for_options = .true.
   interactive = .false.
   job_id = ""
   files = ""
   model = "SM"
   default_lib = "default_lib"
   library = ""
   libraries = ""
   banner = .true.
   logging = .true.
   msg_level = RESULT
   logfile = "whizard.log"
   rebuild_library = .false.
   rebuild_phs = .false.
   rebuild_grids = .false.
   rebuild_events = .false.
   recompile_library = .false.
   call paths_init (paths)
 
 <<Main: MPI init>>
 
   ! Read and process options
   call init_options (print_usage)
   i = 0
   SCAN_CMDLINE: do
      i = i + 1
      call get_command_argument (i, arg, arg_len, arg_status)
      select case (arg_status)
      case (0)
      case (-1)
         call msg_error (" Command argument truncated: '" // arg // "'")
      case default
         exit SCAN_CMDLINE
      end select
      if (look_for_options) then
         select case (arg(1:2))
         case ("--")
            value = trim (arg)
            call split (value, long_option, "=")
            select case (char (long_option))
            case ("--version")
               call no_option_value (long_option, value)
               call print_version (); stop
            case ("--help")
               call no_option_value (long_option, value)
               call print_usage (); stop
            case ("--prefix")
               paths%prefix = get_option_value (i, long_option, value)
               cycle scan_cmdline
            case ("--exec-prefix")
               paths%exec_prefix = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--bindir")
               paths%bindir = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--libdir")
               paths%libdir = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--includedir")
               paths%includedir = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--datarootdir")
               paths%datarootdir = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--libtool")
               paths%libtool = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--lhapdfdir")
               paths%lhapdfdir = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--check")
               call print_usage ()
               call msg_fatal ("Option --check not supported &
                    &(for unit tests, run whizard_ut instead)")
            case ("--show-config")
               call no_option_value (long_option, value)
               call print_features (); stop
            case ("--execute")
               command = get_option_value (i, long_option, value)
               call ifile_append (commands, command)
               cycle SCAN_CMDLINE
            case ("--file")
               cmdfile = get_option_value (i, long_option, value)
               inquire (file=char(cmdfile), exist=cmdfile_exists)
               if (cmdfile_exists) then
                  open (newunit=cmdfile_unit, file=char(cmdfile), &
                       action="read", status="old")
                  call ifile_append (commands, cmdfile_unit)
                  close (cmdfile_unit)
               else
                  call msg_error &
                       ("Sindarin file '" // char (cmdfile) // "' not found")
               end if
               cycle SCAN_CMDLINE
            case ("--interactive")
               call no_option_value (long_option, value)
               interactive = .true.
               cycle SCAN_CMDLINE
            case ("--job-id")
               job_id = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--library")
               library = get_option_value (i, long_option, value)
               libraries = libraries // " " // library
               cycle SCAN_CMDLINE
            case ("--no-library")
               call no_option_value (long_option, value)
               default_lib = ""
               library = ""
               libraries = ""
               cycle SCAN_CMDLINE
            case ("--localprefix")
               paths%localprefix = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--logfile")
               logfile = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--no-logfile")
               call no_option_value (long_option, value)
               logfile = ""
               cycle SCAN_CMDLINE
            case ("--logging")
               call no_option_value (long_option, value)
               logging = .true.
               cycle SCAN_CMDLINE
            case ("--no-logging")
               call no_option_value (long_option, value)
               logging = .false.
               cycle SCAN_CMDLINE
            case ("--query")
               call no_option_value (long_option, value)
               query_string = get_option_value (i, long_option, value)
               call show_description_of_string (query_string)
               call exit (0)
            case ("--generate-variables-tex")
               call no_option_value (long_option, value)
               call show_tex_descriptions ()
               call exit (0)
            case ("--debug")
               call no_option_value (long_option, value)
               call set_debug_levels (get_option_value (i, long_option, value))
               cycle SCAN_CMDLINE
            case ("--debug2")
               call no_option_value (long_option, value)
               call set_debug2_levels (get_option_value (i, long_option, value))
               cycle SCAN_CMDLINE
            case ("--single-event")
               call no_option_value (long_option, value)
               single_event = .true.
               cycle SCAN_CMDLINE
            case ("--banner")
               call no_option_value (long_option, value)
               banner = .true.
               cycle SCAN_CMDLINE
            case ("--no-banner")
               call no_option_value (long_option, value)
               banner = .false.
               cycle SCAN_CMDLINE
            case ("--pack")
               pack_arg = get_option_value (i, long_option, value)
               if (allocated (pack_args)) then
                  call move_alloc (from=pack_args, to=tmp_strings)
                  allocate (pack_args (size (tmp_strings)+1))
                  pack_args(1:size(tmp_strings)) = tmp_strings
               else
                  allocate (pack_args (1))
               end if
               pack_args(size(pack_args)) = pack_arg
               cycle SCAN_CMDLINE
            case ("--unpack")
               unpack_arg = get_option_value (i, long_option, value)
               if (allocated (unpack_args)) then
                  call move_alloc (from=unpack_args, to=tmp_strings)
                  allocate (unpack_args (size (tmp_strings)+1))
                  unpack_args(1:size(tmp_strings)) = tmp_strings
               else
                  allocate (unpack_args (1))
               end if
               unpack_args(size(unpack_args)) = unpack_arg
               cycle SCAN_CMDLINE
            case ("--model")
               model = get_option_value (i, long_option, value)
               cycle SCAN_CMDLINE
            case ("--no-model")
               call no_option_value (long_option, value)
               model = ""
               cycle SCAN_CMDLINE
            case ("--rebuild")
               call no_option_value (long_option, value)
               rebuild_library = .true.
               rebuild_phs = .true.
               rebuild_grids = .true.
               rebuild_events = .true.
               cycle SCAN_CMDLINE
            case ("--no-rebuild")
               call no_option_value (long_option, value)
               rebuild_library = .false.
               recompile_library = .false.
               rebuild_phs = .false.
               rebuild_grids = .false.
               rebuild_events = .false.
               cycle SCAN_CMDLINE
            case ("--rebuild-library")
               call no_option_value (long_option, value)
               rebuild_library = .true.
               cycle SCAN_CMDLINE
            case ("--rebuild-phase-space")
               call no_option_value (long_option, value)
               rebuild_phs = .true.
               cycle SCAN_CMDLINE
            case ("--rebuild-grids")
               call no_option_value (long_option, value)
               rebuild_grids = .true.
               cycle SCAN_CMDLINE
            case ("--rebuild-events")
               call no_option_value (long_option, value)
               rebuild_events = .true.
               cycle SCAN_CMDLINE
            case ("--recompile")
               call no_option_value (long_option, value)
               recompile_library = .true.
               rebuild_grids = .true.
               cycle SCAN_CMDLINE
            case ("--write-syntax-tables")
               call no_option_value (long_option, value)
         call init_syntax_tables ()
               call write_syntax_tables ()
               call final_syntax_tables ()
               stop
               cycle SCAN_CMDLINE
            case default
               call print_usage ()
               call msg_fatal ("Option '" // trim (arg) // "' not recognized")
            end select
         end select
         select case (arg(1:1))
         case ("-")
            j = 1
            if (len_trim (arg) == 1) then
               look_for_options = .false.
            else
               SCAN_SHORT_OPTIONS: do
                  j = j + 1
                  if (j > len_trim (arg)) exit SCAN_SHORT_OPTIONS
                  option = "-" // arg(j:j)
                  select case (option)
                  case ("-V")
                     call print_version (); stop
                  case ("-?", "-h")
                     call print_usage (); stop
                  case ("-e")
                     command = get_option_value (i, var_str (option))
                     call ifile_append (commands, command)
                     cycle SCAN_CMDLINE
                  case ("-f")
                     cmdfile = get_option_value (i, var_str (option))
                     inquire (file=char(cmdfile), exist=cmdfile_exists)
                     if (cmdfile_exists) then
                        open (newunit=cmdfile_unit, file=char(cmdfile), &
                             action="read", status="old")
                        call ifile_append (commands, cmdfile_unit)
                        close (cmdfile_unit)
                     else
                        call msg_error ("Sindarin file '" &
                             // char (cmdfile) // "' not found")
                     end if
                     cycle SCAN_CMDLINE
                  case ("-i")
                     interactive = .true.
                     cycle SCAN_SHORT_OPTIONS
                  case ("-J")
                     if (j == len_trim (arg)) then
                        job_id = get_option_value (i, var_str (option))
                     else
                        job_id = trim (arg(j+1:))
                     end if
                     cycle SCAN_CMDLINE
                  case ("-l")
                     if (j == len_trim (arg)) then
                        library = get_option_value (i, var_str (option))
                     else
                        library = trim (arg(j+1:))
                     end if
                     libraries = libraries // " " // library
                     cycle SCAN_CMDLINE
                  case ("-L")
                     if (j == len_trim (arg)) then
                        logfile = get_option_value (i, var_str (option))
                     else
                        logfile = trim (arg(j+1:))
                     end if
                     cycle SCAN_CMDLINE
                  case ("-m")
                     if (j < len_trim (arg))  call msg_fatal &
                          ("Option '" // option // "' needs a value")
                     model = get_option_value (i, var_str (option))
                     cycle SCAN_CMDLINE
                  case ("-q")
                     call no_option_value (long_option, value)
                     query_string = get_option_value (i, long_option, value)
                     call show_description_of_string (query_string)
                     call exit (0)
                  case ("-r")
                     rebuild_library = .true.
                     rebuild_phs = .true.
                     rebuild_grids = .true.
                     rebuild_events = .true.
                     cycle SCAN_SHORT_OPTIONS
                  case default
                     call print_usage ()
                     call msg_fatal &
                          ("Option '" // option // "' not recognized")
                  end select
               end do SCAN_SHORT_OPTIONS
            end if
         case default
            files = files // " " // trim (arg)
         end select
      else
         files = files // " " // trim (arg)
      end if
   end do SCAN_CMDLINE
 
   ! Overall initialization
   if (logfile /= "")  call logfile_init (logfile)
   if (banner)  call msg_banner ()
 
    allocate (options)
    allocate (whizard_instance)
 
    if (.not. quit) then
 
       ! Set options and initialize the whizard object
       options%job_id = job_id
       if (allocated (pack_args)) then
          options%pack_args = pack_args
       else
          allocate (options%pack_args (0))
       end if
       if (allocated (unpack_args)) then
          options%unpack_args = unpack_args
       else
          allocate (options%unpack_args (0))
       end if
       options%preload_model = model
       options%default_lib = default_lib
       options%preload_libraries = libraries
       options%rebuild_library = rebuild_library
       options%recompile_library = recompile_library
       options%rebuild_phs = rebuild_phs
       options%rebuild_grids = rebuild_grids
       options%rebuild_events = rebuild_events
     <<Main: dependent flags>>
 
       call whizard_instance%init (options, paths, logfile)
 
       call mask_term_signals ()
 
    end if
 
    ! Run commands given on the command line
    if (.not. quit .and. ifile_get_length (commands) > 0) then
       call whizard_instance%process_ifile (commands, quit, quit_code)
    end if
 
    if (.not. quit) then
       ! Process commands from standard input
       if (.not. interactive .and. files == "") then
          call whizard_instance%process_stdin (quit, quit_code)
 
          ! ... or process commands from file
       else
          files = trim (adjustl (files))
          SCAN_FILES: do while (files /= "")
             call split (files, this, " ")
             call whizard_instance%process_file (this, quit, quit_code)
             if (quit)  exit SCAN_FILES
          end do SCAN_FILES
 
       end if
   end if
 
   ! Enter an interactive shell if requested
   if (.not. quit .and. interactive) then
      call whizard_instance%shell (quit_code)
   end if
 
   ! Overall finalization
   call ifile_final (commands)
 
   deallocate (options)
 
   call whizard_instance%final ()
   deallocate (whizard_instance)
 
 <<Main: MPI finalize>>
 
   call terminate_now_if_signal ()
   call release_term_signals ()
   call msg_terminate (quit_code = quit_code)
 
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 contains
 
   subroutine print_version ()
     print "(A)", "WHIZARD " // WHIZARD_VERSION
     print "(A)", "Copyright (C) 1999-2021 Wolfgang Kilian, Thorsten Ohl, Juergen Reuter"
     print "(A)", "              ---------------------------------------                "
     print "(A)", "This is free software; see the source for copying conditions.  There is NO"
     print "(A)", "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
     print *
   end subroutine print_version
 
 end program main
 
 !!! (WK 02/2016)
 !!! Separate subroutine, because this becomes a procedure pointer target
 !!! Internal procedures as targets are not supported by some compilers.
 
   subroutine print_usage ()
     use system_dependencies, only: WHIZARD_VERSION
     print "(A)", "WHIZARD " // WHIZARD_VERSION
     print "(A)", "Usage: whizard [OPTIONS] [FILE]"
     print "(A)", "Run WHIZARD with the command list taken from FILE(s)"
     print "(A)", "Options for resetting default directories and tools" &
             // "(GNU naming conventions):"
     print "(A)", "    --prefix DIR"
     print "(A)", "    --exec-prefix DIR"
     print "(A)", "    --bindir DIR"
     print "(A)", "    --libdir DIR"
     print "(A)", "    --includedir DIR"
     print "(A)", "    --datarootdir DIR"
     print "(A)", "    --libtool LOCAL_LIBTOOL"
     print "(A)", "    --lhapdfdir DIR   (PDF sets directory)"
     print "(A)", "Other options:"
     print "(A)", "-h, --help            display this help and exit"
     print "(A)", "    --banner          display banner at startup (default)"
     print "(A)", "    --debug AREA      switch on debug output for AREA."
     print "(A)", "                      AREA can be one of Whizard's src dirs or 'all'"
     print "(A)", "    --debug2 AREA     switch on more verbose debug output for AREA."
     print "(A)", "    --single-event    only compute one phase-space point (for debugging)"
     print "(A)", "-e, --execute CMDS    execute SINDARIN CMDS before reading FILE(s)"
     print "(A)", "-f, --file CMDFILE    execute SINDARIN from CMDFILE before reading FILE(s)"
     print "(A)", "-i, --interactive     run interactively after reading FILE(s)"
     print "(A)", "-J, --job-id STRING   set job ID to STRING (default: empty)"
     print "(A)", "-l, --library LIB     preload process library NAME"
     print "(A)", "    --localprefix DIR"
     print "(A)", "                      search in DIR for local models (default: ~/.whizard)"
     print "(A)", "-L, --logfile FILE    write log to FILE (default: 'whizard.log'"
     print "(A)", "    --logging         switch on logging at startup (default)"
     print "(A)", "-m, --model NAME      preload model NAME (default: 'SM')"
     print "(A)", "    --no-banner       do not display banner at startup"
     print "(A)", "    --no-library      do not preload process library"
     print "(A)", "    --no-logfile      do not write a logfile"
     print "(A)", "    --no-logging      switch off logging at startup"
     print "(A)", "    --no-model        do not preload a model"
     print "(A)", "    --no-rebuild      do not force rebuilding"
     print "(A)", "    --pack DIR        tar/gzip DIR after job"
     print "(A)", "-q, --query VARIABLE  display documentation of VARIABLE"
     print "(A)", "-r, --rebuild         rebuild all (see below)"
     print "(A)", "    --rebuild-library"
     print "(A)", "                      rebuild process code library"
     print "(A)", "    --rebuild-phase-space"
     print "(A)", "                      rebuild phase-space configuration"
     print "(A)", "    --rebuild-grids   rebuild integration grids"
     print "(A)", "    --rebuild-events  rebuild event samples"
     print "(A)", "    --recompile       recompile process code"
     print "(A)", "    --show-config     show build-time configuration"
     print "(A)", "    --unpack FILE     untar/gunzip FILE before job"
     print "(A)", "-V, --version         output version information and exit"
     print "(A)", "    --write-syntax-tables"
     print "(A)", "                      write the internal syntax tables to files and exit"
     print "(A)", "-                     further options are taken as filenames"
     print *
     print "(A)", "With no FILE, read standard input."
   end subroutine print_usage
 
 @ %def main
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Driver program for the unit tests}
 This is a variant of the above main program that takes unit-test names
 as command-line options and runs those tests.
 <<[[main_ut.f90]]>>=
 <<File header>>
 
 program main_ut
 
 <<Use strings>>
   use unit_tests
   use io_units
   use system_dependencies
   use diagnostics
   use os_interface
 
   use cmdline_options
 
   use model_testbed !NODEP!
 <<Use mpi f08>>
 
 <<Main: use tests>>
 
   implicit none
 
 <<Main: cmdline arg len declaration>>
 
 !!! (WK 02/2016) Interface for the separate external routine below
   interface
      subroutine print_usage ()
      end subroutine print_usage
   end interface
 
   ! Main program variable declarations
   character(CMDLINE_ARG_LEN) :: arg
   character(2) :: option
   type(string_t) :: long_option, value
   integer :: i, j, arg_len, arg_status
   logical :: look_for_options
   logical :: banner
   type(string_t) :: check, checks
   type(test_results_t) :: test_results
   logical :: success
 
   ! Exit status
   integer :: quit_code = 0
 
   ! Initial values
   look_for_options = .true.
   banner = .true.
   logging = .false.
   msg_level = RESULT
   check = ""
   checks = ""
 
 <<Main: MPI init>>
 
   ! Read and process options
   call init_options (print_usage)
   i = 0
   SCAN_CMDLINE: do
      i = i + 1
      call get_command_argument (i, arg, arg_len, arg_status)
      select case (arg_status)
      case (0)
      case (-1)
         call msg_error (" Command argument truncated: '" // arg // "'")
      case default
         exit SCAN_CMDLINE
      end select
      if (look_for_options) then
         select case (arg(1:2))
         case ("--")
            value = trim (arg)
            call split (value, long_option, "=")
            select case (char (long_option))
            case ("--version")
               call no_option_value (long_option, value)
               call print_version (); stop
            case ("--help")
               call no_option_value (long_option, value)
               call print_usage (); stop
            case ("--banner")
               call no_option_value (long_option, value)
               banner = .true.
               cycle SCAN_CMDLINE
            case ("--no-banner")
               call no_option_value (long_option, value)
               banner = .false.
               cycle SCAN_CMDLINE
            case ("--check")
               check = get_option_value (i, long_option, value)
               checks = checks // " " // check
               cycle SCAN_CMDLINE
            case ("--debug")
               call no_option_value (long_option, value)
               call set_debug_levels (get_option_value (i, long_option, value))
               cycle SCAN_CMDLINE
            case ("--debug2")
               call no_option_value (long_option, value)
               call set_debug2_levels (get_option_value (i, long_option, value))
               cycle SCAN_CMDLINE
            case default
               call print_usage ()
               call msg_fatal ("Option '" // trim (arg) // "' not recognized")
            end select
         end select
         select case (arg(1:1))
         case ("-")
            j = 1
            if (len_trim (arg) == 1) then
               look_for_options = .false.
            else
               SCAN_SHORT_OPTIONS: do
                  j = j + 1
                  if (j > len_trim (arg)) exit SCAN_SHORT_OPTIONS
                  option = "-" // arg(j:j)
                  select case (option)
                  case ("-V")
                     call print_version (); stop
                  case ("-?", "-h")
                     call print_usage (); stop
                  case default
                     call print_usage ()
                     call msg_fatal &
                          ("Option '" // option // "' not recognized")
                  end select
               end do SCAN_SHORT_OPTIONS
            end if
         case default
            call print_usage ()
            call msg_fatal ("Option '" // trim (arg) // "' not recognized")
         end select
      else
         call print_usage ()
         call msg_fatal ("Option '" // trim (arg) // "' not recognized")
      end if
   end do SCAN_CMDLINE
 
   ! Overall initialization
   if (banner)  call msg_banner ()
 
    ! Run any self-checks (and no commands)
    if (checks /= "") then
       checks = trim (adjustl (checks))
       RUN_CHECKS: do while (checks /= "")
          call split (checks, check, " ")
          call whizard_check (check, test_results)
       end do RUN_CHECKS
       call test_results%wrapup (6, success)
       if (.not. success)  quit_code = 7
    end if
 
  <<Main: MPI finalize>>
 
    call msg_terminate (quit_code = quit_code)
 
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 contains
 
   subroutine print_version ()
     print "(A)", "WHIZARD " // WHIZARD_VERSION // " (unit test driver)"
     print "(A)", "Copyright (C) 1999-2021 Wolfgang Kilian, Thorsten Ohl, Juergen Reuter"
     print "(A)", "              ---------------------------------------                "
     print "(A)", "This is free software; see the source for copying conditions.  There is NO"
     print "(A)", "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
     print *
   end subroutine print_version
 
 <<Main: tests>>
 
 end program main_ut
 
 !!! (WK 02/2016)
 !!! Separate subroutine, because this becomes a procedure pointer target
 !!! Internal procedures as targets are not supported by some compilers.
 
   subroutine print_usage ()
     use system_dependencies, only: WHIZARD_VERSION
     print "(A)", "WHIZARD " // WHIZARD_VERSION // " (unit test driver)"
     print "(A)", "Usage: whizard_ut [OPTIONS] [FILE]"
     print "(A)", "Run WHIZARD unit tests as given on the command line"
     print "(A)", "Options:"
     print "(A)", "-h, --help            display this help and exit"
     print "(A)", "    --banner          display banner at startup (default)"
     print "(A)", "    --no-banner       do not display banner at startup"
     print "(A)", "    --debug AREA      switch on debug output for AREA."
     print "(A)", "                      AREA can be one of Whizard's src dirs or 'all'"
     print "(A)", "    --debug2 AREA     switch on more verbose debug output for AREA."
     print "(A)", "-V, --version         output version information and exit"
     print "(A)", "    --check TEST      run unit test TEST"
   end subroutine print_usage
 @ %def main_ut
 @
 <<Main: MPI init>>=
 @
 <<Main: MPI finalize>>=
 @
 @ MPI init.
 <<MPI: Main: MPI init>>=
   call MPI_init ()
 <<MPI: Main: MPI finalize>>=
   call MPI_finalize ()
 @ %def MPI_init MPI_finalize
 <<Main: dependent flags>>=
 @
 Every rebuild action is forbidden for the slave workers except
 [[rebuild_grids]], which is handled correctly inside the corresponding
 integration object.
 <<MPI: Main: dependent flags>>=
   if (.not. mpi_is_comm_master ()) then
     options%rebuild_library = .false.
     options%recompile_library = .false.
     options%rebuild_phs = .false.
     options%rebuild_events = .false.
   end if
 @
 \subsection{Self-tests}
 For those self-tests, we need some auxiliary routines that provide an
 enviroment.  The environment depends on things that are not available at the
 level of the module that we want to test.
 
 \subsubsection{Testbed for event I/O}
 This subroutine prepares a test process with a single event.  All objects are
 allocated via anonymous pointers, because we want to recover the pointers and
 delete the objects in a separate procedure.
 <<Main: tests>>=
   subroutine prepare_eio_test (event, unweighted, n_alt, sample_norm)
     use variables, only: var_list_t
     use model_data
     use process, only: process_t
     use instances, only: process_instance_t
     use processes_ut, only: prepare_test_process
     use event_base
     use events
 
     class(generic_event_t), intent(inout), pointer :: event
     logical, intent(in), optional :: unweighted
     integer, intent(in), optional :: n_alt
     type(string_t), intent(in), optional :: sample_norm
     type(model_data_t), pointer :: model
     type(var_list_t) :: var_list
     type(string_t) :: sample_normalization
     type(process_t), pointer :: proc
     type(process_instance_t), pointer :: process_instance
 
     allocate (model)
     call model%init_test ()
 
     allocate (proc)
     allocate (process_instance)
 
     call prepare_test_process (proc, process_instance, model, &
          run_id = var_str ("run_test"))
     call process_instance%setup_event_data ()
 
     call model%final ()
     deallocate (model)
 
     allocate (event_t :: event)
     select type (event)
     type is (event_t)
        if (present (unweighted)) then
           call var_list%append_log (&
                var_str ("?unweighted"), unweighted, &
                intrinsic = .true.)
        else
           call var_list%append_log (&
                var_str ("?unweighted"), .true., &
                intrinsic = .true.)
        end if
        if (present (sample_norm)) then
           sample_normalization = sample_norm
        else
           sample_normalization = var_str ("auto")
        end if
        call var_list%append_string (&
             var_str ("$sample_normalization"), &
             sample_normalization, intrinsic = .true.)
        call event%basic_init (var_list, n_alt)
        call event%connect (process_instance, proc%get_model_ptr ())
        call var_list%final ()
     end select
 
   end subroutine prepare_eio_test
 
 @ %def prepare_eio_test
 @ Recover those pointers, finalize the objects and deallocate.
 <<Main: tests>>=
   subroutine cleanup_eio_test (event)
     use model_data
     use process, only: process_t
     use instances, only: process_instance_t
     use processes_ut, only: cleanup_test_process
     use event_base
     use events
 
     class(generic_event_t), intent(inout), pointer :: event
     type(process_t), pointer :: proc
     type(process_instance_t), pointer :: process_instance
 
     select type (event)
     type is (event_t)
        proc => event%get_process_ptr ()
        process_instance => event%get_process_instance_ptr ()
        call cleanup_test_process (proc, process_instance)
        deallocate (process_instance)
        deallocate (proc)
        call event%final ()
     end select
     deallocate (event)
 
   end subroutine cleanup_eio_test
 
 @ %def cleanup_eio_test_event
 @ Assign those procedures to appropriate pointers (module variables) in the
 [[eio_base]] module, so they can be called as if they were module procedures.
 <<Main: use tests>>=
   use eio_base_ut, only: eio_prepare_test
   use eio_base_ut, only: eio_cleanup_test
 <<Main: prepare testbed>>=
   eio_prepare_test => prepare_eio_test
   eio_cleanup_test => cleanup_eio_test
 @
 \subsubsection{Any Model}
 This procedure reads any model from file and, optionally, assigns a
 var-list pointer.  If the model pointer is still null, we allocate the model
 object first, with concrete type [[model_t]].  This is a service for modules
 which do just have access to the [[model_data_t]] base type.
 <<Main: tests>>=
   subroutine prepare_whizard_model (model, name, vars)
   <<Use strings>>
     use os_interface
     use model_data
     use var_base
     use models
     class(model_data_t), intent(inout), pointer :: model
     type(string_t), intent(in) :: name
     class(vars_t), pointer, intent(out), optional :: vars
     type(os_data_t) :: os_data
     call syntax_model_file_init ()
     call os_data%init ()
     if (.not. associated (model))  allocate (model_t :: model)
     select type (model)
     type is (model_t)
        call model%read (name // ".mdl", os_data)
        if (present (vars)) then
           vars => model%get_var_list_ptr ()
        end if
     end select
   end subroutine prepare_whizard_model
 
 @ %def prepare_whizard_model
 @ Cleanup after use.  Includes deletion of the model-file syntax.
 <<Main: tests>>=
   subroutine cleanup_whizard_model (model)
     use model_data
     use models
     class(model_data_t), intent(inout), target :: model
     call model%final ()
     call syntax_model_file_final ()
   end subroutine cleanup_whizard_model
 
 @ %def cleanup_whizard_model
 @ Assign those procedures to appropriate pointers (module variables) in the
 [[model_testbed]] module, so they can be called as if they were module
 procedures.
 <<Main: prepare testbed>>=
   prepare_model => prepare_whizard_model
   cleanup_model => cleanup_whizard_model
 @
 \subsubsection{Fallback model: hadrons}
 Some event format tests require the hadronic SM implementation, which
 has to be read from file.  We provide the functionality here, so the
 tests do not depend on model I/O.
 <<Main: tests>>=
   subroutine prepare_fallback_model (model)
     use model_data
     class(model_data_t), intent(inout), pointer :: model
     call prepare_whizard_model (model, var_str ("SM_hadrons"))
   end subroutine prepare_fallback_model
 
 @ %def prepare_fallback_model
 @ Assign those procedures to appropriate pointers (module variables) in the
 [[eio_base]] module, so they can be called as if they were module procedures.
 <<Main: use tests>>=
   use eio_base_ut, only: eio_prepare_fallback_model
   use eio_base_ut, only: eio_cleanup_fallback_model
 <<Main: prepare testbed>>=
   eio_prepare_fallback_model => prepare_fallback_model
   eio_cleanup_fallback_model => cleanup_model
 @
 \subsubsection{Access to the test random-number generator}
 This generator is not normally available for the dispatcher.  We assign an
 additional dispatch routine to the hook in the [[dispatch]] module
 which will be checked before the default rule.
 <<Main: use tests>>=
   use dispatch_rng, only: dispatch_rng_factory_fallback
   use dispatch_rng_ut, only: dispatch_rng_factory_test
 <<Main: prepare testbed>>=
   dispatch_rng_factory_fallback => dispatch_rng_factory_test
 @
 \subsubsection{Access to the test structure functions}
 These are not normally available for the dispatcher.  We assign an
 additional dispatch routine to the hook in the [[dispatch]] module
 which will be checked before the default rule.
 <<Main: use tests>>=
   use dispatch_beams, only: dispatch_sf_data_extra
   use dispatch_ut, only: dispatch_sf_data_test
 <<Main: prepare testbed>>=
   dispatch_sf_data_extra => dispatch_sf_data_test
 @
 \subsubsection{Procedure for Checking}
 This is for developers only, but needs a well-defined interface.
 <<Main: tests>>=
   subroutine whizard_check (check, results)
     type(string_t), intent(in) :: check
     type(test_results_t), intent(inout) :: results
     type(os_data_t) :: os_data
     integer :: u
     call os_data%init ()
     u = free_unit ()
     open (u, file="whizard_check." // char (check) // ".log", &
          action="write", status="replace")
     call msg_message (repeat ('=', 76), 0)
     call msg_message ("Running self-test: " // char (check), 0)
     call msg_message (repeat ('-', 76), 0)
   <<Main: prepare testbed>>
     select case (char (check))
   <<Main: test cases>>
     case ("all")
      <<Main: all tests>>
     case default
        call msg_fatal ("Self-test '" // char (check) // "' not implemented.")
     end select
     close (u)
   end subroutine whizard_check
 
 @ %def whizard_check
 @
 \subsection{Unit test references}
 \subsubsection{Formats}
 <<Main: use tests>>=
   use formats_ut, only: format_test
 <<Main: test cases>>=
   case ("formats")
      call format_test (u, results)
 <<Main: all tests>>=
   call format_test (u, results)
 @
 \subsubsection{Binary Tree}
 <<Main: use tests>>=
   use binary_tree_ut, only: binary_tree_test
 <<Main: test cases>>=
   case ("binary_tree")
      call binary_tree_test (u, results)
 <<Main: all tests>>=
   call binary_tree_test (u, results)
 @
 \subsubsection{Array List}
 <<Main: use tests>>=
   use array_list_ut, only: array_list_test
 <<Main: test cases>>=
   case ("array_list")
      call array_list_test (u, results)
 <<Main: all tests>>=
   call array_list_test (u, results)
 @
 \subsubsection{Iterator}
 <<Main: use tests>>=
   use iterator_ut, only: iterator_test
 <<Main: test cases>>=
   case ("iterator")
      call iterator_test (u, results)
 <<Main: all tests>>=
   call iterator_test (u, results)
 @
 \subsubsection{MD5}
 <<Main: use tests>>=
   use md5_ut, only: md5_test
 <<Main: test cases>>=
   case ("md5")
      call md5_test (u, results)
 <<Main: all tests>>=
   call md5_test (u, results)
 @
 \subsubsection{OS Interface}
 <<Main: use tests>>=
   use os_interface_ut, only: os_interface_test
 <<Main: test cases>>=
   case ("os_interface")
      call os_interface_test (u, results)
 <<Main: all tests>>=
   call os_interface_test (u, results)
 @
 \subsubsection{Sorting}
 <<Main: use tests>>=
   use sorting_ut, only: sorting_test
 <<Main: test cases>>=
   case ("sorting")
      call sorting_test (u, results)
 <<Main: all tests>>=
   call sorting_test (u, results)
 @
 \subsubsection{Grids}
 <<Main: use tests>>=
   use grids_ut, only: grids_test
 <<Main: test cases>>=
   case ("grids")
      call grids_test (u, results)
 <<Main: all tests>>=
   call grids_test (u, results)
 @
 \subsubsection{Solver}
 <<Main: use tests>>=
   use solver_ut, only: solver_test
 <<Main: test cases>>=
   case ("solver")
      call solver_test (u, results)
 <<Main: all tests>>=
   call solver_test (u, results)
 @
 \subsubsection{CPU Time}
 <<Main: use tests>>=
   use cputime_ut, only: cputime_test
 <<Main: test cases>>=
   case ("cputime")
      call cputime_test (u, results)
 <<Main: all tests>>=
   call cputime_test (u, results)
 @
 \subsubsection{PHS points}
 <<Main: use tests>>=
   use phs_points_ut, only: phs_points_test
 <<Main: test cases>>=
   case ("phs_points")
      call phs_points_test (u, results)
 <<Main: all tests>>=
   call phs_points_test (u, results)
 @
 \subsubsection{SM QCD}
 <<Main: use tests>>=
   use sm_qcd_ut, only: sm_qcd_test
 <<Main: test cases>>=
   case ("sm_qcd")
      call sm_qcd_test (u, results)
 <<Main: all tests>>=
   call sm_qcd_test (u, results)
 @
+\subsubsection{SM QED}
+<<Main: use tests>>=
+  use sm_qed_ut, only: sm_qed_test
+<<Main: test cases>>=
+  case ("sm_qed")
+     call sm_qed_test (u, results)
+<<Main: all tests>>=
+  call sm_qed_test (u, results)
+@
 \subsubsection{SM physics}
 <<Main: use tests>>=
   use sm_physics_ut, only: sm_physics_test
 <<Main: test cases>>=
   case ("sm_physics")
      call sm_physics_test (u, results)
 <<Main: all tests>>=
   call sm_physics_test (u, results)
 @
 \subsubsection{Lexers}
 <<Main: use tests>>=
   use lexers_ut, only: lexer_test
 <<Main: test cases>>=
   case ("lexers")
      call lexer_test (u, results)
 <<Main: all tests>>=
   call lexer_test (u, results)
 @
 \subsubsection{Parser}
 <<Main: use tests>>=
   use parser_ut, only: parse_test
 <<Main: test cases>>=
   case ("parser")
      call parse_test (u, results)
 <<Main: all tests>>=
   call parse_test (u, results)
 @
 \subsubsection{XML}
 <<Main: use tests>>=
   use xml_ut, only: xml_test
 <<Main: test cases>>=
   case ("xml")
      call xml_test (u, results)
 <<Main: all tests>>=
   call xml_test (u, results)
 @
 \subsubsection{Colors}
 <<Main: use tests>>=
   use colors_ut, only: color_test
 <<Main: test cases>>=
   case ("colors")
      call color_test (u, results)
 <<Main: all tests>>=
   call color_test (u, results)
 @
 \subsubsection{State matrices}
 <<Main: use tests>>=
   use state_matrices_ut, only: state_matrix_test
 <<Main: test cases>>=
   case ("state_matrices")
      call state_matrix_test (u, results)
 <<Main: all tests>>=
   call state_matrix_test (u, results)
 @
 \subsubsection{Analysis}
 <<Main: use tests>>=
   use analysis_ut, only: analysis_test
 <<Main: test cases>>=
   case ("analysis")
      call analysis_test (u, results)
 <<Main: all tests>>=
   call analysis_test (u, results)
 @
 \subsubsection{Particles}
 <<Main: use tests>>=
   use particles_ut, only: particles_test
 <<Main: test cases>>=
   case ("particles")
      call particles_test (u, results)
 <<Main: all tests>>=
   call particles_test (u, results)
 @
 \subsubsection{Models}
 <<Main: use tests>>=
   use models_ut, only: models_test
 <<Main: test cases>>=
   case ("models")
      call models_test (u, results)
 <<Main: all tests>>=
   call models_test (u, results)
 @
 \subsubsection{Auto Components}
 <<Main: use tests>>=
   use auto_components_ut, only: auto_components_test
 <<Main: test cases>>=
   case ("auto_components")
      call auto_components_test (u, results)
 <<Main: all tests>>=
   call auto_components_test (u, results)
 @
 \subsubsection{Radiation Generator}
 <<Main: use tests>>=
   use radiation_generator_ut, only: radiation_generator_test
 <<Main: test cases>>=
   case ("radiation_generator")
      call radiation_generator_test (u, results)
 <<Main: all tests>>=
   call radiation_generator_test (u, results)
 @
 \subsection{BLHA}
 <<Main: use tests>>=
   use blha_ut, only: blha_test
 <<Main: test cases>>=
   case ("blha")
      call blha_test (u, results)
 <<Main: all tests>>=
   call blha_test (u, results)
 @
 \subsubsection{Evaluators}
 <<Main: use tests>>=
   use evaluators_ut, only: evaluator_test
 <<Main: test cases>>=
   case ("evaluators")
      call evaluator_test (u, results)
 <<Main: all tests>>=
   call evaluator_test (u, results)
 @
 \subsubsection{Expressions}
 <<Main: use tests>>=
   use eval_trees_ut, only: expressions_test
 <<Main: test cases>>=
   case ("expressions")
      call expressions_test (u, results)
 <<Main: all tests>>=
   call expressions_test (u, results)
 @
 \subsubsection{Resonances}
 <<Main: use tests>>=
   use resonances_ut, only: resonances_test
 <<Main: test cases>>=
   case ("resonances")
      call resonances_test (u, results)
 <<Main: all tests>>=
   call resonances_test (u, results)
 @
 \subsubsection{PHS Trees}
 <<Main: use tests>>=
   use phs_trees_ut, only: phs_trees_test
 <<Main: test cases>>=
   case ("phs_trees")
      call phs_trees_test (u, results)
 <<Main: all tests>>=
   call phs_trees_test (u, results)
 @
 \subsubsection{PHS Forests}
 <<Main: use tests>>=
   use phs_forests_ut, only: phs_forests_test
 <<Main: test cases>>=
   case ("phs_forests")
      call phs_forests_test (u, results)
 <<Main: all tests>>=
   call phs_forests_test (u, results)
 @
 \subsubsection{Beams}
 <<Main: use tests>>=
   use beams_ut, only: beams_test
 <<Main: test cases>>=
   case ("beams")
      call beams_test (u, results)
 <<Main: all tests>>=
   call beams_test (u, results)
 @
 \subsubsection{$su(N)$ Algebra}
 <<Main: use tests>>=
   use su_algebra_ut, only: su_algebra_test
 <<Main: test cases>>=
   case ("su_algebra")
      call su_algebra_test (u, results)
 <<Main: all tests>>=
   call su_algebra_test (u, results)
 @
 \subsubsection{Bloch Vectors}
 <<Main: use tests>>=
   use bloch_vectors_ut, only: bloch_vectors_test
 <<Main: test cases>>=
   case ("bloch_vectors")
      call bloch_vectors_test (u, results)
 <<Main: all tests>>=
   call bloch_vectors_test (u, results)
 @
 \subsubsection{Polarizations}
 <<Main: use tests>>=
   use polarizations_ut, only: polarizations_test
 <<Main: test cases>>=
   case ("polarizations")
      call polarizations_test (u, results)
 <<Main: all tests>>=
   call polarizations_test (u, results)
 @
 \subsubsection{SF Aux}
 <<Main: use tests>>=
   use sf_aux_ut, only: sf_aux_test
 <<Main: test cases>>=
   case ("sf_aux")
      call sf_aux_test (u, results)
 <<Main: all tests>>=
   call sf_aux_test (u, results)
 @
 \subsubsection{SF Mappings}
 <<Main: use tests>>=
   use sf_mappings_ut, only: sf_mappings_test
 <<Main: test cases>>=
   case ("sf_mappings")
      call sf_mappings_test (u, results)
 <<Main: all tests>>=
   call sf_mappings_test (u, results)
 @
 \subsubsection{SF Base}
 <<Main: use tests>>=
   use sf_base_ut, only: sf_base_test
 <<Main: test cases>>=
   case ("sf_base")
      call sf_base_test (u, results)
 <<Main: all tests>>=
   call sf_base_test (u, results)
 @
 \subsubsection{SF PDF Builtin}
 <<Main: use tests>>=
   use sf_pdf_builtin_ut, only: sf_pdf_builtin_test
 <<Main: test cases>>=
   case ("sf_pdf_builtin")
      call sf_pdf_builtin_test (u, results)
 <<Main: all tests>>=
   call sf_pdf_builtin_test (u, results)
 @
 \subsubsection{SF LHAPDF}
 <<Main: use tests>>=
   use sf_lhapdf_ut, only: sf_lhapdf_test
 <<Main: test cases>>=
   case ("sf_lhapdf")
      call sf_lhapdf_test (u, results)
 <<Main: all tests>>=
   call sf_lhapdf_test (u, results)
 @
 \subsubsection{SF ISR}
 <<Main: use tests>>=
   use sf_isr_ut, only: sf_isr_test
 <<Main: test cases>>=
   case ("sf_isr")
      call sf_isr_test (u, results)
 <<Main: all tests>>=
   call sf_isr_test (u, results)
 @
 \subsubsection{SF EPA}
 <<Main: use tests>>=
   use sf_epa_ut, only: sf_epa_test
 <<Main: test cases>>=
   case ("sf_epa")
      call sf_epa_test (u, results)
 <<Main: all tests>>=
   call sf_epa_test (u, results)
 @
 \subsubsection{SF EWA}
 <<Main: use tests>>=
   use sf_ewa_ut, only: sf_ewa_test
 <<Main: test cases>>=
   case ("sf_ewa")
      call sf_ewa_test (u, results)
 <<Main: all tests>>=
   call sf_ewa_test (u, results)
 @
 \subsubsection{SF CIRCE1}
 <<Main: use tests>>=
   use sf_circe1_ut, only: sf_circe1_test
 <<Main: test cases>>=
   case ("sf_circe1")
      call sf_circe1_test (u, results)
 <<Main: all tests>>=
   call sf_circe1_test (u, results)
 @
 \subsubsection{SF CIRCE2}
 <<Main: use tests>>=
   use sf_circe2_ut, only: sf_circe2_test
 <<Main: test cases>>=
   case ("sf_circe2")
      call sf_circe2_test (u, results)
 <<Main: all tests>>=
   call sf_circe2_test (u, results)
 @
 \subsubsection{SF Gaussian}
 <<Main: use tests>>=
   use sf_gaussian_ut, only: sf_gaussian_test
 <<Main: test cases>>=
   case ("sf_gaussian")
      call sf_gaussian_test (u, results)
 <<Main: all tests>>=
   call sf_gaussian_test (u, results)
 @
 \subsubsection{SF Beam Events}
 <<Main: use tests>>=
   use sf_beam_events_ut, only: sf_beam_events_test
 <<Main: test cases>>=
   case ("sf_beam_events")
      call sf_beam_events_test (u, results)
 <<Main: all tests>>=
   call sf_beam_events_test (u, results)
 @
 \subsubsection{SF EScan}
 <<Main: use tests>>=
   use sf_escan_ut, only: sf_escan_test
 <<Main: test cases>>=
   case ("sf_escan")
      call sf_escan_test (u, results)
 <<Main: all tests>>=
   call sf_escan_test (u, results)
 @
 \subsubsection{PHS Base}
 <<Main: use tests>>=
   use phs_base_ut, only: phs_base_test
 <<Main: test cases>>=
   case ("phs_base")
      call phs_base_test (u, results)
 <<Main: all tests>>=
   call phs_base_test (u, results)
 @
 \subsubsection{PHS None}
 <<Main: use tests>>=
   use phs_none_ut, only: phs_none_test
 <<Main: test cases>>=
   case ("phs_none")
      call phs_none_test (u, results)
 <<Main: all tests>>=
   call phs_none_test (u, results)
 @
 \subsubsection{PHS Single}
 <<Main: use tests>>=
   use phs_single_ut, only: phs_single_test
 <<Main: test cases>>=
   case ("phs_single")
      call phs_single_test (u, results)
 <<Main: all tests>>=
   call phs_single_test (u, results)
 @
 \subsubsection{PHS Rambo}
 <<Main: use tests>>=
   use phs_rambo_ut, only: phs_rambo_test
 <<Main: test cases>>=
   case ("phs_rambo")
      call phs_rambo_test (u, results)
 <<Main: all tests>>=
   call phs_rambo_test (u, results)
 @
 \subsubsection{PHS Wood}
 <<Main: use tests>>=
   use phs_wood_ut, only: phs_wood_test
   use phs_wood_ut, only: phs_wood_vis_test
 <<Main: test cases>>=
   case ("phs_wood")
      call phs_wood_test (u, results)
   case ("phs_wood_vis")
      call phs_wood_vis_test (u, results)
 <<Main: all tests>>=
   call phs_wood_test (u, results)
   call phs_wood_vis_test (u, results)
 @
 \subsubsection{PHS FKS Generator}
 <<Main: use tests>>=
   use phs_fks_ut, only: phs_fks_generator_test
 <<Main: test cases>>=
   case ("phs_fks_generator")
      call phs_fks_generator_test (u, results)
 <<Main: all tests>>=
   call phs_fks_generator_test (u, results)
 @
 \subsubsection{FKS regions}
 <<Main: use tests>>=
   use fks_regions_ut, only: fks_regions_test
 <<Main: test cases>>=
   case ("fks_regions")
      call fks_regions_test (u, results)
 <<Main: all tests>>=
   call fks_regions_test (u, results)
 @
 \subsubsection{Real subtraction}
 <<Main: use tests>>=
   use real_subtraction_ut, only: real_subtraction_test
 <<Main: test cases>>=
   case ("real_subtraction")
      call real_subtraction_test (u, results)
 <<Main: all tests>>=
   call real_subtraction_test (u, results)
 @
 \subsubsection{RECOLA}
 <<Main: use tests>>=
   use prc_recola_ut, only: prc_recola_test
 <<Main: test cases>>=
   case ("prc_recola")
      call prc_recola_test (u, results)
 <<Main: all tests>>=
   call prc_recola_test (u, results)
 @
 \subsubsection{RNG Base}
 <<Main: use tests>>=
   use rng_base_ut, only: rng_base_test
 <<Main: test cases>>=
   case ("rng_base")
      call rng_base_test (u, results)
 <<Main: all tests>>=
   call rng_base_test (u, results)
 @
 \subsubsection{RNG Tao}
 <<Main: use tests>>=
   use rng_tao_ut, only: rng_tao_test
 <<Main: test cases>>=
   case ("rng_tao")
      call rng_tao_test (u, results)
 <<Main: all tests>>=
   call rng_tao_test (u, results)
 @
 \subsubsection{RNG Stream}
 <<Main: use tests>>=
   use rng_stream_ut, only: rng_stream_test
 <<Main: test cases>>=
   case ("rng_stream")
      call rng_stream_test (u, results)
 <<Main: all tests>>=
   call rng_stream_test (u, results)
 @
 \subsubsection{Selectors}
 <<Main: use tests>>=
   use selectors_ut, only: selectors_test
 <<Main: test cases>>=
   case ("selectors")
      call selectors_test (u, results)
 <<Main: all tests>>=
   call selectors_test (u, results)
 @
 \subsubsection{VEGAS}
 <<Main: use tests>>=
   use vegas_ut, only: vegas_test
 <<Main: test cases>>=
   case ("vegas")
      call vegas_test (u, results)
 <<Main: all tests>>=
   call vegas_test (u, results)
 @
 \subsubsection{VAMP2}
 <<Main: use tests>>=
   use vamp2_ut, only: vamp2_test
 <<Main: test cases>>=
   case ("vamp2")
      call vamp2_test (u, results)
 <<Main: all tests>>=
   call vamp2_test (u, results)
 @
 \subsubsection{MCI Base}
 <<Main: use tests>>=
   use mci_base_ut, only: mci_base_test
 <<Main: test cases>>=
   case ("mci_base")
      call mci_base_test (u, results)
 <<Main: all tests>>=
   call mci_base_test (u, results)
 @
 \subsubsection{MCI None}
 <<Main: use tests>>=
   use mci_none_ut, only: mci_none_test
 <<Main: test cases>>=
   case ("mci_none")
      call mci_none_test (u, results)
 <<Main: all tests>>=
   call mci_none_test (u, results)
 @
 \subsubsection{MCI Midpoint}
 <<Main: use tests>>=
   use mci_midpoint_ut, only: mci_midpoint_test
 <<Main: test cases>>=
   case ("mci_midpoint")
      call mci_midpoint_test (u, results)
 <<Main: all tests>>=
   call mci_midpoint_test (u, results)
 @
 \subsubsection{MCI VAMP}
 <<Main: use tests>>=
   use mci_vamp_ut, only: mci_vamp_test
 <<Main: test cases>>=
   case ("mci_vamp")
      call mci_vamp_test (u, results)
 <<Main: all tests>>=
   call mci_vamp_test (u, results)
 @
 \subsubsection{MCI VAMP2}
 <<Main: use tests>>=
   use mci_vamp2_ut, only: mci_vamp2_test
 <<Main: test cases>>=
   case ("mci_vamp2")
      call mci_vamp2_test (u, results)
 <<Main: all tests>>=
   call mci_vamp2_test (u, results)
 @
 \subsubsection{Integration Results}
 <<Main: use tests>>=
   use integration_results_ut, only: integration_results_test
 <<Main: test cases>>=
   case ("integration_results")
      call integration_results_test (u, results)
 <<Main: all tests>>=
   call integration_results_test (u, results)
 @
 \subsubsection{PRCLib Interfaces}
 <<Main: use tests>>=
   use prclib_interfaces_ut, only: prclib_interfaces_test
 <<Main: test cases>>=
   case ("prclib_interfaces")
      call prclib_interfaces_test (u, results)
 <<Main: all tests>>=
   call prclib_interfaces_test (u, results)
 @
 \subsubsection{Particle Specifiers}
 <<Main: use tests>>=
   use particle_specifiers_ut, only: particle_specifiers_test
 <<Main: test cases>>=
   case ("particle_specifiers")
      call particle_specifiers_test (u, results)
 <<Main: all tests>>=
   call particle_specifiers_test (u, results)
 @
 \subsubsection{Process Libraries}
 <<Main: use tests>>=
   use process_libraries_ut, only: process_libraries_test
 <<Main: test cases>>=
   case ("process_libraries")
      call process_libraries_test (u, results)
 <<Main: all tests>>=
   call process_libraries_test (u, results)
 @
 \subsubsection{PRCLib Stacks}
 <<Main: use tests>>=
   use prclib_stacks_ut, only: prclib_stacks_test
 <<Main: test cases>>=
   case ("prclib_stacks")
      call prclib_stacks_test (u, results)
 <<Main: all tests>>=
   call prclib_stacks_test (u, results)
 @
 \subsubsection{HepMC}
 <<Main: use tests>>=
   use hepmc_interface_ut, only: hepmc_interface_test
 <<Main: test cases>>=
   case ("hepmc")
      call hepmc_interface_test (u, results)
 <<Main: all tests>>=
   call hepmc_interface_test (u, results)
 @
 \subsubsection{LCIO}
 <<Main: use tests>>=
   use lcio_interface_ut, only: lcio_interface_test
 <<Main: test cases>>=
   case ("lcio")
      call lcio_interface_test (u, results)
 <<Main: all tests>>=
   call lcio_interface_test (u, results)
 @
 \subsubsection{Jets}
 <<Main: use tests>>=
   use jets_ut, only: jets_test
 <<Main: test cases>>=
   case ("jets")
      call jets_test (u, results)
 <<Main: all tests>>=
   call jets_test (u, results)
 @
 \subsection{LHA User Process WHIZARD}
 <<Main: use tests>>=
   use whizard_lha_ut, only: whizard_lha_test
 <<Main: test cases>>=
   case ("whizard_lha")
      call whizard_lha_test (u, results)
 <<Main: all tests>>=
   call whizard_lha_test (u, results)
 @
 \subsection{Pythia8}
 <<Main: use tests>>=
   use pythia8_ut, only: pythia8_test
 <<Main: test cases>>=
   case ("pythia8")
      call pythia8_test (u, results)
 <<Main: all tests>>=
   call pythia8_test (u, results)
 @
 \subsubsection{PDG Arrays}
 <<Main: use tests>>=
   use pdg_arrays_ut, only: pdg_arrays_test
 <<Main: test cases>>=
   case ("pdg_arrays")
      call pdg_arrays_test (u, results)
 <<Main: all tests>>=
   call pdg_arrays_test (u, results)
 @
 \subsubsection{interactions}
 <<Main: use tests>>=
   use interactions_ut, only: interaction_test
 <<Main: test cases>>=
   case ("interactions")
      call interaction_test (u, results)
 <<Main: all tests>>=
   call interaction_test (u, results)
 @
 \subsubsection{SLHA}
 <<Main: use tests>>=
   use slha_interface_ut, only: slha_test
 <<Main: test cases>>=
   case ("slha_interface")
      call slha_test (u, results)
 <<Main: all tests>>=
   call slha_test (u, results)
 @
 \subsubsection{Cascades}
 <<Main: use tests>>=
   use cascades_ut, only: cascades_test
 <<Main: test cases>>=
   case ("cascades")
      call cascades_test (u, results)
 <<Main: all tests>>=
   call cascades_test (u, results)
 @
 \subsubsection{Cascades2 lexer}
 <<Main: use tests>>=
   use cascades2_lexer_ut, only: cascades2_lexer_test
 <<Main: test cases>>=
   case ("cascades2_lexer")
      call cascades2_lexer_test (u, results)
 <<Main: all tests>>=
   call cascades2_lexer_test (u, results)
 @
 \subsubsection{Cascades2}
 <<Main: use tests>>=
   use cascades2_ut, only: cascades2_test
 <<Main: test cases>>=
   case ("cascades2")
      call cascades2_test (u, results)
 <<Main: all tests>>=
   call cascades2_test (u, results)
 @
 \subsubsection{PRC Test}
 <<Main: use tests>>=
   use prc_test_ut, only: prc_test_test
 <<Main: test cases>>=
   case ("prc_test")
      call prc_test_test (u, results)
 <<Main: all tests>>=
   call prc_test_test (u, results)
 @
 \subsubsection{PRC Template ME}
 <<Main: use tests>>=
   use prc_template_me_ut, only: prc_template_me_test
 <<Main: test cases>>=
   case ("prc_template_me")
      call prc_template_me_test (u, results)
 <<Main: all tests>>=
   call prc_template_me_test (u, results)
 @
 \subsubsection{PRC OMega}
 <<Main: use tests>>=
   use prc_omega_ut, only: prc_omega_test
   use prc_omega_ut, only: prc_omega_diags_test
 <<Main: test cases>>=
   case ("prc_omega")
      call prc_omega_test (u, results)
   case ("prc_omega_diags")
      call prc_omega_diags_test (u, results)
 <<Main: all tests>>=
   call prc_omega_test (u, results)
   call prc_omega_diags_test (u, results)
 @
 \subsubsection{Parton States}
 <<Main: use tests>>=
   use parton_states_ut, only: parton_states_test
 <<Main: test cases>>=
   case ("parton_states")
      call parton_states_test (u, results)
 <<Main: all tests>>=
   call parton_states_test (u, results)
 @
 \subsubsection{Subevt Expr}
 <<Main: use tests>>=
   use expr_tests_ut, only: subevt_expr_test
 <<Main: test cases>>=
   case ("subevt_expr")
      call subevt_expr_test (u, results)
 <<Main: all tests>>=
   call subevt_expr_test (u, results)
 @
 \subsubsection{Processes}
 <<Main: use tests>>=
   use processes_ut, only: processes_test
 <<Main: test cases>>=
   case ("processes")
      call processes_test (u, results)
 <<Main: all tests>>=
   call processes_test (u, results)
 @
 \subsubsection{Process Stacks}
 <<Main: use tests>>=
   use process_stacks_ut, only: process_stacks_test
 <<Main: test cases>>=
   case ("process_stacks")
      call process_stacks_test (u, results)
 <<Main: all tests>>=
   call process_stacks_test (u, results)
 @
 \subsubsection{Event Transforms}
 <<Main: use tests>>=
   use event_transforms_ut, only: event_transforms_test
 <<Main: test cases>>=
   case ("event_transforms")
      call event_transforms_test (u, results)
 <<Main: all tests>>=
   call event_transforms_test (u, results)
 @
 \subsubsection{Resonance Insertion Transform}
 <<Main: use tests>>=
   use resonance_insertion_ut, only: resonance_insertion_test
 <<Main: test cases>>=
   case ("resonance_insertion")
      call resonance_insertion_test (u, results)
 <<Main: all tests>>=
   call resonance_insertion_test (u, results)
 @
 \subsubsection{Recoil Kinematics}
 <<Main: use tests>>=
   use recoil_kinematics_ut, only: recoil_kinematics_test
 <<Main: test cases>>=
   case ("recoil_kinematics")
      call recoil_kinematics_test (u, results)
 <<Main: all tests>>=
   call recoil_kinematics_test (u, results)
 @
 \subsubsection{ISR Handler}
 <<Main: use tests>>=
   use isr_epa_handler_ut, only: isr_handler_test
 <<Main: test cases>>=
   case ("isr_handler")
      call isr_handler_test (u, results)
 <<Main: all tests>>=
   call isr_handler_test (u, results)
 @
 \subsubsection{EPA Handler}
 <<Main: use tests>>=
   use isr_epa_handler_ut, only: epa_handler_test
 <<Main: test cases>>=
   case ("epa_handler")
      call epa_handler_test (u, results)
 <<Main: all tests>>=
   call epa_handler_test (u, results)
 @
 \subsubsection{Decays}
 <<Main: use tests>>=
   use decays_ut, only: decays_test
 <<Main: test cases>>=
   case ("decays")
      call decays_test (u, results)
 <<Main: all tests>>=
   call decays_test (u, results)
 @
 \subsubsection{Shower}
 <<Main: use tests>>=
   use shower_ut, only: shower_test
 <<Main: test cases>>=
   case ("shower")
      call shower_test (u, results)
 <<Main: all tests>>=
   call shower_test (u, results)
 @
 \subsubsection{Events}
 <<Main: use tests>>=
   use events_ut, only: events_test
 <<Main: test cases>>=
   case ("events")
      call events_test (u, results)
 <<Main: all tests>>=
   call events_test (u, results)
 @
 \subsubsection{HEP Events}
 <<Main: use tests>>=
   use hep_events_ut, only: hep_events_test
 <<Main: test cases>>=
   case ("hep_events")
      call hep_events_test (u, results)
 <<Main: all tests>>=
   call hep_events_test (u, results)
 @
 \subsubsection{EIO Data}
 <<Main: use tests>>=
   use eio_data_ut, only: eio_data_test
 <<Main: test cases>>=
   case ("eio_data")
      call eio_data_test (u, results)
 <<Main: all tests>>=
   call eio_data_test (u, results)
 @
 \subsubsection{EIO Base}
 <<Main: use tests>>=
   use eio_base_ut, only: eio_base_test
 <<Main: test cases>>=
   case ("eio_base")
      call eio_base_test (u, results)
 <<Main: all tests>>=
   call eio_base_test (u, results)
 @
 \subsubsection{EIO Direct}
 <<Main: use tests>>=
   use eio_direct_ut, only: eio_direct_test
 <<Main: test cases>>=
   case ("eio_direct")
      call eio_direct_test (u, results)
 <<Main: all tests>>=
   call eio_direct_test (u, results)
 @
 \subsubsection{EIO Raw}
 <<Main: use tests>>=
   use eio_raw_ut, only: eio_raw_test
 <<Main: test cases>>=
   case ("eio_raw")
      call eio_raw_test (u, results)
 <<Main: all tests>>=
   call eio_raw_test (u, results)
 @
 \subsubsection{EIO Checkpoints}
 <<Main: use tests>>=
   use eio_checkpoints_ut, only: eio_checkpoints_test
 <<Main: test cases>>=
   case ("eio_checkpoints")
      call eio_checkpoints_test (u, results)
 <<Main: all tests>>=
   call eio_checkpoints_test (u, results)
 @
 \subsubsection{EIO LHEF}
 <<Main: use tests>>=
   use eio_lhef_ut, only: eio_lhef_test
 <<Main: test cases>>=
   case ("eio_lhef")
      call eio_lhef_test (u, results)
 <<Main: all tests>>=
   call eio_lhef_test (u, results)
 @
 \subsubsection{EIO HepMC}
 <<Main: use tests>>=
   use eio_hepmc_ut, only: eio_hepmc_test
 <<Main: test cases>>=
   case ("eio_hepmc")
      call eio_hepmc_test (u, results)
 <<Main: all tests>>=
   call eio_hepmc_test (u, results)
 @
 \subsubsection{EIO LCIO}
 <<Main: use tests>>=
   use eio_lcio_ut, only: eio_lcio_test
 <<Main: test cases>>=
   case ("eio_lcio")
      call eio_lcio_test (u, results)
 <<Main: all tests>>=
   call eio_lcio_test (u, results)
 @
 \subsubsection{EIO StdHEP}
 <<Main: use tests>>=
   use eio_stdhep_ut, only: eio_stdhep_test
 <<Main: test cases>>=
   case ("eio_stdhep")
      call eio_stdhep_test (u, results)
 <<Main: all tests>>=
   call eio_stdhep_test (u, results)
 @
 \subsubsection{EIO ASCII}
 <<Main: use tests>>=
   use eio_ascii_ut, only: eio_ascii_test
 <<Main: test cases>>=
   case ("eio_ascii")
      call eio_ascii_test (u, results)
 <<Main: all tests>>=
   call eio_ascii_test (u, results)
 @
 \subsubsection{EIO Weights}
 <<Main: use tests>>=
   use eio_weights_ut, only: eio_weights_test
 <<Main: test cases>>=
   case ("eio_weights")
      call eio_weights_test (u, results)
 <<Main: all tests>>=
   call eio_weights_test (u, results)
 @
 \subsubsection{EIO Dump}
 <<Main: use tests>>=
   use eio_dump_ut, only: eio_dump_test
 <<Main: test cases>>=
   case ("eio_dump")
      call eio_dump_test (u, results)
 <<Main: all tests>>=
   call eio_dump_test (u, results)
 @
 \subsubsection{Iterations}
 <<Main: use tests>>=
   use iterations_ut, only: iterations_test
 <<Main: test cases>>=
   case ("iterations")
      call iterations_test (u, results)
 <<Main: all tests>>=
   call iterations_test (u, results)
 @
 \subsubsection{Beam Structures}
 <<Main: use tests>>=
   use beam_structures_ut, only: beam_structures_test
 <<Main: test cases>>=
   case ("beam_structures")
      call beam_structures_test (u, results)
 <<Main: all tests>>=
   call beam_structures_test (u, results)
 @
 \subsubsection{RT Data}
 <<Main: use tests>>=
   use rt_data_ut, only: rt_data_test
 <<Main: test cases>>=
   case ("rt_data")
      call rt_data_test (u, results)
 <<Main: all tests>>=
   call rt_data_test (u, results)
 @
 \subsubsection{Dispatch}
 <<Main: use tests>>=
   use dispatch_ut, only: dispatch_test
 <<Main: test cases>>=
   case ("dispatch")
      call dispatch_test (u, results)
 <<Main: all tests>>=
   call dispatch_test (u, results)
 @
 \subsubsection{Dispatch RNG}
 <<Main: use tests>>=
   use dispatch_rng_ut, only: dispatch_rng_test
 <<Main: test cases>>=
   case ("dispatch_rng")
      call dispatch_rng_test (u, results)
 <<Main: all tests>>=
   call dispatch_rng_test (u, results)
 @
 \subsubsection{Dispatch MCI}
 <<Main: use tests>>=
   use dispatch_mci_ut, only: dispatch_mci_test
 <<Main: test cases>>=
   case ("dispatch_mci")
      call dispatch_mci_test (u, results)
 <<Main: all tests>>=
   call dispatch_mci_test (u, results)
 @
 \subsubsection{Dispatch PHS}
 <<Main: use tests>>=
   use dispatch_phs_ut, only: dispatch_phs_test
 <<Main: test cases>>=
   case ("dispatch_phs")
      call dispatch_phs_test (u, results)
 <<Main: all tests>>=
   call dispatch_phs_test (u, results)
 @
 \subsubsection{Dispatch transforms}
 <<Main: use tests>>=
   use dispatch_transforms_ut, only: dispatch_transforms_test
 <<Main: test cases>>=
   case ("dispatch_transforms")
      call dispatch_transforms_test (u, results)
 <<Main: all tests>>=
   call dispatch_transforms_test (u, results)
 @
 \subsubsection{Shower partons}
 <<Main: use tests>>=
   use shower_base_ut, only: shower_base_test
 <<Main: test cases>>=
   case ("shower_base")
      call shower_base_test (u, results)
 <<Main: all tests>>=
   call shower_base_test (u, results)
 @
 \subsubsection{Process Configurations}
 <<Main: use tests>>=
   use process_configurations_ut, only: process_configurations_test
 <<Main: test cases>>=
   case ("process_configurations")
      call process_configurations_test (u, results)
 <<Main: all tests>>=
   call process_configurations_test (u, results)
 @
 \subsubsection{Compilations}
 <<Main: use tests>>=
   use compilations_ut, only: compilations_test
   use compilations_ut, only: compilations_static_test
 <<Main: test cases>>=
   case ("compilations")
      call compilations_test (u, results)
   case ("compilations_static")
      call compilations_static_test (u, results)
 <<Main: all tests>>=
   call compilations_test (u, results)
   call compilations_static_test (u, results)
 @
 \subsubsection{Integrations}
 <<Main: use tests>>=
   use integrations_ut, only: integrations_test
   use integrations_ut, only: integrations_history_test
 <<Main: test cases>>=
   case ("integrations")
      call integrations_test (u, results)
   case ("integrations_history")
      call integrations_history_test (u, results)
 <<Main: all tests>>=
   call integrations_test (u, results)
   call integrations_history_test (u, results)
 @
 \subsubsection{Event Streams}
 <<Main: use tests>>=
   use event_streams_ut, only: event_streams_test
 <<Main: test cases>>=
   case ("event_streams")
      call event_streams_test (u, results)
 <<Main: all tests>>=
   call event_streams_test (u, results)
 @
 \subsubsection{Restricted Subprocesses}
 <<Main: use tests>>=
   use restricted_subprocesses_ut, only: restricted_subprocesses_test
 <<Main: test cases>>=
   case ("restricted_subprocesses")
      call restricted_subprocesses_test (u, results)
 <<Main: all tests>>=
   call restricted_subprocesses_test (u, results)
 @
 \subsubsection{Simulations}
 <<Main: use tests>>=
   use simulations_ut, only: simulations_test
 <<Main: test cases>>=
   case ("simulations")
      call simulations_test (u, results)
 <<Main: all tests>>=
   call simulations_test (u, results)
 @
 \subsubsection{Commands}
 <<Main: use tests>>=
   use commands_ut, only: commands_test
 <<Main: test cases>>=
   case ("commands")
      call commands_test (u, results)
 <<Main: all tests>>=
   call commands_test (u, results)
 @
 \subsubsection{$ttV$ formfactors}
 <<Main: use tests>>=
   use ttv_formfactors_ut, only: ttv_formfactors_test
 <<Main: test cases>>=
   case ("ttv_formfactors")
      call ttv_formfactors_test (u, results)
 <<Main: all tests>>=
   call ttv_formfactors_test (u, results)
 @
 \subsubsection{API}
 <<Main: use tests>>=
   use api_ut, only: api_test
 <<Main: test cases>>=
   case ("api")
      call api_test (u, results)
 <<Main: all tests>>=
   call api_test (u, results)
 @
 \subsubsection{API/HepMC}
 <<Main: use tests>>=
   use api_hepmc_ut, only: api_hepmc_test
 <<Main: test cases>>=
   case ("api_hepmc")
      call api_hepmc_test (u, results)
 <<Main: all tests>>=
   call api_hepmc_test (u, results)
 @
 \subsubsection{API/LCIO}
 <<Main: use tests>>=
   use api_lcio_ut, only: api_lcio_test
 <<Main: test cases>>=
   case ("api_lcio")
      call api_lcio_test (u, results)
 <<Main: all tests>>=
   call api_lcio_test (u, results)
Index: trunk/src/beams/beams.nw
===================================================================
--- trunk/src/beams/beams.nw	(revision 8766)
+++ trunk/src/beams/beams.nw	(revision 8767)
@@ -1,25396 +1,25481 @@
 %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: beams and beam structure
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Beams}
 \includemodulegraph{beams}
 
 These modules implement beam configuration and beam structure, the
 latter in abstract terms.
 \begin{description}
 \item[beam\_structures]
   The [[beam_structure_t]] type is a messenger type that communicates
   the user settings to the \whizard\ core.
 \item[beams]
   Beam configuration.
 \item[sf\_aux]
   Tools for handling structure functions and splitting
 \item[sf\_mappings]
   Mapping functions, useful for structure function implementation
 \item[sf\_base]
   The abstract structure-function interaction and structure-function
   chain types.
 \end{description}
 
 These are the implementation modules, the concrete counterparts of
 [[sf_base]]:
 \begin{description}
 \item[sf\_isr]
   ISR structure function (photon radiation inclusive and resummed in
   collinear and IR regions).
 \item[sf\_epa]
   Effective Photon Approximation.
 \item[sf\_ewa]
   Effective $W$ (and $Z$) approximation.
 \item[sf\_escan]
   Energy spectrum that emulates a uniform energy scan.
 \item[sf\_gaussian]
   Gaussian beam spread
 \item[sf\_beam\_events]
   Beam-event generator that reads its input from an external file.
 \item[sf\_circe1]
   CIRCE1 beam spectra for electrons and photons.
 \item[sf\_circe2]
   CIRCE2 beam spectra for electrons and photons.
 \item[hoppet\_interface]
   Support for $b$-quark matching, addon to PDF modules.
 \item[sf\_pdf\_builtin]
   Direct support for selected hadron PDFs.
 \item[sf\_lhapdf]
   LHAPDF library support.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Beam structure}
 
 This module stores the beam structure definition as it is declared in
 the SINDARIN script.  The structure definition is not analyzed, just
 recorded for later use.
 
 We do not capture any numerical parameters, just names of particles and
 structure functions.
 <<[[beam_structures.f90]]>>=
 <<File header>>
 
 module beam_structures
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use diagnostics
   use lorentz
   use polarizations
 
 <<Standard module head>>
 
 <<Beam structures: public>>
 
 <<Beam structures: types>>
 
 <<Beam structures: interfaces>>
 
 contains
 
 <<Beam structures: procedures>>
 
 end module beam_structures
 @ %def beam_structures
 @
 \subsection{Beam structure elements}
 An entry in a beam-structure record consists of a string
 that denotes a type of structure function.
 <<Beam structures: types>>=
   type :: beam_structure_entry_t
      logical :: is_valid = .false.
      type(string_t) :: name
    contains
    <<Beam structures: beam structure entry: TBP>>
   end type beam_structure_entry_t
 
 @ %def beam_structure_entry_t
 @ Output.
 <<Beam structures: beam structure entry: TBP>>=
   procedure :: to_string => beam_structure_entry_to_string
 <<Beam structures: procedures>>=
   function beam_structure_entry_to_string (object) result (string)
     class(beam_structure_entry_t), intent(in) :: object
     type(string_t) :: string
     if (object%is_valid) then
        string = object%name
     else
        string = "none"
     end if
   end function beam_structure_entry_to_string
 
 @ %def beam_structure_entry_to_string
 @
 A record in the beam-structure sequence denotes either a
 structure-function entry, a pair of such entries, or a pair spectrum.
 <<Beam structures: types>>=
   type :: beam_structure_record_t
      type(beam_structure_entry_t), dimension(:), allocatable :: entry
   end type beam_structure_record_t
 
 @ %def beam_structure_record_t
 @
 \subsection{Beam structure type}
 The beam-structure object contains the beam particle(s) as simple strings.
 The sequence of records indicates the structure functions by name.  No
 numerical parameters are stored.
 <<Beam structures: public>>=
   public :: beam_structure_t
 <<Beam structures: types>>=
   type :: beam_structure_t
      private
      integer :: n_beam = 0
      type(string_t), dimension(:), allocatable :: prt
      type(beam_structure_record_t), dimension(:), allocatable :: record
      type(smatrix_t), dimension(:), allocatable :: smatrix
      real(default), dimension(:), allocatable :: pol_f
      real(default), dimension(:), allocatable :: p
      real(default), dimension(:), allocatable :: theta
      real(default), dimension(:), allocatable :: phi
    contains
    <<Beam structures: beam structure: TBP>>
   end type beam_structure_t
 
 @ %def beam_structure_t
 @ The finalizer deletes all contents explicitly, so we can continue
 with an empty beam record.  (It is not needed for deallocation.)  We
 have distinct finalizers for the independent parts of the beam structure.
 <<Beam structures: beam structure: TBP>>=
   procedure :: final_sf => beam_structure_final_sf
 <<Beam structures: procedures>>=
   subroutine beam_structure_final_sf (object)
     class(beam_structure_t), intent(inout) :: object
     if (allocated (object%prt))  deallocate (object%prt)
     if (allocated (object%record))  deallocate (object%record)
     object%n_beam = 0
   end subroutine beam_structure_final_sf
 
 @ %def beam_structure_final_sf
 @ Output.  The actual information fits in a single line, therefore we can
 provide a [[to_string]] method.  The [[show]] method also lists the
 current values of relevant global variables.
 <<Beam structures: beam structure: TBP>>=
   procedure :: write => beam_structure_write
   procedure :: to_string => beam_structure_to_string
 <<Beam structures: procedures>>=
   subroutine beam_structure_write (object, unit)
     class(beam_structure_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A,A)")  "Beam structure: ", char (object%to_string ())
     if (allocated (object%smatrix)) then
        do i = 1, size (object%smatrix)
           write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):"
           call object%smatrix(i)%write (u, indent=2)
        end do
     end if
     if (allocated (object%pol_f)) then
        write (u, "(3x,A,F10.7,:,',',F10.7)")  "polarization degree =", &
             object%pol_f
     end if
     if (allocated (object%p)) then
        write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
             ")")  "momentum =", object%p
     end if
     if (allocated (object%theta)) then
        write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
             ")")  "angle th =", object%theta
     end if
     if (allocated (object%phi)) then
        write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
             ")")  "angle ph =", object%phi
     end if
   end subroutine beam_structure_write
 
   function beam_structure_to_string (object, sf_only) result (string)
     class(beam_structure_t), intent(in) :: object
     logical, intent(in), optional :: sf_only
     type(string_t) :: string
     integer :: i, j
     logical :: with_beams
     with_beams = .true.;  if (present (sf_only))  with_beams = .not. sf_only
     select case (object%n_beam)
     case (1)
        if (with_beams) then
           string = object%prt(1)
        else
           string = ""
        end if
     case (2)
        if (with_beams) then
           string = object%prt(1) // ", " // object%prt(2)
        else
           string = ""
        end if
        if (allocated (object%record)) then
           if (size (object%record) > 0) then
              if (with_beams)  string = string // " => "
              do i = 1, size (object%record)
                 if (i > 1)  string = string // " => "
                 do j = 1, size (object%record(i)%entry)
                    if (j > 1)  string = string // ", "
                    string = string // object%record(i)%entry(j)%to_string ()
                 end do
              end do
           end if
        end if
     case default
        string = "[any particles]"
     end select
   end function beam_structure_to_string
 
 @ %def beam_structure_write beam_structure_to_string
 @ Initializer: dimension the beam structure record.  Each array
 element denotes the number of entries for a record within the
 beam-structure sequence.  The number of entries is either one or two,
 while the number of records is unlimited.
 <<Beam structures: beam structure: TBP>>=
   procedure :: init_sf => beam_structure_init_sf
 <<Beam structures: procedures>>=
   subroutine beam_structure_init_sf (beam_structure, prt, dim_array)
     class(beam_structure_t), intent(inout) :: beam_structure
     type(string_t), dimension(:), intent(in) :: prt
     integer, dimension(:), intent(in), optional :: dim_array
     integer :: i
     call beam_structure%final_sf ()
     beam_structure%n_beam = size (prt)
     allocate (beam_structure%prt (size (prt)))
     beam_structure%prt = prt
     if (present (dim_array)) then
        allocate (beam_structure%record (size (dim_array)))
        do i = 1, size (dim_array)
           allocate (beam_structure%record(i)%entry (dim_array(i)))
        end do
     else
        allocate (beam_structure%record (0))
     end if
   end subroutine beam_structure_init_sf
 
 @ %def beam_structure_init_sf
 @ Set an entry, specified by record number and entry number.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_sf => beam_structure_set_sf
 <<Beam structures: procedures>>=
   subroutine beam_structure_set_sf (beam_structure, i, j, name)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i, j
     type(string_t), intent(in) :: name
     associate (entry => beam_structure%record(i)%entry(j))
       entry%name = name
       entry%is_valid = .true.
     end associate
   end subroutine beam_structure_set_sf
 
 @ %def beam_structure_set_sf
 @ Expand the beam-structure object.  (i) For a pair spectrum, keep the
 entry.  (ii) For a single-particle structure function written as a
 single entry, replace this by a record with two entries.
 (ii) For a record with two nontrivial entries, separate this into two
 records with one trivial entry each.
 
 To achieve this, we need a function that tells us whether an entry is
 a spectrum or a structure function.  It returns 0 for a trivial entry,
 1 for a single-particle structure function, and 2 for a two-particle
 spectrum.
 <<Beam structures: interfaces>>=
   abstract interface
      function strfun_mode_fun (name) result (n)
        import
        type(string_t), intent(in) :: name
        integer :: n
      end function strfun_mode_fun
   end interface
 
 @ %def is_spectrum_t
 @ Algorithm: (1) Mark entries as invalid where necessary.  (2) Count
 the number of entries that we will need.  (3) Expand and copy
 entries to a new record array.  (4) Replace the old array by the new one.
 <<Beam structures: beam structure: TBP>>=
   procedure :: expand => beam_structure_expand
 <<Beam structures: procedures>>=
   subroutine beam_structure_expand (beam_structure, strfun_mode)
     class(beam_structure_t), intent(inout) :: beam_structure
     procedure(strfun_mode_fun) :: strfun_mode
     type(beam_structure_record_t), dimension(:), allocatable :: new
     integer :: n_record, i, j
     if (.not. allocated (beam_structure%record))  return
     do i = 1, size (beam_structure%record)
        associate (entry => beam_structure%record(i)%entry)
          do j = 1, size (entry)
             select case (strfun_mode (entry(j)%name))
             case (0);  entry(j)%is_valid = .false.
             end select
          end do
        end associate
     end do
     n_record = 0
     do i = 1, size (beam_structure%record)
        associate (entry => beam_structure%record(i)%entry)
          select case (size (entry))
          case (1)
             if (entry(1)%is_valid) then
                select case (strfun_mode (entry(1)%name))
                case (1);  n_record = n_record + 2
                case (2);  n_record = n_record + 1
                end select
             end if
          case (2)
             do j = 1, 2
                if (entry(j)%is_valid) then
                   select case (strfun_mode (entry(j)%name))
                   case (1);  n_record = n_record + 1
                   case (2)
                      call beam_structure%write ()
                      call msg_fatal ("Pair spectrum used as &
                           &single-particle structure function")
                   end select
                end if
             end do
          end select
        end associate
     end do
     allocate (new (n_record))
     n_record = 0
     do i = 1, size (beam_structure%record)
        associate (entry => beam_structure%record(i)%entry)
          select case (size (entry))
          case (1)
             if (entry(1)%is_valid) then
                select case (strfun_mode (entry(1)%name))
                case (1)
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (2))
                   new(n_record)%entry(1) = entry(1)
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (2))
                   new(n_record)%entry(2) = entry(1)
                case (2)
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (1))
                   new(n_record)%entry(1) = entry(1)
                end select
             end if
          case (2)
             do j = 1, 2
                if (entry(j)%is_valid) then
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (2))
                   new(n_record)%entry(j) = entry(j)
                end if
             end do
          end select
        end associate
     end do
     call move_alloc (from = new, to = beam_structure%record)
   end subroutine beam_structure_expand
 
 @ %def beam_structure_expand
 @
 \subsection{Polarization}
 To record polarization, we provide an allocatable array of [[smatrix]]
 objects, sparse matrices.  The polarization structure is independent of the
 structure-function setup, they are combined only when an actual beam object is
 constructed.
 <<Beam structures: beam structure: TBP>>=
   procedure :: final_pol => beam_structure_final_pol
   procedure :: init_pol => beam_structure_init_pol
 <<Beam structures: procedures>>=
   subroutine beam_structure_final_pol (beam_structure)
     class(beam_structure_t), intent(inout) :: beam_structure
     if (allocated (beam_structure%smatrix))  deallocate (beam_structure%smatrix)
     if (allocated (beam_structure%pol_f))  deallocate (beam_structure%pol_f)
   end subroutine beam_structure_final_pol
 
   subroutine beam_structure_init_pol (beam_structure, n)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: n
     if (allocated (beam_structure%smatrix))  deallocate (beam_structure%smatrix)
     allocate (beam_structure%smatrix (n))
     if (.not. allocated (beam_structure%pol_f)) &
          allocate (beam_structure%pol_f (n), source = 1._default)
   end subroutine beam_structure_init_pol
 
 @ %def beam_structure_final_pol
 @ %def beam_structure_init_pol
 @ Check if polarized beams are used.
 <<Beam structures: beam structure: TBP>>=
   procedure :: has_polarized_beams => beam_structure_has_polarized_beams
 <<Beam structures: procedures>>=
   elemental function beam_structure_has_polarized_beams (beam_structure) result (pol)
     logical :: pol
     class(beam_structure_t), intent(in) :: beam_structure
     if (allocated (beam_structure%pol_f)) then
        pol = any (beam_structure%pol_f /= 0)
     else
        pol = .false.
     end if
   end function beam_structure_has_polarized_beams
 
 @ %def beam_structure_has_polarized_beams
 @ Directly copy the spin density matrices.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_smatrix => beam_structure_set_smatrix
 <<Beam structures: procedures>>=
   subroutine beam_structure_set_smatrix (beam_structure, i, smatrix)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i
     type(smatrix_t), intent(in) :: smatrix
     beam_structure%smatrix(i) = smatrix
   end subroutine beam_structure_set_smatrix
 
 @ %def beam_structure_set_smatrix
 @ Initialize one of the spin density matrices manually.
 <<Beam structures: beam structure: TBP>>=
   procedure :: init_smatrix => beam_structure_init_smatrix
 <<Beam structures: procedures>>=
   subroutine beam_structure_init_smatrix (beam_structure, i, n_entry)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i
     integer, intent(in) :: n_entry
     call beam_structure%smatrix(i)%init (2, n_entry)
   end subroutine beam_structure_init_smatrix
 
 @ %def beam_structure_init_smatrix
 @ Set a polarization entry.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_sentry => beam_structure_set_sentry
 <<Beam structures: procedures>>=
   subroutine beam_structure_set_sentry &
        (beam_structure, i, i_entry, index, value)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i
     integer, intent(in) :: i_entry
     integer, dimension(:), intent(in) :: index
     complex(default), intent(in) :: value
     call beam_structure%smatrix(i)%set_entry (i_entry, index, value)
   end subroutine beam_structure_set_sentry
 
 @ %def beam_structure_set_sentry
 @ Set the array of polarization fractions.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_pol_f => beam_structure_set_pol_f
 <<Beam structures: procedures>>=
   subroutine beam_structure_set_pol_f (beam_structure, f)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: f
     if (allocated (beam_structure%pol_f))  deallocate (beam_structure%pol_f)
     allocate (beam_structure%pol_f (size (f)), source = f)
   end subroutine beam_structure_set_pol_f
 
 @ %def beam_structure_set_pol_f
 @
 \subsection{Beam momenta}
 By default, beam momenta are deduced from the [[sqrts]] value or from
 the mass of the decaying particle, assuming a c.m.\ setup.  Here we
 set them explicitly.
 <<Beam structures: beam structure: TBP>>=
   procedure :: final_mom => beam_structure_final_mom
 <<Beam structures: procedures>>=
   subroutine beam_structure_final_mom (beam_structure)
     class(beam_structure_t), intent(inout) :: beam_structure
     if (allocated (beam_structure%p))  deallocate (beam_structure%p)
     if (allocated (beam_structure%theta))  deallocate (beam_structure%theta)
     if (allocated (beam_structure%phi))  deallocate (beam_structure%phi)
   end subroutine beam_structure_final_mom
 
 @ %def beam_structure_final_mom
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_momentum => beam_structure_set_momentum
   procedure :: set_theta => beam_structure_set_theta
   procedure :: set_phi => beam_structure_set_phi
 <<Beam structures: procedures>>=
   subroutine beam_structure_set_momentum (beam_structure, p)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: p
     if (allocated (beam_structure%p))  deallocate (beam_structure%p)
     allocate (beam_structure%p (size (p)), source = p)
   end subroutine beam_structure_set_momentum
 
   subroutine beam_structure_set_theta (beam_structure, theta)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: theta
     if (allocated (beam_structure%theta))  deallocate (beam_structure%theta)
     allocate (beam_structure%theta (size (theta)), source = theta)
   end subroutine beam_structure_set_theta
 
   subroutine beam_structure_set_phi (beam_structure, phi)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: phi
     if (allocated (beam_structure%phi))  deallocate (beam_structure%phi)
     allocate (beam_structure%phi (size (phi)), source = phi)
   end subroutine beam_structure_set_phi
 
 @ %def beam_structure_set_momentum
 @ %def beam_structure_set_theta
 @ %def beam_structure_set_phi
 @
 \subsection{Get contents}
 Look at the incoming particles.  We may also have the case that beam
 particles are not specified, but polarization.
 <<Beam structures: beam structure: TBP>>=
   procedure :: is_set => beam_structure_is_set
   procedure :: get_n_beam => beam_structure_get_n_beam
   procedure :: get_prt => beam_structure_get_prt
 <<Beam structures: procedures>>=
   function beam_structure_is_set (beam_structure) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     logical :: flag
     flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric ()
   end function beam_structure_is_set
 
   function beam_structure_get_n_beam (beam_structure) result (n)
     class(beam_structure_t), intent(in) :: beam_structure
     integer :: n
     n = beam_structure%n_beam
   end function beam_structure_get_n_beam
 
   function beam_structure_get_prt (beam_structure) result (prt)
     class(beam_structure_t), intent(in) :: beam_structure
     type(string_t), dimension(:), allocatable :: prt
     allocate (prt (size (beam_structure%prt)))
     prt = beam_structure%prt
   end function beam_structure_get_prt
 
 @ %def beam_structure_is_set
 @ %def beam_structure_get_n_beam
 @ %def beam_structure_get_prt
 @
 Return the number of records.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_n_record => beam_structure_get_n_record
 <<Beam structures: procedures>>=
   function beam_structure_get_n_record (beam_structure) result (n)
     class(beam_structure_t), intent(in) :: beam_structure
     integer :: n
     if (allocated (beam_structure%record)) then
        n = size (beam_structure%record)
     else
        n = 0
     end if
   end function beam_structure_get_n_record
 
 @ %def beam_structure_get_n_record
 @ Return an array consisting of the beam indices affected by the valid
 entries within a record.  After expansion, there should be exactly one
 valid entry per record.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_i_entry => beam_structure_get_i_entry
 <<Beam structures: procedures>>=
   function beam_structure_get_i_entry (beam_structure, i) result (i_entry)
     class(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: i
     integer, dimension(:), allocatable :: i_entry
     associate (record => beam_structure%record(i))
       select case (size (record%entry))
       case (1)
          if (record%entry(1)%is_valid) then
             allocate (i_entry (2), source = [1, 2])
          else
             allocate (i_entry (0))
          end if
       case (2)
          if (all (record%entry%is_valid)) then
             allocate (i_entry (2), source = [1, 2])
          else if (record%entry(1)%is_valid) then
             allocate (i_entry (1), source = [1])
          else if (record%entry(2)%is_valid) then
             allocate (i_entry (1), source = [2])
          else
             allocate (i_entry (0))
          end if
       end select
     end associate
   end function beam_structure_get_i_entry
 
 @ %def beam_structure_get_i_entry
 @ Return the name of the first valid entry within a record.  After
 expansion, there should be exactly one valid entry per record.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_name => beam_structure_get_name
 <<Beam structures: procedures>>=
   function beam_structure_get_name (beam_structure, i) result (name)
     type(string_t) :: name
     class(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: i
     associate (record => beam_structure%record(i))
       if (record%entry(1)%is_valid) then
          name = record%entry(1)%name
       else if (size (record%entry) == 2) then
          name = record%entry(2)%name
       end if
     end associate
   end function beam_structure_get_name
 
 @ %def beam_structure_get_name
 @
 <<Beam structures: beam structure: TBP>>=
   procedure :: has_pdf => beam_structure_has_pdf
 <<Beam structures: procedures>>=
   function beam_structure_has_pdf (beam_structure) result (has_pdf)
     logical :: has_pdf
     class(beam_structure_t), intent(in) :: beam_structure
     integer :: i
     type(string_t) :: name
     has_pdf = .false.
     do i = 1, beam_structure%get_n_record ()
        name = beam_structure%get_name (i)
        has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf")
     end do
   end function beam_structure_has_pdf
 
 @ %def beam_structure_has_pdf
 @ Return true if the beam structure contains a particular structure
 function identifier (such as [[lhapdf]], [[isr]], etc.)
 <<Beam structures: beam structure: TBP>>=
   procedure :: contains => beam_structure_contains
 <<Beam structures: procedures>>=
   function beam_structure_contains (beam_structure, name) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     character(*), intent(in) :: name
     logical :: flag
     integer :: i, j
     flag = .false.
     if (allocated (beam_structure%record)) then
        do i = 1, size (beam_structure%record)
           do j = 1, size (beam_structure%record(i)%entry)
              flag = beam_structure%record(i)%entry(j)%name == name
              if (flag)  return
           end do
        end do
     end if
   end function beam_structure_contains
 
 @ %def beam_structure_contains
 @ Return polarization data.
 <<Beam structures: beam structure: TBP>>=
   procedure :: polarized => beam_structure_polarized
   procedure :: get_smatrix => beam_structure_get_smatrix
   procedure :: get_pol_f => beam_structure_get_pol_f
   procedure :: asymmetric => beam_structure_asymmetric
 <<Beam structures: procedures>>=
   function beam_structure_polarized (beam_structure) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     logical :: flag
     flag = allocated (beam_structure%smatrix)
   end function beam_structure_polarized
 
   function beam_structure_get_smatrix (beam_structure) result (smatrix)
     class(beam_structure_t), intent(in) :: beam_structure
     type(smatrix_t), dimension(:), allocatable :: smatrix
     allocate (smatrix (size (beam_structure%smatrix)), &
          source = beam_structure%smatrix)
   end function beam_structure_get_smatrix
 
   function beam_structure_get_pol_f (beam_structure) result (pol_f)
     class(beam_structure_t), intent(in) :: beam_structure
     real(default), dimension(:), allocatable :: pol_f
     allocate (pol_f (size (beam_structure%pol_f)), &
          source = beam_structure%pol_f)
   end function beam_structure_get_pol_f
 
   function beam_structure_asymmetric (beam_structure) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     logical :: flag
     flag = allocated (beam_structure%p) &
          .or. allocated (beam_structure%theta) &
          .or. allocated (beam_structure%phi)
   end function beam_structure_asymmetric
 
 @ %def beam_structure_polarized
 @ %def beam_structure_get_smatrix
 @ %def beam_structure_get_pol_f
 @ %def beam_structure_asymmetric
 @ Return the beam momenta (the space part, i.e., three-momenta).  This
 is meaningful only if momenta and, optionally, angles have been set.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_momenta => beam_structure_get_momenta
 <<Beam structures: procedures>>=
   function beam_structure_get_momenta (beam_structure) result (p)
     class(beam_structure_t), intent(in) :: beam_structure
     type(vector3_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: theta, phi
     integer :: n, i
     if (allocated (beam_structure%p)) then
        n = size (beam_structure%p)
        if (allocated (beam_structure%theta)) then
           if (size (beam_structure%theta) == n) then
              allocate (theta (n), source = beam_structure%theta)
           else
              call msg_fatal ("Beam structure: mismatch in momentum vs. &
                   &angle theta specification")
           end if
        else
           allocate (theta (n), source = 0._default)
        end if
        if (allocated (beam_structure%phi)) then
           if (size (beam_structure%phi) == n) then
              allocate (phi (n), source = beam_structure%phi)
           else
              call msg_fatal ("Beam structure: mismatch in momentum vs. &
                   &angle phi specification")
           end if
        else
           allocate (phi (n), source = 0._default)
        end if
        allocate (p (n))
        do i = 1, n
           p(i) = beam_structure%p(i) * vector3_moving ([ &
                sin (theta(i)) * cos (phi(i)), &
                sin (theta(i)) * sin (phi(i)), &
                cos (theta(i))])
        end do
        if (n == 2)  p(2) = - p(2)
     else
        call msg_fatal ("Beam structure: angle theta/phi specified but &
             &momentum/a p undefined")
     end if
   end function beam_structure_get_momenta
 
 @ %def beam_structure_get_momenta
 @ Check for a complete beam structure.  The [[applies]] flag tells if
 the beam structure should actually be used for a process with the
 given [[n_in]] number of incoming particles.
 
 It set if the beam structure matches the process as either decay or
 scattering.  It is unset if beam structure references a scattering
 setup but the process is a decay.  It is also unset if the beam
 structure itself is empty.
 
 If the beam structure cannot be used, terminate with fatal error.
 <<Beam structures: beam structure: TBP>>=
   procedure :: check_against_n_in => beam_structure_check_against_n_in
 <<Beam structures: procedures>>=
   subroutine beam_structure_check_against_n_in (beam_structure, n_in, applies)
     class(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: n_in
     logical, intent(out) :: applies
     if (beam_structure%is_set ()) then
        if (n_in == beam_structure%get_n_beam ()) then
           applies = .true.
        else if (beam_structure%get_n_beam () == 0) then
           call msg_fatal &
                ("Asymmetric beams: missing beam particle specification")
           applies = .false.
        else
           call msg_fatal &
                ("Mismatch of process and beam setup (scattering/decay)")
           applies = .false.
        end if
     else
        applies = .false.
     end if
   end subroutine beam_structure_check_against_n_in
 
 @ %def beam_structure_check_against_n_in
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[beam_structures_ut.f90]]>>=
 <<File header>>
 
 module beam_structures_ut
   use unit_tests
   use beam_structures_uti
 
 <<Standard module head>>
 
 <<Beam structures: public test>>
 
 contains
 
 <<Beam structures: test driver>>
 
 end module beam_structures_ut
 @ %def beam_structures_ut
 @
 <<[[beam_structures_uti.f90]]>>=
 <<File header>>
 
 module beam_structures_uti
 
 <<Use kinds>>
 <<Use strings>>
 
   use beam_structures
 
 <<Standard module head>>
 
 <<Beam structures: test declarations>>
 
 contains
 
 <<Beam structures: tests>>
 
 <<Beam structures: test auxiliary>>
 
 end module beam_structures_uti
 @ %def beam_structures_ut
 @ API: driver for the unit tests below.
 <<Beam structures: public test>>=
   public :: beam_structures_test
 <<Beam structures: test driver>>=
   subroutine beam_structures_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Beam structures: execute tests>>
 end subroutine beam_structures_test
 
 @ %def beam_structures_tests
 @
 \subsubsection{Empty structure}
 <<Beam structures: execute tests>>=
   call test (beam_structures_1, "beam_structures_1", &
        "empty beam structure record", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_1
 <<Beam structures: tests>>=
   subroutine beam_structures_1 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
 
     write (u, "(A)")  "* Test output: beam_structures_1"
     write (u, "(A)")  "*   Purpose: display empty beam structure record"
     write (u, "(A)")
 
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_1"
 
   end subroutine beam_structures_1
 
 @ %def beam_structures_1
 @
 \subsubsection{Nontrivial configurations}
 <<Beam structures: execute tests>>=
   call test (beam_structures_2, "beam_structures_2", &
        "beam structure records", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_2
 <<Beam structures: tests>>=
   subroutine beam_structures_2 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     integer, dimension(0) :: empty_array
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_2"
     write (u, "(A)")  "*   Purpose: setup beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     call beam_structure%init_sf ([s], empty_array)
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [2])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (1, 2, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [2, 1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (1, 2, var_str ("b"))
     call beam_structure%set_sf (2, 1, var_str ("c"))
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_2"
 
   end subroutine beam_structures_2
 
 @ %def beam_structures_2
 @
 \subsubsection{Expansion}
 Provide a function that tells, for the dummy structure function names
 used here, whether they are considered a two-particle spectrum or a
 single-particle structure function:
 <<Beam structures: test auxiliary>>=
   function test_strfun_mode (name) result (n)
     type(string_t), intent(in) :: name
     integer :: n
     select case (char (name))
     case ("a");  n = 2
     case ("b");  n = 1
     case default;  n = 0
     end select
   end function test_strfun_mode
 
 @ %def test_ist_pair_spectrum
 @
 <<Beam structures: execute tests>>=
   call test (beam_structures_3, "beam_structures_3", &
        "beam structure expansion", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_3
 <<Beam structures: tests>>=
   subroutine beam_structures_3 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_3"
     write (u, "(A)")  "*   Purpose: expand beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     write (u, "(A)")  "* Pair spectrum (keep as-is)"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function pair (expand)"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [2])
     call beam_structure%set_sf (1, 1, var_str ("b"))
     call beam_structure%set_sf (1, 2, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function (separate and expand)"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Combination"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1, 1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (2, 1, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_3"
 
   end subroutine beam_structures_3
 
 @ %def beam_structures_3
 @
 \subsubsection{Public methods}
 Check the methods that can be called to get the beam-structure
 contents.
 <<Beam structures: execute tests>>=
   call test (beam_structures_4, "beam_structures_4", &
        "beam structure contents", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_4
 <<Beam structures: tests>>=
   subroutine beam_structures_4 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     type(string_t) :: s
     type(string_t), dimension(2) :: prt
     integer :: i
 
     write (u, "(A)")  "* Test output: beam_structures_4"
     write (u, "(A)")  "*   Purpose: check the API"
     write (u, "(A)")
 
     s = "s"
 
     write (u, "(A)")  "* Structure-function combination"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1, 2, 2])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (2, 1, var_str ("b"))
     call beam_structure%set_sf (3, 2, var_str ("c"))
     call beam_structure%write (u)
 
     write (u, *)
     write (u, "(1x,A,I0)")  "n_beam = ", beam_structure%get_n_beam ()
     prt = beam_structure%get_prt ()
     write (u, "(1x,A,2(1x,A))")  "prt =", char (prt(1)), char (prt(2))
 
     write (u, *)
     write (u, "(1x,A,I0)")  "n_record = ", beam_structure%get_n_record ()
 
     do i = 1, 3
        write (u, "(A)")
        write (u, "(1x,A,I0,A,A)")  "name(", i, ") = ", &
             char (beam_structure%get_name (i))
        write (u, "(1x,A,I0,A,2(1x,I0))")  "i_entry(", i, ") =", &
             beam_structure%get_i_entry (i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_4"
 
   end subroutine beam_structures_4
 
 @ %def beam_structures_4
 @
 \subsubsection{Polarization}
 The polarization properties are independent from the structure-function setup.
 <<Beam structures: execute tests>>=
   call test (beam_structures_5, "beam_structures_5", &
        "polarization", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_5
 <<Beam structures: tests>>=
   subroutine beam_structures_5 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     integer, dimension(0) :: empty_array
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_5"
     write (u, "(A)")  "*   Purpose: setup polarization in beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     call beam_structure%init_sf ([s], empty_array)
     call beam_structure%init_pol (1)
     call beam_structure%init_smatrix (1, 1)
     call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default))
     call beam_structure%set_pol_f ([0.5_default])
     call beam_structure%write (u)
 
 
     write (u, "(A)")
     call beam_structure%final_sf ()
     call beam_structure%final_pol ()
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%init_pol (2)
     call beam_structure%init_smatrix (1, 2)
     call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default))
     call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default))
     call beam_structure%init_smatrix (2, 0)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_5"
 
   end subroutine beam_structures_5
 
 @ %def beam_structures_5
 @
 \subsubsection{Momenta}
 The momenta are independent from the structure-function setup.
 <<Beam structures: execute tests>>=
   call test (beam_structures_6, "beam_structures_6", &
        "momenta", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_6
 <<Beam structures: tests>>=
   subroutine beam_structures_6 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     integer, dimension(0) :: empty_array
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_6"
     write (u, "(A)")  "*   Purpose: setup momenta in beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     call beam_structure%init_sf ([s], empty_array)
     call beam_structure%set_momentum ([500._default])
     call beam_structure%write (u)
 
 
     write (u, "(A)")
     call beam_structure%final_sf ()
     call beam_structure%final_mom ()
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_momentum ([500._default, 700._default])
     call beam_structure%set_theta ([0._default, 0.1_default])
     call beam_structure%set_phi ([0._default, 1.51_default])
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_6"
 
   end subroutine beam_structures_6
 
 @ %def beam_structures_6
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Beams for collisions and decays}
 
 <<[[beams.f90]]>>=
 <<File header>>
 
 module beams
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use numeric_utils
   use diagnostics
   use md5
   use lorentz
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use interactions
   use polarizations
   use beam_structures
 
 <<Standard module head>>
 
 <<Beams: public>>
 
 <<Beams: types>>
 
 <<Beams: interfaces>>
 
 contains
 
 <<Beams: procedures>>
 
 end module beams
 @ %def beams
 @
 \subsection{Beam data}
 The beam data type contains beam data for one or two beams, depending
 on whether we are dealing with beam collisions or particle decay.  In
 addition, it holds the c.m.\ energy [[sqrts]], the Lorentz
 transformation [[L]] that transforms the c.m.\ system into the lab
 system, and the pair of c.m.\ momenta.
 <<Beams: public>>=
   public :: beam_data_t
 <<Beams: types>>=
   type :: beam_data_t
      logical :: initialized = .false.
      integer :: n = 0
      type(flavor_t), dimension(:), allocatable :: flv
      real(default), dimension(:), allocatable :: mass
      type(pmatrix_t), dimension(:), allocatable :: pmatrix
      logical :: lab_is_cm = .true.
      type(vector4_t), dimension(:), allocatable :: p_cm
      type(vector4_t), dimension(:), allocatable :: p
      type(lorentz_transformation_t), allocatable  :: L_cm_to_lab
      real(default) :: sqrts = 0
      character(32) :: md5sum = ""
    contains
    <<Beams: beam data: TBP>>
   end type beam_data_t
 
 @ %def beam_data_t
 @ Generic initializer.  This is called by the specific initializers
 below.  Initialize either for decay or for collision.
 <<Beams: procedures>>=
   subroutine beam_data_init (beam_data, n)
     type(beam_data_t), intent(out) :: beam_data
     integer, intent(in) :: n
     beam_data%n = n
     allocate (beam_data%flv (n))
     allocate (beam_data%mass (n))
     allocate (beam_data%pmatrix (n))
     allocate (beam_data%p_cm (n))
     allocate (beam_data%p (n))
     beam_data%initialized = .true.
   end subroutine beam_data_init
 
 @ %def beam_data_init
 @ Finalizer: needed for the polarization components of the beams.
 <<Beams: beam data: TBP>>=
   procedure :: final => beam_data_final
 <<Beams: procedures>>=
   subroutine beam_data_final (beam_data)
     class(beam_data_t), intent(inout) :: beam_data
     beam_data%initialized = .false.
   end subroutine beam_data_final
 
 @ %def beam_data_final
 @ The verbose (default) version is for debugging.  The short version
 is for screen output in the UI.
 <<Beams: beam data: TBP>>=
   procedure :: write => beam_data_write
 <<Beams: procedures>>=
   subroutine beam_data_write (beam_data, unit, verbose, write_md5sum)
     class(beam_data_t), intent(in) :: beam_data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose, write_md5sum
     integer :: prt_name_len
     logical :: verb, write_md5
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     verb = .false.;  if (present (verbose))  verb = verbose
     write_md5 = verb;  if (present (write_md5sum)) write_md5 = write_md5sum
     if (.not. beam_data%initialized) then
        write (u, "(1x,A)") "Beam data: [undefined]"
        return
     end if
     prt_name_len = maxval (len (beam_data%flv%get_name ()))
     select case (beam_data%n)
     case (1)
        write (u, "(1x,A)") "Beam data (decay):"
        if (verb) then
           call write_prt (1)
           call beam_data%pmatrix(1)%write (u)
           write (u, *) "R.f. momentum:"
           call vector4_write (beam_data%p_cm(1), u)
           write (u, *) "Lab momentum:"
           call vector4_write (beam_data%p(1), u)
        else
           call write_prt (1)
        end if
     case (2)
        write (u, "(1x,A)") "Beam data (collision):"
        if (verb) then
           call write_prt (1)
           call beam_data%pmatrix(1)%write (u)
           call write_prt (2)
           call beam_data%pmatrix(2)%write (u)
           call write_sqrts
           write (u, *) "C.m. momenta:"
           call vector4_write (beam_data%p_cm(1), u)
           call vector4_write (beam_data%p_cm(2), u)
           write (u, *) "Lab momenta:"
           call vector4_write (beam_data%p(1), u)
           call vector4_write (beam_data%p(2), u)
        else
           call write_prt (1)
           call write_prt (2)
           call write_sqrts
        end if
     end select
     if (allocated (beam_data%L_cm_to_lab)) then
        if (verb) then
           call lorentz_transformation_write (beam_data%L_cm_to_lab, u)
        else
           write (u, "(1x,A)")  "Beam structure: lab and c.m. frame differ"
        end if
     end if
     if (write_md5) then
        write (u, *) "MD5 sum: ", beam_data%md5sum
     end if
   contains
     subroutine write_sqrts
       character(80) :: sqrts_str
       write (sqrts_str, "(" // FMT_19 // ")")  beam_data%sqrts
       write (u, "(3x,A)")  "sqrts = " // trim (adjustl (sqrts_str)) // " GeV"
     end subroutine write_sqrts
     subroutine write_prt (i)
       integer, intent(in) :: i
       character(80) :: name_str, mass_str
       write (name_str, "(A)")  char (beam_data%flv(i)%get_name ())
       write (mass_str, "(ES13.7)")  beam_data%mass(i)
       write (u, "(3x,A)", advance="no") &
            name_str(:prt_name_len) // "  (mass = " &
            // trim (adjustl (mass_str)) // " GeV)"
       if (beam_data%pmatrix(i)%is_polarized ()) then
          write (u, "(2x,A)")  "polarized"
       else
          write (u, *)
       end if
     end subroutine write_prt
   end subroutine beam_data_write
 
 @ %def beam_data_write
 @ Return initialization status:
 <<Beams: beam data: TBP>>=
   procedure :: are_valid => beam_data_are_valid
 <<Beams: procedures>>=
   function beam_data_are_valid (beam_data) result (flag)
     class(beam_data_t), intent(in) :: beam_data
     logical :: flag
     flag = beam_data%initialized
   end function beam_data_are_valid
 
 @ %def beam_data_are_valid
 @ Check whether beam data agree with the current values of relevant
 parameters.
 <<Beams: beam data: TBP>>=
   procedure :: check_scattering => beam_data_check_scattering
 <<Beams: procedures>>=
   subroutine beam_data_check_scattering (beam_data, sqrts)
     class(beam_data_t), intent(in) :: beam_data
     real(default), intent(in), optional :: sqrts
     if (beam_data_are_valid (beam_data)) then
        if (present (sqrts)) then
           if (.not. nearly_equal (sqrts, beam_data%sqrts)) then
              call msg_error ("Current setting of sqrts is inconsistent " &
                   // "with beam setup (ignored).")
           end if
        end if
     else
        call msg_bug ("Beam setup: invalid beam data")
     end if
   end subroutine beam_data_check_scattering
 
 @ %def beam_data_check_scattering
 @ Return the number of beams (1 for decays, 2 for collisions).
 <<Beams: beam data: TBP>>=
   procedure :: get_n_in => beam_data_get_n_in
 <<Beams: procedures>>=
   function beam_data_get_n_in (beam_data) result (n_in)
     class(beam_data_t), intent(in) :: beam_data
     integer :: n_in
     n_in = beam_data%n
   end function beam_data_get_n_in
 
 @ %def beam_data_get_n_in
 @ Return the beam flavor
 <<Beams: beam data: TBP>>=
   procedure :: get_flavor => beam_data_get_flavor
 <<Beams: procedures>>=
   function beam_data_get_flavor (beam_data) result (flv)
     class(beam_data_t), intent(in) :: beam_data
     type(flavor_t), dimension(:), allocatable :: flv
     allocate (flv (beam_data%n))
     flv = beam_data%flv
   end function beam_data_get_flavor
 
 @ %def beam_data_get_flavor
 @ Return the beam energies
 <<Beams: beam data: TBP>>=
   procedure :: get_energy => beam_data_get_energy
 <<Beams: procedures>>=
   function beam_data_get_energy (beam_data) result (e)
     class(beam_data_t), intent(in) :: beam_data
     real(default), dimension(:), allocatable :: e
     integer :: i
     allocate (e (beam_data%n))
     if (beam_data%initialized) then
        do i = 1, beam_data%n
           e(i) = energy (beam_data%p(i))
        end do
     else
        e = 0
     end if
   end function beam_data_get_energy
 
 @ %def beam_data_get_energy
 @ Return the c.m.\ energy.
 <<Beams: beam data: TBP>>=
   procedure :: get_sqrts => beam_data_get_sqrts
 <<Beams: procedures>>=
   function beam_data_get_sqrts (beam_data) result (sqrts)
     class(beam_data_t), intent(in) :: beam_data
     real(default) :: sqrts
     sqrts = beam_data%sqrts
   end function beam_data_get_sqrts
 
 @ %def beam_data_get_sqrts
 @ Return the polarization in case it is just two degrees
 <<Beams: beam data: TBP>>=
   procedure :: get_polarization => beam_data_get_polarization
 <<Beams: procedures>>=
   function beam_data_get_polarization (beam_data) result (pol)
     class(beam_data_t), intent(in) :: beam_data
     real(default), dimension(2) :: pol
     if (beam_data%n /= 2) &
          call msg_fatal ("Beam data: can only treat scattering processes.")
     pol = beam_data%pmatrix%get_simple_pol ()
   end function beam_data_get_polarization
 
 @ %def beam_data_get_polarization
 @
 <<Beams: beam data: TBP>>=
   procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix
 <<Beams: procedures>>=
   function beam_data_get_helicity_state_matrix (beam_data) result (state_hel)
     type(state_matrix_t) :: state_hel
     class(beam_data_t), intent(in) :: beam_data
     type(polarization_t), dimension(:), allocatable :: pol
     integer :: i
     allocate (pol (beam_data%n))
     do i = 1, beam_data%n
        call pol(i)%init_pmatrix (beam_data%pmatrix(i))
     end do
     call combine_polarization_states (pol, state_hel)
   end function beam_data_get_helicity_state_matrix
 
 @ %def beam_data_get_helicity_state_matrix
 @
 <<Beams: beam data: TBP>>=
   procedure :: is_initialized => beam_data_is_initialized
 <<Beams: procedures>>=
   function beam_data_is_initialized (beam_data) result (initialized)
     logical :: initialized
     class(beam_data_t), intent(in) :: beam_data
     initialized = any (beam_data%pmatrix%exists ())
   end function beam_data_is_initialized
 
 @ %def beam_data_is_initialized
 @ Return a MD5 checksum for beam data.  If no checksum is present
 (because beams have not been initialized), compute the checksum of the
 sqrts value.
 <<Beams: beam data: TBP>>=
   procedure :: get_md5sum => beam_data_get_md5sum
 <<Beams: procedures>>=
   function beam_data_get_md5sum (beam_data, sqrts) result (md5sum_beams)
     class(beam_data_t), intent(in) :: beam_data
     real(default), intent(in) :: sqrts
     character(32) :: md5sum_beams
     character(80) :: buffer
     if (beam_data%md5sum /= "") then
        md5sum_beams = beam_data%md5sum
     else
        write (buffer, *)  sqrts
        md5sum_beams = md5sum (buffer)
     end if
   end function beam_data_get_md5sum
 
 @ %def beam_data_get_md5sum
 @
 \subsection{Initializers: beam structure}
 Initialize the beam data object from a beam structure object, given energy and
 model.
 <<Beams: beam data: TBP>>=
   procedure :: init_structure => beam_data_init_structure
 <<Beams: procedures>>=
   subroutine beam_data_init_structure &
        (beam_data, structure, sqrts, model, decay_rest_frame)
     class(beam_data_t), intent(out) :: beam_data
     type(beam_structure_t), intent(in) :: structure
     integer :: n_beam
     real(default), intent(in) :: sqrts
     class(model_data_t), intent(in), target :: model
     logical, intent(in), optional :: decay_rest_frame
     type(flavor_t), dimension(:), allocatable :: flv
     n_beam = structure%get_n_beam ()
     allocate (flv (n_beam))
     call flv%init (structure%get_prt (), model)
     if (structure%asymmetric ()) then
        if (structure%polarized ()) then
           call beam_data%init_momenta (structure%get_momenta (), flv, &
                structure%get_smatrix (), structure%get_pol_f ())
        else
           call beam_data%init_momenta (structure%get_momenta (), flv)
        end if
     else
        select case (n_beam)
        case (1)
           if (structure%polarized ()) then
              call beam_data%init_decay (flv, &
                   structure%get_smatrix (), structure%get_pol_f (), &
                   rest_frame = decay_rest_frame)
           else
              call beam_data%init_decay (flv, &
                   rest_frame = decay_rest_frame)
           end if
        case (2)
           if (structure%polarized ()) then
              call beam_data%init_sqrts (sqrts, flv, &
                   structure%get_smatrix (), structure%get_pol_f ())
           else
              call beam_data%init_sqrts (sqrts, flv)
           end if
        case default
           call msg_bug ("Beam data: invalid beam structure object")
        end select
     end if
   end subroutine beam_data_init_structure
 
 @ %def beam_data_init_structure
 @
 \subsection{Initializers: collisions}
 This is the simplest one: just the two flavors, c.m.\ energy,
 polarization.  Color is inferred from flavor.  Beam momenta and c.m.\
 momenta coincide.
 <<Beams: beam data: TBP>>=
   procedure :: init_sqrts => beam_data_init_sqrts
 <<Beams: procedures>>=
   subroutine beam_data_init_sqrts (beam_data, sqrts, flv, smatrix, pol_f)
     class(beam_data_t), intent(out) :: beam_data
     real(default), intent(in) :: sqrts
     type(flavor_t), dimension(:), intent(in) :: flv
     type(smatrix_t), dimension(:), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     real(default), dimension(size(flv)) :: E, p
     call beam_data_init (beam_data, size (flv))
     beam_data%sqrts = sqrts
     beam_data%lab_is_cm = .true.
     select case (beam_data%n)
     case (1)
        E = sqrts;  p = 0
        beam_data%p_cm = vector4_moving (E, p, 3)
        beam_data%p = beam_data%p_cm
     case (2)
        beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ())
        beam_data%p = colliding_momenta (sqrts, flv%get_mass ())
     end select
     call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
   end subroutine beam_data_init_sqrts
 
 @ %def beam_data_init_sqrts
 @ This version sets beam momenta directly, assuming that they are
 asymmetric, i.e., lab frame and c.m.\ frame do not coincide.
 Polarization info is deferred to a common initializer.
 
 The Lorentz transformation that we compute here is not actually used
 in the calculation; instead, it will be recomputed for each event in
 the subroutine [[phs_set_incoming_momenta]].  We compute it here for
 the nominal beam setup nevertheless, so we can print it and, in
 particular, include it in the MD5 sum.
 <<Beams: beam data: TBP>>=
   procedure :: init_momenta => beam_data_init_momenta
 <<Beams: procedures>>=
   subroutine beam_data_init_momenta (beam_data, p3, flv, smatrix, pol_f)
     class(beam_data_t), intent(out) :: beam_data
     type(vector3_t), dimension(:), intent(in) :: p3
     type(flavor_t), dimension(:), intent(in) :: flv
     type(smatrix_t), dimension(:), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     type(vector4_t) :: p0
     type(vector4_t), dimension(:), allocatable :: p, p_cm_rot
     real(default), dimension(size(p3)) :: e
     real(default), dimension(size(flv)) :: m
     type(lorentz_transformation_t) :: L_boost, L_rot
     call beam_data_init (beam_data, size (flv))
     m = flv%get_mass ()
     e = sqrt (p3 ** 2 + m ** 2)
     allocate (p (beam_data%n))
     p = vector4_moving (e, p3)
     p0 = sum (p)
     beam_data%p = p
     beam_data%lab_is_cm = .false.
     beam_data%sqrts = p0 ** 1
     L_boost = boost (p0, beam_data%sqrts)
     allocate (p_cm_rot (beam_data%n))
     p_cm_rot = inverse (L_boost) * p
     allocate (beam_data%L_cm_to_lab)
     select case (beam_data%n)
     case (1)
        beam_data%L_cm_to_lab = L_boost
        beam_data%p_cm = vector4_at_rest (beam_data%sqrts)
     case (2)
        L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1)))
        beam_data%L_cm_to_lab = L_boost * L_rot
        beam_data%p_cm = &
             colliding_momenta (beam_data%sqrts, flv%get_mass ())
     end select
     call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
   end subroutine beam_data_init_momenta
 
 @ %def beam_data_init_momenta
 @
 Final steps:
 If requested, rotate the beams in the lab frame, and set
 the beam-data components.
 <<Beams: procedures>>=
   subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
     type(beam_data_t), intent(inout) :: beam_data
     type(flavor_t), dimension(:), intent(in) :: flv
     type(smatrix_t), dimension(:), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     integer :: i
     do i = 1, beam_data%n
        beam_data%flv(i) = flv(i)
        beam_data%mass(i) = flv(i)%get_mass ()
        if (present (smatrix)) then
           if (size (smatrix) /= beam_data%n) &
                call msg_fatal ("Beam data: &
                &polarization density array has wrong dimension")
           beam_data%pmatrix(i) = smatrix(i)
           if (present (pol_f)) then
              if (size (pol_f) /= size (smatrix)) &
                   call msg_fatal ("Beam data: &
                   &polarization fraction array has wrong dimension")
              call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i))
           else
              call beam_data%pmatrix(i)%normalize (flv(i), 1._default)
           end if
        else
           call beam_data%pmatrix(i)%init (2, 0)
           call beam_data%pmatrix(i)%normalize (flv(i), 0._default)
        end if
     end do
     call beam_data%compute_md5sum ()
   end subroutine beam_data_finish_initialization
 
 @ %def beam_data_finish_initialization
 @
 The MD5 sum is stored within the beam-data record, so it can be
 checked for integrity in subsequent runs.
 <<Beams: beam data: TBP>>=
   procedure :: compute_md5sum => beam_data_compute_md5sum
 <<Beams: procedures>>=
   subroutine beam_data_compute_md5sum (beam_data)
     class(beam_data_t), intent(inout) :: beam_data
     integer :: unit
     unit = free_unit ()
     open (unit = unit, status = "scratch", action = "readwrite")
     call beam_data%write (unit, write_md5sum = .false., &
        verbose = .true.)
     rewind (unit)
     beam_data%md5sum = md5sum (unit)
     close (unit)
   end subroutine beam_data_compute_md5sum
 
 @ %def beam_data_compute_md5sum
 @
 \subsection{Initializers: decays}
 This is the simplest one: decay in rest frame.  We need just flavor
 and polarization.  Color is inferred from flavor.  Beam momentum and
 c.m.\ momentum coincide.
 <<Beams: beam data: TBP>>=
   procedure :: init_decay => beam_data_init_decay
 <<Beams: procedures>>=
   subroutine beam_data_init_decay (beam_data, flv, smatrix, pol_f, rest_frame)
     class(beam_data_t), intent(out) :: beam_data
     type(flavor_t), dimension(1), intent(in) :: flv
     type(smatrix_t), dimension(1), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     logical, intent(in), optional :: rest_frame
     real(default), dimension(1) :: m
     m = flv%get_mass ()
     if (present (smatrix)) then
        call beam_data%init_sqrts (m(1), flv, smatrix, pol_f)
     else
        call beam_data%init_sqrts (m(1), flv, smatrix, pol_f)
     end if
     if (present (rest_frame))  beam_data%lab_is_cm = rest_frame
   end subroutine beam_data_init_decay
 
 @ %def beam_data_init_decay
 @
 \subsection{The beams type}
 Beam objects are interaction objects that contain the actual beam
 data including polarization and density matrix.  For collisions, the
 beam object actually contains two beams.
 <<Beams: public>>=
   public :: beam_t
 <<Beams: types>>=
   type :: beam_t
      private
      type(interaction_t) :: int
   end type beam_t
 
 @ %def beam_t
 @ The constructor contains code that converts beam data into the
 (entangled) particle-pair quantum state.  First, we set the number of
 particles and polarization mask.  (The polarization mask is handed
 over to all later interactions, so if helicity is diagonal or absent, this fact
 is used when constructing the hard-interaction events.)  Then, we
 construct the entangled state that combines helicity, flavor and color
 of the two particles (where flavor and color are unique, while several
 helicity states are possible).  Then, we transfer this state together
 with the associated values from the spin density matrix into the
 [[interaction_t]] object.
 
 Calling the [[add_state]] method of the interaction object, we keep
 the entries of the helicity density matrix without adding them up.
 This ensures that for unpolarized states, we do not normalize but end
 up with an $1/N$ entry, where $N$ is the initial-state multiplicity.
 <<Beams: public>>=
   public :: beam_init
 <<Beams: procedures>>=
   subroutine beam_init (beam, beam_data)
     type(beam_t), intent(out) :: beam
     type(beam_data_t), intent(in), target :: beam_data
     logical, dimension(beam_data%n) :: polarized, diagonal
     type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d
     type(state_matrix_t), target :: state_hel, state_fc, state_tmp
     type(state_iterator_t) :: it_hel, it_tmp
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     complex(default) :: value
     real(default), parameter :: tolerance = 100 * epsilon (1._default)
     polarized = beam_data%pmatrix%is_polarized ()
     diagonal = beam_data%pmatrix%is_diagonal ()
     mask = quantum_numbers_mask (.false., .false., &
          mask_h = .not. polarized, &
          mask_hd = diagonal)
     mask_d = quantum_numbers_mask (.false., .false., .false., &
          mask_hd = polarized .and. diagonal)
     call beam%int%basic_init &
          (0, 0, beam_data%n, mask = mask, store_values = .true.)
     state_hel = beam_data%get_helicity_state_matrix ()
     allocate (qn (beam_data%n))
     call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1))
     call state_fc%init ()
     call state_fc%add_state (qn)
     call merge_state_matrices (state_hel, state_fc, state_tmp)
     call it_hel%init (state_hel)
     call it_tmp%init (state_tmp)
     do while (it_hel%is_valid ())
        qn = it_tmp%get_quantum_numbers ()
        value = it_hel%get_matrix_element ()
        if (any (qn%are_redundant (mask_d))) then
           ! skip off-diagonal elements for diagonal polarization
        else if (abs (value) <= tolerance) then
           ! skip zero entries
        else
           call beam%int%add_state (qn, value = value)
        end if
        call it_hel%advance ()
        call it_tmp%advance ()
     end do
     call beam%int%freeze ()
     call beam%int%set_momenta (beam_data%p, outgoing = .true.)
     call state_hel%final ()
     call state_fc%final ()
     call state_tmp%final ()
   end subroutine beam_init
 
 @ %def beam_init
 @ Finalizer:
 <<Beams: public>>=
   public :: beam_final
 <<Beams: procedures>>=
   subroutine beam_final (beam)
     type(beam_t), intent(inout) :: beam
     call beam%int%final ()
   end subroutine beam_final
 
 @ %def beam_final
 @ I/O:
 <<Beams: public>>=
   public :: beam_write
 <<Beams: procedures>>=
   subroutine beam_write (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose)
     type(beam_t), intent(in) :: beam
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
     logical, intent(in), optional :: col_verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     select case (beam%int%get_n_out ())
     case (1);  write (u, *) "Decaying particle:"
     case (2);  write (u, *) "Colliding beams:"
     end select
     call beam%int%basic_write &
          (unit, verbose = verbose, show_momentum_sum = &
           show_momentum_sum, show_mass = show_mass, &
           col_verbose = col_verbose)
   end subroutine beam_write
 
 @ %def beam_write
 @ Defined assignment: deep copy
 <<Beams: public>>=
   public :: assignment(=)
 <<Beams: interfaces>>=
   interface assignment(=)
      module procedure beam_assign
   end interface
 
 <<Beams: procedures>>=
   subroutine beam_assign (beam_out, beam_in)
     type(beam_t), intent(out) :: beam_out
     type(beam_t), intent(in) :: beam_in
     beam_out%int = beam_in%int
   end subroutine beam_assign
 
 @ %def beam_assign
 @
 \subsection{Inherited procedures}
 <<Beams: public>>=
   public :: interaction_set_source_link
 <<Beams: interfaces>>=
   interface interaction_set_source_link
      module procedure interaction_set_source_link_beam
   end interface
 <<Beams: procedures>>=
   subroutine interaction_set_source_link_beam (int, i, beam1, i1)
     type(interaction_t), intent(inout) :: int
     type(beam_t), intent(in), target :: beam1
     integer, intent(in) :: i, i1
     call int%set_source_link (i, beam1%int, i1)
   end subroutine interaction_set_source_link_beam
 
 @ %def interaction_set_source_link_beam
 @
 \subsection{Accessing contents}
 Return the interaction component -- as a pointer, to avoid any copying.
 <<Beams: public>>=
   public :: beam_get_int_ptr
 <<Beams: procedures>>=
   function beam_get_int_ptr (beam) result (int)
     type(interaction_t), pointer :: int
     type(beam_t), intent(in), target :: beam
     int => beam%int
   end function beam_get_int_ptr
 
 @ %def beam_get_int_ptr
 @ Set beam momenta directly.  (Used for cascade decays.)
 <<Beams: public>>=
   public :: beam_set_momenta
 <<Beams: procedures>>=
   subroutine beam_set_momenta (beam, p)
     type(beam_t), intent(inout) :: beam
     type(vector4_t), dimension(:), intent(in) :: p
     call beam%int%set_momenta (p)
   end subroutine beam_set_momenta
 
 @ %def beam_set_momenta
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[beams_ut.f90]]>>=
 <<File header>>
 
 module beams_ut
   use unit_tests
   use beams_uti
 
 <<Standard module head>>
 
 <<Beams: public test>>
 
 contains
 
 <<Beams: test driver>>
 
 end module beams_ut
 @ %def beams_ut
 @
 <<[[beams_uti.f90]]>>=
 <<File header>>
 
 module beams_uti
 
 <<Use kinds>>
   use lorentz
   use flavors
   use interactions, only: reset_interaction_counter
   use polarizations, only: smatrix_t
   use model_data
   use beam_structures
 
   use beams
 
 <<Standard module head>>
 
 <<Beams: test declarations>>
 
 contains
 
 <<Beams: tests>>
 
 end module beams_uti
 @ %def beams_ut
 @ API: driver for the unit tests below.
 <<Beams: public test>>=
   public :: beams_test
 <<Beams: test driver>>=
   subroutine beams_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Beams: execute tests>>
   end subroutine beams_test
 
 @  %def beams_test
 @ Test the basic beam setup.
 <<Beams: execute tests>>=
   call test (beam_1, "beam_1", &
        "check basic beam setup", &
        u, results)
 <<Beams: test declarations>>=
   public :: beam_1
 <<Beams: tests>>=
   subroutine beam_1 (u)
     integer, intent(in) :: u
     type(beam_data_t), target :: beam_data
     type(beam_t) :: beam
     real(default) :: sqrts
     type(flavor_t), dimension(2) :: flv
     type(smatrix_t), dimension(2) :: smatrix
     real(default), dimension(2) :: pol_f
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: beam_1"
     write (u, "(A)")  "*   Purpose: test basic beam setup"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* Unpolarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
 
     call beam_data%init_sqrts (sqrts, flv)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call beam_data%init_sqrts (sqrts, flv)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call beam_data%init_sqrts (sqrts, flv)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
 
     call smatrix(1)%init (2, 1)
     call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default))
     pol_f(1) = 0.5_default
 
     call smatrix(2)%init (2, 3)
     call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default))
     call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default))
     call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default))
     pol_f(2) = 1._default
 
     call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call smatrix(1)%init (2, 0)
     pol_f(1) = 0._default
 
     call smatrix(2)%init (2, 1)
     call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default))
     pol_f(2) = 1._default
 
     call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call smatrix(1)%init (2, 0)
     pol_f(1) = 0._default
 
     call smatrix(2)%init (2, 1)
     call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default))
     pol_f(2) = 1._default
 
     call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
 
     call beam_data%init_decay (flv(1:1))
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
     call smatrix(1)%init (2, 1)
     call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default))
     pol_f(1) = 0.4_default
 
     call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1))
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call beam_final (beam)
     call beam_data%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_1"
 
   end subroutine beam_1
 
 @ %def beam_1
 @ Test advanced beam setup.
 <<Beams: execute tests>>=
   call test (beam_2, "beam_2", &
        "beam initialization", &
        u, results)
 <<Beams: test declarations>>=
   public :: beam_2
 <<Beams: tests>>=
   subroutine beam_2 (u)
     integer, intent(in) :: u
     type(beam_data_t), target :: beam_data
     type(beam_t) :: beam
     real(default) :: sqrts
     type(flavor_t), dimension(2) :: flv
     integer, dimension(0) :: no_records
     type(beam_structure_t) :: beam_structure
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: beam_2"
     write (u, "(A)")  "*   Purpose: transfer beam polarization using &
          &beam structure"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* Unpolarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%final_pol ()
 
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%final_pol ()
 
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%final_pol ()
 
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%init_pol (2)
 
     call beam_structure%init_smatrix (1, 1)
     call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default))
 
     call beam_structure%init_smatrix (2, 3)
     call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default))
     call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default))
     call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default))
 
     call beam_structure%set_pol_f ([0.5_default, 1._default])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
     write (u, *)
 
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     call beam_final (beam)
     call beam_data%final ()
     call beam_structure%final_pol ()
     call beam_structure%final_sf ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%init_pol (2)
 
     call beam_structure%init_smatrix (1, 0)
 
     call beam_structure%init_smatrix (2, 1)
     call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default))
 
     call beam_structure%set_pol_f ([0._default, 1._default])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%init_pol (2)
 
     call beam_structure%init_smatrix (1, 0)
 
     call beam_structure%init_smatrix (2, 1)
     call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default))
     call beam_structure%write (u)
 
     write (u, "(A)")
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
 
     call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
     call beam_structure%final_pol ()
     call beam_structure%write (u)
 
     write (u, "(A)")
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
     call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
 
     call beam_structure%init_pol (1)
 
     call beam_structure%init_smatrix (1, 1)
     call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default))
     call beam_structure%set_pol_f ([0.4_default])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call beam_final (beam)
     call beam_data%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_2"
 
   end subroutine beam_2
 
 @ %def beam_2
 @ Test advanced beam setup, completely arbitrary momenta.
 <<Beams: execute tests>>=
   call test (beam_3, "beam_3", &
        "generic beam momenta", &
        u, results)
 <<Beams: test declarations>>=
   public :: beam_3
 <<Beams: tests>>=
   subroutine beam_3 (u)
     integer, intent(in) :: u
     type(beam_data_t), target :: beam_data
     type(beam_t) :: beam
     type(flavor_t), dimension(2) :: flv
     integer, dimension(0) :: no_records
     type(model_data_t), target :: model
     type(beam_structure_t) :: beam_structure
     type(vector3_t), dimension(2) :: p3
     type(vector4_t), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: beam_3"
     write (u, "(A)")  "*   Purpose: set up beams with generic momenta"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* 1: Scattering process"
     write (u, "(A)")
 
     call flv%init ([2212,2212], model)
 
     p3(1) = vector3_moving ([5._default, 0._default, 10._default])
     p3(2) = -vector3_moving ([1._default, 1._default, -10._default])
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%set_momentum (p3 ** 1)
     call beam_structure%set_theta (polar_angle (p3))
     call beam_structure%set_phi (azimuthal_angle (p3))
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, 0._default, model)
     call pacify (beam_data%l_cm_to_lab, 1e-20_default)
     call beam_data%compute_md5sum ()
     call beam_data%write (u, verbose = .true.)
     write (u, *)
 
     write (u, "(1x,A)")  "Beam momenta reconstructed from LT:"
     p = beam_data%L_cm_to_lab * beam_data%p_cm
     call pacify (p, 1e-12_default)
     call vector4_write (p(1), u)
     call vector4_write (p(2), u)
     write (u, "(A)")
 
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     call beam_final (beam)
     call beam_data%final ()
     call beam_structure%final_sf ()
     call beam_structure%final_mom ()
 
     write (u, "(A)")
     write (u, "(A)")  "* 2: Decay"
     write (u, "(A)")
 
     call flv(1)%init (23, model)
     p3(1) = vector3_moving ([10._default, 5._default, 50._default])
 
     call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
     call beam_structure%set_momentum ([p3(1) ** 1])
     call beam_structure%set_theta ([polar_angle (p3(1))])
     call beam_structure%set_phi ([azimuthal_angle (p3(1))])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, 0._default, model)
     call beam_data%write (u, verbose = .true.)
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Beam momentum reconstructed from LT:"
     p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1)
     call pacify (p(1), 1e-12_default)
     call vector4_write (p(1), u)
     write (u, "(A)")
 
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call beam_final (beam)
     call beam_data%final ()
     call beam_structure%final_sf ()
     call beam_structure%final_mom ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_3"
 
   end subroutine beam_3
 
 @ %def beam_3
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Tools}
 
 This module contains auxiliary procedures that can be accessed by the
 structure function code.
 
 <<[[sf_aux.f90]]>>=
 <<File header>>
 
 module sf_aux
 
 <<Use kinds>>
   use io_units
   use constants, only: twopi
   use numeric_utils
 
   use lorentz
 
 <<Standard module head>>
 
 <<SF aux: public>>
 
 <<SF aux: parameters>>
 
 <<SF aux: types>>
 
 contains
 
 <<SF aux: procedures>>
 
 end module sf_aux
 
 @ %def sf_aux
 @
 \subsection{Momentum splitting}
 Let us consider first an incoming parton with momentum $k$ and
 invariant mass squared $s=k^2$ that splits into two partons with
 momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$.  (This is an
 abuse of the Mandelstam notation.  $t$ is actually the momentum
 transfer, assuming that $p$ is radiated and $q$ initiates the hard
 process.) The energy is split among the partons such that if $E=k^0$,
 we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$.
 
 We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the
 momentum axis of the incoming momentum $k$.  Ignoring azimuthal angle,
 we can write the four-momenta in the basis $(E,p_T,p_L)$ as
 \begin{equation}
   k =
   \begin{pmatrix}
     E \\ 0 \\ p
   \end{pmatrix},
   \qquad
   p =
   \begin{pmatrix}
     \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta
   \end{pmatrix},
   \qquad
   q =
   \begin{pmatrix}
     x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta
   \end{pmatrix},
 \end{equation}
 where the first two mass-shell conditions are
 \begin{equation}
   p^2 = E^2 - s,
   \qquad
   \bar p^2 = E^2 - \frac{u}{\bar x^2}.
 \end{equation}
 The second condition implies that, for positive $u$, $\bar x^2 >
 u/E^2$, or equivalently
 \begin{equation}
   x < 1 - \sqrt{u} / E.
 \end{equation}
 
 We are interested in the third mass-shell conditions: $s$ and $u$ are
 fixed, so we need $t$ as a function of $\cos\theta$:
 \begin{equation}
   t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u.
 \end{equation}
 Solving for $\cos\theta$, we get
 \begin{equation}
   \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}.
 \end{equation}
 We can compute $\sin\theta$ numerically as
 $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this
 in view of numerical stability.  To this end, we first determine the
 bounds for $t$.  The cosine must be between $-1$ and $1$, so the
 bounds are
 \begin{align}
   t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u,
 \\
   t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u.
 \end{align}
 Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the
 numerator is a quadratic polynomial in $t$ which has the zeros $t_0$
 and $t_1$, while the common denominator is given by $(2\bar x p\bar
 p)^2$.  Hence, we can write
 \begin{equation}
   \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2}
   \qquad\text{and}\qquad
   \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p},
 \end{equation}
 which is free of large cancellations near $t=t_0$ or $t=t_1$.
 
 If all is massless, i.e., $s=u=0$, this simplifies to
 \begin{align}
   t_0 &= -4\bar x E^2,
 &
   t_1 &= 0,
 \\
   \sin^2\theta &= -\frac{t}{\bar x E^2}
                    \left(1 + \frac{t}{4\bar x E^2}\right),
 &
   \cos\theta &= 1 + \frac{t}{2\bar x E^2}.
 \end{align}
 
 Here is the implementation.  First, we define a container for the
 kinematical integration limits and some further data.
 
 Note: contents are public only for easy access in unit test.
 <<SF aux: public>>=
   public :: splitting_data_t
 <<SF aux: types>>=
   type :: splitting_data_t
 !     private
      logical :: collinear = .false.
      real(default) :: x0 = 0
      real(default) :: x1
      real(default) :: t0
      real(default) :: t1
      real(default) :: phi0 = 0
      real(default) :: phi1 = twopi
      real(default) :: E, p, s, u, m2
      real(default) :: x, xb, pb
      real(default) :: t = 0
      real(default) :: phi = 0
    contains
    <<SF aux: splitting data: TBP>>
   end type splitting_data_t
 
 @ %def splitting_data_t
 @ I/O for debugging:
 <<SF aux: splitting data: TBP>>=
   procedure :: write => splitting_data_write
 <<SF aux: procedures>>=
   subroutine splitting_data_write (d, unit)
     class(splitting_data_t), intent(in) :: d
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A)") "Splitting data:"
     write (u, "(2x,A,L1)")  "collinear = ", d%collinear
 1   format (2x,A,1x,ES15.8)
     write (u, 1) "x0   =", d%x0
     write (u, 1) "x    =", d%x
     write (u, 1) "xb   =", d%xb
     write (u, 1) "x1   =", d%x1
     write (u, 1) "t0   =", d%t0
     write (u, 1) "t    =", d%t
     write (u, 1) "t1   =", d%t1
     write (u, 1) "phi0 =", d%phi0
     write (u, 1) "phi  =", d%phi
     write (u, 1) "phi1 =", d%phi1
     write (u, 1) "E    =", d%E
     write (u, 1) "p    =", d%p
     write (u, 1) "pb   =", d%pb
     write (u, 1) "s    =", d%s
     write (u, 1) "u    =", d%u
     write (u, 1) "m2   =", d%m2
   end subroutine splitting_data_write
 
 @ %def splitting_data_write
 @
 \subsection{Constant data}
 This is the initializer for the data.  The input consists of the
 incoming momentum, its invariant mass squared, and the invariant mass
 squared of the radiated particle.  $m2$ is the \emph{physical} mass
 squared of the outgoing particle.  The $t$ bounds depend on the chosen $x$
 value and cannot be determined yet.
 <<SF aux: splitting data: TBP>>=
   procedure :: init => splitting_data_init
 <<SF aux: procedures>>=
   subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear)
     class(splitting_data_t), intent(out) :: d
     type(vector4_t), intent(in) :: k
     real(default), intent(in) :: mk2, mr2, mo2
     logical, intent(in), optional :: collinear
     if (present (collinear))  d%collinear = collinear
     d%E = energy (k)
     d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E
     d%p = sqrt (d%E**2 - mk2)
     d%s = mk2
     d%u = mr2
     d%m2 = mo2
   end subroutine splitting_data_init
 
 @ %def splitting_data_init
 @ Retrieve the $x$ bounds, if needed for $x$ sampling.  Generating an
 $x$ value is done by the caller, since this is the part that depends
 on the nature of the structure function.
 <<SF aux: splitting data: TBP>>=
   procedure :: get_x_bounds => splitting_get_x_bounds
 <<SF aux: procedures>>=
   function splitting_get_x_bounds (d) result (x)
     class(splitting_data_t), intent(in) :: d
     real(default), dimension(2) :: x
     x = [ d%x0, d%x1 ]
   end function splitting_get_x_bounds
 
 @ %def splitting_get_x_bounds
 @ Now set the momentum fraction and compute $t_0$ and $t_1$.
 
 [The calculation of $t_1$ is subject to numerical problems.  The exact
 formula is ($s=m_i^2$, $u=m_r^2$)
 \begin{equation}
   t_1 = -2\bar x E^2 + m_i^2 + m_r^2
   + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}.
 \end{equation}
 The structure-function paradigm is useful only if $E\gg m_i,m_r$.  In
 a Taylor expansion for large $E$, the leading term cancels.  The
 expansion of the square roots (to subleading order) yields
 \begin{equation}
   t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2.
 \end{equation}
 There are two cases of interest: $m_i=m_o$ and $m_r=0$,
 \begin{equation}
   t_1 = xm_o^2
 \end{equation}
 and $m_i=m_r$ and $m_o=0$,
 \begin{equation}
   t_1 = -\frac{x^2}{\bar x}m_i^2.
 \end{equation}
 In both cases, $t_1\leq m_o^2$.]
 
 That said, it turns out that taking the $t_1$ evaluation at face value
 leads to less problems than the approximation.  We express the angles
 in terms of $t-t_0$ and $t-t_1$.  Numerical noise in $t_1$ can then be
 tolerated.
 <<SF aux: splitting data: TBP>>=
   procedure :: set_t_bounds => splitting_set_t_bounds
 <<SF aux: procedures>>=
   elemental subroutine splitting_set_t_bounds (d, x, xb)
     class(splitting_data_t), intent(inout) :: d
     real(default), intent(in), optional :: x, xb
     real(default) :: tp, tm
     if (present (x))  d%x = x
     if (present (xb)) d%xb = xb
     if (vanishes (d%u)) then
        d%pb = d%E
     else
        if (.not. vanishes (d%xb)) then
           d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default))
        else
           d%pb = 0
        end if
     end if
     tp = -2 * d%xb * d%E**2 + d%s + d%u
     tm = -2 * d%xb * d%p * d%pb
     d%t0 = tp + tm
     d%t1 = tp - tm
     d%t = d%t1
   end subroutine splitting_set_t_bounds
 
 @ %def splitting_set_t_bounds
 @
 \subsection{Sampling recoil}
 Compute a value for the momentum transfer $t$, using a random number
 $r$.  We assume a logarithmic distribution for $t-m^2$, corresponding
 to the propagator $1/(t-m^2)$ with the physical mass $m$ for the
 outgoing particle.  Optionally, we can narrow the kinematical bounds.
 
 If all three masses in the splitting vanish, the upper limit for $t$
 is zero.  In that case, the $t$ value is set to zero and the splitting
 will be collinear.
 <<SF aux: splitting data: TBP>>=
   procedure :: sample_t => splitting_sample_t
 <<SF aux: procedures>>=
   subroutine splitting_sample_t (d, r, t0, t1)
     class(splitting_data_t), intent(inout) :: d
     real(default), intent(in) :: r
     real(default), intent(in), optional :: t0, t1
     real(default) :: tt0, tt1, tt0m, tt1m
     if (d%collinear) then
        d%t = d%t1
     else
        tt0 = d%t0;  if (present (t0))  tt0 = max (t0, tt0)
        tt1 = d%t1;  if (present (t1))  tt1 = min (t1, tt1)
        tt0m = tt0 - d%m2
        tt1m = tt1 - d%m2
        if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > &
             epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then
           d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m))
        else
           d%t = tt1
        end if
     end if
   end subroutine splitting_sample_t
 
 @ %def splitting_sample_t
 @ The inverse operation: Given $t$, we recover the value of $r$ that
 would have produced this value.
 <<SF aux: splitting data: TBP>>=
   procedure :: inverse_t => splitting_inverse_t
 <<SF aux: procedures>>=
   subroutine splitting_inverse_t (d, r, t0, t1)
     class(splitting_data_t), intent(in) :: d
     real(default), intent(out) :: r
     real(default), intent(in), optional :: t0, t1
     real(default) :: tt0, tt1, tt0m, tt1m
     if (d%collinear) then
        r = 0
     else
        tt0 = d%t0;  if (present (t0))  tt0 = max (t0, tt0)
        tt1 = d%t1;  if (present (t1))  tt1 = min (t1, tt1)
        tt0m = tt0 - d%m2
        tt1m = tt1 - d%m2
        if (tt0m < 0 .and. tt1m < 0) then
           r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m)
        else
           r = 0
        end if
     end if
   end subroutine splitting_inverse_t
 
 @ %def splitting_inverse_t
 @ This is trivial, but provided for convenience:
 <<SF aux: splitting data: TBP>>=
   procedure :: sample_phi => splitting_sample_phi
 <<SF aux: procedures>>=
   subroutine splitting_sample_phi (d, r)
     class(splitting_data_t), intent(inout) :: d
     real(default), intent(in) :: r
     if (d%collinear) then
        d%phi = 0
     else
        d%phi = (1-r) * d%phi0 + r * d%phi1
     end if
   end subroutine splitting_sample_phi
 
 @ %def splitting_sample_phi
 @ Inverse:
 <<SF aux: splitting data: TBP>>=
   procedure :: inverse_phi => splitting_inverse_phi
 <<SF aux: procedures>>=
   subroutine splitting_inverse_phi (d, r)
     class(splitting_data_t), intent(in) :: d
     real(default), intent(out) :: r
     if (d%collinear) then
        r = 0
     else
        r = (d%phi - d%phi0) / (d%phi1 - d%phi0)
     end if
   end subroutine splitting_inverse_phi
 
 @ %def splitting_inverse_phi
 @
 \subsection{Splitting}
 In this function, we actually perform the splitting.  The incoming momentum
 $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$.
 
 Apart from the splitting data, we need the incoming momentum $k$, the momentum
 transfer $t$, and the azimuthal angle $\phi$.  The momentum fraction $x$ is
 already known here.
 
 Alternatively, we can split without recoil.  The azimuthal angle is
 irrelevant, and the momentum transfer is always equal to the upper
 limit $t_1$, so the polar angle is zero.  Obviously, if there are
 nonzero masses it is not possible to keep both energy-momentum
 conservation and at the same time all particles on shell.  We choose
 for dropping the on-shell condition here.
 <<SF aux: splitting data: TBP>>=
   procedure :: split_momentum => splitting_split_momentum
 <<SF aux: procedures>>=
   function splitting_split_momentum (d, k) result (q)
     class(splitting_data_t), intent(in) :: d
     type(vector4_t), dimension(2) :: q
     type(vector4_t), intent(in) :: k
     real(default) :: st2, ct2, st, ct, cp, sp
     type(lorentz_transformation_t) :: rot
     real(default) :: tt0, tt1, den
     type(vector3_t) :: kk, q1, q2
     if (d%collinear) then
        if (vanishes (d%s) .and. vanishes(d%u)) then
           q(1) = d%xb * k
           q(2) = d%x * k
        else
           kk = space_part (k)
           q1 = d%xb * (d%pb / d%p) * kk
           q2 = kk - q1
           q(1) = vector4_moving (d%xb * d%E, q1)
           q(2) = vector4_moving (d%x * d%E, q2)
        end if
     else
        den = 2 * d%xb * d%p * d%pb
        tt0 = max (d%t - d%t0, 0._default)
        tt1 = min (d%t - d%t1, 0._default)
        if (den**2 <= epsilon(den)) then
           st2 = 0
        else
           st2 = - (tt0 * tt1) / den ** 2
        end if
        if (st2 > 1) then
           st2 = 1
        end if
        ct2 = 1 - st2
        st = sqrt (max (st2, 0._default))
        ct = sqrt (max (ct2, 0._default))
        if ((d%t - d%t0 + d%t - d%t1) < 0) then
           ct = - ct
        end if
        sp = sin (d%phi)
        cp = cos (d%phi)
        rot = rotation_to_2nd (3, space_part (k))
        q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct])
        q2 = vector3_moving (d%p, 3) - q1
        q(1) = rot * vector4_moving (d%xb * d%E, q1)
        q(2) = rot * vector4_moving (d%x * d%E, q2)
     end if
   end function splitting_split_momentum
 
 @ %def splitting_split_momentum
 @
 Momenta generated by splitting will in general be off-shell.  They are
 on-shell only if they are collinear and massless.  This subroutine
 puts them on shell by brute force, violating either momentum or energy
 conservation.  The direction of three-momentum is always retained.
 
 If the energy is below mass shell, we return a zero momentum.
 <<SF aux: parameters>>=
   integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1
 @ %def KEEP_ENERGY KEEP_MOMENTUM
 <<SF aux: public>>=
   public :: on_shell
 <<SF aux: procedures>>=
   elemental subroutine on_shell (p, m2, keep)
     type(vector4_t), intent(inout) :: p
     real(default), intent(in) :: m2
     integer, intent(in) :: keep
     real(default) :: E, E2, pn
     select case (keep)
     case (KEEP_ENERGY)
        E = energy (p)
        E2 = E ** 2
        if (E2 >= m2) then
           pn = sqrt (E2 - m2)
           p = vector4_moving (E, pn * direction (space_part (p)))
        else
           p = vector4_null
        end if
     case (KEEP_MOMENTUM)
        E = sqrt (space_part (p) ** 2 + m2)
        p = vector4_moving (E, space_part (p))
     end select
   end subroutine on_shell
 
 @ %def on_shell
 @
 \subsection{Recovering the splitting}
 This is the inverse problem.  We have on-shell momenta and want to
 deduce the splitting parameters $x$, $t$, and $\phi$.
 
 Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use
 not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]]
 for recovering $x$ and $\bar x$ separately.  If $x$ happens to be
 close to $1$, we would completely lose the tiny $\bar x$ value,
 otherwise, and thus get a meaningless result.
 <<SF aux: splitting data: TBP>>=
   procedure :: recover => splitting_recover
 <<SF aux: procedures>>=
   subroutine splitting_recover (d, k, q, keep)
     class(splitting_data_t), intent(inout) :: d
     type(vector4_t), intent(in) :: k
     type(vector4_t), dimension(2), intent(in) :: q
     integer, intent(in) :: keep
     type(lorentz_transformation_t) :: rot
     type(vector4_t) :: k0
     type(vector4_t), dimension(2) :: q0
     real(default) :: p1, p2, p3, pt2, pp2, pl
     real(default) :: aux, den, norm
     real(default) :: st2, ct2, ct
     rot = inverse (rotation_to_2nd (3, space_part (k)))
     q0 = rot * q
     p1 = vector4_get_component (q0(2), 1)
     p2 = vector4_get_component (q0(2), 2)
     p3 = vector4_get_component (q0(2), 3)
     pt2 = p1 ** 2 + p2 ** 2
     pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2
     pl = abs (p3)
     k0 = vector4_moving (d%E, d%p, 3)
     select case (keep)
     case (KEEP_ENERGY)
        d%x = energy (q0(2)) / d%E
        d%xb = energy (q0(1)) / d%E
        call d%set_t_bounds ()
        if (.not. d%collinear) then
           aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2
           den = d%p ** 2 - (d%xb * d%pb) ** 2
           if (aux >= 0 .and. den > 0) then
              norm = (d%p * pl + sqrt (aux)) / den
           else
              norm = 1
           end if
        end if
     case (KEEP_MOMENTUM)
        d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E
        d%x = 1 - d%xb
        call d%set_t_bounds ()
        norm = 1
     end select
     if (d%collinear) then
        d%t = d%t1
        d%phi = 0
     else
        if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then
           st2 = 1
        else
           st2 = pt2 / (d%xb * d%pb * norm ) ** 2
        end if
        if (st2 > 1) then
           st2 = 1
        end if
        ct2 = 1 - st2
        ct = sqrt (max (ct2, 0._default))
        if (.not. vanishes (1 + ct)) then
           d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct)
        else
           d%t = d%t0
        end if
        if (.not. vanishes (p1) .or. .not. vanishes (p2)) then
           d%phi = atan2 (-p2, -p1)
        else
           d%phi = 0
        end if
     end if
   end subroutine splitting_recover
 
 @ %def splitting_recover
 @
 \subsection{Extract data}
 <<SF aux: splitting data: TBP>>=
   procedure :: get_x => splitting_get_x
   procedure :: get_xb => splitting_get_xb
 <<SF aux: procedures>>=
   function splitting_get_x (sd) result (x)
     class(splitting_data_t), intent(in) :: sd
     real(default) :: x
     x = sd%x
   end function splitting_get_x
 
   function splitting_get_xb (sd) result (xb)
     class(splitting_data_t), intent(in) :: sd
     real(default) :: xb
     xb = sd%xb
   end function splitting_get_xb
 
 @ %def splitting_get_x
 @ %def splitting_get_xb
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_aux_ut.f90]]>>=
 <<File header>>
 
 module sf_aux_ut
   use unit_tests
   use sf_aux_uti
 
 <<Standard module head>>
 
 <<SF aux: public test>>
 
 contains
 
 <<SF aux: test driver>>
 
 end module sf_aux_ut
 @ %def sf_aux_ut
 @
 <<[[sf_aux_uti.f90]]>>=
 <<File header>>
 
 module sf_aux_uti
 
 <<Use kinds>>
   use lorentz
 
   use sf_aux
 
 <<Standard module head>>
 
 <<SF aux: test declarations>>
 
 contains
 
 <<SF aux: tests>>
 
 end module sf_aux_uti
 @ %def sf_aux_ut
 @ API: driver for the unit tests below.
 <<SF aux: public test>>=
   public :: sf_aux_test
 <<SF aux: test driver>>=
   subroutine sf_aux_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF aux: execute tests>>
   end subroutine sf_aux_test
 
 @ %def sf_aux_test
 @
 \subsubsection{Momentum splitting: massless radiation}
 Compute momentum splitting for generic kinematics.  It turns out that
 for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and
 lower bounds (this can be directly seen from the logarithmic
 distribution in the function [[sample_t]] for $r \equiv x = 1 - x =
 0.5$), we arrive at an exact number $t=-0.15$ for the given
 input values.
 <<SF aux: execute tests>>=
   call test (sf_aux_1, "sf_aux_1", &
        "massless radiation", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_1
 <<SF aux: tests>>=
   subroutine sf_aux_1 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q, q0
     real(default) :: E, mk, mp, mq
     real(default) :: x, r1, r2, r1o, r2o
     real(default) :: k2, q0_2, q1_2, q2_2
 
     write (u, "(A)")  "* Test output: sf_aux_1"
     write (u, "(A)")  "*   Purpose: compute momentum splitting"
     write (u, "(A)")  "             (massless radiated particle)"
     write (u, "(A)")
 
     E = 1
     mk = 0.3_default
     mp = 0
     mq = mk
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
     k2 = k ** 2;  call pacify (k2, 1e-10_default)
 
     x = 0.6_default
     r1 = 0.5_default
     r2 = 0.125_default
 
     write (u, "(A)")  "* (1) Non-collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%sample_t (r1)
     call sd%sample_phi (r2)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Extract: x, 1-x"
     write (u, "(2(1x,F11.8))")  sd%get_x (), sd%get_xb ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, 1 - x)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_1"
 
   end subroutine sf_aux_1
 
 @ %def sf_aux_1
 @
 \subsubsection{Momentum splitting: massless parton}
 Compute momentum splitting for generic kinematics.  It turns out that
 for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and
 lower bounds, we arrive at an exact number $t=-0.36$ for the given
 input values.
 <<SF aux: execute tests>>=
   call test (sf_aux_2, "sf_aux_2", &
        "massless parton", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_2
 <<SF aux: tests>>=
   subroutine sf_aux_2 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q, q0
     real(default) :: E, mk, mp, mq
     real(default) :: x, r1, r2, r1o, r2o
     real(default) :: k2, q02_2, q1_2, q2_2
 
     write (u, "(A)")  "* Test output: sf_aux_2"
     write (u, "(A)")  "*   Purpose: compute momentum splitting"
     write (u, "(A)")  "             (massless outgoing particle)"
     write (u, "(A)")
 
     E = 1
     mk = 0.3_default
     mp = mk
     mq = 0
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
     k2 = k ** 2;  call pacify (k2, 1e-10_default)
 
     x = 0.6_default
     r1 = 0.5_default
     r2 = 0.125_default
 
     write (u, "(A)")  "* (1) Non-collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%sample_t (r1)
     call sd%sample_phi (r2)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, 1 - x)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_2"
 
   end subroutine sf_aux_2
 
 @ %def sf_aux_2
 @
 \subsubsection{Momentum splitting: all massless}
 Compute momentum splitting for massless kinematics.  In the non-collinear
 case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution
 is not possible.
 <<SF aux: execute tests>>=
   call test (sf_aux_3, "sf_aux_3", &
        "massless parton", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_3
 <<SF aux: tests>>=
   subroutine sf_aux_3 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q, q0
     real(default) :: E, mk, mp, mq, qmin, qmax
     real(default) :: x, r1, r2, r1o, r2o
     real(default) :: k2, q02_2, q1_2, q2_2
 
     write (u, "(A)")  "* Test output: sf_aux_3"
     write (u, "(A)")  "*   Purpose: compute momentum splitting"
     write (u, "(A)")  "             (all massless, q cuts)"
     write (u, "(A)")
 
     E = 1
     mk = 0
     mp = 0
     mq = 0
     qmin = 1e-2_default
     qmax = 1e0_default
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
     k2 = k ** 2;  call pacify (k2, 1e-10_default)
 
     x = 0.6_default
     r1 = 0.5_default
     r2 = 0.125_default
 
     write (u, "(A)")  "* (1) Non-collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2)
     call sd%sample_phi (r2)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
 
     call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, 1 - x)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_3"
 
   end subroutine sf_aux_3
 
 @ %def sf_aux_3
 @
 \subsubsection{Endpoint stability}
 Compute momentum splitting for collinear kinematics close to both
 endpoints.  In particular, check both directions $x\to$ momenta and
 momenta $\to x$.
 
 For purely massless collinear splitting, the [[KEEP_XXX]] flag is
 irrelevant.  We choose [[KEEP_ENERGY]] here.
 <<SF aux: execute tests>>=
   call test (sf_aux_4, "sf_aux_4", &
        "endpoint numerics", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_4
 <<SF aux: tests>>=
   subroutine sf_aux_4 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E, mk, mp, mq, qmin, qmax
     real(default) :: x, xb
 
     write (u, "(A)")  "* Test output: sf_aux_4"
     write (u, "(A)")  "*   Purpose: compute massless collinear splitting near endpoint"
 
     E = 1
     mk = 0
     mp = 0
     mq = 0
     qmin = 1e-2_default
     qmax = 1e0_default
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
 
     x = 0.1_default
     xb = 1 - x
 
     write (u, "(A)")
     write (u, "(A)")  "* (1) Collinear setup, moderate kinematics"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momenta"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
     call sd%recover (k, q, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  xb, sd%xb
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Close to x=0"
     write (u, "(A)")
 
     x = 1e-9_default
     xb = 1 - x
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momenta"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
     call sd%recover (k, q, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  xb, sd%xb
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (3) Close to x=1"
     write (u, "(A)")
 
     xb = 1e-9_default
     x = 1 - xb
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momenta"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
     call sd%recover (k, q, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  xb, sd%xb
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_4"
 
   end subroutine sf_aux_4
 
 @ %def sf_aux_4
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Mappings for structure functions}
 In this module, we provide a wrapper for useful mappings of the unit
 (hyper-)square that we can apply to a set of structure functions.
 
 In some cases it is useful, or even mandatory, to map the MC input
 parameters nontrivially onto a set of structure functions for the two
 beams.  In all cases considered here, instead of $x_1,x_2,\ldots$ as
 parameters for the beams, we generate one parameter that is equal, or
 related to, the product $x_1x_2\cdots$ (so it directly corresponds to
 $\sqrt{s}$).  The other parameters describe the distribution of energy
 (loss) between beams and radiations.
 <<[[sf_mappings.f90]]>>=
 <<File header>>
 
 module sf_mappings
 
 <<Use kinds>>
   use kinds, only: double
   use io_units
   use constants, only: pi, zero, one
   use numeric_utils
   use diagnostics
 
 <<Standard module head>>
 
 <<SF mappings: public>>
 
 <<SF mappings: parameters>>
 
 <<SF mappings: types>>
 
 <<SF mappings: interfaces>>
 
 contains
 
 <<SF mappings: procedures>>
 
 end module sf_mappings
 @ %def sf_mappings
 @
 \subsection{Base type}
 First, we define an abstract base type for the mapping.  In all cases
 we need to store the indices of the parameters on which the mapping
 applies.   Additional parameters can be stored in the extensions of
 this type.
 <<SF mappings: public>>=
   public :: sf_mapping_t
 <<SF mappings: types>>=
   type, abstract :: sf_mapping_t
      integer, dimension(:), allocatable :: i
    contains
    <<SF mappings: sf mapping: TBP>>
   end type sf_mapping_t
 
 @ %def sf_mapping_t
 @ The output routine is deferred:
 <<SF mappings: sf mapping: TBP>>=
   procedure (sf_mapping_write), deferred :: write
 <<SF mappings: interfaces>>=
   abstract interface
      subroutine sf_mapping_write (object, unit)
        import
        class(sf_mapping_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine sf_mapping_write
   end interface
 
 @ %def sf_mapping_write
 @ Initializer for the base type.  The array of parameter indices is
 allocated but initialized to zero.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: base_init => sf_mapping_base_init
 <<SF mappings: procedures>>=
   subroutine sf_mapping_base_init (mapping, n_par)
     class(sf_mapping_t), intent(out) :: mapping
     integer, intent(in) :: n_par
     allocate (mapping%i (n_par))
     mapping%i = 0
   end subroutine sf_mapping_base_init
 
 @ %def sf_mapping_base_init
 @ Set an index value.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: set_index => sf_mapping_set_index
 <<SF mappings: procedures>>=
   subroutine sf_mapping_set_index (mapping, j, i)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
   end subroutine sf_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Retrieve an index value.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: get_index => sf_mapping_get_index
 <<SF mappings: procedures>>=
   function sf_mapping_get_index (mapping, j) result (i)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j
     integer :: i
     i = mapping%i(j)
   end function sf_mapping_get_index
 
 @ %def sf_mapping_get_index
 @ Return the dimensionality, i.e., the number of parameters.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: get_n_dim => sf_mapping_get_n_dim
 <<SF mappings: procedures>>=
   function sf_mapping_get_n_dim (mapping) result (n)
     class(sf_mapping_t), intent(in) :: mapping
     integer :: n
     n = size (mapping%i)
   end function sf_mapping_get_n_dim
 
 @ %def sf_mapping_get_n_dim
 @ Computation: the values [[p]] are the input parameters, the values
 [[r]] are the output parameters.  The values [[rb]] are defined as
 $\bar r = 1 - r$, but provided explicitly.  They allow us to avoid
 numerical problems near $r=1$.
 
 The extra parameter [[x_free]]
 indicates that the total energy has already been renormalized by this
 factor.  We have to take such a factor into account in a resonance or
 on-shell mapping.
 
 The Jacobian is [[f]].  We modify only
 the two parameters indicated by the indices [[i]].
 <<SF mappings: sf mapping: TBP>>=
   procedure (sf_mapping_compute), deferred :: compute
 <<SF mappings: interfaces>>=
   abstract interface
      subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free)
        import
        class(sf_mapping_t), intent(inout) :: mapping
        real(default), dimension(:), intent(out) :: r, rb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(in) :: p, pb
        real(default), intent(inout), optional :: x_free
      end subroutine sf_mapping_compute
   end interface
 
 @ %def sf_mapping_compute
 @ The inverse mapping.  Use [[r]] and/or [[rb]] to reconstruct [[p]]
 and also compute [[f]].
 <<SF mappings: sf mapping: TBP>>=
   procedure (sf_mapping_inverse), deferred :: inverse
 <<SF mappings: interfaces>>=
   abstract interface
      subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
        import
        class(sf_mapping_t), intent(inout) :: mapping
        real(default), dimension(:), intent(in) :: r, rb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(out) :: p, pb
        real(default), intent(inout), optional :: x_free
      end subroutine sf_mapping_inverse
   end interface
 
 @ %def sf_mapping_inverse
 @
 \subsection{Methods for self-tests}
 This is a shorthand for: inject parameters, compute the mapping,
 display results, compute the inverse, display again.  We provide an
 output format for the parameters and, optionally, a different output
 format for the Jacobians.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: check => sf_mapping_check
 <<SF mappings: procedures>>=
   subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: u
     real(default), dimension(:), intent(in) :: p_in, pb_in
     character(*), intent(in) :: fmt_p
     character(*), intent(in), optional :: fmt_f
     real(default), dimension(size(p_in)) :: p, pb, r, rb
     real(default) :: f, tolerance
     tolerance = 1.5E-17
     p = p_in
     pb= pb_in
     call mapping%compute (r, rb, f, p, pb)
     call pacify (p, tolerance)
     call pacify (pb, tolerance)
     call pacify (r, tolerance)
     call pacify (rb, tolerance)
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "p =", p
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "pb=", pb
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "r =", r
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "rb=", rb
     if (present (fmt_f)) then
        write (u, "(3x,A,9(1x," // fmt_f // "))")  "f =", f
     else
        write (u, "(3x,A,9(1x," // fmt_p // "))")  "f =", f
     end if
     write (u, *)
     call mapping%inverse (r, rb, f, p, pb)
     call pacify (p, tolerance)
     call pacify (pb, tolerance)
     call pacify (r, tolerance)
     call pacify (rb, tolerance)
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "p =", p
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "pb=", pb
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "r =", r
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "rb=", rb
     if (present (fmt_f)) then
        write (u, "(3x,A,9(1x," // fmt_f // "))")  "f =", f
     else
        write (u, "(3x,A,9(1x," // fmt_p // "))")  "f =", f
     end if
     write (u, *)
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "*r=", product (r)
   end subroutine sf_mapping_check
 
 @ %def sf_mapping_check
 @ This is a consistency check for the self-tests: the integral over the unit
 square should be unity.  We estimate this by a simple binning and adding up
 the values; this should be sufficient for a self-test.
 
 The argument is the requested number of sampling points.  We take the square
 root for binning in both dimensions, so the precise number might be
 different.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: integral => sf_mapping_integral
 <<SF mappings: procedures>>=
   function sf_mapping_integral (mapping, n_calls) result (integral)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: n_calls
     real(default) :: integral
     integer :: n_dim, n_bin, k
     real(default), dimension(:), allocatable :: p, pb, r, rb
     integer, dimension(:), allocatable :: ii
     real(default) :: dx, f, s
 
     n_dim = mapping%get_n_dim ()
     allocate (p (n_dim))
     allocate (pb(n_dim))
     allocate (r (n_dim))
     allocate (rb(n_dim))
     allocate (ii(n_dim))
     n_bin = nint (real (n_calls, default) ** (1._default / n_dim))
     dx = 1._default / n_bin
     s = 0
     ii = 1
 
     SAMPLE: do
        do k = 1, n_dim
           p(k)  = ii(k) * dx - dx/2
           pb(k) = (n_bin - ii(k)) * dx + dx/2
        end do
        call mapping%compute (r, rb, f, p, pb)
        s = s + f
        INCR: do k = 1, n_dim
           ii(k) = ii(k) + 1
           if (ii(k) <= n_bin) then
              exit INCR
           else if (k < n_dim) then
              ii(k) = 1
           else
              exit SAMPLE
           end if
        end do INCR
     end do SAMPLE
 
     integral = s / real (n_bin, default) ** n_dim
 
   end function sf_mapping_integral
 
 @ %def sf_mapping_integral
 @
 \subsection{Implementation: standard mapping}
 This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
 while $p_2$ is related to the ratio.
 <<SF mappings: public>>=
   public :: sf_s_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_s_mapping_t
      logical :: power_set = .false.
      real(default) :: power = 1
    contains
    <<SF mappings: sf standard mapping: TBP>>
   end type sf_s_mapping_t
 
 @ %def sf_s_mapping_t
 @ Output.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: write => sf_s_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_s_mapping_write (object, unit)
     class(sf_s_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A)")  ": standard (", object%power, ")"
   end subroutine sf_s_mapping_write
 
 @ %def sf_s_mapping_write
 @ Initialize: index pair and power parameter.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: init => sf_s_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_s_mapping_init (mapping, power)
     class(sf_s_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: power
     call mapping%base_init (2)
     if (present (power)) then
        mapping%power_set = .true.
        mapping%power = power
     end if
   end subroutine sf_s_mapping_init
 
 @ %def sf_s_mapping_init
 @ Apply mapping.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: compute => sf_s_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_s_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2
     integer :: j
     if (mapping%power_set) then
        call map_unit_square (r2, f, p(mapping%i), mapping%power)
     else
        call map_unit_square (r2, f, p(mapping%i))
     end if
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_s_mapping_compute
 
 @ %def sf_s_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: inverse => sf_s_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_s_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: p2
     integer :: j
     if (mapping%power_set) then
        call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power)
     else
        call map_unit_square_inverse (r(mapping%i), f, p2)
     end if
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_s_mapping_inverse
 
 @ %def sf_s_mapping_inverse
 @
 \subsection{Implementation: resonance pair mapping}
 This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
 while $p_2$ is related to the ratio, then it maps $p_1$ to itself
 according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$
 results in a Breit-Wigner distribution.  Mass and width of the BW are
 rescaled by the energy, thus dimensionless fractions.
 <<SF mappings: public>>=
   public :: sf_res_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_res_mapping_t
      real(default) :: m = 0
      real(default) :: w = 0
    contains
    <<SF mappings: sf resonance mapping: TBP>>
   end type sf_res_mapping_t
 
 @ %def sf_res_mapping_t
 @ Output.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: write => sf_res_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_write (object, unit)
     class(sf_res_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,', ',F7.5,A)")  ": resonance (", object%m, object%w, ")"
   end subroutine sf_res_mapping_write
 
 @ %def sf_res_mapping_write
 @ Initialize: index pair and dimensionless mass and width parameters.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: init => sf_res_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_init (mapping, m, w)
     class(sf_res_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: m, w
     call mapping%base_init (2)
     mapping%m = m
     mapping%w = w
   end subroutine sf_res_mapping_init
 
 @ %def sf_res_mapping_init
 @ Apply mapping.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: compute => sf_res_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, p2
     real(default) :: fbw, f2, p1m
     integer :: j
     p2 = p(mapping%i)
     call map_breit_wigner &
          (p1m, fbw, p2(1), mapping%m, mapping%w, x_free)
     call map_unit_square (r2, f2, [p1m, p2(2)])
     f = fbw * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_res_mapping_compute
 
 @ %def sf_res_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: inverse => sf_res_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: p2
     real(default) :: fbw, f2, p1m
     call map_unit_square_inverse (r(mapping%i), f2, p2)
     call map_breit_wigner_inverse &
          (p2(1), fbw, p1m, mapping%m, mapping%w, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p1m
     pb(mapping%i(1)) = 1 - p1m
     p (mapping%i(2)) = p2(2)
     pb(mapping%i(2)) = 1 - p2(2)
     f = fbw * f2
   end subroutine sf_res_mapping_inverse
 
 @ %def sf_res_mapping_inverse
 @
 \subsection{Implementation: resonance single mapping}
 While simpler, this is needed for structure-function setups only in
 exceptional cases.
 
 This maps the unit interval ($r_1$) to itself
 according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$
 results in a Breit-Wigner distribution.  Mass and width of the BW are
 rescaled by the energy, thus dimensionless fractions.
 <<SF mappings: public>>=
   public :: sf_res_mapping_single_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_res_mapping_single_t
      real(default) :: m = 0
      real(default) :: w = 0
    contains
    <<SF mappings: sf resonance single mapping: TBP>>
   end type sf_res_mapping_single_t
 
 @ %def sf_res_mapping_single_t
 @ Output.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: write => sf_res_mapping_single_write
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_single_write (object, unit)
     class(sf_res_mapping_single_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,', ',F7.5,A)")  ": resonance (", object%m, object%w, ")"
   end subroutine sf_res_mapping_single_write
 
 @ %def sf_res_mapping_single_write
 @ Initialize: single index (!) and dimensionless mass and width parameters.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: init => sf_res_mapping_single_init
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_single_init (mapping, m, w)
     class(sf_res_mapping_single_t), intent(out) :: mapping
     real(default), intent(in) :: m, w
     call mapping%base_init (1)
     mapping%m = m
     mapping%w = w
   end subroutine sf_res_mapping_single_init
 
 @ %def sf_res_mapping_single_init
 @ Apply mapping.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: compute => sf_res_mapping_single_compute
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_single_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: r2, p2
     real(default) :: fbw
     integer :: j
     p2 = p(mapping%i)
     call map_breit_wigner &
          (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free)
     f = fbw
     r = p
     rb= pb
     r (mapping%i(1)) = r2(1)
     rb(mapping%i(1)) = 1 - r2(1)
   end subroutine sf_res_mapping_single_compute
 
 @ %def sf_res_mapping_single_compute
 @ Apply inverse.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: inverse => sf_res_mapping_single_inverse
 <<SF mappings: procedures>>=
   subroutine sf_res_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: p2
     real(default) :: fbw
     call map_breit_wigner_inverse &
          (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p2(1)
     pb(mapping%i(1)) = 1 - p2(1)
     f = fbw
   end subroutine sf_res_mapping_single_inverse
 
 @ %def sf_res_mapping_single_inverse
 @
 \subsection{Implementation: on-shell mapping}
 This is a degenerate version of the unit-square mapping where the
 product $r_1r_2$ is constant.  This product is given by the rescaled
 squared mass.  We introduce an artificial first parameter $p_1$ to
 keep the counting, but nothing depends on it.  The second parameter is
 the same $p_2$ as for the standard unit-square mapping for $\alpha=1$,
 it parameterizes the ratio of $r_1$ and $r_2$.
 <<SF mappings: public>>=
   public :: sf_os_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_os_mapping_t
      real(default) :: m = 0
      real(default) :: lm2 = 0
    contains
    <<SF mappings: sf on-shell mapping: TBP>>
   end type sf_os_mapping_t
 
 @ %def sf_os_mapping_t
 @ Output.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: write => sf_os_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_write (object, unit)
     class(sf_os_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A)")  ": on-shell (", object%m, ")"
   end subroutine sf_os_mapping_write
 
 @ %def sf_os_mapping_write
 @ Initialize: index pair and dimensionless mass parameter.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: init => sf_os_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_init (mapping, m)
     class(sf_os_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: m
     call mapping%base_init (2)
     mapping%m = m
     mapping%lm2 = abs (2 * log (mapping%m))
   end subroutine sf_os_mapping_init
 
 @ %def sf_os_mapping_init
 @ Apply mapping.  The [[x_free]] parameter rescales the total energy,
 which must be accounted for in the enclosed mapping.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: compute => sf_os_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, p2
     integer :: j
     p2 = p(mapping%i)
     call map_on_shell (r2, f, p2, mapping%lm2, x_free)
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_os_mapping_compute
 
 @ %def sf_os_mapping_compute
 @ Apply inverse.  The irrelevant parameter $p_1$ is always set zero.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: inverse => sf_os_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: p2, r2
     r2 = r(mapping%i)
     call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p2(1)
     pb(mapping%i(1)) = 1 - p2(1)
     p (mapping%i(2)) = p2(2)
     pb(mapping%i(2)) = 1 - p2(2)
   end subroutine sf_os_mapping_inverse
 
 @ %def sf_os_mapping_inverse
 @
 \subsection{Implementation: on-shell single mapping}
 This is a degenerate version of the unit-interval mapping where the
 result $r$ is constant.  The value is given by the rescaled squared
 mass.  The input parameter $p_1$ is actually ignored, nothing depends
 on it.
 <<SF mappings: public>>=
   public :: sf_os_mapping_single_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_os_mapping_single_t
      real(default) :: m = 0
      real(default) :: lm2 = 0
    contains
    <<SF mappings: sf on-shell mapping single: TBP>>
   end type sf_os_mapping_single_t
 
 @ %def sf_os_mapping_single_t
 @ Output.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: write => sf_os_mapping_single_write
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_single_write (object, unit)
     class(sf_os_mapping_single_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A)")  ": on-shell (", object%m, ")"
   end subroutine sf_os_mapping_single_write
 
 @ %def sf_os_mapping_single_write
 @ Initialize: index pair and dimensionless mass parameter.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: init => sf_os_mapping_single_init
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_single_init (mapping, m)
     class(sf_os_mapping_single_t), intent(out) :: mapping
     real(default), intent(in) :: m
     call mapping%base_init (1)
     mapping%m = m
     mapping%lm2 = abs (2 * log (mapping%m))
   end subroutine sf_os_mapping_single_init
 
 @ %def sf_os_mapping_single_init
 @ Apply mapping.  The [[x_free]] parameter rescales the total energy,
 which must be accounted for in the enclosed mapping.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: compute => sf_os_mapping_single_compute
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_single_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: r2, p2
     integer :: j
     p2 = p(mapping%i)
     call map_on_shell_single (r2, f, p2, mapping%lm2, x_free)
     r = p
     rb= pb
     r (mapping%i(1)) = r2(1)
     rb(mapping%i(1)) = 1 - r2(1)
   end subroutine sf_os_mapping_single_compute
 
 @ %def sf_os_mapping_single_compute
 @ Apply inverse.  The irrelevant parameter $p_1$ is always set zero.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: inverse => sf_os_mapping_single_inverse
 <<SF mappings: procedures>>=
   subroutine sf_os_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: p2, r2
     r2 = r(mapping%i)
     call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p2(1)
     pb(mapping%i(1)) = 1 - p2(1)
   end subroutine sf_os_mapping_single_inverse
 
 @ %def sf_os_mapping_single_inverse
 @
 \subsection{Implementation: endpoint mapping}
 This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
 while $p_2$ is related to the ratio.  Furthermore, we enhance the
 region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and
 $p_2=0,1$.  The enhancement is such that any power-like singularity is
 caught.  This is useful for beamstrahlung spectra.
 
 In addition, we allow for a delta-function singularity in $r_1$ and/or
 $r_2$.  The singularity is smeared to an interval of width
 $\epsilon$.  If nonzero, we distinguish the kinematical momentum
 fractions $r_i$ from effective values $x_i$, which should go into the
 structure-function evaluation.  A bin of width $\epsilon$ in $r$ is
 mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped
 to $(0,1)$ in $x$.  The Jacobian reflects this distinction, and the
 logical [[in_peak]] allows for an unambiguous distinction.
 
 The delta-peak fraction is used only for the integration self-test.
 <<SF mappings: public>>=
   public :: sf_ep_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ep_mapping_t
      real(default) :: a = 1
    contains
    <<SF mappings: sf endpoint mapping: TBP>>
   end type sf_ep_mapping_t
 
 @ %def sf_ep_mapping_t
 @ Output.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: write => sf_ep_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_ep_mapping_write (object, unit)
     class(sf_ep_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,ES12.5,A)")  ": endpoint (a =", object%a, ")"
   end subroutine sf_ep_mapping_write
 
 @ %def sf_ep_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: init => sf_ep_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_ep_mapping_init (mapping, a)
     class(sf_ep_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: a
     call mapping%base_init (2)
     if (present (a))  mapping%a = a
   end subroutine sf_ep_mapping_init
 
 @ %def sf_ep_mapping_init
 @ Apply mapping.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: compute => sf_ep_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ep_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, r2
     real(default) :: f1, f2
     integer :: j
     call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a)
     call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
     call map_unit_square (r2, f, px)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_ep_mapping_compute
 
 @ %def sf_ep_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: inverse => sf_ep_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ep_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, px, p2
     real(default) :: f1, f2
     integer :: j
     do j = 1, 2
        r2(j) = r(mapping%i(j))
     end do
     call map_unit_square_inverse (r2, f, px)
     call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a)
     call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_ep_mapping_inverse
 
 @ %def sf_ep_mapping_inverse
 @
 \subsection{Implementation: endpoint mapping with resonance}
 Like the endpoint mapping for $p_2$, but replace the endpoint mapping
 by a Breit-Wigner mapping for $p_1$.  This covers resonance production
 in the presence of beamstrahlung.
 
 If the flag [[resonance]] is unset, we skip the resonance mapping, so
 the parameter $p_1$ remains equal to $r_1r_2$, as in the standard
 s-channel mapping.
 <<SF mappings: public>>=
   public :: sf_epr_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_epr_mapping_t
      real(default) :: a = 1
      real(default) :: m = 0
      real(default) :: w = 0
      logical :: resonance = .true.
    contains
    <<SF mappings: sf endpoint/res mapping: TBP>>
   end type sf_epr_mapping_t
 
 @ %def sf_epr_mapping_t
 @ Output.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: write => sf_epr_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_epr_mapping_write (object, unit)
     class(sf_epr_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     if (object%resonance) then
        write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)")  ": ep/res (a = ", object%a, &
             " | ", object%m, object%w, ")"
     else
        write (u, "(A,F7.5,A)")  ": ep/nores (a = ", object%a, ")"
     end if
   end subroutine sf_epr_mapping_write
 
 @ %def sf_epr_mapping_write
 @ Initialize: if mass and width are not given, we initialize a
 non-resonant version of the mapping.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: init => sf_epr_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_epr_mapping_init (mapping, a, m, w)
     class(sf_epr_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: a
     real(default), intent(in), optional :: m, w
     call mapping%base_init (2)
     mapping%a = a
     if (present (m) .and. present (w)) then
        mapping%m = m
        mapping%w = w
     else
        mapping%resonance = .false.
     end if
   end subroutine sf_epr_mapping_init
 
 @ %def sf_epr_mapping_init
 @ Apply mapping.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: compute => sf_epr_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_epr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, r2
     real(default) :: f1, f2
     integer :: j
     if (mapping%resonance) then
        call map_breit_wigner &
             (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free)
     else
        px(1) = p(mapping%i(1))
        f1 = 1
     end if
     call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
     call map_unit_square (r2, f, px)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_epr_mapping_compute
 
 @ %def sf_epr_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: inverse => sf_epr_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_epr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, p2
     real(default) :: f1, f2
     integer :: j
     call map_unit_square_inverse (r(mapping%i), f, px)
     if (mapping%resonance) then
        call map_breit_wigner_inverse &
             (px(1), f1, p2(1), mapping%m, mapping%w, x_free)
     else
        p2(1) = px(1)
        f1 = 1
     end if
     call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_epr_mapping_inverse
 
 @ %def sf_epr_mapping_inverse
 @
 \subsection{Implementation: endpoint mapping for on-shell particle}
 Analogous to the resonance mapping, but the $p_1$ input is ignored
 altogether.  This covers on-shell particle production
 in the presence of beamstrahlung.
 <<SF mappings: public>>=
   public :: sf_epo_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_epo_mapping_t
      real(default) :: a = 1
      real(default) :: m = 0
      real(default) :: lm2 = 0
    contains
    <<SF mappings: sf endpoint/os mapping: TBP>>
   end type sf_epo_mapping_t
 
 @ %def sf_epo_mapping_t
 @ Output.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: write => sf_epo_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_epo_mapping_write (object, unit)
     class(sf_epo_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A)")  ": ep/on-shell (a = ", object%a, &
          " | ", object%m, ")"
   end subroutine sf_epo_mapping_write
 
 @ %def sf_epo_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: init => sf_epo_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_epo_mapping_init (mapping, a, m)
     class(sf_epo_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: a, m
     call mapping%base_init (2)
     mapping%a = a
     mapping%m = m
     mapping%lm2 = abs (2 * log (mapping%m))
   end subroutine sf_epo_mapping_init
 
 @ %def sf_epo_mapping_init
 @ Apply mapping.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: compute => sf_epo_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_epo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, r2
     real(default) :: f2
     integer :: j
     px(1) = 0
     call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
     call map_on_shell (r2, f, px, mapping%lm2)
     f = f * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_epo_mapping_compute
 
 @ %def sf_epo_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: inverse => sf_epo_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_epo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, p2
     real(default) :: f2
     integer :: j
     call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2)
     p2(1) = 0
     call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
     f = f * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_epo_mapping_inverse
 
 @ %def sf_epo_mapping_inverse
 @
 \subsection{Implementation: ISR endpoint mapping}
 Similar to the endpoint mapping above: This maps the unit square
 ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is
 related to the ratio.  Furthermore, we enhance the region at $r_1=1$
 and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$.
 
 The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
 flattened.  This would be easy in one dimension, but becomes
 nontrivial in two dimensions.
 <<SF mappings: public>>=
   public :: sf_ip_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ip_mapping_t
      real(default) :: eps = 0
    contains
    <<SF mappings: sf power mapping: TBP>>
   end type sf_ip_mapping_t
 
 @ %def sf_ip_mapping_t
 @ Output.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: write => sf_ip_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_ip_mapping_write (object, unit)
     class(sf_ip_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,ES12.5,A)")  ": isr (eps =", object%eps, ")"
   end subroutine sf_ip_mapping_write
 
 @ %def sf_ip_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: init => sf_ip_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_ip_mapping_init (mapping, eps)
     class(sf_ip_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: eps
     call mapping%base_init (2)
     if (present (eps))  mapping%eps = eps
     if (mapping%eps <= 0) &
          call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
   end subroutine sf_ip_mapping_init
 
 @ %def sf_ip_mapping_init
 @ Apply mapping.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: compute => sf_ip_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ip_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, pxb, r2, r2b
     real(default) :: f1, f2, xb, y, yb
     integer :: j
     call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps)
     call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
     px(1)  = 1 - xb
     pxb(1) = xb
     px(2)  = y
     pxb(2) = yb
     call map_unit_square_prec (r2, r2b, f, px, pxb)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2 (j)
        rb(mapping%i(j)) = r2b(j)
     end do
   end subroutine sf_ip_mapping_compute
 
 @ %def sf_ip_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: inverse => sf_ip_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ip_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
     real(default) :: f1, f2, xb, y, yb
     integer :: j
     do j = 1, 2
        r2 (j) = r (mapping%i(j))
        r2b(j) = rb(mapping%i(j))
     end do
     call map_unit_square_inverse_prec (r2, r2b, f, px, pxb)
     xb = pxb(1)
     if (px(1) > 0) then
        y  = px(2)
        yb = pxb(2)
     else
        y  = 0.5_default
        yb = 0.5_default
     end if
     call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps)
     call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
     p2 = 1 - p2b
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = p2b(j)
     end do
   end subroutine sf_ip_mapping_inverse
 
 @ %def sf_ip_mapping_inverse
 @
 \subsection{Implementation: ISR endpoint mapping, resonant}
 Similar to the endpoint mapping above: This maps the unit square
 ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is
 related to the ratio.  Furthermore, we enhance the region at $r_1=1$
 and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$.
 
 The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
 flattened.  This would be easy in one dimension, but becomes
 nontrivial in two dimensions.
 
 The resonance can be turned off by the flag [[resonance]].
 <<SF mappings: public>>=
   public :: sf_ipr_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ipr_mapping_t
      real(default) :: eps = 0
      real(default) :: m = 0
      real(default) :: w = 0
      logical :: resonance = .true.
    contains
    <<SF mappings: sf power/res mapping: TBP>>
   end type sf_ipr_mapping_t
 
 @ %def sf_ipr_mapping_t
 @ Output.
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: write => sf_ipr_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_ipr_mapping_write (object, unit)
     class(sf_ipr_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     if (object%resonance) then
        write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)")  ": isr/res (eps = ", &
             object%eps, " | ", object%m, object%w, ")"
     else
        write (u, "(A,F7.5,A)")  ": isr/res (eps = ", object%eps, ")"
     end if
   end subroutine sf_ipr_mapping_write
 
 @ %def sf_ipr_mapping_write
 @ Initialize:
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: init => sf_ipr_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_ipr_mapping_init (mapping, eps, m, w)
     class(sf_ipr_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: eps, m, w
     call mapping%base_init (2)
     if (present (eps))  mapping%eps = eps
     if (mapping%eps <= 0) &
          call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
     if (present (m) .and. present (w)) then
        mapping%m = m
        mapping%w = w
     else
        mapping%resonance = .false.
     end if
   end subroutine sf_ipr_mapping_init
 
 @ %def sf_ipr_mapping_init
 @ Apply mapping.
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: compute => sf_ipr_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, pxb, r2, r2b
     real(default) :: f1, f2, y, yb
     integer :: j
     if (mapping%resonance) then
        call map_breit_wigner &
             (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free)
     else
        px(1) = p(mapping%i(1))
        f1 = 1
     end if
     call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
     pxb(1) = 1 - px(1)
     px(2)  = y
     pxb(2) = yb
     call map_unit_square_prec (r2, r2b, f, px, pxb)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2 (j)
        rb(mapping%i(j)) = r2b(j)
     end do
   end subroutine sf_ipr_mapping_compute
 
 @ %def sf_ipr_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: inverse => sf_ipr_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
     real(default) :: f1, f2, y, yb
     integer :: j
     do j = 1, 2
        r2 (j) = r (mapping%i(j))
        r2b(j) = rb(mapping%i(j))
     end do
     call map_unit_square_inverse_prec (r2, r2b, f, px, pxb)
     if (px(1) > 0) then
        y  = px(2)
        yb = pxb(2)
     else
        y  = 0.5_default
        yb = 0.5_default
     end if
     if (mapping%resonance) then
        call map_breit_wigner_inverse &
             (px(1), f1, p2(1), mapping%m, mapping%w, x_free)
     else
        p2(1) = px(1)
        f1 = 1
     end if
     call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
     p2b(1) = 1 - p2(1)
     p2 (2) = 1 - p2b(2)
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = p2b(j)
     end do
   end subroutine sf_ipr_mapping_inverse
 
 @ %def sf_ipr_mapping_inverse
 @
 \subsection{Implementation: ISR on-shell mapping}
 Similar to the endpoint mapping above: This maps the unit square
 ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is
 constant.  $p_2$ is related to the ratio.  Furthermore, we enhance the
 region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and
 $p_2=0,1$.
 
 The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
 flattened.  This would be easy in one dimension, but becomes
 nontrivial in two dimensions.
 <<SF mappings: public>>=
   public :: sf_ipo_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ipo_mapping_t
      real(default) :: eps = 0
      real(default) :: m = 0
    contains
    <<SF mappings: sf power/os mapping: TBP>>
   end type sf_ipo_mapping_t
 
 @ %def sf_ipo_mapping_t
 @ Output.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: write => sf_ipo_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_ipo_mapping_write (object, unit)
     class(sf_ipo_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A)")  ": isr/os (eps = ", object%eps, &
          " | ", object%m, ")"
   end subroutine sf_ipo_mapping_write
 
 @ %def sf_ipo_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: init => sf_ipo_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_ipo_mapping_init (mapping, eps, m)
     class(sf_ipo_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: eps, m
     call mapping%base_init (2)
     if (present (eps))  mapping%eps = eps
     if (mapping%eps <= 0) &
          call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
     mapping%m = m
   end subroutine sf_ipo_mapping_init
 
 @ %def sf_ipo_mapping_init
 @ Apply mapping.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: compute => sf_ipo_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, pxb, r2, r2b
     real(default) :: f1, f2, y, yb
     integer :: j
     call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
     px(1)  = mapping%m ** 2
     if (present (x_free))  px(1) = px(1) / x_free
     pxb(1) = 1 - px(1)
     px(2)  = y
     pxb(2) = yb
     call map_unit_square_prec (r2, r2b, f1, px, pxb)
     f = f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2 (j)
        rb(mapping%i(j)) = r2b(j)
     end do
   end subroutine sf_ipo_mapping_compute
 
 @ %def sf_ipo_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: inverse => sf_ipo_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
     real(default) :: f1, f2, y, yb
     integer :: j
     do j = 1, 2
        r2 (j) = r (mapping%i(j))
        r2b(j) = rb(mapping%i(j))
     end do
     call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb)
     y  = px(2)
     yb = pxb(2)
     call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
     p2(1) = 0
     p2b(1)= 1
     p2(2) = 1 - p2b(2)
     f = f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = p2b(j)
     end do
   end subroutine sf_ipo_mapping_inverse
 
 @ %def sf_ipo_mapping_inverse
 @
 \subsection{Implementation: Endpoint + ISR power mapping}
 This is a combination of endpoint (i.e., beamstrahlung) and ISR power
 mapping.  The first two parameters apply to the beamstrahlung
 spectrum, the last two to the ISR function for the first and second
 beam, respectively.
 <<SF mappings: public>>=
   public :: sf_ei_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ei_mapping_t
      type(sf_ep_mapping_t) :: ep
      type(sf_ip_mapping_t) :: ip
    contains
    <<SF mappings: sf ep-ip mapping: TBP>>
   end type sf_ei_mapping_t
 
 @ %def sf_ei_mapping_t
 @ Output.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: write => sf_ei_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_ei_mapping_write (object, unit)
     class(sf_ei_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,3(',',I0),')')", advance="no")  object%i
     end if
     write (u, "(A,ES12.5,A,ES12.5,A)")  ": ep/isr (a =", object%ep%a, &
          ", eps =", object%ip%eps, ")"
   end subroutine sf_ei_mapping_write
 
 @ %def sf_ei_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: init => sf_ei_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_ei_mapping_init (mapping, a, eps)
     class(sf_ei_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: a, eps
     call mapping%base_init (4)
     call mapping%ep%init (a)
     call mapping%ip%init (eps)
   end subroutine sf_ei_mapping_init
 
 @ %def sf_ei_mapping_init
 @ Set an index value.  We should communicate the appropriate indices to the
 enclosed sub-mappings, therefore override the method.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: set_index => sf_ei_mapping_set_index
 <<SF mappings: procedures>>=
   subroutine sf_ei_mapping_set_index (mapping, j, i)
     class(sf_ei_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
     select case (j)
     case (1:2);  call mapping%ep%set_index (j, i)
     case (3:4);  call mapping%ip%set_index (j-2, i)
     end select
   end subroutine sf_ei_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Apply mapping.  Now, the beamstrahlung and ISR mappings are
 independent of each other.  The parameter subsets that are actually
 used should not overlap.  The Jacobians are multiplied.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: compute => sf_ei_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ei_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: q, qb
     real(default) :: f1, f2
     call mapping%ep%compute (q, qb, f1, p, pb, x_free)
     call mapping%ip%compute (r, rb, f2, q, qb, x_free)
     f = f1 * f2
   end subroutine sf_ei_mapping_compute
 
 @ %def sf_ei_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: inverse => sf_ei_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ei_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: q, qb
     real(default) :: f1, f2
     call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
     call mapping%ep%inverse (q, qb, f1, p, pb, x_free)
     f = f1 * f2
   end subroutine sf_ei_mapping_inverse
 
 @ %def sf_ei_mapping_inverse
 @
 \subsection{Implementation: Endpoint + ISR + resonance}
 This is a combination of endpoint (i.e., beamstrahlung) and ISR power
 mapping, adapted for an s-channel resonance.  The first two internal
 parameters apply to the beamstrahlung spectrum, the last two to the
 ISR function for the first and second beam, respectively.  The first
 and third parameters are the result of an overall resonance mapping,
 so on the outside, the first parameter is the total momentum fraction,
 the third one describes the distribution between beamstrahlung and ISR.
 <<SF mappings: public>>=
   public :: sf_eir_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_eir_mapping_t
      type(sf_res_mapping_t) :: res
      type(sf_epr_mapping_t) :: ep
      type(sf_ipr_mapping_t) :: ip
    contains
    <<SF mappings: sf ep-ip-res mapping: TBP>>
   end type sf_eir_mapping_t
 
 @ %def sf_eir_mapping_t
 @ Output.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: write => sf_eir_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_eir_mapping_write (object, unit)
     class(sf_eir_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,3(',',I0),')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)")  &
          ": ep/isr/res (a =", object%ep%a, &
          ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")"
   end subroutine sf_eir_mapping_write
 
 @ %def sf_eir_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: init => sf_eir_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_eir_mapping_init (mapping, a, eps, m, w)
     class(sf_eir_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: a, eps, m, w
     call mapping%base_init (4)
     call mapping%res%init (m, w)
     call mapping%ep%init (a)
     call mapping%ip%init (eps)
   end subroutine sf_eir_mapping_init
 
 @ %def sf_eir_mapping_init
 @ Set an index value.  We should communicate the appropriate indices to the
 enclosed sub-mappings, therefore override the method.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: set_index => sf_eir_mapping_set_index
 <<SF mappings: procedures>>=
   subroutine sf_eir_mapping_set_index (mapping, j, i)
     class(sf_eir_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
     select case (j)
     case (1);  call mapping%res%set_index (1, i)
     case (3);  call mapping%res%set_index (2, i)
     end select
     select case (j)
     case (1:2);  call mapping%ep%set_index (j, i)
     case (3:4);  call mapping%ip%set_index (j-2, i)
     end select
   end subroutine sf_eir_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Apply mapping.  Now, the beamstrahlung and ISR mappings are
 independent of each other.  The parameter subsets that are actually
 used should not overlap.  The Jacobians are multiplied.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: compute => sf_eir_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_eir_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%res%compute (px, pxb, f0, p, pb, x_free)
     call mapping%ep%compute (q, qb, f1, px, pxb, x_free)
     call mapping%ip%compute (r, rb, f2, q, qb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eir_mapping_compute
 
 @ %def sf_eir_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: inverse => sf_eir_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_eir_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
     call mapping%ep%inverse (q, qb, f1, px, pxb, x_free)
     call mapping%res%inverse (px, pxb, f0, p, pb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eir_mapping_inverse
 
 @ %def sf_eir_mapping_inverse
 @
 \subsection{Implementation: Endpoint + ISR power mapping, on-shell}
 This is a combination of endpoint (i.e., beamstrahlung) and ISR power
 mapping.  The first two parameters apply to the beamstrahlung
 spectrum, the last two to the ISR function for the first and second
 beam, respectively.  On top of that, we map the first and third parameter
 such that the product is constant.  From the outside, the first
 parameter is irrelevant while the third parameter describes the
 distribution of energy (loss) among beamstrahlung and ISR.
 <<SF mappings: public>>=
   public :: sf_eio_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_eio_mapping_t
      type(sf_os_mapping_t) :: os
      type(sf_epr_mapping_t) :: ep
      type(sf_ipr_mapping_t) :: ip
    contains
    <<SF mappings: sf ep-ip-os mapping: TBP>>
   end type sf_eio_mapping_t
 
 @ %def sf_eio_mapping_t
 @ Output.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: write => sf_eio_mapping_write
 <<SF mappings: procedures>>=
   subroutine sf_eio_mapping_write (object, unit)
     class(sf_eio_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,3(',',I0),')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A,F7.5,A)")  ": ep/isr/os (a =", object%ep%a, &
          ", eps =", object%ip%eps, " | ", object%os%m, ")"
   end subroutine sf_eio_mapping_write
 
 @ %def sf_eio_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: init => sf_eio_mapping_init
 <<SF mappings: procedures>>=
   subroutine sf_eio_mapping_init (mapping, a, eps, m)
     class(sf_eio_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: a, eps, m
     call mapping%base_init (4)
     call mapping%os%init (m)
     call mapping%ep%init (a)
     call mapping%ip%init (eps)
   end subroutine sf_eio_mapping_init
 
 @ %def sf_eio_mapping_init
 @ Set an index value.  We should communicate the appropriate indices to the
 enclosed sub-mappings, therefore override the method.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: set_index => sf_eio_mapping_set_index
 <<SF mappings: procedures>>=
   subroutine sf_eio_mapping_set_index (mapping, j, i)
     class(sf_eio_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
     select case (j)
     case (1);  call mapping%os%set_index (1, i)
     case (3);  call mapping%os%set_index (2, i)
     end select
     select case (j)
     case (1:2);  call mapping%ep%set_index (j, i)
     case (3:4);  call mapping%ip%set_index (j-2, i)
     end select
   end subroutine sf_eio_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Apply mapping.  Now, the beamstrahlung and ISR mappings are
 independent of each other.  The parameter subsets that are actually
 used should not overlap.  The Jacobians are multiplied.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: compute => sf_eio_mapping_compute
 <<SF mappings: procedures>>=
   subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_eio_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%os%compute (px, pxb, f0, p, pb, x_free)
     call mapping%ep%compute (q, qb, f1, px, pxb, x_free)
     call mapping%ip%compute (r, rb, f2, q, qb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eio_mapping_compute
 
 @ %def sf_eio_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: inverse => sf_eio_mapping_inverse
 <<SF mappings: procedures>>=
   subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_eio_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
     call mapping%ep%inverse (q, qb, f1, px, pxb, x_free)
     call mapping%os%inverse (px, pxb, f0, p, pb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eio_mapping_inverse
 
 @ %def sf_eio_mapping_inverse
 @
 \subsection{Basic formulas}
 \subsubsection{Standard mapping of the unit square}
 This mapping of the unit square is appropriate in particular for
 structure functions which are concentrated at the lower end.  Instead
 of a rectangular grid, one set of grid lines corresponds to constant
 parton c.m. energy.  The other set is chosen such that the jacobian is
 only mildly singular ($\ln x$ which is zero at $x=1$), corresponding
 to an initial concentration of sampling points at the maximum energy.
 If [[power]] is greater than one (the default), points are also
 concentrated at the lower end.
 
 The formula is ([[power]]=$\alpha$):
 \begin{align}
   r_1 &= (p_1 ^ {p_2})^\alpha \\
   r_2 &= (p_1 ^ {1 - p_2})^\alpha\\
   f   &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1|
 \end{align}
 and for the default case $\alpha=1$:
 \begin{align}
   r_1 &= p_1 ^ {p_2} \\
   r_2 &= p_1 ^ {1 - p_2} \\
   f   &= |\log p_1|
 \end{align}
 <<SF mappings: procedures>>=
   subroutine map_unit_square (r, factor, p, power)
     real(default), dimension(2), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(in) :: p
     real(default), intent(in), optional :: power
     real(default) :: xx, yy
     factor = 1
     xx = p(1)
     yy = p(2)
     if (present(power)) then
        if (p(1) > 0 .and. power > 1) then
           xx = p(1)**power
           factor = factor * power * xx / p(1)
        end if
     end if
     if (.not. vanishes (xx)) then
        r(1) = xx ** yy
        r(2) = xx / r(1)
        factor = factor * abs (log (xx))
     else
        r = 0
     end if
   end subroutine map_unit_square
 
 @ %def map_unit_square
 @ This is the inverse mapping.
 <<SF mappings: procedures>>=
   subroutine map_unit_square_inverse (r, factor, p, power)
     real(kind=default), dimension(2), intent(in) :: r
     real(kind=default), intent(out) :: factor
     real(kind=default), dimension(2), intent(out) :: p
     real(kind=default), intent(in), optional :: power
     real(kind=default) :: lg, xx, yy
     factor = 1
     xx = r(1) * r(2)
     if (.not. vanishes (xx)) then
        lg = log (xx)
        if (.not. vanishes (lg)) then
           yy = log (r(1)) / lg
        else
           yy = 0
        end if
        p(2) = yy
        factor = factor * abs (lg)
        if (present(power)) then
           p(1) = xx**(1._default/power)
           factor = factor * power * xx / p(1)
        else
           p(1) = xx
        end if
     else
        p = 0
     end if
   end subroutine map_unit_square_inverse
 
 @ %def map_unit_square_inverse
 @
 \subsubsection{Precise mapping of the unit square}
 A more precise version (with unit power parameter).  This version
 should be numerically stable near $x=1$ and $y=0,1$.  The formulas are again
 \begin{equation}
   r_1 = p_1^{p_2}, \qquad
   r_2 = p_1^{\bar p_2}, \qquad
   f = - \log p_1
 \end{equation}
 but we compute both $r_i$ and $\bar r_i$ simultaneously and make
 direct use of both $p_i$ and $\bar p_i$ as appropriate.
 <<SF mappings: procedures>>=
   subroutine map_unit_square_prec (r, rb, factor, p, pb)
     real(default), dimension(2), intent(out) :: r
     real(default), dimension(2), intent(out) :: rb
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(in) :: p
     real(default), dimension(2), intent(in) :: pb
     if (p(1) > 0.5_default) then
        call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2))
        call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2))
        factor = - log_prec (p(1), pb(1))
     else if (.not. vanishes (p(1))) then
        call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2))
        call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2))
        factor = - log_prec (p(1), pb(1))
     else
        r  = 0
        rb = 1
        factor = 0
     end if
   end subroutine map_unit_square_prec
 
 @ %def map_unit_square_prec
 @ This is the inverse mapping.
 <<SF mappings: procedures>>=
   subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb)
     real(default), dimension(2), intent(in) :: r
     real(default), dimension(2), intent(in) :: rb
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(out) :: p
     real(default), dimension(2), intent(out) :: pb
     call inverse_prec_x (r, rb, p(1), pb(1))
     if (all (r > 0)) then
        if (rb(1) < rb(2)) then
           call inverse_prec_y (r, rb, p(2), pb(2))
        else
           call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2))
        end if
        factor = - log_prec (p(1), pb(1))
     else
        p(1)  = 0
        pb(1) = 1
        p(2)  = 0.5_default
        pb(2) = 0.5_default
        factor = 0
     end if
   end subroutine map_unit_square_inverse_prec
 
 @ %def map_unit_square_prec_inverse
 @ This is an auxiliary function: evaluate the expression $\bar z = 1 -
 x^y$ in a numerically stable way.  Instabilities occur for $y=0$ and
 $x=1$.  The idea is to replace the bracket by the first terms of its
 Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$)
 \begin{equation}
   1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x +
     \frac16(2-y)(1-y)\bar x^2\right)
 \end{equation}
 whenever this is the better approximation.  Actually, the relative
 numerical error of the exact formula is about $\eta/(y\bar x)$ where
 $\eta$ is given by [[epsilon(KIND)]] in Fortran.  The relative error
 of the approximation is better than the last included term divided by
 $(y\bar x)$.
 
 The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log
 x$ should be expanded, the second one near $x=0$ where $\log x$ can be
 kept.
 <<SF mappings: procedures>>=
   subroutine compute_prec_xy_1 (z, zb, x, xb, y)
     real(default), intent(out) :: z, zb
     real(default), intent(in) :: x, xb, y
     real(default) :: a1, a2, a3
     a1 = y * xb
     a2 = a1 * (1 - y) * xb / 2
     a3 = a2 * (2 - y) * xb / 3
     if (abs (a3) < epsilon (a3)) then
        zb = a1 + a2 + a3
        z = 1 - zb
     else
        z = x ** y
        zb = 1 - z
     end if
   end subroutine compute_prec_xy_1
 
   subroutine compute_prec_xy_0 (z, zb, x, xb, y)
     real(default), intent(out) :: z, zb
     real(default), intent(in) :: x, xb, y
     real(default) :: a1, a2, a3, lx
     lx = -log (x)
     a1 = y * lx
     a2 = a1 * y * lx / 2
     a3 = a2 * y * lx / 3
     if (abs (a3) < epsilon (a3)) then
        zb = a1 + a2 + a3
        z = 1 - zb
     else
        z = x ** y
        zb = 1 - z
     end if
   end subroutine compute_prec_xy_0
 
 @ %def compute_prec_xy_1
 @ %def compute_prec_xy_0
 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way.
 Since it is just a polynomial, the expansion near $x=1$ is
 analytically exact, and we don't need to choose based on precision.
 <<SF mappings: procedures>>=
   subroutine inverse_prec_x (r, rb, x, xb)
     real(default), dimension(2), intent(in) :: r, rb
     real(default), intent(out) :: x, xb
     real(default) :: a0, a1
     a0 = rb(1) + rb(2)
     a1 = rb(1) * rb(2)
     if (a0 > 0.5_default) then
        xb = a0 - a1
        x = 1 - xb
     else
        x = r(1) * r(2)
        xb = 1 - x
     end if
   end subroutine inverse_prec_x
 
 @ %def inverse_prec_x
 @ The inverse calculation for the relative momentum fraction
 \begin{equation}
   y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}}
 \end{equation}
 is slightly more complicated.  We should take the precise form of the
 logarithm, so we are safe near $r_i=1$.  A series expansion is
 required if $r_1\ll r_2$, since then $y$ becomes small.  (We assume
 $r_1<r_2$ here; for the opposite case, the arguments can be
 exchanged.)
 <<SF mappings: procedures>>=
   subroutine inverse_prec_y (r, rb, y, yb)
     real(default), dimension(2), intent(in) :: r, rb
     real(default), intent(out) :: y, yb
     real(default) :: log1, log2, a1, a2, a3
     log1 = log_prec (r(1), rb(1))
     log2 = log_prec (r(2), rb(2))
     if (abs (log2**3) < epsilon (one)) then
        if (abs(log1) < epsilon (one)) then
           y = zero
        else
           y = one / (one + log2 / log1)
        end if
        if (abs(log2) < epsilon (one)) then
           yb = zero
        else
           yb = one / (one + log1 / log2)
        end if
        return
     end if
     a1 = - rb(1) / log2
     a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2))
     a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2))
     if (abs (a3) < epsilon (a3)) then
        y  = a1 + a2 + a3
        yb = one - y
     else
        y  = one / (one + log2 / log1)
        yb = one / (one + log1 / log2)
     end if
   end subroutine inverse_prec_y
 
 @ %def inverse_prec_y
 @
 \subsubsection{Mapping for on-shell s-channel}
 The limiting case, if the product $r_1r_2$ is fixed for on-shell
 production.  The parameter $p_1$ is ignored.  In the inverse mapping,
 it is returned zero.
 
 The parameter [[x_free]], if present, rescales the total energy.  If
 it is less than one, the rescaled mass parameter $m^2$ should be increased
 accordingly.
 
 Public for access in unit test.
 <<SF mappings: public>>=
   public :: map_on_shell
   public :: map_on_shell_inverse
 <<SF mappings: procedures>>=
   subroutine map_on_shell (r, factor, p, lm2, x_free)
     real(default), dimension(2), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(in) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     r(1) = exp (- p(2) * lx)
     r(2) = exp (- (1 - p(2)) * lx)
     factor = lx
   end subroutine map_on_shell
 
   subroutine map_on_shell_inverse (r, factor, p, lm2, x_free)
     real(default), dimension(2), intent(in) :: r
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(out) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     p(1) = 0
     p(2) = abs (log (r(1))) / lx
     factor = lx
   end subroutine map_on_shell_inverse
 
 @ %def map_on_shell
 @ %def map_on_shell_inverse
 @
 \subsubsection{Mapping for on-shell s-channel, single parameter}
 This is a pseudo-mapping which applies if there is actually just one
 parameter [[p]].  The output parameter [[r]] is fixed for on-shell
 production.  The lone parameter $p_1$ is ignored.  In the inverse mapping,
 it is returned zero.
 
 The parameter [[x_free]], if present, rescales the total energy.  If
 it is less than one, the rescaled mass parameter $m^2$ should be increased
 accordingly.
 
 Public for access in unit test.
 <<SF mappings: public>>=
   public :: map_on_shell_single
   public :: map_on_shell_single_inverse
 <<SF mappings: procedures>>=
   subroutine map_on_shell_single (r, factor, p, lm2, x_free)
     real(default), dimension(1), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), dimension(1), intent(in) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     r(1) = exp (- lx)
     factor = 1
   end subroutine map_on_shell_single
 
   subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free)
     real(default), dimension(1), intent(in) :: r
     real(default), intent(out) :: factor
     real(default), dimension(1), intent(out) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     p(1) = 0
     factor = 1
   end subroutine map_on_shell_single_inverse
 
 @ %def map_on_shell_single
 @ %def map_on_shell_single_inverse
 @
 \subsubsection{Mapping for a Breit-Wigner resonance}
 This is the standard Breit-Wigner mapping.  We apply it to a single
 variable, independently of or in addition to a unit-square mapping.  We
 assume here that the limits for the variable are 0 and 1, and that the
 mass $m$ and width $w$ are rescaled appropriately, so they are
 dimensionless and usually between 0 and 1.
 
 If [[x_free]] is set, it rescales the total energy and thus mass and
 width, since these are defined with respect to the total energy.
 <<SF mappings: procedures>>=
   subroutine map_breit_wigner (r, factor, p, m, w, x_free)
     real(default), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), intent(in) :: p
     real(default), intent(in) :: m
     real(default), intent(in) :: w
     real(default), intent(in), optional :: x_free
     real(default) :: m2, mw, a1, a2, a3, z, tmp
     m2 = m ** 2
     mw = m * w
     if (present (x_free)) then
        m2 = m2 / x_free
        mw = mw / x_free
     end if
     a1 = atan (- m2 / mw)
     a2 = atan ((1 - m2) / mw)
     a3 = (a2 - a1) * mw
     z = (1-p) * a1 + p * a2
     if (-pi/2 < z .and. z < pi/2) then
        tmp = tan (z)
        r = max (m2 + mw * tmp, 0._default)
        factor = a3 * (1 + tmp ** 2)
     else
        r = 0
        factor = 0
     end if
   end subroutine map_breit_wigner
 
   subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free)
     real(default), intent(in) :: r
     real(default), intent(out) :: factor
     real(default), intent(out) :: p
     real(default), intent(in) :: m
     real(default), intent(in) :: w
     real(default) :: m2, mw, a1, a2, a3, tmp
     real(default), intent(in), optional :: x_free
     m2 = m ** 2
     mw = m * w
     if (present (x_free)) then
        m2 = m2 / x_free
        mw = mw / x_free
     end if
     a1 = atan (- m2 / mw)
     a2 = atan ((1 - m2) / mw)
     a3 = (a2 - a1) * mw
     tmp = (r - m2) / mw
     p = (atan (tmp) - a1) / (a2 - a1)
     factor = a3 * (1 + tmp ** 2)
   end subroutine map_breit_wigner_inverse
 
 @ %def map_breit_wigner
 @ %def map_breit_wigner_inverse
 @
 \subsubsection{Mapping with endpoint enhancement}
 This is a mapping which is close to the unit mapping, except that at
 the endpoint(s), the output values are exponentially enhanced.
 \begin{equation}
   y = \tanh (a \tan (\frac{\pi}{2}x))
 \end{equation}
 We have two variants: one covers endpoints at $0$ and $1$
 symmetrically, while the other one (which essentially maps one-half of
 the range), covers only the endpoint at $1$.
 <<SF mappings: procedures>>=
   subroutine map_endpoint_1 (x3, factor, x1, a)
     real(default), intent(out) :: x3, factor
     real(default), intent(in) :: x1
     real(default), intent(in) :: a
     real(default) :: x2
     if (abs (x1) < 1) then
        x2 = tan (x1 * pi / 2)
        x3 = tanh (a * x2)
        factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2)
     else
        x3 = x1
        factor = 0
     end if
   end subroutine map_endpoint_1
 
   subroutine map_endpoint_inverse_1 (x3, factor, x1, a)
     real(default), intent(in) :: x3
     real(default), intent(out) :: x1, factor
     real(default), intent(in) :: a
     real(default) :: x2
     if (abs (x3) < 1) then
        x2 = atanh (x3) / a
        x1 = 2 / pi * atan (x2)
        factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2)
     else
        x1 = x3
        factor = 0
     end if
   end subroutine map_endpoint_inverse_1
 
   subroutine map_endpoint_01 (x4, factor, x0, a)
     real(default), intent(out) :: x4, factor
     real(default), intent(in) :: x0
     real(default), intent(in) :: a
     real(default) :: x1, x3
     x1 = 2 * x0 - 1
     call map_endpoint_1 (x3, factor, x1, a)
     x4 = (x3 + 1) / 2
   end subroutine map_endpoint_01
 
   subroutine map_endpoint_inverse_01 (x4, factor, x0, a)
     real(default), intent(in) :: x4
     real(default), intent(out) :: x0, factor
     real(default), intent(in) :: a
     real(default) :: x1, x3
     x3 = 2 * x4 - 1
     call map_endpoint_inverse_1 (x3, factor, x1, a)
     x0 = (x1 + 1) / 2
   end subroutine map_endpoint_inverse_01
 
 @ %def map_endpoint_1
 @ %def map_endpoint_inverse_1
 @ %def map_endpoint_01
 @ %def map_endpoint_inverse_01
 @
 \subsubsection{Mapping with endpoint enhancement (ISR)}
 This is another endpoint mapping.  It is designed to flatten the ISR
 singularity which is of power type at $x=1$, i.e., if
 \begin{equation}
   \sigma = \int_0^1 dx\,f(x)\,G(x)
   = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x),
 \end{equation}
 we replace this by
 \begin{equation}
   r = x^\epsilon \quad\Longrightarrow\quad
   \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}).
 \end{equation}
 We expect that $\epsilon$ is small.
 
 The actual mapping is $r\to x$ (so $x$ emerges closer to $1$).  The
 Jacobian that we return is thus $1/f(x)$.  We compute the mapping in
 terms of $\bar x\equiv 1 - x$, so we can achieve the required precision.
 Because some compilers show quite wild numeric fluctuations, we
 internally convert numeric types to explicit [[double]] precision.
 <<SF mappings: public>>=
   public :: map_power_1
   public :: map_power_inverse_1
 <<SF mappings: procedures>>=
   subroutine map_power_1 (xb, factor, rb, eps)
     real(default), intent(out) :: xb, factor
     real(default), intent(in) :: rb
     real(double) :: rb_db, factor_db, eps_db, xb_db
     real(default), intent(in) :: eps
     rb_db = real (rb, kind=double)
     eps_db = real (eps, kind=double)
     xb_db = rb_db ** (1 / eps_db)
     if (rb_db > 0) then
        factor_db = xb_db / rb_db / eps_db
        factor = real (factor_db, kind=default)
     else
        factor = 0
     end if
     xb = real (xb_db, kind=default)
   end subroutine map_power_1
 
   subroutine map_power_inverse_1 (xb, factor, rb, eps)
     real(default), intent(in) :: xb
     real(default), intent(out) :: rb, factor
     real(double) :: xb_db, factor_db, eps_db, rb_db
     real(default), intent(in) :: eps
     xb_db = real (xb, kind=double)
     eps_db = real (eps, kind=double)
     rb_db = xb_db ** eps_db
     if (xb_db > 0) then
        factor_db = xb_db / rb_db / eps_db
        factor = real (factor_db, kind=default)
     else
        factor = 0
     end if
     rb = real (rb_db, kind=default)
   end subroutine map_power_inverse_1
 
 @ %def map_power_1
 @ %def map_power_inverse_1
 @ Here we apply a power mapping to both endpoints.  We divide the
 interval in two equal halves and apply the power mapping for the
 nearest endpoint, either $0$ or $1$.
 <<SF mappings: procedures>>=
   subroutine map_power_01 (y, yb, factor, r, eps)
     real(default), intent(out) :: y, yb, factor
     real(default), intent(in) :: r
     real(default), intent(in) :: eps
     real(default) :: u, ub, zp, zm
     u = 2 * r - 1
     if (u > 0) then
        ub = 2 * (1 - r)
        call map_power_1 (zm, factor, ub, eps)
        zp = 2 - zm
     else if (u < 0) then
        ub = 2 * r
        call map_power_1 (zp, factor, ub, eps)
        zm = 2 - zp
     else
        factor = 1 / eps
        zp = 1
        zm = 1
     end if
     y  = zp / 2
     yb = zm / 2
   end subroutine map_power_01
 
   subroutine map_power_inverse_01 (y, yb, factor, r, eps)
     real(default), intent(in) :: y, yb
     real(default), intent(out) :: r, factor
     real(default), intent(in) :: eps
     real(default) :: ub, zp, zm
     zp = 2 * y
     zm = 2 * yb
     if (zm < zp) then
        call map_power_inverse_1 (zm, factor, ub, eps)
        r = 1 - ub / 2
     else if (zp < zm) then
        call map_power_inverse_1 (zp, factor, ub, eps)
        r = ub / 2
     else
        factor = 1 / eps
        ub = 1
        r = ub / 2
     end if
   end subroutine map_power_inverse_01
 
 @ %def map_power_01
 @ %def map_power_inverse_01
 @
 \subsubsection{Structure-function channels}
 A structure-function chain parameterization (channel) may contain a
 mapping that applies to multiple structure functions.  This is
 described by an extension of the [[sf_mapping_t]] type.  In addition,
 it may contain mappings that apply to (other) individual structure
 functions.  The details of these mappings are implementation-specific.
 
 The [[sf_channel_t]] type combines this information.  It contains an
 array of map codes, one for each structure-function entry.  The code
 values are:
 \begin{description}
 \item[none] MC input parameters $r$ directly become energy fractions $x$
 \item[single] default mapping for a single structure-function entry
 \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$
 \item[multi/resonance] as before, adapted to s-channel resonance
 \item[multi/on-shell] as before, adapted to an on-shell particle in
   the s channel
 \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$
 \item[multi/endpoint/res] endpoint mapping with resonance
 \item[multi/endpoint/os] endpoint mapping for on-shell
 \item[multi/power/os] like multi/endpoint, regulating a power singularity
 \end{description}
 <<SF mappings: parameters>>=
   integer, parameter :: SFMAP_NONE = 0
   integer, parameter :: SFMAP_SINGLE = 1
   integer, parameter :: SFMAP_MULTI_S = 2
   integer, parameter :: SFMAP_MULTI_RES = 3
   integer, parameter :: SFMAP_MULTI_ONS = 4
   integer, parameter :: SFMAP_MULTI_EP = 5
   integer, parameter :: SFMAP_MULTI_EPR = 6
   integer, parameter :: SFMAP_MULTI_EPO = 7
   integer, parameter :: SFMAP_MULTI_IP = 8
   integer, parameter :: SFMAP_MULTI_IPR = 9
   integer, parameter :: SFMAP_MULTI_IPO = 10
   integer, parameter :: SFMAP_MULTI_EI = 11
   integer, parameter :: SFMAP_MULTI_SRS = 13
   integer, parameter :: SFMAP_MULTI_SON = 14
 
 @ %def SFMAP_NONE SFMAP_SINGLE
 @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS
 @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO
 @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO
 @ %def SFMAP_MULTI_EI
 @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON
 @ Then, it contains an allocatable entry for the multi mapping.  This
 entry holds the MC-parameter indices on which the mapping applies
 (there may be more than one MC parameter per structure-function entry)
 and any parameters associated with the mapping.
 
 There can be only one multi-mapping per channel.
 <<SF mappings: public>>=
   public :: sf_channel_t
 <<SF mappings: types>>=
   type :: sf_channel_t
      integer, dimension(:), allocatable :: map_code
      class(sf_mapping_t), allocatable :: multi_mapping
    contains
    <<SF mappings: sf channel: TBP>>
   end type sf_channel_t
 
 @ %def sf_channel_t
 @ The output format prints a single character for each
 structure-function entry and, if applicable, an account of the mapping
 parameters.
 <<SF mappings: sf channel: TBP>>=
   procedure :: write => sf_channel_write
 <<SF mappings: procedures>>=
   subroutine sf_channel_write (object, unit)
     class(sf_channel_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     if (allocated (object%map_code)) then
        do i = 1, size (object%map_code)
           select case (object%map_code (i))
           case (SFMAP_NONE)
              write (u, "(1x,A)", advance="no") "-"
           case (SFMAP_SINGLE)
              write (u, "(1x,A)", advance="no") "+"
           case (SFMAP_MULTI_S)
              write (u, "(1x,A)", advance="no") "s"
           case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS)
              write (u, "(1x,A)", advance="no") "r"
           case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON)
              write (u, "(1x,A)", advance="no") "o"
           case (SFMAP_MULTI_EP)
              write (u, "(1x,A)", advance="no") "e"
           case (SFMAP_MULTI_EPR)
              write (u, "(1x,A)", advance="no") "p"
           case (SFMAP_MULTI_EPO)
              write (u, "(1x,A)", advance="no") "q"
           case (SFMAP_MULTI_IP)
              write (u, "(1x,A)", advance="no") "i"
           case (SFMAP_MULTI_IPR)
              write (u, "(1x,A)", advance="no") "i"
           case (SFMAP_MULTI_IPO)
              write (u, "(1x,A)", advance="no") "i"
           case (SFMAP_MULTI_EI)
              write (u, "(1x,A)", advance="no") "i"
           case default
              write (u, "(1x,A)", advance="no") "?"
           end select
        end do
     else
        write (u, "(1x,A)", advance="no") "-"
     end if
     if (allocated (object%multi_mapping)) then
        write (u, "(1x,'/')", advance="no")
        call object%multi_mapping%write (u)
     else
        write (u, *)
     end if
   end subroutine sf_channel_write
 
 @ %def sf_channel_write
 @ Initializer for a single [[sf_channel]] object.
 <<SF mappings: sf channel: TBP>>=
   procedure :: init => sf_channel_init
 <<SF mappings: procedures>>=
   subroutine sf_channel_init (channel, n_strfun)
     class(sf_channel_t), intent(out) :: channel
     integer, intent(in) :: n_strfun
     allocate (channel%map_code (n_strfun))
     channel%map_code = SFMAP_NONE
   end subroutine sf_channel_init
 
 @ %def sf_channel_init
 @ Assignment.  This merely copies intrinsic assignment.
 <<SF mappings: sf channel: TBP>>=
   generic :: assignment (=) => sf_channel_assign
   procedure :: sf_channel_assign
 <<SF mappings: procedures>>=
   subroutine sf_channel_assign (copy, original)
     class(sf_channel_t), intent(out) :: copy
     type(sf_channel_t), intent(in) :: original
     allocate (copy%map_code (size (original%map_code)))
     copy%map_code = original%map_code
     if (allocated (original%multi_mapping)) then
          allocate (copy%multi_mapping, source = original%multi_mapping)
     end if
   end subroutine sf_channel_assign
 
 @ %def sf_channel_assign
 @ This initializer allocates an array of channels with common number of
 structure-function entries, therefore it is not a type-bound procedure.
 <<SF mappings: public>>=
   public :: allocate_sf_channels
 <<SF mappings: procedures>>=
   subroutine allocate_sf_channels (channel, n_channel, n_strfun)
     type(sf_channel_t), dimension(:), intent(out), allocatable :: channel
     integer, intent(in) :: n_channel
     integer, intent(in) :: n_strfun
     integer :: c
     allocate (channel (n_channel))
     do c = 1, n_channel
        call channel(c)%init (n_strfun)
     end do
   end subroutine allocate_sf_channels
 
 @ %def allocate_sf_channels
 @ This marks a given subset of indices as single-mapping.
 <<SF mappings: sf channel: TBP>>=
   procedure :: activate_mapping => sf_channel_activate_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_activate_mapping (channel, i_sf)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     channel%map_code(i_sf) = SFMAP_SINGLE
   end subroutine sf_channel_activate_mapping
 
 @ %def sf_channel_activate_mapping
 @ This sets an s-channel multichannel mapping.  The parameter indices
 are not yet set.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_s_mapping => sf_channel_set_s_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_s_mapping (channel, i_sf, power)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: power
     channel%map_code(i_sf) = SFMAP_MULTI_S
     allocate (sf_s_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_s_mapping_t)
        call mapping%init (power)
     end select
   end subroutine sf_channel_set_s_mapping
 
 @ %def sf_channel_set_s_mapping
 @ This sets an s-channel resonance multichannel mapping.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_res_mapping => sf_channel_set_res_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: m, w
     logical, intent(in) :: single
     if (single) then
        channel%map_code(i_sf) = SFMAP_MULTI_SRS
        allocate (sf_res_mapping_single_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_res_mapping_single_t)
           call mapping%init (m, w)
        end select
     else
        channel%map_code(i_sf) = SFMAP_MULTI_RES
        allocate (sf_res_mapping_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_res_mapping_t)
           call mapping%init (m, w)
        end select
     end if
   end subroutine sf_channel_set_res_mapping
 
 @ %def sf_channel_set_res_mapping
 @ This sets an s-channel on-shell multichannel mapping.  The length of the
 [[i_sf]] array must be 2.  (The first parameter actually becomes an
 irrelevant dummy.)
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_os_mapping => sf_channel_set_os_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_os_mapping (channel, i_sf, m, single)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: m
     logical, intent(in) :: single
     if (single) then
        channel%map_code(i_sf) = SFMAP_MULTI_SON
        allocate (sf_os_mapping_single_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_os_mapping_single_t)
           call mapping%init (m)
        end select
     else
        channel%map_code(i_sf) = SFMAP_MULTI_ONS
        allocate (sf_os_mapping_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_os_mapping_t)
           call mapping%init (m)
        end select
     end if
   end subroutine sf_channel_set_os_mapping
 
 @ %def sf_channel_set_os_mapping
 @ This sets an s-channel endpoint mapping.  The parameter $a$ is the
 slope parameter (default 1); increasing it moves the endpoint region
 (at $x=1$ to lower values in the input parameter.
 region even more.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ep_mapping => sf_channel_set_ep_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_ep_mapping (channel, i_sf, a)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a
     channel%map_code(i_sf) = SFMAP_MULTI_EP
     allocate (sf_ep_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ep_mapping_t)
        call mapping%init (a = a)
     end select
   end subroutine sf_channel_set_ep_mapping
 
 @ %def sf_channel_set_ep_mapping
 @ This sets a resonant endpoint mapping.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_epr_mapping => sf_channel_set_epr_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: a, m, w
     channel%map_code(i_sf) = SFMAP_MULTI_EPR
     allocate (sf_epr_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_epr_mapping_t)
        call mapping%init (a, m, w)
     end select
   end subroutine sf_channel_set_epr_mapping
 
 @ %def sf_channel_set_epr_mapping
 @ This sets an on-shell endpoint mapping.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_epo_mapping => sf_channel_set_epo_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: a, m
     channel%map_code(i_sf) = SFMAP_MULTI_EPO
     allocate (sf_epo_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_epo_mapping_t)
        call mapping%init (a, m)
     end select
   end subroutine sf_channel_set_epo_mapping
 
 @ %def sf_channel_set_epo_mapping
 @ This sets an s-channel power mapping, regulating a singularity of
 type $(1-x)^{-1+\epsilon}$.  The parameter $\epsilon$ depends on the
 structure function.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ip_mapping => sf_channel_set_ip_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_ip_mapping (channel, i_sf, eps)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: eps
     channel%map_code(i_sf) = SFMAP_MULTI_IP
     allocate (sf_ip_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ip_mapping_t)
        call mapping%init (eps)
     end select
   end subroutine sf_channel_set_ip_mapping
 
 @ %def sf_channel_set_ip_mapping
 @ This sets an s-channel resonant power mapping, regulating a
 singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an
 s-channel resonance.  The parameter $\epsilon$ depends on the
 structure function.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: eps, m, w
     channel%map_code(i_sf) = SFMAP_MULTI_IPR
     allocate (sf_ipr_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ipr_mapping_t)
        call mapping%init (eps, m, w)
     end select
   end subroutine sf_channel_set_ipr_mapping
 
 @ %def sf_channel_set_ipr_mapping
 @ This sets an on-shell power mapping, regulating a
 singularity of type $(1-x)^{-1+\epsilon}$ for the production of a
 single on-shell particle..  The parameter $\epsilon$ depends on the
 structure function.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: eps, m
     channel%map_code(i_sf) = SFMAP_MULTI_IPO
     allocate (sf_ipo_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ipo_mapping_t)
        call mapping%init (eps, m)
     end select
   end subroutine sf_channel_set_ipo_mapping
 
 @ %def sf_channel_set_ipo_mapping
 @ This sets a combined endpoint/ISR mapping.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ei_mapping => sf_channel_set_ei_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a, eps
     channel%map_code(i_sf) = SFMAP_MULTI_EI
     allocate (sf_ei_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ei_mapping_t)
        call mapping%init (a, eps)
     end select
   end subroutine sf_channel_set_ei_mapping
 
 @ %def sf_channel_set_ei_mapping
 @ This sets a combined endpoint/ISR mapping with resonance.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_eir_mapping => sf_channel_set_eir_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a, eps, m, w
     channel%map_code(i_sf) = SFMAP_MULTI_EI
     allocate (sf_eir_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_eir_mapping_t)
        call mapping%init (a, eps, m, w)
     end select
   end subroutine sf_channel_set_eir_mapping
 
 @ %def sf_channel_set_eir_mapping
 @ This sets a combined endpoint/ISR mapping, on-shell.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_eio_mapping => sf_channel_set_eio_mapping
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a, eps, m
     channel%map_code(i_sf) = SFMAP_MULTI_EI
     allocate (sf_eio_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_eio_mapping_t)
        call mapping%init (a, eps, m)
     end select
   end subroutine sf_channel_set_eio_mapping
 
 @ %def sf_channel_set_eio_mapping
 @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]].
 <<SF mappings: sf channel: TBP>>=
   procedure :: is_single_mapping => sf_channel_is_single_mapping
 <<SF mappings: procedures>>=
   function sf_channel_is_single_mapping (channel, i_sf) result (flag)
     class(sf_channel_t), intent(in) :: channel
     integer, intent(in) :: i_sf
     logical :: flag
     flag = channel%map_code(i_sf) == SFMAP_SINGLE
   end function sf_channel_is_single_mapping
 
 @ %def sf_channel_is_single_mapping
 @ Return true if the mapping code at position [[i_sf]] is any of the
 [[SFMAP_MULTI]] mappings.
 <<SF mappings: sf channel: TBP>>=
   procedure :: is_multi_mapping => sf_channel_is_multi_mapping
 <<SF mappings: procedures>>=
   function sf_channel_is_multi_mapping (channel, i_sf) result (flag)
     class(sf_channel_t), intent(in) :: channel
     integer, intent(in) :: i_sf
     logical :: flag
     select case (channel%map_code(i_sf))
     case (SFMAP_NONE, SFMAP_SINGLE)
        flag = .false.
     case default
        flag = .true.
     end select
   end function sf_channel_is_multi_mapping
 
 @ %def sf_channel_is_multi_mapping
 @ Return the number of parameters that the multi-mapping requires.  The
 mapping object must be allocated.
 <<SF mappings: sf channel: TBP>>=
   procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par
 <<SF mappings: procedures>>=
   function sf_channel_get_multi_mapping_n_par (channel) result (n_par)
     class(sf_channel_t), intent(in) :: channel
     integer :: n_par
     if (allocated (channel%multi_mapping)) then
        n_par = channel%multi_mapping%get_n_dim ()
     else
        n_par = 0
     end if
   end function sf_channel_get_multi_mapping_n_par
 
 @ %def sf_channel_is_multi_mapping
 @ Return true if there is any nontrivial mapping in any of the channels.
 <<SF mappings: public>>=
   public :: any_sf_channel_has_mapping
 <<SF mappings: procedures>>=
   function any_sf_channel_has_mapping (channel) result (flag)
     type(sf_channel_t), dimension(:), intent(in) :: channel
     logical :: flag
     integer :: c
     flag = .false.
     do c = 1, size (channel)
        flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE)
     end do
   end function any_sf_channel_has_mapping
 
 @ %def any_sf_channel_has_mapping
 @ Set a parameter index for an active multi mapping.  We assume that
 the index array is allocated properly.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_par_index => sf_channel_set_par_index
 <<SF mappings: procedures>>=
   subroutine sf_channel_set_par_index (channel, j, i_par)
     class(sf_channel_t), intent(inout) :: channel
     integer, intent(in) :: j
     integer, intent(in) :: i_par
     associate (mapping => channel%multi_mapping)
       if (j >= 1 .and. j <= mapping%get_n_dim ()) then
          if (mapping%get_index (j) == 0) then
             call channel%multi_mapping%set_index (j, i_par)
          else
             call msg_bug ("Structure-function setup: mapping index set twice")
          end if
       else
          call msg_bug ("Structure-function setup: mapping index out of range")
       end if
     end associate
   end subroutine sf_channel_set_par_index
 
 @ %def sf_channel_set_par_index
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_mappings_ut.f90]]>>=
 <<File header>>
 
 module sf_mappings_ut
   use unit_tests
   use sf_mappings_uti
 
 <<Standard module head>>
 
 <<SF mappings: public test>>
 
 contains
 
 <<SF mappings: test driver>>
 
 end module sf_mappings_ut
 @ %def sf_mappings_ut
 @
 <<[[sf_mappings_uti.f90]]>>=
 <<File header>>
 
 module sf_mappings_uti
 
 <<Use kinds>>
   use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16
 
   use sf_mappings
 
 <<Standard module head>>
 
 <<SF mappings: test declarations>>
 
 contains
 
 <<SF mappings: tests>>
 
 end module sf_mappings_uti
 @ %def sf_mappings_ut
 @ API: driver for the unit tests below.
 <<SF mappings: public test>>=
   public :: sf_mappings_test
 <<SF mappings: test driver>>=
   subroutine sf_mappings_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF mappings: execute tests>>
   end subroutine sf_mappings_test
 
 @ %def sf_mappings_test
 @
 \subsubsection{Check standard mapping}
 Probe the standard mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_1, "sf_mappings_1", &
        "standard pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_1
 <<SF mappings: tests>>=
   subroutine sf_mappings_1 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_1"
     write (u, "(A)")  "*   Purpose: probe standard mapping"
     write (u, "(A)")
 
     allocate (sf_s_mapping_t :: mapping)
     select type (mapping)
     type is (sf_s_mapping_t)
        call mapping%init ()
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.1):"
     p = [0.1_default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
     allocate (sf_s_mapping_t :: mapping)
     select type (mapping)
     type is (sf_s_mapping_t)
        call mapping%init (power=2._default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     write (u, *)
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.1):"
     p = [0.1_default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)")  "I =", mapping%integral (100000)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_1"
 
   end subroutine sf_mappings_1
 
 @ %def sf_mappings_1
 @
 \subsubsection{Channel entries}
 Construct channel entries and print them.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_2, "sf_mappings_2", &
        "structure-function mapping channels", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_2
 <<SF mappings: tests>>=
   subroutine sf_mappings_2 (u)
     integer, intent(in) :: u
     type(sf_channel_t), dimension(:), allocatable :: channel
     integer :: c
 
     write (u, "(A)")  "* Test output: sf_mappings_2"
     write (u, "(A)")  "*   Purpose: construct and display &
          &mapping-channel objects"
     write (u, "(A)")
 
     call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2)
     call channel(2)%activate_mapping ([1])
     call channel(3)%set_s_mapping ([1,2])
     call channel(4)%set_s_mapping ([1,2], power=2._default)
     call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.)
     call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.)
     call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.)
     call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.)
 
     call channel(3)%set_par_index (1, 1)
     call channel(3)%set_par_index (2, 4)
 
     call channel(4)%set_par_index (1, 1)
     call channel(4)%set_par_index (2, 4)
 
     call channel(5)%set_par_index (1, 1)
     call channel(5)%set_par_index (2, 3)
 
     call channel(6)%set_par_index (1, 1)
     call channel(6)%set_par_index (2, 2)
 
     call channel(7)%set_par_index (1, 1)
 
     call channel(8)%set_par_index (1, 1)
 
     do c = 1, size (channel)
        write (u, "(I0,':')", advance="no")  c
        call channel(c)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_2"
 
   end subroutine sf_mappings_2
 
 @ %def sf_mappings_2
 @
 \subsubsection{Check resonance mapping}
 Probe the resonance mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 
 The resonance mass is at $1/2$ the energy, the width is $1/10$.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_3, "sf_mappings_3", &
        "resonant pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_3
 <<SF mappings: tests>>=
   subroutine sf_mappings_3 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_3"
     write (u, "(A)")  "*   Purpose: probe resonance pair mapping"
     write (u, "(A)")
 
     allocate (sf_res_mapping_t :: mapping)
     select type (mapping)
     type is (sf_res_mapping_t)
        call mapping%init (0.5_default, 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.1):"
     p = [0.1_default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_3"
 
   end subroutine sf_mappings_3
 
 @ %def sf_mappings_3
 @
 \subsubsection{Check on-shell mapping}
 Probe the on-shell mapping of the unit square for different parameter
 values.  Also calculates integrals.  In this case, the Jacobian is
 constant and given by $|\log m^2|$, so this is also the value of the
 integral.  The factor results from the variable change in the $\delta$
 function $\delta (m^2 - x_1x_2)$ which multiplies the cross section
 for the case at hand.
 
 For the test, the (rescaled) resonance mass is set at $1/2$ the
 energy.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_4, "sf_mappings_4", &
        "on-shell pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_4
 <<SF mappings: tests>>=
   subroutine sf_mappings_4 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_4"
     write (u, "(A)")  "*   Purpose: probe on-shell pair mapping"
     write (u, "(A)")
 
     allocate (sf_os_mapping_t :: mapping)
     select type (mapping)
     type is (sf_os_mapping_t)
        call mapping%init (0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.1):"
     p = [0._default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,1.0):"
     p = [0._default, 1.0_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_4"
 
   end subroutine sf_mappings_4
 
 @ %def sf_mappings_4
 @
 \subsubsection{Check endpoint mapping}
 Probe the endpoint mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_5, "sf_mappings_5", &
        "endpoint pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_5
 <<SF mappings: tests>>=
   subroutine sf_mappings_5 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_5"
     write (u, "(A)")  "*   Purpose: probe endpoint pair mapping"
     write (u, "(A)")
 
     allocate (sf_ep_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ep_mapping_t)
        call mapping%init ()
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_5"
 
   end subroutine sf_mappings_5
 
 @ %def sf_mappings_5
 @
 \subsubsection{Check endpoint resonant mapping}
 Probe the endpoint mapping with resonance.  Also calculates integrals.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_6, "sf_mappings_6", &
        "endpoint resonant mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_6
 <<SF mappings: tests>>=
   subroutine sf_mappings_6 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_6"
     write (u, "(A)")  "*   Purpose: probe endpoint resonant mapping"
     write (u, "(A)")
 
     allocate (sf_epr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_epr_mapping_t)
        call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Same mapping without resonance:"
     write (u, "(A)")
 
     allocate (sf_epr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_epr_mapping_t)
        call mapping%init (a = 1._default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_6"
 
   end subroutine sf_mappings_6
 
 @ %def sf_mappings_6
 @
 \subsubsection{Check endpoint on-shell mapping}
 Probe the endpoint mapping with an on-shell particle.  Also calculates
 integrals.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_7, "sf_mappings_7", &
        "endpoint on-shell mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_7
 <<SF mappings: tests>>=
   subroutine sf_mappings_7 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_7"
     write (u, "(A)")  "*   Purpose: probe endpoint on-shell mapping"
     write (u, "(A)")
 
     allocate (sf_epo_mapping_t :: mapping)
     select type (mapping)
     type is (sf_epo_mapping_t)
        call mapping%init (a = 1._default, m = 0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_7"
 
   end subroutine sf_mappings_7
 
 @ %def sf_mappings_7
 @
 \subsubsection{Check power mapping}
 Probe the power mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_8, "sf_mappings_8", &
        "power pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_8
 <<SF mappings: tests>>=
   subroutine sf_mappings_8 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_8"
     write (u, "(A)")  "*   Purpose: probe power pair mapping"
     write (u, "(A)")
 
     allocate (sf_ip_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ip_mapping_t)
        call mapping%init (eps = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9,0.5):"
     p = [0.9_default, 0.5_default]
     pb= [0.1_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     pb= [0.3_default, 0.8_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.8):"
     p = [0.7_default, 0.8_default]
     pb= [0.3_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.99,0.02):"
     p = [0.99_default, 0.02_default]
     pb= [0.01_default, 0.98_default]
     call mapping%check (u, p, pb, FMT_14, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.99,0.98):"
     p = [0.99_default, 0.98_default]
     pb= [0.01_default, 0.02_default]
     call mapping%check (u, p, pb, FMT_14, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_8"
 
   end subroutine sf_mappings_8
 
 @ %def sf_mappings_8
 @
 \subsubsection{Check resonant power mapping}
 Probe the power mapping of the unit square, adapted for an s-channel
 resonance, for different parameter values.  Also calculates integrals.
 For a finite number of bins, they differ slightly from $1$, but the
 result is well-defined because we are not using random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_9, "sf_mappings_9", &
        "power resonance mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_9
 <<SF mappings: tests>>=
   subroutine sf_mappings_9 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_9"
     write (u, "(A)")  "*   Purpose: probe power resonant pair mapping"
     write (u, "(A)")
 
     allocate (sf_ipr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ipr_mapping_t)
        call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9,0.5):"
     p = [0.9_default, 0.5_default]
     pb= [0.1_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     pb= [0.3_default, 0.8_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.8):"
     p = [0.7_default, 0.8_default]
     pb= [0.3_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9999,0.02):"
     p = [0.9999_default, 0.02_default]
     pb= [0.0001_default, 0.98_default]
     call mapping%check (u, p, pb, FMT_11, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9999,0.98):"
     p = [0.9999_default, 0.98_default]
     pb= [0.0001_default, 0.02_default]
     call mapping%check (u, p, pb, FMT_11, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Same mapping without resonance:"
     write (u, "(A)")
 
     allocate (sf_ipr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ipr_mapping_t)
        call mapping%init (eps = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9,0.5):"
     p = [0.9_default, 0.5_default]
     pb= [0.1_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     pb= [0.3_default, 0.8_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.8):"
     p = [0.7_default, 0.8_default]
     pb= [0.3_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_9"
 
   end subroutine sf_mappings_9
 
 @ %def sf_mappings_9
 @
 \subsubsection{Check on-shell power mapping}
 Probe the power mapping of the unit square, adapted for
 single-particle production, for different parameter values.  Also
 calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not
 using random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_10, "sf_mappings_10", &
        "power on-shell mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_10
 <<SF mappings: tests>>=
   subroutine sf_mappings_10 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_10"
     write (u, "(A)")  "*   Purpose: probe power on-shell mapping"
     write (u, "(A)")
 
     allocate (sf_ipo_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ipo_mapping_t)
        call mapping%init (eps = 0.1_default, m = 0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.02):"
     p = [0._default, 0.02_default]
     pb= [1._default, 0.98_default]
     call mapping%check (u, p, pb, FMT_15, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.98):"
     p = [0._default, 0.98_default]
     pb= [1._default, 0.02_default]
     call mapping%check (u, p, pb, FMT_15, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_10"
 
   end subroutine sf_mappings_10
 
 @ %def sf_mappings_10
 @
 \subsubsection{Check combined endpoint-power mapping}
 Probe the mapping for the beamstrahlung/ISR combination.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_11, "sf_mappings_11", &
        "endpoint/power combined mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_11
 <<SF mappings: tests>>=
   subroutine sf_mappings_11 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(4) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_11"
     write (u, "(A)")  "*   Purpose: probe power pair mapping"
     write (u, "(A)")
 
     allocate (sf_ei_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ei_mapping_t)
        call mapping%init (eps = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
        call mapping%set_index (3, 3)
        call mapping%set_index (4, 4)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5, 0.5, 0.5, 0.5):"
     p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7, 0.2, 0.4, 0.8):"
     p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
     pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9, 0.06, 0.95, 0.1):"
     p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
     pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
     call mapping%check (u, p, pb, FMT_13, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_11"
 
   end subroutine sf_mappings_11
 
 @ %def sf_mappings_11
 @
 \subsubsection{Check resonant endpoint-power mapping}
 Probe the mapping for the beamstrahlung/ISR combination.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_12, "sf_mappings_12", &
        "endpoint/power resonant combined mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_12
 <<SF mappings: tests>>=
   subroutine sf_mappings_12 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(4) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_12"
     write (u, "(A)")  "*   Purpose: probe resonant combined mapping"
     write (u, "(A)")
 
     allocate (sf_eir_mapping_t :: mapping)
     select type (mapping)
     type is (sf_eir_mapping_t)
        call mapping%init (a = 1._default, &
             eps = 0.1_default, m = 0.5_default, w = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
        call mapping%set_index (3, 3)
        call mapping%set_index (4, 4)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5, 0.5, 0.5, 0.5):"
     p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7, 0.2, 0.4, 0.8):"
     p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
     pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9, 0.06, 0.95, 0.1):"
     p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
     pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
     call mapping%check (u, p, pb, FMT_15, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_12"
 
   end subroutine sf_mappings_12
 
 @ %def sf_mappings_12
 @
 \subsubsection{Check on-shell endpoint-power mapping}
 Probe the mapping for the beamstrahlung/ISR combination.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_13, "sf_mappings_13", &
        "endpoint/power on-shell combined mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_13
 <<SF mappings: tests>>=
   subroutine sf_mappings_13 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(4) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_13"
     write (u, "(A)")  "*   Purpose: probe on-shell combined mapping"
     write (u, "(A)")
 
     allocate (sf_eio_mapping_t :: mapping)
     select type (mapping)
     type is (sf_eio_mapping_t)
        call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
        call mapping%set_index (3, 3)
        call mapping%set_index (4, 4)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5, 0.5, 0.5, 0.5):"
     p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7, 0.2, 0.4, 0.8):"
     p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
     pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9, 0.06, 0.95, 0.1):"
     p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
     pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
     call mapping%check (u, p, pb, FMT_14, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_13"
 
   end subroutine sf_mappings_13
 
 @ %def sf_mappings_13
 @
 \subsubsection{Check rescaling}
 Check the rescaling factor in on-shell basic mapping.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_14, "sf_mappings_14", &
        "rescaled on-shell mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_14
 <<SF mappings: tests>>=
   subroutine sf_mappings_14 (u)
     integer, intent(in) :: u
     real(default), dimension(2) :: p2, r2
     real(default), dimension(1) :: p1, r1
     real(default) :: f, x_free, m2
 
     write (u, "(A)")  "* Test output: sf_mappings_14"
     write (u, "(A)")  "*   Purpose: probe rescaling in os mapping"
     write (u, "(A)")
 
     x_free = 0.9_default
     m2 = 0.5_default
 
     write (u, "(A)")  "* Two parameters"
     write (u, "(A)")
 
     p2 = [0.1_default, 0.2_default]
 
     call map_on_shell (r2, f, p2, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p2
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r2
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r2)
 
     write (u, *)
 
     call map_on_shell_inverse (r2, f, p2, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p2
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r2
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r2)
 
     write (u, "(A)")
     write (u, "(A)")  "* One parameter"
     write (u, "(A)")
 
     p1 = [0.1_default]
 
     call map_on_shell_single (r1, f, p1, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p1
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r1
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r1)
 
     write (u, *)
 
     call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p1
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r1
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_14"
 
   end subroutine sf_mappings_14
 
 @ %def sf_mappings_14
 @
 \subsubsection{Check single parameter resonance mapping}
 Probe the resonance mapping of the unit interval for different parameter
 values.  Also calculates integrals.
 
 The resonance mass is at $1/2$ the energy, the width is $1/10$.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_15, "sf_mappings_15", &
        "resonant single mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_15
 <<SF mappings: tests>>=
   subroutine sf_mappings_15 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(1) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_15"
     write (u, "(A)")  "*   Purpose: probe resonance single mapping"
     write (u, "(A)")
 
     allocate (sf_res_mapping_single_t :: mapping)
     select type (mapping)
     type is (sf_res_mapping_single_t)
        call mapping%init (0.5_default, 0.1_default)
        call mapping%set_index (1, 1)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0):"
     p = [0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5):"
     p = [0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1):"
     p = [0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_15"
 
   end subroutine sf_mappings_15
 
 @ %def sf_mappings_15
 @
 \subsubsection{Check single parameter on-shell mapping}
 Probe the on-shell (pseudo) mapping of the unit interval for different parameter
 values.  Also calculates integrals.
 
 The resonance mass is at $1/2$ the energy.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_16, "sf_mappings_16", &
        "on-shell single mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_16
 <<SF mappings: tests>>=
   subroutine sf_mappings_16 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(1) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_16"
     write (u, "(A)")  "*   Purpose: probe on-shell single mapping"
     write (u, "(A)")
 
     allocate (sf_os_mapping_single_t :: mapping)
     select type (mapping)
     type is (sf_os_mapping_single_t)
        call mapping%init (0.5_default)
        call mapping%set_index (1, 1)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0):"
     p = [0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5):"
     p = [0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_16"
 
   end subroutine sf_mappings_16
 
 @ %def sf_mappings_16
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Structure function base}
 
 <<[[sf_base.f90]]>>=
 <<File header>>
 
 module sf_base
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: write_separator
   use format_defs, only: FMT_17, FMT_19
   use diagnostics
   use lorentz
   use quantum_numbers
   use interactions
   use evaluators
   use pdg_arrays
   use beams
   use sf_aux
   use sf_mappings
   use constants, only: one, two
   use physics_defs, only: n_beams_rescaled
 
 <<Standard module head>>
 
 <<SF base: public>>
 
 <<SF base: parameters>>
 
 <<SF base: types>>
 
 <<SF base: interfaces>>
 
 contains
 
 <<SF base: procedures>>
 
 end module sf_base
 @ %def sf_base
 @
 \subsection{Abstract rescale data-type}
 
 NLO calculations require the treatment of initial state parton radiation.
 The radiation of a parton rescales the energy fraction which enters the hard process.
 We allow for different rescale settings by extending the abstract.
 [[sf_rescale_t]] data type.
 <<SF base: public>>=
   public :: sf_rescale_t
 <<SF base: types>>=
   type, abstract :: sf_rescale_t
     integer :: i_beam = 0
   contains
   <<SF base: rescaling function: TBP>>
   end type sf_rescale_t
 
 @ %def sf_rescale_t
 @
 <<SF base: rescaling function: TBP>>=
   procedure (sf_rescale_apply), deferred :: apply
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_rescale_apply (func, x)
        import
        class(sf_rescale_t), intent(in) :: func
        real(default), intent(inout) :: x
      end subroutine sf_rescale_apply
   end interface
 
 @ %def rescale_apply
 @
 <<SF base: rescaling function: TBP>>=
   procedure :: set_i_beam => sf_rescale_set_i_beam
 <<SF base: procedures>>=
   subroutine sf_rescale_set_i_beam (func, i_beam)
     class(sf_rescale_t), intent(inout) :: func
     integer, intent(in) :: i_beam
     func%i_beam = i_beam
   end subroutine sf_rescale_set_i_beam
 
 @ %def rescale_set_i_beam
 @
 <<SF base: public>>=
   public :: sf_rescale_collinear_t
 <<SF base: types>>=
   type, extends (sf_rescale_t) :: sf_rescale_collinear_t
      real(default) :: xi_tilde
   contains
   <<SF base: rescale collinear: TBP>>
   end type sf_rescale_collinear_t
 
 @ %def sf_rescale_collinear_t
 @ For the subtraction terms we need to rescale the Born $x$ of both beams in the
 collinear limit. This leaves one beam unaffected and rescales the other according to
 \begin{equation}
   x = \frac{\overline{x}}{1-\xi}
 \end{equation}
 which is the collinear limit of [[sf_rescale_real_apply]].
 <<SF base: rescale collinear: TBP>>=
   procedure :: apply => sf_rescale_collinear_apply
 <<SF base: procedures>>=
   subroutine sf_rescale_collinear_apply (func, x)
     class(sf_rescale_collinear_t), intent(in) :: func
     real(default), intent(inout) :: x
     real(default) :: xi
     if (debug2_active (D_BEAMS)) then
        print *, 'Rescaling function - Collinear: '
        print *, 'Input, unscaled x: ', x
        print *, 'xi_tilde: ', func%xi_tilde
     end if
     xi = func%xi_tilde * (one - x)
     x = x / (one - xi)
     if (debug2_active (D_BEAMS))  print *, 'rescaled x: ', x
   end subroutine sf_rescale_collinear_apply
 
 @ %def sf_rescale_collinear_apply
 @
 <<SF base: rescale collinear: TBP>>=
   procedure :: set => sf_rescale_collinear_set
 <<SF base: procedures>>=
   subroutine sf_rescale_collinear_set (func, xi_tilde)
     class(sf_rescale_collinear_t), intent(inout) :: func
     real(default), intent(in) :: xi_tilde
     func%xi_tilde = xi_tilde
   end subroutine sf_rescale_collinear_set
 
 @ %def sf_rescale_collinear_set
 @
 <<SF base: public>>=
   public :: sf_rescale_real_t
 <<SF base: types>>=
   type, extends (sf_rescale_t) :: sf_rescale_real_t
      real(default) :: xi, y
   contains
   <<SF base: rescale real: TBP>>
   end type sf_rescale_real_t
 
 @ %def sf_rescale_real_t
 @ In case of IS Splittings, the beam $x$ changes from Born to real and thus needs to be rescaled according to
 \begin{equation}
   x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}}
   , \qquad
   x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}}
 \end{equation}
 Refs:
 \begin{itemize}
   \item[\textbullet] [0709.2092] Eq. (5.7).
   \item[\textbullet] [0907.4076] Eq. (2.21).
   \item Christian Weiss' PhD Thesis (DESY-THESIS-2017-025), Eq. (A.2.3).
 \end{itemize}
 <<SF base: rescale real: TBP>>=
   procedure :: apply => sf_rescale_real_apply
 <<SF base: procedures>>=
   subroutine sf_rescale_real_apply (func, x)
     class(sf_rescale_real_t), intent(in) :: func
     real(default), intent(inout) :: x
     real(default) :: onepy, onemy
     if (debug2_active (D_BEAMS)) then
        print *, 'Rescaling function - Real: '
        print *, 'Input, unscaled: ', x
        print *, 'Beam index: ', func%i_beam
        print *, 'xi: ', func%xi, 'y: ', func%y
     end if
     x = x / sqrt (one - func%xi)
     onepy = one + func%y; onemy = one - func%y
     if (func%i_beam == 1) then
        x = x * sqrt ((two - func%xi * onemy) / (two - func%xi * onepy))
     else if (func%i_beam == 2) then
        x = x * sqrt ((two - func%xi * onepy) / (two - func%xi * onemy))
     else
        call msg_fatal ("sf_rescale_real_apply - invalid beam index")
     end if
     if (debug2_active (D_BEAMS))  print *, 'rescaled x: ', x
   end subroutine sf_rescale_real_apply
 
 @ %def sf_rescale_real_apply
 @
 <<SF base: rescale real: TBP>>=
   procedure :: set => sf_rescale_real_set
 <<SF base: procedures>>=
   subroutine sf_rescale_real_set (func, xi, y)
     class(sf_rescale_real_t), intent(inout) :: func
     real(default), intent(in) :: xi, y
     func%xi = xi; func%y = y
   end subroutine sf_rescale_real_set
 
 @ %def sf_rescale_real_set
 <<SF base: public>>=
   public :: sf_rescale_dglap_t
 <<SF base: types>>=
   type, extends(sf_rescale_t) :: sf_rescale_dglap_t
      real(default), dimension(:), allocatable :: z
    contains
    <<SF base: rescale dglap: TBP>>
   end type sf_rescale_dglap_t
 
 @ %def sf_rescale_dglap_t
 @
 <<SF base: rescale dglap: TBP>>=
   procedure :: apply => sf_rescale_dglap_apply
 <<SF base: procedures>>=
   subroutine sf_rescale_dglap_apply (func, x)
     class(sf_rescale_dglap_t), intent(in) :: func
     real(default), intent(inout) :: x
     if (debug2_active (D_BEAMS))  then
        print *, "Rescaling function - DGLAP:"
        print *, "Input: ", x
        print *, "Beam index: ", func%i_beam
        print *, "z: ", func%z
     end if
     x = x / func%z(func%i_beam)
     if (debug2_active (D_BEAMS)) print *, "scaled x: ", x
   end subroutine sf_rescale_dglap_apply
 
 @ %def sf_rescale_dglap_apply
 @
 <<SF base: rescale dglap: TBP>>=
   procedure :: set => sf_rescale_dglap_set
 <<SF base: procedures>>=
   subroutine sf_rescale_dglap_set (func, z)
     class(sf_rescale_dglap_t), intent(inout) :: func
     real(default), dimension(:), intent(in) :: z
     ! allocate-on-assginment
     func%z = z
   end subroutine sf_rescale_dglap_set
 
 @  %def sf_rescale_dglap_set
 @
 \subsection{Abstract structure-function data type}
 This type should hold all configuration data for a specific type of
 structure function.  The base object is empty; the implementations
 will fill it.
 <<SF base: public>>=
   public :: sf_data_t
 <<SF base: types>>=
   type, abstract :: sf_data_t
    contains
    <<SF base: sf data: TBP>>
   end type sf_data_t
 
 @ %def sf_data_t
 @ Output.
 <<SF base: sf data: TBP>>=
   procedure (sf_data_write), deferred :: write
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_data_write (data, unit, verbose)
        import
        class(sf_data_t), intent(in) :: data
        integer, intent(in), optional :: unit
        logical, intent(in), optional :: verbose
      end subroutine sf_data_write
   end interface
 
 @ %def sf_data_write
 @ Return true if this structure function is in generator mode.  In
 that case, all parameters are free, otherwise bound.  (We do not
 support mixed cases.)  Default is: no generator.
 <<SF base: sf data: TBP>>=
   procedure :: is_generator => sf_data_is_generator
 <<SF base: procedures>>=
   function sf_data_is_generator (data) result (flag)
     class(sf_data_t), intent(in) :: data
     logical :: flag
     flag = .false.
   end function sf_data_is_generator
 
 @ %def sf_data_is_generator
 @ Return the number of input parameters that determine the
 structure function.
 <<SF base: sf data: TBP>>=
   procedure (sf_data_get_int), deferred :: get_n_par
 <<SF base: interfaces>>=
   abstract interface
      function sf_data_get_int (data) result (n)
        import
        class(sf_data_t), intent(in) :: data
        integer :: n
      end function sf_data_get_int
   end interface
 
 @ %def sf_data_get_int
 @ Return the outgoing particle PDG codes for the current setup.  The codes can
 be an array of particles, for each beam.
 <<SF base: sf data: TBP>>=
   procedure (sf_data_get_pdg_out), deferred :: get_pdg_out
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_data_get_pdg_out (data, pdg_out)
        import
        class(sf_data_t), intent(in) :: data
        type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
      end subroutine sf_data_get_pdg_out
   end interface
 
 @ %def sf_data_get_pdg_out
 @ Allocate a matching structure function interaction object and
 properly initialize it.
 
 <<SF base: sf data: TBP>>=
   procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_data_allocate_sf_int (data, sf_int)
        import
        class(sf_data_t), intent(in) :: data
        class(sf_int_t), intent(inout), allocatable :: sf_int
      end subroutine sf_data_allocate_sf_int
   end interface
 
 @ %def sf_data_allocate_sf_int
 @ Return the PDF set index, if applicable.  We implement a default
 method which returns zero.  The PDF (builtin and LHA) implementations
 will override this.
 <<SF base: sf data: TBP>>=
   procedure :: get_pdf_set => sf_data_get_pdf_set
 <<SF base: procedures>>=
   elemental function sf_data_get_pdf_set (data) result (pdf_set)
     class(sf_data_t), intent(in) :: data
     integer :: pdf_set
     pdf_set = 0
   end function sf_data_get_pdf_set
 
 @ %def sf_data_get_pdf_set
 @ Return the spectrum file, if applicable. We implement a default
 method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will
 override this.
 <<SF base: sf data: TBP>>=
   procedure :: get_beam_file => sf_data_get_beam_file
 <<SF base: procedures>>=
   function sf_data_get_beam_file (data) result (file)
     class(sf_data_t), intent(in) :: data
     type(string_t) :: file
     file = ""
   end function sf_data_get_beam_file
 
 @ %def sf_data_get_beam_file
 @
 \subsection{Structure-function chain configuration}
 This is the data type that the [[process]] module uses for setting
 up its structure-function chain.  For each structure function described
 by the beam data, there is an entry.  The [[i]] array indicates the
 beam(s) to which this structure function applies, and the [[data]]
 object contains the actual configuration data.
 <<SF base: public>>=
   public :: sf_config_t
 <<SF base: types>>=
   type :: sf_config_t
      integer, dimension(:), allocatable :: i
      class(sf_data_t), allocatable :: data
    contains
    <<SF base: sf config: TBP>>
   end type sf_config_t
 
 @ %def sf_config_t
 @ Output:
 <<SF base: sf config: TBP>>=
   procedure :: write => sf_config_write
 <<SF base: procedures>>=
   subroutine sf_config_write (object, unit, verbose)
     class(sf_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     if (allocated (object%i)) then
        write (u, "(1x,A,2(1x,I0))")  "Structure-function configuration: &
             &beam(s)", object%i
        if (allocated (object%data)) &
             call object%data%write (u, verbose = verbose)
     else
        write (u, "(1x,A)")  "Structure-function configuration: [undefined]"
     end if
   end subroutine sf_config_write
 
 @ %def sf_config_write
 @ Initialize.
 <<SF base: sf config: TBP>>=
   procedure :: init => sf_config_init
 <<SF base: procedures>>=
   subroutine sf_config_init (sf_config, i_beam, sf_data)
     class(sf_config_t), intent(out) :: sf_config
     integer, dimension(:), intent(in) :: i_beam
     class(sf_data_t), intent(in) :: sf_data
     allocate (sf_config%i (size (i_beam)), source = i_beam)
     allocate (sf_config%data, source = sf_data)
   end subroutine sf_config_init
 
 @ %def sf_config_init
 @ Return the PDF set, if any.
 <<SF base: sf config: TBP>>=
   procedure :: get_pdf_set => sf_config_get_pdf_set
 <<SF base: procedures>>=
   elemental function sf_config_get_pdf_set (sf_config) result (pdf_set)
     class(sf_config_t), intent(in) :: sf_config
     integer :: pdf_set
     pdf_set = sf_config%data%get_pdf_set ()
   end function sf_config_get_pdf_set
 
 @ %def sf_config_get_pdf_set
 @ Return the beam spectrum file, if any.
 <<SF base: sf config: TBP>>=
   procedure :: get_beam_file => sf_config_get_beam_file
 <<SF base: procedures>>=
   function sf_config_get_beam_file (sf_config) result (file)
     class(sf_config_t), intent(in) :: sf_config
     type(string_t) :: file
     file = sf_config%data%get_beam_file ()
   end function sf_config_get_beam_file
 
 @ %def sf_config_get_beam_file
 @
 \subsection{Structure-function instance}
 The [[sf_int_t]] data type contains an [[interaction_t]] object (it is
 an extension of this type) and a pointer to the [[sf_data_t]]
 configuration data.  This interaction, or copies of it, is used to
 implement structure-function kinematics and dynamics in the context of
 process evaluation.
 
 The status code [[status]] tells whether the interaction is undefined,
 has defined kinematics (but matrix elements invalid), or is completely
 defined.  There is also a status code for failure.  The implementation
 is responsible for updating the status.
 
 The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared
 invariant masses of the incoming, radiated, and outgoing particle,
 respectively.  They are supposed to be set upon initialization, but
 could also be varied event by event.
 
 If the radiated or outgoing mass is nonzero, we may need to apply an
 on-shell projection.  The projection mode is stored as
 [[on_shell_mode]].
 
 The array [[beam_index]] is the list of beams on which this structure
 function applies ($1$, $2$, or both).  The arrays [[incoming]],
 [[radiated]], and [[outgoing]] contain the indices of the respective
 particle sets within the interaction, for convenient lookup.  The
 array [[par_index]] indicates the MC input parameters that this entry
 will use up in the structure-function chain.  The first parameter (or
 the first two, for a spectrum) in this array determines the momentum
 fraction and is thus subject to global mappings.
 
 In the abstract base type, we do not implement the data pointer.  This
 allows us to restrict its type in the implementations.
 <<SF base: public>>=
   public :: sf_int_t
 <<SF base: types>>=
   type, abstract, extends (interaction_t) :: sf_int_t
      integer :: status = SF_UNDEFINED
      real(default), dimension(:), allocatable :: mi2
      real(default), dimension(:), allocatable :: mr2
      real(default), dimension(:), allocatable :: mo2
      integer :: on_shell_mode = KEEP_ENERGY
      logical :: qmin_defined = .false.
      logical :: qmax_defined = .false.
      real(default), dimension(:), allocatable :: qmin
      real(default), dimension(:), allocatable :: qmax
      integer, dimension(:), allocatable :: beam_index
      integer, dimension(:), allocatable :: incoming
      integer, dimension(:), allocatable :: radiated
      integer, dimension(:), allocatable :: outgoing
      integer, dimension(:), allocatable :: par_index
      integer, dimension(:), allocatable :: par_primary
    contains
    <<SF base: sf int: TBP>>
   end type sf_int_t
 
 @ %def sf_int_t
 @ Status codes.  The codes that refer to links, masks, and
 connections, apply to structure-function chains only.
 
 The status codes are public.
 <<SF base: parameters>>=
   integer, parameter, public :: SF_UNDEFINED = 0
   integer, parameter, public :: SF_INITIAL = 1
   integer, parameter, public :: SF_DONE_LINKS = 2
   integer, parameter, public :: SF_FAILED_MASK = 3
   integer, parameter, public :: SF_DONE_MASK = 4
   integer, parameter, public :: SF_FAILED_CONNECTIONS = 5
   integer, parameter, public :: SF_DONE_CONNECTIONS = 6
   integer, parameter, public :: SF_SEED_KINEMATICS = 10
   integer, parameter, public :: SF_FAILED_KINEMATICS = 11
   integer, parameter, public :: SF_DONE_KINEMATICS = 12
   integer, parameter, public :: SF_FAILED_EVALUATION = 13
   integer, parameter, public :: SF_EVALUATED = 20
 
 @ %def SF_UNDEFINED SF_INITIAL
 @ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS
 @ %def SF_DONE_KINEMATICS SF_EVALUATED
 @ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS
 @ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION
 @ Write a string version of the status code:
 <<SF base: procedures>>=
   subroutine write_sf_status (status, u)
     integer, intent(in) :: status
     integer, intent(in) :: u
     select case (status)
     case (SF_UNDEFINED)
        write (u, "(1x,'[',A,']')")  "undefined"
     case (SF_INITIAL)
        write (u, "(1x,'[',A,']')")  "initialized"
     case (SF_DONE_LINKS)
        write (u, "(1x,'[',A,']')")  "links set"
     case (SF_FAILED_MASK)
        write (u, "(1x,'[',A,']')")  "mask mismatch"
     case (SF_DONE_MASK)
        write (u, "(1x,'[',A,']')")  "mask set"
     case (SF_FAILED_CONNECTIONS)
        write (u, "(1x,'[',A,']')")  "connections failed"
     case (SF_DONE_CONNECTIONS)
        write (u, "(1x,'[',A,']')")  "connections set"
     case (SF_SEED_KINEMATICS)
        write (u, "(1x,'[',A,']')")  "incoming momenta set"
     case (SF_FAILED_KINEMATICS)
        write (u, "(1x,'[',A,']')")  "kinematics failed"
     case (SF_DONE_KINEMATICS)
        write (u, "(1x,'[',A,']')")  "kinematics set"
     case (SF_FAILED_EVALUATION)
        write (u, "(1x,'[',A,']')")  "evaluation failed"
     case (SF_EVALUATED)
        write (u, "(1x,'[',A,']')")  "evaluated"
     end select
   end subroutine write_sf_status
 
 @ %def write_sf_status
 @ This is the basic output routine.  Display status and interaction.
 <<SF base: sf int: TBP>>=
   procedure :: base_write => sf_int_base_write
 <<SF base: procedures>>=
   subroutine sf_int_base_write (object, unit, testflag)
     class(sf_int_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "SF instance:"
     call write_sf_status (object%status, u)
     if (allocated (object%beam_index)) &
          write (u, "(3x,A,2(1x,I0))")  "beam      =", object%beam_index
     if (allocated (object%incoming)) &
          write (u, "(3x,A,2(1x,I0))")  "incoming  =", object%incoming
     if (allocated (object%radiated)) &
          write (u, "(3x,A,2(1x,I0))")  "radiated  =", object%radiated
     if (allocated (object%outgoing)) &
          write (u, "(3x,A,2(1x,I0))")  "outgoing  =", object%outgoing
     if (allocated (object%par_index)) &
          write (u, "(3x,A,2(1x,I0))")  "parameter =", object%par_index
     if (object%qmin_defined) &
          write (u, "(3x,A,1x," // FMT_19 // ")")  "q_min     =", object%qmin
     if (object%qmax_defined) &
          write (u, "(3x,A,1x," // FMT_19 // ")")  "q_max     =", object%qmax
     call object%interaction_t%basic_write (u, testflag = testflag)
   end subroutine sf_int_base_write
 
 @ %def sf_int_base_write
 @ The type string identifies the structure function class, and possibly more
 details about the structure function.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_type_string), deferred :: type_string
 <<SF base: interfaces>>=
   abstract interface
      function sf_int_type_string (object) result (string)
        import
        class(sf_int_t), intent(in) :: object
        type(string_t) :: string
      end function sf_int_type_string
   end interface
 
 @ %def sf_int_type_string
 @ Output of the concrete object.  We should not forget to call the
 output routine for the base type.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_write), deferred :: write
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_write (object, unit, testflag)
        import
        class(sf_int_t), intent(in) :: object
        integer, intent(in), optional :: unit
        logical, intent(in), optional :: testflag
      end subroutine sf_int_write
   end interface
 
 @ %def sf_int_write
 @ Basic initialization: set the invariant masses for the particles and
 initialize the interaction.  The caller should then add states to the
 interaction and freeze it.
 
 The dimension of the mask should be equal to the sum of the dimensions
 of the mass-squared arrays, which determine incoming, radiated, and
 outgoing particles, respectively.
 
 Optionally, we can define minimum and maximum values for the momentum
 transfer to the outgoing particle(s).  If all masses are zero, this is
 actually required for non-collinear splitting.
 <<SF base: sf int: TBP>>=
   procedure :: base_init => sf_int_base_init
 <<SF base: procedures>>=
   subroutine sf_int_base_init &
        (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock)
     class(sf_int_t), intent(out) :: sf_int
     type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     real(default), dimension(:), intent(in) :: mi2, mr2, mo2
     real(default), dimension(:), intent(in), optional :: qmin, qmax
     integer, dimension(:), intent(in), optional :: hel_lock
     allocate (sf_int%mi2 (size (mi2)))
     sf_int%mi2 = mi2
     allocate (sf_int%mr2 (size (mr2)))
     sf_int%mr2 = mr2
     allocate (sf_int%mo2 (size (mo2)))
     sf_int%mo2 = mo2
     if (present (qmin)) then
        sf_int%qmin_defined = .true.
        allocate (sf_int%qmin (size (qmin)))
        sf_int%qmin = qmin
     end if
     if (present (qmax)) then
        sf_int%qmax_defined = .true.
        allocate (sf_int%qmax (size (qmax)))
        sf_int%qmax = qmax
     end if
     call sf_int%interaction_t%basic_init &
          (size (mi2), 0, size (mr2) + size (mo2), &
          mask = mask, hel_lock = hel_lock, set_relations = .true.)
   end subroutine sf_int_base_init
 
 @ %def sf_int_base_init
 @ Set the indices of the incoming, radiated, and outgoing particles,
 respectively.
 <<SF base: sf int: TBP>>=
   procedure :: set_incoming => sf_int_set_incoming
   procedure :: set_radiated => sf_int_set_radiated
   procedure :: set_outgoing => sf_int_set_outgoing
 <<SF base: procedures>>=
   subroutine sf_int_set_incoming (sf_int, incoming)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: incoming
     allocate (sf_int%incoming (size (incoming)))
     sf_int%incoming = incoming
   end subroutine sf_int_set_incoming
 
   subroutine sf_int_set_radiated (sf_int, radiated)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: radiated
     allocate (sf_int%radiated (size (radiated)))
     sf_int%radiated = radiated
   end subroutine sf_int_set_radiated
 
   subroutine sf_int_set_outgoing (sf_int, outgoing)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: outgoing
     allocate (sf_int%outgoing (size (outgoing)))
     sf_int%outgoing = outgoing
   end subroutine sf_int_set_outgoing
 
 @ %def sf_int_set_incoming
 @ %def sf_int_set_radiated
 @ %def sf_int_set_outgoing
 @ Initialization.  This proceeds via an abstract data object, which
 for the actual implementation should have the matching concrete type.
 Since all implementations have the same signature, we can prepare a
 deferred procedure.  The data object will become the target of a
 corresponding pointer within the [[sf_int_t]] implementation.
 
 This should call the previous procedure.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_init), deferred :: init
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_init (sf_int, data)
        import
        class(sf_int_t), intent(out) :: sf_int
        class(sf_data_t), intent(in), target :: data
      end subroutine sf_int_init
   end interface
 
 @ %def sf_int_init
 @ Complete initialization.  This routine contains initializations that can
 only be performed after the interaction object got its final shape, i.e.,
 redundant helicities have been eliminated by matching with beams and process.
 
 The default implementation does nothing.
 
 The [[target]] attribute is formally required since some overriding
 implementations use a temporary pointer (iterator) to the state-matrix
 component.  It doesn't appear to make a real difference, though.
 <<SF base: sf int: TBP>>=
   procedure :: setup_constants => sf_int_setup_constants
 <<SF base: procedures>>=
   subroutine sf_int_setup_constants (sf_int)
     class(sf_int_t), intent(inout), target :: sf_int
   end subroutine sf_int_setup_constants
 
 @ %def sf_int_setup_constants
 @ Set beam indices, i.e., the beam(s) on which
 this structure function applies.
 <<SF base: sf int: TBP>>=
   procedure :: set_beam_index => sf_int_set_beam_index
 <<SF base: procedures>>=
   subroutine sf_int_set_beam_index (sf_int, beam_index)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: beam_index
     allocate (sf_int%beam_index (size (beam_index)))
     sf_int%beam_index = beam_index
   end subroutine sf_int_set_beam_index
 
 @ %def sf_int_set_beam_index
 @ Set parameter indices, indicating which MC input parameters are to
 be used for evaluating this structure function.
 <<SF base: sf int: TBP>>=
   procedure :: set_par_index => sf_int_set_par_index
 <<SF base: procedures>>=
   subroutine sf_int_set_par_index (sf_int, par_index)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: par_index
     allocate (sf_int%par_index (size (par_index)))
     sf_int%par_index = par_index
   end subroutine sf_int_set_par_index
 
 @ %def sf_int_set_par_index
 @ Initialize the structure-function kinematics, setting incoming
 momenta.  We assume that array shapes match.
 
 Three versions.  The first version relies on the momenta being linked
 to another interaction.  The second version sets the momenta
 explicitly.  In the third version, we first compute momenta for the
 specified energies and store those.
 <<SF base: sf int: TBP>>=
   generic :: seed_kinematics => sf_int_receive_momenta
   generic :: seed_kinematics => sf_int_seed_momenta
   generic :: seed_kinematics => sf_int_seed_energies
   procedure :: sf_int_receive_momenta
   procedure :: sf_int_seed_momenta
   procedure :: sf_int_seed_energies
 <<SF base: procedures>>=
   subroutine sf_int_receive_momenta (sf_int)
     class(sf_int_t), intent(inout) :: sf_int
     if (sf_int%status >= SF_INITIAL) then
        call sf_int%receive_momenta ()
        sf_int%status = SF_SEED_KINEMATICS
     end if
   end subroutine sf_int_receive_momenta
 
   subroutine sf_int_seed_momenta (sf_int, k)
     class(sf_int_t), intent(inout) :: sf_int
     type(vector4_t), dimension(:), intent(in) :: k
     if (sf_int%status >= SF_INITIAL) then
        call sf_int%set_momenta (k, outgoing=.false.)
        sf_int%status = SF_SEED_KINEMATICS
     end if
   end subroutine sf_int_seed_momenta
 
   subroutine sf_int_seed_energies (sf_int, E)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: E
     type(vector4_t), dimension(:), allocatable :: k
     integer :: j
     if (sf_int%status >= SF_INITIAL) then
        allocate (k (size (E)))
        if (all (E**2 >= sf_int%mi2)) then
           do j = 1, size (E)
              k(j) = vector4_moving (E(j), &
                   (3-2*j) * sqrt (E(j)**2 - sf_int%mi2(j)), 3)
           end do
           call sf_int%seed_kinematics (k)
        end if
     end if
   end subroutine sf_int_seed_energies
 
 @ %def sf_int_seed_momenta
 @ %def sf_int_seed_energies
 @ Tell if in generator mode.  By default, this is false.  To be
 overridden where appropriate; we may refer to the [[is_generator]]
 method of the [[data]] component in the concrete type.
 <<SF base: sf int: TBP>>=
   procedure :: is_generator => sf_int_is_generator
 <<SF base: procedures>>=
   function sf_int_is_generator (sf_int) result (flag)
     class(sf_int_t), intent(in) :: sf_int
     logical :: flag
     flag = .false.
   end function sf_int_is_generator
 
 @ %def sf_int_is_generator
 @ Generate free parameters [[r]].  Parameters are free if they do not
 correspond to integration parameters (i.e., are bound), but are
 generated by the structure function object itself.  By default, all
 parameters are bound, and the output values of this procedure will be
 discarded.  With free parameters, we have to override this procedure.
 
 The value [[x_free]] is the renormalization factor of the total energy
 that corresponds to the free parameters.  If there are no free
 parameters, the procedure will not change its value, which starts as
 unity.  Otherwise, the fraction is typically decreased, but may also
 be increased in some cases.
 <<SF base: sf int: TBP>>=
   procedure :: generate_free => sf_int_generate_free
 <<SF base: procedures>>=
   subroutine sf_int_generate_free (sf_int, r, rb,  x_free)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     r = 0
     rb= 1
   end subroutine sf_int_generate_free
 
 @ %def sf_int_generate_free
 @ Complete the structure-function kinematics, derived from an input
 parameter (array) $r$ between 0 and 1.  The interaction momenta are
 calculated, and we return $x$ (the momentum fraction), and $f$ (the
 Jacobian factor for the map $r\to x$), if [[map]] is set.
 
 If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will
 become unity.  If it is set, the structure-function implementation chooses a
 convenient mapping from $r$ to $x$ with Jacobian $f$.
 
 In the [[inverse_kinematics]] variant, we exchange the intent of [[x]]
 and [[r]].  The momenta are calculated only if the optional flag
 [[set_momenta]] is present and set.  Internal parameters of [[sf_int]]
 are calculated only if the optional flag [[set_x]] is present and set.
 
 Update 2018-08-22: Throughout this algorithm, we now carry
 [[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before.
 This allows us to handle unstable endpoint numerics wherever
 necessary.  The only place where the changes actually did matter was
 for inverse kinematics in the ISR setup, with a very soft photon, but
 it might be most sensible to apply the extension with [[xb]] everywhere.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_complete_kinematics), deferred :: complete_kinematics
   procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map)
        import
        class(sf_int_t), intent(inout) :: sf_int
        real(default), dimension(:), intent(out) :: x
        real(default), dimension(:), intent(out) :: xb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(in) :: r
        real(default), dimension(:), intent(in) :: rb
        logical, intent(in) :: map
      end subroutine sf_int_complete_kinematics
   end interface
 
   abstract interface
      subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
        import
        class(sf_int_t), intent(inout) :: sf_int
        real(default), dimension(:), intent(in) :: x
        real(default), dimension(:), intent(in) :: xb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(out) :: r
        real(default), dimension(:), intent(out) :: rb
        logical, intent(in) :: map
        logical, intent(in), optional :: set_momenta
      end subroutine sf_int_inverse_kinematics
   end interface
 
 @ %def sf_int_complete_kinematics
 @ %def sf_int_inverse_kinematics
 @ Single splitting: compute momenta, given $x$ input parameters.  We
 assume that the incoming momentum is set.  The status code is set to
 [[SF_FAILED_KINEMATICS]] if
 the $x$ array does not correspond to a valid momentum configuration.
 Otherwise, it is updated to [[SF_DONE_KINEMATICS]].
 
 We force the outgoing particle on-shell.  The on-shell projection is
 determined by the [[on_shell_mode]].  The radiated particle should already be
 on shell.
 <<SF base: sf int: TBP>>=
   procedure :: split_momentum => sf_int_split_momentum
 <<SF base: procedures>>=
   subroutine sf_int_split_momentum (sf_int, x, xb)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     type(splitting_data_t) :: sd
     real(default) :: E1, E2
     logical :: fail
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        k = sf_int%get_momentum (1)
        call sd%init (k, &
             sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), &
             collinear = size (x) == 1)
        call sd%set_t_bounds (x(1), xb(1))
        select case (size (x))
        case (1)
        case (3)
           if (sf_int%qmax_defined) then
              if (sf_int%qmin_defined) then
                 call sd%sample_t (x(2), &
                      t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2)
              else
                 call sd%sample_t (x(2), &
                      t0 = - sf_int%qmax(1) ** 2)
              end if
           else
              if (sf_int%qmin_defined) then
                 call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2)
              else
                 call sd%sample_t (x(2))
              end if
           end if
           call sd%sample_phi (x(3))
        case default
           call msg_bug ("Structure function: impossible number of parameters")
        end select
        q = sd%split_momentum (k)
        call on_shell (q, [sf_int%mr2, sf_int%mo2], &
             sf_int%on_shell_mode)
        call sf_int%set_momenta (q, outgoing=.true.)
        E1 = energy (q(1))
        E2 = energy (q(2))
        fail = E1 < 0 .or. E2 < 0 &
             .or. E1 ** 2 < sf_int%mr2(1) &
             .or. E2 ** 2 < sf_int%mo2(1)
        if (fail) then
           sf_int%status = SF_FAILED_KINEMATICS
        else
           sf_int%status = SF_DONE_KINEMATICS
        end if
     end if
   end subroutine sf_int_split_momentum
 
 @ %def sf_test_split_momentum
 @ Pair splitting: two incoming momenta, two radiated, two outgoing.
 This is simple because we insist on all momenta being collinear.
 <<SF base: sf int: TBP>>=
   procedure :: split_momenta => sf_int_split_momenta
 <<SF base: procedures>>=
   subroutine sf_int_split_momenta (sf_int, x, xb)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(4) :: q
     real(default), dimension(4) :: E
     logical :: fail
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        select case (size (x))
        case (2)
        case default
           call msg_bug ("Pair structure function: recoil requested &
                &but not implemented yet")
        end select
        k(1) = sf_int%get_momentum (1)
        k(2) = sf_int%get_momentum (2)
        q(1:2) = xb * k
        q(3:4) = x * k
        select case (size (sf_int%mr2))
        case (2)
           call on_shell (q, &
                [sf_int%mr2(1), sf_int%mr2(2), &
                sf_int%mo2(1), sf_int%mo2(2)], &
                sf_int%on_shell_mode)
           call sf_int%set_momenta (q, outgoing=.true.)
           E = energy (q)
           fail = any (E < 0) &
                .or. any (E(1:2) ** 2 < sf_int%mr2) &
                .or. any (E(3:4) ** 2 < sf_int%mo2)
        case default;  call msg_bug ("split momenta: incorrect use")
        end select
        if (fail) then
           sf_int%status = SF_FAILED_KINEMATICS
        else
           sf_int%status = SF_DONE_KINEMATICS
        end if
     end if
   end subroutine sf_int_split_momenta
 
 @ %def sf_int_split_momenta
 @ Pair spectrum: the reduced version of the previous splitting,
 without radiated momenta.
 <<SF base: sf int: TBP>>=
   procedure :: reduce_momenta => sf_int_reduce_momenta
 <<SF base: procedures>>=
   subroutine sf_int_reduce_momenta (sf_int, x)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(2) :: q
     real(default), dimension(2) :: E
     logical :: fail
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        select case (size (x))
        case (2)
        case default
           call msg_bug ("Pair spectrum: recoil requested &
                &but not implemented yet")
        end select
        k(1) = sf_int%get_momentum (1)
        k(2) = sf_int%get_momentum (2)
        q = x * k
        call on_shell (q, &
             [sf_int%mo2(1), sf_int%mo2(2)], &
             sf_int%on_shell_mode)
        call sf_int%set_momenta (q, outgoing=.true.)
        E = energy (q)
        fail = any (E < 0) &
             .or. any (E ** 2 < sf_int%mo2)
        if (fail) then
           sf_int%status = SF_FAILED_KINEMATICS
        else
           sf_int%status = SF_DONE_KINEMATICS
        end if
     end if
   end subroutine sf_int_reduce_momenta
 
 @ %def sf_int_reduce_momenta
 @ The inverse procedure: we compute the [[x]] array from the momentum
 configuration.  In an overriding TBP, we may also set internal data
 that depend on this, for convenience.
 
 NOTE: Here and above, the single-particle case is treated in detail,
 allowing for non-collinearity and non-vanishing masses and nontrivial
 momentum-transfer bounds.  For the pair case, we currently implement
 only collinear splitting and assume massless particles.  This should
 be improved.
 
 Update 2017-08-22: recover also [[xb]], using the updated [[recover]]
 method of the splitting-data object.  Th
 <<SF base: sf int: TBP>>=
   procedure :: recover_x => sf_int_recover_x
   procedure :: base_recover_x => sf_int_recover_x
 <<SF base: procedures>>=
   subroutine sf_int_recover_x (sf_int, x, xb, x_free)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     type(vector4_t), dimension(:), allocatable :: k
     type(vector4_t), dimension(:), allocatable :: q
     type(splitting_data_t) :: sd
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        allocate (k (sf_int%interaction_t%get_n_in ()))
        allocate (q (sf_int%interaction_t%get_n_out ()))
        k = sf_int%get_momenta (outgoing=.false.)
        q = sf_int%get_momenta (outgoing=.true.)
        select case (size (k))
        case (1)
           call sd%init (k(1), &
                sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), &
                collinear = size (x) == 1)
           call sd%recover (k(1), q, sf_int%on_shell_mode)
           x(1)  = sd%get_x ()
           xb(1) = sd%get_xb ()
           select case (size (x))
           case (1)
           case (3)
              if (sf_int%qmax_defined) then
                 if (sf_int%qmin_defined) then
                    call sd%inverse_t (x(2), &
                         t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2)
                 else
                    call sd%inverse_t (x(2), &
                         t0 = - sf_int%qmax(1) ** 2)
                 end if
              else
                 if (sf_int%qmin_defined) then
                    call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2)
                 else
                    call sd%inverse_t (x(2))
                 end if
              end if
              call sd%inverse_phi (x(3))
              xb(2:3) = 1 - x(2:3)
           case default
              call msg_bug ("Structure function: impossible number &
                   &of parameters")
           end select
        case (2)
           select case (size (x))
           case (2)
           case default
              call msg_bug ("Pair structure function: recoil requested &
                   &but not implemented yet")
           end select
           select case (sf_int%on_shell_mode)
           case (KEEP_ENERGY)
              select case (size (q))
              case (4)
                 x = energy (q(3:4)) / energy (k)
                 xb= energy (q(1:2)) / energy (k)
              case (2)
                 x = energy (q) / energy (k)
                 xb= 1 - x
              end select
           case (KEEP_MOMENTUM)
              select case (size (q))
              case (4)
                 x = longitudinal_part (q(3:4)) / longitudinal_part (k)
                 xb= longitudinal_part (q(1:2)) / longitudinal_part (k)
              case (2)
                 x = longitudinal_part (q) / longitudinal_part (k)
                 xb= 1 - x
              end select
           end select
        end select
     end if
   end subroutine sf_int_recover_x
 
 @ %def sf_int_recover_x
 @ Apply the structure function, i.e., evaluate the interaction.  For
 the calculation, we may use the stored momenta, any further
 information stored inside the [[sf_int]] implementation during
 kinematics setup, and the given energy scale.  It may happen that for
 the given kinematics the value is not defined.  This should be
 indicated by the status code.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_apply), deferred :: apply
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_apply (sf_int, scale, negative_sf, rescale, i_sub)
        import
        class(sf_int_t), intent(inout) :: sf_int
        real(default), intent(in) :: scale
        logical, intent(in), optional :: negative_sf
        class(sf_rescale_t), intent(in), optional :: rescale
        integer, intent(in), optional :: i_sub
      end subroutine sf_int_apply
   end interface
 
 @ %def sf_int_apply
 @
 \subsection{Accessing the structure function}
 Return metadata.  Once [[interaction_t]] is rewritten in OO, some of this will
 be inherited.
 
 The number of outgoing particles is equal to the number of incoming particles.
 The radiated particles are the difference.
 <<SF base: sf int: TBP>>=
   procedure :: get_n_in => sf_int_get_n_in
   procedure :: get_n_rad => sf_int_get_n_rad
   procedure :: get_n_out => sf_int_get_n_out
 <<SF base: procedures>>=
   pure function sf_int_get_n_in (object) result (n_in)
     class(sf_int_t), intent(in) :: object
     integer :: n_in
     n_in = object%interaction_t%get_n_in ()
   end function sf_int_get_n_in
 
   pure function sf_int_get_n_rad (object) result (n_rad)
     class(sf_int_t), intent(in) :: object
     integer :: n_rad
     n_rad = object%interaction_t%get_n_out () &
          - object%interaction_t%get_n_in ()
   end function sf_int_get_n_rad
 
   pure function sf_int_get_n_out (object) result (n_out)
     class(sf_int_t), intent(in) :: object
     integer :: n_out
     n_out = object%interaction_t%get_n_in ()
   end function sf_int_get_n_out
 
 @ %def sf_int_get_n_in
 @ %def sf_int_get_n_rad
 @ %def sf_int_get_n_out
 @ Number of matrix element entries in the interaction:
 <<SF base: sf int: TBP>>=
   procedure :: get_n_states => sf_int_get_n_states
 <<SF base: procedures>>=
   function sf_int_get_n_states (sf_int) result (n_states)
     class(sf_int_t), intent(in) :: sf_int
     integer :: n_states
     n_states = sf_int%get_n_matrix_elements ()
   end function sf_int_get_n_states
 
 @ %def sf_int_get_n_states
 @ Return a specific state as a quantum-number array.
 <<SF base: sf int: TBP>>=
   procedure :: get_state => sf_int_get_state
 <<SF base: procedures>>=
   function sf_int_get_state (sf_int, i) result (qn)
     class(sf_int_t), intent(in) :: sf_int
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer, intent(in) :: i
     allocate (qn (sf_int%get_n_tot ()))
     qn = sf_int%get_quantum_numbers (i)
   end function sf_int_get_state
 
 @ %def sf_int_get_state
 @ Return the matrix-element values for all states.  We can assume that
 the matrix elements are real, so we take the real part.
 <<SF base: sf int: TBP>>=
   procedure :: get_values => sf_int_get_values
 <<SF base: procedures>>=
   subroutine sf_int_get_values (sf_int, value)
     class(sf_int_t), intent(in) :: sf_int
     real(default), dimension(:), intent(out) :: value
     integer :: i
     if (sf_int%status >= SF_EVALUATED) then
        do i = 1, size (value)
           value(i) = real (sf_int%get_matrix_element (i))
        end do
     else
        value = 0
     end if
   end subroutine sf_int_get_values
 
 @ %def sf_int_get_values
 @
 \subsection{Direct calculations}
 Compute a structure function value (array) directly, given an array of $x$
 values and a scale.  If the energy is also given, we initialize the
 kinematics for that energy, otherwise take it from a previous run.
 
 We assume that the [[E]] array has dimension [[n_in]], and the [[x]]
 array has [[n_par]].
 
 Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case.
 <<SF base: sf int: TBP>>=
   procedure :: compute_values => sf_int_compute_values
 <<SF base: procedures>>=
   subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: value
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(in) :: scale
     real(default), dimension(:), intent(in), optional :: E
     real(default), dimension(size (x)) :: xx, xxb
     real(default) :: f
     if (present (E))  call sf_int%seed_kinematics (E)
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.)
        call sf_int%apply (scale)
        call sf_int%get_values (value)
        value = value * f
     else
        value = 0
     end if
   end subroutine sf_int_compute_values
 
 @ %def sf_int_compute_values
 @ Compute just a single value for one of the states, i.e., throw the
 others away.
 <<SF base: sf int: TBP>>=
   procedure :: compute_value => sf_int_compute_value
 <<SF base: procedures>>=
   subroutine sf_int_compute_value &
        (sf_int, i_state, value, x, xb, scale, E)
     class(sf_int_t), intent(inout) :: sf_int
     integer, intent(in) :: i_state
     real(default), intent(out) :: value
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(in) :: scale
     real(default), dimension(:), intent(in), optional :: E
     real(default), dimension(:), allocatable :: value_array
     if (sf_int%status >= SF_INITIAL) then
        allocate (value_array (sf_int%get_n_states ()))
        call sf_int%compute_values (value_array, x, xb, scale, E)
        value = value_array(i_state)
     else
        value = 0
     end if
   end subroutine sf_int_compute_value
 
 @ %def sf_int_compute_value
 @
 \subsection{Structure-function instance}
 This is a wrapper for [[sf_int_t]] objects, such that we can
 build an array with different structure-function types.  The
 structure-function contains an array (a sequence) of [[sf_int_t]]
 objects.
 
 The object, it holds the evaluator that connects the preceding part of the
 structure-function chain to the current interaction.
 
 It also stores the input and output parameter values for the
 contained structure function.  The [[r]] array has a second dimension,
 corresponding to the mapping channels in a multi-channel
 configuration.  There is a Jacobian entry [[f]] for each channel.  The
 corresponding logical array [[mapping]] tells whether we apply the
 mapping appropriate for the current structure function in this channel.
 The [[x]] parameter values (energy fractions) are common to all
 channels.
 <<SF base: types>>=
   type :: sf_instance_t
      class(sf_int_t), allocatable :: int
      type(evaluator_t) :: eval
      real(default), dimension(:,:), allocatable :: r
      real(default), dimension(:,:), allocatable :: rb
      real(default), dimension(:), allocatable :: f
      logical, dimension(:), allocatable :: m
      real(default), dimension(:), allocatable :: x
      real(default), dimension(:), allocatable :: xb
   end type sf_instance_t
 
 @ %def sf_instance_t
 @
 \subsection{Structure-function chain}
 A chain is an array of structure functions [[sf]], initiated by a beam setup.
 We do not use this directly for evaluation, but create instances with
 copies of the contained interactions.
 
 [[n_par]] is the total number of parameters that is necessary for
 completely determining the structure-function chain.  [[n_bound]] is
 the number of MC input parameters that are requested from the
 integrator.  The difference of [[n_par]] and [[n_bound]] is the number
 of free parameters, which are generated by a structure-function
 object in generator mode.
 <<SF base: public>>=
   public :: sf_chain_t
 <<SF base: types>>=
   type, extends (beam_t) :: sf_chain_t
      type(beam_data_t), pointer :: beam_data => null ()
      integer :: n_in = 0
      integer :: n_strfun = 0
      integer :: n_par = 0
      integer :: n_bound = 0
      type(sf_instance_t), dimension(:), allocatable :: sf
      logical :: trace_enable = .false.
      integer :: trace_unit = 0
    contains
    <<SF base: sf chain: TBP>>
   end type sf_chain_t
 
 @ %def sf_chain_t
 @ Finalizer.
 <<SF base: sf chain: TBP>>=
   procedure :: final => sf_chain_final
 <<SF base: procedures>>=
   subroutine sf_chain_final (object)
     class(sf_chain_t), intent(inout) :: object
     integer :: i
     call object%final_tracing ()
     if (allocated (object%sf)) then
        do i = 1, size (object%sf, 1)
           associate (sf => object%sf(i))
             if (allocated (sf%int)) then
                call sf%int%final ()
             end if
           end associate
        end do
     end if
     call beam_final (object%beam_t)
   end subroutine sf_chain_final
 
 @ %def sf_chain_final
 @ Output.
 <<SF base: sf chain: TBP>>=
   procedure :: write => sf_chain_write
 <<SF base: procedures>>=
   subroutine sf_chain_write (object, unit)
     class(sf_chain_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Incoming particles / structure-function chain:"
     if (associated (object%beam_data)) then
        write (u, "(3x,A,I0)")  "n_in      = ", object%n_in
        write (u, "(3x,A,I0)")  "n_strfun  = ", object%n_strfun
        write (u, "(3x,A,I0)")  "n_par     = ", object%n_par
        if (object%n_par /= object%n_bound) then
           write (u, "(3x,A,I0)")  "n_bound   = ", object%n_bound
        end if
        call object%beam_data%write (u)
        call write_separator (u)
        call beam_write (object%beam_t, u)
        if (allocated (object%sf)) then
           do i = 1, object%n_strfun
              associate (sf => object%sf(i))
                call write_separator (u)
                if (allocated (sf%int)) then
                   call sf%int%write (u)
                else
                   write (u, "(1x,A)")  "SF instance: [undefined]"
                end if
              end associate
           end do
        end if
     else
        write (u, "(3x,A)")  "[undefined]"
     end if
   end subroutine sf_chain_write
 
 @ %def sf_chain_write
 @ Initialize: setup beams.  The [[beam_data]] target must remain valid
 for the lifetime of the chain, since we just establish a pointer.  The
 structure-function configuration array is used to initialize the
 individual structure-function entries.  The target attribute is needed
 because the [[sf_int]] entries establish pointers to the configuration data.
 <<SF base: sf chain: TBP>>=
   procedure :: init => sf_chain_init
 <<SF base: procedures>>=
   subroutine sf_chain_init (sf_chain, beam_data, sf_config)
     class(sf_chain_t), intent(out) :: sf_chain
     type(beam_data_t), intent(in), target :: beam_data
     type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config
     integer :: i
     sf_chain%beam_data => beam_data
     sf_chain%n_in = beam_data%get_n_in ()
     call beam_init (sf_chain%beam_t, beam_data)
     if (present (sf_config)) then
        sf_chain%n_strfun = size (sf_config)
        allocate (sf_chain%sf (sf_chain%n_strfun))
        do i = 1, sf_chain%n_strfun
           call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data)
        end do
     end if
   end subroutine sf_chain_init
 
 @ %def sf_chain_init
 @ Receive the beam momenta from a source to which the beam interaction
 is linked.
 <<SF base: sf chain: TBP>>=
   procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta
 <<SF base: procedures>>=
   subroutine sf_chain_receive_beam_momenta (sf_chain)
     class(sf_chain_t), intent(inout), target :: sf_chain
     type(interaction_t), pointer :: beam_int
     beam_int => sf_chain%get_beam_int_ptr ()
     call beam_int%receive_momenta ()
   end subroutine sf_chain_receive_beam_momenta
 
 @ %def sf_chain_receive_beam_momenta
 @ Explicitly set the beam momenta.
 <<SF base: sf chain: TBP>>=
   procedure :: set_beam_momenta => sf_chain_set_beam_momenta
 <<SF base: procedures>>=
   subroutine sf_chain_set_beam_momenta (sf_chain, p)
     class(sf_chain_t), intent(inout) :: sf_chain
     type(vector4_t), dimension(:), intent(in) :: p
     call beam_set_momenta (sf_chain%beam_t, p)
   end subroutine sf_chain_set_beam_momenta
 
 @ %def sf_chain_set_beam_momenta
 @ Set a structure-function entry.  We use the [[data]] input to
 allocate the [[int]] structure-function instance with appropriate
 type, then initialize the entry.  The entry establishes a pointer to
 [[data]].
 
 The index [[i]] is the structure-function index in the chain.
 <<SF base: sf chain: TBP>>=
   procedure :: set_strfun => sf_chain_set_strfun
 <<SF base: procedures>>=
   subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data)
     class(sf_chain_t), intent(inout) :: sf_chain
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: beam_index
     class(sf_data_t), intent(in), target :: data
     integer :: n_par, j
     n_par = data%get_n_par ()
     call data%allocate_sf_int (sf_chain%sf(i)%int)
     associate (sf_int => sf_chain%sf(i)%int)
       call sf_int%init (data)
       call sf_int%set_beam_index (beam_index)
       call sf_int%set_par_index &
            ([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)])
       sf_chain%n_par = sf_chain%n_par + n_par
       if (.not. data%is_generator ()) then
          sf_chain%n_bound = sf_chain%n_bound + n_par
       end if
     end associate
   end subroutine sf_chain_set_strfun
 
 @ %def sf_chain_set_strfun
 @ Return the number of structure-function parameters.
 <<SF base: sf chain: TBP>>=
   procedure :: get_n_par => sf_chain_get_n_par
   procedure :: get_n_bound => sf_chain_get_n_bound
 <<SF base: procedures>>=
   function sf_chain_get_n_par (sf_chain) result (n)
     class(sf_chain_t), intent(in) :: sf_chain
     integer :: n
     n = sf_chain%n_par
   end function sf_chain_get_n_par
 
   function sf_chain_get_n_bound (sf_chain) result (n)
     class(sf_chain_t), intent(in) :: sf_chain
     integer :: n
     n = sf_chain%n_bound
   end function sf_chain_get_n_bound
 
 @ %def sf_chain_get_n_par
 @ %def sf_chain_get_n_bound
 @ Return a pointer to the beam interaction.
 <<SF base: sf chain: TBP>>=
   procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr
 <<SF base: procedures>>=
   function sf_chain_get_beam_int_ptr (sf_chain) result (int)
     type(interaction_t), pointer :: int
     class(sf_chain_t), intent(in), target :: sf_chain
     int => beam_get_int_ptr (sf_chain%beam_t)
   end function sf_chain_get_beam_int_ptr
 
 @ %def sf_chain_get_beam_int_ptr
 @ Enable the trace feature: record structure function data (input
 parameters, $x$ values, evaluation result) to an external file.
 <<SF base: sf chain: TBP>>=
   procedure :: setup_tracing => sf_chain_setup_tracing
   procedure :: final_tracing => sf_chain_final_tracing
 <<SF base: procedures>>=
   subroutine sf_chain_setup_tracing (sf_chain, file)
     class(sf_chain_t), intent(inout) :: sf_chain
     type(string_t), intent(in) :: file
     if (sf_chain%n_strfun > 0) then
        sf_chain%trace_enable = .true.
        sf_chain%trace_unit = free_unit ()
        open (sf_chain%trace_unit, file = char (file), action = "write", &
             status = "replace")
        call sf_chain%write_trace_header ()
     else
        call msg_error ("Beam structure: no structure functions, tracing &
             &disabled")
     end if
   end subroutine sf_chain_setup_tracing
 
   subroutine sf_chain_final_tracing (sf_chain)
     class(sf_chain_t), intent(inout) :: sf_chain
     if (sf_chain%trace_enable) then
        close (sf_chain%trace_unit)
        sf_chain%trace_enable = .false.
     end if
   end subroutine sf_chain_final_tracing
 
 @ %def sf_chain_setup_tracing
 @ %def sf_chain_final_tracing
 @ Write the header for the tracing file.
 <<SF base: sf chain: TBP>>=
   procedure :: write_trace_header => sf_chain_write_trace_header
 <<SF base: procedures>>=
   subroutine sf_chain_write_trace_header (sf_chain)
     class(sf_chain_t), intent(in) :: sf_chain
     integer :: u
     if (sf_chain%trace_enable) then
        u = sf_chain%trace_unit
        write (u, "('# ',A)")  "WHIZARD output: &
             &structure-function sampling data"
        write (u, "('# ',A,1x,I0)")  "Number of sf records:", sf_chain%n_strfun
        write (u, "('# ',A,1x,I0)")  "Number of parameters:", sf_chain%n_par
        write (u, "('# ',A)")  "Columns: channel, p(n_par), x(n_par), f, Jac * f"
     end if
   end subroutine sf_chain_write_trace_header
 
 @ %def sf_chain_write_trace_header
 @ Write a record which collects the structure function data for the
 current data point.  For the selected channel, we print first the
 input integration parameters, then the $x$ values, then the
 structure-function value summed over all quantum numbers, then the
 structure function value times the mapping Jacobian.
 <<SF base: sf chain: TBP>>=
   procedure :: trace => sf_chain_trace
 <<SF base: procedures>>=
   subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum)
     class(sf_chain_t), intent(in) :: sf_chain
     integer, intent(in) :: c_sel
     real(default), dimension(:,:), intent(in) :: p
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: f
     real(default), intent(in) :: sf_sum
     real(default) :: sf_sum_pac, f_sf_sum_pac
     integer :: u, i
     if (sf_chain%trace_enable) then
        u = sf_chain%trace_unit
        write (u, "(1x,I0)", advance="no")  c_sel
        write (u, "(2x)", advance="no")
        do i = 1, sf_chain%n_par
           write (u, "(1x," // FMT_17 // ")", advance="no")  p(i,c_sel)
        end do
        write (u, "(2x)", advance="no")
        do i = 1, sf_chain%n_par
           write (u, "(1x," // FMT_17 // ")", advance="no")  x(i)
        end do
        write (u, "(2x)", advance="no")
        sf_sum_pac = sf_sum
        f_sf_sum_pac = f(c_sel) * sf_sum
        call pacify (sf_sum_pac, 1.E-28_default)
        call pacify (f_sf_sum_pac, 1.E-28_default)
        write (u, "(2(1x," // FMT_17 // "))")  sf_sum_pac, f_sf_sum_pac
     end if
   end subroutine sf_chain_trace
 
 @ %def sf_chain_trace
 @
 \subsection{Chain instances}
 A structure-function chain instance contains copies of the
 interactions in the configuration chain, suitably linked to each other
 and connected by evaluators.
 
 After initialization, [[out_sf]] should point, for each beam, to the
 last structure function that affects this beam.  [[out_sf_i]] should
 indicate the index of the corresponding outgoing particle within that
 structure-function interaction.
 
 Analogously, [[out_eval]] is the last evaluator in the
 structure-function chain, which contains the complete set of outgoing
 particles. [[out_eval_i]] should indicate the index of the outgoing
 particles, within that evaluator, which will initiate the collision.
 
 When calculating actual kinematics, we fill the [[p]], [[r]], and
 [[x]] arrays and the [[f]] factor.  The [[p]] array denotes the MC
 input parameters as they come from the random-number generator.  The
 [[r]] array results from applying global mappings.  The [[x]] array
 results from applying structure-function local mappings.  The $x$
 values can be interpreted directly as momentum fractions (or angle
 fractions, where recoil is involved).  The [[f]] factor is the
 Jacobian that results from applying all mappings.
 
 Update 2017-08-22: carry and output all complements ([[pb]], [[rb]],
 [[xb]]).  Previously, [[xb]] was not included in the record, and the
 output did not contain either.  It does become more verbose, however.
 
 The [[mapping]] entry may store a global mapping that is applied to a
 combination of $x$ values and structure functions, as opposed to mappings that
 affect only a single structure function.  It is applied before the latter
 mappings, in the transformation from the [[p]] array to the [[r]] array.  For
 parameters affected by this mapping, we should ensure that they are not
 involved in a local mapping.
 <<SF base: public>>=
   public :: sf_chain_instance_t
 <<SF base: types>>=
   type, extends (beam_t) :: sf_chain_instance_t
      type(sf_chain_t), pointer :: config => null ()
      integer :: status = SF_UNDEFINED
      type(sf_instance_t), dimension(:), allocatable :: sf
      integer, dimension(:), allocatable :: out_sf
      integer, dimension(:), allocatable :: out_sf_i
      integer :: out_eval = 0
      integer, dimension(:), allocatable :: out_eval_i
      integer :: selected_channel = 0
      real(default), dimension(:,:), allocatable :: p, pb
      real(default), dimension(:,:), allocatable :: r, rb
      real(default), dimension(:), allocatable :: f
      real(default), dimension(:), allocatable :: x, xb
      logical, dimension(:), allocatable :: bound
      real(default) :: x_free = 1
      type(sf_channel_t), dimension(:), allocatable :: channel
    contains
    <<SF base: sf chain instance: TBP>>
   end type sf_chain_instance_t
 
 @ %def sf_chain_instance_t
 @ Finalizer.
 <<SF base: sf chain instance: TBP>>=
   procedure :: final => sf_chain_instance_final
 <<SF base: procedures>>=
   subroutine sf_chain_instance_final (object)
     class(sf_chain_instance_t), intent(inout) :: object
     integer :: i
     if (allocated (object%sf)) then
        do i = 1, size (object%sf, 1)
           associate (sf => object%sf(i))
             if (allocated (sf%int)) then
                call sf%eval%final ()
                call sf%int%final ()
             end if
           end associate
        end do
     end if
     call beam_final (object%beam_t)
   end subroutine sf_chain_instance_final
 
 @ %def sf_chain_instance_final
 @ Output.
 <<SF base: sf chain instance: TBP>>=
   procedure :: write => sf_chain_instance_write
 <<SF base: procedures>>=
   subroutine sf_chain_instance_write (object, unit, col_verbose)
     class(sf_chain_instance_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: col_verbose
     integer :: u, i, c
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "Structure-function chain instance:"
     call write_sf_status (object%status, u)
     if (allocated (object%out_sf)) then
        write (u, "(3x,A)", advance="no")  "outgoing (interactions) ="
        do i = 1, size (object%out_sf)
           write (u, "(1x,I0,':',I0)", advance="no") &
                object%out_sf(i), object%out_sf_i(i)
        end do
        write (u, *)
     end if
     if (object%out_eval /= 0) then
        write (u, "(3x,A)", advance="no")  "outgoing (evaluators)   ="
        do i = 1, size (object%out_sf)
           write (u, "(1x,I0,':',I0)", advance="no") &
                object%out_eval, object%out_eval_i(i)
        end do
        write (u, *)
     end if
     if (allocated (object%sf)) then
        if (size (object%sf) /= 0) then
           write (u, "(1x,A)")  "Structure-function parameters:"
           do c = 1, size (object%f)
              write (u, "(1x,A,I0,A)", advance="no")  "Channel #", c, ":"
              if (c == object%selected_channel) then
                 write (u, "(1x,A)")  "[selected]"
              else
                 write (u, *)
              end if
              write (u, "(3x,A,9(1x,F9.7))")  "p =", object%p(:,c)
              write (u, "(3x,A,9(1x,F9.7))")  "pb=", object%pb(:,c)
              write (u, "(3x,A,9(1x,F9.7))")  "r =", object%r(:,c)
              write (u, "(3x,A,9(1x,F9.7))")  "rb=", object%rb(:,c)
              write (u, "(3x,A,9(1x,ES13.7))")  "f =", object%f(c)
              write (u, "(3x,A)", advance="no") "m ="
              call object%channel(c)%write (u)
           end do
           write (u, "(3x,A,9(1x,F9.7))")  "x =", object%x
           write (u, "(3x,A,9(1x,F9.7))")  "xb=", object%xb
           if (.not. all (object%bound)) then
              write (u, "(3x,A,9(1x,L1))")  "bound =", object%bound
           end if
        end if
     end if
     call write_separator (u)
     call beam_write (object%beam_t, u, col_verbose = col_verbose)
     if (allocated (object%sf)) then
        do i = 1, size (object%sf)
           associate (sf => object%sf(i))
             call write_separator (u)
             if (allocated (sf%int)) then
                if (allocated (sf%r)) then
                   write (u, "(1x,A)")  "Structure-function parameters:"
                   do c = 1, size (sf%f)
                      write (u, "(1x,A,I0,A)", advance="no")  "Channel #", c, ":"
                      if (c == object%selected_channel) then
                         write (u, "(1x,A)")  "[selected]"
                      else
                         write (u, *)
                      end if
                      write (u, "(3x,A,9(1x,F9.7))")  "r =", sf%r(:,c)
                      write (u, "(3x,A,9(1x,F9.7))")  "rb=", sf%rb(:,c)
                      write (u, "(3x,A,9(1x,ES13.7))")  "f =", sf%f(c)
                      write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c)
                   end do
                   write (u, "(3x,A,9(1x,F9.7))")  "x =", sf%x
                   write (u, "(3x,A,9(1x,F9.7))")  "xb=", sf%xb
                end if
                call sf%int%write(u)
                if (.not. sf%eval%is_empty ()) then
                      call sf%eval%write (u, col_verbose = col_verbose)
                end if
             end if
           end associate
        end do
     end if
   end subroutine sf_chain_instance_write
 
 @ %def sf_chain_instance_write
 @ Initialize.  This creates a copy of the interactions in the
 configuration chain, assumed to be properly initialized.  In the copy,
 we allocate the [[p]] etc.\ arrays.
 
 The brute-force assignment of the [[sf]] component would be
 straightforward, but we provide a more fine-grained copy.
 In any case, the copy is deep as far as allocatables are concerned,
 but for the contained [[interaction_t]] objects the copy is shallow,
 as long as we do not bind defined assignment to the type.  Therefore,
 we have to re-assign the [[interaction_t]] components explicitly, this
 time calling the proper defined assignment.  Furthermore, we allocate
 the parameter arrays for each structure function.
 <<SF base: sf chain instance: TBP>>=
   procedure :: init => sf_chain_instance_init
 <<SF base: procedures>>=
   subroutine sf_chain_instance_init (chain, config, n_channel)
     class(sf_chain_instance_t), intent(out), target :: chain
     type(sf_chain_t), intent(in), target :: config
     integer, intent(in) :: n_channel
     integer :: i, j
     integer :: n_par_tot, n_par, n_strfun
     chain%config => config
     n_strfun = config%n_strfun
     chain%beam_t = config%beam_t
     allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in))
     allocate (chain%out_eval_i (config%n_in))
     chain%out_sf = 0
     chain%out_sf_i = [(i, i = 1, config%n_in)]
     chain%out_eval_i = chain%out_sf_i
     n_par_tot = 0
     if (n_strfun /= 0) then
        allocate (chain%sf (n_strfun))
        do i = 1, n_strfun
           associate (sf => chain%sf(i))
             allocate (sf%int, source=config%sf(i)%int)
             sf%int%interaction_t = config%sf(i)%int%interaction_t
             n_par = size (sf%int%par_index)
             allocate (sf%r (n_par, n_channel));  sf%r = 0
             allocate (sf%rb(n_par, n_channel));  sf%rb= 0
             allocate (sf%f (n_channel));         sf%f = 0
             allocate (sf%m (n_channel));         sf%m = .false.
             allocate (sf%x (n_par));             sf%x = 0
             allocate (sf%xb(n_par));             sf%xb= 0
             n_par_tot = n_par_tot + n_par
           end associate
        end do
        allocate (chain%p (n_par_tot, n_channel));  chain%p = 0
        allocate (chain%pb(n_par_tot, n_channel));  chain%pb= 0
        allocate (chain%r (n_par_tot, n_channel));  chain%r = 0
        allocate (chain%rb(n_par_tot, n_channel));  chain%rb= 0
        allocate (chain%f (n_channel));             chain%f = 0
        allocate (chain%x (n_par_tot));             chain%x = 0
        allocate (chain%xb(n_par_tot));             chain%xb= 0
        call allocate_sf_channels &
             (chain%channel, n_channel=n_channel, n_strfun=n_strfun)
     end if
     allocate (chain%bound (n_par_tot), source = .true.)
     do i = 1, n_strfun
        associate (sf => chain%sf(i))
          if (sf%int%is_generator ()) then
             do j = 1, size (sf%int%par_index)
                chain%bound(sf%int%par_index(j)) = .false.
             end do
          end if
        end associate
     end do
     chain%status = SF_INITIAL
   end subroutine sf_chain_instance_init
 
 @ %def sf_chain_instance_init
 @ Manually select a channel.
 <<SF base: sf chain instance: TBP>>=
   procedure :: select_channel => sf_chain_instance_select_channel
 <<SF base: procedures>>=
   subroutine sf_chain_instance_select_channel (chain, channel)
     class(sf_chain_instance_t), intent(inout) :: chain
     integer, intent(in), optional :: channel
     if (present (channel)) then
        chain%selected_channel = channel
     else
        chain%selected_channel = 0
     end if
   end subroutine sf_chain_instance_select_channel
 
 @ %def sf_chain_instance_select_channel
 @ Copy a channel-mapping object to the structure-function
 chain instance.  We assume that assignment is sufficient, i.e., any
 non-static components of the [[channel]] object are allocatable und
 thus recursively copied.
 
 After the copy, we extract the single-entry mappings and activate them
 for the individual structure functions.  If there is a multi-entry
 mapping, we obtain the corresponding MC parameter indices and set them
 in the copy of the channel object.
 <<SF base: sf chain instance: TBP>>=
   procedure :: set_channel => sf_chain_instance_set_channel
 <<SF base: procedures>>=
   subroutine sf_chain_instance_set_channel (chain, c, channel)
     class(sf_chain_instance_t), intent(inout) :: chain
     integer, intent(in) :: c
     type(sf_channel_t), intent(in) :: channel
     integer :: i, j, k
     if (chain%status >= SF_INITIAL) then
        chain%channel(c) = channel
        j = 0
        do i = 1, chain%config%n_strfun
           associate (sf => chain%sf(i))
             sf%m(c) = channel%is_single_mapping (i)
             if (channel%is_multi_mapping (i)) then
                do k = 1, size (sf%int%beam_index)
                   j = j + 1
                   call chain%channel(c)%set_par_index &
                        (j, sf%int%par_index(k))
                end do
             end if
           end associate
        end do
        if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then
           print *, "index last filled    = ", j
           print *, "number of parameters = ", &
                chain%channel(c)%get_multi_mapping_n_par ()
           call msg_bug ("Structure-function setup: mapping index mismatch")
        end if
        chain%status = SF_INITIAL
     end if
   end subroutine sf_chain_instance_set_channel
 
 @ %def sf_chain_instance_set_channel
 @ Link the interactions in the chain.  First, link the beam instance
 to its template in the configuration chain, which should have the
 appropriate momenta fixed.
 
 Then, we follow the chain via the
 arrays [[out_sf]] and [[out_sf_i]].  The arrays are (up to)
 two-dimensional, the entries correspond to the beam particle(s).
 For each beam, the entry [[out_sf]] points to the last interaction
 that affected this beam, and [[out_sf_i]] is the
 out-particle index within that interaction.  For the initial beam,
 [[out_sf]] is zero by definition.
 
 For each entry in the chain, we scan the affected beams (one or two).
 We look for [[out_sf]] and link the out-particle there to the
 corresponding in-particle in the current interaction.  Then, we update
 the entry in [[out_sf]] and [[out_sf_i]] to point to the current
 interaction.
 <<SF base: sf chain instance: TBP>>=
   procedure :: link_interactions => sf_chain_instance_link_interactions
 <<SF base: procedures>>=
   subroutine sf_chain_instance_link_interactions (chain)
     class(sf_chain_instance_t), intent(inout), target :: chain
     type(interaction_t), pointer :: int
     integer :: i, j, b
     if (chain%status >= SF_INITIAL) then
        do b = 1, chain%config%n_in
           int => beam_get_int_ptr (chain%beam_t)
           call interaction_set_source_link (int, b, &
                chain%config%beam_t, b)
        end do
        if (allocated (chain%sf)) then
           do i = 1, size (chain%sf)
              associate (sf_int => chain%sf(i)%int)
                do j = 1, size (sf_int%beam_index)
                   b = sf_int%beam_index(j)
                   call link (sf_int%interaction_t, b, sf_int%incoming(j))
                   chain%out_sf(b) = i
                   chain%out_sf_i(b) = sf_int%outgoing(j)
                end do
              end associate
           end do
        end if
        chain%status = SF_DONE_LINKS
     end if
   contains
     subroutine link (int, b, in_index)
       type(interaction_t), intent(inout) :: int
       integer, intent(in) :: b, in_index
       integer :: i
       i = chain%out_sf(b)
       select case (i)
       case (0)
          call interaction_set_source_link (int, in_index, &
               chain%beam_t, chain%out_sf_i(b))
       case default
          call int%set_source_link (in_index, &
               chain%sf(i)%int, chain%out_sf_i(b))
       end select
     end subroutine link
   end subroutine sf_chain_instance_link_interactions
 
 @ %def sf_chain_instance_link_interactions
 @ Exchange the quantum-number masks between the interactions in the
 chain, so we can combine redundant entries and detect any obvious mismatch.
 
 We proceed first in the forward direction and then backwards again.
 
 After this is finished, we finalize initialization by calling the
 [[setup_constants]] method, which prepares constant data that depend on the
 matrix element structure.
 <<SF base: sf chain instance: TBP>>=
   procedure :: exchange_mask => sf_chain_exchange_mask
 <<SF base: procedures>>=
   subroutine sf_chain_exchange_mask (chain)
     class(sf_chain_instance_t), intent(inout), target :: chain
     type(interaction_t), pointer :: int
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
     integer :: i
     if (chain%status >= SF_DONE_LINKS) then
        if (allocated (chain%sf)) then
           int => beam_get_int_ptr (chain%beam_t)
           allocate (mask (int%get_n_out ()))
           mask = int%get_mask ()
           if (size (chain%sf) /= 0) then
              do i = 1, size (chain%sf) - 1
                 call interaction_exchange_mask (chain%sf(i)%int%interaction_t)
              end do
              do i = size (chain%sf), 1, -1
                 call interaction_exchange_mask (chain%sf(i)%int%interaction_t)
              end do
              if (any (mask .neqv. int%get_mask ())) then
                 chain%status = SF_FAILED_MASK
                 return
              end if
              do i = 1, size (chain%sf)
                 call chain%sf(i)%int%setup_constants ()
              end do
           end if
        end if
        chain%status = SF_DONE_MASK
     end if
   end subroutine sf_chain_exchange_mask
 
 @ %def sf_chain_exchange_mask
 @ Initialize the evaluators that connect the interactions in the
 chain.
 <<SF base: sf chain instance: TBP>>=
   procedure :: init_evaluators => sf_chain_instance_init_evaluators
 <<SF base: procedures>>=
   subroutine sf_chain_instance_init_evaluators (chain, extended_sf)
     class(sf_chain_instance_t), intent(inout), target :: chain
     logical, intent(in), optional :: extended_sf
     type(interaction_t), pointer :: int
     type(quantum_numbers_mask_t) :: mask
     integer :: i
     logical :: yorn
     yorn = .false.; if (present (extended_sf)) yorn = extended_sf
     if (chain%status >= SF_DONE_MASK) then
        if (allocated (chain%sf)) then
           if (size (chain%sf) /= 0) then
              mask = quantum_numbers_mask (.false., .false., .true.)
              int => beam_get_int_ptr (chain%beam_t)
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                    if (yorn) then
                       if (int%get_n_sub () == 0) then
                          call int%declare_subtraction (n_beams_rescaled)
                       end if
                       if (sf%int%interaction_t%get_n_sub () == 0) then
                          call sf%int%interaction_t%declare_subtraction (n_beams_rescaled)
                       end if
                    end if
                    call sf%eval%init_product (int, sf%int%interaction_t, mask,&
                         & ignore_sub_for_qn = .true.)
                    if (sf%eval%is_empty ()) then
                       chain%status = SF_FAILED_CONNECTIONS
                       return
                    end if
                    int => sf%eval%interaction_t
                 end associate
              end do
              call find_outgoing_particles ()
           end if
        else if (chain%out_eval == 0) then
           int => beam_get_int_ptr (chain%beam_t)
           call int%tag_hard_process ()
        end if
        chain%status = SF_DONE_CONNECTIONS
     end if
   contains
   <<SF base: init evaluators: find outgoing particles>>
   end subroutine sf_chain_instance_init_evaluators
 
 @ %def sf_chain_instance_init_evaluators
 @ For debug purposes
 <<SF base: sf chain instance: TBP>>=
   procedure :: write_interaction => sf_chain_instance_write_interaction
 <<SF base: procedures>>=
   subroutine sf_chain_instance_write_interaction (chain, i_sf, i_int, unit)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: i_sf, i_int
     integer, intent(in) :: unit
     class(interaction_t), pointer :: int_in1 => null ()
     class(interaction_t), pointer :: int_in2 => null ()
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     if (chain%status >= SF_DONE_MASK) then
        if (allocated (chain%sf)) then
           int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1)
           int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2)
           if (int_in1%get_tag () == i_int) then
              call int_in1%basic_write (u)
           else if (int_in2%get_tag () == i_int) then
              call int_in2%basic_write (u)
           else
              write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int
           end if
        else
           write (u, "(A)") 'No sf_chain allocated!'
        end if
     else
        write (u, "(A)") 'sf_chain not ready!'
     end if
   end subroutine sf_chain_instance_write_interaction
 
 @ %def sf_chain_instance_write_interaction
 @ This is an internal subroutine of the previous one: After evaluators
 are set, trace the outgoing particles to the last evaluator.  We only
 need the first channel, all channels are equivalent for this purpose.
 
 For each beam, the outgoing particle is located by [[out_sf]] (the
 structure-function object where it originates) and [[out_sf_i]] (the
 index within that object).  This particle is referenced by the
 corresponding evaluator, which in turn is referenced by the next
 evaluator, until we are at the end of the chain.  We can trace back
 references by [[interaction_find_link]].  Knowing that [[out_eval]] is
 the index of the last evaluator, we thus determine [[out_eval_i]], the
 index of the outgoing particle within that evaluator.
 <<SF base: init evaluators: find outgoing particles>>=
   subroutine find_outgoing_particles ()
     type(interaction_t), pointer :: int, int_next
     integer :: i, j, out_sf, out_i
     chain%out_eval = size (chain%sf)
     do j = 1, size (chain%out_eval_i)
        out_sf = chain%out_sf(j)
        out_i = chain%out_sf_i(j)
        if (out_sf == 0) then
           int => beam_get_int_ptr (chain%beam_t)
           out_sf = 1
        else
           int => chain%sf(out_sf)%int%interaction_t
        end if
        do i = out_sf, chain%out_eval
           int_next => chain%sf(i)%eval%interaction_t
           out_i = interaction_find_link (int_next, int, out_i)
           int => int_next
        end do
        chain%out_eval_i(j) = out_i
     end do
     call int%tag_hard_process (chain%out_eval_i)
   end subroutine find_outgoing_particles
 
 @ %def find_outgoing_particles
 @ Compute the kinematics in the chain instance.  We can assume that
 the seed momenta are set in the configuration beams.  Scanning the
 chain, we first transfer the incoming momenta.  Then, the use up the MC input
 parameter array [[p]] to compute the radiated and outgoing momenta.
 
 In the multi-channel case, [[c_sel]] is the channel which we use for
 computing the kinematics and the [[x]] values.  In the other channels,
 we invert the kinematics in order to recover the corresponding rows in
 the [[r]] array, and the Jacobian [[f]].
 
 We first apply any global mapping to transform the input [[p]] into
 the array [[r]].  This is then given to the structure functions which
 compute the final array [[x]] and Jacobian factors [[f]], which we
 multiply to obtain the overall Jacobian.
 <<SF base: sf chain instance: TBP>>=
   procedure :: compute_kinematics => sf_chain_instance_compute_kinematics
 <<SF base: procedures>>=
   subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in)
     class(sf_chain_instance_t), intent(inout), target :: chain
     integer, intent(in) :: c_sel
     real(default), dimension(:), intent(in) :: p_in
     type(interaction_t), pointer :: int
     real(default) :: f_mapping
     integer :: i, j, c
     if (chain%status >= SF_DONE_CONNECTIONS) then
        call chain%select_channel (c_sel)
        int => beam_get_int_ptr (chain%beam_t)
        call int%receive_momenta ()
        if (allocated (chain%sf)) then
           if (size (chain%sf) /= 0) then
              forall (i = 1:size (chain%sf))  chain%sf(i)%int%status = SF_INITIAL
              chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default)
              chain%pb(:,c_sel) = 1 - chain%p(:,c_sel)
              chain%f = 1
              chain%x_free = 1
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), &
                        chain%x_free)
                   do j = 1, size (sf%x)
                      if (.not. chain%bound(sf%int%par_index(j))) then
                         chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel)
                         chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel)
                      end if
                   end do
                 end associate
              end do
              if (allocated (chain%channel(c_sel)%multi_mapping)) then
                 call chain%channel(c_sel)%multi_mapping%compute &
                      (chain%r(:,c_sel), chain%rb(:,c_sel), &
                       f_mapping, &
                       chain%p(:,c_sel), chain%pb(:,c_sel), &
                       chain%x_free)
                 chain%f(c_sel) = f_mapping
              else
                 chain%r (:,c_sel) = chain%p (:,c_sel)
                 chain%rb(:,c_sel) = chain%pb(:,c_sel)
                 chain%f(c_sel) = 1
              end if
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%seed_kinematics ()
                   do j = 1, size (sf%x)
                      sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel)
                      sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel)
                   end do
                   call sf%int%complete_kinematics &
                        (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), &
                         sf%m(c_sel))
                   do j = 1, size (sf%x)
                      chain%x(sf%int%par_index(j)) = sf%x(j)
                      chain%xb(sf%int%par_index(j)) = sf%xb(j)
                   end do
                   if (sf%int%status <= SF_FAILED_KINEMATICS) then
                      chain%status = SF_FAILED_KINEMATICS
                      return
                   end if
                   do c = 1, size (sf%f)
                      if (c /= c_sel) then
                         call sf%int%inverse_kinematics &
                              (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c))
                         do j = 1, size (sf%x)
                            chain%r (sf%int%par_index(j),c) = sf%r (j,c)
                            chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
                         end do
                      end if
                      chain%f(c) = chain%f(c) * sf%f(c)
                   end do
                   if (.not. sf%eval%is_empty ()) then
                      call sf%eval%receive_momenta ()
                   end if
                 end associate
              end do
              do c = 1, size (chain%f)
                 if (c /= c_sel) then
                    if (allocated (chain%channel(c)%multi_mapping)) then
                       call chain%channel(c)%multi_mapping%inverse &
                            (chain%r(:,c), chain%rb(:,c), &
                             f_mapping, &
                             chain%p(:,c), chain%pb(:,c), &
                             chain%x_free)
                       chain%f(c) = chain%f(c) * f_mapping
                    else
                       chain%p (:,c) = chain%r (:,c)
                       chain%pb(:,c) = chain%rb(:,c)
                    end if
                 end if
              end do
           end if
        end if
        chain%status = SF_DONE_KINEMATICS
     end if
   end subroutine sf_chain_instance_compute_kinematics
 
 @ %def sf_chain_instance_compute_kinematics
 @ This is a variant of the previous procedure.  We know the $x$ parameters and
 reconstruct the momenta and the MC input parameters [[p]].  We do not need to
 select a channel.
 
 Note: this is probably redundant, since the method we actually want
 starts from the momenta, recovers all $x$ parameters, and then
 inverts mappings.  See below [[recover_kinematics]].
 <<SF base: sf chain instance: TBP>>=
   procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics
 <<SF base: procedures>>=
   subroutine sf_chain_instance_inverse_kinematics (chain, x, xb)
     class(sf_chain_instance_t), intent(inout), target :: chain
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     type(interaction_t), pointer :: int
     real(default) :: f_mapping
     integer :: i, j, c
     if (chain%status >= SF_DONE_CONNECTIONS) then
        call chain%select_channel ()
        int => beam_get_int_ptr (chain%beam_t)
        call int%receive_momenta ()
        if (allocated (chain%sf)) then
           chain%f = 1
           if (size (chain%sf) /= 0) then
              forall (i = 1:size (chain%sf))  chain%sf(i)%int%status = SF_INITIAL
              chain%x = x
              chain%xb= xb
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%seed_kinematics ()
                   do j = 1, size (sf%x)
                      sf%x(j)  = chain%x(sf%int%par_index(j))
                      sf%xb(j) = chain%xb(sf%int%par_index(j))
                   end do
                   do c = 1, size (sf%f)
                      call sf%int%inverse_kinematics &
                           (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), &
                           set_momenta = c==1)
                      chain%f(c) = chain%f(c) * sf%f(c)
                      do j = 1, size (sf%x)
                         chain%r (sf%int%par_index(j),c) = sf%r (j,c)
                         chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
                      end do
                   end do
                   if (.not. sf%eval%is_empty ()) then
                      call sf%eval%receive_momenta ()
                   end if
                 end associate
              end do
              do c = 1, size (chain%f)
                 if (allocated (chain%channel(c)%multi_mapping)) then
                    call chain%channel(c)%multi_mapping%inverse &
                         (chain%r(:,c), chain%rb(:,c), &
                         f_mapping, &
                         chain%p(:,c), chain%pb(:,c), &
                         chain%x_free)
                    chain%f(c) = chain%f(c) * f_mapping
                 else
                    chain%p (:,c) = chain%r (:,c)
                    chain%pb(:,c) = chain%rb(:,c)
                 end if
              end do
           end if
        end if
        chain%status = SF_DONE_KINEMATICS
     end if
   end subroutine sf_chain_instance_inverse_kinematics
 
 @ %def sf_chain_instance_inverse_kinematics
 @ Recover the kinematics: assuming that the last evaluator has
 been filled with a valid set of momenta, we travel the momentum links
 backwards and fill the preceding evaluators and, as a side effect,
 interactions.  We stop at the beam interaction.
 
 After all momenta are set, apply the [[inverse_kinematics]] procedure
 above, suitably modified, to recover the $x$ and $p$ parameters and
 the Jacobian factors.
 
 The [[c_sel]] (channel) argument is just used to mark a selected
 channel for the records, otherwise the recovery procedure is
 independent of this.
 <<SF base: sf chain instance: TBP>>=
   procedure :: recover_kinematics => sf_chain_instance_recover_kinematics
 <<SF base: procedures>>=
   subroutine sf_chain_instance_recover_kinematics (chain, c_sel)
     class(sf_chain_instance_t), intent(inout), target :: chain
     integer, intent(in) :: c_sel
     real(default) :: f_mapping
     integer :: i, j, c
     if (chain%status >= SF_DONE_CONNECTIONS) then
        call chain%select_channel (c_sel)
        if (allocated (chain%sf)) then
           do i = size (chain%sf), 1, -1
              associate (sf => chain%sf(i))
                if (.not. sf%eval%is_empty ()) then
                   call interaction_send_momenta (sf%eval%interaction_t)
                end if
              end associate
           end do
           chain%f = 1
           if (size (chain%sf) /= 0) then
              forall (i = 1:size (chain%sf))  chain%sf(i)%int%status = SF_INITIAL
              chain%x_free = 1
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%seed_kinematics ()
                   call sf%int%recover_x (sf%x, sf%xb, chain%x_free)
                   do j = 1, size (sf%x)
                      chain%x(sf%int%par_index(j))  = sf%x(j)
                      chain%xb(sf%int%par_index(j)) = sf%xb(j)
                   end do
                   do c = 1, size (sf%f)
                      call sf%int%inverse_kinematics &
                           (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), &
                           set_momenta = .false.)
                      chain%f(c) = chain%f(c) * sf%f(c)
                      do j = 1, size (sf%x)
                         chain%r (sf%int%par_index(j),c) = sf%r (j,c)
                         chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
                      end do
                   end do
                 end associate
              end do
              do c = 1, size (chain%f)
                 if (allocated (chain%channel(c)%multi_mapping)) then
                    call chain%channel(c)%multi_mapping%inverse &
                         (chain%r(:,c), chain%rb(:,c), &
                         f_mapping, &
                         chain%p(:,c), chain%pb(:,c), &
                         chain%x_free)
                    chain%f(c) = chain%f(c) * f_mapping
                 else
                    chain%p (:,c) = chain%r (:,c)
                    chain%pb(:,c) = chain%rb(:,c)
                 end if
              end do
           end if
        end if
        chain%status = SF_DONE_KINEMATICS
     end if
   end subroutine sf_chain_instance_recover_kinematics
 
 @ %def sf_chain_instance_recover_kinematics
 @ Return the initial beam momenta to their source, thus completing
 kinematics recovery.  Obviously, this works as a side effect.
 <<SF base: sf chain instance: TBP>>=
   procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta
 <<SF base: procedures>>=
   subroutine sf_chain_instance_return_beam_momenta (chain)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(interaction_t), pointer :: int
     if (chain%status >= SF_DONE_KINEMATICS) then
        int => beam_get_int_ptr (chain%beam_t)
        call interaction_send_momenta (int)
     end if
   end subroutine sf_chain_instance_return_beam_momenta
 
 @ %def sf_chain_instance_return_beam_momenta
 @ Evaluate all interactions in the chain and the product evaluators.
 We provide a [[scale]] argument that is given to all structure
 functions in the chain.
 
 Hadronic NLO calculations involve rescaled fractions of the original beam
 momentum. In particular, we have to handle the following cases:
 \begin{itemize}
   \item normal evaluation (where [[i_sub = 0]]) for all terms except the
     real non-subtracted,
   \item rescaled momentum fraction for both beams in the case of the
     real non-subtracted term ([[i_sub = 0]]),
   \item and rescaled momentum fraction for one of both beams in the case of the
     subtraction and DGLAP component ([[i_sub = 1,2]]).
 \end{itemize}
 For the collinear final or intial state counter terms, we apply a rescaling to
 one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions.
 <<SF base: sf chain instance: TBP>>=
   procedure :: evaluate => sf_chain_instance_evaluate
 <<SF base: procedures>>=
   subroutine sf_chain_instance_evaluate (chain, scale, negative_sf, sf_rescale)
     class(sf_chain_instance_t), intent(inout), target :: chain
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(inout), optional :: sf_rescale
     type(interaction_t), pointer :: out_int
     real(default) :: sf_sum
     integer :: i_beam, i_sub, n_sub
     logical :: rescale
     n_sub = 0
     rescale = .false.; if (present (sf_rescale)) rescale = .true.
     if (rescale) then
        n_sub = chain%get_n_sub ()
     end if
     if (chain%status >= SF_DONE_KINEMATICS) then
        if (allocated (chain%sf)) then
           if (size (chain%sf) /= 0) then
              do i_beam = 1, size (chain%sf)
                 associate (sf => chain%sf(i_beam))
                    if (rescale) then
                       call sf_rescale%set_i_beam (i_beam)
                       do i_sub = 0, n_sub
                          select case (i_sub)
                          case (0)
                             if (n_sub == 0) then
                                call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub)
                             else
                                call sf%int%apply (scale, negative_sf, i_sub = i_sub)
                             end if
                          case default
                             if (i_beam == i_sub) then
                                call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub)
                             else
                                call sf%int%apply (scale, negative_sf, i_sub = i_sub)
                             end if
                          end select
                       end do
                    else
                       call sf%int%apply (scale, negative_sf, i_sub = n_sub)
                    end if
                    if (sf%int%status <= SF_FAILED_EVALUATION) then
                       chain%status = SF_FAILED_EVALUATION
                       return
                    end if
                    if (.not. sf%eval%is_empty ())  call sf%eval%evaluate ()
                 end associate
              end do
              out_int => chain%get_out_int_ptr ()
              sf_sum = real (out_int%sum ())
              call chain%config%trace &
                   (chain%selected_channel, chain%p, chain%x, chain%f, sf_sum)
           end if
        end if
        chain%status = SF_EVALUATED
     end if
   end subroutine sf_chain_instance_evaluate
 
 @ %def sf_chain_instance_evaluate
 @
 \subsection{Access to the chain instance}
 Transfer the outgoing momenta to the array [[p]].  We assume that
 array sizes match.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_momenta => sf_chain_instance_get_out_momenta
 <<SF base: procedures>>=
   subroutine sf_chain_instance_get_out_momenta (chain, p)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(vector4_t), dimension(:), intent(out) :: p
     type(interaction_t), pointer :: int
     integer :: i, j
     if (chain%status >= SF_DONE_KINEMATICS) then
        do j = 1, size (chain%out_sf)
           i = chain%out_sf(j)
           select case (i)
           case (0)
              int => beam_get_int_ptr (chain%beam_t)
           case default
              int => chain%sf(i)%int%interaction_t
           end select
           p(j) = int%get_momentum (chain%out_sf_i(j))
        end do
     end if
   end subroutine sf_chain_instance_get_out_momenta
 
 @ %def sf_chain_instance_get_out_momenta
 @ Return a pointer to the last evaluator in the chain (to the interaction).
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr
 <<SF base: procedures>>=
   function sf_chain_instance_get_out_int_ptr (chain) result (int)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(interaction_t), pointer :: int
     if (chain%out_eval == 0) then
        int => beam_get_int_ptr (chain%beam_t)
     else
        int => chain%sf(chain%out_eval)%eval%interaction_t
     end if
   end function sf_chain_instance_get_out_int_ptr
 
 @ %def sf_chain_instance_get_out_int_ptr
 @ Return the index of the [[j]]-th outgoing particle, within the last
 evaluator.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_i => sf_chain_instance_get_out_i
 <<SF base: procedures>>=
   function sf_chain_instance_get_out_i (chain, j) result (i)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: j
     integer :: i
     i = chain%out_eval_i(j)
   end function sf_chain_instance_get_out_i
 
 @ %def sf_chain_instance_get_out_i
 @ Return the mask for the outgoing particle(s), within the last evaluator.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_mask => sf_chain_instance_get_out_mask
 <<SF base: procedures>>=
   function sf_chain_instance_get_out_mask (chain) result (mask)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
     type(interaction_t), pointer :: int
     allocate (mask (chain%config%n_in))
     int => chain%get_out_int_ptr ()
     mask = int%get_mask (chain%out_eval_i)
   end function sf_chain_instance_get_out_mask
 
 @ %def sf_chain_instance_get_out_mask
 @ Return the array of MC input parameters that corresponds to channel [[c]].
 This is the [[p]] array, the parameters before all mappings.
 
 The [[p]] array may be deallocated.  This should correspond to a
 zero-size [[r]] argument, so nothing to do then.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_mcpar => sf_chain_instance_get_mcpar
 <<SF base: procedures>>=
   subroutine sf_chain_instance_get_mcpar (chain, c, r)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: c
     real(default), dimension(:), intent(out) :: r
     if (allocated (chain%p))  r = pack (chain%p(:,c), chain%bound)
   end subroutine sf_chain_instance_get_mcpar
 
 @ %def sf_chain_instance_get_mcpar
 @ Return the Jacobian factor that corresponds to channel [[c]].
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_f => sf_chain_instance_get_f
 <<SF base: procedures>>=
   function sf_chain_instance_get_f (chain, c) result (f)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: c
     real(default) :: f
     if (allocated (chain%f)) then
        f = chain%f(c)
     else
        f = 1
     end if
   end function sf_chain_instance_get_f
 
 @ %def sf_chain_instance_get_f
 @ Return the evaluation status.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_status => sf_chain_instance_get_status
 <<SF base: procedures>>=
   function sf_chain_instance_get_status (chain) result (status)
     class(sf_chain_instance_t), intent(in) :: chain
     integer :: status
     status = chain%status
   end function sf_chain_instance_get_status
 
 @ %def sf_chain_instance_get_status
 @
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements
 <<SF base: procedures>>=
   subroutine sf_chain_instance_get_matrix_elements (chain, i, ff)
      class(sf_chain_instance_t), intent(in) :: chain
      integer, intent(in) :: i
      real(default), intent(out), dimension(:), allocatable :: ff
 
      associate (sf => chain%sf(i))
         ff = real (sf%int%get_matrix_element ())
      end associate
   end subroutine sf_chain_instance_get_matrix_elements
 
 @ %def sf_chain_instance_get_matrix_elements
 @
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr
 <<SF base: procedures>>=
   function sf_chain_instance_get_beam_int_ptr (chain) result (int)
     type(interaction_t), pointer :: int
     class(sf_chain_instance_t), intent(in), target :: chain
     int => beam_get_int_ptr (chain%beam_t)
   end function sf_chain_instance_get_beam_int_ptr
 
 @ %def sf_chain_instance_get_beam_ptr
 @
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_n_sub => sf_chain_instance_get_n_sub
 <<SF base: procedures>>=
   integer function sf_chain_instance_get_n_sub (chain) result (n_sub)
     type(interaction_t), pointer :: int
     class(sf_chain_instance_t), intent(in), target :: chain
     int => beam_get_int_ptr (chain%beam_t)
     n_sub = int%get_n_sub ()
   end function sf_chain_instance_get_n_sub
 
 @ %def sf_chain_instance_get_n_sub
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_base_ut.f90]]>>=
 <<File header>>
 
 module sf_base_ut
   use unit_tests
   use sf_base_uti
 
 <<Standard module head>>
 
 <<SF base: public test auxiliary>>
 
 <<SF base: public test>>
 
 contains
 
 <<SF base: test driver>>
 
 end module sf_base_ut
 @ %def sf_base_ut
 @
 <<[[sf_base_uti.f90]]>>=
 <<File header>>
 
 module sf_base_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use format_utils, only: write_separator
   use diagnostics
   use lorentz
   use pdg_arrays
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices, only: FM_IGNORE_HELICITY
   use interactions
   use particles
   use model_data
   use beams
   use sf_aux
   use sf_mappings
 
   use sf_base
 
 <<Standard module head>>
 
 <<SF base: test declarations>>
 
 <<SF base: public test auxiliary>>
 
 <<SF base: test types>>
 
 contains
 
 <<SF base: tests>>
 
 <<SF base: test auxiliary>>
 
 end module sf_base_uti
 @ %def sf_base_ut
 @ API: driver for the unit tests below.
 <<SF base: public test>>=
   public :: sf_base_test
 <<SF base: test driver>>=
   subroutine sf_base_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF base: execute tests>>
   end subroutine sf_base_test
 
 @ %def sf_base_test
 @
 \subsection{Test implementation: structure function}
 This is a template for the actual structure-function implementation
 which will be defined in separate modules.
 
 \subsubsection{Configuration data}
 The test structure function uses the [[Test]] model.  It describes a
 scalar within an arbitrary initial particle, which is given in the
 initialization.  The radiated particle is also a scalar, the same one,
 but we set its mass artificially to zero.
 <<SF base: public test auxiliary>>=
   public :: sf_test_data_t
 <<SF base: test types>>=
   type, extends (sf_data_t) :: sf_test_data_t
      class(model_data_t), pointer :: model => null ()
      integer :: mode = 0
      type(flavor_t) :: flv_in
      type(flavor_t) :: flv_out
      type(flavor_t) :: flv_rad
      real(default) :: m = 0
      logical :: collinear = .true.
      real(default), dimension(:), allocatable :: qbounds
    contains
    <<SF base: sf test data: TBP>>
   end type sf_test_data_t
 
 @ %def sf_test_data_t
 @ Output.
 <<SF base: sf test data: TBP>>=
   procedure :: write => sf_test_data_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_write (data, unit, verbose)
     class(sf_test_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "SF test data:"
     write (u, "(3x,A,A)") "model     = ", char (data%model%get_name ())
     write (u, "(3x,A)", advance="no") "incoming  = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "outgoing  = "
     call data%flv_out%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "radiated  = "
     call data%flv_rad%write (u);  write (u, *)
     write (u, "(3x,A," // FMT_19 // ")")  "mass      = ", data%m
     write (u, "(3x,A,L1)")  "collinear = ", data%collinear
     if (.not. data%collinear .and. allocated (data%qbounds)) then
        write (u, "(3x,A," // FMT_19 // ")")  "qmin      = ", data%qbounds(1)
        write (u, "(3x,A," // FMT_19 // ")")  "qmax      = ", data%qbounds(2)
     end if
   end subroutine sf_test_data_write
 
 @ %def sf_test_data_write
 @ Initialization.
 <<SF base: sf test data: TBP>>=
   procedure :: init => sf_test_data_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode)
     class(sf_test_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     logical, intent(in), optional :: collinear
     real(default), dimension(2), intent(in), optional :: qbounds
     integer, intent(in), optional :: mode
     data%model => model
     if (present (mode))  data%mode = mode
     if (pdg_array_get (pdg_in, 1) /= 25) then
        call msg_fatal ("Test spectrum function: input flavor must be 's'")
     end if
     call data%flv_in%init (25, model)
     data%m = data%flv_in%get_mass ()
     if (present (collinear))  data%collinear = collinear
     call data%flv_out%init (25, model)
     call data%flv_rad%init (25, model)
     if (present (qbounds)) then
        allocate (data%qbounds (2))
        data%qbounds = qbounds
     end if
   end subroutine sf_test_data_init
 
 @ %def sf_test_data_init
 @ Return the number of parameters: 1 if only consider collinear
 splitting, 3 otherwise.
 <<SF base: sf test data: TBP>>=
   procedure :: get_n_par => sf_test_data_get_n_par
 <<SF base: test auxiliary>>=
   function sf_test_data_get_n_par (data) result (n)
     class(sf_test_data_t), intent(in) :: data
     integer :: n
     if (data%collinear) then
        n = 1
     else
        n = 3
     end if
   end function sf_test_data_get_n_par
 
 @ %def sf_test_data_get_n_par
 @ Return the outgoing particle PDG code: 25
 <<SF base: sf test data: TBP>>=
   procedure :: get_pdg_out => sf_test_data_get_pdg_out
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_get_pdg_out (data, pdg_out)
     class(sf_test_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = 25
   end subroutine sf_test_data_get_pdg_out
 
 @ %def sf_test_data_get_pdg_out
 @ Allocate the matching interaction.
 <<SF base: sf test data: TBP>>=
   procedure :: allocate_sf_int => sf_test_data_allocate_sf_int
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_allocate_sf_int (data, sf_int)
     class(sf_test_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     if (allocated (sf_int)) deallocate (sf_int)
     allocate (sf_test_t :: sf_int)
   end subroutine sf_test_data_allocate_sf_int
 
 @ %def sf_test_data_allocate_sf_int
 @
 \subsubsection{Interaction}
 <<SF base: test types>>=
   type, extends (sf_int_t) :: sf_test_t
      type(sf_test_data_t), pointer :: data => null ()
      real(default) :: x = 0
    contains
    <<SF base: sf test int: TBP>>
   end type sf_test_t
 
 @ %def sf_test_t
 @ Type string: constant
 <<SF base: sf test int: TBP>>=
   procedure :: type_string => sf_test_type_string
 <<SF base: test auxiliary>>=
   function sf_test_type_string (object) result (string)
     class(sf_test_t), intent(in) :: object
     type(string_t) :: string
     string = "Test"
   end function sf_test_type_string
 
 @ %def sf_test_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF base: sf test int: TBP>>=
   procedure :: write => sf_test_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_write (object, unit, testflag)
     class(sf_test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "SF test data: [undefined]"
     end if
   end subroutine sf_test_write
 
 @ %def sf_test_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 
 Optionally, we can provide minimum and maximum values for the momentum
 transfer.
 <<SF base: sf test int: TBP>>=
   procedure :: init => sf_test_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_init (sf_int, data)
     class(sf_test_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     type(helicity_t) :: hel0
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(3) :: qn
     mask = quantum_numbers_mask (.false., .false., .false.)
     select type (data)
     type is (sf_test_data_t)
        if (allocated (data%qbounds)) then
           call sf_int%base_init (mask, &
                [data%m**2], [0._default], [data%m**2], &
                [data%qbounds(1)], [data%qbounds(2)])
        else
           call sf_int%base_init (mask, &
                [data%m**2], [0._default], [data%m**2])
        end if
        sf_int%data => data
        call hel0%init (0)
        call col0%init ()
        call qn(1)%init (data%flv_in,  col0, hel0)
        call qn(2)%init (data%flv_rad, col0, hel0)
        call qn(3)%init (data%flv_out, col0, hel0)
        call sf_int%add_state (qn)
        call sf_int%freeze ()
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
     end select
     sf_int%status = SF_INITIAL
   end subroutine sf_test_init
 
 @ %def sf_test_init
 @ Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
 <<SF base: sf test int: TBP>>=
   procedure :: complete_kinematics => sf_test_complete_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(sf_test_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        x(1) = r(1)**2
        f = 2 * r(1)
     else
        x(1) = r(1)
        f = 1
     end if
     xb(1) = 1 - x(1)
     if (size (x) == 3) then
        x(2:3)  = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     sf_int%x = x(1)
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS);  f = 0
     end select
   end subroutine sf_test_complete_kinematics
 
 @ %def sf_test_complete_kinematics
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF base: sf test int: TBP>>=
   procedure :: inverse_kinematics => sf_test_inverse_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(sf_test_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        r(1) = sqrt (x(1))
        f = 2 * r(1)
     else
        r(1) = x(1)
        f = 1
     end if
     if (size (x) == 3)  r(2:3) = x(2:3)
     rb = 1 - r
     sf_int%x = x(1)
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine sf_test_inverse_kinematics
 
 @ %def sf_test_inverse_kinematics
 @ Apply the structure function.  The matrix element becomes unity and
 the application always succeeds.
 
 If the [[mode]] indicator is one, the matrix element is equal to the
 parameter~$x$.
 <<SF base: sf test int: TBP>>=
   procedure :: apply => sf_test_apply
 <<SF base: test auxiliary>>=
   subroutine sf_test_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(sf_test_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     select case (sf_int%data%mode)
     case (0)
        call sf_int%set_matrix_element &
             (cmplx (1._default, kind=default))
     case (1)
        call sf_int%set_matrix_element &
             (cmplx (sf_int%x, kind=default))
     end select
     sf_int%status = SF_EVALUATED
   end subroutine sf_test_apply
 
 @ %def sf_test_apply
 @
 \subsection{Test implementation: pair spectrum}
 Another template, this time for a incoming particle pair, splitting
 into two radiated and two outgoing particles.
 
 \subsubsection{Configuration data}
 For simplicity, the spectrum contains two mirror images of the
 previous structure-function configuration: the incoming and all
 outgoing particles are test scalars.
 
 We have two versions, one with radiated particles, one without.
 <<SF base: test types>>=
   type, extends (sf_data_t) :: sf_test_spectrum_data_t
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      type(flavor_t) :: flv_out
      type(flavor_t) :: flv_rad
      logical :: with_radiation = .true.
      real(default) :: m = 0
    contains
    <<SF base: sf test spectrum data: TBP>>
   end type sf_test_spectrum_data_t
 
 @ %def sf_test_spectrum_data_t
 @ Output.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: write => sf_test_spectrum_data_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_write (data, unit, verbose)
     class(sf_test_spectrum_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "SF test spectrum data:"
     write (u, "(3x,A,A)") "model     = ", char (data%model%get_name ())
     write (u, "(3x,A)", advance="no") "incoming  = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "outgoing  = "
     call data%flv_out%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "radiated  = "
     call data%flv_rad%write (u);  write (u, *)
     write (u, "(3x,A," // FMT_19 // ")")  "mass      = ", data%m
   end subroutine sf_test_spectrum_data_write
 
 @ %def sf_test_spectrum_data_write
 @ Initialization.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: init => sf_test_spectrum_data_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation)
     class(sf_test_spectrum_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     logical, intent(in) :: with_radiation
     data%model => model
     data%with_radiation = with_radiation
     if (pdg_array_get (pdg_in, 1) /= 25) then
        call msg_fatal ("Test structure function: input flavor must be 's'")
     end if
     call data%flv_in%init (25, model)
     data%m = data%flv_in%get_mass ()
     call data%flv_out%init (25, model)
     if (with_radiation) then
        call data%flv_rad%init (25, model)
     end if
   end subroutine sf_test_spectrum_data_init
 
 @ %def sf_test_spectrum_data_init
 @ Return the number of parameters: 2, since we have only collinear
 splitting here.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: get_n_par => sf_test_spectrum_data_get_n_par
 <<SF base: test auxiliary>>=
   function sf_test_spectrum_data_get_n_par (data) result (n)
     class(sf_test_spectrum_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function sf_test_spectrum_data_get_n_par
 
 @ %def sf_test_spectrum_data_get_n_par
 @ Return the outgoing particle PDG codes: 25
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out)
     class(sf_test_spectrum_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = 25
     pdg_out(2) = 25
   end subroutine sf_test_spectrum_data_get_pdg_out
 
 @ %def sf_test_spectrum_data_get_pdg_out
 @ Allocate the matching interaction.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: allocate_sf_int => &
        sf_test_spectrum_data_allocate_sf_int
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int)
     class(sf_test_spectrum_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (sf_test_spectrum_t :: sf_int)
   end subroutine sf_test_spectrum_data_allocate_sf_int
 
 @ %def sf_test_spectrum_data_allocate_sf_int
 @
 \subsubsection{Interaction}
 <<SF base: test types>>=
   type, extends (sf_int_t) :: sf_test_spectrum_t
      type(sf_test_spectrum_data_t), pointer :: data => null ()
    contains
    <<SF base: sf test spectrum: TBP>>
   end type sf_test_spectrum_t
 
 @ %def sf_test_spectrum_t
 <<SF base: sf test spectrum: TBP>>=
   procedure :: type_string => sf_test_spectrum_type_string
 <<SF base: test auxiliary>>=
   function sf_test_spectrum_type_string (object) result (string)
     class(sf_test_spectrum_t), intent(in) :: object
     type(string_t) :: string
     string = "Test Spectrum"
   end function sf_test_spectrum_type_string
 
 @ %def sf_test_spectrum_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: write => sf_test_spectrum_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_write (object, unit, testflag)
     class(sf_test_spectrum_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "SF test spectrum data: [undefined]"
     end if
   end subroutine sf_test_spectrum_write
 
 @ %def sf_test_spectrum_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_spectrum_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 
 Optionally, we can provide minimum and maximum values for the momentum
 transfer.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: init => sf_test_spectrum_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_init (sf_int, data)
     class(sf_test_spectrum_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(6) :: mask
     type(helicity_t) :: hel0
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(6) :: qn
     mask = quantum_numbers_mask (.false., .false., .false.)
     select type (data)
     type is (sf_test_spectrum_data_t)
        if (data%with_radiation) then
           call sf_int%base_init (mask(1:6), &
                [data%m**2, data%m**2], &
                [0._default, 0._default], &
                [data%m**2, data%m**2])
           sf_int%data => data
           call hel0%init (0)
           call col0%init ()
           call qn(1)%init (data%flv_in,  col0, hel0)
           call qn(2)%init (data%flv_in,  col0, hel0)
           call qn(3)%init (data%flv_rad, col0, hel0)
           call qn(4)%init (data%flv_rad, col0, hel0)
           call qn(5)%init (data%flv_out, col0, hel0)
           call qn(6)%init (data%flv_out, col0, hel0)
           call sf_int%add_state (qn(1:6))
           call sf_int%set_incoming ([1,2])
           call sf_int%set_radiated ([3,4])
           call sf_int%set_outgoing ([5,6])
        else
           call sf_int%base_init (mask(1:4), &
                [data%m**2, data%m**2], &
                [real(default) :: ], &
                [data%m**2, data%m**2])
           sf_int%data => data
           call hel0%init (0)
           call col0%init ()
           call qn(1)%init (data%flv_in,  col0, hel0)
           call qn(2)%init (data%flv_in,  col0, hel0)
           call qn(3)%init (data%flv_out, col0, hel0)
           call qn(4)%init (data%flv_out, col0, hel0)
           call sf_int%add_state (qn(1:4))
           call sf_int%set_incoming ([1,2])
           call sf_int%set_outgoing ([3,4])
        end if
        call sf_int%freeze ()
     end select
     sf_int%status = SF_INITIAL
   end subroutine sf_test_spectrum_init
 
 @ %def sf_test_spectrum_init
 @ Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ (as above) for both $x$ parameters
 and consequently $f(r)=4r_1r_2$.
 
 <<SF base: sf test spectrum: TBP>>=
   procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(sf_test_spectrum_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default), dimension(2) :: xb1
     if (map) then
        x = r**2
        f = 4 * r(1) * r(2)
     else
        x = r
        f = 1
     end if
     xb = 1 - x
     if (sf_int%data%with_radiation) then
        call sf_int%split_momenta (x, xb)
     else
        call sf_int%reduce_momenta (x)
     end if
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS);  f = 0
     end select
   end subroutine sf_test_spectrum_complete_kinematics
 
 @ %def sf_test_spectrum_complete_kinematics
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(sf_test_spectrum_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
      real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default), dimension(2) :: xb1
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        r = sqrt (x)
        f = 4 * r(1) * r(2)
     else
        r = x
        f = 1
     end if
     rb = 1 - r
     if (set_mom)  then
        if (sf_int%data%with_radiation) then
           call sf_int%split_momenta (x, xb)
        else
           call sf_int%reduce_momenta (x)
        end if
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine sf_test_spectrum_inverse_kinematics
 
 @ %def sf_test_spectrum_inverse_kinematics
 @ Apply the structure function.  The matrix element becomes unity and
 the application always succeeds.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: apply => sf_test_spectrum_apply
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(sf_test_spectrum_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     call sf_int%set_matrix_element &
          (cmplx (1._default, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine sf_test_spectrum_apply
 
 @ %def sf_test_spectrum_apply
 @
 \subsection{Test implementation: generator spectrum}
 A generator for two beams, no radiation (for simplicity).
 
 \subsubsection{Configuration data}
 For simplicity, the spectrum contains two mirror images of the
 previous structure-function configuration: the incoming and all
 outgoing particles are test scalars.
 
 We have two versions, one with radiated particles, one without.
 <<SF base: test types>>=
   type, extends (sf_data_t) :: sf_test_generator_data_t
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      type(flavor_t) :: flv_out
      type(flavor_t) :: flv_rad
      real(default) :: m = 0
    contains
    <<SF base: sf test generator data: TBP>>
   end type sf_test_generator_data_t
 
 @ %def sf_test_generator_data_t
 @ Output.
 <<SF base: sf test generator data: TBP>>=
   procedure :: write => sf_test_generator_data_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_write (data, unit, verbose)
     class(sf_test_generator_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "SF test generator data:"
     write (u, "(3x,A,A)") "model     = ", char (data%model%get_name ())
     write (u, "(3x,A)", advance="no") "incoming  = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "outgoing  = "
     call data%flv_out%write (u);  write (u, *)
     write (u, "(3x,A," // FMT_19 // ")")  "mass      = ", data%m
   end subroutine sf_test_generator_data_write
 
 @ %def sf_test_generator_data_write
 @ Initialization.
 <<SF base: sf test generator data: TBP>>=
   procedure :: init => sf_test_generator_data_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_init (data, model, pdg_in)
     class(sf_test_generator_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     data%model => model
     if (pdg_array_get (pdg_in, 1) /= 25) then
        call msg_fatal ("Test generator: input flavor must be 's'")
     end if
     call data%flv_in%init (25, model)
     data%m = data%flv_in%get_mass ()
     call data%flv_out%init (25, model)
   end subroutine sf_test_generator_data_init
 
 @ %def sf_test_generator_data_init
 @ This structure function is a generator.
 <<SF base: sf test generator data: TBP>>=
   procedure :: is_generator => sf_test_generator_data_is_generator
 <<SF base: test auxiliary>>=
   function sf_test_generator_data_is_generator (data) result (flag)
     class(sf_test_generator_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function sf_test_generator_data_is_generator
 
 @ %def sf_test_generator_data_is_generator
 @ Return the number of parameters: 2, since we have only collinear
 splitting here.
 <<SF base: sf test generator data: TBP>>=
   procedure :: get_n_par => sf_test_generator_data_get_n_par
 <<SF base: test auxiliary>>=
   function sf_test_generator_data_get_n_par (data) result (n)
     class(sf_test_generator_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function sf_test_generator_data_get_n_par
 
 @ %def sf_test_generator_data_get_n_par
 @ Return the outgoing particle PDG codes: 25
 <<SF base: sf test generator data: TBP>>=
   procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_get_pdg_out (data, pdg_out)
     class(sf_test_generator_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = 25
     pdg_out(2) = 25
   end subroutine sf_test_generator_data_get_pdg_out
 
 @ %def sf_test_generator_data_get_pdg_out
 @ Allocate the matching interaction.
 <<SF base: sf test generator data: TBP>>=
   procedure :: allocate_sf_int => &
        sf_test_generator_data_allocate_sf_int
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_allocate_sf_int (data, sf_int)
     class(sf_test_generator_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (sf_test_generator_t :: sf_int)
   end subroutine sf_test_generator_data_allocate_sf_int
 
 @ %def sf_test_generator_data_allocate_sf_int
 @
 \subsubsection{Interaction}
 <<SF base: test types>>=
   type, extends (sf_int_t) :: sf_test_generator_t
      type(sf_test_generator_data_t), pointer :: data => null ()
    contains
    <<SF base: sf test generator: TBP>>
   end type sf_test_generator_t
 
 @ %def sf_test_generator_t
 <<SF base: sf test generator: TBP>>=
   procedure :: type_string => sf_test_generator_type_string
 <<SF base: test auxiliary>>=
   function sf_test_generator_type_string (object) result (string)
     class(sf_test_generator_t), intent(in) :: object
     type(string_t) :: string
     string = "Test Generator"
   end function sf_test_generator_type_string
 
 @ %def sf_test_generator_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF base: sf test generator: TBP>>=
   procedure :: write => sf_test_generator_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_write (object, unit, testflag)
     class(sf_test_generator_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "SF test generator data: [undefined]"
     end if
   end subroutine sf_test_generator_write
 
 @ %def sf_test_generator_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_generator_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass.  No radiation.
 <<SF base: sf test generator: TBP>>=
   procedure :: init => sf_test_generator_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_init (sf_int, data)
     class(sf_test_generator_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(4) :: mask
     type(helicity_t) :: hel0
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(4) :: qn
     mask = quantum_numbers_mask (.false., .false., .false.)
     select type (data)
     type is (sf_test_generator_data_t)
        call sf_int%base_init (mask(1:4), &
             [data%m**2, data%m**2], &
             [real(default) :: ], &
             [data%m**2, data%m**2])
        sf_int%data => data
        call hel0%init (0)
        call col0%init ()
        call qn(1)%init (data%flv_in,  col0, hel0)
        call qn(2)%init (data%flv_in,  col0, hel0)
        call qn(3)%init (data%flv_out, col0, hel0)
        call qn(4)%init (data%flv_out, col0, hel0)
        call sf_int%add_state (qn(1:4))
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%freeze ()
     end select
     sf_int%status = SF_INITIAL
   end subroutine sf_test_generator_init
 
 @ %def sf_test_generator_init
 @ This structure function is a generator.
 <<SF base: sf test generator: TBP>>=
   procedure :: is_generator => sf_test_generator_is_generator
 <<SF base: test auxiliary>>=
   function sf_test_generator_is_generator (sf_int) result (flag)
     class(sf_test_generator_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function sf_test_generator_is_generator
 
 @ %def sf_test_generator_is_generator
 @ Generate free parameters.  This mock generator always produces the
 nubmers 0.8 and 0.5.
 <<SF base: sf test generator: TBP>>=
   procedure :: generate_free => sf_test_generator_generate_free
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_generate_free (sf_int, r, rb,  x_free)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     r = [0.8, 0.5]
     rb= 1 - r
     x_free = x_free * product (r)
   end subroutine sf_test_generator_generate_free
 
 @ %def sf_test_generator_generate_free
 @ Recover momentum fractions.  Since the x values are free, we also set the [[x_free]] parameter.
 <<SF base: sf test generator: TBP>>=
   procedure :: recover_x => sf_test_generator_recover_x
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb)
     if (present (x_free))  x_free = x_free * product (x)
   end subroutine sf_test_generator_recover_x
 
 @ %def sf_test_generator_recover_x
 @ Set kinematics.  Since this is a generator, just transfer input to output.
 <<SF base: sf test generator: TBP>>=
   procedure :: complete_kinematics => sf_test_generator_complete_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     x = r
     xb= rb
     f = 1
     call sf_int%reduce_momenta (x)
   end subroutine sf_test_generator_complete_kinematics
 
 @ %def sf_test_generator_complete_kinematics
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF base: sf test generator: TBP>>=
   procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     r = x
     rb= xb
     f = 1
     if (set_mom)  call sf_int%reduce_momenta (x)
   end subroutine sf_test_generator_inverse_kinematics
 
 @ %def sf_test_generator_inverse_kinematics
 @ Apply the structure function.  The matrix element becomes unity and
 the application always succeeds.
 <<SF base: sf test generator: TBP>>=
   procedure :: apply => sf_test_generator_apply
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     call sf_int%set_matrix_element &
          (cmplx (1._default, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine sf_test_generator_apply
 
 @ %def sf_test_generator_apply
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF base: execute tests>>=
   call test (sf_base_1, "sf_base_1", &
        "structure function configuration", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_1
 <<SF base: tests>>=
   subroutine sf_base_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_base_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle code:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_1"
 
   end subroutine sf_base_1
 
 @ %def sf_base_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the test
 structure function.
 <<SF base: execute tests>>=
   call test (sf_base_2, "sf_base_2", &
        "structure function instance", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_2
 <<SF base: tests>>=
   subroutine sf_base_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
     call flv%init (25, model)
 
     call reset_interaction_counter ()
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=1"
     write (u, "(A)")
 
     r = 1
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics with mapping for r=0.8"
     write (u, "(A)")
 
     r = 0.8_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics for x=0.64 and evaluate"
     write (u, "(A)")
 
     x = 0.64_default
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_2"
 
   end subroutine sf_base_2
 
 @ %def sf_base_2
 @
 \subsubsection{Collinear kinematics}
 Scan over the possibilities for mass assignment and on-shell
 projections, collinear case.
 <<SF base: execute tests>>=
   call test (sf_base_3, "sf_base_3", &
        "alternatives for collinear kinematics", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_3
 <<SF base: tests>>=
   subroutine sf_base_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_3"
     write (u, "(A)")  "*   Purpose: check various kinematical setups"
     write (u, "(A)")  "*            for collinear structure-function splitting."
     write (u, "(A)")  "             (two masses equal, one zero)"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
     call flv%init (25, model)
 
     call reset_interaction_counter ()
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%write (u)
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
 
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set radiated mass to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = sf_int%mi2
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set outgoing mass to zero"
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming mass to zero"
 
     k = vector4_moving (E, E, 3)
     call sf_int%seed_kinematics ([k])
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = sf_int%mi2
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set all masses to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = 0
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_3"
 
   end subroutine sf_base_3
 
 @ %def sf_base_3
 @
 \subsubsection{Non-collinear kinematics}
 Scan over the possibilities for mass assignment and on-shell
 projections, non-collinear case.
 <<SF base: execute tests>>=
   call test (sf_base_4, "sf_base_4", &
        "alternatives for non-collinear kinematics", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_4
 <<SF base: tests>>=
   subroutine sf_base_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_4"
     write (u, "(A)")  "*   Purpose: check various kinematical setups"
     write (u, "(A)")  "*            for free structure-function splitting."
     write (u, "(A)")  "             (two masses equal, one zero)"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
     call flv%init (25, model)
 
     call reset_interaction_counter ()
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in, collinear=.false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%write (u)
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
 
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set radiated mass to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = sf_int%mi2
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set outgoing mass to zero"
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming mass to zero"
 
     k = vector4_moving (E, E, 3)
     call sf_int%seed_kinematics ([k])
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = sf_int%mi2
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set all masses to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = 0
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-Initialize structure-function object with Q bounds"
 
     call reset_interaction_counter ()
 
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in, collinear=.false., &
             qbounds = [1._default, 100._default])
     end select
 
     call sf_int%init (data)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_4"
 
   end subroutine sf_base_4
 
 @ %def sf_base_4
 @
 \subsubsection{Pair spectrum}
 Construct and display a structure function object for a pair spectrum
 (a structure function involving two particles simultaneously).
 <<SF base: execute tests>>=
   call test (sf_base_5, "sf_base_5", &
        "pair spectrum with radiation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_5
 <<SF base: tests>>=
   subroutine sf_base_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(4) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &a pair spectrum object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     allocate (sf_test_spectrum_data_t :: data)
     select type (data)
     type is (sf_test_spectrum_data_t)
        call data%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize spectrum object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momenta with sqrts=1000"
 
     E = 500
     k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.4,0.8"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.4_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics with mapping for r=0.6,0.8"
     write (u, "(A)")
 
     r = [0.6_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call reset_interaction_counter ()
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%seed_kinematics (k)
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics for x=0.36,0.64 &
          &and evaluate"
     write (u, "(A)")
 
     x = [0.36_default, 0.64_default]
     xb = 1 - x
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_5"
 
   end subroutine sf_base_5
 
 @ %def sf_base_5
 @
 \subsubsection{Pair spectrum without radiation}
 Construct and display a structure function object for a pair spectrum
 (a structure function involving two particles simultaneously).
 <<SF base: execute tests>>=
   call test (sf_base_6, "sf_base_6", &
        "pair spectrum without radiation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_6
 <<SF base: tests>>=
   subroutine sf_base_6 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_6"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &a pair spectrum object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     allocate (sf_test_spectrum_data_t :: data)
     select type (data)
     type is (sf_test_spectrum_data_t)
        call data%init (model, pdg_in, with_radiation=.false.)
     end select
 
     write (u, "(A)")  "* Initialize spectrum object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     write (u, "(A)")  "* Initialize incoming momenta with sqrts=1000"
 
     E = 500
     k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.4,0.8"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.4_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call reset_interaction_counter ()
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%seed_kinematics (k)
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics for x=0.4,0.8 &
          &and evaluate"
     write (u, "(A)")
 
     x = [0.4_default, 0.8_default]
     xb = 1 - x
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_6"
 
   end subroutine sf_base_6
 
 @ %def sf_base_6
 @
 \subsubsection{Direct access to structure function}
 Probe a structure function directly.
 <<SF base: execute tests>>=
   call test (sf_base_7, "sf_base_7", &
        "direct access", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_7
 <<SF base: tests>>=
   subroutine sf_base_7 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     real(default), dimension(:), allocatable :: value
 
     write (u, "(A)")  "* Test output: sf_base_7"
     write (u, "(A)")  "*   Purpose: check direct access method"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     write (u, "(A)")  "* Probe structure function: states"
     write (u, "(A)")
 
     write (u, "(A,I0)")  "n_states = ", sf_int%get_n_states ()
     write (u, "(A,I0)")  "n_in     = ", sf_int%get_n_in ()
     write (u, "(A,I0)")  "n_rad    = ", sf_int%get_n_rad ()
     write (u, "(A,I0)")  "n_out    = ", sf_int%get_n_out ()
     write (u, "(A)")
     write (u, "(A)", advance="no")  "state(1)  = "
     call quantum_numbers_write (sf_int%get_state (1), u)
     write (u, *)
 
     allocate (value (sf_int%get_n_states ()))
     call sf_int%compute_values (value, &
          E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default)
 
     write (u, "(A)")
     write (u, "(A)", advance="no")  "value (E=500, x=0.5) ="
     write (u, "(9(1x," // FMT_19 // "))")  value
 
     call sf_int%compute_values (value, &
          x=[0.1_default], xb=[0.9_default], scale=0._default)
 
     write (u, "(A)")
     write (u, "(A)", advance="no")  "value (E=500, x=0.1) ="
     write (u, "(9(1x," // FMT_19 // "))")  value
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize spectrum object"
     write (u, "(A)")
 
     deallocate (value)
     call sf_int%final ()
     deallocate (sf_int)
     deallocate (data)
 
     allocate (sf_test_spectrum_data_t :: data)
     select type (data)
     type is (sf_test_spectrum_data_t)
        call data%init (model, pdg_in, with_radiation=.false.)
     end select
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     write (u, "(A)")  "* Probe spectrum: states"
     write (u, "(A)")
 
     write (u, "(A,I0)")  "n_states = ", sf_int%get_n_states ()
     write (u, "(A,I0)")  "n_in     = ", sf_int%get_n_in ()
     write (u, "(A,I0)")  "n_rad    = ", sf_int%get_n_rad ()
     write (u, "(A,I0)")  "n_out    = ", sf_int%get_n_out ()
     write (u, "(A)")
     write (u, "(A)", advance="no")  "state(1)  = "
     call quantum_numbers_write (sf_int%get_state (1), u)
     write (u, *)
 
     allocate (value (sf_int%get_n_states ()))
     call sf_int%compute_value (1, value(1), &
          E = [500._default, 500._default], &
          x = [0.5_default, 0.6_default], &
          xb= [0.5_default, 0.4_default], &
          scale = 0._default)
 
     write (u, "(A)")
     write (u, "(A)", advance="no")  "value (E=500,500, x=0.5,0.6) ="
     write (u, "(9(1x," // FMT_19 // "))")  value
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_7"
 
   end subroutine sf_base_7
 
 @ %def sf_base_7
 @
 \subsubsection{Structure function chain configuration}
 <<SF base: execute tests>>=
   call test (sf_base_8, "sf_base_8", &
        "structure function chain configuration", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_8
 <<SF base: tests>>=
   subroutine sf_base_8 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_spectrum
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_chain_t) :: sf_chain
 
     write (u, "(A)")  "* Test output: sf_base_8"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_spectrum_data_t :: data_spectrum)
     select type (data_spectrum)
     type is (sf_test_spectrum_data_t)
        call data_spectrum%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(A)")  "* Set up chain with beams only"
     write (u, "(A)")
 
     call sf_chain%init (beam_data)
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with structure function"
     write (u, "(A)")
 
     allocate (sf_config (1))
     call sf_config(1)%init ([1], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with spectrum and structure function"
     write (u, "(A)")
 
     deallocate (sf_config)
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_spectrum)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_8"
 
   end subroutine sf_base_8
 
 @ %def sf_base_8
 @
 \subsubsection{Structure function instance configuration}
 We create a structure-function chain instance which implements a
 configured structure-function chain.  We link the momentum entries in
 the interactions and compute kinematics.
 
 We do not actually connect the interactions and create evaluators.  We
 skip this step and manually advance the status of the chain instead.
 <<SF base: execute tests>>=
   call test (sf_base_9, "sf_base_9", &
        "structure function chain instance", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_9
 <<SF base: tests>>=
   subroutine sf_base_9 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_spectrum
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     type(sf_channel_t), dimension(2) :: sf_channel
     type(vector4_t), dimension(2) :: p
     integer :: j
 
     write (u, "(A)")  "* Test output: sf_base_9"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain &
          &and create an instance"
     write (u, "(A)")  "*            compute kinematics"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_spectrum_data_t :: data_spectrum)
     select type (data_spectrum)
     type is (sf_test_spectrum_data_t)
        call data_spectrum%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(A)")  "* Set up chain with beams only"
     write (u, "(A)")
 
     call sf_chain%init (beam_data)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics (1, [real(default) ::])
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call sf_chain_instance%get_out_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Outgoing momenta:"
 
     do j = 1, 2
        write (u, "(A)")
        call vector4_write (p(j), u)
     end do
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with structure function"
     write (u, "(A)")
 
     allocate (sf_config (1))
     call sf_config(1)%init ([1], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(1)%init (1)
     call sf_channel(1)%activate_mapping ([1])
     call sf_chain_instance%set_channel (1, sf_channel(1))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics (1, [0.8_default])
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call sf_chain_instance%get_out_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Outgoing momenta:"
 
     do j = 1, 2
        write (u, "(A)")
        call vector4_write (p(j), u)
     end do
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with spectrum and structure function"
     write (u, "(A)")
 
     deallocate (sf_config)
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_spectrum)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics &
          (1, [0.5_default, 0.6_default, 0.8_default])
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call sf_chain_instance%get_out_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Outgoing momenta:"
 
     do j = 1, 2
        write (u, "(A)")
        call vector4_write (p(j), u)
     end do
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_9"
 
   end subroutine sf_base_9
 
 @ %def sf_base_9
 @
 \subsubsection{Structure function chain mappings}
 Set up a structure function chain instance with a pair of
 single-particle structure functions.  We test different global
 mappings for this setup.
 
 Again, we skip evaluators.
 <<SF base: execute tests>>=
  call test (sf_base_10, "sf_base_10", &
       "structure function chain mapping", &
       u, results)
 <<SF base: test declarations>>=
   public :: sf_base_10
 <<SF base: tests>>=
   subroutine sf_base_10 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     type(sf_channel_t), dimension(2) :: sf_channel
     real(default), dimension(2) :: x_saved
 
     write (u, "(A)")  "* Test output: sf_base_10"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")  "*            and check mappings"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Set up chain with structure function pair &
          &and standard mapping"
     write (u, "(A)")
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data_strfun)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(1)%init (2)
     call sf_channel(1)%set_s_mapping ([1,2])
     call sf_chain_instance%set_channel (1, sf_channel(1))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default])
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert the kinematics calculation"
     write (u, "(A)")
 
     x_saved = sf_chain_instance%x
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%set_s_mapping ([1, 2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_10"
 
   end subroutine sf_base_10
 
 @ %def sf_base_10
 @
 \subsubsection{Structure function chain evaluation}
 Here, we test the complete workflow for structure-function chains.
 First, we create the template chain, then initialize an instance.  We
 set up links, mask, and evaluators.  Finally, we set kinematics and
 evaluate the matrix elements and their products.
 <<SF base: execute tests>>=
   call test (sf_base_11, "sf_base_11", &
        "structure function chain evaluation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_11
 <<SF base: tests>>=
   subroutine sf_base_11 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_spectrum
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     type(sf_channel_t), dimension(2) :: sf_channel
     type(particle_set_t) :: pset
     type(interaction_t), pointer :: int
     logical :: ok
 
     write (u, "(A)")  "* Test output: sf_base_11"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")  "*            create an instance and evaluate"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_spectrum_data_t :: data_spectrum)
     select type (data_spectrum)
     type is (sf_test_spectrum_data_t)
        call data_spectrum%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(A)")  "* Set up chain with beams only"
     write (u, "(A)")
 
     call sf_chain%init (beam_data)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     call sf_chain_instance%compute_kinematics (1, [real(default) ::])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true.)
     call sf_chain_instance%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover chain:"
     write (u, "(A)")
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%fill_interaction (int, 2, check_match=.false.)
 
     call sf_chain_instance%recover_kinematics (1)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call pset%final ()
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with structure function"
     write (u, "(A)")
 
     allocate (sf_config (1))
     call sf_config(1)%init ([1], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(1)%init (1)
     call sf_channel(1)%activate_mapping ([1])
     call sf_chain_instance%set_channel (1, sf_channel(1))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     call sf_chain_instance%compute_kinematics (1, [0.8_default])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true.)
     call sf_chain_instance%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover chain:"
     write (u, "(A)")
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(1)%init (1)
     call sf_channel(1)%activate_mapping ([1])
     call sf_chain_instance%set_channel (1, sf_channel(1))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%fill_interaction (int, 2, check_match=.false.)
 
     call sf_chain_instance%recover_kinematics (1)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call pset%final ()
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with spectrum and structure function"
     write (u, "(A)")
 
     deallocate (sf_config)
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_spectrum)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     call sf_chain_instance%compute_kinematics &
          (1, [0.5_default, 0.6_default, 0.8_default])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true.)
     call sf_chain_instance%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover chain:"
     write (u, "(A)")
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%fill_interaction (int, 2, check_match=.false.)
 
     call sf_chain_instance%recover_kinematics (1)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call pset%final ()
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_11"
 
   end subroutine sf_base_11
 
 @ %def sf_base_11
 @
 \subsubsection{Multichannel case}
 We set up a structure-function chain as before, but with three
 different parameterizations.  The first instance is without mappings,
 the second one with single-particle mappings, and the third one with
 two-particle mappings.
 <<SF base: execute tests>>=
   call test (sf_base_12, "sf_base_12", &
        "multi-channel structure function chain", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_12
 <<SF base: tests>>=
   subroutine sf_base_12 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     real(default), dimension(2) :: x_saved
     real(default), dimension(2,3) :: p_saved
     type(sf_channel_t), dimension(:), allocatable :: sf_channel
 
     write (u, "(A)")  "* Test output: sf_base_12"
     write (u, "(A)")  "*   Purpose: set up and evaluate a multi-channel &
          &structure-function chain"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Set up chain with structure function pair &
          &and three different mappings"
     write (u, "(A)")
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 3)
 
     call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2)
 
     ! channel 1: no mapping
     call sf_chain_instance%set_channel (1, sf_channel(1))
 
     ! channel 2: single-particle mappings
     call sf_channel(2)%activate_mapping ([1,2])
     ! call sf_chain_instance%activate_mapping (2, [1,2])
     call sf_chain_instance%set_channel (2, sf_channel(2))
 
     ! channel 3: two-particle mapping
     call sf_channel(3)%set_s_mapping ([1,2])
     ! call sf_chain_instance%set_s_mapping (3, [1, 2])
     call sf_chain_instance%set_channel (3, sf_channel(3))
 
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     write (u, "(A)")  "* Compute kinematics in channel 1 and evaluate"
     write (u, "(A)")
 
     call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert the kinematics calculation"
     write (u, "(A)")
 
     x_saved = sf_chain_instance%x
 
     call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute kinematics in channel 2 and evaluate"
     write (u, "(A)")
 
     p_saved = sf_chain_instance%p
 
     call sf_chain_instance%compute_kinematics (2, p_saved(:,2))
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute kinematics in channel 3 and evaluate"
     write (u, "(A)")
 
     call sf_chain_instance%compute_kinematics (3, p_saved(:,3))
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_12"
 
   end subroutine sf_base_12
 
 @ %def sf_base_12
 @
 \subsubsection{Generated spectrum}
 Construct and evaluate a structure function object for a pair spectrum
 which is evaluated as a beam-event generator.
 <<SF base: execute tests>>=
   call test (sf_base_13, "sf_base_13", &
        "pair spectrum generator", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_13
 <<SF base: tests>>=
   subroutine sf_base_13 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_base_13"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &a pair generator object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     allocate (sf_test_generator_data_t :: data)
     select type (data)
     type is (sf_test_generator_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize generator object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     write (u, "(A)")  "* Generate free r values"
     write (u, "(A)")
 
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
 
     write (u, "(A)")  "* Initialize incoming momenta with sqrts=1000"
 
     E = 500
     k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Complete kinematics"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call reset_interaction_counter ()
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%seed_kinematics (k)
     call sf_int%set_momenta (q, outgoing=.true.)
     x_free = 1
     call sf_int%recover_x (x, xb, x_free)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics &
          &and evaluate"
     write (u, "(A)")
 
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_13"
 
   end subroutine sf_base_13
 
 @ %def sf_base_13
 @
 \subsubsection{Structure function chain evaluation}
 Here, we test the complete workflow for a structure-function chain
 with generator.  First, we create the template chain, then initialize
 an instance.  We set up links, mask, and evaluators.  Finally, we set
 kinematics and evaluate the matrix elements and their products.
 <<SF base: execute tests>>=
   call test (sf_base_14, "sf_base_14", &
        "structure function generator evaluation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_14
 <<SF base: tests>>=
   subroutine sf_base_14 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_generator
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     real(default), dimension(:), allocatable :: p_in
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
 
     write (u, "(A)")  "* Test output: sf_base_14"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")  "*            create an instance and evaluate"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_generator_data_t :: data_generator)
     select type (data_generator)
     type is (sf_test_generator_data_t)
        call data_generator%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Set up chain with generator and structure function"
     write (u, "(A)")
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_generator)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     write (u, "(A)")  "* Inject integration parameter"
     write (u, "(A)")
 
     allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default)
     write (u, "(A,9(1x,F10.7))")  "p_in =", p_in
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_chain_instance%compute_kinematics (1, p_in)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call sf_chain_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract integration parameter"
     write (u, "(A)")
 
     call sf_chain_instance%get_mcpar (1, p_in)
     write (u, "(A,9(1x,F10.7))")  "p_in =", p_in
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_14"
 
   end subroutine sf_base_14
 
 @ %def sf_base_14
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Photon radiation: ISR}
 
 <<[[sf_isr.f90]]>>=
 <<File header>>
 
 module sf_isr
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_15, FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: PHOTON
   use lorentz
   use sm_physics, only: Li2
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use quantum_numbers
   use polarizations
   use sf_aux
   use sf_mappings
   use sf_base
   use electron_pdfs
 
 <<Standard module head>>
 
 <<SF isr: public>>
 
 <<SF isr: parameters>>
 
 <<SF isr: types>>
 
 contains
 
 <<SF isr: procedures>>
 
 end module sf_isr
 @ %def sf_isr
 @
 \subsection{Physics}
 The ISR structure function is in the most crude approximation (LLA
 without $\alpha$ corrections, i.e. $\epsilon^0$)
 \begin{equation}
   f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad
   \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2},
 \end{equation}
 where $m$ is the mass of the incoming (and outgoing) particle, which
 is initially assumed on-shell.
 
 In $f_0(x)$, there is an integrable singularity at $x=1$ which does
 not spoil the integration, but would lead to an unbounded $f_{\rm
 max}$.  Therefore, we map this singularity like
 \begin{equation}\label{ISR-mapping}
   x = 1 - (1-x')^{1/\epsilon}
 \end{equation}
 such that
 \begin{equation}
   \int dx\,f_0(x) = \int dx'
 \end{equation}
 
 For the detailed form of the QED ISR structure function
 cf. Chap.~\ref{chap:qed_pdf}.
 
 \subsection{Implementation}
 
 In the concrete implementation, the zeroth order mapping
 (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to
 $f_i(x)/f_0(x)$.  This can be written as
 \begin{align}
   \frac{f_0(x)}{f_0(x)} &= 1 \\
   \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\
 \begin{split}\label{ISR-f2}
   \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon
     + \frac{27 - 8\pi^2}{96}\epsilon^2
     - \frac{1-x^2}{2(1-x')} \\
   &\quad - \frac{(1+3x^2)\ln x
     + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon
 \end{split}
 \end{align}
 %'
 For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to
 \begin{align}
   \frac{f_0(x)}{f_0(x)} &= 1 \\
   \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\
   \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon
     + \frac{27 - 8\pi^2}{96}\epsilon^2
 \end{align}
 The last line in (\ref{ISR-f2}) is zero for
 \begin{equation}
   x_{\rm min} = 0.00714053329734592839549879772019
 \end{equation}
 (Mathematica result), independent of $\epsilon$.  For $x$ values less
 than this we ignore this correction because of the logarithmic
 singularity which should in principle be resummed.
 
 
 \subsection{The ISR data block}
 <<SF isr: public>>=
   public :: isr_data_t
 <<SF isr: types>>=
   type, extends (sf_data_t) :: isr_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:), allocatable :: flv_in
      type(qed_pdf_t) :: pdf
      real(default) :: alpha = 0
      real(default) :: q_max = 0
      real(default) :: real_mass = 0
      real(default) :: mass = 0
      real(default) :: eps = 0
      real(default) :: log = 0
      logical :: recoil = .false.
      logical :: keep_energy = .true.
      integer :: order = 3
      integer :: error = NONE
    contains
    <<SF isr: isr data: TBP>>
   end type isr_data_t
 
 @ %def isr_data_t
 @ Error codes
 <<SF isr: parameters>>=
   integer, parameter :: NONE = 0
   integer, parameter :: ZERO_MASS = 1
   integer, parameter :: Q_MAX_TOO_SMALL = 2
   integer, parameter :: EPS_TOO_LARGE = 3
   integer, parameter :: INVALID_ORDER = 4
   integer, parameter :: CHARGE_MIX = 5
   integer, parameter :: CHARGE_ZERO = 6
   integer, parameter :: MASS_MIX = 7
 @ Generate flavor-dependent ISR data:
 <<SF isr: isr data: TBP>>=
   procedure :: init => isr_data_init
 <<SF isr: procedures>>=
   subroutine isr_data_init (data, model, pdg_in, alpha, q_max, &
        mass, order, recoil, keep_energy)
     class(isr_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     real(default), intent(in) :: alpha
     real(default), intent(in) :: q_max
     real(default), intent(in), optional :: mass
     integer, intent(in), optional :: order
     logical, intent(in), optional :: recoil
     logical, intent(in), optional :: keep_energy
     integer :: i, n_flv
     real(default) :: charge
     data%model => model
     n_flv = pdg_array_get_length (pdg_in)
     allocate (data%flv_in (n_flv))
     do i = 1, n_flv
        call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model)
     end do
     data%alpha = alpha
     data%q_max = q_max
     if (present (order)) then
        call data%set_order (order)
     end if
     if (present (recoil)) then
        data%recoil = recoil
     end if
     if (present (keep_energy)) then
        data%keep_energy = keep_energy
     end if
     data%real_mass = data%flv_in(1)%get_mass ()
     if (present (mass)) then
        if (mass > 0) then
           data%mass = mass
        else
           data%mass = data%real_mass
           if (any (data%flv_in%get_mass () /= data%mass)) then
              data%error = MASS_MIX;  return
           end if
        end if
     else
        data%mass = data%real_mass
        if (any (data%flv_in%get_mass () /= data%mass)) then
           data%error = MASS_MIX;  return
        end if
     end if
     if (vanishes (data%mass)) then
        data%error = ZERO_MASS;  return
     else if (data%mass >= data%q_max) then
        data%error = Q_MAX_TOO_SMALL;  return
     end if
     data%log = log (1 + (data%q_max / data%mass)**2)
     charge = data%flv_in(1)%get_charge ()
     if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then
        data%error = CHARGE_MIX;  return
     else if (charge == 0) then
        data%error = CHARGE_ZERO;  return
     end if
     data%eps = data%alpha / pi * charge ** 2 &
          * (2 * log (data%q_max / data%mass) - 1)
     if (data%eps > 1) then
        data%error = EPS_TOO_LARGE;  return
     end if
     call data%pdf%init &
          (data%mass, data%alpha, charge, data%q_max, data%order)
   end subroutine isr_data_init
 
 @ %def isr_data_init
 @ Explicitly set ISR order
 <<SF isr: isr data: TBP>>=
   procedure :: set_order => isr_data_set_order
 <<SF isr: procedures>>=
   elemental subroutine isr_data_set_order (data, order)
     class(isr_data_t), intent(inout) :: data
     integer, intent(in) :: order
     if (order < 0 .or. order > 3) then
        data%error = INVALID_ORDER
     else
        data%order = order
     end if
   end subroutine isr_data_set_order
 
 @ %def isr_data_set_order
 @ Handle error conditions.  Should always be done after
 initialization, unless we are sure everything is ok.
 <<SF isr: isr data: TBP>>=
   procedure :: check => isr_data_check
 <<SF isr: procedures>>=
   subroutine isr_data_check (data)
     class(isr_data_t), intent(in) :: data
     select case (data%error)
     case (ZERO_MASS)
        call msg_fatal ("ISR: Particle mass is zero")
     case (Q_MAX_TOO_SMALL)
        call msg_fatal ("ISR: Particle mass exceeds Qmax")
     case (EPS_TOO_LARGE)
        call msg_fatal ("ISR: Expansion parameter too large, " // &
             "perturbative expansion breaks down")
     case (INVALID_ORDER)
        call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)")
     case (MASS_MIX)
        call msg_fatal ("ISR: Incoming particle masses must be uniform")
     case (CHARGE_MIX)
        call msg_fatal ("ISR: Incoming particle charges must be uniform")
     case (CHARGE_ZERO)
        call msg_fatal ("ISR: Incoming particle must be charged")
     end select
   end subroutine isr_data_check
 
 @ %def isr_data_check
 @ Output
 <<SF isr: isr data: TBP>>=
   procedure :: write => isr_data_write
 <<SF isr: procedures>>=
   subroutine isr_data_write (data, unit, verbose)
     class(isr_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "ISR data:"
     if (allocated (data%flv_in)) then
        write (u, "(3x,A)", advance="no") "  flavor =  "
        do i = 1, size (data%flv_in)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_in(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A," // FMT_19 // ")") "  alpha    = ", data%alpha
        write (u, "(3x,A," // FMT_19 // ")") "  q_max    = ", data%q_max
        write (u, "(3x,A," // FMT_19 // ")") "  mass     = ", data%mass
        write (u, "(3x,A," // FMT_19 // ")") "  eps      = ", data%eps
        write (u, "(3x,A," // FMT_19 // ")") "  log      = ", data%log
        write (u, "(3x,A,I2)")      "  order    = ", data%order
        write (u, "(3x,A,L2)")      "  recoil   = ", data%recoil
        write (u, "(3x,A,L2)")      "  keep en. = ", data%keep_energy
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine isr_data_write
 
 @ %def isr_data_write
 @ For ISR, there is the option to generate transverse momentum is
 generated. Hence, there can be up to three parameters, $x$, and two
 angles.
 <<SF isr: isr data: TBP>>=
   procedure :: get_n_par => isr_data_get_n_par
 <<SF isr: procedures>>=
   function isr_data_get_n_par (data) result (n)
     class(isr_data_t), intent(in) :: data
     integer :: n
     if (data%recoil) then
        n = 3
     else
        n = 1
     end if
   end function isr_data_get_n_par
 
 @ %def isr_data_get_n_par
 @ Return the outgoing particles PDG codes.  For ISR, these are
 identical to the incoming particles.
 <<SF isr: isr data: TBP>>=
   procedure :: get_pdg_out => isr_data_get_pdg_out
 <<SF isr: procedures>>=
   subroutine isr_data_get_pdg_out (data, pdg_out)
     class(isr_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = data%flv_in%get_pdg ()
   end subroutine isr_data_get_pdg_out
 
 @ %def isr_data_get_pdg_out
 @ Return the [[eps]] value.  We need it for an appropriate mapping of
 structure-function parameters.
 <<SF isr: isr data: TBP>>=
   procedure :: get_eps => isr_data_get_eps
 <<SF isr: procedures>>=
   function isr_data_get_eps (data) result (eps)
     class(isr_data_t), intent(in) :: data
     real(default) :: eps
     eps = data%eps
   end function isr_data_get_eps
 
 @ %def isr_data_get_eps
 @ Allocate the interaction record.
 <<SF isr: isr data: TBP>>=
   procedure :: allocate_sf_int => isr_data_allocate_sf_int
 <<SF isr: procedures>>=
   subroutine isr_data_allocate_sf_int (data, sf_int)
     class(isr_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (isr_t :: sf_int)
   end subroutine isr_data_allocate_sf_int
 
 @ %def isr_data_allocate_sf_int
 @
 \subsection{The ISR object}
 The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for
 single-photon emission only (but use the multi-photon resummed
 radiator function).  The particles are ordered as (incoming, photon,
 outgoing).
 
 There is no need to handle several flavors (and data blocks) in
 parallel, since ISR is always applied immediately after beam
 collision.  (ISR for partons is accounted for by the PDFs themselves.)
 Polarization is carried through, i.e., we retain the polarization of
 the incoming particle and treat the emitted photon as unpolarized.
 Color is trivially carried through.  This implies that particles 1 and
 3 should be locked together. For ISR we don't need the q variable.
 <<SF isr: public>>=
   public :: isr_t
 <<SF isr: types>>=
   type, extends (sf_int_t) :: isr_t
      private
      type(isr_data_t), pointer :: data => null ()
      real(default) :: x = 0
      real(default) :: xb= 0
    contains
    <<SF isr: isr: TBP>>
   end type isr_t
 
 @ %def isr_t
 @ Type string: has to be here, but there is no string variable on which ISR
 depends. Hence, a dummy routine.
 <<SF isr: isr: TBP>>=
   procedure :: type_string => isr_type_string
 <<SF isr: procedures>>=
   function isr_type_string (object) result (string)
     class(isr_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "ISR: e+ e- ISR spectrum"
     else
        string = "ISR: [undefined]"
     end if
   end function isr_type_string
 
 @ %def isr_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF isr: isr: TBP>>=
   procedure :: write => isr_write
 <<SF isr: procedures>>=
   subroutine isr_write (object, unit, testflag)
     class(isr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_15 // ")")  "x =", object%x
           write (u, "(3x,A," // FMT_15 // ")")  "xb=", object%xb
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "ISR data: [undefined]"
     end if
   end subroutine isr_write
 
 @ %def isr_write
 @ Explicitly set ISR order (for unit test).
 <<SF isr: isr: TBP>>=
   procedure :: set_order => isr_set_order
 <<SF isr: procedures>>=
   subroutine isr_set_order (object, order)
     class(isr_t), intent(inout) :: object
     integer, intent(in) :: order
     call object%data%set_order (order)
     call object%data%pdf%set_order (order)
   end subroutine isr_set_order
 
 @ %def isr_set_order
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ were trivial. The ISR structure
 function allows for a straightforward mapping of the unit interval.
 So, to leading order, the structure function value is unity, but the
 $x$ value is transformed.  Higher orders affect the function value.
 
 The structure function implementation applies the above mapping to the
 input (random) number [[r]] to generate the momentum fraction [[x]]
 and the function value [[f]].  For numerical stability reasons, we
 also output [[xb]], which is $\bar x=1-x$.
 
 For the ISR structure function, the mapping Jacobian cancels the
 structure function (to order zero).  We apply the cancellation
 explicitly, therefore both the Jacobian [[f]] and the zeroth-order value
 (see the [[apply]] method) are unity if mapping is turned on.  If
 mapping is turned off, the Jacobian [[f]] includes the value of the
 (zeroth-order) structure function, and strongly peaked.
 <<SF isr: isr: TBP>>=
   procedure :: complete_kinematics => isr_complete_kinematics
 <<SF isr: procedures>>=
   subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(isr_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default) :: eps
     eps = sf_int%data%eps
     if (map) then
        call map_power_1 (sf_int%xb, f, rb(1), eps)
     else
        sf_int%xb = rb(1)
        if (rb(1) > 0) then
           f = 1
        else
           f = 0
        end if
     end if
     sf_int%x = 1 - sf_int%xb
     x(1) = sf_int%x
     xb(1) = sf_int%xb
     if (size (x) == 3) then
        x(2:3) = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        sf_int%xb= 0
        f = 0
     end select
   end subroutine isr_complete_kinematics
 
 @ %def isr_complete_kinematics
 @ Overriding the default method: we compute the [[x]] array from the
 momentum configuration.  In the specific case of ISR, we also set the
 internally stored $x$ and $\bar x$ values, so they can be used in the
 following routine.
 <<SF isr: isr: TBP>>=
   procedure :: recover_x => sf_isr_recover_x
 <<SF isr: procedures>>=
   subroutine sf_isr_recover_x (sf_int, x, xb, x_free)
     class(isr_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
     sf_int%xb = xb(1)
   end subroutine sf_isr_recover_x
 
 @ %def sf_isr_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 
 For extracting $x$, we rely on the stored $\bar x$ value, since the
 $x$ value in the argument is likely imprecise.  This means that either
 [[complete_kinematics]] or [[recover_x]] must be called first, for the
 current sampling point (but maybe another channel).
 <<SF isr: isr: TBP>>=
   procedure :: inverse_kinematics => isr_inverse_kinematics
 <<SF isr: procedures>>=
   subroutine isr_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(isr_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: eps
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     eps = sf_int%data%eps
     if (map) then
        call map_power_inverse_1 (xb(1), f, rb(1), eps)
     else
        rb(1) = xb(1)
        if (rb(1) > 0) then
           f = 1
        else
           f = 0
        end if
     end if
     r(1) = 1 - rb(1)
     if (size(r) == 3) then
        r(2:3) = x(2:3)
        rb(2:3)= xb(2:3)
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS)
           r = 0
           rb= 0
           f = 0
        end select
     end if
   end subroutine isr_inverse_kinematics
 
 @ %def isr_inverse_kinematics
 @
 <<SF isr: isr: TBP>>=
   procedure :: init => isr_init
 <<SF isr: procedures>>=
   subroutine isr_init (sf_int, data)
     class(isr_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     integer, dimension(3) :: hel_lock
     type(polarization_t), target :: pol
     type(quantum_numbers_t), dimension(1) :: qn_fc
     type(flavor_t) :: flv_photon
     type(color_t) :: col_photon
     type(quantum_numbers_t) :: qn_hel, qn_photon, qn
     type(polarization_iterator_t) :: it_hel
     real(default) :: m2
     integer :: i
     mask = quantum_numbers_mask (.false., .false., &
          mask_h = [.false., .true., .false.])
     hel_lock = [3, 0, 1]
     select type (data)
     type is (isr_data_t)
        m2 = data%mass**2
        call sf_int%base_init (mask, [m2], [0._default], [m2], &
             hel_lock = hel_lock)
        sf_int%data => data
        call flv_photon%init (PHOTON, data%model)
        call col_photon%init ()
        call qn_photon%init (flv_photon, col_photon)
        call qn_photon%tag_radiated ()
        do i = 1, size (data%flv_in)
           call pol%init_generic (data%flv_in(i))
           call qn_fc(1)%init (&
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i), 1))
           call it_hel%init (pol)
           do while (it_hel%is_valid ())
              qn_hel = it_hel%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc(1)
              call sf_int%add_state ([qn, qn_photon, qn])
              call it_hel%advance ()
           end do
           ! call pol%final ()  !!! Obsolete
        end do
        call sf_int%freeze ()
        if (data%keep_energy) then
           sf_int%on_shell_mode = KEEP_ENERGY
        else
           sf_int%on_shell_mode = KEEP_MOMENTUM
        end if
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
        sf_int%status = SF_INITIAL
     end select
   end subroutine isr_init
 
 @ %def isr_init
 @
 \subsection{ISR application}
 For ISR, we could in principle compute kinematics and function value
 in a single step. In order to be able to reweight matrix elements
 including structure functions we split kinematics and structure
 function calculation. The structure function works on a single beam,
 assuming that the input momentum has been set.
 
 For the structure-function evaluation, we rely on the fact that the
 power mapping, which we apply in the kinematics method (if the [[map]]
 flag is set), has a Jacobian which is just the inverse lowest-order
 structure function.  With mapping active, the two should cancel
 exactly.
 
 After splitting momenta, we set the outgoing momenta on-shell.  We
 choose to conserve momentum, so energy conservation may be violated.
 <<SF isr: isr: TBP>>=
   procedure :: apply => isr_apply
 <<SF isr: procedures>>=
   subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(isr_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f, finv, x, xb, eps, rb
     real(default) :: log_x, log_xb, x_2
     associate (data => sf_int%data)
       eps = sf_int%data%eps
       x = sf_int%x
       xb = sf_int%xb
       call map_power_inverse_1 (xb, finv, rb, eps)
       if (finv > 0) then
          f = 1 / finv
       else
          f = 0
       end if
       call data%pdf%evolve_qed_pdf (x, xb, rb, f)
     end associate
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine isr_apply
 
 @ %def isr_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_isr_ut.f90]]>>=
 <<File header>>
 
 module sf_isr_ut
   use unit_tests
   use sf_isr_uti
 
 <<Standard module head>>
 
 <<SF isr: public test>>
 
 contains
 
 <<SF isr: test driver>>
 
 end module sf_isr_ut
 @ %def sf_isr_ut
 @
 <<[[sf_isr_uti.f90]]>>=
 <<File header>>
 
 module sf_isr_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_12
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use interactions, only: interaction_pacify_momenta
   use model_data
   use sf_aux, only: KEEP_ENERGY
   use sf_mappings
   use sf_base
 
   use sf_isr
 
 <<Standard module head>>
 
 <<SF isr: test declarations>>
 
 contains
 
 <<SF isr: tests>>
 
 end module sf_isr_uti
 @ %def sf_isr_ut
 @ API: driver for the unit tests below.
 <<SF isr: public test>>=
   public :: sf_isr_test
 <<SF isr: test driver>>=
   subroutine sf_isr_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF isr: execute tests>>
   end subroutine sf_isr_test
 
 @ %def sf_isr_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF isr: execute tests>>=
   call test (sf_isr_1, "sf_isr_1", &
        "structure function configuration", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_1
 <<SF isr: tests>>=
   subroutine sf_isr_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_isr_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in = ELECTRON
 
     allocate (isr_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 10._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_1"
 
   end subroutine sf_isr_1
 
 @ %def sf_isr_1
 @
 \subsubsection{Structure function without mapping}
 Direct ISR evaluation.  This is the use case for a double-beam
 structure function.  The parameter pair is mapped in the calling program.
 <<SF isr: execute tests>>=
   call test (sf_isr_2, "sf_isr_2", &
        "no ISR mapping", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_2
 <<SF isr: tests>>=
   subroutine sf_isr_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, f_isr
 
     write (u, "(A)")  "* Test output: sf_isr_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in = ELECTRON
     call flv%init (ELECTRON, model)
 
     call reset_interaction_counter ()
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.9, no ISR mapping, &
          &collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.9_default
     rb = 1 - r
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A)")
     write (u, "(A,9(1x," // FMT_12 // "))")  "x =", x
     write (u, "(A,9(1x," // FMT_12 // "))")  "xb=", xb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert kinematics"
     write (u, "(A)")
 
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value, default order"
     write (u, "(A)")
 
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-evaluate structure function, leading order"
     write (u, "(A)")
 
     select type (sf_int)
     type is (isr_t)
        call sf_int%set_order (0)
     end select
     call sf_int%apply (scale = 100._default)
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_2"
 
   end subroutine sf_isr_2
 
 @ %def sf_isr_2
 @
 \subsubsection{Structure function with mapping}
 Apply the optimal ISR mapping.  This is the use case for a single-beam
 structure function.
 <<SF isr: execute tests>>=
   call test (sf_isr_3, "sf_isr_3", &
        "ISR mapping", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_3
 <<SF isr: tests>>=
   subroutine sf_isr_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, f_isr
 
     write (u, "(A)")  "* Test output: sf_isr_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.7, with ISR mapping, &
          &collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.7_default
     rb = 1 - r
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A)")
     write (u, "(A,9(1x," // FMT_12 // "))")  "x =", x
     write (u, "(A,9(1x," // FMT_12 // "))")  "xb=", xb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert kinematics"
     write (u, "(A)")
 
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value, default order"
     write (u, "(A)")
 
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-evaluate structure function, leading order"
     write (u, "(A)")
 
     select type (sf_int)
     type is (isr_t)
        call sf_int%set_order (0)
     end select
     call sf_int%apply (scale = 100._default)
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_3"
 
   end subroutine sf_isr_3
 
 @ %def sf_isr_3
 @
 \subsubsection{Non-collinear ISR splitting}
 Construct and display a structure function object based on the ISR
 structure function. We blank out numerical fluctuations for 32bit.
 <<SF isr: execute tests>>=
   call test (sf_isr_4, "sf_isr_4", &
        "ISR non-collinear", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_4
 <<SF isr: tests>>=
   subroutine sf_isr_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, f_isr
     character(len=80) :: buffer
     integer :: u_scratch, iostat
 
     write (u, "(A)")  "* Test output: sf_isr_4"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .true.)
     end select
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, "
     write (u, "(A)")  "          non-coll., keeping energy"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.5_default, 0.5_default, 0.25_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
     call sf_int%apply (scale = 10._default)
     u_scratch = free_unit ()
     open (u_scratch, status="scratch", action = "readwrite")
     call sf_int%write (u_scratch, testflag = .true.)
     rewind (u_scratch)
     do
        read (u_scratch, "(A)", iostat=iostat) buffer
        if (iostat /= 0) exit
        if (buffer(1:25) == " P =   0.000000E+00  9.57") then
           buffer = replace (buffer, 26, "XXXX")
        end if
        if (buffer(1:25) == " P =   0.000000E+00 -9.57") then
           buffer = replace (buffer, 26, "XXXX")
        end if
        write (u, "(A)") buffer
     end do
     close (u_scratch)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value"
     write (u, "(A)")
 
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_4"
 
   end subroutine sf_isr_4
 
 @ %def sf_isr_4
 @
 \subsubsection{Structure function pair with mapping}
 Apply the ISR mapping for a ISR pair.
 structure function.
 <<SF isr: execute tests>>=
   call test (sf_isr_5, "sf_isr_5", &
        "ISR pair mapping", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_5
 <<SF isr: tests>>=
   subroutine sf_isr_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_mapping_t), allocatable :: mapping
     class(sf_int_t), dimension(:), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     real(default) :: E, f_map
     real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb
     real(default), dimension(2) :: f, f_isr
     integer :: i
 
     write (u, "(A)")  "* Test output: sf_isr_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     allocate (sf_ip_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ip_mapping_t)
        select type (data)
        type is (isr_data_t)
           call mapping%init (eps = data%get_eps ())
        end select
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     allocate (isr_t :: sf_int (2))
 
     do i = 1, 2
        call sf_int(i)%init (data)
        call sf_int(i)%set_beam_index ([i])
     end do
 
     write (u, "(A)")  "* Initialize incoming momenta with E=500"
     write (u, "(A)")
     E = 500
     k(1) = vector4_moving (E,   sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     do i = 1, 2
        call vector4_write (k(i), u)
        call sf_int(i)%seed_kinematics (k(i:i))
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for p=[0.7,0.4], collinear"
     write (u, "(A)")
 
     allocate (p (2 * data%get_n_par ()))
     allocate (pb(size (p)))
     allocate (r (size (p)))
     allocate (rb(size (p)))
     allocate (x (size (p)))
     allocate (xb(size (p)))
 
     p = [0.7_default, 0.4_default]
     pb= 1 - p
     call mapping%compute (r, rb, f_map, p, pb)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "p =", p
     write (u, "(A,9(1x," // FMT_12 // "))")  "pb=", pb
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "fm=", f_map
 
     do i = 1, 2
        call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), &
             map=.false.)
     end do
 
     write (u, "(A)")
     write (u, "(A,9(1x," // FMT_12 // "))")  "x =", x
     write (u, "(A,9(1x," // FMT_12 // "))")  "xb=", xb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert kinematics"
     write (u, "(A)")
 
     do i = 1, 2
        call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), &
             map=.false.)
     end do
     call mapping%inverse (r, rb, f_map, p, pb)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "p =", p
     write (u, "(A,9(1x," // FMT_12 // "))")  "pb=", pb
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "fm=", f_map
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
 
     call sf_int(1)%apply (scale = 100._default)
     call sf_int(2)%apply (scale = 100._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function #1"
     write (u, "(A)")
     call sf_int(1)%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function #2"
     write (u, "(A)")
     call sf_int(2)%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value, default order"
     write (u, "(A)")
 
     do i = 1, 2
        f_isr(i) = sf_int(i)%get_matrix_element (1)
     end do
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", &
          product (f_isr)
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", &
          product (f_isr * f) * f_map
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     do i = 1, 2
        call sf_int(i)%final ()
     end do
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_5"
 
   end subroutine sf_isr_5
 
 @ %def sf_isr_5
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{EPA}
 
 <<[[sf_epa.f90]]>>=
 <<File header>>
 
 module sf_epa
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_17, FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: PHOTON
   use lorentz
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use interactions
   use sf_aux
   use sf_base
 
 <<Standard module head>>
 
 <<SF epa: public>>
 
 <<SF epa: parameters>>
 
 <<SF epa: types>>
 
 contains
 
 <<SF epa: procedures>>
 
 end module sf_epa
 @ %def sf_epa
 @
 \subsection{Physics}
 The EPA structure function for a photon inside an (elementary)
 particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g.,
 electron) is given by ($\bar x \equiv 1-x$)
 
 There are several variants of the EPA, which are steered by the
 [[\$epa\_mode]] switch. The formula (6.17b) from the report by Budnev
 et al. is given by
 %% %\cite{Budnev:1974de}
 %% \bibitem{Budnev:1974de}
 %%   V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo,
 %%   %``The Two photon particle production mechanism. Physical problems.
 %%   %Applications. Equivalent photon approximation,''
 %%   Phys.\ Rept.\  {\bf 15} (1974) 181.
 %%   %%CITATION = PRPLC,15,181;%%
 \begin{multline}
 \label{EPA_617}
   f(x) =
   \frac{\alpha}{\pi}\,q_p^2\,
   \frac{1}{x}\,
   \biggl[\left(\bar x + \frac{x^2}{2}\right)
         \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}}
         \\
   - \left(1 - \frac{x}{2}\right)^2
     \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}}
                   {x^2+\frac{Q^2_{\rm min}}{E^2}}
         - x^2\frac{m^2}{Q^2_{\rm min}}
           \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right)
   \biggr].
 \end{multline}
 If no explicit $Q$ bounds are provided, the kinematical bounds are
 \begin{align}
   -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2,
 \\
   -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2
   \approx
   -\frac{x^2}{\bar x}m^2.
 \end{align}
 
 The second and third terms in (\ref{EPA_617}) are negative definite (and
 subleading).  Noting that $\bar x + x^2/2$ is bounded between
 $1/2$ and $1$, we derive that $f(x)$ is always smaller than
 \begin{equation}
   \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x}
   \qquad\text{where}\qquad
   L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)},
 \end{equation}
 where we allow for explicit $Q$ bounds that narrow the kinematical range.
 Therefore, we generate this distribution:
 \begin{equation}\label{EPA-subst}
   \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx'
 \end{equation}
 We set
 \begin{equation}\label{EPA-x(x')}
   \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1)
   + \bar x'\ln x_0(L-\ln x_0) \right]} \right\}
 \end{equation}
 such that $x(0)=x_0$ and $x(1)=x_1$ and
 \begin{equation}
   \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1}
   x\frac{C(x_0,x_1)}{L - 2\ln x}
 \end{equation}
 with
 \begin{equation}
   C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln
   x_0(L-\ln x_0)\right]
 \end{equation}
 such that (\ref{EPA-subst}) is satisfied.  Finally, we have
 \begin{equation}
   \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\,
   \frac{f(x(x'))}{\bar f(x(x'))}
 \end{equation}
 where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}).
 
 The structure of the mapping is most obvious from:
 \begin{equation}
   x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)}
   {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; .
 \end{equation}
 
 Taking the Eq. (6.16e) from the Budnev et al. report, and integrating
 it over $q^2$ yields the modified result
 \begin{equation}
 \label{EPA_616e}
   f(x) =
   \frac{\alpha}{\pi}\,q_p^2\,
   \frac{1}{x}\,
   \biggl[\left(\bar x + \frac{x^2}{2}\right)
         \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}}
         - x^2\frac{m^2}{Q^2_{\rm min}}
           \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right)
   \biggr].
 \end{equation}
 This is closer to many standard papers from LEP times, and to textbook
 formulae like e.g. in Peskin/Schroeder. For historical reasons, we
 keep Eq.~(\ref{EPA_617}) as the default in \whizard.
 
 
 \subsection{The EPA data block}
 The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and
 $x_{\rm min}$.  Instead of $m$ we can use the incoming particle PDG
 code as input; from this we can deduce the mass and charge.
 
 Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln
 x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming
 particle mass.
 <<SF epa: public>>=
   public :: EPA_MODE_DEFAULT
   public :: EPA_MODE_BUDNEV_617
   public :: EPA_MODE_BUDNEV_616E
   public :: EPA_MODE_LOG_POWER
   public :: EPA_MODE_LOG_SIMPLE
   public :: EPA_MODE_LOG
 <<SF epa: parameters>>=
   integer, parameter :: EPA_MODE_DEFAULT = 0
   integer, parameter :: EPA_MODE_BUDNEV_617 = 0
   integer, parameter :: EPA_MODE_BUDNEV_616E = 1
   integer, parameter :: EPA_MODE_LOG_POWER = 2
   integer, parameter :: EPA_MODE_LOG_SIMPLE = 3
   integer, parameter :: EPA_MODE_LOG = 4
 
 @ %def EPA_MODE_DEFAULT EPA_MODE_BUDNEV_617 EPA_MODE_BUDNEV_616E
 @ %def EPA_MODE_LOG_POWER EPA_MODE_LOG_SIMPLE EPA_MODE_LOG
 @ 
 <<SF epa: public>>=
   public :: epa_data_t
 <<SF epa: types>>=
   type, extends(sf_data_t) :: epa_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:), allocatable :: flv_in
      real(default) :: alpha
      real(default) :: x_min
      real(default) :: x_max
      real(default) :: q_min
      real(default) :: q_max
      real(default) :: E_max
      real(default) :: mass
      real(default) :: log
      real(default) :: a
      real(default) :: c0
      real(default) :: c1
      real(default) :: dc
      integer :: mode = EPA_MODE_DEFAULT
      integer :: error = NONE
      logical :: recoil = .false.
      logical :: keep_energy = .true.
    contains
    <<SF epa: epa data: TBP>>
   end type epa_data_t
 
 @ %def epa_data_t
 @ Error codes
 <<SF epa: parameters>>=
   integer, parameter :: NONE = 0
   integer, parameter :: ZERO_QMIN = 1
   integer, parameter :: Q_MAX_TOO_SMALL = 2
   integer, parameter :: ZERO_XMIN = 3
   integer, parameter :: MASS_MIX = 4
   integer, parameter :: NO_EPA = 5
 <<SF epa: epa data: TBP>>=
   procedure :: init => epa_data_init
 <<SF epa: procedures>>=
   subroutine epa_data_init (data, model, mode, pdg_in, alpha, &
        x_min, q_min, q_max, mass, recoil, keep_energy)
     class(epa_data_t), intent(inout) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     integer, intent(in) :: mode
     real(default), intent(in) :: alpha, x_min, q_min, q_max
     real(default), intent(in), optional :: mass
     logical, intent(in), optional :: recoil
     logical, intent(in), optional :: keep_energy
     integer :: n_flv, i
     data%model => model
     data%mode = mode
     n_flv = pdg_array_get_length (pdg_in)
     allocate (data%flv_in (n_flv))
     do i = 1, n_flv
        call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model)
     end do
     data%alpha = alpha
     data%E_max = q_max / 2
     data%x_min = x_min
     data%x_max = 1
     if (vanishes (data%x_min)) then
        data%error = ZERO_XMIN;  return
     end if
     data%q_min = q_min
     data%q_max = q_max
     select case (char (data%model%get_name ()))
     case ("QCD","Test")
        data%error = NO_EPA;  return
     end select
     if (present (recoil)) then
        data%recoil = recoil
     end if
     if (present (keep_energy)) then
        data%keep_energy = keep_energy
     end if
     if (present (mass)) then
        data%mass = mass
     else
        data%mass = data%flv_in(1)%get_mass ()
        if (any (data%flv_in%get_mass () /= data%mass)) then
           data%error = MASS_MIX;  return
        end if
     end if
     if (max (data%mass, data%q_min) == 0) then
        data%error = ZERO_QMIN;  return
     else if (max (data%mass, data%q_min) >= data%E_max) then
        data%error = Q_MAX_TOO_SMALL;  return
     end if
     data%log = log ((data%q_max / max (data%mass, data%q_min)) ** 2 )
     data%a  = data%alpha / pi
     data%c0 = log (data%x_min) * (data%log - log (data%x_min))
     data%c1 = log (data%x_max) * (data%log - log (data%x_max))
     data%dc = data%c1 - data%c0
   end subroutine epa_data_init
 
 @ %def epa_data_init
 @ Handle error conditions.  Should always be done after
 initialization, unless we are sure everything is ok.
 <<SF epa: epa data: TBP>>=
   procedure :: check => epa_data_check
 <<SF epa: procedures>>=
   subroutine epa_data_check (data)
     class(epa_data_t), intent(in) :: data
     select case (data%error)
     case (NO_EPA)
        call msg_fatal ("EPA structure function not available for model " &
             // char (data%model%get_name ()) // ".")
     case (ZERO_QMIN)
        call msg_fatal ("EPA: Particle mass is zero")
     case (Q_MAX_TOO_SMALL)
        call msg_fatal ("EPA: Particle mass exceeds Qmax")
     case (ZERO_XMIN)
        call msg_fatal ("EPA: x_min must be larger than zero")
     case (MASS_MIX)
        call msg_fatal ("EPA: incoming particle masses must be uniform")
     end select
   end subroutine epa_data_check
 
 @ %def epa_data_check
 @ Output
 <<SF epa: epa data: TBP>>=
   procedure :: write => epa_data_write
 <<SF epa: procedures>>=
   subroutine epa_data_write (data, unit, verbose)
     class(epa_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "EPA data:"
     if (allocated (data%flv_in)) then
        write (u, "(3x,A)", advance="no") "  flavor =  "
        do i = 1, size (data%flv_in)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_in(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A," // FMT_19 // ")") "  alpha    = ", data%alpha
        write (u, "(3x,A," // FMT_19 // ")") "  x_min    = ", data%x_min
        write (u, "(3x,A," // FMT_19 // ")") "  x_max    = ", data%x_max
        write (u, "(3x,A," // FMT_19 // ")") "  q_min    = ", data%q_min
        write (u, "(3x,A," // FMT_19 // ")") "  q_max    = ", data%q_max
        write (u, "(3x,A," // FMT_19 // ")") "  E_max    = ", data%e_max
        write (u, "(3x,A," // FMT_19 // ")") "  mass     = ", data%mass
        write (u, "(3x,A," // FMT_19 // ")") "  a        = ", data%a
        write (u, "(3x,A," // FMT_19 // ")") "  c0       = ", data%c0
        write (u, "(3x,A," // FMT_19 // ")") "  c1       = ", data%c1
        write (u, "(3x,A," // FMT_19 // ")") "  log      = ", data%log
        write (u, "(3x,A,L2)")      "  recoil   = ", data%recoil
        write (u, "(3x,A,L2)")      "  keep en. = ", data%keep_energy
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine epa_data_write
 
 @ %def epa_data_write
 @ The number of kinematic parameters.
 <<SF epa: epa data: TBP>>=
   procedure :: get_n_par => epa_data_get_n_par
 <<SF epa: procedures>>=
   function epa_data_get_n_par (data) result (n)
     class(epa_data_t), intent(in) :: data
     integer :: n
     if (data%recoil) then
        n = 3
     else
        n = 1
     end if
   end function epa_data_get_n_par
 
 @ %def epa_data_get_n_par
 @ Return the outgoing particles PDG codes. The outgoing particle is always
 the photon while the radiated particle is identical to the incoming one.
 <<SF epa: epa data: TBP>>=
   procedure :: get_pdg_out => epa_data_get_pdg_out
 <<SF epa: procedures>>=
   subroutine epa_data_get_pdg_out (data, pdg_out)
     class(epa_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = PHOTON
   end subroutine epa_data_get_pdg_out
 
 @ %def epa_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF epa: epa data: TBP>>=
   procedure :: allocate_sf_int => epa_data_allocate_sf_int
 <<SF epa: procedures>>=
   subroutine epa_data_allocate_sf_int (data, sf_int)
     class(epa_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (epa_t :: sf_int)
   end subroutine epa_data_allocate_sf_int
 
 @ %def epa_data_allocate_sf_int
 @
 \subsection{The EPA object}
 The [[epa_t]] data type is a $1\to 2$ interaction.  We should be able
 to handle several flavors in parallel, since EPA is not necessarily
 applied immediately after beam collision:  Photons may be radiated
 from quarks.  In that case, the partons are massless and $q_{\rm min}$
 applies instead, so we do not need to generate several kinematical
 configurations in parallel.
 
 The squared charge values multiply the matrix elements, depending on the
 flavour.  We scan the interaction after building it, so we have the correct
 assignments.
 
 The particles are ordered as (incoming, radiated, photon), where the
 photon initiates the hard interaction.
 
 We generate an unpolarized photon and transfer initial polarization to
 the radiated parton.  Color is transferred in the same way.
 <<SF epa: types>>=
   type, extends (sf_int_t) :: epa_t
      type(epa_data_t), pointer :: data => null ()
      real(default) :: x  = 0
      real(default) :: xb = 0
      real(default) :: E  = 0
      real(default), dimension(:), allocatable :: charge2
    contains
    <<SF epa: epa: TBP>>
   end type epa_t
 
 @ %def epa_t
 @ Type string: has to be here, but there is no string variable on which EPA
 depends. Hence, a dummy routine.
 <<SF epa: epa: TBP>>=
   procedure :: type_string => epa_type_string
 <<SF epa: procedures>>=
   function epa_type_string (object) result (string)
     class(epa_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "EPA: equivalent photon approx."
     else
        string = "EPA: [undefined]"
     end if
   end function epa_type_string
 
 @ %def epa_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF epa: epa: TBP>>=
   procedure :: write => epa_write
 <<SF epa: procedures>>=
   subroutine epa_write (object, unit, testflag)
     class(epa_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A," // FMT_17 // ")")  "E =", object%E
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "EPA data: [undefined]"
     end if
   end subroutine epa_write
 
 @ %def epa_write
 @ Prepare the interaction object.  We have to construct transition matrix
 elements for all flavor and helicity combinations.
 <<SF epa: epa: TBP>>=
   procedure :: init => epa_init
 <<SF epa: procedures>>=
   subroutine epa_init (sf_int, data)
     class(epa_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     integer, dimension(3) :: hel_lock
     type(polarization_t), target :: pol
     type(quantum_numbers_t), dimension(1) :: qn_fc
     type(flavor_t) :: flv_photon
     type(color_t) :: col_photon
     type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad
     type(polarization_iterator_t) :: it_hel
     integer :: i
     mask = quantum_numbers_mask (.false., .false., &
          mask_h = [.false., .false., .true.])
     hel_lock = [2, 1, 0]
     select type (data)
     type is (epa_data_t)
        call sf_int%base_init (mask, [data%mass**2], &
             [data%mass**2], [0._default], hel_lock = hel_lock)
        sf_int%data => data
        call flv_photon%init (PHOTON, data%model)
        call col_photon%init ()
        call qn_photon%init (flv_photon, col_photon)
        do i = 1, size (data%flv_in)
           call pol%init_generic (data%flv_in(i))
           call qn_fc(1)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i), 1))
           call it_hel%init (pol)
           do while (it_hel%is_valid ())
              qn_hel = it_hel%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc(1)
              qn_rad = qn
              call qn_rad%tag_radiated ()
              call sf_int%add_state ([qn, qn_rad, qn_photon])
              call it_hel%advance ()
           end do
           !  call pol%final ()
        end do
        call sf_int%freeze ()
        if (data%keep_energy) then
           sf_int%on_shell_mode = KEEP_ENERGY
        else
           sf_int%on_shell_mode = KEEP_MOMENTUM
        end if
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
     end select
   end subroutine epa_init
 
 @ %def epa_init
 @ Prepare the charge array.  This is separate from the previous routine since
 the state matrix may be helicity-contracted.
 <<SF epa: epa: TBP>>=
   procedure :: setup_constants => epa_setup_constants
 <<SF epa: procedures>>=
   subroutine epa_setup_constants (sf_int)
     class(epa_t), intent(inout), target :: sf_int
     type(state_iterator_t) :: it
     type(flavor_t) :: flv
     integer :: i, n_me
     n_me = sf_int%get_n_matrix_elements ()
     allocate (sf_int%charge2 (n_me))
     call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
     do while (it%is_valid ())
        i = it%get_me_index ()
        flv = it%get_flavor (1)
        sf_int%charge2(i) = flv%get_charge () ** 2
        call it%advance ()
     end do
     sf_int%status = SF_INITIAL
   end subroutine epa_setup_constants
 
 @ %def epa_setup_constants
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 The EPA structure function allows for a straightforward mapping of the
 unit interval. The $x$ value is transformed, and the mapped structure
 function becomes unity at its upper boundary.
 
 The structure function implementation applies the above mapping to the
 input (random) number [[r]] to generate the momentum fraction [[x]]
 and the function value [[f]].  For numerical stability reasons, we
 also output [[xb]], which is $\bar x=1-x$.
 <<SF epa: epa: TBP>>=
   procedure :: complete_kinematics => epa_complete_kinematics
 <<SF epa: procedures>>=
   subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(epa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default) :: delta, sqrt_delta, lx
     if (map) then
        associate (data => sf_int%data)
          delta = data%log ** 2 -  4 * (r(1) * data%c1 + rb(1) * data%c0)
          if (delta > 0) then
             sqrt_delta = sqrt (delta)
             lx = (data%log - sqrt_delta) / 2
          else
             sf_int%status = SF_FAILED_KINEMATICS
             f = 0
             return
          end if
          x(1) = exp (lx)
          f = x(1) * data%dc / sqrt_delta
        end associate
     else
        x(1) = r(1)
        if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then
           f = 1
        else
           sf_int%status = SF_FAILED_KINEMATICS
           f = 0
           return
        end if
     end if
     xb(1) = 1 - x(1)
     if (size(x) == 3) then
        x(2:3) = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x = x(1)
        sf_int%xb= xb(1)
        sf_int%E  = energy (sf_int%get_momentum (1))
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        sf_int%xb= 0
        f = 0
     end select
   end subroutine epa_complete_kinematics
 
 @ %def epa_complete_kinematics
 @ Overriding the default method: we compute the [[x]] array from the
 momentum configuration.  In the specific case of EPA, we also set the
 internally stored $x$ and $\bar x$ values, so they can be used in the
 following routine.
 
 Note: the extraction of $\bar x$ is not numerically safe, but it cannot
 be as long as the base [[recover_x]] is not.
 <<SF epa: epa: TBP>>=
   procedure :: recover_x => sf_epa_recover_x
 <<SF epa: procedures>>=
   subroutine sf_epa_recover_x (sf_int, x, xb, x_free)
     class(epa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
     sf_int%xb = xb(1)
   end subroutine sf_epa_recover_x
 
 @ %def sf_epa_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF epa: epa: TBP>>=
   procedure :: inverse_kinematics => epa_inverse_kinematics
 <<SF epa: procedures>>=
   subroutine epa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(epa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: lx, delta, sqrt_delta, c
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        associate (data => sf_int%data)
          lx = log (x(1))
          sqrt_delta = data%log - 2 * lx
          delta = sqrt_delta ** 2
          c = (data%log ** 2 - delta) / 4
          r (1) = (c - data%c0) / data%dc
          rb(1) = (data%c1 - c) / data%dc
          f = x(1) * data%dc / sqrt_delta
        end associate
     else
        r (1) = x(1)
        rb(1) = xb(1)
        if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then
           f = 1
        else
           f = 0
        end if
     end if
     if (size(r) == 3) then
        r (2:3) = x(2:3)
        rb(2:3) = xb(2:3)
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
     sf_int%E  = energy (sf_int%get_momentum (1))
   end subroutine epa_inverse_kinematics
 
 @ %def epa_inverse_kinematics
 @
 \subsection{EPA application}
 For EPA, we can in principle compute kinematics and function value in
 a single step. In order to be able to reweight events, kinematics and
 structure function application are separated. This function works on a
 single beam, assuming that the input momentum has been set.  We need
 three random numbers as input: one for $x$, and two for the polar and
 azimuthal angles. Alternatively, for the no-recoil case, we can skip
 $p_T$ generation; in this case, we only need one.
 
 For obtaining splitting kinematics, we rely on the assumption that all
 in-particles are mass-degenerate (or there is only one), so the
 generated $x$ values are identical.
 
 Fix 2020-03-10: Divide by two if there is polarization.
 In the polarized case, the outgoing electron/positron
 retains the incoming polarization.  The latter is summed over
 when convoluting with the beam, but there are still two
 states with different outgoing polarization but identical
 structure-function value.  This leads to double-counting for the
 overall cross section.
 <<SF epa: epa: TBP>>=
   procedure :: apply => epa_apply
 <<SF epa: procedures>>=
   subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(epa_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: x, xb, qminsq, qmaxsq, f, E, m2
     associate (data => sf_int%data)
       x = sf_int%x
       xb= sf_int%xb
       E = sf_int%E
       m2 = data%mass ** 2
       qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2)
       select case (data%mode)
       case (0)
          qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2)
          if (qminsq < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) &
                  - (1 - x / 2) ** 2 &
                  * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) &
                  - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
          else
             f = 0
          end if
       case (1)
          qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2)
          if (qminsq < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) &
                  - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
          else
             f = 0
          end if
       case (2)
          qmaxsq = data%q_max ** 2
          if (data%mass ** 2 < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / m2) &
                  - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
          else
             f = 0
          end if
       case (3)
          qmaxsq = data%q_max ** 2
          if (data%mass ** 2 < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / m2) &
                  - x ** 2 * (1 - m2 / qmaxsq))
          else
             f = 0
          end if
       case (4)
          qmaxsq = data%q_max ** 2
          if (data%mass ** 2 < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / m2))
          else
             f = 0
          end if
       end select
       f = f / sf_int%get_n_matrix_elements ()
       call sf_int%set_matrix_element &
            (cmplx (f, kind=default) * sf_int%charge2)
     end associate
     sf_int%status = SF_EVALUATED
   end subroutine epa_apply
 
 @ %def epa_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_epa_ut.f90]]>>=
 <<File header>>
 
 module sf_epa_ut
   use unit_tests
   use sf_epa_uti
 
 <<Standard module head>>
 
 <<SF epa: public test>>
 
 contains
 
 <<SF epa: test driver>>
 
 end module sf_epa_ut
 @ %def sf_epa_ut
 @
 <<[[sf_epa_uti.f90]]>>=
 <<File header>>
 
 module sf_epa_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use interactions, only: interaction_pacify_momenta
   use model_data
   use sf_aux
   use sf_base
 
   use sf_epa
 
 <<Standard module head>>
 
 <<SF epa: test declarations>>
 
 contains
 
 <<SF epa: tests>>
 
 end module sf_epa_uti
 @ %def sf_epa_ut
 @ API: driver for the unit tests below.
 <<SF epa: public test>>=
   public :: sf_epa_test
 <<SF epa: test driver>>=
   subroutine sf_epa_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF epa: execute tests>>
   end subroutine sf_epa_test
 
 @ %def sf_epa_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF epa: execute tests>>=
   call test (sf_epa_1, "sf_epa_1", &
        "structure function configuration", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_1
 <<SF epa: tests>>=
   subroutine sf_epa_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_epa_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in = ELECTRON
 
     allocate (epa_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_1"
 
   end subroutine sf_epa_1
 
 @ %def sf_epa_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the EPA
 structure function.
 <<SF epa: execute tests>>=
   call test (sf_epa_2, "sf_epa_2", &
        "structure function instance", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_2
 <<SF epa: tests>>=
   subroutine sf_epa_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EPA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_2"
 
   end subroutine sf_epa_2
 
 @ %def sf_epa_2
 @
 \subsubsection{Standard mapping}
 Construct and display a structure function object based on the EPA
 structure function, applying the standard single-particle mapping.
 <<SF epa: execute tests>>=
   call test (sf_epa_3, "sf_epa_3", &
        "apply mapping", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_3
 <<SF epa: tests>>=
   subroutine sf_epa_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, with EPA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_3"
 
   end subroutine sf_epa_3
 
 @ %def sf_epa_3
 @
 \subsubsection{Non-collinear case}
 Construct and display a structure function object based on the EPA
 structure function.
 <<SF epa: execute tests>>=
   call test (sf_epa_4, "sf_epa_4", &
        "non-collinear", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_4
 <<SF epa: tests>>=
   subroutine sf_epa_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E, m
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_4"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 5.0_default, recoil = .true.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500, me = 5 GeV"
     write (u, "(A)")
     E = 500
     m = 5
     k = vector4_moving (E, sqrt (E**2 - m**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, "
     write (u, "(A)")  "          non-coll., keeping energy, me = 5 GeV"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.5_default, 0.5_default, 0.25_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
     call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_4"
 
   end subroutine sf_epa_4
 
 @ %def sf_epa_4
 @
 \subsubsection{Structure function for multiple flavors}
 Construct and display a structure function object based on the EPA
 structure function.  The incoming state has multiple particles with
 non-uniform charge.
 <<SF epa: execute tests>>=
   call test (sf_epa_5, "sf_epa_5", &
        "multiple flavors", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_5
 <<SF epa: tests>>=
   subroutine sf_epa_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (1, model)
     pdg_in = [1, 2, -1, -2]
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
        call data%check ()
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EPA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_5"
 
   end subroutine sf_epa_5
 
 @ %def sf_epa_5
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{EWA}
 
 <<[[sf_ewa.f90]]>>=
 <<File header>>
 
 module sf_ewa
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_17, FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: W_BOSON, Z_BOSON
   use lorentz
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use interactions
   use sf_aux
   use sf_base
 
 <<Standard module head>>
 
 <<SF ewa: public>>
 
 <<SF ewa: parameters>>
 
 <<SF ewa: types>>
 
 contains
 
 <<SF ewa: procedures>>
 
 end module sf_ewa
 @ %def sf_ewa
 @
 \subsection{Physics}
 The EWA structure function for a $Z$ or $W$ inside a fermion (lepton
 or quark) depends on the vector-boson polarization.  We distinguish
 transversal ($\pm$) and longitudinal ($0$) polarization.
 \begin{align}
   F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x}
   \left[
   \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right)
   -
   \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
   \right]
   \\
   F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x}
   \left[
   \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right)
   -
   \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
   \right]
   \\
   F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\,
   \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
 \end{align}
 where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is
 the vector-boson mass, $v$ and $a$ are the vector and axial-vector
 couplings, and $\bar x\equiv 1-x$.  Note that the longitudinal
 structure function is finite for large cutoff, while the transversal
 structure function is logarithmically divergent.
 
 The maximal transverse momentum is given by the kinematical limit, it is
 \begin{equation}
 p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2.
 \end{equation}
 The vector and axial couplings for a fermion branching into a $W$ are
 \begin{align}
   v_W &= \frac{g}{2\sqrt 2},
 & a_W &= \frac{g}{2\sqrt 2}.
 \end{align}
 For $Z$ emission, this is replaced by
 \begin{align}
   v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right),
 & a_Z &= \frac{g}{2\cos\theta_w}t_3,
 \end{align}
 where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge.
 
 For an initial antifermion, the signs of the axial couplings are
 inverted.  Note that a common sign change of $v$ and $a$ is
 irrelevant.
 
 %% Differentiating with respect to the cutoff, we get structure functions
 %% \begin{align}
 %%   f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\,
 %%   \frac{1+\bar x^2}{x}
 %%   \frac{p_\perp}{p_\perp^2 + \bar x M^2}
 %%   \\
 %%   f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\,
 %%   \frac{2\bar x}{x}\,
 %%   \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2}
 %%   \\
 %%   F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}
 %%   \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\,
 %%   \frac{1+\bar x^2}{x}
 %%   \frac{p_\perp}{p_\perp^2 + \bar x M^2}
 %%   \\
 %%   F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\,
 %%   \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\,
 %%   \frac{2\bar x}{x}\,
 %%   \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2}
 %% \end{align}
 %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion
 %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the
 %% positron charge.
 
 The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and
 $M_Z$.  These can all be taken from the SM input, and the prefactors
 are calculated from those and the incoming particle type.
 
 Since these structure functions have a $1/x$ singularity (which is not
 really relevant in practice, however, since the vector boson mass is
 finite), we map this singularity allowing for nontrivial $x$ bounds:
 \begin{equation}
   x = \exp(\bar r\ln x_0 + r\ln x_1)
 \end{equation}
 such that
 \begin{equation}
   \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr.
 \end{equation}
 
 As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$.
 The divergence $1/x$ also requires a $x_0$ cutoff; and for
 completeness we introduce a corresponding $x_1$.  Physically, the
 minimal sensible value of $x$ is $M^2/s$, although the approximation
 loses its value already at higher $x$ values.
 
 
 \subsection{The EWA data block}
 The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and
 $m$. Instead of $m$ we can use the incoming particle PDG code as
 input; from this we can deduce the mass and charges. In the
 initialization phase it is not yet determined whether a $W$ or a $Z$
 is radiated, hence we set the vector and axial-vector couplings equal
 to the common prefactors $g/2 = e/2/\sin\theta_W$.
 
 In principle, for EWA it would make sense to allow the user to also
 set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here.
 <<SF ewa: public>>=
   public :: ewa_data_t
 <<SF ewa: types>>=
   type, extends(sf_data_t) :: ewa_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:), allocatable :: flv_in
      type(flavor_t), dimension(:), allocatable :: flv_out
      real(default) :: pt_max
      real(default) :: sqrts
      real(default) :: x_min
      real(default) :: x_max
      real(default) :: mass
      real(default) :: m_out
      real(default) :: q_min
      real(default) :: cv
      real(default) :: ca
      real(default) :: costhw
      real(default) :: sinthw
      real(default) :: mW
      real(default) :: mZ
      real(default) :: coeff
      logical :: mass_set = .false.
      logical :: recoil = .false.
      logical :: keep_energy = .false.
      integer :: id = 0
      integer :: error = NONE
    contains
    <<SF ewa: ewa data: TBP>>
   end type ewa_data_t
 
 @ %def ewa_data_t
 @ Error codes
 <<SF ewa: parameters>>=
   integer, parameter :: NONE = 0
   integer, parameter :: ZERO_QMIN = 1
   integer, parameter :: Q_MAX_TOO_SMALL = 2
   integer, parameter :: ZERO_XMIN = 3
   integer, parameter :: MASS_MIX = 4
   integer, parameter :: ZERO_SW = 5
   integer, parameter :: ISOSPIN_MIX = 6
   integer, parameter :: WRONG_PRT = 7
   integer, parameter :: MASS_MIX_OUT = 8
   integer, parameter :: NO_EWA = 9
 <<SF ewa: ewa data: TBP>>=
   procedure :: init => ewa_data_init
 <<SF ewa: procedures>>=
   subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, &
         sqrts, recoil, keep_energy, mass)
     class(ewa_data_t), intent(inout) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     real(default), intent(in) :: x_min, pt_max, sqrts
     logical, intent(in) :: recoil, keep_energy
     real(default), intent(in), optional :: mass
     real(default) :: g, ee
     integer :: n_flv, i
     data%model => model
     if (.not. any (pdg_in .match. &
          [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then
        data%error = WRONG_PRT;  return
     end if
     n_flv = pdg_array_get_length (pdg_in)
     allocate (data%flv_in (n_flv))
     allocate (data%flv_out(n_flv))
     do i = 1, n_flv
        call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model)
     end do
     data%pt_max = pt_max
     data%sqrts = sqrts
     data%x_min = x_min
     data%x_max = 1
     if (vanishes (data%x_min)) then
        data%error = ZERO_XMIN;  return
     end if
     select case (char (data%model%get_name ()))
     case ("QCD","QED","Test")
        data%error = NO_EWA;  return
     end select
     ee = data%model%get_real (var_str ("ee"))
     data%sinthw = data%model%get_real (var_str ("sw"))
     data%costhw = data%model%get_real (var_str ("cw"))
     data%mZ = data%model%get_real (var_str ("mZ"))
     data%mW = data%model%get_real (var_str ("mW"))
     if (data%sinthw /= 0) then
        g = ee / data%sinthw
     else
        data%error = ZERO_SW;  return
     end if
     data%cv = g / 2._default
     data%ca = g / 2._default
     data%coeff = 1._default / (8._default * PI**2)
     data%recoil = recoil
     data%keep_energy = keep_energy
     if (present (mass)) then
        data%mass = mass
        data%m_out = mass
        data%mass_set = .true.
     else
        data%mass = data%flv_in(1)%get_mass ()
        if (any (data%flv_in%get_mass () /= data%mass)) then
           data%error = MASS_MIX;  return
        end if
     end if
   end subroutine ewa_data_init
 
 @ %def ewa_data_init
 @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons.
 <<SF ewa: ewa data: TBP>>=
   procedure :: set_id => ewa_set_id
 <<SF ewa: procedures>>=
   subroutine ewa_set_id (data, id)
     class(ewa_data_t), intent(inout) :: data
     integer, intent(in) :: id
     integer :: i, isospin, pdg
     if (.not. allocated (data%flv_in)) &
          call msg_bug ("EWA: incoming particles not set")
     data%id = id
     select case (data%id)
     case (23)
        data%m_out = data%mass
        data%flv_out = data%flv_in
     case (24)
        do i = 1, size (data%flv_in)
           pdg = data%flv_in(i)%get_pdg ()
           isospin = data%flv_in(i)%get_isospin_type ()
           if (isospin > 0) then
              !!! up-type quark or neutrinos
              if (data%flv_in(i)%is_antiparticle ()) then
                 call data%flv_out(i)%init (pdg + 1, data%model)
              else
                 call data%flv_out(i)%init (pdg - 1, data%model)
              end if
           else
              !!! down-type quark or lepton
              if (data%flv_in(i)%is_antiparticle ()) then
                 call data%flv_out(i)%init (pdg - 1, data%model)
              else
                 call data%flv_out(i)%init (pdg + 1, data%model)
              end if
           end if
        end do
        if (.not. data%mass_set) then
           data%m_out = data%flv_out(1)%get_mass ()
           if (any (data%flv_out%get_mass () /= data%m_out)) then
              data%error = MASS_MIX_OUT;  return
           end if
        end if
     end select
   end subroutine ewa_set_id
 
 @ %def ewa_set_id
 @ Handle error conditions.  Should always be done after
 initialization, unless we are sure everything is ok.
 <<SF ewa: ewa data: TBP>>=
   procedure :: check => ewa_data_check
 <<SF ewa: procedures>>=
   subroutine ewa_data_check (data)
     class(ewa_data_t), intent(in) :: data
     select case (data%error)
     case (WRONG_PRT)
        call msg_fatal ("EWA structure function only accessible for " &
             // "SM quarks and leptons.")
     case (NO_EWA)
        call msg_fatal ("EWA structure function not available for model " &
             // char (data%model%get_name ()))
     case (ZERO_SW)
        call msg_fatal ("EWA: Vanishing value of sin(theta_w)")
     case (ZERO_QMIN)
        call msg_fatal ("EWA: Particle mass is zero")
     case (Q_MAX_TOO_SMALL)
        call msg_fatal ("EWA: Particle mass exceeds Qmax")
     case (ZERO_XMIN)
        call msg_fatal ("EWA: x_min must be larger than zero")
     case (MASS_MIX)
        call msg_fatal ("EWA: incoming particle masses must be uniform")
     case (MASS_MIX_OUT)
        call msg_fatal ("EWA: outgoing particle masses must be uniform")
     case (ISOSPIN_MIX)
        call msg_fatal ("EWA: incoming particle isospins must be uniform")
     end select
   end subroutine ewa_data_check
 
 @ %def ewa_data_check
 @ Output
 <<SF ewa: ewa data: TBP>>=
   procedure :: write => ewa_data_write
 <<SF ewa: procedures>>=
   subroutine ewa_data_write (data, unit, verbose)
     class(ewa_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "EWA data:"
     if (allocated (data%flv_in) .and. allocated (data%flv_out)) then
        write (u, "(3x,A)", advance="no") "  flavor(in)  =  "
        do i = 1, size (data%flv_in)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_in(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A)", advance="no") "  flavor(out) =  "
        do i = 1, size (data%flv_out)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_out(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A," // FMT_19 // ")") "  x_min     = ", data%x_min
        write (u, "(3x,A," // FMT_19 // ")") "  x_max     = ", data%x_max
        write (u, "(3x,A," // FMT_19 // ")") "  pt_max    = ", data%pt_max
        write (u, "(3x,A," // FMT_19 // ")") "  sqrts     = ", data%sqrts
        write (u, "(3x,A," // FMT_19 // ")") "  mass      = ", data%mass
        write (u, "(3x,A," // FMT_19 // ")") "  cv        = ", data%cv
        write (u, "(3x,A," // FMT_19 // ")") "  ca        = ", data%ca
        write (u, "(3x,A," // FMT_19 // ")") "  coeff     = ", data%coeff
        write (u, "(3x,A," // FMT_19 // ")") "  costhw    = ", data%costhw
        write (u, "(3x,A," // FMT_19 // ")") "  sinthw    = ", data%sinthw
        write (u, "(3x,A," // FMT_19 // ")") "  mZ        = ", data%mZ
        write (u, "(3x,A," // FMT_19 // ")") "  mW        = ", data%mW
        write (u, "(3x,A,L2)")      "  recoil    = ", data%recoil
        write (u, "(3x,A,L2)")      "  keep en.  = ", data%keep_energy
        write (u, "(3x,A,I2)")      "  PDG (VB)  = ", data%id
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine ewa_data_write
 
 @ %def ewa_data_write
 @ The number of parameters is one for collinear splitting, in case the
 [[recoil]] option is set, we take the recoil into account.
 <<SF ewa: ewa data: TBP>>=
   procedure :: get_n_par => ewa_data_get_n_par
 <<SF ewa: procedures>>=
   function ewa_data_get_n_par (data) result (n)
     class(ewa_data_t), intent(in) :: data
     integer :: n
     if (data%recoil) then
        n = 3
     else
        n = 1
     end if
   end function ewa_data_get_n_par
 
 @ %def ewa_data_get_n_par
 @ Return the outgoing particles PDG codes. This depends, whether this
 is a charged-current or neutral-current interaction.
 <<SF ewa: ewa data: TBP>>=
   procedure :: get_pdg_out => ewa_data_get_pdg_out
 <<SF ewa: procedures>>=
   subroutine ewa_data_get_pdg_out (data, pdg_out)
     class(ewa_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     integer :: i, n_flv
     if (allocated (data%flv_out)) then
        n_flv = size (data%flv_out)
     else
        n_flv = 0
     end if
     allocate (pdg1 (n_flv))
     do i = 1, n_flv
        pdg1(i) = data%flv_out(i)%get_pdg ()
     end do
     pdg_out(1) = pdg1
   end subroutine ewa_data_get_pdg_out
 
 @ %def ewa_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF ewa: ewa data: TBP>>=
   procedure :: allocate_sf_int => ewa_data_allocate_sf_int
 <<SF ewa: procedures>>=
   subroutine ewa_data_allocate_sf_int (data, sf_int)
     class(ewa_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (ewa_t :: sf_int)
   end subroutine ewa_data_allocate_sf_int
 
 @ %def ewa_data_allocate_sf_int
 @
 \subsection{The EWA object}
 The [[ewa_t]] data type is a $1\to 2$ interaction.  We should be able
 to handle several flavors in parallel, since EWA is not necessarily
 applied immediately after beam collision:  $W/Z$ bosons may be radiated
 from quarks.  In that case, the partons are massless and $q_{\rm min}$
 applies instead, so we do not need to generate several kinematical
 configurations in parallel.
 
 The particles are ordered as (incoming, radiated, W/Z), where the
 W/Z initiates the hard interaction.
 
 In the case of EPA, we generated an unpolarized photon and transferred
 initial polarization to the radiated parton.  Color is transferred in
 the same way. I do not know whether the same can/should be done for
 EWA, as the structure functions depend on the W/Z polarization. If we
 are having $Z$ bosons, both up- and down-type fermions can
 participate. Otherwise, with a $W^+$ an up-type fermion is transferred
 to a down-type fermion, and the other way round.
 <<SF ewa: types>>=
   type, extends (sf_int_t) :: ewa_t
      type(ewa_data_t), pointer :: data => null ()
      real(default) :: x  = 0
      real(default) :: xb = 0
      integer :: n_me = 0
      real(default), dimension(:), allocatable :: cv
      real(default), dimension(:), allocatable :: ca
    contains
    <<SF ewa: ewa: TBP>>
   end type ewa_t
 
 @ %def ewa_t
 @ Type string: has to be here, but there is no string variable on which EWA
 depends. Hence, a dummy routine.
 <<SF ewa: ewa: TBP>>=
   procedure :: type_string => ewa_type_string
 <<SF ewa: procedures>>=
   function ewa_type_string (object) result (string)
     class(ewa_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "EWA: equivalent W/Z approx."
     else
        string = "EWA: [undefined]"
     end if
   end function ewa_type_string
 
 @ %def ewa_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF ewa: ewa: TBP>>=
   procedure :: write => ewa_write
 <<SF ewa: procedures>>=
   subroutine ewa_write (object, unit, testflag)
     class(ewa_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           write (u, "(3x,A," // FMT_17 // ")")  "xb=", object%xb
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "EWA data: [undefined]"
     end if
   end subroutine ewa_write
 
 @ %def ewa_write
 @ The current implementation requires uniform isospin for all incoming
 particles, therefore we need to probe only the first one.
 <<SF ewa: ewa: TBP>>=
   procedure :: init => ewa_init
 <<SF ewa: procedures>>=
   subroutine ewa_init (sf_int, data)
     class(ewa_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     integer, dimension(3) :: hel_lock
     type(polarization_t), target :: pol
     type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin
     type(flavor_t) :: flv_z, flv_wp, flv_wm
     type(color_t) :: col0
     type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w
     type(polarization_iterator_t) :: it_hel
     integer :: i, isospin
     select type (data)
     type is (ewa_data_t)
        mask = quantum_numbers_mask (.false., .false., &
             mask_h = [.false., .false., .true.])
        hel_lock = [2, 1, 0]
        call col0%init ()
        select case (data%id)
        case (23)
           !!! Z boson, flavor is not changing
           call sf_int%base_init (mask, [data%mass**2], [data%mass**2], &
                [data%mZ**2], hel_lock = hel_lock)
           sf_int%data => data
           call flv_z%init (Z_BOSON, data%model)
           call qn_z%init (flv_z, col0)
           do i = 1, size (data%flv_in)
              call pol%init_generic (data%flv_in(i))
              call qn_fc(1)%init ( &
                   flv = data%flv_in(i), &
                   col = color_from_flavor (data%flv_in(i), 1))
              call it_hel%init (pol)
              do while (it_hel%is_valid ())
                 qn_hel = it_hel%get_quantum_numbers ()
                 qn = qn_hel .merge. qn_fc(1)
                 qn_rad = qn
                 call qn_rad%tag_radiated ()
                 call sf_int%add_state ([qn, qn_rad, qn_z])
                 call it_hel%advance ()
              end do
              !  call pol%final ()
           end do
        case (24)
           call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], &
                [data%mW**2], hel_lock = hel_lock)
           sf_int%data => data
           call flv_wp%init (W_BOSON, data%model)
           call flv_wm%init (- W_BOSON, data%model)
           call qn_wp%init (flv_wp, col0)
           call qn_wm%init (flv_wm, col0)
           do i = 1, size (data%flv_in)
              isospin = data%flv_in(i)%get_isospin_type ()
              if (isospin > 0) then
                 !!! up-type quark or neutrinos
                 if (data%flv_in(i)%is_antiparticle ()) then
                    qn_w = qn_wm
                 else
                    qn_w = qn_wp
                 end if
              else
                 !!! down-type quark or lepton
                 if (data%flv_in(i)%is_antiparticle ()) then
                    qn_w = qn_wp
                 else
                    qn_w = qn_wm
                 end if
              end if
              call pol%init_generic (data%flv_in(i))
              call qn_fc(1)%init ( &
                   flv = data%flv_in(i), &
                   col = color_from_flavor (data%flv_in(i), 1))
              call qn_fc_fin(1)%init ( &
                   flv = data%flv_out(i), &
                   col = color_from_flavor (data%flv_out(i), 1))
              call it_hel%init (pol)
              do while (it_hel%is_valid ())
                 qn_hel = it_hel%get_quantum_numbers ()
                 qn = qn_hel .merge. qn_fc(1)
                 qn_rad = qn_hel .merge. qn_fc_fin(1)
                 call qn_rad%tag_radiated ()
                 call sf_int%add_state ([qn, qn_rad, qn_w])
                 call it_hel%advance ()
              end do
              ! call pol%final ()
           end do
        case default
           call msg_fatal ("EWA initialization failed: wrong particle type.")
        end select
        call sf_int%freeze ()
        if (data%keep_energy) then
           sf_int%on_shell_mode = KEEP_ENERGY
        else
           sf_int%on_shell_mode = KEEP_MOMENTUM
        end if
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
     end select
   end subroutine ewa_init
 
 @ %def ewa_init
 @ Prepare the coupling arrays.  This is separate from the previous routine since
 the state matrix may be helicity-contracted.
 <<SF ewa: ewa: TBP>>=
   procedure :: setup_constants => ewa_setup_constants
 <<SF ewa: procedures>>=
   subroutine ewa_setup_constants (sf_int)
     class(ewa_t), intent(inout), target :: sf_int
     type(state_iterator_t) :: it
     type(flavor_t) :: flv
     real(default) :: q, t3
     integer :: i
     sf_int%n_me = sf_int%get_n_matrix_elements ()
     allocate (sf_int%cv (sf_int%n_me))
     allocate (sf_int%ca (sf_int%n_me))
     associate (data => sf_int%data)
       select case (data%id)
       case (23)
          call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
          do while (it%is_valid ())
             i = it%get_me_index ()
             flv = it%get_flavor (1)
             q = flv%get_charge ()
             t3 = flv%get_isospin ()
             if (flv%is_antiparticle ()) then
                sf_int%cv(i) = - data%cv &
                     * (t3 - 2._default * q * data%sinthw**2) / data%costhw
                sf_int%ca(i) = data%ca *  t3 / data%costhw
             else
                sf_int%cv(i) = data%cv &
                     * (t3 - 2._default * q * data%sinthw**2) / data%costhw
                sf_int%ca(i) = data%ca *  t3 / data%costhw
             end if
             call it%advance ()
          end do
       case (24)
          call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
          do while (it%is_valid ())
             i = it%get_me_index ()
             flv = it%get_flavor (1)
             if (flv%is_antiparticle ()) then
                sf_int%cv(i) = data%cv / sqrt(2._default)
                sf_int%ca(i) = - data%ca / sqrt(2._default)
             else
                sf_int%cv(i) = data%cv / sqrt(2._default)
                sf_int%ca(i) = data%ca / sqrt(2._default)
             end if
             call it%advance ()
          end do
       end select
     end associate
     sf_int%status = SF_INITIAL
   end subroutine ewa_setup_constants
 
 @ %def ewa_setup_constants
 @
 \subsection{Kinematics}
 Set kinematics.  The EWA structure function allows for a
 straightforward mapping of the unit interval.  So, to leading order,
 the structure function value is unity, but the $x$ value is
 transformed.  Higher orders affect the function value.
 If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian
 $f(r)$ is trivial.
 
 If [[map]] is set, the exponential mapping for the $1/x$ singularity
 discussed above is applied.
 <<SF ewa: ewa: TBP>>=
   procedure :: complete_kinematics => ewa_complete_kinematics
 <<SF ewa: procedures>>=
   subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(ewa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default) :: e_1
     real(default) :: x0, x1, lx0, lx1, lx
     e_1 = energy (sf_int%get_momentum (1))
     if (sf_int%data%recoil) then
        select case (sf_int%data%id)
        case (23)
           x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1)
        case (24)
           x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1)
        end select
     else
        x0 = sf_int%data%x_min
     end if
     x1 = sf_int%data%x_max
     if ( x0 >= x1) then
        f = 0
        sf_int%status = SF_FAILED_KINEMATICS
        return
     end if
     if (map) then
        lx0 = log (x0)
        lx1 = log (x1)
        lx = lx1 * r(1) + lx0 * rb(1)
        x(1) = exp(lx)
        f = x(1) * (lx1 - lx0)
     else
        x(1) = r(1)
        if (x0 < x(1) .and. x(1) < x1) then
           f = 1
        else
           sf_int%status = SF_FAILED_KINEMATICS
           f = 0
           return
        end if
     end if
     xb(1) = 1 - x(1)
     if (size(x) == 3) then
        x(2:3) = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x  = x(1)
        sf_int%xb = xb(1)
     case (SF_FAILED_KINEMATICS)
        sf_int%x  = 0
        sf_int%xb = 0
        f = 0
     end select
   end subroutine ewa_complete_kinematics
 
 @ %def ewa_complete_kinematics
 @ Overriding the default method: we compute the [[x]] array from the
 momentum configuration.  In the specific case of EWA, we also set the
 internally stored $x$ and $\bar x$ values, so they can be used in the
 following routine.
 <<SF ewa: ewa: TBP>>=
   procedure :: recover_x => sf_ewa_recover_x
 <<SF ewa: procedures>>=
   subroutine sf_ewa_recover_x (sf_int, x, xb, x_free)
     class(ewa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
     sf_int%xb = xb(1)
   end subroutine sf_ewa_recover_x
 
 @ %def sf_ewa_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF ewa: ewa: TBP>>=
   procedure :: inverse_kinematics => ewa_inverse_kinematics
 <<SF ewa: procedures>>=
   subroutine ewa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(ewa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: x0, x1, lx0, lx1, lx, e_1
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     e_1 = energy (sf_int%get_momentum (1))
     if (sf_int%data%recoil) then
        select case (sf_int%data%id)
        case (23)
           x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1)
        case (24)
           x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1)
        end select
     else
        x0 = sf_int%data%x_min
     end if
     x1 = sf_int%data%x_max
     if (map) then
        lx0 = log (x0)
        lx1 = log (x1)
        lx = log (x(1))
        r(1)  = (lx - lx0) / (lx1 - lx0)
        rb(1) = (lx1 - lx) / (lx1 - lx0)
        f = x(1) * (lx1 - lx0)
     else
        r (1) = x(1)
        rb(1) = 1 - x(1)
        if (x0 < x(1) .and. x(1) < x1) then
           f = 1
        else
           f = 0
        end if
     end if
     if (size(r) == 3) then
        r (2:3) = x(2:3)
        rb(2:3) = xb(2:3)
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine ewa_inverse_kinematics
 
 @ %def ewa_inverse_kinematics
 @
 \subsection{EWA application}
 For EWA, we can compute kinematics and function value in a single
 step.  This function works on a single beam, assuming that the input
 momentum has been set.  We need four random numbers as input: one for
 $x$, one for $Q^2$, and two for the polar and azimuthal angles.
 Alternatively, we can skip $p_T$ generation; in this case, we only
 need one.
 
 For obtaining splitting kinematics, we rely on the assumption that all
 in-particles are mass-degenerate (or there is only one), so the
 generated $x$ values are identical.
 <<SF ewa: ewa: TBP>>=
   procedure :: apply => ewa_apply
 <<SF ewa: procedures>>=
   subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(ewa_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: x, xb, pt2, c1, c2
     real(default) :: cv, ca
     real(default) :: f, fm, fp, fL
     integer :: i
     associate (data => sf_int%data)
       x  = sf_int%x
       xb = sf_int%xb
       pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2)
       select case (data%id)
       case (23)
          !!! Z boson structure function
          c1 = log (1 + pt2 / (xb * (data%mZ)**2))
          c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2)
       case (24)
          !!! W boson structure function
          c1 = log (1 + pt2 / (xb * (data%mW)**2))
          c2 = 1 / (1 + (xb * (data%mW)**2) / pt2)
       end select
       do i = 1, sf_int%n_me
          cv = sf_int%cv(i)
          ca = sf_int%ca(i)
          fm = data%coeff * &
               ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x)
          fp = data%coeff * &
               ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x)
          fL = data%coeff * &
               (cv**2 + ca**2) * (2 * xb / x) * c2
          f = fp + fm + fL
          if (.not. vanishes (f)) then
             fp = fp / f
             fm = fm / f
             fL = fL / f
          end if
          call sf_int%set_matrix_element (i, cmplx (f, kind=default))
       end do
     end associate
     sf_int%status = SF_EVALUATED
   end subroutine ewa_apply
 
 @ %def ewa_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_ewa_ut.f90]]>>=
 <<File header>>
 
 module sf_ewa_ut
   use unit_tests
   use sf_ewa_uti
 
 <<Standard module head>>
 
 <<SF ewa: public test>>
 
 contains
 
 <<SF ewa: test driver>>
 
 end module sf_ewa_ut
 @ %def sf_ewa_ut
 @
 <<[[sf_ewa_uti.f90]]>>=
 <<File header>>
 
 module sf_ewa_uti
 
 <<Use kinds>>
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use interactions, only: interaction_pacify_momenta
   use model_data
   use sf_aux
   use sf_base
 
   use sf_ewa
 
 <<Standard module head>>
 
 <<SF ewa: test declarations>>
 
 contains
 
 <<SF ewa: tests>>
 
 end module sf_ewa_uti
 @ %def sf_ewa_ut
 @ API: driver for the unit tests below.
 <<SF ewa: public test>>=
   public :: sf_ewa_test
 <<SF ewa: test driver>>=
   subroutine sf_ewa_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF ewa: execute tests>>
   end subroutine sf_ewa_test
 
 @ %def sf_ewa_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_1, "sf_ewa_1", &
        "structure function configuration", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_1
 <<SF ewa: tests>>=
   subroutine sf_ewa_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_ewa_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_sm_test ()
     pdg_in = 2
 
     allocate (ewa_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize for Z boson"
     write (u, "(A)")
 
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 5000._default, .false., .false.)
        call data%set_id (23)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize for W boson"
     write (u, "(A)")
 
     deallocate (data)
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 5000._default, .false., .false.)
        call data%set_id (24)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_1"
 
   end subroutine sf_ewa_1
 
 @ %def sf_ewa_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the EWA
 structure function.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_2, "sf_ewa_2", &
        "structure function instance", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_2
 <<SF ewa: tests>>=
   subroutine sf_ewa_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (2, model)
     pdg_in = 2
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000._default, .false., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EWA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_2"
 
   end subroutine sf_ewa_2
 
 @ %def sf_ewa_2
 @
 \subsubsection{Standard mapping}
 Construct and display a structure function object based on the EWA
 structure function, applying the standard single-particle mapping.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_3, "sf_ewa_3", &
        "apply mapping", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_3
 <<SF ewa: tests>>=
   subroutine sf_ewa_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (2, model)
     pdg_in = 2
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000._default, .false., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, with EWA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_3"
 
   end subroutine sf_ewa_3
 
 @ %def sf_ewa_3
 @
 \subsubsection{Non-collinear case}
 Construct and display a structure function object based on the EPA
 structure function.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_4, "sf_ewa_4", &
        "non-collinear", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_4
 <<SF ewa: tests>>=
   subroutine sf_ewa_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_4"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call modeL%init_sm_test ()
     call flv%init (2, model)
     pdg_in = 2
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000.0_default, .true., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, "
     write (u, "(A)")  "          non-coll., keeping energy"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.5_default, 0.5_default, 0.25_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
     call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 1500._default)
     call sf_int%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_4"
 
   end subroutine sf_ewa_4
 
 @ %def sf_ewa_4
 @
 \subsubsection{Structure function for multiple flavors}
 Construct and display a structure function object based on the EWA
 structure function.  The incoming state has multiple particles with
 non-uniform quantum numbers.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_5, "sf_ewa_5", &
        "structure function instance", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_5
 <<SF ewa: tests>>=
   subroutine sf_ewa_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (2, model)
     pdg_in = [1, 2, -1, -2]
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000._default, .false., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EWA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_5"
 
   end subroutine sf_ewa_5
 
 @ %def sf_ewa_5
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Energy-scan spectrum}
 
 This spectrum is actually a trick that allows us to plot the c.m.\ energy
 dependence of a cross section without scanning the input energy.  We
 start with the observation that a spectrum $f(x)$, applied to one of
 the incoming beams only, results in a cross section
 \begin{equation}
   \sigma = \int dx\,f(x)\,\hat\sigma(xs).
 \end{equation}
 We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e.,
 \begin{equation}
   \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx}
   = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs),
 \end{equation}
 so if we set
 \begin{equation}
   f(x) = \frac{\sqrt{s}}{2\sqrt{x}},
 \end{equation}
 we get the distribution
 \begin{equation}
   \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2).
 \end{equation}
 We implement this as a spectrum with a single parameter $x$.  The
 parameters for the individual beams are computed as $x_i=\sqrt{x}$, so
 they are equal and the kinematics is always symmetric.
 <<[[sf_escan.f90]]>>=
 <<File header>>
 
 module sf_escan
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_12
   use numeric_utils
   use diagnostics
   use lorentz
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF escan: public>>
 
 <<SF escan: types>>
 
 contains
 
 <<SF escan: procedures>>
 
 end module sf_escan
 @ %def sf_escan
 @
 \subsection{Data type}
 The [[norm]] is unity if the total cross section should be normalized
 to one, and $\sqrt{s}$ if it should be normalized to the total
 energy.  In the latter case, the differential distribution
 $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section
 $\hat\sigma$ as a function of $\sqrt{\hat s}$.
 <<SF escan: public>>=
   public :: escan_data_t
 <<SF escan: types>>=
   type, extends(sf_data_t) :: escan_data_t
      private
      type(flavor_t), dimension(:,:), allocatable :: flv_in
      integer, dimension(2) :: n_flv = 0
      real(default) :: norm = 1
    contains
    <<SF escan: escan data: TBP>>
   end type escan_data_t
 
 @  %def escan_data_t
 <<SF escan: escan data: TBP>>=
   procedure :: init => escan_data_init
 <<SF escan: procedures>>=
   subroutine escan_data_init (data, model, pdg_in, norm)
     class(escan_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), intent(in), optional :: norm
     real(default), dimension(2) :: m2
     integer :: i, j
     data%n_flv = pdg_array_get_length (pdg_in)
     allocate (data%flv_in (maxval (data%n_flv), 2))
     do i = 1, 2
        do j = 1, data%n_flv(i)
           call data%flv_in(j, i)%init (pdg_array_get (pdg_in(i), j), model)
        end do
     end do
     m2 = data%flv_in(1,:)%get_mass ()
     do i = 1, 2
        if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then
           call msg_fatal ("Energy scan: incoming particle mass must be uniform")
        end if
     end do
     if (present (norm))  data%norm = norm
   end subroutine escan_data_init
 
 @ %def escan_data_init
 @ Output
 <<SF escan: escan data: TBP>>=
   procedure :: write => escan_data_write
 <<SF escan: procedures>>=
   subroutine escan_data_write (data, unit, verbose)
     class(escan_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i, j
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Energy-scan data:"
     write (u, "(3x,A)", advance="no")  "prt_in = "
     do i = 1, 2
        if (i > 1)  write (u, "(',',1x)", advance="no")
        do j = 1, data%n_flv(i)
           if (j > 1)  write (u, "(':')", advance="no")
           write (u, "(A)", advance="no")  char (data%flv_in(j,i)%get_name ())
        end do
     end do
     write (u, *)
     write (u, "(3x,A," // FMT_12 // ")")  "norm   =", data%norm
   end subroutine escan_data_write
 
 @ %def escan_data_write
 @ Kinematics is completely collinear, hence there is only one
 parameter for a pair spectrum.
 <<SF escan: escan data: TBP>>=
   procedure :: get_n_par => escan_data_get_n_par
 <<SF escan: procedures>>=
   function escan_data_get_n_par (data) result (n)
     class(escan_data_t), intent(in) :: data
     integer :: n
     n = 1
   end function escan_data_get_n_par
 
 @ %def escan_data_get_n_par
 @ Return the outgoing particles PDG codes. This is always the same as
 the incoming particle, where we use two indices for the two beams.
 <<SF escan: escan data: TBP>>=
   procedure :: get_pdg_out => escan_data_get_pdg_out
 <<SF escan: procedures>>=
   subroutine escan_data_get_pdg_out (data, pdg_out)
     class(escan_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg ()
     end do
   end subroutine escan_data_get_pdg_out
 
 @ %def escan_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF escan: escan data: TBP>>=
   procedure :: allocate_sf_int => escan_data_allocate_sf_int
 <<SF escan: procedures>>=
   subroutine escan_data_allocate_sf_int (data, sf_int)
     class(escan_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (escan_t :: sf_int)
   end subroutine escan_data_allocate_sf_int
 
 @ %def escan_data_allocate_sf_int
 @
 \subsection{The Energy-scan object}
 This is a spectrum, not a radiation.  We create an interaction with
 two incoming and two outgoing particles, flavor, color, and helicity
 being carried through. $x$ nevertheless is only one-dimensional, as we
 are always using only one beam parameter.
 <<SF escan: types>>=
   type, extends (sf_int_t) :: escan_t
      type(escan_data_t), pointer :: data => null ()
    contains
    <<SF escan: escan: TBP>>
   end type escan_t
 
 @ %def escan_t
 @ Type string: for the energy scan this is just a dummy function.
 <<SF escan: escan: TBP>>=
   procedure :: type_string => escan_type_string
 <<SF escan: procedures>>=
   function escan_type_string (object) result (string)
     class(escan_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "Escan: energy scan"
     else
        string = "Escan: [undefined]"
     end if
   end function escan_type_string
 
 @ %def escan_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF escan: escan: TBP>>=
   procedure :: write => escan_write
 <<SF escan: procedures>>=
   subroutine escan_write (object, unit, testflag)
     class(escan_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "Energy scan data: [undefined]"
     end if
   end subroutine escan_write
 
 @ %def escan_write
 @
 <<SF escan: escan: TBP>>=
   procedure :: init => escan_init
 <<SF escan: procedures>>=
   subroutine escan_init (sf_int, data)
     class(escan_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(4) :: mask
     integer, dimension(4) :: hel_lock
     real(default), dimension(2) :: m2
     real(default), dimension(0) :: mr2
     type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
     type(polarization_t), target :: pol1, pol2
     type(polarization_iterator_t) :: it_hel1, it_hel2
     integer :: j1, j2
     select type (data)
     type is (escan_data_t)
        hel_lock = [3, 4, 1, 2]
        m2 = data%flv_in(1,:)%get_mass ()
        call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
        sf_int%data => data
        do j1 = 1, data%n_flv(1)
           call qn_fc(1)%init ( &
                flv = data%flv_in(j1,1), &
                col = color_from_flavor (data%flv_in(j1,1)))
           call qn_fc(3)%init ( &
                flv = data%flv_in(j1,1), &
                col = color_from_flavor (data%flv_in(j1,1)))
           call pol1%init_generic (data%flv_in(j1,1))
           do j2 = 1, data%n_flv(2)
              call qn_fc(2)%init ( &
                   flv = data%flv_in(j2,2), &
                   col = color_from_flavor (data%flv_in(j2,2)))
              call qn_fc(4)%init ( &
                   flv = data%flv_in(j2,2), &
                   col = color_from_flavor (data%flv_in(j2,2)))
              call pol2%init_generic (data%flv_in(j2,2))
              call it_hel1%init (pol1)
              do while (it_hel1%is_valid ())
                 qn_hel(1) = it_hel1%get_quantum_numbers ()
                 qn_hel(3) = it_hel1%get_quantum_numbers ()
                 call it_hel2%init (pol2)
                 do while (it_hel2%is_valid ())
                    qn_hel(2) = it_hel2%get_quantum_numbers ()
                    qn_hel(4) = it_hel2%get_quantum_numbers ()
                    qn = qn_hel .merge. qn_fc
                    call sf_int%add_state (qn)
                    call it_hel2%advance ()
                 end do
                 call it_hel1%advance ()
              end do
              ! call pol2%final ()
           end do
           ! call pol1%final ()
        end do
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%freeze ()
        sf_int%status = SF_INITIAL
     end select
   end subroutine escan_init
 
 @ %def escan_init
 @
 \subsection{Kinematics}
 Set kinematics.  We have a single parameter, but reduce both beams.
 The [[map]] flag is ignored.
 <<SF escan: escan: TBP>>=
   procedure :: complete_kinematics => escan_complete_kinematics
 <<SF escan: procedures>>=
   subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(escan_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default) :: sqrt_x
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     x = r
     xb= rb
     sqrt_x = sqrt (x(1))
     if (sqrt_x > 0) then
        f = 1 / (2 * sqrt_x)
     else
        f = 0
        sf_int%status = SF_FAILED_KINEMATICS
        return
     end if
     call sf_int%reduce_momenta ([sqrt_x, sqrt_x])
   end subroutine escan_complete_kinematics
 
 @ %def escan_complete_kinematics
 @ Recover $x$.  The base procedure should return two momentum
 fractions for the two beams, while we have only one parameter.  This
 is the product of the extracted momentum fractions.
 <<SF escan: escan: TBP>>=
   procedure :: recover_x => escan_recover_x
 <<SF escan: procedures>>=
   subroutine escan_recover_x (sf_int, x, xb, x_free)
     class(escan_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: xi, xib
     call sf_int%base_recover_x (xi, xib, x_free)
     x = product (xi)
     xb= 1 - x
   end subroutine escan_recover_x
 
 @ %def escan_recover_x
 @ Compute inverse kinematics.
 <<SF escan: escan: TBP>>=
   procedure :: inverse_kinematics => escan_inverse_kinematics
 <<SF escan: procedures>>=
   subroutine escan_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(escan_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: sqrt_x
     logical :: set_mom
 
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     sqrt_x = sqrt (x(1))
     if (sqrt_x > 0) then
        f = 1 / (2 * sqrt_x)
     else
        f = 0
        sf_int%status = SF_FAILED_KINEMATICS
        return
     end if
     r = x
     rb = xb
     if (set_mom) then
        call sf_int%reduce_momenta ([sqrt_x, sqrt_x])
     end if
   end subroutine escan_inverse_kinematics
 
 @ %def escan_inverse_kinematics
 @
 \subsection{Energy scan application}
 Here, we insert the predefined norm.
 <<SF escan: escan: TBP>>=
   procedure :: apply => escan_apply
 <<SF escan: procedures>>=
   subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(escan_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f
     associate (data => sf_int%data)
       f = data%norm
     end associate
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine escan_apply
 
 @ %def escan_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_escan_ut.f90]]>>=
 <<File header>>
 
 module sf_escan_ut
   use unit_tests
   use sf_escan_uti
 
 <<Standard module head>>
 
 <<SF escan: public test>>
 
 contains
 
 <<SF escan: test driver>>
 
 end module sf_escan_ut
 @ %def sf_escan_ut
 @
 <<[[sf_escan_uti.f90]]>>=
 <<File header>>
 
 module sf_escan_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_aux
   use sf_base
 
   use sf_escan
 
 <<Standard module head>>
 
 <<SF escan: test declarations>>
 
 contains
 
 <<SF escan: tests>>
 
 end module sf_escan_uti
 @ %def sf_escan_ut
 @ API: driver for the unit tests below.
 <<SF escan: public test>>=
   public :: sf_escan_test
 <<SF escan: test driver>>=
   subroutine sf_escan_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF escan: execute tests>>
   end subroutine sf_escan_test
 
 @ %def sf_escan_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF escan: execute tests>>=
   call test (sf_escan_1, "sf_escan_1", &
        "structure function configuration", &
        u, results)
 <<SF escan: test declarations>>=
   public :: sf_escan_1
 <<SF escan: tests>>=
   subroutine sf_escan_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_escan_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &energy-scan structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (escan_data_t :: data)
     select type (data)
     type is (escan_data_t)
        call data%init (model, pdg_in, norm = 2._default)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_escan_1"
 
   end subroutine sf_escan_1
 
 @ %def sf_escan_1
 g@
 \subsubsection{Probe the structure-function object}
 Active the beam event reader, generate an event.
 <<SF escan: execute tests>>=
   call test (sf_escan_2, "sf_escan_2", &
        "generate event", &
        u, results)
 <<SF escan: test declarations>>=
   public :: sf_escan_2
 <<SF escan: tests>>=
   subroutine sf_escan_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: x_free, f
 
     write (u, "(A)")  "* Test output: sf_escan_2"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &beam-events structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (escan_data_t :: data)
     select type (data)
     type is (escan_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set dummy parameters and generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0.8
     rb = 1 - r
     x_free = 1
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb, x_free)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_escan_2"
 
   end subroutine sf_escan_2
 
 @ %def sf_escan_2
 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Gaussian beam spread}
 
 Instead of an analytic beam description, beam data may be provided in
 form of an event file.  In its most simple form, the event file
 contains pairs of $x$ values, relative to nominal beam energies.  More
 advanced formats may include polarization, etc.  The current
 implementation carries beam polarization through, if specified.
 
 The code is very similar to the energy scan described above.
 
 However, we must include a file-handle manager for the beam-event
 files.  Two different processes may access a given beam-event file at
 the same time (i.e., serially but alternating).  Accessing an open
 file from two different units is non-standard and not supported by all
 compilers.  Therefore, we keep a global registry of open files,
 associated units, and reference counts.  The [[gaussian_t]] objects
 act as proxies to this registry.
 <<[[sf_gaussian.f90]]>>=
 <<File header>>
 
 module sf_gaussian
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_12
   use file_registries
   use diagnostics
   use lorentz
   use rng_base
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF gaussian: public>>
 
 <<SF gaussian: types>>
 
 contains
 
 <<SF gaussian: procedures>>
 
 end module sf_gaussian
 @ %def sf_gaussian
 @
 \subsection{The beam-data file registry}
 We manage data files via the [[file_registries]] module.  To this end,
 we keep the registry as a private module variable here.
 <<CCC SF gaussian: variables>>=
   type(file_registry_t), save :: beam_file_registry
 
 @ %def beam_file_registry
 @
 \subsection{Data type}
 We store the spread for each beam, as a relative number related to the beam
 energy.  For the actual generation, we include an (abstract) random-number
 generator factory.
 <<SF gaussian: public>>=
   public :: gaussian_data_t
 <<SF gaussian: types>>=
   type, extends(sf_data_t) :: gaussian_data_t
      private
      type(flavor_t), dimension(2) :: flv_in
      real(default), dimension(2) :: spread
      class(rng_factory_t), allocatable :: rng_factory
    contains
    <<SF gaussian: gaussian data: TBP>>
   end type gaussian_data_t
 
 @  %def gaussian_data_t
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: init => gaussian_data_init
 <<SF gaussian: procedures>>=
   subroutine gaussian_data_init (data, model, pdg_in, spread, rng_factory)
     class(gaussian_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), dimension(2), intent(in) :: spread
     class(rng_factory_t), intent(inout), allocatable :: rng_factory
     if (any (spread < 0)) then
        call msg_fatal ("Gaussian beam spread: must not be negative")
     end if
     call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
     call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
     data%spread = spread
     call move_alloc (from = rng_factory, to = data%rng_factory)
   end subroutine gaussian_data_init
 
 @ %def gaussian_data_init
 @ Return true since this spectrum is always in generator mode.
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: is_generator => gaussian_data_is_generator
 <<SF gaussian: procedures>>=
   function gaussian_data_is_generator (data) result (flag)
     class(gaussian_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function gaussian_data_is_generator
 
 @ %def gaussian_data_is_generator
 @ The number of parameters is two.  They are free parameters.
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: get_n_par => gaussian_data_get_n_par
 <<SF gaussian: procedures>>=
   function gaussian_data_get_n_par (data) result (n)
     class(gaussian_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function gaussian_data_get_n_par
 
 @ %def gaussian_data_get_n_par
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: get_pdg_out => gaussian_data_get_pdg_out
 <<SF gaussian: procedures>>=
   subroutine gaussian_data_get_pdg_out (data, pdg_out)
     class(gaussian_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%flv_in(i)%get_pdg ()
     end do
   end subroutine gaussian_data_get_pdg_out
 
 @ %def gaussian_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: allocate_sf_int => gaussian_data_allocate_sf_int
 <<SF gaussian: procedures>>=
   subroutine gaussian_data_allocate_sf_int (data, sf_int)
     class(gaussian_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (gaussian_t :: sf_int)
   end subroutine gaussian_data_allocate_sf_int
 
 @ %def gaussian_data_allocate_sf_int
 @ Output
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: write => gaussian_data_write
 <<SF gaussian: procedures>>=
   subroutine gaussian_data_write (data, unit, verbose)
     class(gaussian_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Gaussian beam spread data:"
     write (u, "(3x,A,A,A,A)") "prt_in = ", &
          char (data%flv_in(1)%get_name ()), &
          ", ", char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread
     call data%rng_factory%write (u)
   end subroutine gaussian_data_write
 
 @ %def gaussian_data_write
 @
 \subsection{The gaussian object}
 Flavor and polarization carried through, no radiated particles.  The generator
 needs a random-number generator, obviously.
 <<SF gaussian: public>>=
   public :: gaussian_t
 <<SF gaussian: types>>=
   type, extends (sf_int_t) :: gaussian_t
      type(gaussian_data_t), pointer :: data => null ()
      class(rng_t), allocatable :: rng
    contains
    <<SF gaussian: gaussian: TBP>>
   end type gaussian_t
 
 @ %def gaussian_t
 @ Type string: show gaussian file.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: type_string => gaussian_type_string
 <<SF gaussian: procedures>>=
   function gaussian_type_string (object) result (string)
     class(gaussian_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "Gaussian: gaussian beam-energy spread"
     else
        string = "Gaussian: [undefined]"
     end if
   end function gaussian_type_string
 
 @ %def gaussian_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: write => gaussian_write
 <<SF gaussian: procedures>>=
   subroutine gaussian_write (object, unit, testflag)
     class(gaussian_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%rng%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "gaussian data: [undefined]"
     end if
   end subroutine gaussian_write
 
 @ %def gaussian_write
 @
 <<SF gaussian: gaussian: TBP>>=
   procedure :: init => gaussian_init
 <<SF gaussian: procedures>>=
   subroutine gaussian_init (sf_int, data)
     class(gaussian_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     real(default), dimension(2) :: m2
     real(default), dimension(0) :: mr2
     type(quantum_numbers_mask_t), dimension(4) :: mask
     integer, dimension(4) :: hel_lock
     type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
     type(polarization_t), target :: pol1, pol2
     type(polarization_iterator_t) :: it_hel1, it_hel2
     integer :: i
     select type (data)
     type is (gaussian_data_t)
        m2 = data%flv_in%get_mass () ** 2
        hel_lock = [3, 4, 1, 2]
        mask = quantum_numbers_mask (.false., .false., .false.)
        call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
        sf_int%data => data
        do i = 1, 2
           call qn_fc(i)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
           call qn_fc(i+2)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
        end do
        call pol1%init_generic (data%flv_in(1))
        call it_hel1%init (pol1)
        do while (it_hel1%is_valid ())
           qn_hel(1) = it_hel1%get_quantum_numbers ()
           qn_hel(3) = it_hel1%get_quantum_numbers ()
           call pol2%init_generic (data%flv_in(2))
           call it_hel2%init (pol2)
           do while (it_hel2%is_valid ())
              qn_hel(2) = it_hel2%get_quantum_numbers ()
              qn_hel(4) = it_hel2%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc
              call sf_int%add_state (qn)
              call it_hel2%advance ()
           end do
           ! call pol2%final ()
           call it_hel1%advance ()
        end do
        ! call pol1%final ()
        call sf_int%freeze ()
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        sf_int%status = SF_INITIAL
     end select
     call sf_int%data%rng_factory%make (sf_int%rng)
   end subroutine gaussian_init
 
 @ %def gaussian_init
 @ This spectrum type needs a finalizer, which closes the data file.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: final => sf_gaussian_final
 <<SF gaussian: procedures>>=
   subroutine sf_gaussian_final (object)
     class(gaussian_t), intent(inout) :: object
     call object%interaction_t%final ()
   end subroutine sf_gaussian_final
 
 @ %def sf_gaussian_final
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: is_generator => gaussian_is_generator
 <<SF gaussian: procedures>>=
   function gaussian_is_generator (sf_int) result (flag)
     class(gaussian_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function gaussian_is_generator
 
 @ %def gaussian_is_generator
 @ Generate free parameters.  The $x$ value should be distributed with mean $1$
 and $\sigma$ given by the spread.  We reject negative $x$ values.  (This
 cut slightly biases the distribution, but for reasonable (small)
 spreads negative $r$ should not occur.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: generate_free => gaussian_generate_free
 <<SF gaussian: procedures>>=
   subroutine gaussian_generate_free (sf_int, r, rb, x_free)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     real(default), dimension(size(r)) :: z
     associate (data => sf_int%data)
       do
          call sf_int%rng%generate_gaussian (z)
          rb = z * data%spread
          r = 1 - rb
          x_free = x_free * product (r)
          if (all (r > 0))  exit
       end do
     end associate
   end subroutine gaussian_generate_free
 
 @ %def gaussian_generate_free
 @ Set kinematics.  Trivial transfer since this is a pure generator.
 The [[map]] flag doesn't apply.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: complete_kinematics => gaussian_complete_kinematics
 <<SF gaussian: procedures>>=
   subroutine gaussian_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("gaussian: map flag not supported")
     else
        x = r
        xb= rb
        f = 1
     end if
     call sf_int%reduce_momenta (x)
   end subroutine gaussian_complete_kinematics
 
 @ %def gaussian_complete_kinematics
 @ Compute inverse kinematics.  Trivial in this case.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: inverse_kinematics => gaussian_inverse_kinematics
 <<SF gaussian: procedures>>=
   subroutine gaussian_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("gaussian: map flag not supported")
     else
        r = x
        rb= xb
        f = 1
     end if
     if (set_mom) then
        call sf_int%reduce_momenta (x)
     end if
   end subroutine gaussian_inverse_kinematics
 
 @ %def gaussian_inverse_kinematics
 @
 \subsection{gaussian application}
 Trivial, just set the unit weight.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: apply => gaussian_apply
 <<SF gaussian: procedures>>=
   subroutine gaussian_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f
     f = 1
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine gaussian_apply
 
 @ %def gaussian_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_gaussian_ut.f90]]>>=
 <<File header>>
 
 module sf_gaussian_ut
   use unit_tests
   use sf_gaussian_uti
 
 <<Standard module head>>
 
 <<SF gaussian: public test>>
 
 contains
 
 <<SF gaussian: test driver>>
 
 end module sf_gaussian_ut
 @ %def sf_gaussian_ut
 @
 <<[[sf_gaussian_uti.f90]]>>=
 <<File header>>
 
 module sf_gaussian_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use rng_base
   use sf_aux
   use sf_base
 
   use sf_gaussian
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<SF gaussian: test declarations>>
 
 contains
 
 <<SF gaussian: tests>>
 
 end module sf_gaussian_uti
 @ %def sf_gaussian_ut
 @ API: driver for the unit tests below.
 <<SF gaussian: public test>>=
   public :: sf_gaussian_test
 <<SF gaussian: test driver>>=
   subroutine sf_gaussian_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF gaussian: execute tests>>
   end subroutine sf_gaussian_test
 
 @ %def sf_gaussian_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF gaussian: execute tests>>=
   call test (sf_gaussian_1, "sf_gaussian_1", &
        "structure function configuration", &
        u, results)
 <<SF gaussian: test declarations>>=
   public :: sf_gaussian_1
 <<SF gaussian: tests>>=
   subroutine sf_gaussian_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
     class(rng_factory_t), allocatable :: rng_factory
 
     write (u, "(A)")  "* Test output: sf_gaussian_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &gaussian-spread structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (gaussian_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (gaussian_data_t)
        call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_gaussian_1"
 
   end subroutine sf_gaussian_1
 
 @ %def sf_gaussian_1
 @
 \subsubsection{Probe the structure-function object}
 Active the beam event reader, generate an event.
 <<SF gaussian: execute tests>>=
   call test (sf_gaussian_2, "sf_gaussian_2", &
        "generate event", &
        u, results)
 <<SF gaussian: test declarations>>=
   public :: sf_gaussian_2
 <<SF gaussian: tests>>=
   subroutine sf_gaussian_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: x_free, f
     integer :: i
 
     write (u, "(A)")  "* Test output: sf_gaussian_2"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &gaussian-spread structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (gaussian_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (gaussian_data_t)
        call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set dummy parameters and generate x."
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call pacify (rb, 1.e-8_default)
     call pacify (xb, 1.e-8_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate more events"
     write (u, "(A)")
 
     select type (sf_int)
     type is (gaussian_t)
        do i = 1, 3
           call sf_int%generate_free (r, rb, x_free)
           write (u, "(A,9(1x,F10.7))")  "r =", r
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_gaussian_2"
 
   end subroutine sf_gaussian_2
 
 @ %def sf_gaussian_2
 @
 \clearpage
 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Using beam event data}
 
 Instead of an analytic beam description, beam data may be provided in
 form of an event file.  In its most simple form, the event file
 contains pairs of $x$ values, relative to nominal beam energies.  More
 advanced formats may include polarization, etc.  The current
 implementation carries beam polarization through, if specified.
 
 The code is very similar to the energy scan described above.
 
 However, we must include a file-handle manager for the beam-event
 files.  Two different processes may access a given beam-event file at
 the same time (i.e., serially but alternating).  Accessing an open
 file from two different units is non-standard and not supported by all
 compilers.  Therefore, we keep a global registry of open files,
 associated units, and reference counts.  The [[beam_events_t]] objects
 act as proxies to this registry.
 <<[[sf_beam_events.f90]]>>=
 <<File header>>
 
 module sf_beam_events
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use file_registries
   use diagnostics
   use lorentz
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF beam events: public>>
 
 <<SF beam events: types>>
 
 <<SF beam events: variables>>
 
 contains
 
 <<SF beam events: procedures>>
 
 end module sf_beam_events
 @ %def sf_beam_events
 @
 \subsection{The beam-data file registry}
 We manage data files via the [[file_registries]] module.  To this end,
 we keep the registry as a private module variable here.
 
 This is public only for the unit tests.
 <<SF beam events: public>>=
   public :: beam_file_registry
 <<SF beam events: variables>>=
   type(file_registry_t), save :: beam_file_registry
 
 @ %def beam_file_registry
 @
 \subsection{Data type}
 <<SF beam events: public>>=
   public :: beam_events_data_t
 <<SF beam events: types>>=
   type, extends(sf_data_t) :: beam_events_data_t
      private
      type(flavor_t), dimension(2) :: flv_in
      type(string_t) :: dir
      type(string_t) :: file
      type(string_t) :: fqn
      integer :: unit = 0
      logical :: warn_eof = .true.
    contains
    <<SF beam events: beam events data: TBP>>
   end type beam_events_data_t
 
 @  %def beam_events_data_t
 <<SF beam events: beam events data: TBP>>=
   procedure :: init => beam_events_data_init
 <<SF beam events: procedures>>=
   subroutine beam_events_data_init (data, model, pdg_in, dir, file, warn_eof)
     class(beam_events_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     type(string_t), intent(in) :: dir
     type(string_t), intent(in) :: file
     logical, intent(in), optional :: warn_eof
     if (any (pdg_array_get_length (pdg_in) /= 1)) then
        call msg_fatal ("Beam events: incoming beam particles must be unique")
     end if
     call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
     call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
     data%dir = dir
     data%file = file
     if (present (warn_eof))  data%warn_eof = warn_eof
   end subroutine beam_events_data_init
 
 @ %def beam_events_data_init
 @ Return true since this spectrum is always in generator mode.
 <<SF beam events: beam events data: TBP>>=
   procedure :: is_generator => beam_events_data_is_generator
 <<SF beam events: procedures>>=
   function beam_events_data_is_generator (data) result (flag)
     class(beam_events_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function beam_events_data_is_generator
 
 @ %def beam_events_data_is_generator
 @ The number of parameters is two.  They are free parameters.
 <<SF beam events: beam events data: TBP>>=
   procedure :: get_n_par => beam_events_data_get_n_par
 <<SF beam events: procedures>>=
   function beam_events_data_get_n_par (data) result (n)
     class(beam_events_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function beam_events_data_get_n_par
 
 @ %def beam_events_data_get_n_par
 <<SF beam events: beam events data: TBP>>=
   procedure :: get_pdg_out => beam_events_data_get_pdg_out
 <<SF beam events: procedures>>=
   subroutine beam_events_data_get_pdg_out (data, pdg_out)
     class(beam_events_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%flv_in(i)%get_pdg ()
     end do
   end subroutine beam_events_data_get_pdg_out
 
 @ %def beam_events_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF beam events: beam events data: TBP>>=
   procedure :: allocate_sf_int => beam_events_data_allocate_sf_int
 <<SF beam events: procedures>>=
   subroutine beam_events_data_allocate_sf_int (data, sf_int)
     class(beam_events_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (beam_events_t :: sf_int)
   end subroutine beam_events_data_allocate_sf_int
 
 @ %def beam_events_data_allocate_sf_int
 @ Output
 <<SF beam events: beam events data: TBP>>=
   procedure :: write => beam_events_data_write
 <<SF beam events: procedures>>=
   subroutine beam_events_data_write (data, unit, verbose)
     class(beam_events_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Beam-event file data:"
     write (u, "(3x,A,A,A,A)") "prt_in = ", &
          char (data%flv_in(1)%get_name ()), &
          ", ", char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,A,A)") "file   = '", char (data%file), "'"
     write (u, "(3x,A,I0)")  "unit   = ", data%unit
     write (u, "(3x,A,L1)")  "warn   = ", data%warn_eof
   end subroutine beam_events_data_write
 
 @ %def beam_events_data_write
 @ The data file needs to be opened and closed explicitly.  The
 open/close message is communicated to the file handle registry, which
 does the actual work.
 
 We determine first whether to look in the local directory or in the
 given system directory.
 <<SF beam events: beam events data: TBP>>=
   procedure :: open => beam_events_data_open
   procedure :: close => beam_events_data_close
 <<SF beam events: procedures>>=
   subroutine beam_events_data_open (data)
     class(beam_events_data_t), intent(inout) :: data
     logical :: exist
     if (data%unit == 0) then
        data%fqn = data%file
        if (data%fqn == "") &
             call msg_fatal ("Beam events: $beam_events_file is not set")
        inquire (file = char (data%fqn), exist = exist)
        if (.not. exist) then
           data%fqn = data%dir // "/" // data%file
           inquire (file = char (data%fqn), exist = exist)
           if (.not. exist) then
              data%fqn = ""
              call msg_fatal ("Beam events: file '" &
                   // char (data%file) // "' not found")
              return
           end if
        end if
        call msg_message ("Beam events: reading from file '" &
             // char (data%file) // "'")
        call beam_file_registry%open (data%fqn, data%unit)
     else
        call msg_bug ("Beam events: file '" &
          // char (data%file) // "' is already open")
     end if
   end subroutine beam_events_data_open
 
   subroutine beam_events_data_close (data)
     class(beam_events_data_t), intent(inout) :: data
     if (data%unit /= 0) then
        call beam_file_registry%close (data%fqn)
        call msg_message ("Beam events: closed file '" &
          // char (data%file) // "'")
        data%unit = 0
     end if
   end subroutine beam_events_data_close
 
 @ %def beam_events_data_close
 @ Return the beam event file.
 <<SF beam events: beam events data: TBP>>=
   procedure :: get_beam_file => beam_events_data_get_beam_file
 <<SF beam events: procedures>>=
   function beam_events_data_get_beam_file (data) result (file)
     class(beam_events_data_t), intent(in) :: data
     type(string_t) :: file
     file = "Beam events: " // data%file
   end function beam_events_data_get_beam_file
 
 @ %def beam_events_data_get_beam_file
 @
 \subsection{The beam events object}
 Flavor and polarization carried through, no radiated particles.
 <<SF beam events: public>>=
   public :: beam_events_t
 <<SF beam events: types>>=
   type, extends (sf_int_t) :: beam_events_t
      type(beam_events_data_t), pointer :: data => null ()
      integer :: count = 0
    contains
    <<SF beam events: beam events: TBP>>
   end type beam_events_t
 
 @ %def beam_events_t
 @ Type string: show beam events file.
 <<SF beam events: beam events: TBP>>=
   procedure :: type_string => beam_events_type_string
 <<SF beam events: procedures>>=
   function beam_events_type_string (object) result (string)
     class(beam_events_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "Beam events: " // object%data%file
     else
        string = "Beam events: [undefined]"
     end if
   end function beam_events_type_string
 
 @ %def beam_events_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF beam events: beam events: TBP>>=
   procedure :: write => beam_events_write
 <<SF beam events: procedures>>=
   subroutine beam_events_write (object, unit, testflag)
     class(beam_events_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "Beam events data: [undefined]"
     end if
   end subroutine beam_events_write
 
 @ %def beam_events_write
 @
 <<SF beam events: beam events: TBP>>=
   procedure :: init => beam_events_init
 <<SF beam events: procedures>>=
   subroutine beam_events_init (sf_int, data)
     class(beam_events_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     real(default), dimension(2) :: m2
     real(default), dimension(0) :: mr2
     type(quantum_numbers_mask_t), dimension(4) :: mask
     integer, dimension(4) :: hel_lock
     type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
     type(polarization_t), target :: pol1, pol2
     type(polarization_iterator_t) :: it_hel1, it_hel2
     integer :: i
     select type (data)
     type is (beam_events_data_t)
        m2 = data%flv_in%get_mass () ** 2
        hel_lock = [3, 4, 1, 2]
        mask = quantum_numbers_mask (.false., .false., .false.)
        call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
        sf_int%data => data
        do i = 1, 2
           call qn_fc(i)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
           call qn_fc(i+2)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
        end do
        call pol1%init_generic (data%flv_in(1))
        call it_hel1%init (pol1)
        do while (it_hel1%is_valid ())
           qn_hel(1) = it_hel1%get_quantum_numbers ()
           qn_hel(3) = it_hel1%get_quantum_numbers ()
           call pol2%init_generic (data%flv_in(2))
           call it_hel2%init (pol2)
           do while (it_hel2%is_valid ())
              qn_hel(2) = it_hel2%get_quantum_numbers ()
              qn_hel(4) = it_hel2%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc
              call sf_int%add_state (qn)
              call it_hel2%advance ()
           end do
           ! call pol2%final ()
           call it_hel1%advance ()
        end do
        ! call pol1%final ()
        call sf_int%freeze ()
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%data%open ()
        sf_int%status = SF_INITIAL
     end select
   end subroutine beam_events_init
 
 @ %def beam_events_init
 @ This spectrum type needs a finalizer, which closes the data file.
 <<SF beam events: beam events: TBP>>=
   procedure :: final => sf_beam_events_final
 <<SF beam events: procedures>>=
   subroutine sf_beam_events_final (object)
     class(beam_events_t), intent(inout) :: object
     call object%data%close ()
     call object%interaction_t%final ()
   end subroutine sf_beam_events_final
 
 @ %def sf_beam_events_final
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF beam events: beam events: TBP>>=
   procedure :: is_generator => beam_events_is_generator
 <<SF beam events: procedures>>=
   function beam_events_is_generator (sf_int) result (flag)
     class(beam_events_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function beam_events_is_generator
 
 @ %def beam_events_is_generator
 @ Generate free parameters.  We read them from file.
 <<SF beam events: beam events: TBP>>=
   procedure :: generate_free => beam_events_generate_free
 <<SF beam events: procedures>>=
   recursive subroutine beam_events_generate_free (sf_int, r, rb,  x_free)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     integer :: iostat
     associate (data => sf_int%data)
       if (data%unit /= 0) then
          read (data%unit, fmt=*, iostat=iostat)  r
          if (iostat > 0) then
             write (msg_buffer, "(A,I0,A)") &
                  "Beam events: I/O error after reading ", sf_int%count, &
                  " events"
             call msg_fatal ()
          else if (iostat < 0) then
             if (sf_int%count == 0) then
                call msg_fatal ("Beam events: file is empty")
             else if (sf_int%data%warn_eof) then
                write (msg_buffer, "(A,I0,A)") &
                     "Beam events: End of file after reading ", sf_int%count, &
                     " events, rewinding"
                call msg_warning ()
             end if
             rewind (data%unit)
             sf_int%count = 0
             call sf_int%generate_free (r, rb, x_free)
          else
             sf_int%count = sf_int%count + 1
             rb = 1 - r
             x_free = x_free * product (r)
          end if
       else
          call msg_bug ("Beam events: file is not open for reading")
       end if
     end associate
   end subroutine beam_events_generate_free
 
 @ %def beam_events_generate_free
 @ Set kinematics.  Trivial transfer since this is a pure generator.
 The [[map]] flag doesn't apply.
 <<SF beam events: beam events: TBP>>=
   procedure :: complete_kinematics => beam_events_complete_kinematics
 <<SF beam events: procedures>>=
   subroutine beam_events_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("Beam events: map flag not supported")
     else
        x = r
        xb= rb
        f = 1
     end if
     call sf_int%reduce_momenta (x)
   end subroutine beam_events_complete_kinematics
 
 @ %def beam_events_complete_kinematics
 @ Compute inverse kinematics.  Trivial in this case.
 <<SF beam events: beam events: TBP>>=
   procedure :: inverse_kinematics => beam_events_inverse_kinematics
 <<SF beam events: procedures>>=
   subroutine beam_events_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("Beam events: map flag not supported")
     else
        r = x
        rb= xb
        f = 1
     end if
     if (set_mom) then
        call sf_int%reduce_momenta (x)
     end if
   end subroutine beam_events_inverse_kinematics
 
 @ %def beam_events_inverse_kinematics
 @
 \subsection{Beam events application}
 Trivial, just set the unit weight.
 <<SF beam events: beam events: TBP>>=
   procedure :: apply => beam_events_apply
 <<SF beam events: procedures>>=
   subroutine beam_events_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f
     f = 1
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine beam_events_apply
 
 @ %def beam_events_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_beam_events_ut.f90]]>>=
 <<File header>>
 
 module sf_beam_events_ut
   use unit_tests
   use sf_beam_events_uti
 
 <<Standard module head>>
 
 <<SF beam events: public test>>
 
 contains
 
 <<SF beam events: test driver>>
 
 end module sf_beam_events_ut
 @ %def sf_beam_events_ut
 @
 <<[[sf_beam_events_uti.f90]]>>=
 <<File header>>
 
 module sf_beam_events_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_aux
   use sf_base
 
   use sf_beam_events
 
 <<Standard module head>>
 
 <<SF beam events: test declarations>>
 
 contains
 
 <<SF beam events: tests>>
 
 end module sf_beam_events_uti
 @ %def sf_beam_events_ut
 @ API: driver for the unit tests below.
 <<SF beam events: public test>>=
   public :: sf_beam_events_test
 <<SF beam events: test driver>>=
   subroutine sf_beam_events_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF beam events: execute tests>>
   end subroutine sf_beam_events_test
 
 @ %def sf_beam_events_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF beam events: execute tests>>=
   call test (sf_beam_events_1, "sf_beam_events_1", &
        "structure function configuration", &
        u, results)
 <<SF beam events: test declarations>>=
   public :: sf_beam_events_1
 <<SF beam events: tests>>=
   subroutine sf_beam_events_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_beam_events_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &beam-events structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (beam_events_data_t :: data)
     select type (data)
     type is (beam_events_data_t)
        call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat"))
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_beam_events_1"
 
   end subroutine sf_beam_events_1
 
 @ %def sf_beam_events_1
 @
 \subsubsection{Probe the structure-function object}
 Active the beam event reader, generate an event.
 <<SF beam events: execute tests>>=
   call test (sf_beam_events_2, "sf_beam_events_2", &
        "generate event", &
        u, results)
 <<SF beam events: test declarations>>=
   public :: sf_beam_events_2
 <<SF beam events: tests>>=
   subroutine sf_beam_events_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: x_free, f
     integer :: i
 
     write (u, "(A)")  "* Test output: sf_beam_events_2"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &beam-events structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (beam_events_data_t :: data)
     select type (data)
     type is (beam_events_data_t)
        call data%init (model, pdg_in, &
             var_str (""), var_str ("test_beam_events.dat"))
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set dummy parameters and generate x."
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
     select type (sf_int)
     type is (beam_events_t)
        write (u, "(A,1x,I0)")  "count =", sf_int%count
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate more events, rewind"
     write (u, "(A)")
 
     select type (sf_int)
     type is (beam_events_t)
        do i = 1, 3
           call sf_int%generate_free (r, rb, x_free)
           write (u, "(A,9(1x,F10.7))")  "r =", r
           write (u, "(A,1x,I0)")  "count =", sf_int%count
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_beam_events_2"
 
   end subroutine sf_beam_events_2
 
 @ %def sf_beam_events_2
 @
 \subsubsection{Check the file handle registry}
 Open and close some files, checking the registry contents.
 <<SF beam events: execute tests>>=
   call test (sf_beam_events_3, "sf_beam_events_3", &
        "check registry", &
        u, results)
 <<SF beam events: test declarations>>=
   public :: sf_beam_events_3
 <<SF beam events: tests>>=
   subroutine sf_beam_events_3 (u)
     integer, intent(in) :: u
     integer :: u1
 
     write (u, "(A)")  "* Test output: sf_beam_events_2"
     write (u, "(A)")  "*   Purpose: check file handle registry"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create some empty files"
     write (u, "(A)")
 
     u1 = free_unit ()
     open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new")
     close (u1)
     open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new")
     close (u1)
     open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new")
     close (u1)
 
     write (u, "(A)")  "* Empty registry"
     write (u, "(A)")
 
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Insert three entries"
     write (u, "(A)")
 
     call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp"))
     call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Open a second channel"
     write (u, "(A)")
 
     call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Close second entry twice"
     write (u, "(A)")
 
     call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Close last entry"
     write (u, "(A)")
 
     call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Close remaining entry"
     write (u, "(A)")
 
     call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     open (u1, file = "sf_beam_events_f1.tmp", action="write")
     close (u1, status = "delete")
     open (u1, file = "sf_beam_events_f2.tmp", action="write")
     close (u1, status = "delete")
     open (u1, file = "sf_beam_events_f3.tmp", action="write")
     close (u1, status = "delete")
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_beam_events_3"
 
   end subroutine sf_beam_events_3
 
 @ %def sf_beam_events_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Lepton collider beamstrahlung: CIRCE1}
 
 <<[[sf_circe1.f90]]>>=
 <<File header>>
 
 module sf_circe1
 
 <<Use kinds>>
   use kinds, only: double
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_17, FMT_19
   use diagnostics
   use physics_defs, only: ELECTRON, PHOTON
   use lorentz
   use rng_base
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_mappings
   use sf_base
   use circe1, circe1_rng_t => rng_type !NODEP!
 
 <<Standard module head>>
 
 <<SF circe1: public>>
 
 <<SF circe1: types>>
 
 contains
 
 <<SF circe1: procedures>>
 
 end module sf_circe1
 @ %def sf_circe1
 @
 \subsection{Physics}
 Beamstrahlung is applied before ISR.  The [[CIRCE1]] implementation has
 a single structure function for both beams (which makes sense since it
 has to be switched on or off for both beams simultaneously).
 Nevertheless it is factorized:
 
 The functional form in the [[CIRCE1]] parameterization is defined for
 electrons or photons
 \begin{equation}
   f(x) = \alpha\,x^\beta\,(1-x)^\gamma
 \end{equation}
 for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case).  In the
 remaining interval, the standard form is zero, with a delta
 singularity at $x=1$ (resp.\ $x=0$).  Equivalently, the delta part may be
 distributed uniformly among this interval.  This latter form is
 implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and
 is used here.
 
 The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]]
 structure function. Its default value is $10^{-5}$.
 The other parameters are the parameterization version and revision
 number, the accelerator type, and the $\sqrt{s}$ value used by
 [[CIRCE1]]. The chattiness can also be set.
 
 Since the energy is distributed in a narrow region around unity (for
 electrons) or zero (for photons), it is advantageous to map the
 interval first.  The mapping is controlled by the parameter
 [[circe1\_epsilon]] which is taken from the [[CIRCE1]]
 internal data structure.
 
 The $\sqrt{s}$ value, if not explicitly set, is taken from the
 process data.  Note that interpolating $\sqrt{s}$ is not recommended;
 one should rather choose one of the distinct values known to [[CIRCE1]].
 
 \subsection{The CIRCE1 data block}
 The CIRCE1 parameters are: The incoming flavors, the flags whether the photon
 or the lepton is the parton in the hard interaction, the flags for the
 generation mode (generator/mapping/no mapping), the mapping parameter
 $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]],
 [[rev]], [[acc]], [[chat]].
 
 In generator mode, the $x$ values are actually discarded and a random number
 generator is used instead.
 <<SF circe1: public>>=
   public :: circe1_data_t
 <<SF circe1: types>>=
   type, extends (sf_data_t) :: circe1_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(2) :: flv_in
      integer, dimension(2) :: pdg_in
      real(default), dimension(2) :: m_in = 0
      logical, dimension(2) :: photon = .false.
      logical :: generate = .false.
      class(rng_factory_t), allocatable :: rng_factory
      real(default) :: sqrts = 0
      real(default) :: eps = 0
      integer :: ver = 0
      integer :: rev = 0
      character(6) :: acc = "?"
      integer :: chat = 0
      logical :: with_radiation = .false.
    contains
      <<SF circe1: circe1 data: TBP>>
   end type circe1_data_t
 
 @ %def circe1_data_t
 @
 <<SF circe1: circe1 data: TBP>>=
   procedure :: init => circe1_data_init
 <<SF circe1: procedures>>=
   subroutine circe1_data_init &
        (data, model, pdg_in, sqrts, eps, out_photon, &
         ver, rev, acc, chat, with_radiation)
     class(circe1_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), intent(in) :: sqrts
     real(default), intent(in) :: eps
     logical, dimension(2), intent(in) :: out_photon
     character(*), intent(in) :: acc
     integer, intent(in) :: ver, rev, chat
     logical, intent(in) :: with_radiation
     data%model => model
     if (any (pdg_array_get_length (pdg_in) /= 1)) then
        call msg_fatal ("CIRCE1: incoming beam particles must be unique")
     end if
     call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
     call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
     data%pdg_in = data%flv_in%get_pdg ()
     data%m_in = data%flv_in%get_mass ()
     data%sqrts = sqrts
     data%eps = eps
     data%photon = out_photon
     data%ver = ver
     data%rev = rev
     data%acc = acc
     data%chat = chat
     data%with_radiation = with_radiation
     call data%check ()
     call circex (0.d0, 0.d0, dble (data%sqrts), &
          data%acc, data%ver, data%rev, data%chat)
   end subroutine circe1_data_init
 
 @ %def circe1_data_init
 @ Activate the generator mode.  We import a RNG factory into the data
 type, which can then spawn RNG generator objects.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: set_generator_mode => circe1_data_set_generator_mode
 <<SF circe1: procedures>>=
   subroutine circe1_data_set_generator_mode (data, rng_factory)
     class(circe1_data_t), intent(inout) :: data
     class(rng_factory_t), intent(inout), allocatable :: rng_factory
     data%generate = .true.
     call move_alloc (from = rng_factory, to = data%rng_factory)
   end subroutine circe1_data_set_generator_mode
 
 @ %def circe1_data_set_generator_mode
 @ Handle error conditions.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: check => circe1_data_check
 <<SF circe1: procedures>>=
   subroutine circe1_data_check (data)
     class(circe1_data_t), intent(in) :: data
     type(flavor_t) :: flv_electron, flv_photon
     call flv_electron%init (ELECTRON, data%model)
     call flv_photon%init (PHOTON, data%model)
     if (.not. flv_electron%is_defined () &
          .or. .not. flv_photon%is_defined ()) then
        call msg_fatal ("CIRCE1: model must contain photon and electron")
     end if
     if (any (abs (data%pdg_in) /= ELECTRON) &
          .or. (data%pdg_in(1) /= - data%pdg_in(2))) then
        call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions")
     end if
     if (data%eps <= 0) then
        call msg_error ("CIRCE1: circe1_eps = 0: integration will &
             &miss x=1 peak")
     end if
   end subroutine circe1_data_check
 
 @ %def circe1_data_check
 @ Output
 <<SF circe1: circe1 data: TBP>>=
   procedure :: write => circe1_data_write
 <<SF circe1: procedures>>=
   subroutine circe1_data_write (data, unit, verbose)
     class(circe1_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     logical :: verb
     verb = .false.;  if (present (verbose))  verb = verbose
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "CIRCE1 data:"
     write (u, "(3x,A,2(1x,A))") "prt_in   =", &
          char (data%flv_in(1)%get_name ()), &
          char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,2(1x,L1))")  "photon   =", data%photon
     write (u, "(3x,A,L1)")        "generate = ", data%generate
     write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in     =", data%m_in
     write (u, "(3x,A," // FMT_19 // ")") "sqrts    = ", data%sqrts
     write (u, "(3x,A," // FMT_19 // ")") "eps      = ", data%eps
     write (u, "(3x,A,I0)") "ver      = ", data%ver
     write (u, "(3x,A,I0)") "rev      = ", data%rev
     write (u, "(3x,A,A)")  "acc      = ", data%acc
     write (u, "(3x,A,I0)") "chat     = ", data%chat
     write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation
     if (data%generate) then
        if (verb) then
           call data%rng_factory%write (u)
        end if
     end if
   end subroutine circe1_data_write
 
 @ %def circe1_data_write
 @ Return true if this structure function is in generator mode.  In
 that case, all parameters are free, otherwise bound.  (We do not
 support mixed cases.)  Default is: no generator.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: is_generator => circe1_data_is_generator
 <<SF circe1: procedures>>=
   function circe1_data_is_generator (data) result (flag)
     class(circe1_data_t), intent(in) :: data
     logical :: flag
     flag = data%generate
   end function circe1_data_is_generator
 
 @ %def circe1_data_is_generator
 @ The number of parameters is two, collinear splitting for the two beams.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_n_par => circe1_data_get_n_par
 <<SF circe1: procedures>>=
   function circe1_data_get_n_par (data) result (n)
     class(circe1_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function circe1_data_get_n_par
 
 @ %def circe1_data_get_n_par
 @ Return the outgoing particles PDG codes. This is either the incoming
 particle (if a photon is radiated), or the photon if that is the particle
 of the hard interaction. The latter is determined via the [[photon]]
 flag. There are two entries for the two beams.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_pdg_out => circe1_data_get_pdg_out
 <<SF circe1: procedures>>=
   subroutine circe1_data_get_pdg_out (data, pdg_out)
     class(circe1_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        if (data%photon(i)) then
           pdg_out(i) = PHOTON
        else
           pdg_out(i) = data%pdg_in(i)
        end if
     end do
   end subroutine circe1_data_get_pdg_out
 
 @ %def circe1_data_get_pdg_out
 @ This variant is not inherited, it returns integers.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_pdg_int => circe1_data_get_pdg_int
 <<SF circe1: procedures>>=
   function circe1_data_get_pdg_int (data) result (pdg)
     class(circe1_data_t), intent(in) :: data
     integer, dimension(2) :: pdg
     integer :: i
     do i = 1, 2
        if (data%photon(i)) then
           pdg(i) = PHOTON
        else
           pdg(i) = data%pdg_in(i)
        end if
     end do
   end function circe1_data_get_pdg_int
 
 @ %def circe1_data_get_pdg_int
 @ Allocate the interaction record.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: allocate_sf_int => circe1_data_allocate_sf_int
 <<SF circe1: procedures>>=
   subroutine circe1_data_allocate_sf_int (data, sf_int)
     class(circe1_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (circe1_t :: sf_int)
   end subroutine circe1_data_allocate_sf_int
 
 @ %def circe1_data_allocate_sf_int
 @ Return the accelerator type.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_beam_file => circe1_data_get_beam_file
 <<SF circe1: procedures>>=
   function circe1_data_get_beam_file (data) result (file)
     class(circe1_data_t), intent(in) :: data
     type(string_t) :: file
     file = "CIRCE1: " // data%acc
   end function circe1_data_get_beam_file
 
 @ %def circe1_data_get_beam_file
 @
 \subsection{Random Number Generator for CIRCE}
 The CIRCE implementation now supports a generic random-number
 generator object that allows for a local state as a component.  To
 support this, we must extend the abstract type provided by CIRCE and
 delegate the generator call to the (also abstract) RNG used by WHIZARD.
 <<SF circe1: types>>=
   type, extends (circe1_rng_t) :: rng_obj_t
      class(rng_t), allocatable :: rng
    contains
      procedure :: generate => rng_obj_generate
   end type rng_obj_t
 
 @ %def rng_obj_t
 <<SF circe1: procedures>>=
   subroutine rng_obj_generate (rng_obj, u)
     class(rng_obj_t), intent(inout) :: rng_obj
     real(double), intent(out) :: u
     real(default) :: x
     call rng_obj%rng%generate (x)
     u = x
   end subroutine rng_obj_generate
 
 @ %def rng_obj_generate
 @
 \subsection{The CIRCE1 object}
 This is a $2\to 4$ interaction, where, depending on the parameters, any two of
 the four outgoing particles are connected to the hard interactions, the others
 are radiated.  Knowing that all particles are colorless, we do not have to
 deal with color.
 
 The flavors are sorted such that the first two particles are the incoming
 leptons, the next two are the radiated particles, and the last two are the
 partons initiating the hard interaction.
 
 CIRCE1 does not support polarized beams explicitly.  For simplicity, we
 nevertheless carry beam polarization through to the outgoing electrons and
 make the photons unpolarized.
 
 In the case that no radiated particle is kept (which actually is the
 default), polarization is always transferred to the electrons, too. If
 there is a recoil photon in the event, the radiated particles are 3
 and 4, respectively, and 5 and 6 are the outgoing ones (triggering the
 hard scattering process), while in the case of no radiation, the
 outgoing particles are 3 and 4, respectively. In the case of the
 electron being the radiated particle, helicity is not kept.
 <<SF circe1: public>>=
   public :: circe1_t
 <<SF circe1: types>>=
   type, extends (sf_int_t) :: circe1_t
      type(circe1_data_t), pointer :: data => null ()
      real(default), dimension(2) :: x = 0
      real(default), dimension(2) :: xb= 0
      real(default) :: f = 0
      logical, dimension(2) :: continuum = .true.
      logical, dimension(2) :: peak = .true.
      type(rng_obj_t) :: rng_obj
    contains
    <<SF circe1: circe1: TBP>>
   end type circe1_t
 
 @ %def circe1_t
 @ Type string: has to be here, but there is no string variable on which CIRCE1
 depends. Hence, a dummy routine.
 <<SF circe1: circe1: TBP>>=
   procedure :: type_string => circe1_type_string
 <<SF circe1: procedures>>=
   function circe1_type_string (object) result (string)
     class(circe1_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "CIRCE1: beamstrahlung"
     else
        string = "CIRCE1: [undefined]"
     end if
   end function circe1_type_string
 
 @ %def circe1_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF circe1: circe1: TBP>>=
   procedure :: write => circe1_write
 <<SF circe1: procedures>>=
   subroutine circe1_write (object, unit, testflag)
     class(circe1_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%data%generate)  call object%rng_obj%rng%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(3x,A,2(1x," // FMT_17 // "))")  "x =", object%x
           write (u, "(3x,A,2(1x," // FMT_17 // "))")  "xb=", object%xb
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A,1x," // FMT_17 // ")")  "f =", object%f
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "CIRCE1 data: [undefined]"
     end if
   end subroutine circe1_write
 
 @ %def circe1_write
 @
 <<SF circe1: circe1: TBP>>=
   procedure :: init => circe1_init
 <<SF circe1: procedures>>=
   subroutine circe1_init (sf_int, data)
     class(circe1_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     logical, dimension(6) :: mask_h
     type(quantum_numbers_mask_t), dimension(6) :: mask
     integer, dimension(6) :: hel_lock
     type(polarization_t), target :: pol1, pol2
     type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2
     type(flavor_t) :: flv_photon
     type(color_t) :: col0
     real(default), dimension(2) :: mi2, mr2, mo2
     type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2
     type(quantum_numbers_t), dimension(6) :: qn
     type(polarization_iterator_t) :: it_hel1, it_hel2
     hel_lock = 0
     mask_h = .false.
     select type (data)
     type is (circe1_data_t)
        mi2 = data%m_in**2
        if (data%with_radiation) then
           if (data%photon(1)) then
              hel_lock(1) = 3;  hel_lock(3) = 1;  mask_h(5) = .true.
              mr2(1) = mi2(1)
              mo2(1) = 0._default
           else
              hel_lock(1) = 5;  hel_lock(5) = 1;  mask_h(3) = .true.
              mr2(1) = 0._default
              mo2(1) = mi2(1)
           end if
           if (data%photon(2)) then
              hel_lock(2) = 4;  hel_lock(4) = 2;  mask_h(6) = .true.
              mr2(2) = mi2(2)
              mo2(2) = 0._default
           else
              hel_lock(2) = 6;  hel_lock(6) = 2;  mask_h(4) = .true.
              mr2(2) = 0._default
              mo2(2) = mi2(2)
           end if
           mask = quantum_numbers_mask (.false., .false., mask_h)
           call sf_int%base_init (mask, mi2, mr2, mo2, &
                hel_lock = hel_lock)
           sf_int%data => data
           call flv_photon%init (PHOTON, data%model)
           call col0%init ()
           call qn_photon%init (flv_photon, col0)
           call pol1%init_generic (data%flv_in(1))
           call qn_fc1(1)%init (flv = data%flv_in(1), col = col0)
           call pol2%init_generic (data%flv_in(2))
           call qn_fc2(1)%init (flv = data%flv_in(2), col = col0)
           call it_hel1%init (pol1)
 
           do while (it_hel1%is_valid ())
              qn_hel1 = it_hel1%get_quantum_numbers ()
              qn1 = qn_hel1 .merge. qn_fc1(1)
              qn(1) = qn1
              if (data%photon(1)) then
                 qn(3) = qn1;  qn(5) = qn_photon
              else
                 qn(3) = qn_photon;  qn(5) = qn1
              end if
              call it_hel2%init (pol2)
              do while (it_hel2%is_valid ())
                 qn_hel2 = it_hel2%get_quantum_numbers ()
                 qn2 = qn_hel2 .merge. qn_fc2(1)
                 qn(2) = qn2
                 if (data%photon(2)) then
                    qn(4) = qn2;  qn(6) = qn_photon
                 else
                    qn(4) = qn_photon;  qn(6) = qn2
                 end if
                 call qn(3:4)%tag_radiated ()
                 call sf_int%add_state (qn)
                 call it_hel2%advance ()
              end do
              call it_hel1%advance ()
           end do
 !           call pol1%final ()
 !           call pol2%final ()
           call sf_int%freeze ()
           call sf_int%set_incoming ([1,2])
           call sf_int%set_radiated ([3,4])
           call sf_int%set_outgoing ([5,6])
        else
           if (data%photon(1)) then
              mask_h(3) = .true.
              mo2(1) = 0._default
           else
              hel_lock(1) = 3;  hel_lock(3) = 1
              mo2(1) = mi2(1)
           end if
           if (data%photon(2)) then
              mask_h(4) = .true.
              mo2(2) = 0._default
           else
              hel_lock(2) = 4;  hel_lock(4) = 2
              mo2(2) = mi2(2)
           end if
           mask = quantum_numbers_mask (.false., .false., mask_h)
           call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, &
                hel_lock = hel_lock(1:4))
           sf_int%data => data
           call flv_photon%init (PHOTON, data%model)
           call col0%init ()
           call qn_photon%init (flv_photon, col0)
           call pol1%init_generic (data%flv_in(1))
           call qn_fc1(1)%init (flv = data%flv_in(1), col = col0)
           call pol2%init_generic (data%flv_in(2))
           call qn_fc2(1)%init (flv = data%flv_in(2), col = col0)
           call it_hel1%init (pol1)
 
           do while (it_hel1%is_valid ())
              qn_hel1 = it_hel1%get_quantum_numbers ()
              qn1 = qn_hel1 .merge. qn_fc1(1)
              qn(1) = qn1
              if (data%photon(1)) then
                 qn(3) = qn_photon
              else
                 qn(3) = qn1
              end if
              call it_hel2%init (pol2)
              do while (it_hel2%is_valid ())
                 qn_hel2 = it_hel2%get_quantum_numbers ()
                 qn2 = qn_hel2 .merge. qn_fc2(1)
                 qn(2) = qn2
                 if (data%photon(2)) then
                    qn(4) = qn_photon
                 else
                    qn(4) = qn2
                 end if
                 call sf_int%add_state (qn(1:4))
                 call it_hel2%advance ()
              end do
              call it_hel1%advance ()
           end do
 !           call pol1%final ()
 !           call pol2%final ()
           call sf_int%freeze ()
           call sf_int%set_incoming ([1,2])
           call sf_int%set_outgoing ([3,4])
        end if
        sf_int%status = SF_INITIAL
     end select
     if (sf_int%data%generate) then
        call sf_int%data%rng_factory%make (sf_int%rng_obj%rng)
     end if
   end subroutine circe1_init
 
 @ %def circe1_init
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF circe1: circe1: TBP>>=
   procedure :: is_generator => circe1_is_generator
 <<SF circe1: procedures>>=
   function circe1_is_generator (sf_int) result (flag)
     class(circe1_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function circe1_is_generator
 
 @ %def circe1_is_generator
 @ Generate free parameters, if generator mode is on.  Otherwise, the
 parameters will be discarded.
 <<SF circe1: circe1: TBP>>=
   procedure :: generate_free => circe1_generate_free
 <<SF circe1: procedures>>=
   subroutine circe1_generate_free (sf_int, r, rb,  x_free)
     class(circe1_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
 
     if (sf_int%data%generate) then
        call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj)
        rb = 1 - r
        x_free = x_free * product (r)
     else
        r = 0
        rb= 1
     end if
   end subroutine circe1_generate_free
 
 @ %def circe1_generate_free
 @ Generator mode: depending on the particle codes, call one of the
 available [[girce]] generators.  Illegal particle code combinations
 should have been caught during data initialization.
 <<SF circe1: procedures>>=
   subroutine circe_generate (x, pdg, rng_obj)
     real(default), dimension(2), intent(out) :: x
     integer, dimension(2), intent(in) :: pdg
     class(rng_obj_t), intent(inout) :: rng_obj
     real(double) :: xc1, xc2
     select case (abs (pdg(1)))
     case (ELECTRON)
        select case (abs (pdg(2)))
        case (ELECTRON)
           call gircee (xc1, xc2, rng_obj = rng_obj)
        case (PHOTON)
           call girceg (xc1, xc2, rng_obj = rng_obj)
        end select
     case (PHOTON)
        select case (abs (pdg(2)))
        case (ELECTRON)
           call girceg (xc2, xc1, rng_obj = rng_obj)
        case (PHOTON)
           call gircgg (xc1, xc2, rng_obj = rng_obj)
        end select
     end select
     x = [xc1, xc2]
   end subroutine circe_generate
 
 @ %def circe_generate
 @ Set kinematics.  The $r$ values (either from integration or from the
 generator call above) are copied to $x$ unchanged, and $f$ is unity.
 We store the $x$ values, so we can use them for the evaluation later.
 <<SF circe1: circe1: TBP>>=
   procedure :: complete_kinematics => circe1_complete_kinematics
 <<SF circe1: procedures>>=
   subroutine circe1_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(circe1_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     x = r
     xb = rb
     sf_int%x = x
     sf_int%xb= xb
     f = 1
     if (sf_int%data%with_radiation) then
        call sf_int%split_momenta (x, xb)
     else
        call sf_int%reduce_momenta (x)
     end if
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS);  f = 0
     end select
   end subroutine circe1_complete_kinematics
 
 @ %def circe1_complete_kinematics
 @ Compute inverse kinematics.  In generator mode, the $r$ values are
 meaningless, but we copy them anyway.
 <<SF circe1: circe1: TBP>>=
   procedure :: inverse_kinematics => circe1_inverse_kinematics
 <<SF circe1: procedures>>=
   subroutine circe1_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(circe1_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     r = x
     rb = xb
     sf_int%x = x
     sf_int%xb= xb
     f = 1
     if (set_mom) then
        call sf_int%split_momenta (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine circe1_inverse_kinematics
 
 @ %def circe1_inverse_kinematics
 @
 \subsection{CIRCE1 application}
 CIRCE is applied for the two beams at once.  We can safely assume that no
 structure functions are applied before this, so the incoming particles are
 on-shell electrons/positrons.
 
 The scale is ignored.
 <<SF circe1: circe1: TBP>>=
   procedure :: apply => circe1_apply
 <<SF circe1: procedures>>=
   subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(circe1_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default), dimension(2) :: xb
     real(double), dimension(2) :: xc
     real(double), parameter :: one = 1
     associate (data => sf_int%data)
       xc = sf_int%x
       xb = sf_int%xb
       if (data%generate) then
          sf_int%f = 1
       else
          sf_int%f = 0
          if (all (sf_int%continuum)) then
             sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2))
          end if
          if (sf_int%continuum(2) .and. sf_int%peak(1)) then
             sf_int%f = sf_int%f &
                  + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) &
                  * peak (xb(1), data%eps)
          end if
          if (sf_int%continuum(1) .and. sf_int%peak(2)) then
             sf_int%f = sf_int%f &
                  + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) &
                  * peak (xb(2), data%eps)
          end if
          if (all (sf_int%peak)) then
             sf_int%f = sf_int%f &
                  + circe (one, one, data%pdg_in(1), data%pdg_in(2)) &
                  * peak (xb(1), data%eps) * peak (xb(2), data%eps)
          end if
       end if
     end associate
     call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine circe1_apply
 
 @ %def circe1_apply
 @ This is a smeared delta peak at zero, as an endpoint singularity.
 We choose an exponentially decreasing function, starting at zero, with
 integral (from $0$ to $1$) $1-e^{-1/\epsilon}$.  For small $\epsilon$,
 this reduces to one.
 <<SF circe1: procedures>>=
   function peak (x, eps) result (f)
     real(default), intent(in) :: x, eps
     real(default) :: f
     f = exp (-x / eps) / eps
   end function peak
 
 @ %def peak
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_circe1_ut.f90]]>>=
 <<File header>>
 
 module sf_circe1_ut
   use unit_tests
   use sf_circe1_uti
 
 <<Standard module head>>
 
 <<SF circe1: public test>>
 
 contains
 
 <<SF circe1: test driver>>
 
 end module sf_circe1_ut
 @ %def sf_circe1_ut
 @
 <<[[sf_circe1_uti.f90]]>>=
 <<File header>>
 
 module sf_circe1_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use rng_base
   use sf_aux
   use sf_base
 
   use sf_circe1
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<SF circe1: test declarations>>
 
 contains
 
 <<SF circe1: tests>>
 
 end module sf_circe1_uti
 @ %def sf_circe1_ut
 @ API: driver for the unit tests below.
 <<SF circe1: public test>>=
   public :: sf_circe1_test
 <<SF circe1: test driver>>=
   subroutine sf_circe1_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF circe1: execute tests>>
   end subroutine sf_circe1_test
 
 @ %def sf_circe1_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF circe1: execute tests>>=
   call test (sf_circe1_1, "sf_circe1_1", &
        "structure function configuration", &
        u, results)
 <<SF circe1: test declarations>>=
   public :: sf_circe1_1
 <<SF circe1: tests>>=
   subroutine sf_circe1_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_circe1_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &CIRCE structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (circe1_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (circe1_data_t)
        call data%init (model, pdg_in, &
             sqrts = 500._default, &
             eps = 1e-6_default, &
             out_photon = [.false., .false.], &
             ver = 0, &
             rev = 0, &
             acc = "SBAND", &
             chat = 0, &
             with_radiation = .true.)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe1_1"
 
   end subroutine sf_circe1_1
 
 @ %def sf_circe1_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the PDF builtin
 structure function.
 <<SF circe1: execute tests>>=
   call test (sf_circe1_2, "sf_circe1_2", &
        "structure function instance", &
        u, results)
 <<SF circe1: test declarations>>=
   public :: sf_circe1_2
 <<SF circe1: tests>>=
   subroutine sf_circe1_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     type(vector4_t), dimension(4) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_circe1_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe1 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (circe1_data_t :: data)
     select type (data)
     type is (circe1_data_t)
        call data%init (model, pdg_in, &
             sqrts = 500._default, &
             eps = 1e-6_default, &
             out_photon = [.false., .false.], &
             ver = 0, &
             rev = 0, &
             acc = "SBAND", &
             chat = 0, &
             with_radiation = .true.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.95,0.85."
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.9_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1, 2])
 
     call sf_int%seed_kinematics ([k1, k2])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe1_2"
 
   end subroutine sf_circe1_2
 
 @ %def sf_circe1_2
 @
 \subsubsection{Generator mode}
 Construct and evaluate a structure function object in generator mode.
 <<SF circe1: execute tests>>=
   call test (sf_circe1_3, "sf_circe1_3", &
        "generator mode", &
        u, results)
 <<SF circe1: test declarations>>=
   public :: sf_circe1_3
 <<SF circe1: tests>>=
   subroutine sf_circe1_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_circe1_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe1 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (circe1_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (circe1_data_t)
        call data%init (model, pdg_in, &
             sqrts = 500._default, &
             eps = 1e-6_default, &
             out_photon = [.false., .false.], &
             ver = 0, &
             rev = 0, &
             acc = "SBAND", &
             chat = 0, &
             with_radiation = .true.)
        call data%set_generator_mode (rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
     select type (sf_int)
     type is (circe1_t)
        call sf_int%rng_obj%rng%init (3)
     end select
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe1_3"
 
   end subroutine sf_circe1_3
 
 @ %def sf_circe1_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2}
 
 <<[[sf_circe2.f90]]>>=
 <<File header>>
 
 module sf_circe2
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use numeric_utils
   use diagnostics
   use os_interface
   use physics_defs, only: PHOTON, ELECTRON
   use lorentz
   use rng_base
   use selectors
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
   use circe2, circe2_rng_t => rng_type !NODEP!
 
 <<Standard module head>>
 
 <<SF circe2: public>>
 
 <<SF circe2: types>>
 
 contains
 
 <<SF circe2: procedures>>
 
 end module sf_circe2
 @ %def sf_circe2
 @
 \subsection{Physics}
 [[CIRCE2]] describes photon spectra
 Beamstrahlung is applied before ISR.  The [[CIRCE2]] implementation has
 a single structure function for both beams (which makes sense since it
 has to be switched on or off for both beams simultaneously).
 
 
 \subsection{The CIRCE2 data block}
 The CIRCE2 parameters are: file and collider specification, incoming
 (= outgoing) particles.  The luminosity is returned by [[circe2_luminosity]].
 <<SF circe2: public>>=
   public :: circe2_data_t
 <<SF circe2: types>>=
   type, extends (sf_data_t) :: circe2_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(2) :: flv_in
      integer, dimension(2) :: pdg_in
      real(default) :: sqrts = 0
      logical :: polarized = .false.
      logical :: beams_polarized = .false.
      class(rng_factory_t), allocatable :: rng_factory
      type(string_t) :: filename
      type(string_t) :: file
      type(string_t) :: design
      real(default) :: lumi = 0
      real(default), dimension(4) :: lumi_hel_frac = 0
      integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1]
      integer, dimension(0:4) :: h2 = [0, -1,  1,-1, 1]
      integer :: error = 1
    contains
      <<SF circe2: circe2 data: TBP>>
   end type circe2_data_t
 
 @ %def circe2_data_t
 <<SF circe2: types>>=
   type(circe2_state) :: circe2_global_state
 
 @
 <<SF circe2: circe2 data: TBP>>=
   procedure :: init => circe2_data_init
 <<SF circe2: procedures>>=
   subroutine circe2_data_init (data, os_data, model, pdg_in, &
        sqrts, polarized, beam_pol, file, design)
     class(circe2_data_t), intent(out) :: data
     type(os_data_t), intent(in) :: os_data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), intent(in) :: sqrts
     logical, intent(in) :: polarized, beam_pol
     type(string_t), intent(in) :: file, design
     integer :: h
     data%model => model
     if (any (pdg_array_get_length (pdg_in) /= 1)) then
        call msg_fatal ("CIRCE2: incoming beam particles must be unique")
     end if
     call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
     call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
     data%pdg_in = data%flv_in%get_pdg ()
     data%sqrts = sqrts
     data%polarized = polarized
     data%beams_polarized = beam_pol
     data%filename = file
     data%design = design
     call data%check_file (os_data)
     call circe2_load (circe2_global_state, trim (char(data%file)), &
             trim (char(data%design)), data%sqrts, data%error)
     call data%check ()
     data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0])
     if (vanishes (data%lumi)) then
        call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.")
     end if
     if (data%polarized) then
        do h = 1, 4
           data%lumi_hel_frac(h) = &
                circe2_luminosity (circe2_global_state, data%pdg_in, &
                             [data%h1(h), data%h2(h)]) &
                / data%lumi
        end do
     end if
   end subroutine circe2_data_init
 
 @ %def circe2_data_init
 @ Activate the generator mode.  We import a RNG factory into the data
 type, which can then spawn RNG generator objects.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: set_generator_mode => circe2_data_set_generator_mode
 <<SF circe2: procedures>>=
   subroutine circe2_data_set_generator_mode (data, rng_factory)
     class(circe2_data_t), intent(inout) :: data
     class(rng_factory_t), intent(inout), allocatable :: rng_factory
     call move_alloc (from = rng_factory, to = data%rng_factory)
   end subroutine circe2_data_set_generator_mode
 
 @ %def circe2_data_set_generator_mode
 @ Check whether the requested data file is in the system directory or
 in the current directory.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: check_file => circe2_check_file
 <<SF circe2: procedures>>=
   subroutine circe2_check_file (data, os_data)
     class(circe2_data_t), intent(inout) :: data
     type(os_data_t), intent(in) :: os_data
     logical :: exist
     type(string_t) :: file
     file = data%filename
     if (file == "") &
          call msg_fatal ("CIRCE2: $circe2_file is not set")
     inquire (file = char (file), exist = exist)
     if (exist) then
        data%file = file
     else
        file = os_data%whizard_circe2path // "/" // data%filename
        inquire (file = char (file), exist = exist)
        if (exist) then
           data%file = file
        else
           call msg_fatal ("CIRCE2: data file '" // char (data%filename) &
                // "' not found")
        end if
     end if
   end subroutine circe2_check_file
 
 @ %def circe2_check_file
 @ Handle error conditions.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: check => circe2_data_check
 <<SF circe2: procedures>>=
   subroutine circe2_data_check (data)
     class(circe2_data_t), intent(in) :: data
     type(flavor_t) :: flv_photon, flv_electron
     call flv_photon%init (PHOTON, data%model)
     if (.not. flv_photon%is_defined ()) then
        call msg_fatal ("CIRCE2: model must contain photon")
     end if
     call flv_electron%init (ELECTRON, data%model)
     if (.not. flv_electron%is_defined ()) then
        call msg_fatal ("CIRCE2: model must contain electron")
     end if
     if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) &
          then
        call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions")
     end if
     select case (data%error)
     case (-1)
        call msg_fatal ("CIRCE2: data file not found.")
     case (-2)
        call msg_fatal ("CIRCE2: beam setup does not match data file.")
     case (-3)
        call msg_fatal ("CIRCE2: invalid format of data file.")
     case (-4)
        call msg_fatal ("CIRCE2: data file too large.")
     end select
   end subroutine circe2_data_check
 
 @ %def circe2_data_check
 @ Output
 <<SF circe2: circe2 data: TBP>>=
   procedure :: write => circe2_data_write
 <<SF circe2: procedures>>=
   subroutine circe2_data_write (data, unit, verbose)
     class(circe2_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, h
     logical :: verb
     verb = .false.;  if (present (verbose))  verb = verbose
     u = given_output_unit (unit)
     write (u, "(1x,A)") "CIRCE2 data:"
     write (u, "(3x,A,A)")       "file   = ", char(data%filename)
     write (u, "(3x,A,A)")       "design = ", char(data%design)
     write (u, "(3x,A," // FMT_19 // ")") "sqrts  = ", data%sqrts
     write (u, "(3x,A,A,A,A)")   "prt_in = ", &
          char (data%flv_in(1)%get_name ()), &
          ", ", char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,L1)")      "polarized  = ", data%polarized
     write (u, "(3x,A,L1)")      "beams pol. = ", data%beams_polarized
     write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi
     if (data%polarized) then
        do h = 1, 4
           write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") &
                data%h1(h), data%h2(h)
           write (u, "(6x, " // FMT_19 // ")")  data%lumi_hel_frac(h)
        end do
     end if
     if (verb) then
        call data%rng_factory%write (u)
     end if
   end subroutine circe2_data_write
 
 @ %def circe2_data_write
 @ This is always in generator mode.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: is_generator => circe2_data_is_generator
 <<SF circe2: procedures>>=
   function circe2_data_is_generator (data) result (flag)
     class(circe2_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function circe2_data_is_generator
 
 @ %def circe2_data_is_generator
 @ The number of parameters is two, collinear splitting for
 the two beams.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: get_n_par => circe2_data_get_n_par
 <<SF circe2: procedures>>=
   function circe2_data_get_n_par (data) result (n)
     class(circe2_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function circe2_data_get_n_par
 
 @ %def circe2_data_get_n_par
 @ Return the outgoing particles PDG codes.  They are equal to the
 incoming ones.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: get_pdg_out => circe2_data_get_pdg_out
 <<SF circe2: procedures>>=
   subroutine circe2_data_get_pdg_out (data, pdg_out)
     class(circe2_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%pdg_in(i)
     end do
   end subroutine circe2_data_get_pdg_out
 
 @ %def circe2_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: allocate_sf_int => circe2_data_allocate_sf_int
 <<SF circe2: procedures>>=
   subroutine circe2_data_allocate_sf_int (data, sf_int)
     class(circe2_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (circe2_t :: sf_int)
   end subroutine circe2_data_allocate_sf_int
 
 @ %def circe2_data_allocate_sf_int
 @ Return the beam file.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: get_beam_file => circe2_data_get_beam_file
 <<SF circe2: procedures>>=
   function circe2_data_get_beam_file (data) result (file)
     class(circe2_data_t), intent(in) :: data
     type(string_t) :: file
     file = "CIRCE2: " // data%filename
   end function circe2_data_get_beam_file
 
 @ %def circe2_data_get_beam_file
 @
 \subsection{Random Number Generator for CIRCE}
 The CIRCE implementation now supports a generic random-number
 generator object that allows for a local state as a component.  To
 support this, we must extend the abstract type provided by CIRCE and
 delegate the generator call to the (also abstract) RNG used by WHIZARD.
 <<SF circe2: types>>=
   type, extends (circe2_rng_t) :: rng_obj_t
      class(rng_t), allocatable :: rng
    contains
      procedure :: generate => rng_obj_generate
   end type rng_obj_t
 
 @ %def rng_obj_t
 <<SF circe2: procedures>>=
   subroutine rng_obj_generate (rng_obj, u)
     class(rng_obj_t), intent(inout) :: rng_obj
     real(default), intent(out) :: u
     real(default) :: x
     call rng_obj%rng%generate (x)
     u = x
   end subroutine rng_obj_generate
 
 @ %def rng_obj_generate
 @
 \subsection{The CIRCE2 object}
 For CIRCE2 spectra it does not make sense to describe the state matrix
 as a radiation interaction, even if photons originate from laser
 backscattering.  Instead, it is a $2\to 2$ interaction where the
 incoming particles are identical to the outgoing ones.
 
 The current implementation of CIRCE2 does support polarization and
 classical correlations, but no entanglement, so the density matrix of
 the outgoing particles is diagonal.  The incoming particles are
 unpolarized (user-defined polarization for beams is meaningless, since
 polarization is described by the data file).  The outgoing particles
 are polarized or polarization-averaged, depending on user request.
 
 When assigning matrix elements, we scan the previously initialized
 state matrix.  For each entry, we extract helicity and call the
 structure function.  In the unpolarized case, the helicity is
 undefined and replaced by value zero.  In the polarized case, there
 are four entries.  If the generator is used, only one entry is nonzero
 in each call.  Which one, is determined by comparing with a previously
 (randomly, distributed by relative luminosity) selected pair of
 helicities.
 <<SF circe2: public>>=
   public :: circe2_t
 <<SF circe2: types>>=
   type, extends (sf_int_t) :: circe2_t
      type(circe2_data_t), pointer :: data => null ()
      type(rng_obj_t) :: rng_obj
      type(selector_t) :: selector
      integer :: h_sel = 0
    contains
    <<SF circe2: circe2: TBP>>
   end type circe2_t
 
 @ %def circe2_t
 @ Type string: show file and design of [[CIRCE2]] structure function.
 <<SF circe2: circe2: TBP>>=
   procedure :: type_string => circe2_type_string
 <<SF circe2: procedures>>=
   function circe2_type_string (object) result (string)
     class(circe2_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "CIRCE2: " // object%data%design
     else
        string = "CIRCE2: [undefined]"
     end if
   end function circe2_type_string
 
 @ %def circe2_type_string
 @
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF circe2: circe2: TBP>>=
   procedure :: write => circe2_write
 <<SF circe2: procedures>>=
   subroutine circe2_write (object, unit, testflag)
     class(circe2_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "CIRCE2 data: [undefined]"
     end if
   end subroutine circe2_write
 
 @ %def circe2_write
 @
 <<SF circe2: circe2: TBP>>=
   procedure :: init => circe2_init
 <<SF circe2: procedures>>=
   subroutine circe2_init (sf_int, data)
     class(circe2_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     logical, dimension(4) :: mask_h
     real(default), dimension(2) :: m2_array
     real(default), dimension(0) :: null_array
     type(quantum_numbers_mask_t), dimension(4) :: mask
     type(quantum_numbers_t), dimension(4) :: qn
     type(helicity_t) :: hel
     type(color_t) :: col0
     integer :: h
     select type (data)
     type is (circe2_data_t)
        if (data%polarized .and. data%beams_polarized) then
           call msg_fatal ("CIRCE2: Beam polarization can't be set &
                &for polarized data file")
        else if (data%beams_polarized) then
           call msg_warning ("CIRCE2: User-defined beam polarization set &
                &for unpolarized CIRCE2 data file")
        end if
        mask_h(1:2) = .not. data%beams_polarized
        mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized)
        mask = quantum_numbers_mask (.false., .false., mask_h)
        m2_array(:) = (data%flv_in(:)%get_mass ())**2
        call sf_int%base_init (mask, m2_array, null_array, m2_array)
        sf_int%data => data
        if (data%polarized) then
           if (vanishes (sum (data%lumi_hel_frac)) .or. &
                any (data%lumi_hel_frac < 0)) then
              call msg_fatal ("CIRCE2: Helicity-dependent lumi " &
                   // "fractions all vanish or",  &
                   [var_str ("are negative: Please inspect the " &
                   // "CIRCE2 file or "), &
                    var_str ("switch off the polarized" // &
                   " option for CIRCE2.")])
           else
              call sf_int%selector%init (data%lumi_hel_frac)
           end if
        end if
        call col0%init ()
        if (data%beams_polarized) then
           do h = 1, 4
              call hel%init (data%h1(h))
              call qn(1)%init &
                   (flv = data%flv_in(1), col = col0, hel = hel)
              call qn(3)%init &
                   (flv = data%flv_in(1), col = col0, hel = hel)
              call hel%init (data%h2(h))
              call qn(2)%init &
                   (flv = data%flv_in(2), col = col0, hel = hel)
              call qn(4)%init &
                   (flv = data%flv_in(2), col = col0, hel = hel)
              call sf_int%add_state (qn)
           end do
        else if (data%polarized) then
           call qn(1)%init (flv = data%flv_in(1), col = col0)
           call qn(2)%init (flv = data%flv_in(2), col = col0)
           do h = 1, 4
              call hel%init (data%h1(h))
              call qn(3)%init &
                   (flv = data%flv_in(1), col = col0, hel = hel)
              call hel%init (data%h2(h))
              call qn(4)%init &
                   (flv = data%flv_in(2), col = col0, hel = hel)
              call sf_int%add_state (qn)
           end do
        else
           call qn(1)%init (flv = data%flv_in(1), col = col0)
           call qn(2)%init (flv = data%flv_in(2), col = col0)
           call qn(3)%init (flv = data%flv_in(1), col = col0)
           call qn(4)%init (flv = data%flv_in(2), col = col0)
           call sf_int%add_state (qn)
        end if
        call sf_int%freeze ()
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%data%rng_factory%make (sf_int%rng_obj%rng)
        sf_int%status = SF_INITIAL
     end select
   end subroutine circe2_init
 
 @ %def circe2_init
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF circe2: circe2: TBP>>=
   procedure :: is_generator => circe2_is_generator
 <<SF circe2: procedures>>=
   function circe2_is_generator (sf_int) result (flag)
     class(circe2_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function circe2_is_generator
 
 @ %def circe2_is_generator
 @ Generate free parameters.  We first select a helicity, which we have
 to store, then generate $x$ values for that helicity.
 <<SF circe2: circe2: TBP>>=
   procedure :: generate_free => circe2_generate_whizard_free
 <<SF circe2: procedures>>=
   subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free)
     class(circe2_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     integer :: h_sel
     if (sf_int%data%polarized) then
        call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel)
     else
        h_sel = 0
     end if
     sf_int%h_sel = h_sel
     call circe2_generate_whizard (r, sf_int%data%pdg_in, &
          [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], &
          sf_int%rng_obj)
     rb = 1 - r
     x_free = x_free * product (r)
   end subroutine circe2_generate_whizard_free
 
 @ %def circe2_generate_whizard_free
 @ Generator mode: call the CIRCE2 generator for the given particles
 and helicities.  (For unpolarized generation, helicities are zero.)
 <<SF circe2: procedures>>=
   subroutine circe2_generate_whizard (x, pdg, hel, rng_obj)
     real(default), dimension(2), intent(out) :: x
     integer, dimension(2), intent(in) :: pdg
     integer, dimension(2), intent(in) :: hel
     class(rng_obj_t), intent(inout) :: rng_obj
     call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel)
   end subroutine circe2_generate_whizard
 
 @ %def circe2_generate_whizard
 @ Set kinematics.  Trivial here.
 <<SF circe2: circe2: TBP>>=
   procedure :: complete_kinematics => circe2_complete_kinematics
 <<SF circe2: procedures>>=
   subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(circe2_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("CIRCE2: map flag not supported")
     else
        x = r
        xb= rb
        f = 1
     end if
     call sf_int%reduce_momenta (x)
   end subroutine circe2_complete_kinematics
 
 @ %def circe2_complete_kinematics
 @ Compute inverse kinematics.
 <<SF circe2: circe2: TBP>>=
   procedure :: inverse_kinematics => circe2_inverse_kinematics
 <<SF circe2: procedures>>=
   subroutine circe2_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(circe2_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("CIRCE2: map flag not supported")
     else
        r = x
        rb= xb
        f = 1
     end if
     if (set_mom) then
        call sf_int%reduce_momenta (x)
     end if
   end subroutine circe2_inverse_kinematics
 
 @ %def circe2_inverse_kinematics
 @
 \subsection{CIRCE2 application}
 This function works on both beams.  In polarized mode, we set only the
 selected helicity.  In unpolarized mode,
 the interaction has only one entry, and the factor is unity.
 <<SF circe2: circe2: TBP>>=
   procedure :: apply => circe2_apply
 <<SF circe2: procedures>>=
   subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(circe2_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     complex(default) :: f
     associate (data => sf_int%data)
       f = 1
       if (data%beams_polarized) then
          call sf_int%set_matrix_element (f)
       else if (data%polarized) then
          call sf_int%set_matrix_element (sf_int%h_sel, f)
       else
          call sf_int%set_matrix_element (1, f)
       end if
     end associate
     sf_int%status = SF_EVALUATED
   end subroutine circe2_apply
 
 @ %def circe2_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_circe2_ut.f90]]>>=
 <<File header>>
 
 module sf_circe2_ut
   use unit_tests
   use sf_circe2_uti
 
 <<Standard module head>>
 
 <<SF circe2: public test>>
 
 contains
 
 <<SF circe2: test driver>>
 
 end module sf_circe2_ut
 @ %def sf_circe2_ut
 @
 <<[[sf_circe2_uti.f90]]>>=
 <<File header>>
 
 module sf_circe2_uti
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use physics_defs, only: PHOTON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use rng_base
   use sf_aux
   use sf_base
 
   use sf_circe2
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<SF circe2: test declarations>>
 
 contains
 
 <<SF circe2: tests>>
 
 end module sf_circe2_uti
 @ %def sf_circe2_ut
 @ API: driver for the unit tests below.
 <<SF circe2: public test>>=
   public :: sf_circe2_test
 <<SF circe2: test driver>>=
   subroutine sf_circe2_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF circe2: execute tests>>
   end subroutine sf_circe2_test
 
 @ %def sf_circe2_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF circe2: execute tests>>=
   call test (sf_circe2_1, "sf_circe2_1", &
        "structure function configuration", &
        u, results)
 <<SF circe2: test declarations>>=
   public :: sf_circe2_1
 <<SF circe2: tests>>=
   subroutine sf_circe2_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
     class(rng_factory_t), allocatable :: rng_factory
 
     write (u, "(A)")  "* Test output: sf_circe2_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &CIRCE structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_qed_test ()
     pdg_in(1) = PHOTON
     pdg_in(2) = PHOTON
 
     allocate (circe2_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize (unpolarized)"
     write (u, "(A)")
 
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .false., &
             beam_pol = .false., &
             file = var_str ("teslagg_500_polavg.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     call data%write (u, verbose = .true.)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize (polarized)"
     write (u, "(A)")
 
     allocate (rng_test_factory_t :: rng_factory)
 
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .true., &
             beam_pol = .false., &
             file = var_str ("teslagg_500.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     call data%write (u, verbose = .true.)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe2_1"
 
   end subroutine sf_circe2_1
 
 @ %def sf_circe2_1
 @
 \subsubsection{Generator mode, unpolarized}
 Construct and evaluate a structure function object in generator mode.
 <<SF circe2: execute tests>>=
   call test (sf_circe2_2, "sf_circe2_2", &
        "generator, unpolarized", &
        u, results)
 <<SF circe2: test declarations>>=
   public :: sf_circe2_2
 <<SF circe2: tests>>=
   subroutine sf_circe2_2 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_circe2_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe2 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_qed_test ()
     call flv(1)%init (PHOTON, model)
     call flv(2)%init (PHOTON, model)
     pdg_in(1) = PHOTON
     pdg_in(2) = PHOTON
 
     call reset_interaction_counter ()
 
     allocate (circe2_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .false., &
             beam_pol = .false., &
             file = var_str ("teslagg_500_polavg.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
     select type (sf_int)
     type is (circe2_t)
        call sf_int%rng_obj%rng%init (3)
     end select
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe2_2"
 
   end subroutine sf_circe2_2
 
 @ %def sf_circe2_2
 @
 \subsubsection{Generator mode, polarized}
 Construct and evaluate a structure function object in generator mode.
 <<SF circe2: execute tests>>=
   call test (sf_circe2_3, "sf_circe2_3", &
        "generator, polarized", &
        u, results)
 <<SF circe2: test declarations>>=
   public :: sf_circe2_3
 <<SF circe2: tests>>=
   subroutine sf_circe2_3 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_circe2_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe2 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_qed_test ()
     call flv(1)%init (PHOTON, model)
     call flv(2)%init (PHOTON, model)
     pdg_in(1) = PHOTON
     pdg_in(2) = PHOTON
 
     call reset_interaction_counter ()
 
     allocate (circe2_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .true., &
             beam_pol = .false., &
             file = var_str ("teslagg_500.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
     select type (sf_int)
     type is (circe2_t)
        call sf_int%rng_obj%rng%init (3)
     end select
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe2_3"
 
   end subroutine sf_circe2_3
 
 @ %def sf_circe2_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{HOPPET interface}
 Interface to the HOPPET wrapper necessary to perform
 the LO vs. NLO matching of processes containing an initial
 b quark.
 <<[[hoppet_interface.f90]]>>=
 <<File header>>
 
 module hoppet_interface
   use lhapdf !NODEP!
 
 <<Standard module head>>
 
   public :: hoppet_init, hoppet_eval
 
 contains
 
   subroutine hoppet_init (pdf_builtin, pdf, pdf_id)
     logical, intent(in) :: pdf_builtin
     type(lhapdf_pdf_t), intent(inout), optional :: pdf
     integer, intent(in), optional :: pdf_id
     external InitForWhizard
     call InitForWhizard (pdf_builtin, pdf, pdf_id)
   end subroutine hoppet_init
 
   subroutine hoppet_eval (x, q, f)
     double precision, intent(in)  :: x, q
     double precision, intent(out) :: f(-6:6)
     external EvalForWhizard
     call EvalForWhizard (x, q, f)
   end subroutine hoppet_eval
 
 end module hoppet_interface
 @ %def hoppet_interface
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Builtin PDF sets}
 For convenience in order not to depend on the external package LHAPDF,
 we ship some PDFs with WHIZARD.
 @
 \subsection{The module}
 <<[[sf_pdf_builtin.f90]]>>=
 <<File header>>
 
 module sf_pdf_builtin
 
 <<Use kinds>>
   use kinds, only: double
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_17
   use diagnostics
   use os_interface
   use physics_defs, only: PROTON, PHOTON, GLUON
   use physics_defs, only: HADRON_REMNANT_SINGLET
   use physics_defs, only: HADRON_REMNANT_TRIPLET
   use physics_defs, only: HADRON_REMNANT_OCTET
   use sm_qcd
   use lorentz
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
   use pdf_builtin !NODEP!
   use hoppet_interface
 
 <<Standard module head>>
 
 <<SF pdf builtin: public>>
 
 <<SF pdf builtin: types>>
 
 <<SF pdf builtin: parameters>>
 
 contains
 
 <<SF pdf builtin: procedures>>
 
 end module sf_pdf_builtin
 @ %def sf_pdf_builtin
 @
 \subsection{Codes for default PDF sets}
 <<SF pdf builtin: parameters>>=
   character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L"
   ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION   = "NONE"
   ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp"
 @ %def PDF_BUILTIN_DEFAULT_SET
 @
 \subsection{The PDF builtin data block}
 The data block holds the incoming flavor (which has to be proton,
 pion, or photon), the corresponding pointer to the global access data
 (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the
 bounds as returned by LHAPDF for the specified set, and a mask that
 determines which partons will be actually in use.
 <<SF pdf builtin: public>>=
   public :: pdf_builtin_data_t
 <<SF pdf builtin: types>>=
   type, extends (sf_data_t) :: pdf_builtin_data_t
      private
      integer :: id = -1
      type (string_t) :: name
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      logical :: invert
      logical :: has_photon
      logical :: photon
      logical, dimension(-6:6) :: mask
      logical :: mask_photon
      logical :: hoppet_b_matching = .false.
    contains
    <<SF pdf builtin: pdf builtin data: TBP>>
   end type pdf_builtin_data_t
 
 @ %def pdf_builtin_data_t
 @ Generate PDF data and initialize the requested set. Pion and photon PDFs
 are disabled at the moment until we ship appropiate structure functions.
 needed.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: init => pdf_builtin_data_init
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_data_init (data, &
        model, pdg_in, name, path, hoppet_b_matching)
     class(pdf_builtin_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: path
     logical, intent(in), optional :: hoppet_b_matching
     data%model => model
     if (pdg_array_get_length (pdg_in) /= 1) &
          call msg_fatal ("PDF: incoming particle must be unique")
     call data%flv_in%init (pdg_array_get (pdg_in, 1), model)
     data%mask = .true.
     data%mask_photon = .true.
     select case (pdg_array_get (pdg_in, 1))
     case (PROTON)
        data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON)
        data%invert = .false.
        data%photon = .false.
     case (-PROTON)
        data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON)
        data%invert = .true.
        data%photon = .false.
        ! case (PIPLUS)
        !    data%name = var_str (PDF_BUILTIN_DEFAULT_PION)
        !    data%invert = .false.
        !    data%photon = .false.
        ! case (-PIPLUS)
        !    data%name = var_str (PDF_BUILTIN_DEFAULT_PION)
        !    data%invert = .true.
        !    data%photon = .false.
        ! case (PHOTON)
        !    data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON)
        !    data%invert = .false.
        !    data%photon = .true.
     case default
        call msg_fatal ("PDF: " &
             // "incoming particle must either proton or antiproton.")
        return
     end select
     data%name = name
     data%id = pdf_get_id (data%name)
     if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name))
     data%has_photon = pdf_provides_photon (data%id)
     if (present (hoppet_b_matching))  data%hoppet_b_matching = hoppet_b_matching
     call pdf_init (data%id, path)
     if (data%hoppet_b_matching)  call hoppet_init (.true., pdf_id = data%id)
   end subroutine pdf_builtin_data_init
 
 @ %def pdf_builtin_data_init
 @ Enable/disable partons explicitly.  If a mask entry is true,
 applying the PDF will generate the corresponding flavor on output.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: set_mask => pdf_builtin_data_set_mask
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_data_set_mask (data, mask)
     class(pdf_builtin_data_t), intent(inout) :: data
     logical, dimension(-6:6), intent(in) :: mask
     data%mask = mask
   end subroutine pdf_builtin_data_set_mask
 
 @ %def pdf_builtin_data_set_mask
 @ Output.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: write => pdf_builtin_data_write
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_data_write (data, unit, verbose)
     class(pdf_builtin_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)")  "PDF builtin data:"
     if (data%id < 0) then
        write (u, "(3x,A)") "[undefined]"
        return
     end if
     write (u, "(3x,A)", advance="no") "flavor       = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A,A)")   "name         = ", char (data%name)
     write (u, "(3x,A,L1)")  "invert       = ", data%invert
     write (u, "(3x,A,L1)")  "has photon   = ", data%has_photon
     write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") &
          "mask         =", &
          data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6)
     write (u, "(3x,A,L1)") "photon mask  = ", data%mask_photon
     write (u, "(3x,A,L1)") "hoppet_b     = ", data%hoppet_b_matching
   end subroutine pdf_builtin_data_write
 
 @ %def pdf_builtin_data_write
 @ The number of parameters is one.  We do not generate transverse momentum.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: get_n_par => pdf_builtin_data_get_n_par
 <<SF pdf builtin: procedures>>=
   function pdf_builtin_data_get_n_par (data) result (n)
     class(pdf_builtin_data_t), intent(in) :: data
     integer :: n
     n = 1
   end function pdf_builtin_data_get_n_par
 
 @ %def pdf_builtin_data_get_n_par
 @ Return the outgoing particle PDG codes.  This is based on the mask.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_data_get_pdg_out (data, pdg_out)
     class(pdf_builtin_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     integer :: n, np, i
     n = count (data%mask)
     np = 0;  if (data%has_photon .and. data%mask_photon)  np = 1
     allocate (pdg1 (n + np))
     pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask)
     if (np == 1)  pdg1(n+np) = PHOTON
     pdg_out(1) = pdg1
   end subroutine pdf_builtin_data_get_pdg_out
 
 @ %def pdf_builtin_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_data_allocate_sf_int (data, sf_int)
     class(pdf_builtin_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (pdf_builtin_t :: sf_int)
   end subroutine pdf_builtin_data_allocate_sf_int
 
 @ %def pdf_builtin_data_allocate_sf_int
 @ Return the numerical PDF set index.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set
 <<SF pdf builtin: procedures>>=
   elemental function pdf_builtin_data_get_pdf_set (data) result (pdf_set)
     class(pdf_builtin_data_t), intent(in) :: data
     integer :: pdf_set
     pdf_set = data%id
   end function pdf_builtin_data_get_pdf_set
 
 @ %def pdf_builtin_data_get_pdf_set
 @
 \subsection{The PDF object}
 The PDF $1\to 2$ interaction which describes
 the splitting of an (anti)proton into a parton and a beam remnant.  We
 stay in the strict forward-splitting limit, but allow some invariant
 mass for the beam remnant such that the outgoing parton is exactly
 massless.  For a real event, we would replace this by a parton
 cascade, where the outgoing partons have virtuality as dictated by
 parton-shower kinematics, and transverse momentum is generated.
 
 The PDF application is a $1\to 2$ splitting process, where the
 particles are ordered as (hadron, remnant, parton).
 
 Polarization is ignored completely.  The beam particle is colorless,
 while partons and beam remnant carry color.  The remnant gets a
 special flavor code.
 <<SF pdf builtin: public>>=
   public :: pdf_builtin_t
 <<SF pdf builtin: types>>=
   type, extends (sf_int_t) :: pdf_builtin_t
      type(pdf_builtin_data_t), pointer :: data => null ()
      real(default) :: x = 0
      real(default) :: q = 0
   contains
   <<SF pdf builtin: pdf builtin: TBP>>
   end type pdf_builtin_t
 
 @ %def pdf_builtin_t
 @ Type string: display the chosen PDF set.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: type_string => pdf_builtin_type_string
 <<SF pdf builtin: procedures>>=
   function pdf_builtin_type_string (object) result (string)
     class(pdf_builtin_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "PDF builtin: " // object%data%name
     else
        string = "PDF builtin: [undefined]"
     end if
   end function pdf_builtin_type_string
 
 @ %def pdf_builtin_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: write => pdf_builtin_write
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_write (object, unit, testflag)
     class(pdf_builtin_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A," // FMT_17 // ")")  "Q =", object%q
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "PDF builtin data: [undefined]"
     end if
   end subroutine pdf_builtin_write
 
 @ %def pdf_builtin_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 
 Optionally, we can provide minimum and maximum values for the momentum
 transfer.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: init => pdf_builtin_init
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_init (sf_int, data)
     class(pdf_builtin_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     type(flavor_t) :: flv, flv_remnant
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(3) :: qn
     integer :: i
     select type (data)
     type is (pdf_builtin_data_t)
        mask = quantum_numbers_mask (.false., .false., .true.)
        call col0%init ()
        call sf_int%base_init (mask, [0._default], [0._default], [0._default])
        sf_int%data => data
        do i = -6, 6
           if (data%mask(i)) then
              call qn(1)%init (data%flv_in, col = col0)
              if (i == 0) then
                 call flv%init (GLUON, data%model)
                 call flv_remnant%init (HADRON_REMNANT_OCTET, data%model)
              else
                 call flv%init (i, data%model)
                 call flv_remnant%init &
                      (sign (HADRON_REMNANT_TRIPLET, -i), data%model)
              end if
              call qn(2)%init ( &
                   flv = flv_remnant, col = color_from_flavor (flv_remnant, 1))
              call qn(2)%tag_radiated ()
              call qn(3)%init ( &
                   flv = flv, col = color_from_flavor (flv, 1, reverse=.true.))
              call sf_int%add_state (qn)
           end if
        end do
        if (data%has_photon .and. data%mask_photon) then
           call flv%init (PHOTON, data%model)
           call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model)
           call qn(2)%init (flv = flv_remnant, &
                col = color_from_flavor (flv_remnant, 1))
           call qn(2)%tag_radiated ()
           call qn(3)%init (flv = flv, &
                col = color_from_flavor (flv, 1, reverse = .true.))
           call sf_int%add_state (qn)
        end if
        call sf_int%freeze ()
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
        sf_int%status = SF_INITIAL
     end select
   end subroutine pdf_builtin_init
 
 @ %def pdf_builtin_init
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: complete_kinematics => pdf_builtin_complete_kinematics
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("PDF builtin: map flag not supported")
     else
        x(1) = r(1)
        xb(1)= rb(1)
        f = 1
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x = x(1)
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        f = 0
     end select
   end subroutine pdf_builtin_complete_kinematics
 
 @ %def pdf_builtin_complete_kinematics
 @ Overriding the default method: we compute the [[x]] value from the
 momentum configuration.  In this specific case, we also set the
 internally stored $x$ value, so it can be used in the
 following routine.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: recover_x => pdf_builtin_recover_x
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
   end subroutine pdf_builtin_recover_x
 
 @ %def sf_pdf_builtin_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("PDF builtin: map flag not supported")
     else
        r(1) = x(1)
        rb(1)= xb(1)
        f = 1
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine pdf_builtin_inverse_kinematics
 
 @ %def pdf_builtin_inverse_kinematics
 @
 \subsection{Structure function}
 Once the scale is also known, we can actually call the PDF and
 set the values.  Contrary to LHAPDF, the wrapper already takes care of
 adjusting to the $x$ and $Q$ bounds.  Account for the Jacobian.
 
 The parameter [[negative_sf]] is necessary to determine if we allow for negative PDF values.
 The class [[rescale]] gives rescaling prescription for NLO convolution of the
 structure function in combination with [[i_sub]].
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: apply => pdf_builtin_apply
 <<SF pdf builtin: procedures>>=
   subroutine pdf_builtin_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default), dimension(-6:6) :: ff
     real(double), dimension(-6:6) :: ff_dbl
     real(default) :: x, fph
     real(double) :: xx, qq
     complex(default), dimension(:), allocatable :: fc
     integer :: i, j_sub, i_sub_opt
     logical :: negative_sf_opt
     i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub
     negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf
     associate (data => sf_int%data)
       sf_int%q = scale
       x = sf_int%x
       if (present (rescale))  call rescale%apply (x)
       if (debug2_active (D_BEAMS)) then
          call msg_debug2 (D_BEAMS, "pdf_builtin_apply")
          call msg_debug2 (D_BEAMS, "rescale: ", present(rescale))
          call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt)
          call msg_debug2 (D_BEAMS, "x: ", x)
       end if
       xx = x
       qq = scale
       if (data%invert) then
          if (data%has_photon) then
             call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph)
          else
             if (data%hoppet_b_matching) then
                call hoppet_eval (xx, qq, ff_dbl(6:-6:-1))
                ff = ff_dbl
             else
                call pdf_evolve (data%id, x, scale, ff(6:-6:-1))
             end if
          end if
       else
          if (data%has_photon) then
             call pdf_evolve (data%id, x, scale, ff, fph)
          else
             if (data%hoppet_b_matching) then
                call hoppet_eval (xx, qq, ff_dbl)
                ff = ff_dbl
             else
                call pdf_evolve (data%id, x, scale, ff)
             end if
          end if
       end if
       if (data%has_photon) then
          allocate (fc (count ([data%mask, data%mask_photon])))
          if (negative_sf_opt) then
             fc = pack ([ff, fph], [data%mask, data%mask_photon])
          else
             fc = max( pack ([ff, fph], [data%mask, data%mask_photon]), 0._default)
          end if
       else
          allocate (fc (count (data%mask)))
          if (negative_sf_opt) then
             fc = pack (ff, data%mask)
          else
             fc = max( pack (ff, data%mask), 0._default)
          end if
       end if
     end associate
     if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc)
     call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))])
     sf_int%status = SF_EVALUATED
   end subroutine pdf_builtin_apply
 
 @ %def pdf_builtin_apply
 @
 \subsection{Strong Coupling}
 Since the PDF codes provide a function for computing the running
 $\alpha_s$ value, we make this available as an implementation of the
 abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation.
 <<SF pdf builtin: public>>=
   public :: alpha_qcd_pdf_builtin_t
 <<SF pdf builtin: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t
      type(string_t) :: pdfset_name
      integer :: pdfset_id = -1
    contains
    <<SF pdf builtin: alpha qcd: TBP>>
   end type alpha_qcd_pdf_builtin_t
 
 @ %def alpha_qcd_pdf_builtin_t
 @ Output.
 <<SF pdf builtin: alpha qcd: TBP>>=
   procedure :: write => alpha_qcd_pdf_builtin_write
 <<SF pdf builtin: procedures>>=
   subroutine alpha_qcd_pdf_builtin_write (object, unit)
     class(alpha_qcd_pdf_builtin_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A)")  "QCD parameters (pdf_builtin):"
     write (u, "(5x,A,A)")  "PDF set = ", char (object%pdfset_name)
     write (u, "(5x,A,I0)") "PDF ID  = ", object%pdfset_id
   end subroutine alpha_qcd_pdf_builtin_write
 
 @ %def alpha_qcd_pdf_builtin_write
 @ Calculation: the numeric ID selects the correct PDF set, which must
 be properly initialized.
 <<SF pdf builtin: alpha qcd: TBP>>=
   procedure :: get => alpha_qcd_pdf_builtin_get
 <<SF pdf builtin: procedures>>=
   function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     alpha = pdf_alphas (alpha_qcd%pdfset_id, scale)
   end function alpha_qcd_pdf_builtin_get
 
 @ %def alpha_qcd_pdf_builtin_get
 @
 Initialization.  We need to access the global initialization status.
 <<SF pdf builtin: alpha qcd: TBP>>=
   procedure :: init => alpha_qcd_pdf_builtin_init
 <<SF pdf builtin: procedures>>=
   subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path)
     class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: path
     alpha_qcd%pdfset_name = name
     alpha_qcd%pdfset_id = pdf_get_id (name)
     if (alpha_qcd%pdfset_id < 0) &
          call msg_fatal ("QCD parameter initialization: PDF set " &
          // char (name) // " is unknown")
     call pdf_init (alpha_qcd%pdfset_id, path)
   end subroutine alpha_qcd_pdf_builtin_init
 
 @ %def alpha_qcd_pdf_builtin_init
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_pdf_builtin_ut.f90]]>>=
 <<File header>>
 
 module sf_pdf_builtin_ut
   use unit_tests
   use sf_pdf_builtin_uti
 
 <<Standard module head>>
 
 <<SF pdf builtin: public test>>
 
 contains
 
 <<SF pdf builtin: test driver>>
 
 end module sf_pdf_builtin_ut
 @ %def sf_pdf_builtin_ut
 @
 <<[[sf_pdf_builtin_uti.f90]]>>=
 <<File header>>
 
 module sf_pdf_builtin_uti
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use physics_defs, only: PROTON
   use sm_qcd
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_base
 
   use sf_pdf_builtin
 
 <<Standard module head>>
 
 <<SF pdf builtin: test declarations>>
 
 contains
 
 <<SF pdf builtin: tests>>
 
 end module sf_pdf_builtin_uti
 @ %def sf_pdf_builtin_ut
 @ API: driver for the unit tests below.
 <<SF pdf builtin: public test>>=
   public :: sf_pdf_builtin_test
 <<SF pdf builtin: test driver>>=
   subroutine sf_pdf_builtin_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF pdf builtin: execute tests>>
   end subroutine sf_pdf_builtin_test
 
 @ %def sf_pdf_builtin_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF pdf builtin: execute tests>>=
   call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", &
        "structure function configuration", &
        u, results)
 <<SF pdf builtin: test declarations>>=
   public :: sf_pdf_builtin_1
 <<SF pdf builtin: tests>>=
   subroutine sf_pdf_builtin_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: sf_pdf_builtin_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call os_data%init ()
 
     call model%init_sm_test ()
     pdg_in = PROTON
 
     allocate (pdf_builtin_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     name = "CTEQ6L"
 
     select type (data)
     type is (pdf_builtin_data_t)
        call data%init (model, pdg_in, name, &
             os_data%pdf_builtin_datapath)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_pdf_builtin_1"
 
   end subroutine sf_pdf_builtin_1
 
 @ %def sf_pdf_builtin_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the PDF builtin
 structure function.
 <<SF pdf builtin: execute tests>>=
   call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", &
        "structure function instance", &
        u, results)
 <<SF pdf builtin: test declarations>>=
   public :: sf_pdf_builtin_2
 <<SF pdf builtin: tests>>=
   subroutine sf_pdf_builtin_2 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(string_t) :: name
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_pdf_builtin_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_sm_test ()
     call flv%init (PROTON, model)
     pdg_in = PROTON
 
     call reset_interaction_counter ()
 
     name = "CTEQ6L"
 
     allocate (pdf_builtin_data_t :: data)
     select type (data)
     type is (pdf_builtin_data_t)
        call data%init (model, pdg_in, name, &
             os_data%pdf_builtin_datapath)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.5_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100 GeV"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_pdf_builtin_2"
 
   end subroutine sf_pdf_builtin_2
 
 @ %def sf_pdf_builtin_2
 @
 \subsubsection{Strong Coupling}
 Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract
 type.
 <<SF pdf builtin: execute tests>>=
   call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", &
        "running alpha_s", &
        u, results)
 <<SF pdf builtin: test declarations>>=
   public :: sf_pdf_builtin_3
 <<SF pdf builtin: tests>>=
   subroutine sf_pdf_builtin_3 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(qcd_t) :: qcd
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: sf_pdf_builtin_3"
     write (u, "(A)")  "*   Purpose: initialize and evaluate alpha_s"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
 
     name = "CTEQ6L"
 
     write (u, "(A)")  "* Initialize qcd object"
     write (u, "(A)")
 
     allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha)
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_pdf_builtin_t)
        call alpha%init (name, os_data%pdf_builtin_datapath)
     end select
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100"
     write (u, "(A)")
 
     write (u, "(1x,A,F8.5)")  "alpha = ", qcd%alpha%get (100._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_pdf_builtin_3"
 
   end subroutine sf_pdf_builtin_3
 
 @ %def sf_pdf_builtin_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{LHAPDF}
 Parton distribution functions (PDFs) are available via an interface to
 the LHAPDF standard library.
 @
 \subsection{The module}
 <<[[sf_lhapdf.f90]]>>=
 <<File header>>
 
 module sf_lhapdf
 
 <<Use kinds>>
 <<Use strings>>
   use format_defs, only: FMT_17, FMT_19
   use io_units
   use system_dependencies, only: LHAPDF_PDFSETS_PATH
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
   use diagnostics
   use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON
   use physics_defs, only: HADRON_REMNANT_SINGLET
   use physics_defs, only: HADRON_REMNANT_TRIPLET
   use physics_defs, only: HADRON_REMNANT_OCTET
   use lorentz
   use sm_qcd
   use pdg_arrays
   use model_data
   use flavors
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
   use lhapdf !NODEP!
   use hoppet_interface
 
 <<Standard module head>>
 
 <<SF lhapdf: public>>
 
 <<SF lhapdf: types>>
 
 <<SF lhapdf: parameters>>
 
 <<SF lhapdf: variables>>
 
 <<SF lhapdf: interfaces>>
 
 contains
 
 <<SF lhapdf: procedures>>
 
 end module sf_lhapdf
 @ %def sf_lhapdf
 @
 \subsection{Codes for default PDF sets}
 The default PDF for protons set is chosen to be CTEQ6ll (LO fit with
 LO $\alpha_s$).
 <<SF lhapdf: parameters>>=
   character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf"
   character(*), parameter :: LHAPDF5_DEFAULT_PION   = "ABFKWPI.LHgrid"
   character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid"
   character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10"
 @ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION
 @ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON
 @
 \subsection{LHAPDF library interface}
 Here we specify explicit interfaces for all LHAPDF routines that we
 use below.
 <<SF lhapdf: interfaces>>=
   interface
      subroutine InitPDFsetM (set, file)
        integer, intent(in) :: set
        character(*), intent(in) :: file
      end subroutine InitPDFsetM
   end interface
 
 @ %def InitPDFsetM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine InitPDFM (set, mem)
        integer, intent(in) :: set, mem
      end subroutine InitPDFM
   end interface
 
 @ %def InitPDFM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine numberPDFM (set, n_members)
        integer, intent(in) :: set
        integer, intent(out) :: n_members
      end subroutine numberPDFM
   end interface
 
 @ %def numberPDFM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine evolvePDFM (set, x, q, ff)
        integer, intent(in) :: set
        double precision, intent(in) :: x, q
        double precision, dimension(-6:6), intent(out) :: ff
      end subroutine evolvePDFM
   end interface
 
 @ %def evolvePDFM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine evolvePDFphotonM (set, x, q, ff, fphot)
        integer, intent(in) :: set
        double precision, intent(in) :: x, q
        double precision, dimension(-6:6), intent(out) :: ff
        double precision, intent(out) :: fphot
      end subroutine evolvePDFphotonM
   end interface
 
 @ %def evolvePDFphotonM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine evolvePDFpM (set, x, q, s, scheme, ff)
        integer, intent(in) :: set
        double precision, intent(in) :: x, q, s
        integer, intent(in) :: scheme
        double precision, dimension(-6:6), intent(out) :: ff
      end subroutine evolvePDFpM
   end interface
 
 @ %def evolvePDFpM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetXminM (set, mem, xmin)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: xmin
      end subroutine GetXminM
   end interface
 
 @ %def GetXminM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetXmaxM (set, mem, xmax)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: xmax
      end subroutine GetXmaxM
   end interface
 
 @ %def GetXmaxM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetQ2minM (set, mem, q2min)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: q2min
      end subroutine GetQ2minM
   end interface
 
 @ %def GetQ2minM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetQ2maxM (set, mem, q2max)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: q2max
      end subroutine GetQ2maxM
   end interface
 
 @ %def GetQ2maxM
 <<SF lhapdf: interfaces>>=
   interface
      function has_photon () result(flag)
         logical :: flag
      end function has_photon
   end interface
 
 @ %def has_photon
 @
 \subsection{The LHAPDF status}
 This type holds the initialization status of the LHAPDF system. Entry
 1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs.
 
 Since it is connected to the external LHAPDF library, this is a truly
 global object.  We implement it as a a private module variable.  To
 access it from elsewhere, the caller has to create and initialize an
 object of type [[lhapdf_status_t]], which acts as a proxy.
 <<SF lhapdf: types>>=
   type :: lhapdf_global_status_t
      private
      logical, dimension(3) :: initialized = .false.
   end type lhapdf_global_status_t
 
 @ %def lhapdf_global_status_t
 <<SF lhapdf: variables>>=
   type(lhapdf_global_status_t), save :: lhapdf_global_status
 @ %def lhapdf_global_status
 <<SF lhapdf: procedures>>=
   function lhapdf_global_status_is_initialized (set) result (flag)
     logical :: flag
     integer, intent(in), optional :: set
     if (present (set)) then
        select case (set)
        case (1:3);    flag = lhapdf_global_status%initialized(set)
        case default;  flag = .false.
        end select
     else
        flag = any (lhapdf_global_status%initialized)
     end if
   end function lhapdf_global_status_is_initialized
 
 @ %def lhapdf_global_status_is_initialized
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_global_status_set_initialized (set)
     integer, intent(in) :: set
     lhapdf_global_status%initialized(set) = .true.
   end subroutine lhapdf_global_status_set_initialized
 
 @ %def lhapdf_global_status_set_initialized
 @ This is the only public procedure, it tells the system to forget
 about previous initialization, allowing for changing the chosen PDF
 set.  Note that such a feature works only if the global program flow
 is serial, so no two distinct sets are accessed simultaneously.  But
 this applies to LHAPDF anyway.
 <<SF lhapdf: public>>=
   public :: lhapdf_global_reset
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_global_reset ()
     lhapdf_global_status%initialized = .false.
   end subroutine lhapdf_global_reset
 
 @ %def lhapdf_global_status_reset
 @
 \subsection{LHAPDF initialization}
 Before using LHAPDF, we have to initialize it with a particular data
 set and member.  This applies not just if we use structure functions,
 but also if we just use an $\alpha_s$ formula.  The integer [[set]]
 should be $1$ for proton, $2$ for pion, and $3$ for photon, but this
 is just convention.
 
 It appears as if LHAPDF does not allow for multiple data sets being
 used concurrently (?), so multi-threaded usage with different sets
 (e.g., a scan) is excluded.  The current setup with a global flag that
 indicates initialization is fine as long as Whizard itself is run in
 serial mode at the Sindarin level.  If we introduce multithreading in
 any form from Sindarin, we have to rethink the implementation of the
 LHAPDF interface.  (The same considerations apply to builtin PDFs.)
 
 If the particular set has already been initialized, do nothing.  This
 implies that whenever we want to change the setup for a particular
 set, we have to reset the LHAPDF status.
 [[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]],
 the reason it works for [[pdf_builtin]] is that there things are
 outsourced to a separate module (inc. [[lhapdf_status]] etc.).
 <<SF lhapdf: public>>=
   public :: lhapdf_initialize
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_initialize (set, prefix, file, member, pdf, b_match)
     integer, intent(in) :: set
     type(string_t), intent(inout) :: prefix
     type(string_t), intent(inout) :: file
     type(lhapdf_pdf_t), intent(inout), optional :: pdf
     integer, intent(inout) :: member
     logical, intent(in), optional :: b_match
     if (prefix == "")  prefix = LHAPDF_PDFSETS_PATH
     if (LHAPDF5_AVAILABLE) then
        if (lhapdf_global_status_is_initialized (set))  return
        if (file == "") then
           select case (set)
           case (1);  file = LHAPDF5_DEFAULT_PROTON
           case (2);  file = LHAPDF5_DEFAULT_PION
           case (3);  file = LHAPDF5_DEFAULT_PHOTON
           end select
        end if
        if (data_file_exists (prefix // "/" // file)) then
           call InitPDFsetM (set, char (prefix // "/" // file))
        else
           call msg_fatal ("LHAPDF: Data file '" &
                // char (file) // "' not found in '" // char (prefix) // "'.")
           return
        end if
        if (.not. dataset_member_exists (set, member)) then
           call msg_error (" LHAPDF: Chosen member does not exist for set '" &
                // char (file) // "', using default.")
           member = 0
        end if
        call InitPDFM (set, member)
     else if (LHAPDF6_AVAILABLE) then
     ! TODO: (bcn 2015-07-07) we should have a closer look why this global
     !                        check must not be executed
     !   if (lhapdf_global_status_is_initialized (set) .and. &
     !        pdf%is_associated ()) return
        if (file == "") then
           select case (set)
           case (1);  file = LHAPDF6_DEFAULT_PROTON
           case (2);
              call msg_fatal ("LHAPDF6: no pion PDFs supported")
           case (3);
              call msg_fatal ("LHAPDF6: no photon PDFs supported")
           end select
        end if
        if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then
           call pdf%init (char (file), member)
        else
           call msg_fatal ("LHAPDF: Data file '" &
                // char (file) // "' not found in '" // char (prefix) // "'.")
           return
        end if
     end if
     if (present (b_match)) then
        if (b_match) then
           if (LHAPDF5_AVAILABLE) then
              call hoppet_init (.false.)
           else if (LHAPDF6_AVAILABLE) then
              call hoppet_init (.false., pdf)
           end if
        end if
     end if
     call lhapdf_global_status_set_initialized (set)
   contains
     function data_file_exists (fq_name) result (exist)
       type(string_t), intent(in) :: fq_name
       logical :: exist
       inquire (file = char(fq_name), exist = exist)
     end function data_file_exists
     function dataset_member_exists (set, member) result (exist)
       integer, intent(in) :: set, member
       logical :: exist
       integer :: n_members
       call numberPDFM (set, n_members)
       exist = member >= 0 .and. member <= n_members
     end function dataset_member_exists
   end subroutine lhapdf_initialize
 
 @ %def lhapdf_initialize
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: complete_kinematics => lhapdf_complete_kinematics
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("LHAPDF: map flag not supported")
     else
        x(1) = r(1)
        xb(1)= rb(1)
        f = 1
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x = x(1)
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        f = 0
     end select
   end subroutine lhapdf_complete_kinematics
 
 @ %def lhapdf_complete_kinematics
 @ Overriding the default method: we compute the [[x]] value from the
 momentum configuration.  In this specific case, we also set the
 internally stored $x$ value, so it can be used in the
 following routine.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: recover_x => lhapdf_recover_x
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_recover_x (sf_int, x, xb, x_free)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
   end subroutine lhapdf_recover_x
 
 @ %def lhapdf_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: inverse_kinematics => lhapdf_inverse_kinematics
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("LHAPDF: map flag not supported")
     else
        r(1) = x(1)
        rb(1)= xb(1)
        f = 1
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine lhapdf_inverse_kinematics
 
 @ %def lhapdf_inverse_kinematics
 @
 \subsection{The LHAPDF data block}
 The data block holds the incoming flavor (which has to be proton,
 pion, or photon), the corresponding pointer to the global access data
 (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the
 bounds as returned by LHAPDF for the specified set, and a mask that
 determines which partons will be actually in use.
 <<SF lhapdf: public>>=
   public :: lhapdf_data_t
 <<SF lhapdf: types>>=
   type, extends (sf_data_t) :: lhapdf_data_t
      private
      type(string_t) :: prefix
      type(string_t) :: file
      type(lhapdf_pdf_t) :: pdf
      integer :: member = 0
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      integer :: set = 0
      logical :: invert = .false.
      logical :: photon = .false.
      logical :: has_photon = .false.
      integer :: photon_scheme = 0
      real(default) :: xmin = 0, xmax = 0
      real(default) :: qmin = 0, qmax = 0
      logical, dimension(-6:6) :: mask = .true.
      logical :: mask_photon = .true.
      logical :: hoppet_b_matching = .false.
    contains
      <<SF lhapdf: lhapdf data: TBP>>
   end type lhapdf_data_t
 
 @ %def lhapdf_data_t
 @ Generate PDF data.  This is provided as a function, but it has the
 side-effect of initializing the requested PDF set.  A finalizer is not
 needed.
 
 The library uses double precision, so since the default precision may be
 extended or quadruple, we use auxiliary variables for type casting.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: init => lhapdf_data_init
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_data_init &
        (data, model, pdg_in, prefix, file, member, photon_scheme, &
             hoppet_b_matching)
     class(lhapdf_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     type(string_t), intent(in), optional :: prefix, file
     integer, intent(in), optional :: member
     integer, intent(in), optional :: photon_scheme
     logical, intent(in), optional :: hoppet_b_matching
     double precision :: xmin, xmax, q2min, q2max
     external :: InitPDFsetM, InitPDFM, numberPDFM
     external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM
     if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then
        call msg_fatal ("LHAPDF requested but library is not linked")
        return
     end if
     data%model => model
     if (pdg_array_get_length (pdg_in) /= 1) &
          call msg_fatal ("PDF: incoming particle must be unique")
     call data%flv_in%init (pdg_array_get (pdg_in, 1), model)
     select case (pdg_array_get (pdg_in, 1))
     case (PROTON)
        data%set = 1
     case (-PROTON)
        data%set = 1
        data%invert = .true.
     case (PIPLUS)
        data%set = 2
     case (-PIPLUS)
        data%set = 2
        data%invert = .true.
     case (PHOTON)
        data%set = 3
        data%photon = .true.
        if (present (photon_scheme))  data%photon_scheme = photon_scheme
     case default
        call msg_fatal (" LHAPDF: " &
             // "incoming particle must be (anti)proton, pion, or photon.")
        return
     end select
     if (present (prefix)) then
        data%prefix = prefix
     else
        data%prefix = ""
     end if
     if (present (file)) then
        data%file = file
     else
        data%file = ""
     end if
     if (present (hoppet_b_matching))  data%hoppet_b_matching = hoppet_b_matching
     if (LHAPDF5_AVAILABLE) then
        call lhapdf_initialize (data%set, &
             data%prefix, data%file, data%member, &
             b_match = data%hoppet_b_matching)
        call GetXminM (data%set, data%member, xmin)
        call GetXmaxM (data%set, data%member, xmax)
        call GetQ2minM (data%set, data%member, q2min)
        call GetQ2maxM (data%set, data%member, q2max)
        data%xmin = xmin
        data%xmax = xmax
        data%qmin = sqrt (q2min)
        data%qmax = sqrt (q2max)
        data%has_photon = has_photon ()
     else if (LHAPDF6_AVAILABLE) then
        call lhapdf_initialize (data%set, &
             data%prefix, data%file, data%member, &
             data%pdf, data%hoppet_b_matching)
        data%xmin = data%pdf%getxmin ()
        data%xmax = data%pdf%getxmax ()
        data%qmin = sqrt(data%pdf%getq2min ())
        data%qmax = sqrt(data%pdf%getq2max ())
        data%has_photon = data%pdf%has_photon ()
     end if
   end subroutine lhapdf_data_init
 
 @ %def lhapdf_data_init
 @ Enable/disable partons explicitly.  If a mask entry is true,
 applying the PDF will generate the corresponding flavor on output.
 <<LHAPDF: lhapdf data: TBP>>=
   procedure :: set_mask => lhapdf_data_set_mask
 <<LHAPDF: procedures>>=
   subroutine lhapdf_data_set_mask (data, mask)
     class(lhapdf_data_t), intent(inout) :: data
     logical, dimension(-6:6), intent(in) :: mask
     data%mask = mask
   end subroutine lhapdf_data_set_mask
 
 @ %def lhapdf_data_set_mask
 @ Return the public part of the data set.
 <<LHAPDF: public>>=
   public :: lhapdf_data_get_public_info
 <<LHAPDF: procedures>>=
   subroutine lhapdf_data_get_public_info &
        (data, lhapdf_dir, lhapdf_file, lhapdf_member)
     type(lhapdf_data_t), intent(in) :: data
     type(string_t), intent(out) :: lhapdf_dir, lhapdf_file
     integer, intent(out) :: lhapdf_member
     lhapdf_dir = data%prefix
     lhapdf_file = data%file
     lhapdf_member = data%member
   end subroutine lhapdf_data_get_public_info
 
 @ %def lhapdf_data_get_public_info
 @ Return the number of the member of the data set.
 <<LHAPDF: public>>=
   public :: lhapdf_data_get_set
 <<LHAPDF: procedures>>=
   function lhapdf_data_get_set(data) result(set)
     type(lhapdf_data_t), intent(in) :: data
     integer :: set
     set = data%set
   end function lhapdf_data_get_set
 
 @ %def lhapdf_data_get_set
 @ Output
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: write => lhapdf_data_write
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_data_write (data, unit, verbose)
     class(lhapdf_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     logical :: verb
     integer :: u
     if (present (verbose)) then
        verb = verbose
     else
        verb = .false.
     end if
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "LHAPDF data:"
     if (data%set /= 0) then
        write (u, "(3x,A)", advance="no") "flavor       =  "
        call data%flv_in%write (u);  write (u, *)
        if (verb) then
           write (u, "(3x,A,A)")       "  prefix       =  ", char (data%prefix)
        else
           write (u, "(3x,A,A)")       "  prefix       = ", &
                " <empty (non-verbose version)>"
        end if
        write (u, "(3x,A,A)")       "  file         =  ", char (data%file)
        write (u, "(3x,A,I3)")      "  member       = ", data%member
        write (u, "(3x,A," // FMT_19 // ")") "  x(min)       = ", data%xmin
        write (u, "(3x,A," // FMT_19 // ")") "  x(max)       = ", data%xmax
        write (u, "(3x,A," // FMT_19 // ")") "  Q(min)       = ", data%qmin
        write (u, "(3x,A," // FMT_19 // ")") "  Q(max)       = ", data%qmax
        write (u, "(3x,A,L1)")      "  invert       =  ", data%invert
        if (data%photon)  write (u, "(3x,A,I3)") &
             "  IP2 (scheme) = ", data%photon_scheme
           write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") &
                "  mask         = ", &
                data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6)
           write (u, "(3x,A,L1)")   "  photon mask  =  ", data%mask_photon
        if (data%set == 1)  write (u, "(3x,A,L1)") &
             "  hoppet_b     =  ", data%hoppet_b_matching
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine lhapdf_data_write
 @ %def lhapdf_data_write
 @ The number of parameters is one.  We do not generate transverse momentum.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: get_n_par => lhapdf_data_get_n_par
 <<SF lhapdf: procedures>>=
   function lhapdf_data_get_n_par (data) result (n)
     class(lhapdf_data_t), intent(in) :: data
     integer :: n
     n = 1
   end function lhapdf_data_get_n_par
 
 @ %def lhapdf_data_get_n_par
 @ Return the outgoing particle PDG codes.  This is based on the mask.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: get_pdg_out => lhapdf_data_get_pdg_out
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_data_get_pdg_out (data, pdg_out)
     class(lhapdf_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     integer :: n, np, i
     n = count (data%mask)
     np = 0;  if (data%has_photon .and. data%mask_photon)  np = 1
     allocate (pdg1 (n + np))
     pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask)
     if (np == 1)  pdg1(n+np) = PHOTON
     pdg_out(1) = pdg1
   end subroutine lhapdf_data_get_pdg_out
 
 @ %def lhapdf_data_get_pdg_out
 @ Allocate the interaction record.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_data_allocate_sf_int (data, sf_int)
     class(lhapdf_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (lhapdf_t :: sf_int)
   end subroutine lhapdf_data_allocate_sf_int
 
 @ %def lhapdf_data_allocate_sf_int
 @ Return the numerical PDF set index.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: get_pdf_set => lhapdf_data_get_pdf_set
 <<SF lhapdf: procedures>>=
   elemental function lhapdf_data_get_pdf_set (data) result (pdf_set)
     class(lhapdf_data_t), intent(in) :: data
     integer :: pdf_set
     pdf_set = data%set
   end function lhapdf_data_get_pdf_set
 
 @ %def lhapdf_data_get_pdf_set
 @
 \subsection{The LHAPDF object}
 The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes
 the splitting of an (anti)proton into a parton and a beam remnant.  We
 stay in the strict forward-splitting limit, but allow some invariant
 mass for the beam remnant such that the outgoing parton is exactly
 massless.  For a real event, we would replace this by a parton
 cascade, where the outgoing partons have virtuality as dictated by
 parton-shower kinematics, and transverse momentum is generated.
 
 This is the LHAPDF object which holds input data together with the
 interaction.  We also store the $x$ momentum fraction and the scale,
 since kinematics and function value are requested at different times.
 
 The PDF application is a $1\to 2$ splitting process, where the
 particles are ordered as (hadron, remnant, parton).
 
 Polarization is ignored completely.  The beam particle is colorless,
 while partons and beam remnant carry color.  The remnant gets a
 special flavor code.
 <<SF lhapdf: public>>=
   public :: lhapdf_t
 <<SF lhapdf: types>>=
   type, extends (sf_int_t) :: lhapdf_t
      type(lhapdf_data_t), pointer :: data => null ()
      real(default) :: x = 0
      real(default) :: q = 0
      real(default) :: s = 0
    contains
    <<SF lhapdf: lhapdf: TBP>>
   end type lhapdf_t
 
 @ %def lhapdf_t
 @ Type string: display the chosen PDF set.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: type_string => lhapdf_type_string
 <<SF lhapdf: procedures>>=
   function lhapdf_type_string (object) result (string)
     class(lhapdf_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "LHAPDF: " // object%data%file
     else
        string = "LHAPDF: [undefined]"
     end if
   end function lhapdf_type_string
 
 @ %def lhapdf_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: write => lhapdf_write
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_write (object, unit, testflag)
     class(lhapdf_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A," // FMT_17 // ")")  "Q =", object%q
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "LHAPDF data: [undefined]"
     end if
   end subroutine lhapdf_write
 
 @ %def lhapdf_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_lhapdf_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: init => lhapdf_init
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_init (sf_int, data)
     class(lhapdf_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     type(flavor_t) :: flv, flv_remnant
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(3) :: qn
     integer :: i
     select type (data)
     type is (lhapdf_data_t)
        mask = quantum_numbers_mask (.false., .false., .true.)
        call col0%init ()
        call sf_int%base_init (mask, [0._default], [0._default], [0._default])
        sf_int%data => data
        do i = -6, 6
           if (data%mask(i)) then
              call qn(1)%init (data%flv_in, col = col0)
              if (i == 0) then
                 call flv%init (GLUON, data%model)
                 call flv_remnant%init (HADRON_REMNANT_OCTET, data%model)
              else
                 call flv%init (i, data%model)
                 call flv_remnant%init &
                      (sign (HADRON_REMNANT_TRIPLET, -i), data%model)
              end if
              call qn(2)%init ( &
                   flv = flv_remnant, col = color_from_flavor (flv_remnant, 1))
              call qn(2)%tag_radiated ()
              call qn(3)%init ( &
                   flv = flv, col = color_from_flavor (flv, 1, reverse=.true.))
              call sf_int%add_state (qn)
           end if
        end do
        if (data%has_photon .and. data%mask_photon) then
           call flv%init (PHOTON, data%model)
           call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model)
           call qn(2)%init (flv = flv_remnant, &
                col = color_from_flavor (flv_remnant, 1))
           call qn(2)%tag_radiated ()
           call qn(3)%init (flv = flv, &
                col = color_from_flavor (flv, 1, reverse=.true.))
           call sf_int%add_state (qn)
        end if
        call sf_int%freeze ()
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
        sf_int%status = SF_INITIAL
     end select
   end subroutine lhapdf_init
 
 @ %def lhapdf_init
 @
 \subsection{Structure function}
 We have to cast the LHAPDF arguments to/from double precision (possibly
 from/to extended/quadruple precision), if necessary.
 Some structure functions can yield negative results (sea quarks close
 to $x=1$). In an NLO computation, this is perfectly fine and we keep negative values.
 Unlike total cross sections, PDFs do not have to be positive definite. For LO however,
 negative PDFs would cause negative event weights so we set these values to zero instead.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: apply => lhapdf_apply
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: x, s
     double precision :: xx, qq, ss
     double precision, dimension(-6:6) :: ff
     double precision :: fphot
     complex(default), dimension(:), allocatable :: fc
     integer :: i, i_sub_opt, j_sub
     logical :: negative_sf_opt
     external :: evolvePDFM, evolvePDFpM
     i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub
     negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf
     associate (data => sf_int%data)
       sf_int%q = scale
       x = sf_int%x
       if (present (rescale))  call rescale%apply (x)
       s = sf_int%s
       xx = x
       if (debug2_active (D_BEAMS)) then
          call msg_debug2 (D_BEAMS, "lhapdf_apply")
          call msg_debug2 (D_BEAMS, "rescale: ", present(rescale))
          call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt)
          call msg_debug2 (D_BEAMS, "x: ", x)
       end if
       qq = min (data%qmax, scale)
       qq = max (data%qmin, qq)
       if (.not. data%photon) then
          if (data%invert) then
             if (data%has_photon) then
                if (LHAPDF5_AVAILABLE) then
                   call evolvePDFphotonM &
                        (data%set, xx, qq, ff(6:-6:-1), fphot)
                else if (LHAPDF6_AVAILABLE) then
                   call data%pdf%evolve_pdfphotonm &
                        (xx, qq, ff(6:-6:-1), fphot)
                end if
             else
                if (data%hoppet_b_matching) then
                   call hoppet_eval (xx, qq, ff(6:-6:-1))
                else
                   if (LHAPDF5_AVAILABLE) then
                      call evolvePDFM (data%set, xx, qq, ff(6:-6:-1))
                   else if (LHAPDF6_AVAILABLE) then
                      call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1))
                   end if
                end if
             end if
          else
             if (data%has_photon) then
                if (LHAPDF5_AVAILABLE) then
                   call evolvePDFphotonM (data%set, xx, qq, ff, fphot)
                else if (LHAPDF6_AVAILABLE) then
                   call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot)
                end if
             else
                if (data%hoppet_b_matching) then
                   call hoppet_eval (xx, qq, ff)
                else
                   if (LHAPDF5_AVAILABLE) then
                      call evolvePDFM (data%set, xx, qq, ff)
                   else if (LHAPDF6_AVAILABLE) then
                      call data%pdf%evolve_pdfm (xx, qq, ff)
                   end if
                end if
             end if
          end if
       else
          ss = s
          if (LHAPDF5_AVAILABLE) then
             call evolvePDFpM (data%set, xx, qq, &
                  ss, data%photon_scheme, ff)
          else if (LHAPDF6_AVAILABLE) then
             call data%pdf%evolve_pdfpm (xx, qq, ss, &
                  data%photon_scheme, ff)
          end if
       end if
       if (data%has_photon) then
          allocate (fc (count ([data%mask, data%mask_photon])))
          if (negative_sf_opt) then
             fc = pack ([ff, fphot] / x, [data%mask, data%mask_photon])
          else
             fc = max( pack ([ff, fphot] / x, [data%mask, data%mask_photon]), 0._default)
          end if
       else
          allocate (fc (count (data%mask)))
          if (negative_sf_opt) then
             fc = pack (ff / x, data%mask)
          else
             fc = max( pack (ff / x, data%mask), 0._default)
          end if
       end if
     end associate
     if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc)
     call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))])
     sf_int%status = SF_EVALUATED
   end subroutine lhapdf_apply
 
 @ %def apply_lhapdf
 @
 \subsection{Strong Coupling}
 Since the PDF codes provide a function for computing the running
 $\alpha_s$ value, we make this available as an implementation of the
 abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation.
 <<SF lhapdf: public>>=
   public :: alpha_qcd_lhapdf_t
 <<SF lhapdf: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t
      type(string_t) :: pdfset_dir
      type(string_t) :: pdfset_file
      integer :: pdfset_member = -1
      type(lhapdf_pdf_t) :: pdf
    contains
    <<SF lhapdf: alpha qcd: TBP>>
   end type alpha_qcd_lhapdf_t
 
 @ %def alpha_qcd_lhapdf_t
 @ Output. As in earlier versions we leave the LHAPDF path out.
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: write => alpha_qcd_lhapdf_write
 <<SF lhapdf: procedures>>=
   subroutine alpha_qcd_lhapdf_write (object, unit)
     class(alpha_qcd_lhapdf_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A)")  "QCD parameters (lhapdf):"
     write (u, "(5x,A,A)")  "PDF set    = ", char (object%pdfset_file)
     write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member
   end subroutine alpha_qcd_lhapdf_write
 
 @ %def alpha_qcd_lhapdf_write
 @ Calculation: the numeric member ID selects the correct PDF set, which must
 be properly initialized.
 <<SF lhapdf: interfaces>>=
   interface
      double precision function alphasPDF (Q)
        double precision, intent(in) :: Q
      end function alphasPDF
   end interface
 
 @ %def alphasPDF
 @
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: get => alpha_qcd_lhapdf_get
 <<SF lhapdf: procedures>>=
   function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     if (LHAPDF5_AVAILABLE) then
        alpha = alphasPDF (dble (scale))
     else if (LHAPDF6_AVAILABLE) then
        alpha = alpha_qcd%pdf%alphas_pdf (dble (scale))
     end if
   end function alpha_qcd_lhapdf_get
 
 @ %def alpha_qcd_lhapdf_get
 @
 Initialization.  We need to access the (quasi-global) initialization status.
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: init => alpha_qcd_lhapdf_init
 <<SF lhapdf: procedures>>=
   subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path)
     class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd
     type(string_t), intent(inout) :: file
     integer, intent(inout) :: member
     type(string_t), intent(inout) :: path
     alpha_qcd%pdfset_file = file
     alpha_qcd%pdfset_member = member
     if (alpha_qcd%pdfset_member < 0) &
          call msg_fatal ("QCD parameter initialization: PDF set " &
          // char (file) // " is unknown")
     if (LHAPDF5_AVAILABLE) then
        call lhapdf_initialize (1, path, file, member)
     else if (LHAPDF6_AVAILABLE) then
        call lhapdf_initialize &
             (1, path, file, member, alpha_qcd%pdf)
     end if
   end subroutine alpha_qcd_lhapdf_init
 
 @ %def alpha_qcd_lhapdf_init
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_lhapdf_ut.f90]]>>=
 <<File header>>
 
 module sf_lhapdf_ut
   use unit_tests
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
   use sf_lhapdf_uti
 
 <<Standard module head>>
 
 <<SF lhapdf: public test>>
 
 contains
 
 <<SF lhapdf: test driver>>
 
 end module sf_lhapdf_ut
 @ %def sf_lhapdf_ut
 @
 <<[[sf_lhapdf_uti.f90]]>>=
 <<File header>>
 
 module sf_lhapdf_uti
 
 <<Use kinds>>
 <<Use strings>>
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
   use os_interface
   use physics_defs, only: PROTON
   use sm_qcd
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_base
 
   use sf_lhapdf
 
 <<Standard module head>>
 
 <<SF lhapdf: test declarations>>
 
 contains
 
 <<SF lhapdf: tests>>
 
 end module sf_lhapdf_uti
 @ %def sf_lhapdf_ut
 @ API: driver for the unit tests below.
 <<SF lhapdf: public test>>=
   public :: sf_lhapdf_test
 <<SF lhapdf: test driver>>=
   subroutine sf_lhapdf_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF lhapdf: execute tests>>
   end subroutine sf_lhapdf_test
 
 @ %def sf_lhapdf_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF lhapdf: execute tests>>=
   if (LHAPDF5_AVAILABLE) then
      call test (sf_lhapdf_1, "sf_lhapdf5_1", &
           "structure function configuration", &
           u, results)
   else if (LHAPDF6_AVAILABLE) then
      call test (sf_lhapdf_1, "sf_lhapdf6_1", &
           "structure function configuration", &
           u, results)
   end if
 <<SF lhapdf: test declarations>>=
   public :: sf_lhapdf_1
 <<SF lhapdf: tests>>=
   subroutine sf_lhapdf_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_lhapdf_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_sm_test ()
     pdg_in = PROTON
 
     allocate (lhapdf_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (lhapdf_data_t)
        call data%init (model, pdg_in)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_lhapdf_1"
 
   end subroutine sf_lhapdf_1
 
 @ %def sf_lhapdf_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the PDF builtin
 structure function.
 <<SF lhapdf: execute tests>>=
   if (LHAPDF5_AVAILABLE) then
      call test (sf_lhapdf_2, "sf_lhapdf5_2", &
           "structure function instance", &
           u, results)
   else if (LHAPDF6_AVAILABLE) then
      call test (sf_lhapdf_2, "sf_lhapdf6_2", &
           "structure function instance", &
           u, results)
   end if
 <<SF lhapdf: test declarations>>=
   public :: sf_lhapdf_2
 <<SF lhapdf: tests>>=
   subroutine sf_lhapdf_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_lhapdf_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (PROTON, model)
     pdg_in = PROTON
     call lhapdf_global_reset ()
 
     call reset_interaction_counter ()
 
     allocate (lhapdf_data_t :: data)
     select type (data)
     type is (lhapdf_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.5_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100 GeV"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u, testflag = .true.)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_lhapdf_2"
 
   end subroutine sf_lhapdf_2
 
 @ %def sf_lhapdf_2
 @
 \subsubsection{Strong Coupling}
 Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract
 type.
 <<SF lhapdf: execute tests>>=
   if (LHAPDF5_AVAILABLE) then
      call test (sf_lhapdf_3, "sf_lhapdf5_3", &
           "running alpha_s", &
           u, results)
   else if (LHAPDF6_AVAILABLE) then
      call test (sf_lhapdf_3, "sf_lhapdf6_3", &
           "running alpha_s", &
           u, results)
   end if
 <<SF lhapdf: test declarations>>=
   public :: sf_lhapdf_3
 <<SF lhapdf: tests>>=
   subroutine sf_lhapdf_3 (u)
     integer, intent(in) :: u
     type(qcd_t) :: qcd
     type(string_t) :: name, path
     integer :: member
 
     write (u, "(A)")  "* Test output: sf_lhapdf_3"
     write (u, "(A)")  "*   Purpose: initialize and evaluate alpha_s"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call lhapdf_global_reset ()
 
     if (LHAPDF5_AVAILABLE) then
        name = "cteq6ll.LHpdf"
        member = 1
        path = ""
     else if (LHAPDF6_AVAILABLE) then
        name = "CT10"
        member = 1
        path = ""
     end if
 
     write (u, "(A)")  "* Initialize qcd object"
     write (u, "(A)")
 
     allocate (alpha_qcd_lhapdf_t :: qcd%alpha)
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_lhapdf_t)
        call alpha%init (name, member, path)
     end select
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100"
     write (u, "(A)")
 
     write (u, "(1x,A,F8.5)")  "alpha = ", qcd%alpha%get (100._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_lhapdf_3"
 
   end subroutine sf_lhapdf_3
 
 @ %def sf_lhapdf_3
 @
 \section{Easy PDF Access}
 For the shower, subtraction and matching, it is very useful to have
 direct access to $f(x,Q)$ independently of the used library.
 <<[[pdf.f90]]>>=
 <<File header>>
 
 module pdf
 
 <<Use kinds with double>>
   use io_units
   use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE
   use diagnostics
   use beam_structures
   use lhapdf !NODEP!
   use pdf_builtin !NODEP!
 
 <<Standard module head>>
 
 <<PDF: public>>
 
 <<PDF: parameters>>
 
 <<PDF: types>>
 
 contains
 
 <<PDF: procedures>>
 
 end module pdf
 @ %def pdf
 We support the following implementations:
 <<PDF: parameters>>=
   integer, parameter, public :: STRF_NONE = 0
   integer, parameter, public :: STRF_LHAPDF6 = 1
   integer, parameter, public :: STRF_LHAPDF5 = 2
   integer, parameter, public :: STRF_PDF_BUILTIN = 3
 
 @ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN
 @ A container to bundle all necessary PDF data. Could be moved to a more
 central location.
 <<PDF: public>>=
   public :: pdf_data_t
 <<PDF: types>>=
   type :: pdf_data_t
     type(lhapdf_pdf_t) :: pdf
     real(default) :: xmin, xmax, qmin, qmax
     integer :: type = STRF_NONE
     integer :: set = 0
    contains
    <<PDF: pdf data: TBP>>
   end type pdf_data_t
 
 @ %def pdf_data
 @
 <<PDF: pdf data: TBP>>=
   procedure :: init => pdf_data_init
 <<PDF: procedures>>=
   subroutine pdf_data_init (pdf_data, pdf_data_in)
     class(pdf_data_t), intent(out) :: pdf_data
     type(pdf_data_t), target, intent(in) :: pdf_data_in
     pdf_data%xmin = pdf_data_in%xmin
     pdf_data%xmax = pdf_data_in%xmax
     pdf_data%qmin = pdf_data_in%qmin
     pdf_data%qmax = pdf_data_in%qmax
     pdf_data%set = pdf_data_in%set
     pdf_data%type = pdf_data_in%type
     if (pdf_data%type == STRF_LHAPDF6) then
        if (pdf_data_in%pdf%is_associated ()) then
           call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf)
        else
           call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!')
        end if
     end if
   end subroutine pdf_data_init
 
 @ %def pdf_data_init
 @
 <<PDF: pdf data: TBP>>=
   procedure :: write => pdf_data_write
 <<PDF: procedures>>=
   subroutine pdf_data_write (pdf_data, unit)
     class(pdf_data_t), intent(in) :: pdf_data
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(3x,A,I0)") "PDF set  = ", pdf_data%set
     write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type
   end subroutine pdf_data_write
 
 @ %def pdf_data_write
 @
 <<PDF: pdf data: TBP>>=
   procedure :: setup => pdf_data_setup
 <<PDF: procedures>>=
   subroutine pdf_data_setup (pdf_data, caller, beam_structure, lhapdf_member, set)
     class(pdf_data_t), intent(inout) :: pdf_data
     character(len=*), intent(in) :: caller
     type(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: lhapdf_member, set
     real(default) :: xmin, xmax, q2min, q2max
     pdf_data%set = set
     if (beam_structure%contains ("lhapdf")) then
        if (LHAPDF6_AVAILABLE) then
           pdf_data%type = STRF_LHAPDF6
        else if (LHAPDF5_AVAILABLE) then
           pdf_data%type = STRF_LHAPDF5
        end if
        write (msg_buffer, "(A,I0)")  caller &
             // ": interfacing LHAPDF set #", pdf_data%set
        call msg_message ()
     else if (beam_structure%contains ("pdf_builtin")) then
        pdf_data%type = STRF_PDF_BUILTIN
        write (msg_buffer, "(A,I0)")  caller &
             // ": interfacing PDF builtin set #", pdf_data%set
        call msg_message ()
     end if
     select case (pdf_data%type)
     case (STRF_LHAPDF6)
        pdf_data%xmin = pdf_data%pdf%getxmin ()
        pdf_data%xmax = pdf_data%pdf%getxmax ()
        pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ())
        pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ())
     case (STRF_LHAPDF5)
        call GetXminM (1, lhapdf_member, xmin)
        call GetXmaxM (1, lhapdf_member, xmax)
        call GetQ2minM (1, lhapdf_member, q2min)
        call GetQ2maxM (1, lhapdf_member, q2max)
        pdf_data%xmin = xmin
        pdf_data%xmax = xmax
        pdf_data%qmin = sqrt(q2min)
        pdf_data%qmax = sqrt(q2max)
     end select
   end subroutine pdf_data_setup
 
 @ %def pdf_data_setup
 @ This could be overloaded with a version that only asks for a specific
 flavor as it is supported by LHAPDF6.
 <<PDF: pdf data: TBP>>=
   procedure :: evolve => pdf_data_evolve
 <<PDF: procedures>>=
   subroutine pdf_data_evolve (pdf_data, x, q_in, f)
     class(pdf_data_t), intent(inout) :: pdf_data
     real(double), intent(in) :: x, q_in
     real(double), dimension(-6:6), intent(out) :: f
     real(double) :: q
     select case (pdf_data%type)
     case (STRF_PDF_BUILTIN)
        call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f)
     case (STRF_LHAPDF6)
        q = min (pdf_data%qmax, q_in)
        q = max (pdf_data%qmin, q)
        call pdf_data%pdf%evolve_pdfm (x, q, f)
     case (STRF_LHAPDF5)
        q = min (pdf_data%qmax, q_in)
        q = max (pdf_data%qmin, q)
        call evolvePDFM (pdf_data%set, x, q, f)
     case default
        call msg_fatal ("PDF function: unknown PDF method.")
     end select
   end subroutine pdf_data_evolve
 @ %def pdf_data_evolve
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Dispatch}
 @
 <<[[dispatch_beams.f90]]>>=
 <<File header>>
 
 module dispatch_beams
 
 <<Use kinds>>
 <<Use strings>>
   use diagnostics
   use os_interface, only: os_data_t
   use variables, only: var_list_t
-  use constants, only: PI
+  use constants, only: PI, one
   use numeric_utils, only: vanishes
   use physics_defs, only: PHOTON
   use rng_base, only: rng_factory_t
   use pdg_arrays
   use model_data, only: model_data_t
   use dispatch_rng, only: dispatch_rng_factory
   use dispatch_rng, only: update_rng_seed_in_var_list
   use flavors, only: flavor_t
   use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t
   use sm_qcd, only: alpha_qcd_from_lambda_t
-  use physics_defs, only: MZ_REF, ALPHA_QCD_MZ_REF
+  use sm_qed, only: qed_t, alpha_qed_fixed_t, alpha_qed_from_scale_t
+  use physics_defs, only: MZ_REF, ME_REF, ALPHA_QCD_MZ_REF, ALPHA_QED_ME_REF
 
   use beam_structures
   use sf_base
   use sf_mappings
   use sf_isr
   use sf_epa
   use sf_ewa
   use sf_escan
   use sf_gaussian
   use sf_beam_events
   use sf_circe1
   use sf_circe2
   use sf_pdf_builtin
   use sf_lhapdf
 
 <<Standard module head>>
 
 <<Dispatch beams: public>>
 
 <<Dispatch beams: types>>
 
 <<Dispatch beams: variables>>
 
 contains
 
 <<Dispatch beams: procedures>>
 
 end module dispatch_beams
 @ %def dispatch_beams
 @ This data type is a container for transferring structure-function
 specific data from the [[dispatch_sf_data]] to the
 [[dispatch_sf_channels]] subroutine.
 <<Dispatch beams: public>>=
   public :: sf_prop_t
 <<Dispatch beams: types>>=
   type :: sf_prop_t
      real(default), dimension(2) :: isr_eps = 1
   end type sf_prop_t
 
 @ %def sf_prop_t
 @
 Allocate a structure-function configuration object according to the
 [[sf_method]] string.
 
 The [[sf_prop]] object can be used to transfer structure-function
 specific data up and to the [[dispatch_sf_channels]] subroutine below,
 so they can be used for particular mappings.
 
 The [[var_list_global]] object is used for the RNG generator seed.
 It is intent(inout) because the RNG generator seed
 may change during initialization.
 
 The [[pdg_in]] array is the array of incoming flavors, corresponding
 to the upstream structure function or the beam array.  This will be
 checked for the structure function in question and replaced by the
 outgoing flavors.  The [[pdg_prc]] array is the array of incoming
 flavors (beam index, component index) for the hard process.
 <<Dispatch beams: public>>=
   public :: dispatch_sf_data
 <<Dispatch beams: procedures>>=
   subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, &
          var_list, var_list_global, model, &
          os_data, sqrts, pdg_in, pdg_prc, polarized)
     class(sf_data_t), allocatable, intent(inout) :: data
     type(string_t), intent(in) :: sf_method
     integer, dimension(:), intent(in) :: i_beam
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_in
     type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
     type(sf_prop_t), intent(inout) :: sf_prop
     type(var_list_t), intent(in) :: var_list
     type(var_list_t), intent(inout) :: var_list_global
     integer :: next_rng_seed
     class(model_data_t), target, intent(in) :: model
     type(os_data_t), intent(in) :: os_data
     real(default), intent(in) :: sqrts
     logical, intent(in) :: polarized
     type(pdg_array_t), dimension(:), allocatable :: pdg_out
     real(default) :: isr_alpha, isr_q_max, isr_mass
     integer :: isr_order
     logical :: isr_recoil, isr_keep_energy
     real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_q_max, epa_mass
     logical :: epa_recoil, epa_keep_energy
     integer :: epa_int_mode
     type(string_t) :: epa_mode
     real(default) :: ewa_x_min, ewa_pt_max, ewa_mass
     logical :: ewa_recoil, ewa_keep_energy
     type(pdg_array_t), dimension(:), allocatable :: pdg_prc1
     integer :: ewa_id
     type(string_t) :: pdf_name
     type(string_t) :: lhapdf_dir, lhapdf_file
     type(string_t), dimension(13) :: lhapdf_photon_sets
     integer :: lhapdf_member, lhapdf_photon_scheme
     logical :: hoppet_b_matching
     class(rng_factory_t), allocatable :: rng_factory
     logical :: circe1_photon1, circe1_photon2, circe1_generate, &
          circe1_with_radiation
     real(default) :: circe1_sqrts, circe1_eps
     integer :: circe1_version, circe1_chattiness, &
          circe1_revision
     character(6) :: circe1_accelerator
     logical :: circe2_polarized
     type(string_t) :: circe2_design, circe2_file
     real(default), dimension(2) :: gaussian_spread
     logical :: beam_events_warn_eof
     type(string_t) :: beam_events_dir, beam_events_file
     logical :: escan_normalize
     integer :: i
     lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), &
          var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), &
          var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), &
          var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), &
          var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), &
          var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), &
          var_str ("SASG.LHgrid")]
     select case (char (sf_method))
     case ("pdf_builtin")
        allocate (pdf_builtin_data_t :: data)
        select type (data)
        type is (pdf_builtin_data_t)
           pdf_name = &
                var_list%get_sval (var_str ("$pdf_builtin_set"))
           hoppet_b_matching = &
                var_list%get_lval (var_str ("?hoppet_b_matching"))
           call data%init ( &
                model, pdg_in(i_beam(1)), &
                name = pdf_name, &
                path = os_data%pdf_builtin_datapath, &
                hoppet_b_matching = hoppet_b_matching)
        end select
     case ("pdf_builtin_photon")
        call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", &
             [var_str ("for the photon content inside a proton or neutron use"), &
              var_str ("the 'lhapdf_photon' structure function.")])
     case ("lhapdf")
        allocate (lhapdf_data_t :: data)
        if (pdg_array_get (pdg_in(i_beam(1)), 1) == PHOTON) then
           call msg_fatal ("The 'lhapdf' structure is intended only for protons and", &
                [var_str ("pions, please use 'lhapdf_photon' for photon beams.")])
        end if
        lhapdf_dir = &
             var_list%get_sval (var_str ("$lhapdf_dir"))
        lhapdf_file = &
             var_list%get_sval (var_str ("$lhapdf_file"))
        lhapdf_member = &
             var_list%get_ival (var_str ("lhapdf_member"))
        lhapdf_photon_scheme = &
             var_list%get_ival (var_str ("lhapdf_photon_scheme"))
        hoppet_b_matching = &
             var_list%get_lval (var_str ("?hoppet_b_matching"))
        select type (data)
        type is (lhapdf_data_t)
           call data%init &
                (model, pdg_in(i_beam(1)), &
                 lhapdf_dir, lhapdf_file, lhapdf_member, &
                 lhapdf_photon_scheme, hoppet_b_matching)
        end select
     case ("lhapdf_photon")
        allocate (lhapdf_data_t :: data)
        if (pdg_array_get_length (pdg_in(i_beam(1))) /= 1 .or. &
             pdg_array_get (pdg_in(i_beam(1)), 1) /= PHOTON) then
           call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", &
                [var_str ("photon PDFs, i.e. for photons as beam particles")])
        end if
        lhapdf_dir = &
             var_list%get_sval (var_str ("$lhapdf_dir"))
        lhapdf_file = &
             var_list%get_sval (var_str ("$lhapdf_photon_file"))
        lhapdf_member = &
             var_list%get_ival (var_str ("lhapdf_member"))
        lhapdf_photon_scheme = &
             var_list%get_ival (var_str ("lhapdf_photon_scheme"))
        if (.not. any (lhapdf_photon_sets == lhapdf_file)) then
           call msg_fatal ("This PDF set is not supported or not " // &
                "intended for photon beams.")
        end if
        select type (data)
        type is (lhapdf_data_t)
           call data%init &
                (model, pdg_in(i_beam(1)), &
                 lhapdf_dir, lhapdf_file, lhapdf_member, &
                 lhapdf_photon_scheme)
        end select
     case ("isr")
        allocate (isr_data_t :: data)
        isr_alpha = &
             var_list%get_rval (var_str ("isr_alpha"))
        if (vanishes (isr_alpha)) then
           isr_alpha = (var_list%get_rval (var_str ("ee"))) &
                ** 2 / (4 * PI)
        end if
        isr_q_max = &
             var_list%get_rval (var_str ("isr_q_max"))
        if (vanishes (isr_q_max)) then
           isr_q_max = sqrts
        end if
        isr_mass   = var_list%get_rval (var_str ("isr_mass"))
        isr_order  = var_list%get_ival (var_str ("isr_order"))
        isr_recoil = var_list%get_lval (var_str ("?isr_recoil"))
        isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy"))
        select type (data)
        type is (isr_data_t)
           call data%init &
                (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, &
                isr_mass, isr_order, recoil = isr_recoil, keep_energy = &
                isr_keep_energy)
           call data%check ()
           sf_prop%isr_eps(i_beam(1)) = data%get_eps ()
        end select
     case ("epa")
        allocate (epa_data_t :: data)
        epa_mode = var_list%get_sval (var_str ("$epa_mode"))
        epa_int_mode = 0
        epa_alpha = var_list%get_rval (var_str ("epa_alpha"))
        if (vanishes (epa_alpha)) then
           epa_alpha = (var_list%get_rval (var_str ("ee"))) &
                ** 2 / (4 * PI)
        end if
        epa_x_min = var_list%get_rval (var_str ("epa_x_min"))
        epa_q_min = var_list%get_rval (var_str ("epa_q_min"))
        epa_q_max = var_list%get_rval (var_str ("epa_q_max"))
        if (vanishes (epa_q_max)) then
           epa_q_max = sqrts
        end if
        select case (char (epa_mode))
        case ("default", "Budnev_617")
           epa_int_mode = 0
        case ("Budnev_616e")
           epa_int_mode = 1
        case ("log_power")
           epa_int_mode = 2
           epa_q_max = sqrts
        case ("log_simple")
           epa_int_mode = 3
           epa_q_max = sqrts
        case ("log")
           epa_int_mode = 4
           epa_q_max = sqrts
        case default
           call msg_fatal ("EPA: unsupported EPA mode; please choose " // &
                "'default', 'Budnev_616', 'Budnev_616e', 'log_power', " // &
                "'log_simple', or 'log'")
        end select
        epa_mass   = var_list%get_rval (var_str ("epa_mass"))
        epa_recoil = var_list%get_lval (var_str ("?epa_recoil"))
        epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy"))
        select type (data)
        type is (epa_data_t)
           call data%init &
                (model, epa_int_mode, pdg_in (i_beam(1)), epa_alpha, &
                epa_x_min, epa_q_min, epa_q_max, epa_mass, &
                recoil = epa_recoil, keep_energy = epa_keep_energy)
           call data%check ()
        end select
     case ("ewa")
        allocate (ewa_data_t :: data)
        allocate (pdg_prc1 (size (pdg_prc, 2)))
        pdg_prc1 = pdg_prc(i_beam(1),:)
        if (any (pdg_array_get_length (pdg_prc1) /= 1) &
             .or. any (pdg_prc1 /= pdg_prc1(1))) then
           call msg_fatal &
                ("EWA: process incoming particle (W/Z) must be unique")
        end if
        ewa_id = abs (pdg_array_get (pdg_prc1(1), 1))
        ewa_x_min = var_list%get_rval (var_str ("ewa_x_min"))
        ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max"))
        if (vanishes (ewa_pt_max)) then
           ewa_pt_max = sqrts
        end if
        ewa_mass = var_list%get_rval (var_str ("ewa_mass"))
        ewa_recoil = var_list%get_lval (&
             var_str ("?ewa_recoil"))
        ewa_keep_energy = var_list%get_lval (&
             var_str ("?ewa_keep_energy"))
        select type (data)
        type is (ewa_data_t)
           call data%init &
                (model, pdg_in (i_beam(1)), ewa_x_min, &
                ewa_pt_max, sqrts, ewa_recoil, &
                ewa_keep_energy, ewa_mass)
           call data%set_id (ewa_id)
           call data%check ()
        end select
     case ("circe1")
        allocate (circe1_data_t :: data)
        select type (data)
        type is (circe1_data_t)
           circe1_photon1 = &
                var_list%get_lval (var_str ("?circe1_photon1"))
           circe1_photon2 = &
                var_list%get_lval (var_str ("?circe1_photon2"))
           circe1_sqrts = &
                var_list%get_rval (var_str ("circe1_sqrts"))
           circe1_eps = &
                var_list%get_rval (var_str ("circe1_eps"))
           if (circe1_sqrts <= 0)  circe1_sqrts = sqrts
           circe1_generate = &
                var_list%get_lval (var_str ("?circe1_generate"))
           circe1_version = &
                var_list%get_ival (var_str ("circe1_ver"))
           circe1_revision = &
                var_list%get_ival (var_str ("circe1_rev"))
           circe1_accelerator = &
                char (var_list%get_sval (var_str ("$circe1_acc")))
           circe1_chattiness = &
                var_list%get_ival (var_str ("circe1_chat"))
           circe1_with_radiation = &
                var_list%get_lval (var_str ("?circe1_with_radiation"))
           call data%init (model, pdg_in, circe1_sqrts, circe1_eps, &
                [circe1_photon1, circe1_photon2], &
                circe1_version, circe1_revision, circe1_accelerator, &
                circe1_chattiness, circe1_with_radiation)
           if (circe1_generate) then
              call msg_message ("CIRCE1: activating generator mode")
              call dispatch_rng_factory &
                   (rng_factory, var_list_global, next_rng_seed)
              call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
              call data%set_generator_mode (rng_factory)
           end if
        end select
     case ("circe2")
        allocate (circe2_data_t :: data)
        select type (data)
        type is (circe2_data_t)
           circe2_polarized = &
                var_list%get_lval (var_str ("?circe2_polarized"))
           circe2_file = &
                var_list%get_sval (var_str ("$circe2_file"))
           circe2_design = &
                var_list%get_sval (var_str ("$circe2_design"))
           call data%init (os_data, model, pdg_in, sqrts, &
                circe2_polarized, polarized, circe2_file, circe2_design)
           call msg_message ("CIRCE2: activating generator mode")
           call dispatch_rng_factory &
                (rng_factory, var_list_global, next_rng_seed)
           call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
           call data%set_generator_mode (rng_factory)
        end select
     case ("gaussian")
        allocate (gaussian_data_t :: data)
        select type (data)
        type is (gaussian_data_t)
           gaussian_spread = &
                [var_list%get_rval (var_str ("gaussian_spread1")), &
                var_list%get_rval (var_str ("gaussian_spread2"))]
           call dispatch_rng_factory &
                (rng_factory, var_list_global, next_rng_seed)
           call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
           call data%init (model, pdg_in, gaussian_spread, rng_factory)
        end select
     case ("beam_events")
        allocate (beam_events_data_t :: data)
        select type (data)
        type is (beam_events_data_t)
           beam_events_dir = os_data%whizard_beamsimpath
           beam_events_file = var_list%get_sval (&
                var_str ("$beam_events_file"))
           beam_events_warn_eof = var_list%get_lval (&
                var_str ("?beam_events_warn_eof"))
           call data%init (model, pdg_in, &
                   beam_events_dir, beam_events_file, beam_events_warn_eof)
        end select
     case ("energy_scan")
        escan_normalize = &
             var_list%get_lval (var_str ("?energy_scan_normalize"))
        allocate (escan_data_t :: data)
        select type (data)
        type is (escan_data_t)
           if (escan_normalize) then
              call data%init (model, pdg_in)
           else
              call data%init (model, pdg_in, sqrts)
           end if
        end select
     case default
        if (associated (dispatch_sf_data_extra)) then
           call dispatch_sf_data_extra (data, sf_method, i_beam, &
                sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, &
                pdg_prc, polarized)
        end if
        if (.not. allocated (data)) then
           call msg_fatal ("Structure function '" &
                // char (sf_method) // "' not implemented")
        end if
     end select
     if (allocated (data)) then
        allocate (pdg_out (size (pdg_prc, 1)))
        call data%get_pdg_out (pdg_out)
        do i = 1, size (i_beam)
           pdg_in(i_beam(i)) = pdg_out(i)
        end do
     end if
   end subroutine dispatch_sf_data
 
 @ %def dispatch_sf_data
 @ This is a hook that allows us to inject further handlers for
 structure-function objects, in particular a test structure function.
 <<Dispatch beams: public>>=
   public :: dispatch_sf_data_extra
 <<Dispatch beams: variables>>=
   procedure (dispatch_sf_data), pointer :: &
        dispatch_sf_data_extra => null ()
 @ %def dispatch_sf_data_extra
 @ This is an auxiliary procedure, used by the beam-structure
 expansion: tell for a given structure function name, whether it
 corresponds to a pair spectrum ($n=2$), a single-particle structure
 function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can
 in principle also be a pair spectrum, it always has only one
 parameter.
 <<Dispatch beams: public>>=
   public :: strfun_mode
 <<Dispatch beams: procedures>>=
   function strfun_mode (name) result (n)
     type(string_t), intent(in) :: name
     integer :: n
     select case (char (name))
     case ("none")
        n = 0
     case ("sf_test_0", "sf_test_1")
        n = 1
     case ("pdf_builtin","pdf_builtin_photon", &
           "lhapdf","lhapdf_photon")
        n = 1
     case ("isr","epa","ewa")
        n = 1
     case ("circe1", "circe2")
        n = 2
     case ("gaussian")
        n = 2
     case ("beam_events")
        n = 2
     case ("energy_scan")
        n = 2
     case default
        n = -1
        call msg_bug ("Structure function '" // char (name) &
             // "' not supported yet")
     end select
   end function strfun_mode
 
 @ %def strfun_mode
 @ Dispatch a whole structure-function chain, given beam data and beam
 structure data.
 
 This could be done generically, but we should look at the specific
 combination of structure functions in order to select appropriate mappings.
 
 The [[beam_structure]] argument gets copied because
 we want to expand it to canonical form (one valid structure-function
 entry per record) before proceeding further.
 
 The [[pdg_prc]] argument is the array of incoming flavors.  The first
 index is the beam index, the second one the process component index.
 Each element is itself a PDG array, notrivial if there is a flavor sum
 for the incoming state of this component.
 
 The dispatcher is divided in two parts.  The first part configures the
 structure function data themselves.  After this, we can configure the
 phase space for the elementary process.
 <<Dispatch beams: public>>=
   public :: dispatch_sf_config
 <<Dispatch beams: procedures>>=
   subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, &
          var_list, var_list_global, model, os_data, sqrts, pdg_prc)
     type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config
     type(sf_prop_t), intent(out) :: sf_prop
     type(beam_structure_t), intent(inout) :: beam_structure
     type(var_list_t), intent(in) :: var_list
     type(var_list_t), intent(inout) :: var_list_global
     class(model_data_t), target, intent(in) :: model
     type(os_data_t), intent(in) :: os_data
     real(default), intent(in) :: sqrts
     class(sf_data_t), allocatable :: sf_data
     type(beam_structure_t) :: beam_structure_tmp
     type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
     type(string_t), dimension(:), allocatable :: prt_in
     type(pdg_array_t), dimension(:), allocatable :: pdg_in
     type(flavor_t) :: flv_in
     integer :: n_beam, n_record, i
     beam_structure_tmp = beam_structure
     call beam_structure_tmp%expand (strfun_mode)
     n_record = beam_structure_tmp%get_n_record ()
     allocate (sf_config (n_record))
     n_beam = beam_structure_tmp%get_n_beam ()
     if (n_beam > 0) then
        allocate (prt_in (n_beam), pdg_in (n_beam))
        prt_in = beam_structure_tmp%get_prt ()
        do i = 1, n_beam
           call flv_in%init (prt_in(i), model)
           pdg_in(i) = flv_in%get_pdg ()
        end do
     else
        n_beam = size (pdg_prc, 1)
        allocate (pdg_in (n_beam))
        pdg_in = pdg_prc(:,1)
     end if
     do i = 1, n_record
        call dispatch_sf_data (sf_data, &
             beam_structure_tmp%get_name (i), &
             beam_structure_tmp%get_i_entry (i), &
             sf_prop, var_list, var_list_global, model, os_data, sqrts, &
             pdg_in, pdg_prc, &
             beam_structure_tmp%polarized ())
        call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data)
        deallocate (sf_data)
     end do
   end subroutine dispatch_sf_config
 
 @ %def dispatch_sf_config
 @
-\subsection{QCD coupling}
+\subsection{QCD and QED coupling}
 Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with
 a concrete implementation, depending on the variable settings in the
 [[global]] record.
 
 If a fixed $\alpha_s$ is requested, we do not allocate the
 [[qcd%alpha]] object.  In this case, the matrix element code will just take
 the model parameter as-is, which implies fixed $\alpha_s$.  If the
 object is allocated, the $\alpha_s$ value is computed and updated for
 each matrix-element call.
 
 Also fetch the [[alphas_nf]] variable from the list and store it in
 the QCD record.  This is not used in the $\alpha_s$ calculation, but
 the QCD record thus becomes a messenger for this user parameter.
 <<Dispatch beams: public>>=
   public :: dispatch_qcd
 <<Dispatch beams: procedures>>=
   subroutine dispatch_qcd (qcd, var_list, os_data)
     type(qcd_t), intent(inout) :: qcd
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd
     real(default) :: mz, alpha_val, lambda
     integer :: nf, order, lhapdf_member
     type(string_t) :: pdfset, lhapdf_dir, lhapdf_file
     call unpack_variables ()
     if (allocated (qcd%alpha))  deallocate (qcd%alpha)
     if (from_lhapdf .and. from_pdf_builtin) then
         call msg_fatal (" Mixing alphas evolution",  &
              [var_str (" from LHAPDF and builtin PDF is not permitted")])
     end if
     select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd]))
     case (0)
        if (fixed) then
           allocate (alpha_qcd_fixed_t :: qcd%alpha)
        else
           call msg_fatal ("QCD alpha: no calculation mode set")
        end if
     case (2:)
        call msg_fatal ("QCD alpha: calculation mode is ambiguous")
     case (1)
        if (fixed) then
           call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // &
                "running alphas")
        else if (from_mz) then
           allocate (alpha_qcd_from_scale_t :: qcd%alpha)
        else if (from_pdf_builtin) then
           allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha)
        else if (from_lhapdf) then
           allocate (alpha_qcd_lhapdf_t :: qcd%alpha)
        else if (from_lambda_qcd) then
           allocate (alpha_qcd_from_lambda_t :: qcd%alpha)
        end if
        call msg_message ("QCD alpha: using a running strong coupling")
     end select
     call init_alpha ()
     qcd%n_f = var_list%get_ival (var_str ("alphas_nf"))
   contains
   <<Dispatch qcd: dispatch qcd: procedures>>
   end subroutine dispatch_qcd
 
 @ %def dispatch_qcd
 @
 <<Dispatch qcd: dispatch qcd: procedures>>=
   subroutine unpack_variables ()
     fixed = var_list%get_lval (var_str ("?alphas_is_fixed"))
     from_mz = var_list%get_lval (var_str ("?alphas_from_mz"))
     from_pdf_builtin = &
          var_list%get_lval (var_str ("?alphas_from_pdf_builtin"))
     from_lhapdf = &
          var_list%get_lval (var_str ("?alphas_from_lhapdf"))
     from_lambda_qcd = &
          var_list%get_lval (var_str ("?alphas_from_lambda_qcd"))
     pdfset = var_list%get_sval (var_str ("$pdf_builtin_set"))
     lambda = var_list%get_rval (var_str ("lambda_qcd"))
     nf = var_list%get_ival (var_str ("alphas_nf"))
     order = var_list%get_ival (var_str ("alphas_order"))
     lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir"))
     lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file"))
     lhapdf_member = var_list%get_ival (var_str ("lhapdf_member"))
     if (var_list%contains (var_str ("mZ"))) then
        mz = var_list%get_rval (var_str ("mZ"))
     else
        mz = MZ_REF
     end if
     if (var_list%contains (var_str ("alphas"))) then
        alpha_val = var_list%get_rval (var_str ("alphas"))
     else
        alpha_val = ALPHA_QCD_MZ_REF
     end if
   end subroutine unpack_variables
 
 @
 <<Dispatch qcd: dispatch qcd: procedures>>=
   subroutine init_alpha ()
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_fixed_t)
        alpha%val = alpha_val
     type is (alpha_qcd_from_scale_t)
        alpha%mu_ref = mz
        alpha%ref = alpha_val
        alpha%order = order
        alpha%nf = nf
     type is (alpha_qcd_from_lambda_t)
        alpha%lambda = lambda
        alpha%order = order
        alpha%nf = nf
     type is (alpha_qcd_pdf_builtin_t)
        call alpha%init (pdfset, &
             os_data%pdf_builtin_datapath)
     type is (alpha_qcd_lhapdf_t)
        call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir)
     end select
   end subroutine init_alpha
 
 @
+@ Same for QED.
+<<Dispatch beams: public>>=
+  public :: dispatch_qed
+<<Dispatch beams: procedures>>=
+  subroutine dispatch_qed (qed, var_list)
+    type(qed_t), intent(inout) :: qed
+    type(var_list_t), intent(in) :: var_list
+    logical :: fixed, from_me, analytic
+    real(default) :: me, alpha_val
+    integer :: nf, nlep, order
+    call unpack_variables ()
+    if (allocated (qed%alpha))  deallocate (qed%alpha)
+    select case (count ([from_me]))
+    case (0)
+       if (fixed) then
+          allocate (alpha_qed_fixed_t :: qed%alpha)
+       else
+          call msg_fatal ("QED alpha: no calculation mode set")
+       end if
+    case (2:)
+       call msg_fatal ("QED alpha: calculation mode is ambiguous")
+    case (1)
+       if (fixed) then
+          call msg_fatal ("QED alpha: use '?alphas_is_fixed = false' for " // &
+               "running alpha")
+       else if (from_me) then
+          allocate (alpha_qed_from_scale_t :: qed%alpha)
+       end if
+       call msg_message ("QED alpha: using a running electromagnetic coupling")
+    end select
+    call init_alpha ()
+    if (var_list%get_ival (var_str ("alpha_nf")) == -1) then
+       qed%n_f = var_list%get_ival (var_str ("alphas_nf"))
+    else
+       qed%n_f = var_list%get_ival (var_str ("alpha_nf"))
+    end if
+    qed%n_lep = var_list%get_ival (var_str ("alpha_nlep"))
+  contains
+  <<Dispatch qed: dispatch qed: procedures>>
+  end subroutine dispatch_qed
+
+@ %def dispatch_qed
+@
+<<Dispatch qed: dispatch qed: procedures>>=
+  subroutine unpack_variables ()
+    fixed = var_list%get_lval (var_str ("?alpha_is_fixed"))
+    from_me = var_list%get_lval (var_str ("?alpha_from_me"))
+    if (var_list%get_ival (var_str ("alpha_nf")) == -1) then
+       nf = var_list%get_ival (var_str ("alphas_nf"))
+    else
+       nf = var_list%get_ival (var_str ("alpha_nf"))
+    end if
+    analytic = var_list%get_lval (var_str ("?alpha_evolve_analytic"))
+    nlep = var_list%get_ival (var_str ("alpha_nlep"))
+    order = var_list%get_ival (var_str ("alpha_order"))
+    if (var_list%contains (var_str ("me"))) then
+       me = var_list%get_rval (var_str ("me"))
+    else
+       me = ME_REF
+    end if
+    if (var_list%contains (var_str ("alpha_em_i"))) then
+       alpha_val = one / var_list%get_rval (var_str ("alpha_em_i"))
+    else
+       alpha_val = ALPHA_QED_ME_REF
+    end if
+  end subroutine unpack_variables
+
+@
+<<Dispatch qed: dispatch qed: procedures>>=
+  subroutine init_alpha ()
+    select type (alpha => qed%alpha)
+    type is (alpha_qed_fixed_t)
+       alpha%val = alpha_val
+    type is (alpha_qed_from_scale_t)
+       alpha%mu_ref = me
+       alpha%ref = alpha_val
+       alpha%order = order
+       alpha%nf = nf
+       alpha%nlep = nlep
+       alpha%analytic = analytic
+    end select
+  end subroutine init_alpha
+
+@
Index: trunk/src/variables/variables.nw
===================================================================
--- trunk/src/variables/variables.nw	(revision 8766)
+++ trunk/src/variables/variables.nw	(revision 8767)
@@ -1,7015 +1,7049 @@
 % -*- 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
   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_OBSEV_INT = 13, V_OBSEV_REAL = 23
   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 V_OBS1_INT
 @ %def V_OBS2_INT V_OBSEV_INT V_OBS1_REAL V_OBS2_REAL V_OBSEV_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 ()
      procedure(obs_sev_int),  nopass, pointer :: obsev_int  => null ()
      procedure(obs_sev_real), nopass, pointer :: obsev_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
   public :: obs_sev_int
   public :: obs_sev_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
   abstract interface
      function obs_sev_int (sev) result (ival)
        import
        integer :: ival
        type(subevt_t), intent(in) :: sev
      end function obs_sev_int
   end interface
   abstract interface
      function obs_sev_real (sev) result (rval)
        import
        real(default) :: rval
        type(subevt_t), intent(in) :: sev
      end function obs_sev_real
   end interface
 
 @ %def obs_unary_int obs_unary_real
 @ %def obs_binary_int obs_binary_real
 @ %def obs_sev_int obs_sev_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
 
   subroutine var_entry_init_obs_sev (var, name, type, pval)
     type(var_entry_t), intent(out) :: var
     type(string_t), intent(in) :: name
     integer, intent(in) :: type
     type(subevt_t), intent(in), target :: pval
     var%type = type
     var%name = name
     var%pval => pval
     var%is_intrinsic = .true.
     var%is_defined = .true.
   end subroutine var_entry_init_obs_sev
 
 @ %def var_entry_init_obs var_entry_init_obs_sev
 @ 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_OBSEV_INT);  write (u, "(A)", advance=advance) "[int] = subeventary 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_OBSEV_REAL); write (u, "(A)", advance=advance) "[real] = subeventary 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
 
   subroutine var_entry_assign_obsev_int_ptr (ptr, var)
     procedure(obs_sev_int), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obsev_int
   end subroutine var_entry_assign_obsev_int_ptr
 
   subroutine var_entry_assign_obsev_real_ptr (ptr, var)
     procedure(obs_sev_real), pointer :: ptr
     type(var_entry_t), intent(in), target :: var
     ptr => var%obsev_real
   end subroutine var_entry_assign_obsev_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
 @ %def var_entry_assigbn_obsev_int_ptr var_entry_assign_obsev_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_obsev_iptr => var_list_get_obsev_iptr
   procedure :: get_obs1_rptr => var_list_get_obs1_rptr
   procedure :: get_obs2_rptr => var_list_get_obs2_rptr
   procedure :: get_obsev_rptr => var_list_get_obsev_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_obsev_iptr (var_list, name, obsev_iptr, pval)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr
     type(subevt_t), pointer, intent(out) :: pval
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBSEV_INT)
     if (associated (var)) then
        call var_entry_assign_obsev_int_ptr (obsev_iptr, var)
        pval => var_entry_get_pval_ptr (var)
     else
        obsev_iptr => null ()
        pval => null ()
     end if
   end subroutine var_list_get_obsev_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
 
   subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval)
     class(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr
     type(subevt_t), pointer, intent(out) :: pval
     type(var_entry_t), pointer :: var
     var => var_list_get_var_ptr (var_list, name, V_OBSEV_REAL)
     if (associated (var)) then
        call var_entry_assign_obsev_real_ptr (obsev_rptr, var)
        pval => var_entry_get_pval_ptr (var)
     else
        obsev_rptr => null ()
        pval => null ()
     end if
   end subroutine var_list_get_obsev_rptr
 
 @ %def var_list_get_obs1_iptr
 @ %def var_list_get_obs2_iptr
 @ %def var_list_get_obsev_iptr
 @ %def var_list_get_obs1_rptr
 @ %def var_list_get_obs2_rptr
 @ %def var_list_get_obsev_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
   public :: var_list_append_obsev_iptr
   public :: var_list_append_obsev_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_obsev_iptr (var_list, name, obsev_iptr, sev)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_sev_int) :: obsev_iptr
     type(subevt_t), intent(in), target :: sev
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs_sev (var, name, V_OBSEV_INT, sev)
     var%obsev_int => obsev_iptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obsev_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
 
   subroutine var_list_append_obsev_rptr (var_list, name, obsev_rptr, sev)
     type(var_list_t), intent(inout) :: var_list
     type(string_t), intent(in) :: name
     procedure(obs_sev_real) :: obsev_rptr
     type(subevt_t), intent(in), target :: sev
     type(var_entry_t), pointer :: var
     allocate (var)
     call var_entry_init_obs_sev (var, name, V_OBSEV_REAL, sev)
     var%obsev_real => obsev_rptr
     call var_list_append (var_list, var)
   end subroutine var_list_append_obsev_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_recomb_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})'))
     call var_list%append_string (var_str ("$negative_sf"), var_str ("default"), &
           intrinsic=.true., &
           description=var_str ('String variable to set the behavior to either ' // &
           'keep negative structure function/PDF values or set them to zero. ' // &
           'The default (\ttt{"default"}) takes the first option for NLO and the ' // &
           'second for LO processes. Explicit behavior can be set with ' // &
           '\ttt{"positive"} or \ttt{"negative"}.'))
   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}$ ' // &
+          'QCD $\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 ("?alpha_is_fixed"), .true., &
+          intrinsic=.true., &
+          description=var_str ('Flag that tells \whizard\ to use a non-running ' // &
+          'QED $\alpha$. Note that this has to be set explicitly to $\ttt{false}$ ' // &
+          'if the user wants to use one of the running $\alpha$ options. ' // &
+          '(cf. also \ttt{alpha\_order}, \ttt{alpha\_nf}, \ttt{alpha\_lep}, ' // &
+          '\ttt{?alphas\_from\_me}'))
     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_log (var_str ("?alpha_evolve_analytic"), .true., &
+          intrinsic=.true., &
+          description=var_str ('Flag that tells \whizard\ to use analytic running ' // &
+          'formulae for $\alpha$ instead of a numeric Runge-Kutta. ' // &
+          '(cf. also \ttt{alpha\_order}, \ttt{?alpha\_is\_fixed}, ' // &
+          '\ttt{alpha\_nf}, \ttt{alpha\_nlep}, \ttt{?alpha\_from\_me}) '))
     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 ("alpha_order"), 0, &
+          intrinsic=.true., &
+          description=var_str ('Integer parameter that sets the order ' // &
+          'of the internal evolution for running $\alpha$ in \whizard: ' // &
+          'the default, \ttt{0}, is LO running, \ttt{1} is NLO. ' // &
+          '(cf. also \ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, \ttt{alphas\_lep}, ' // &
+          '\ttt{?alpha\_from\_me})'))
     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. (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_int (var_str ("alpha_nf"), -1, &
+          intrinsic=.true., &
+          description=var_str ('Integer parameter that sets the number ' // &
+          'of active quark flavors for the internal evolution for running ' // &
+          '$\alpha$ in \whizard. The default, \ttt{-1}, keeps it equal to \ttt{alphas\_nf} ' // &
+          '\ttt{alpha\_is\_fixed}, \ttt{alphas\_order}, \ttt{?alpha\_from\_me}, ' // &
+          '\ttt{?alpha\_evolve\_analytic}'))
+    call var_list%append_int (var_str ("alpha_nlep"), 1, &
+          intrinsic=.true., &
+          description=var_str ('Integer parameter that sets the number ' // &
+          'of active leptons in the running of $\alpha$ in \whizard. The deffault is' // &
+          'one, with only the electron considered massless (cf. also ' // &
+          '\ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, ' // &
+          '\ttt{alpha\_order}, \ttt{?alpha\_from\_me}, \ttt{?alpha\_evolve\_analytic})'))
     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 ("?rescan_force"), .false., &
           intrinsic=.true., &
           description=var_str ('Flag that allows to bypass essential ' // &
           'checks on the particle set 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 ("?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 whether 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})'))
     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_int (var_str ("vamp_grid_checkpoint"), 1, &
           intrinsic=.true., &
           description=var_str ('Integer parameter for setting checkpoints to save ' // &
           'the current state of the grids and the results so far of the integration. ' // &
           'Allowed are all positive integer. Zero values corresponds to a checkpoint ' // &
           'after each integration pass, a one value to a checkpoint after each iteration ' // &
           '(default) and an \(N\) value correspond to a checkpoint after \(N\) iterations ' // &
           ' or after each pass, respectively.'))
     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.'))
     call var_list%append_string (var_str ("$vamp_parallel_method"), var_str ("simple"), &
          intrinsic=.true., &
          description=var_str ('Character string that tells \whizard\ ' // &
          'the parallel method to use for parallel integration within \ttt{vamp2}.' // &
          ' (i) \ttt{simple} (default) is a local work sharing approach without the need of communication ' // &
          'between all workers except for the communication during result collection.' // &
          ' (ii) \ttt{load} is a global queue approach where the master worker acts as a' // &
          'governor listening and providing work for each worker. The queue is filled and assigned with workers ' // &
          'a-priori with respect to the assumed computational impact of each channel.' // &
          'Both approaches use the same mechanism for result collection using non-blocking ' // &
          'communication allowing for a efficient usage of the computing resources.'))
   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 and photon recombination parameters and all that:
 <<Variables: var list: TBP>>=
   procedure :: set_isolation_recomb_defaults => &
        var_list_set_isolation_recomb_defaults
 <<Variables: procedures>>=
   subroutine var_list_set_isolation_recomb_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})'))
     call var_list%append_real (var_str ("photon_rec_r0"), 0.1_default, &
          intrinsic=.true., &
          description=var_str ('Photon recombination parameter $R_0^\gamma$ ' // &
          'for photon recombination in NLO EW calculations'))
     call var_list%append_log (&
          var_str ("?keep_flavors_when_recombining"), .true., &
          intrinsic = .true., &
          description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_recombining ' // &
          '= true/false} specifies whether the flavor of a particle should be ' // &
          'kept during \ttt{photon\_recombination} when a jet/lepton consists of one lepton/quark ' // &
          'and zero or more photons (cf. also \ttt{photon\_recombination}).'))
   end subroutine var_list_set_isolation_recomb_defaults
 
 @ %def var_list_set_isolation_recomb_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_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' // &
          'independent 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. Only supported for massless FSR. ' // &
          '(cf. also \ttt{fks\_dij\_exp1}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2})'))
     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 ('(Experimental) Real parameter 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. Could thus be used for debugging. ' // &
          'This is not implemented properly, use at your own risk!'))
     call var_list%append_real (var_str ("fks_delta_o"), &
          2._default, intrinsic = .true., &
          description = var_str ('Real parameter for the FKS ' // &
          'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$ ' // &
          'for final state singularities only. ' // &
          'The dependence on the parameter vanishes between real subtraction and integrated ' // &
          'subtraction term. For debugging purposes.'))
     call var_list%append_real (var_str ("fks_delta_i"), &
          2._default, intrinsic = .true., &
          description = var_str ('Real parameter 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. For debugging purposes.'))
     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_string (var_str ("$real_partition_mode"), var_str ("default"), &
          intrinsic=.true., &
          description=var_str ('String variable to choose which parts of the real cross ' // &
          'section are to be integrated. With the default value (\ttt{"default"}) ' // &
          'or \ttt{"off"} the real cross section is integrated as usual without partition. ' // &
          'If set to \ttt{"on"} or \ttt{"all"}, the real cross section is split into singular ' // &
          'and finite 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. If set to \ttt{"singular"} (\ttt{"finite"}), ' // &
          'only the singular (finite) real component is integrated.' // &
          '(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{\$real\_partition\_mode})'))
     call var_list%append_log (var_str ("?nlo_reuse_amplitudes_fks"), &
          .false., intrinsic = .true., &
          description=var_str ('Only compute real and virtual amplitudes for ' // &
          'subprocesses that give a different amplitude and reuse the result ' // &
          'for equivalent subprocesses. ' // &
          'Might give a speed-up for some processes. Might ' // &
          'break others, especially in cases where resonance histories are needed. ' // &
          'Experimental feature, use at your own risk!'))
   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
   public :: var_list_set_observables_sev
 <<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
 
   subroutine var_list_set_observables_sev (var_list, pval)
     type(var_list_t), intent(inout) :: var_list
     type(subevt_t), intent(in), target:: pval
     call var_list_append_obsev_rptr &
          (var_list, var_str ("Ht"), obs_ht, pval)
   end subroutine var_list_set_observables_sev
 
 @ %def var_list_set_observables_unary var_list_set_observables_binary
 @ %def var_list_set_observables_nary
 \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", "Nacl", &
          "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", &
          "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT", &
          "Ht")
        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
 @ Subeventary observables, e.g. the transverse mass $H_T$.
 <<Observables: procedures>>=
   real(default) function obs_ht (sev) result (ht)
     type(subevt_t), intent(in) :: sev
     integer :: i, n
     type(prt_t) :: prt
     n = subevt_get_length (sev)
     ht = 0
     do i = 1, n
        prt = subevt_get_prt (sev, i)
        ht = ht + &
             sqrt (obs_pt1(prt)**2 + obs_mass_squared1(prt))
     end do
   end function obs_ht
 
 @ %def obs_ht
Index: trunk/src/process_integration/process_integration.nw
===================================================================
--- trunk/src/process_integration/process_integration.nw	(revision 8766)
+++ trunk/src/process_integration/process_integration.nw	(revision 8767)
@@ -1,19803 +1,19803 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: integration and process objects and such
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Integration and Process Objects}
 \includemodulegraph{process_integration}
 
 This is the central part of the \whizard\ package.  It provides the
 functionality for evaluating structure functions, kinematics and matrix
 elements, integration and event generation.  It combines the various
 parts that deal with those tasks individually and organizes the data
 transfer between them.
 
 \begin{description}
 \item[subevt\_expr]
   This enables process observables as (abstract) expressions, to be
   evaluated for each process call.
 \item[parton\_states]
   A [[parton_state_t]] object represents an elementary partonic
   interaction.  There are two versions: one for the isolated
   elementary process, one for the elementary process convoluted with
   the structure-function chain.  The parton state is an effective
   state.  It needs not coincide with the seed-kinematics state which is
   used in evaluating phase space.
 \item[process]
   Here, all pieces are combined for the purpose of evaluating the
   elementary processes.  The whole algorithm is coded in terms of
   abstract data types as defined in the appropriate modules: [[prc_core]]
   for matrix-element evaluation, [[prc_core_def]] for the associated
   configuration and driver, [[sf_base]] for beams and structure-functions,
   [[phs_base]] for phase space, and [[mci_base]] for integration and event
   generation.
 \item[process\_config]
 \item[process\_counter]
   Very simple object for statistics
 \item[process\_mci]
 \item[pcm]
 \item[kinematics]
 \item[instances]
   While the above modules set up all static information, the instances
   have the changing event data. There are term and process instances but
   no component instances.
 \item[process\_stacks]
   Process stacks collect process objects.
 \end{description}
 
 We combine here hard interactions, phase space, and (for scatterings)
 structure functions and interfaces them to the integration module.
 
 The process object implements the combination of a fixed beam and
 structure-function setup with a number of elementary processes.  The
 latter are called process components.  The process object
 represents an entity which is supposedly observable.  It should
 be meaningful to talk about the cross section of a process.
 
 The individual components of a process are, technically, processes
 themselves, but they may have unphysical cross sections which have to
 be added for a physical result.  Process components may be exclusive
 tree-level elementary processes, dipole subtraction term, loop
 corrections, etc.
 
 The beam and structure function setup is common to all process
 components.  Thus, there is only one instance of this part.
 
 The process may be a scattering process or a decay process.  In the
 latter case, there are no structure functions, and the beam setup
 consists of a single particle.  Otherwise, the two classes are treated
 on the same footing.
 
 Once a sampling point has been chosen, a process determines a set of
 partons with a correlated density matrix of quantum numbers.  In
 general, each sampling point will generate, for each process component,
 one or more distinct parton configurations.  This is the [[computed]]
 state.  The computed state is the subject of the multi-channel
 integration algorithm.
 
 For NLO computations, it is necessary to project the computed states
 onto another set of parton configurations (e.g., by recombining
 certain pairs).  This is the [[observed]] state.  When computing
 partonic observables, the information is taken from the observed
 state.
 
 For the purpose of event generation, we will later select one parton
 configuration from the observed state and collapse the correlated
 quantum state.  This configuration is then dressed by applying parton
 shower, decays and hadronization.  The decay chain, in particular,
 combines a scattering process with possible subsequent decay processes
 on the parton level, which are full-fledged process objects themselves.
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process observables}
 We define an abstract [[subevt_expr_t]] object as an extension of the
 [[subevt_t]] type.  The object contains a local variable list, variable
 instances (as targets for pointers in the variable list), and evaluation
 trees.  The evaluation trees reference both the variables and the [[subevt]].
 
 There are two instances of the abstract type: one for process instances, one
 for physical events.  Both have a common logical expression [[selection]]
 which determines whether the object passes user-defined cuts.
 
 The intention is that we fill the [[subevt_t]] base object and compute the
 variables once we have evaluated a kinematical phase space point (or a
 complete event).  We then evaluate the expressions and can use the results in
 further calculations.
 
 The [[process_expr_t]] extension contains furthermore scale and weight
 expressions.  The [[event_expr_t]] extension contains a reweighting-factor
 expression and a logical expression for event analysis.  In practice, we will
 link the variable list of the [[event_obs]] object to the variable list of the
 currently active [[process_obs]] object, such that the process variables are
 available to both objects.  Event variables are meaningful only for physical
 events.
 
 Note that there are unit tests, but they are deferred to the
 [[expr_tests]] module.
 <<[[subevt_expr.f90]]>>=
 <<File header>>
 module subevt_expr
 
 <<Use kinds>>
 <<Use strings>>
   use constants, only: zero, one
   use io_units
   use format_utils, only: write_separator
   use diagnostics
   use lorentz
   use subevents
   use variables
   use flavors
   use quantum_numbers
   use interactions
   use particles
   use expr_base
 
 <<Standard module head>>
 
 <<Subevt expr: public>>
 
 <<Subevt expr: types>>
 
 <<Subevt expr: interfaces>>
 
 contains
 
 <<Subevt expr: procedures>>
 
 end module subevt_expr
 @ %def subevt_expr
 @
 \subsection{Abstract base type}
 <<Subevt expr: types>>=
   type, extends (subevt_t), abstract :: subevt_expr_t
      logical :: subevt_filled = .false.
      type(var_list_t) :: var_list
      real(default) :: sqrts_hat = 0
      integer :: n_in = 0
      integer :: n_out = 0
      integer :: n_tot = 0
      logical :: has_selection = .false.
      class(expr_t), allocatable :: selection
      logical :: colorize_subevt = .false.
    contains
    <<Subevt expr: subevt expr: TBP>>
   end type subevt_expr_t
 
 @ %def subevt_expr_t
 @ Output: Base and extended version.  We already have a [[write]] routine for
 the [[subevt_t]] parent type.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: base_write => subevt_expr_write
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_write (object, unit, pacified)
     class(subevt_expr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacified
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Local variables:"
     call write_separator (u)
     call var_list_write (object%var_list, u, follow_link=.false., &
          pacified = pacified)
     call write_separator (u)
     if (object%subevt_filled) then
        call object%subevt_t%write (u, pacified = pacified)
        if (object%has_selection) then
           call write_separator (u)
           write (u, "(1x,A)")  "Selection expression:"
           call write_separator (u)
           call object%selection%write (u)
        end if
     else
        write (u, "(1x,A)")  "subevt: [undefined]"
     end if
   end subroutine subevt_expr_write
 
 @ %def subevt_expr_write
 @ Finalizer.
 <<Subevt expr: subevt expr: TBP>>=
   procedure (subevt_expr_final), deferred :: final
   procedure :: base_final => subevt_expr_final
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_final (object)
     class(subevt_expr_t), intent(inout) :: object
     call object%var_list%final ()
     if (object%has_selection) then
        call object%selection%final ()
     end if
   end subroutine subevt_expr_final
 
 @ %def subevt_expr_final
 @
 \subsection{Initialization}
 Initialization: define local variables and establish pointers.
 
 The common variables are [[sqrts]] (the nominal beam energy, fixed),
 [[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for
 the [[subevt]].  With the exception of [[sqrts]], all are implemented as
 pointers to subobjects.
 <<Subevt expr: subevt expr: TBP>>=
   procedure (subevt_expr_setup_vars), deferred :: setup_vars
   procedure :: base_setup_vars => subevt_expr_setup_vars
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_setup_vars (expr, sqrts)
     class(subevt_expr_t), intent(inout), target :: expr
     real(default), intent(in) :: sqrts
     call expr%var_list%final ()
     call var_list_append_real (expr%var_list, &
          var_str ("sqrts"), sqrts, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("sqrts_hat"), expr%sqrts_hat, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("n_in"), expr%n_in, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("n_out"), expr%n_out, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("n_tot"), expr%n_tot, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
   end subroutine subevt_expr_setup_vars
 
 @ %def subevt_expr_setup_vars
 @ Append the subevent expr (its base-type core) itself to the variable
 list, if it is not yet present.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: setup_var_self => subevt_expr_setup_var_self
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_setup_var_self (expr)
     class(subevt_expr_t), intent(inout), target :: expr
     if (.not. expr%var_list%contains (var_str ("@evt"))) then
        call var_list_append_subevt_ptr &
             (expr%var_list, &
             var_str ("@evt"), expr%subevt_t, &
             is_known = expr%subevt_filled, &
             locked = .true., verbose = .false., intrinsic=.true.)
     end if
   end subroutine subevt_expr_setup_var_self
 
 @ %def subevt_expr_setup_var_self
 @ Link a variable list to the local one.  This could be done event by event,
 but before evaluating expressions.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: link_var_list => subevt_expr_link_var_list
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_link_var_list (expr, var_list)
     class(subevt_expr_t), intent(inout) :: expr
     type(var_list_t), intent(in), target :: var_list
     call expr%var_list%link (var_list)
   end subroutine subevt_expr_link_var_list
 
 @ %def subevt_expr_link_var_list
 @ Compile the selection expression.  If there is no expression, the build
 method will not allocate the expression object.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: setup_selection => subevt_expr_setup_selection
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_setup_selection (expr, ef_cuts)
     class(subevt_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_cuts
     call ef_cuts%build (expr%selection)
     if (allocated (expr%selection)) then
        call expr%setup_var_self ()
        call expr%selection%setup_lexpr (expr%var_list)
        expr%has_selection = .true.
     end if
   end subroutine subevt_expr_setup_selection
 
 @ %def subevt_expr_setup_selection
 @ (De)activate color storage and evaluation for the expression.  The subevent
 particles will have color information.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: colorize => subevt_expr_colorize
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_colorize (expr, colorize_subevt)
     class(subevt_expr_t), intent(inout), target :: expr
     logical, intent(in) :: colorize_subevt
     expr%colorize_subevt = colorize_subevt
   end subroutine subevt_expr_colorize
 
 @ %def subevt_expr_colorize
 @
 \subsection{Evaluation}
 Reset to initial state, i.e., mark the [[subevt]] as invalid.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: reset_contents => subevt_expr_reset_contents
   procedure :: base_reset_contents => subevt_expr_reset_contents
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_reset_contents (expr)
     class(subevt_expr_t), intent(inout) :: expr
     expr%subevt_filled = .false.
   end subroutine subevt_expr_reset_contents
 
 @ %def subevt_expr_reset_contents
 @ Evaluate the selection expression and return the result.  There is also a
 deferred version: this should evaluate the remaining expressions if the event
 has passed.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: base_evaluate => subevt_expr_evaluate
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_evaluate (expr, passed)
     class(subevt_expr_t), intent(inout) :: expr
     logical, intent(out) :: passed
     if (expr%has_selection) then
        call expr%selection%evaluate ()
        if (expr%selection%is_known ()) then
           passed = expr%selection%get_log ()
        else
           call msg_error ("Evaluate selection expression: result undefined")
           passed = .false.
        end if
     else
        passed = .true.
     end if
   end subroutine subevt_expr_evaluate
 
 @ %def subevt_expr_evaluate
 @
 \subsection{Implementation for partonic events}
 This implementation contains the expressions that we can evaluate for the
 partonic process during integration.
 <<Subevt expr: public>>=
   public :: parton_expr_t
 <<Subevt expr: types>>=
   type, extends (subevt_expr_t) :: parton_expr_t
      integer, dimension(:), allocatable :: i_beam
      integer, dimension(:), allocatable :: i_in
      integer, dimension(:), allocatable :: i_out
      logical :: has_scale = .false.
      logical :: has_fac_scale = .false.
      logical :: has_ren_scale = .false.
      logical :: has_weight = .false.
      class(expr_t), allocatable :: scale
      class(expr_t), allocatable :: fac_scale
      class(expr_t), allocatable :: ren_scale
      class(expr_t), allocatable :: weight
    contains
    <<Subevt expr: parton expr: TBP>>
   end type parton_expr_t
 
 @ %def parton_expr_t
 @ Finalizer.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: final => parton_expr_final
 <<Subevt expr: procedures>>=
   subroutine parton_expr_final (object)
     class(parton_expr_t), intent(inout) :: object
     call object%base_final ()
     if (object%has_scale) then
        call object%scale%final ()
     end if
     if (object%has_fac_scale) then
        call object%fac_scale%final ()
     end if
     if (object%has_ren_scale) then
        call object%ren_scale%final ()
     end if
     if (object%has_weight) then
        call object%weight%final ()
     end if
   end subroutine parton_expr_final
 
 @ %def parton_expr_final
 @ Output: continue writing the active expressions, after the common selection
 expression.
 
 Note: the [[prefix]] argument is declared in the [[write]] method of the
 [[subevt_t]] base type.  Here, it is unused.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: write => parton_expr_write
 <<Subevt expr: procedures>>=
   subroutine parton_expr_write (object, unit, prefix, pacified)
     class(parton_expr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     character(*), intent(in), optional :: prefix
     logical, intent(in), optional :: pacified
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u, pacified = pacified)
     if (object%subevt_filled) then
        if (object%has_scale) then
           call write_separator (u)
           write (u, "(1x,A)")  "Scale expression:"
           call write_separator (u)
           call object%scale%write (u)
        end if
        if (object%has_fac_scale) then
           call write_separator (u)
           write (u, "(1x,A)")  "Factorization scale expression:"
           call write_separator (u)
           call object%fac_scale%write (u)
        end if
        if (object%has_ren_scale) then
           call write_separator (u)
           write (u, "(1x,A)")  "Renormalization scale expression:"
           call write_separator (u)
           call object%ren_scale%write (u)
        end if
        if (object%has_weight) then
           call write_separator (u)
           write (u, "(1x,A)")  "Weight expression:"
           call write_separator (u)
           call object%weight%write (u)
        end if
     end if
   end subroutine parton_expr_write
 
 @ %def parton_expr_write
 @ Define variables.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_vars => parton_expr_setup_vars
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_vars (expr, sqrts)
     class(parton_expr_t), intent(inout), target :: expr
     real(default), intent(in) :: sqrts
     call expr%base_setup_vars (sqrts)
   end subroutine parton_expr_setup_vars
 
 @ %def parton_expr_setup_vars
 @ Compile the scale expressions.  If a pointer is disassociated, there is
 no expression.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_scale => parton_expr_setup_scale
   procedure :: setup_fac_scale => parton_expr_setup_fac_scale
   procedure :: setup_ren_scale => parton_expr_setup_ren_scale
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_scale (expr, ef_scale)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_scale
     call ef_scale%build (expr%scale)
     if (allocated (expr%scale)) then
        call expr%setup_var_self ()
        call expr%scale%setup_expr (expr%var_list)
        expr%has_scale = .true.
     end if
   end subroutine parton_expr_setup_scale
 
   subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_fac_scale
     call ef_fac_scale%build (expr%fac_scale)
     if (allocated (expr%fac_scale)) then
        call expr%setup_var_self ()
        call expr%fac_scale%setup_expr (expr%var_list)
        expr%has_fac_scale = .true.
     end if
   end subroutine parton_expr_setup_fac_scale
 
   subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_ren_scale
     call ef_ren_scale%build (expr%ren_scale)
     if (allocated (expr%ren_scale)) then
        call expr%setup_var_self ()
        call expr%ren_scale%setup_expr (expr%var_list)
        expr%has_ren_scale = .true.
     end if
   end subroutine parton_expr_setup_ren_scale
 
 @ %def parton_expr_setup_scale
 @ %def parton_expr_setup_fac_scale
 @ %def parton_expr_setup_ren_scale
 @ Compile the weight expression.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_weight => parton_expr_setup_weight
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_weight (expr, ef_weight)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_weight
     call ef_weight%build (expr%weight)
     if (allocated (expr%weight)) then
        call expr%setup_var_self ()
        call expr%weight%setup_expr (expr%var_list)
        expr%has_weight = .true.
     end if
   end subroutine parton_expr_setup_weight
 
 @ %def parton_expr_setup_weight
 @ Filling the partonic state consists of two parts.  The first routine
 prepares the subevt without assigning momenta.  It takes the particles from an
 [[interaction_t]].  It needs the indices and flavors for the beam,
 incoming, and outgoing particles.
 
 We can assume that the particle content of the subevt does not change.
 Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already
 in this initialization step.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_subevt => parton_expr_setup_subevt
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_subevt (expr, int, &
        i_beam, i_in, i_out, f_beam, f_in, f_out)
     class(parton_expr_t), intent(inout) :: expr
     type(interaction_t), intent(in), target :: int
     integer, dimension(:), intent(in) :: i_beam, i_in, i_out
     type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
     allocate (expr%i_beam (size (i_beam)))
     allocate (expr%i_in (size (i_in)))
     allocate (expr%i_out (size (i_out)))
     expr%i_beam = i_beam
     expr%i_in = i_in
     expr%i_out = i_out
     call interaction_to_subevt (int, &
          expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
     call subevt_set_pdg_beam     (expr%subevt_t, f_beam%get_pdg ())
     call subevt_set_pdg_incoming (expr%subevt_t, f_in%get_pdg ())
     call subevt_set_pdg_outgoing (expr%subevt_t, f_out%get_pdg ())
     call subevt_set_p2_beam     (expr%subevt_t, f_beam%get_mass () ** 2)
     call subevt_set_p2_incoming (expr%subevt_t, f_in%get_mass ()   ** 2)
     call subevt_set_p2_outgoing (expr%subevt_t, f_out%get_mass ()  ** 2)
     expr%n_in  = size (i_in)
     expr%n_out = size (i_out)
     expr%n_tot = expr%n_in + expr%n_out
   end subroutine parton_expr_setup_subevt
 
 @ %def parton_expr_setup_subevt
 @ Transfer PDG codes, masses (initalization) and momenta to a
 predefined subevent.  We use the flavor assignment of the first
 branch in the interaction state matrix.  Only incoming and outgoing
 particles are transferred.  Switch momentum sign for incoming
 particles.
 <<Subevt expr: interfaces>>=
   interface interaction_momenta_to_subevt
      module procedure interaction_momenta_to_subevt_id
      module procedure interaction_momenta_to_subevt_tr
   end interface
 
 <<Subevt expr: procedures>>=
   subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt)
     type(interaction_t), intent(in), target :: int
     integer, dimension(:), intent(in) :: j_beam, j_in, j_out
     type(subevt_t), intent(out) :: subevt
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: n_beam, n_in, n_out, i, j
     allocate (flv (int%get_n_tot ()))
     flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1))
     n_beam = size (j_beam)
     n_in = size (j_in)
     n_out = size (j_out)
     call subevt_init (subevt, n_beam + n_in + n_out)
     do i = 1, n_beam
        j = j_beam(i)
        call subevt_set_beam (subevt, i, &
             flv(j)%get_pdg (), &
             vector4_null, &
             flv(j)%get_mass () ** 2)
     end do
     do i = 1, n_in
        j = j_in(i)
        call subevt_set_incoming (subevt, n_beam + i, &
             flv(j)%get_pdg (), &
             vector4_null, &
             flv(j)%get_mass () ** 2)
     end do
     do i = 1, n_out
        j = j_out(i)
        call subevt_set_outgoing (subevt, n_beam + n_in + i, &
             flv(j)%get_pdg (), &
             vector4_null, &
             flv(j)%get_mass () ** 2)
     end do
   end subroutine interaction_to_subevt
 
   subroutine interaction_momenta_to_subevt_id (int, j_beam, j_in, j_out, subevt)
     type(interaction_t), intent(in) :: int
     integer, dimension(:), intent(in) :: j_beam, j_in, j_out
     type(subevt_t), intent(inout) :: subevt
     call subevt_set_p_beam (subevt, - int%get_momenta (j_beam))
     call subevt_set_p_incoming (subevt, - int%get_momenta (j_in))
     call subevt_set_p_outgoing (subevt, int%get_momenta (j_out))
   end subroutine interaction_momenta_to_subevt_id
 
   subroutine interaction_momenta_to_subevt_tr &
        (int, j_beam, j_in, j_out, lt, subevt)
     type(interaction_t), intent(in) :: int
     integer, dimension(:), intent(in) :: j_beam, j_in, j_out
     type(subevt_t), intent(inout) :: subevt
     type(lorentz_transformation_t), intent(in) :: lt
     call subevt_set_p_beam &
          (subevt, - lt * int%get_momenta (j_beam))
     call subevt_set_p_incoming &
          (subevt, - lt * int%get_momenta (j_in))
     call subevt_set_p_outgoing &
          (subevt, lt * int%get_momenta (j_out))
   end subroutine interaction_momenta_to_subevt_tr
 
 @ %def interaction_momenta_to_subevt
 @ The second part takes the momenta from the interaction object and thus
 completes the subevt.  The partonic energy can then be computed.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: fill_subevt => parton_expr_fill_subevt
 <<Subevt expr: procedures>>=
   subroutine parton_expr_fill_subevt (expr, int)
     class(parton_expr_t), intent(inout) :: expr
     type(interaction_t), intent(in), target :: int
     call interaction_momenta_to_subevt (int, &
          expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
     expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
     expr%subevt_filled = .true.
   end subroutine parton_expr_fill_subevt
 
 @ %def parton_expr_fill_subevt
 @ Evaluate, if the event passes the selection.  For absent expressions we take
 default values.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: evaluate => parton_expr_evaluate
 <<Subevt expr: procedures>>=
   subroutine parton_expr_evaluate &
        (expr, passed, scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
     class(parton_expr_t), intent(inout) :: expr
     logical, intent(out) :: passed
     real(default), intent(out) :: scale
     real(default), allocatable, intent(out) :: fac_scale
     real(default), allocatable, intent(out) :: ren_scale
     real(default), intent(out) :: weight
     real(default), intent(in), allocatable, optional :: scale_forced
     logical, intent(in), optional :: force_evaluation
     logical :: force_scale, force_eval
     force_scale = .false.; force_eval = .false.
     if (present (scale_forced))  force_scale = allocated (scale_forced)
     if (present (force_evaluation)) force_eval = force_evaluation
     call expr%base_evaluate (passed)
     if (passed .or. force_eval) then
        if (force_scale) then
           scale = scale_forced
        else if (expr%has_scale) then
           call expr%scale%evaluate ()
           if (expr%scale%is_known ()) then
              scale = expr%scale%get_real ()
           else
              call msg_error ("Evaluate scale expression: result undefined")
              scale = zero
           end if
        else
           scale = expr%sqrts_hat
        end if
        if (expr%has_fac_scale) then
           call expr%fac_scale%evaluate ()
           if (expr%fac_scale%is_known ()) then
              if (.not. allocated (fac_scale)) then
                 allocate (fac_scale, source = expr%fac_scale%get_real ())
              else
                 fac_scale = expr%fac_scale%get_real ()
              end if
           else
              call msg_error ("Evaluate factorization scale expression: &
                   &result undefined")
           end if
        end if
        if (expr%has_ren_scale) then
           call expr%ren_scale%evaluate ()
           if (expr%ren_scale%is_known ()) then
              if (.not. allocated (ren_scale)) then
                 allocate (ren_scale, source = expr%ren_scale%get_real ())
              else
                 ren_scale = expr%ren_scale%get_real ()
              end if
           else
              call msg_error ("Evaluate renormalization scale expression: &
                   &result undefined")
           end if
        end if
        if (expr%has_weight) then
           call expr%weight%evaluate ()
           if (expr%weight%is_known ()) then
              weight = expr%weight%get_real ()
           else
              call msg_error ("Evaluate weight expression: result undefined")
              weight = zero
           end if
        else
           weight = one
        end if
     else
        weight = zero
     end if
   end subroutine parton_expr_evaluate
 
 @ %def parton_expr_evaluate
 @ Return the beam/incoming parton indices.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: get_beam_index => parton_expr_get_beam_index
   procedure :: get_in_index => parton_expr_get_in_index
 <<Subevt expr: procedures>>=
   subroutine parton_expr_get_beam_index (expr, i_beam)
     class(parton_expr_t), intent(in) :: expr
     integer, dimension(:), intent(out) :: i_beam
     i_beam = expr%i_beam
   end subroutine parton_expr_get_beam_index
 
   subroutine parton_expr_get_in_index (expr, i_in)
     class(parton_expr_t), intent(in) :: expr
     integer, dimension(:), intent(out) :: i_in
     i_in = expr%i_in
   end subroutine parton_expr_get_in_index
 
 @ %def parton_expr_get_beam_index
 @ %def parton_expr_get_in_index
 @
 \subsection{Implementation for full events}
 This implementation contains the expressions that we can evaluate for the
 full event.  It also contains data that pertain to the event, suitable
 for communication with external event formats.  These data
 simultaneously serve as pointer targets for the variable lists hidden
 in the expressions (eval trees).
 
 Squared matrix element and weight values: when reading events from
 file, the [[ref]] value is the number in the file, while the [[prc]]
 value is the number that we calculate from the momenta in the file,
 possibly with different parameters.  When generating events the first
 time, or if we do not recalculate, the numbers should coincide.
 Furthermore, the array of [[alt]] values is copied from an array of
 alternative event records.  These values should represent calculated
 values.
 <<Subevt expr: public>>=
   public :: event_expr_t
 <<Subevt expr: types>>=
   type, extends (subevt_expr_t) :: event_expr_t
      logical :: has_reweight = .false.
      logical :: has_analysis = .false.
      class(expr_t), allocatable :: reweight
      class(expr_t), allocatable :: analysis
      logical :: has_id = .false.
      type(string_t) :: id
      logical :: has_num_id = .false.
      integer :: num_id = 0
      logical :: has_index = .false.
      integer :: index = 0
      logical :: has_sqme_ref = .false.
      real(default) :: sqme_ref = 0
      logical :: has_sqme_prc = .false.
      real(default) :: sqme_prc = 0
      logical :: has_weight_ref = .false.
      real(default) :: weight_ref = 0
      logical :: has_weight_prc = .false.
      real(default) :: weight_prc = 0
      logical :: has_excess_prc = .false.
      real(default) :: excess_prc = 0
      integer :: n_alt = 0
      logical :: has_sqme_alt = .false.
      real(default), dimension(:), allocatable :: sqme_alt
      logical :: has_weight_alt = .false.
      real(default), dimension(:), allocatable :: weight_alt
    contains
    <<Subevt expr: event expr: TBP>>
   end type event_expr_t
 
 @ %def event_expr_t
 @ Finalizer for the expressions.
 <<Subevt expr: event expr: TBP>>=
   procedure :: final => event_expr_final
 <<Subevt expr: procedures>>=
   subroutine event_expr_final (object)
     class(event_expr_t), intent(inout) :: object
     call object%base_final ()
     if (object%has_reweight) then
        call object%reweight%final ()
     end if
     if (object%has_analysis) then
        call object%analysis%final ()
     end if
   end subroutine event_expr_final
 
 @ %def event_expr_final
 @ Output: continue writing the active expressions, after the common selection
 expression.
 
 Note: the [[prefix]] argument is declared in the [[write]] method of the
 [[subevt_t]] base type.  Here, it is unused.
 <<Subevt expr: event expr: TBP>>=
   procedure :: write => event_expr_write
 <<Subevt expr: procedures>>=
   subroutine event_expr_write (object, unit, prefix, pacified)
     class(event_expr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     character(*), intent(in), optional :: prefix
     logical, intent(in), optional :: pacified
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u, pacified = pacified)
     if (object%subevt_filled) then
        if (object%has_reweight) then
           call write_separator (u)
           write (u, "(1x,A)")  "Reweighting expression:"
           call write_separator (u)
           call object%reweight%write (u)
        end if
        if (object%has_analysis) then
           call write_separator (u)
           write (u, "(1x,A)")  "Analysis expression:"
           call write_separator (u)
           call object%analysis%write (u)
        end if
     end if
   end subroutine event_expr_write
 
 @ %def event_expr_write
 @ Initializer.  This is required only for the [[sqme_alt]] and
 [[weight_alt]] arrays.
 <<Subevt expr: event expr: TBP>>=
   procedure :: init => event_expr_init
 <<Subevt expr: procedures>>=
   subroutine event_expr_init (expr, n_alt)
     class(event_expr_t), intent(out) :: expr
     integer, intent(in), optional :: n_alt
     if (present (n_alt)) then
        expr%n_alt = n_alt
        allocate (expr%sqme_alt (n_alt), source = 0._default)
        allocate (expr%weight_alt (n_alt), source = 0._default)
     end if
   end subroutine event_expr_init
 
 @ %def event_expr_init
 @ Define variables.  We have the variables of the base type plus
 specific variables for full events.  There is the event index.
 <<Subevt expr: event expr: TBP>>=
   procedure :: setup_vars => event_expr_setup_vars
 <<Subevt expr: procedures>>=
   subroutine event_expr_setup_vars (expr, sqrts)
     class(event_expr_t), intent(inout), target :: expr
     real(default), intent(in) :: sqrts
     call expr%base_setup_vars (sqrts)
     call var_list_append_string_ptr (expr%var_list, &
          var_str ("$process_id"), expr%id, &
          is_known = expr%has_id, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("process_num_id"), expr%num_id, &
          is_known = expr%has_num_id, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("sqme"), expr%sqme_prc, &
          is_known = expr%has_sqme_prc, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("sqme_ref"), expr%sqme_ref, &
          is_known = expr%has_sqme_ref, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("event_index"), expr%index, &
          is_known = expr%has_index, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("event_weight"), expr%weight_prc, &
          is_known = expr%has_weight_prc, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("event_weight_ref"), expr%weight_ref, &
          is_known = expr%has_weight_ref, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("event_excess"), expr%excess_prc, &
          is_known = expr%has_excess_prc, &
          locked = .true., verbose = .false., intrinsic = .true.)
   end subroutine event_expr_setup_vars
 
 @ %def event_expr_setup_vars
 @ Compile the analysis expression.  If the pointer is disassociated, there is
 no expression.
 <<Subevt expr: event expr: TBP>>=
   procedure :: setup_analysis => event_expr_setup_analysis
 <<Subevt expr: procedures>>=
   subroutine event_expr_setup_analysis (expr, ef_analysis)
     class(event_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_analysis
     call ef_analysis%build (expr%analysis)
     if (allocated (expr%analysis)) then
        call expr%setup_var_self ()
        call expr%analysis%setup_lexpr (expr%var_list)
        expr%has_analysis = .true.
     end if
   end subroutine event_expr_setup_analysis
 
 @ %def event_expr_setup_analysis
 @ Compile the reweight expression.
 <<Subevt expr: event expr: TBP>>=
   procedure :: setup_reweight => event_expr_setup_reweight
 <<Subevt expr: procedures>>=
   subroutine event_expr_setup_reweight (expr, ef_reweight)
     class(event_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_reweight
     call ef_reweight%build (expr%reweight)
     if (allocated (expr%reweight)) then
        call expr%setup_var_self ()
        call expr%reweight%setup_expr (expr%var_list)
        expr%has_reweight = .true.
     end if
   end subroutine event_expr_setup_reweight
 
 @ %def event_expr_setup_reweight
 @ Store the string or numeric process ID.  This should be done during
 initialization.
 <<Subevt expr: event expr: TBP>>=
   procedure :: set_process_id => event_expr_set_process_id
   procedure :: set_process_num_id => event_expr_set_process_num_id
 <<Subevt expr: procedures>>=
   subroutine event_expr_set_process_id (expr, id)
     class(event_expr_t), intent(inout) :: expr
     type(string_t), intent(in) :: id
     expr%id = id
     expr%has_id = .true.
   end subroutine event_expr_set_process_id
 
   subroutine event_expr_set_process_num_id (expr, num_id)
     class(event_expr_t), intent(inout) :: expr
     integer, intent(in) :: num_id
     expr%num_id = num_id
     expr%has_num_id = .true.
   end subroutine event_expr_set_process_num_id
 
 @ %def event_expr_set_process_id
 @ %def event_expr_set_process_num_id
 @ Reset / set the data that pertain to a particular event.  The event
 index is reset unless explicitly told to keep it.
 <<Subevt expr: event expr: TBP>>=
   procedure :: reset_contents => event_expr_reset_contents
   procedure :: set => event_expr_set
 <<Subevt expr: procedures>>=
   subroutine event_expr_reset_contents (expr)
     class(event_expr_t), intent(inout) :: expr
     call expr%base_reset_contents ()
     expr%has_sqme_ref = .false.
     expr%has_sqme_prc = .false.
     expr%has_sqme_alt = .false.
     expr%has_weight_ref = .false.
     expr%has_weight_prc = .false.
     expr%has_weight_alt = .false.
     expr%has_excess_prc = .false.
   end subroutine event_expr_reset_contents
 
   subroutine event_expr_set (expr, &
        weight_ref, weight_prc, weight_alt, &
        excess_prc, &
        sqme_ref, sqme_prc, sqme_alt)
     class(event_expr_t), intent(inout) :: expr
     real(default), intent(in), optional :: weight_ref, weight_prc
     real(default), intent(in), optional :: excess_prc
     real(default), intent(in), optional :: sqme_ref, sqme_prc
     real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
     if (present (sqme_ref)) then
        expr%has_sqme_ref = .true.
        expr%sqme_ref = sqme_ref
     end if
     if (present (sqme_prc)) then
        expr%has_sqme_prc = .true.
        expr%sqme_prc = sqme_prc
     end if
     if (present (sqme_alt)) then
        expr%has_sqme_alt = .true.
        expr%sqme_alt = sqme_alt
     end if
     if (present (weight_ref)) then
        expr%has_weight_ref = .true.
        expr%weight_ref = weight_ref
     end if
     if (present (weight_prc)) then
        expr%has_weight_prc = .true.
        expr%weight_prc = weight_prc
     end if
     if (present (weight_alt)) then
        expr%has_weight_alt = .true.
        expr%weight_alt = weight_alt
     end if
     if (present (excess_prc)) then
        expr%has_excess_prc = .true.
        expr%excess_prc = excess_prc
     end if
   end subroutine event_expr_set
 
 @ %def event_expr_reset_contents event_expr_set
 @ Access the subevent index.
 <<Subevt expr: event expr: TBP>>=
   procedure :: has_event_index => event_expr_has_event_index
   procedure :: get_event_index => event_expr_get_event_index
 <<Subevt expr: procedures>>=
   function event_expr_has_event_index (expr) result (flag)
     class(event_expr_t), intent(in) :: expr
     logical :: flag
     flag = expr%has_index
   end function event_expr_has_event_index
 
   function event_expr_get_event_index (expr) result (index)
     class(event_expr_t), intent(in) :: expr
     integer :: index
     if (expr%has_index) then
        index = expr%index
     else
        index = 0
     end if
   end function event_expr_get_event_index
 
 @ %def event_expr_has_event_index
 @ %def event_expr_get_event_index
 @ Set/increment the subevent index.  Initialize it if necessary.
 <<Subevt expr: event expr: TBP>>=
   procedure :: set_event_index => event_expr_set_event_index
   procedure :: reset_event_index => event_expr_reset_event_index
   procedure :: increment_event_index => event_expr_increment_event_index
 <<Subevt expr: procedures>>=
   subroutine event_expr_set_event_index (expr, index)
     class(event_expr_t), intent(inout) :: expr
     integer, intent(in) :: index
     expr%index = index
     expr%has_index = .true.
   end subroutine event_expr_set_event_index
 
   subroutine event_expr_reset_event_index (expr)
     class(event_expr_t), intent(inout) :: expr
     expr%has_index = .false.
   end subroutine event_expr_reset_event_index
 
   subroutine event_expr_increment_event_index (expr, offset)
     class(event_expr_t), intent(inout) :: expr
     integer, intent(in), optional :: offset
     if (expr%has_index) then
        expr%index = expr%index + 1
     else if (present (offset)) then
        call expr%set_event_index (offset + 1)
     else
        call expr%set_event_index (1)
     end if
   end subroutine event_expr_increment_event_index
 
 @ %def event_expr_set_event_index
 @ %def event_expr_increment_event_index
 @ Fill the event expression: take the particle data and kinematics
 from a [[particle_set]] object.
 
 We allow the particle content to change for each event.  Therefore, we set the
 event variables each time.
 
 Also increment the event index; initialize it if necessary.
 <<Subevt expr: event expr: TBP>>=
   procedure :: fill_subevt => event_expr_fill_subevt
 <<Subevt expr: procedures>>=
   subroutine event_expr_fill_subevt (expr, particle_set)
     class(event_expr_t), intent(inout) :: expr
     type(particle_set_t), intent(in) :: particle_set
     call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt)
     expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
     expr%n_in  = subevt_get_n_in  (expr%subevt_t)
     expr%n_out = subevt_get_n_out (expr%subevt_t)
     expr%n_tot = expr%n_in + expr%n_out
     expr%subevt_filled = .true.
   end subroutine event_expr_fill_subevt
 
 @ %def event_expr_fill_subevt
 @ Evaluate, if the event passes the selection.  For absent expressions we take
 default values.
 <<Subevt expr: event expr: TBP>>=
   procedure :: evaluate => event_expr_evaluate
 <<Subevt expr: procedures>>=
   subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag)
     class(event_expr_t), intent(inout) :: expr
     logical, intent(out) :: passed
     real(default), intent(out) :: reweight
     logical, intent(out) :: analysis_flag
     call expr%base_evaluate (passed)
     if (passed) then
        if (expr%has_reweight) then
           call expr%reweight%evaluate ()
           if (expr%reweight%is_known ()) then
              reweight = expr%reweight%get_real ()
           else
              call msg_error ("Evaluate reweight expression: &
                   &result undefined")
              reweight = 0
           end if
        else
           reweight = 1
        end if
        if (expr%has_analysis) then
           call expr%analysis%evaluate ()
           if (expr%analysis%is_known ()) then
              analysis_flag = expr%analysis%get_log ()
           else
              call msg_error ("Evaluate analysis expression: &
                   &result undefined")
              analysis_flag = .false.
           end if
        else
           analysis_flag = .true.
        end if
     end if
   end subroutine event_expr_evaluate
 
 @ %def event_expr_evaluate
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Parton states}
 A [[parton_state_t]] object contains the effective kinematics and
 dynamics of an elementary partonic interaction, with or without the
 beam/structure function state included.  The type is abstract and has
 two distinct extensions.  The [[isolated_state_t]] extension describes
 the isolated elementary interaction where the [[int_eff]] subobject
 contains the complex transition amplitude, exclusive in all quantum
 numbers.  The particle content and kinematics describe the effective
 partonic state.  The [[connected_state_t]] extension contains the
 partonic [[subevt]] and the expressions for cuts and scales which use
 it.
 
 In the isolated state, the effective partonic interaction may either
 be identical to the hard interaction, in which case it is just a
 pointer to the latter.  Or it may involve a rearrangement of partons,
 in which case we allocate it explicitly and flag this by
 [[int_is_allocated]].
 
 The [[trace]] evaluator contains the absolute square of the effective
 transition amplitude matrix, summed over final states.  It is also summed over
 initial states, depending on the the beam setup allows.  The result is used for
 integration.
 
 The [[matrix]] evaluator is the counterpart of [[trace]] which is kept
 exclusive in all observable quantum numbers.  The [[flows]] evaluator is
 furthermore exclusive in colors, but neglecting all color interference.  The
 [[matrix]] and [[flows]] evaluators are filled only for sampling points that
 become part of physical events.
 
 Note: It would be natural to make the evaluators allocatable. The extra
 [[has_XXX]] flags indicate whether evaluators are active, instead.
 
 This module contains no unit tests.  The tests are covered by the
 [[processes]] module below.
 <<[[parton_states.f90]]>>=
 <<File header>>
 module parton_states
 
 <<Use kinds>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use diagnostics
   use lorentz
   use subevents
   use variables
   use expr_base
   use model_data
   use flavors
   use helicities
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use interactions
   use evaluators
 
   use beams
   use sf_base
   use process_constants
   use prc_core
   use subevt_expr
 
 <<Standard module head>>
 
 <<Parton states: public>>
 
 <<Parton states: types>>
 
 contains
 
 <<Parton states: procedures>>
 
 end module parton_states
 @ %def parton_states
 @
 \subsection{Abstract base type}
 The common part are the evaluators, one for the trace (summed over all
 quantum numbers), one for the transition matrix (summed only over
 unobservable quantum numbers), and one for the flow distribution
 (transition matrix without interferences, exclusive in color flow).
 <<Parton states: types>>=
   type, abstract :: parton_state_t
      logical :: has_trace = .false.
      logical :: has_matrix = .false.
      logical :: has_flows = .false.
      type(evaluator_t) :: trace
      type(evaluator_t) :: matrix
      type(evaluator_t) :: flows
    contains
    <<Parton states: parton state: TBP>>
   end type parton_state_t
 
 @ %def parton_state_t
 @ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object
 and the (hard) effective interaction [[int_eff]], separately, both are
 implemented as a pointer.  The evaluators (trace, matrix, flows) apply
 to the hard interaction only.
 
 If the effective interaction differs from the hard interaction, the
 pointer is allocated explicitly.  Analogously for [[sf_chain_eff]].
 <<Parton states: public>>=
   public :: isolated_state_t
 <<Parton states: types>>=
   type, extends (parton_state_t) :: isolated_state_t
      logical :: sf_chain_is_allocated = .false.
      type(sf_chain_instance_t), pointer :: sf_chain_eff => null ()
      logical :: int_is_allocated = .false.
      type(interaction_t), pointer :: int_eff => null ()
    contains
    <<Parton states: isolated state: TBP>>
   end type isolated_state_t
 
 @ %def isolated_state_t
 @ The [[connected_state_t]] extension contains all data that enable
 the evaluation of observables for the effective connected state.  The
 evaluators connect the (effective) structure-function chain and hard
 interaction that were kept separate in the [[isolated_state_t]].
 
 The [[flows_sf]] evaluator is an extended copy of the
 structure-function
 
 The [[expr]] subobject consists of the [[subevt]], a simple event record,
 expressions for cuts etc.\ which refer to this record, and a [[var_list]]
 which contains event-specific variables, linked to the process variable
 list.  Variables used within the expressions are looked up in [[var_list]].
 <<Parton states: public>>=
   public :: connected_state_t
 <<Parton states: types>>=
   type, extends (parton_state_t) :: connected_state_t
      type(state_flv_content_t) :: state_flv
      logical :: has_flows_sf = .false.
      type(evaluator_t) :: flows_sf
      logical :: has_expr = .false.
      type(parton_expr_t) :: expr
    contains
    <<Parton states: connected state: TBP>>
   end type connected_state_t
 
 @ %def connected_state_t
 @ Output: each evaluator is written only when it is active.  The
 [[sf_chain]] is only written if it is explicitly allocated.
 <<Parton states: parton state: TBP>>=
   procedure :: write => parton_state_write
 <<Parton states: procedures>>=
   subroutine parton_state_write (state, unit, testflag)
     class(parton_state_t), intent(in) :: state
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     select type (state)
     class is (isolated_state_t)
        if (state%sf_chain_is_allocated) then
           call write_separator (u)
           call state%sf_chain_eff%write (u)
        end if
        if (state%int_is_allocated) then
           call write_separator (u)
           write (u, "(1x,A)") &
                "Effective interaction:"
           call write_separator (u)
           call state%int_eff%basic_write (u, testflag = testflag)
        end if
     class is (connected_state_t)
        if (state%has_flows_sf) then
           call write_separator (u)
           write (u, "(1x,A)") &
                "Evaluator (extension of the beam evaluator &
                &with color contractions):"
           call write_separator (u)
           call state%flows_sf%write (u, testflag = testflag)
        end if
     end select
     if (state%has_trace) then
        call write_separator (u)
        write (u, "(1x,A)") &
             "Evaluator (trace of the squared transition matrix):"
        call write_separator (u)
        call state%trace%write (u, testflag = testflag)
     end if
     if (state%has_matrix) then
        call write_separator (u)
        write (u, "(1x,A)") &
             "Evaluator (squared transition matrix):"
        call write_separator (u)
        call state%matrix%write (u, testflag = testflag)
     end if
     if (state%has_flows) then
        call write_separator (u)
        write (u, "(1x,A)") &
             "Evaluator (squared color-flow matrix):"
        call write_separator (u)
        call state%flows%write (u, testflag = testflag)
     end if
     select type (state)
     class is (connected_state_t)
        if (state%has_expr) then
           call write_separator (u)
           call state%expr%write (u)
        end if
     end select
   end subroutine parton_state_write
 
 @ %def parton_state_write
 @ Finalize interaction and evaluators, but only if allocated.
 <<Parton states: parton state: TBP>>=
   procedure :: final => parton_state_final
 <<Parton states: procedures>>=
   subroutine parton_state_final (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_flows) then
        call state%flows%final ()
        state%has_flows = .false.
     end if
     if (state%has_matrix) then
        call state%matrix%final ()
        state%has_matrix = .false.
     end if
     if (state%has_trace) then
        call state%trace%final ()
        state%has_trace = .false.
     end if
     select type (state)
     class is (connected_state_t)
        if (state%has_flows_sf) then
           call state%flows_sf%final ()
           state%has_flows_sf = .false.
        end if
        call state%expr%final ()
     class is (isolated_state_t)
        if (state%int_is_allocated) then
           call state%int_eff%final ()
           deallocate (state%int_eff)
           state%int_is_allocated = .false.
        end if
        if (state%sf_chain_is_allocated) then
           call state%sf_chain_eff%final ()
        end if
     end select
   end subroutine parton_state_final
 
 @ %def parton_state_final
 @
 \subsection{Common Initialization}
 Initialize the isolated parton state.  In this version, the
 effective structure-function chain [[sf_chain_eff]] and the effective
 interaction [[int_eff]] both are trivial pointers to the seed
 structure-function chain and to the hard interaction, respectively.
 <<Parton states: isolated state: TBP>>=
   procedure :: init => isolated_state_init
 <<Parton states: procedures>>=
   subroutine isolated_state_init (state, sf_chain, int)
     class(isolated_state_t), intent(out) :: state
     type(sf_chain_instance_t), intent(in), target :: sf_chain
     type(interaction_t), intent(in), target :: int
     state%sf_chain_eff => sf_chain
     state%int_eff => int
   end subroutine isolated_state_init
 
 @ %def isolated_state_init
 @
 \subsection{Evaluator initialization: isolated state}
 Create an evaluator for the trace of the squared transition matrix.
 The trace goes over all outgoing quantum numbers.  Whether we trace
 over incoming quantum numbers other than color, depends on the given
 [[qn_mask_in]].
 
 There are two options: explicitly computing the color factor table
 ([[use_cf]] false; [[nc]] defined), or taking the color factor
 table from the hard matrix element data.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_square_trace => isolated_state_setup_square_trace
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_square_trace (state, core, &
        qn_mask_in, col, keep_fs_flavor)
     class(isolated_state_t), intent(inout), target :: state
     class(prc_core_t), intent(in) :: core
     type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
     !!! Actually need allocatable attribute here for once because col might
     !!! enter the subroutine non-allocated.
     integer, intent(in), dimension(:), allocatable :: col
     logical, intent(in) :: keep_fs_flavor
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     associate (data => core%data)
       allocate (qn_mask (data%n_in + data%n_out))
       qn_mask( : data%n_in) = &
               quantum_numbers_mask (.false., .true., .false.) &
               .or. qn_mask_in
       qn_mask(data%n_in + 1 : ) = &
               quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.)
       if (core%use_color_factors) then
          call state%trace%init_square (state%int_eff, qn_mask, &
               col_flow_index = data%cf_index, &
               col_factor = data%color_factors, &
               col_index_hi = col, &
               nc = core%nc)
       else
          call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc)
       end if
     end associate
     state%has_trace = .true.
   end subroutine isolated_state_setup_square_trace
 
 @ %def isolated_state_setup_square_trace
 @ Set up an identity-evaluator for the trace. This implies that [[me]]
 is considered to be a squared amplitude, as for example for BLHA matrix
 elements.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_identity_trace => isolated_state_setup_identity_trace
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_identity_trace (state, core, qn_mask_in, &
       keep_fs_flavors, keep_colors)
      class(isolated_state_t), intent(inout), target :: state
      class(prc_core_t), intent(in) :: core
      type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
      logical, intent(in), optional :: keep_fs_flavors, keep_colors
      type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
      logical :: fs_flv_flag, col_flag
      fs_flv_flag = .true.; col_flag = .true.
      if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
      if (present(keep_colors)) col_flag = .not. keep_colors
      associate (data => core%data)
         allocate (qn_mask (data%n_in + data%n_out))
         qn_mask( : data%n_in) = &
            quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in
         qn_mask(data%n_in + 1 : ) = &
            quantum_numbers_mask (fs_flv_flag, col_flag, .true.)
      end associate
      call state%int_eff%set_mask (qn_mask)
      call state%trace%init_identity (state%int_eff)
      state%has_trace = .true.
   end subroutine isolated_state_setup_identity_trace
 
 @ %def isolated_state_setup_identity_trace
 @ Set up the evaluator for the transition matrix, exclusive in
 helicities where this is requested.
 
 For all unstable final-state particles we keep polarization according to the
 applicable decay options.  If the process is a decay itself, this applies also
 to the initial state.
 
 For all polarized final-state particles, we keep polarization including
 off-diagonal entries.  We drop helicity completely for unpolarized final-state
 particles.
 
 For the initial state, if the particle has not been handled yet, we
 apply the provided [[qn_mask_in]] which communicates the beam properties.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_square_matrix => isolated_state_setup_square_matrix
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_square_matrix &
        (state, core, model, qn_mask_in, col)
     class(isolated_state_t), intent(inout), target :: state
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
     integer, dimension(:), intent(in) :: col
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     logical :: helmask, helmask_hd
     associate (data => core%data)
       allocate (qn_mask (data%n_in + data%n_out))
       allocate (flv (data%n_flv))
       do i = 1, data%n_in + data%n_out
          call flv%init (data%flv_state(i,:), model)
          if ((data%n_in == 1 .or. i > data%n_in) &
               .and. any (.not. flv%is_stable ())) then
             helmask = all (flv%decays_isotropically ())
             helmask_hd = all (flv%decays_diagonal ())
             qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, &
                  mask_hd = helmask_hd)
          else if (i > data%n_in) then
             helmask = all (.not. flv%is_polarized ())
             qn_mask(i) = quantum_numbers_mask (.false., .true., helmask)
          else
             qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) &
               .or. qn_mask_in(i)
          end if
       end do
       if (core%use_color_factors) then
          call state%matrix%init_square (state%int_eff, qn_mask, &
               col_flow_index = data%cf_index, &
               col_factor = data%color_factors, &
               col_index_hi = col, &
               nc = core%nc)
       else
          call state%matrix%init_square (state%int_eff, &
               qn_mask, &
               nc = core%nc)
       end if
     end associate
     state%has_matrix = .true.
   end subroutine isolated_state_setup_square_matrix
 
 @ %def isolated_state_setup_square_matrix
 @ This procedure initializes the evaluator that computes the
 contributions to color flows, neglecting color interference.
 The incoming-particle mask can be used to sum over incoming flavor.
 
 Helicity handling: see above.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_square_flows => isolated_state_setup_square_flows
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_square_flows (state, core, model, qn_mask_in)
     class(isolated_state_t), intent(inout), target :: state
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     logical :: helmask, helmask_hd
     associate (data => core%data)
       allocate (qn_mask (data%n_in + data%n_out))
       allocate (flv (data%n_flv))
       do i = 1, data%n_in + data%n_out
          call flv%init (data%flv_state(i,:), model)
          if ((data%n_in == 1 .or. i > data%n_in) &
               .and. any (.not. flv%is_stable ())) then
             helmask = all (flv%decays_isotropically ())
             helmask_hd = all (flv%decays_diagonal ())
             qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, &
                  mask_hd = helmask_hd)
          else if (i > data%n_in) then
             helmask = all (.not. flv%is_polarized ())
             qn_mask(i) = quantum_numbers_mask (.false., .false., helmask)
          else
             qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) &
               .or. qn_mask_in(i)
          end if
       end do
       call state%flows%init_square (state%int_eff, qn_mask, &
            expand_color_flows = .true.)
     end associate
     state%has_flows = .true.
   end subroutine isolated_state_setup_square_flows
 
 @ %def isolated_state_setup_square_flows
 @
 \subsection{Evaluator initialization: connected state}
 Set up a trace evaluator as a product of two evaluators (incoming state,
 effective interaction).  In the result, all quantum numbers are summed over.
 
 If the optional [[int]] interaction is provided, use this for the
 first factor in the convolution.  Otherwise, use the final interaction
 of the stored [[sf_chain]].
 
 The [[resonant]] flag applies if we want to construct
 a decay chain.  The resonance property can propagate to the final
 event output.
 
 If an extended structure function is required [[requires_extended_sf]],
 we have to not consider [[sub]] as a quantum number.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_connected_trace => connected_state_setup_connected_trace
 <<Parton states: procedures>>=
   subroutine connected_state_setup_connected_trace &
        (state, isolated, int, resonant, undo_helicities, &
         keep_fs_flavors, requires_extended_sf)
     class(connected_state_t), intent(inout), target :: state
     type(isolated_state_t), intent(in), target :: isolated
     type(interaction_t), intent(in), optional, target :: int
     logical, intent(in), optional :: resonant
     logical, intent(in), optional :: undo_helicities
     logical, intent(in), optional :: keep_fs_flavors
     logical, intent(in), optional :: requires_extended_sf
     type(quantum_numbers_mask_t) :: mask
     type(interaction_t), pointer :: src_int, beam_int
     logical :: reduce, fs_flv_flag
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
          "connected_state_setup_connected_trace")
     reduce = .false.; fs_flv_flag = .true.
     if (present (undo_helicities)) reduce = undo_helicities
     if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
     mask = quantum_numbers_mask (fs_flv_flag, .true., .true.)
     if (present (int)) then
        src_int => int
     else
        src_int => isolated%sf_chain_eff%get_out_int_ptr ()
     end if
 
     if (debug2_active (D_PROCESS_INTEGRATION)) then
        call src_int%basic_write ()
     end if
 
     call state%trace%init_product (src_int, isolated%trace, &
          qn_mask_conn = mask, &
          qn_mask_rest = mask, &
          connections_are_resonant = resonant, &
          ignore_sub_for_qn = requires_extended_sf)
 
     if (reduce) then
        beam_int => isolated%sf_chain_eff%get_beam_int_ptr ()
        call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ())
        call undo_qn_hel (src_int, mask, src_int%get_n_tot ())
        call beam_int%set_matrix_element (cmplx (1, 0, default))
        call src_int%set_matrix_element (cmplx (1, 0, default))
     end if
 
     state%has_trace = .true.
   contains
     subroutine undo_qn_hel (int_in, mask, n_tot)
       type(interaction_t), intent(inout) :: int_in
       type(quantum_numbers_mask_t), intent(in) :: mask
       integer, intent(in) :: n_tot
       type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in
       mask_in = mask
       call int_in%set_mask (mask_in)
     end subroutine undo_qn_hel
   end subroutine connected_state_setup_connected_trace
 
 @ %def connected_state_setup_connected_trace
 @ Set up a matrix evaluator as a product of two evaluators (incoming
 state, effective interation).  In the intermediate state, color and
 helicity is summed over.  In the final state, we keep the quantum
 numbers which are present in the original evaluators.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_connected_matrix => connected_state_setup_connected_matrix
 <<Parton states: procedures>>=
   subroutine connected_state_setup_connected_matrix &
        (state, isolated, int, resonant, qn_filter_conn)
     class(connected_state_t), intent(inout), target :: state
     type(isolated_state_t), intent(in), target :: isolated
     type(interaction_t), intent(in), optional, target :: int
     logical, intent(in), optional :: resonant
     type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
     type(quantum_numbers_mask_t) :: mask
     type(interaction_t), pointer :: src_int
     mask = quantum_numbers_mask (.false., .true., .true.)
     if (present (int)) then
        src_int => int
     else
        src_int => isolated%sf_chain_eff%get_out_int_ptr ()
     end if
     call state%matrix%init_product &
          (src_int, isolated%matrix, mask, &
           qn_filter_conn = qn_filter_conn, &
           connections_are_resonant = resonant)
     state%has_matrix = .true.
   end subroutine connected_state_setup_connected_matrix
 
 @ %def connected_state_setup_connected_matrix
 @ Set up a matrix evaluator as a product of two evaluators (incoming
 state, effective interation).  In the intermediate state, only
 helicity is summed over.  In the final state, we keep the quantum
 numbers which are present in the original evaluators.
 
 
 If the optional [[int]] interaction is provided, use this for the
 first factor in the convolution.  Otherwise, use the final interaction
 of the stored [[sf_chain]], after creating an intermediate interaction
 that includes a correlated color state.  We assume that for a
 caller-provided [[int]], this is not necessary.
 
 For fixed-order NLO differential distribution, we are interested at
 the partonic level, no parton showering takes place as this would
 demand for a proper matching. So, the flows in the [[connected_state]]
 are not needed, and the color part will be masked for the interaction
 coming from the [[sf_chain]]. The squared matrix elements coming from
 the OLP provider at the moment do not come with flows anyhow. This
 needs to be revised once the matching to the shower is completed.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_connected_flows => connected_state_setup_connected_flows
 <<Parton states: procedures>>=
   subroutine connected_state_setup_connected_flows &
        (state, isolated, int, resonant, qn_filter_conn, mask_color)
     class(connected_state_t), intent(inout), target :: state
     type(isolated_state_t), intent(in), target :: isolated
     type(interaction_t), intent(in), optional, target :: int
     logical, intent(in), optional :: resonant, mask_color
     type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
     type(quantum_numbers_mask_t) :: mask
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_sf
     type(interaction_t), pointer :: src_int
     logical :: mask_c
     mask_c = .false.
     if (present (mask_color))  mask_c = mask_color
     mask = quantum_numbers_mask (.false., .false., .true.)
     if (present (int)) then
        src_int => int
     else
        src_int => isolated%sf_chain_eff%get_out_int_ptr ()
        call state%flows_sf%init_color_contractions (src_int)
        state%has_flows_sf = .true.
        src_int => state%flows_sf%interaction_t
        if (mask_c) then
           allocate (mask_sf (src_int%get_n_tot ()))
           mask_sf = quantum_numbers_mask (.false., .true., .false.)
           call src_int%reduce_state_matrix (mask_sf, keep_order = .true.)
        end if
     end if
     call state%flows%init_product (src_int, isolated%flows, mask, &
          qn_filter_conn = qn_filter_conn, &
          connections_are_resonant = resonant)
     state%has_flows = .true.
   end subroutine connected_state_setup_connected_flows
 
 @ %def connected_state_setup_connected_flows
 @ Determine and store the flavor content for the connected state.
 This queries the [[matrix]] evaluator component, which should hold the
 requested flavor information.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_state_flv => connected_state_setup_state_flv
 <<Parton states: procedures>>=
   subroutine connected_state_setup_state_flv (state, n_out_hard)
     class(connected_state_t), intent(inout), target :: state
     integer, intent(in) :: n_out_hard
     call interaction_get_flv_content &
          (state%matrix%interaction_t, state%state_flv, n_out_hard)
   end subroutine connected_state_setup_state_flv
 
 @ %def connected_state_setup_state_flv
 @ Return the current flavor state object.
 <<Parton states: connected state: TBP>>=
   procedure :: get_state_flv => connected_state_get_state_flv
 <<Parton states: procedures>>=
   function connected_state_get_state_flv (state) result (state_flv)
     class(connected_state_t), intent(in) :: state
     type(state_flv_content_t) :: state_flv
     state_flv = state%state_flv
   end function connected_state_get_state_flv
 
 @ %def connected_state_get_state_flv
 @
 \subsection{Cuts and expressions}
 Set up the [[subevt]] that corresponds to the connected interaction.
 The index arrays refer to the interaction.
 
 We assign the particles as follows: the beam particles are the first
 two (decay process: one) entries in the trace evaluator.  The incoming
 partons are identified by their link to the outgoing partons of the
 structure-function chain.  The outgoing partons are those of the trace
 evaluator, which include radiated partons during the
 structure-function chain.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_subevt => connected_state_setup_subevt
 <<Parton states: procedures>>=
   subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out)
     class(connected_state_t), intent(inout), target :: state
     type(sf_chain_instance_t), intent(in), target :: sf_chain
     type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
     integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j
     integer, dimension(:), allocatable :: i_beam, i_in, i_out
     integer :: sf_out_i
     type(interaction_t), pointer :: sf_int
     sf_int => sf_chain%get_out_int_ptr ()
     n_beam = size (f_beam)
     n_in = size (f_in)
     n_out = size (f_out)
     n_vir = state%trace%get_n_vir ()
     n_tot = state%trace%get_n_tot ()
     allocate (i_beam (n_beam), i_in (n_in), i_out (n_out))
     i_beam = [(i, i = 1, n_beam)]
     do j = 1, n_in
        sf_out_i = sf_chain%get_out_i (j)
        i_in(j) = interaction_find_link &
             (state%trace%interaction_t, sf_int, sf_out_i)
     end do
     i_out = [(i, i = n_vir + 1, n_tot)]
     call state%expr%setup_subevt (state%trace%interaction_t, &
          i_beam, i_in, i_out, f_beam, f_in, f_out)
     state%has_expr = .true.
   end subroutine connected_state_setup_subevt
 
 @ %def connected_state_setup_subevt
 @ Initialize the variable list specific for this state/term.  We insert event
 variables ([[sqrts_hat]]) and link the process variable list.  The variable
 list acquires pointers to subobjects of [[state]], which must therefore have a
 [[target]] attribute.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_var_list => connected_state_setup_var_list
 <<Parton states: procedures>>=
   subroutine connected_state_setup_var_list (state, process_var_list, beam_data)
     class(connected_state_t), intent(inout), target :: state
     type(var_list_t), intent(in), target :: process_var_list
     type(beam_data_t), intent(in) :: beam_data
     call state%expr%setup_vars (beam_data%get_sqrts ())
     call state%expr%link_var_list (process_var_list)
   end subroutine connected_state_setup_var_list
 
 @ %def connected_state_setup_var_list
 @ Allocate the cut expression etc.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_cuts => connected_state_setup_cuts
   procedure :: setup_scale => connected_state_setup_scale
   procedure :: setup_fac_scale => connected_state_setup_fac_scale
   procedure :: setup_ren_scale => connected_state_setup_ren_scale
   procedure :: setup_weight => connected_state_setup_weight
 <<Parton states: procedures>>=
   subroutine connected_state_setup_cuts (state, ef_cuts)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_cuts
     call state%expr%setup_selection (ef_cuts)
   end subroutine connected_state_setup_cuts
 
   subroutine connected_state_setup_scale (state, ef_scale)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_scale
     call state%expr%setup_scale (ef_scale)
   end subroutine connected_state_setup_scale
 
   subroutine connected_state_setup_fac_scale (state, ef_fac_scale)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_fac_scale
     call state%expr%setup_fac_scale (ef_fac_scale)
   end subroutine connected_state_setup_fac_scale
 
   subroutine connected_state_setup_ren_scale (state, ef_ren_scale)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_ren_scale
     call state%expr%setup_ren_scale (ef_ren_scale)
   end subroutine connected_state_setup_ren_scale
 
   subroutine connected_state_setup_weight (state, ef_weight)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_weight
     call state%expr%setup_weight (ef_weight)
   end subroutine connected_state_setup_weight
 
 @ %def connected_state_setup_expressions
 @ Reset the expression object: invalidate the subevt.
 <<Parton states: connected state: TBP>>=
   procedure :: reset_expressions => connected_state_reset_expressions
 <<Parton states: procedures>>=
   subroutine connected_state_reset_expressions (state)
     class(connected_state_t), intent(inout) :: state
     if (state%has_expr)  call state%expr%reset_contents ()
   end subroutine connected_state_reset_expressions
 
 @ %def connected_state_reset_expressions
 @
 \subsection{Evaluation}
 Transfer momenta to the trace evaluator and fill the [[subevt]] with
 this effective kinematics, if applicable.
 
 Note: we may want to apply a boost for the [[subevt]].
 <<Parton states: parton state: TBP>>=
   procedure :: receive_kinematics => parton_state_receive_kinematics
 <<Parton states: procedures>>=
   subroutine parton_state_receive_kinematics (state)
     class(parton_state_t), intent(inout), target :: state
     if (state%has_trace) then
        call state%trace%receive_momenta ()
        select type (state)
        class is (connected_state_t)
           if (state%has_expr) then
              call state%expr%fill_subevt (state%trace%interaction_t)
           end if
        end select
     end if
   end subroutine parton_state_receive_kinematics
 
 @ %def parton_state_receive_kinematics
 @ Recover kinematics: We assume that the trace evaluator is filled
 with momenta.  Send those momenta back to the sources, then fill the
 variables and subevent as above.
 
 The incoming momenta of the connected state are not connected to the
 isolated state but to the beam interaction.  Therefore, the incoming
 momenta within the isolated state do not become defined, yet.
 Instead, we reconstruct the beam (and ISR) momentum configuration.
 <<Parton states: parton state: TBP>>=
   procedure :: send_kinematics => parton_state_send_kinematics
 <<Parton states: procedures>>=
   subroutine parton_state_send_kinematics (state)
     class(parton_state_t), intent(inout), target :: state
     if (state%has_trace) then
        call interaction_send_momenta (state%trace%interaction_t)
        select type (state)
        class is (connected_state_t)
           call state%expr%fill_subevt (state%trace%interaction_t)
        end select
     end if
   end subroutine parton_state_send_kinematics
 
 @ %def parton_state_send_kinematics
 @ Evaluate the expressions.  The routine evaluates first the cut expression.
 If the event passes, it evaluates the other expressions.  Where no expressions
 are defined, default values are inserted.
 <<Parton states: connected state: TBP>>=
   procedure :: evaluate_expressions => connected_state_evaluate_expressions
 <<Parton states: procedures>>=
   subroutine connected_state_evaluate_expressions (state, passed, &
        scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
     class(connected_state_t), intent(inout) :: state
     logical, intent(out) :: passed
     real(default), intent(out) :: scale, weight
     real(default), intent(out), allocatable :: fac_scale, ren_scale
     real(default), intent(in), allocatable, optional :: scale_forced
     logical, intent(in), optional :: force_evaluation
     if (state%has_expr) then
        call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, &
             scale_forced, force_evaluation)
     end if
   end subroutine connected_state_evaluate_expressions
 
 @ %def connected_state_evaluate_expressions
 @ Evaluate the structure-function chain, if it is allocated
 explicitly.  The argument is the factorization scale.
 
 If the chain is merely a pointer, the chain should already be
 evaluated at this point.
 <<Parton states: isolated state: TBP>>=
   procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain
 <<Parton states: procedures>>=
   subroutine isolated_state_evaluate_sf_chain (state, fac_scale)
     class(isolated_state_t), intent(inout) :: state
     real(default), intent(in) :: fac_scale
     if (state%sf_chain_is_allocated)  call state%sf_chain_eff%evaluate (fac_scale)
   end subroutine isolated_state_evaluate_sf_chain
 
 @ %def isolated_state_evaluate_sf_chain
 @ Evaluate the trace.
 <<Parton states: parton state: TBP>>=
   procedure :: evaluate_trace => parton_state_evaluate_trace
 <<Parton states: procedures>>=
   subroutine parton_state_evaluate_trace (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_trace) call state%trace%evaluate ()
   end subroutine parton_state_evaluate_trace
 
 @ %def parton_state_evaluate_trace
 <<Parton states: parton state: TBP>>=
   procedure :: evaluate_matrix => parton_state_evaluate_matrix
 <<Parton states: procedures>>=
   subroutine parton_state_evaluate_matrix (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_matrix) call state%matrix%evaluate ()
   end subroutine parton_state_evaluate_matrix
 
 @ %def parton_state_evaluate_matrix
 @ Evaluate the extra evaluators that we need for physical events.
 <<Parton states: parton state: TBP>>=
   procedure :: evaluate_event_data => parton_state_evaluate_event_data
 <<Parton states: procedures>>=
   subroutine parton_state_evaluate_event_data (state, only_momenta)
     class(parton_state_t), intent(inout) :: state
     logical, intent(in), optional :: only_momenta
     logical :: only_mom
     only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta
     select type (state)
     type is (connected_state_t)
        if (state%has_flows_sf) then
           call state%flows_sf%receive_momenta ()
           if (.not. only_mom) call state%flows_sf%evaluate ()
        end if
     end select
     if (state%has_matrix) then
        call state%matrix%receive_momenta ()
        if (.not. only_mom) call state%matrix%evaluate ()
     end if
     if (state%has_flows) then
        call state%flows%receive_momenta ()
        if (.not. only_mom) call state%flows%evaluate ()
     end if
   end subroutine parton_state_evaluate_event_data
 
 @ %def parton_state_evaluate_event_data
 @ Normalize the helicity density matrix by its trace, i.e., factor out
 the trace and put it into an overall normalization factor.  The trace
 and flow evaluators are unchanged.
 <<Parton states: parton state: TBP>>=
   procedure :: normalize_matrix_by_trace => &
        parton_state_normalize_matrix_by_trace
 <<Parton states: procedures>>=
   subroutine parton_state_normalize_matrix_by_trace (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_matrix) call state%matrix%normalize_by_trace ()
   end subroutine parton_state_normalize_matrix_by_trace
 
 @ %def parton_state_normalize_matrix_by_trace
 @
 \subsection{Accessing the state}
 Three functions return a pointer to the event-relevant interactions.
 <<Parton states: parton state: TBP>>=
   procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr
   procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr
   procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr
 <<Parton states: procedures>>=
   function parton_state_get_trace_int_ptr (state) result (ptr)
     class(parton_state_t), intent(in), target :: state
     type(interaction_t), pointer :: ptr
     if (state%has_trace) then
        ptr => state%trace%interaction_t
     else
        ptr => null ()
     end if
   end function parton_state_get_trace_int_ptr
 
   function parton_state_get_matrix_int_ptr (state) result (ptr)
     class(parton_state_t), intent(in), target :: state
     type(interaction_t), pointer :: ptr
     if (state%has_matrix) then
        ptr => state%matrix%interaction_t
     else
        ptr => null ()
     end if
   end function parton_state_get_matrix_int_ptr
 
   function parton_state_get_flows_int_ptr (state) result (ptr)
     class(parton_state_t), intent(in), target :: state
     type(interaction_t), pointer :: ptr
     if (state%has_flows) then
        ptr => state%flows%interaction_t
     else
        ptr => null ()
     end if
   end function parton_state_get_flows_int_ptr
 
 @ %def parton_state_get_trace_int_ptr
 @ %def parton_state_get_matrix_int_ptr
 @ %def parton_state_get_flows_int_ptr
 @ Return the indices of the beam particles and the outgoing particles within
 the trace (and thus, matrix and flows) evaluator, respectively.
 <<Parton states: connected state: TBP>>=
   procedure :: get_beam_index => connected_state_get_beam_index
   procedure :: get_in_index => connected_state_get_in_index
 <<Parton states: procedures>>=
   subroutine connected_state_get_beam_index (state, i_beam)
     class(connected_state_t), intent(in) :: state
     integer, dimension(:), intent(out) :: i_beam
     call state%expr%get_beam_index (i_beam)
   end subroutine connected_state_get_beam_index
 
   subroutine connected_state_get_in_index (state, i_in)
     class(connected_state_t), intent(in) :: state
     integer, dimension(:), intent(out) :: i_in
     call state%expr%get_in_index (i_in)
   end subroutine connected_state_get_in_index
 
 @ %def connected_state_get_beam_index
 @ %def connected_state_get_in_index
 @
 <<Parton states: public>>=
   public :: refill_evaluator
 <<Parton states: procedures>>=
   subroutine refill_evaluator (sqme, qn, flv_index, evaluator)
     complex(default), intent(in), dimension(:) :: sqme
     type(quantum_numbers_t), intent(in), dimension(:,:) :: qn
     integer, intent(in), dimension(:), optional :: flv_index
     type(evaluator_t), intent(inout) :: evaluator
     integer :: i, i_flv
     do i = 1, size (sqme)
        if (present (flv_index)) then
           i_flv = flv_index(i)
        else
           i_flv = i
        end if
        call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), &
             match_only_flavor = .true.)
     end do
   end subroutine refill_evaluator
 
 @ %def refill_evaluator
 @ Return the number of outgoing (hard) particles for the state.
 <<Parton states: parton state: TBP>>=
   procedure :: get_n_out => parton_state_get_n_out
 <<Parton states: procedures>>=
   function parton_state_get_n_out (state) result (n)
     class(parton_state_t), intent(in), target :: state
     integer :: n
     n = state%trace%get_n_out ()
   end function parton_state_get_n_out
 
 @ %def parton_state_get_n_out
 @
 \subsection{Unit tests}
 <<[[parton_states_ut.f90]]>>=
 <<File header>>
 
 module parton_states_ut
   use unit_tests
   use parton_states_uti
 
 <<Standard module head>>
 
 <<Parton states: public test>>
 
 contains
 
 <<Parton states: test driver>>
 
 end module parton_states_ut
 @ %def parton_states_ut
 <<[[parton_states_uti.f90]]>>=
 <<File header>>
 
 module parton_states_uti
 
 <<Use kinds>>
 <<Use strings>>
   use constants, only: zero
   use numeric_utils
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use sf_base, only: sf_chain_instance_t
   use state_matrices, only: state_matrix_t
   use prc_template_me, only: prc_template_me_t
   use interactions, only: interaction_t
   use models, only: model_t, create_test_model
   use parton_states
 
 <<Standard module head>>
 
 <<Parton states: test declarations>>
 
 contains
 
 <<Parton states: tests>>
 
 end module parton_states_uti
 @ %def parton_states_uti
 @
 <<Parton states: public test>>=
   public :: parton_states_test
 <<Parton states: test driver>>=
   subroutine parton_states_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Parton states: execute tests>>
   end subroutine parton_states_test
 
 @ %def parton_states_test
 @
 \subsubsection{Test a simple isolated state}
 <<Parton states: execute tests>>=
   call test (parton_states_1, "parton_states_1", &
        "Create a 2 -> 2 isolated state and compute trace", &
        u, results)
 <<Parton states: test declarations>>=
   public :: parton_states_1
 <<Parton states: tests>>=
   subroutine parton_states_1 (u)
     integer, intent(in) :: u
     type(state_matrix_t), allocatable :: state
     type(flavor_t), dimension(2) :: flv_in
     type(flavor_t), dimension(2) :: flv_out1, flv_out2
     type(flavor_t), dimension(4) :: flv_tot
     type(helicity_t), dimension(4) :: hel
     type(color_t), dimension(4) :: col
     integer :: h1, h2, h3, h4
     integer :: f
     integer :: i
     type(quantum_numbers_t), dimension(4) :: qn
     type(prc_template_me_t) :: core
     type(sf_chain_instance_t), target :: sf_chain
     type(interaction_t), target :: int
     type(isolated_state_t) :: isolated_state
     integer :: n_states = 0
     integer, dimension(:), allocatable :: col_flow_index
     type(quantum_numbers_mask_t), dimension(2) :: qn_mask
     integer, dimension(8) :: i_allowed_states
     complex(default), dimension(8) :: me
     complex(default) :: me_check_tot, me_check_1, me_check_2, me2
     logical :: tmp1, tmp2
     type(model_t), pointer :: test_model => null ()
 
     write (u, "(A)") "* Test output: parton_states_1"
     write (u, "(A)") "* Purpose: Test the standard parton states"
     write (u, "(A)")
 
     call flv_in%init ([11, -11])
     call flv_out1%init ([1, -1])
     call flv_out2%init ([2, -2])
 
     write (u, "(A)") "* Using incoming flavors: "
     call flavor_write_array (flv_in, u)
     write (u, "(A)") "* Two outgoing flavor structures: "
     call flavor_write_array (flv_out1, u)
     call flavor_write_array (flv_out2, u)
 
 
     write (u, "(A)") "* Initialize state matrix"
     allocate (state)
     call state%init ()
 
     write (u, "(A)") "* Fill state matrix"
     call col(3)%init ([1])
     call col(4)%init ([-1])
     do f = 1, 2
        do h1 = -1, 1, 2
           do h2 = -1, 1, 2
              do h3 = -1, 1, 2
                 do h4 = -1, 1, 2
                    n_states = n_states + 1
                    call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
                    if (f == 1) then
                       flv_tot = [flv_in, flv_out1]
                    else
                       flv_tot = [flv_in, flv_out2]
                    end if
                    call qn%init (flv_tot, col, hel)
                    call state%add_state (qn)
                 end do
              end do
           end do
        end do
     end do
 
     !!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations
     !!! -> 32 states.
     write (u, "(A)")
     write (u, "(A,I2)") "* Generated number of states: ", n_states
 
     call state%freeze ()
 
     !!! Indices of the helicity configurations which are non-zero
     i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27]
     me = [cmplx (-1.89448E-5_default,  9.94456E-7_default, default), &
           cmplx (-8.37887E-2_default,  4.30842E-3_default, default), &
           cmplx (-1.99997E-1_default, -1.01985E-2_default, default), &
           cmplx ( 1.79717E-5_default,  9.27038E-7_default, default), &
           cmplx (-1.74859E-5_default,  8.78819E-7_default, default), &
           cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), &
           cmplx ( 2.41331E-1_default,  1.23306E-2_default, default), &
           cmplx (-3.59435E-5_default, -1.85407E-6_default, default)]
     me_check_tot = cmplx (zero, zero, default)
     me_check_1 = cmplx (zero, zero, default)
     me_check_2 = cmplx (zero, zero, default)
     do i = 1, 8
        me2 = me(i) * conjg (me(i))
        me_check_tot = me_check_tot + me2
        if (i < 5) then
           me_check_1 = me_check_1 + me2
        else
           me_check_2 = me_check_2 + me2
        end if
        call state%set_matrix_element (i_allowed_states(i), me(i))
     end do
 
     !!! Do not forget the color factor
     me_check_tot = 3._default * me_check_tot
     me_check_1 = 3._default * me_check_1
     me_check_2 = 3._default * me_check_2
     write (u, "(A)")
 
     write (u, "(A)") "* Setup interaction"
     call int%basic_init (2, 0, 2, set_relations = .true.)
     call int%set_state_matrix (state)
 
     core%data%n_in = 2; core%data%n_out = 2
     core%data%n_flv = 2
     allocate (core%data%flv_state (4, 2))
     core%data%flv_state (1, :) = [11, 11]
     core%data%flv_state (2, :) = [-11, -11]
     core%data%flv_state (3, :) = [1, 2]
     core%data%flv_state (4, :) = [-1, -2]
     core%use_color_factors = .false.
     core%nc = 3
 
     write (u, "(A)") "* Init isolated state"
     call isolated_state%init (sf_chain, int)
     !!! There is only one color flow.
     allocate (col_flow_index (n_states)); col_flow_index = 1
     call qn_mask%init (.false., .false., .true., mask_cg = .false.)
     write (u, "(A)") "* Give a trace to the isolated state"
     call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.)
     call isolated_state%evaluate_trace ()
     write (u, "(A)")
     write (u, "(A)", advance = "no") "* Squared matrix element correct: "
     write (u, "(L1)") nearly_equal (me_check_tot, &
        isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default)
 
 
     write (u, "(A)") "* Give a matrix to the isolated state"
     call create_test_model (var_str ("SM"), test_model)
     call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index)
     call isolated_state%evaluate_matrix ()
 
     write (u, "(A)") "* Sub-matrixelements correct: "
     tmp1 = nearly_equal (me_check_1, &
        isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default)
     tmp2 = nearly_equal (me_check_2, &
        isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default)
     write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2
 
     write (u, "(A)") "* Test output end: parton_states_1"
   end subroutine parton_states_1
 
 @ %def parton_states_1
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process component management}
 This module contains tools for managing and combining process
 components and matrix-element code and values, acting at a level below
 the actual process definition.
 
 \subsection{Abstract base type}
 The types introduced here are abstract base types.
 <<[[pcm_base.f90]]>>=
 <<File header>>
 
 module pcm_base
 
 <<Use kinds>>
   use io_units
   use diagnostics
   use format_utils, only: write_integer_array
   use format_utils, only: write_separator
   use physics_defs, only: BORN, NLO_REAL
 <<Use strings>>
   use os_interface, only: os_data_t
 
   use process_libraries, only: process_component_def_t
   use process_libraries, only: process_library_t
 
   use prc_core_def
   use prc_core
 
   use variables, only: var_list_t
   use mappings, only: mapping_defaults_t
   use phs_base, only: phs_config_t
   use phs_forests, only: phs_parameters_t
   use mci_base, only: mci_t
   use model_data, only: model_data_t
   use models, only: model_t
 
   use blha_config, only: blha_master_t
   use blha_olp_interfaces, only: blha_template_t
   use process_config
   use process_mci, only: process_mci_entry_t
 
 <<Standard module head>>
 
 <<PCM base: public>>
 
 <<PCM base: parameters>>
 
 <<PCM base: types>>
 
 <<PCM base: interfaces>>
 
 contains
 
 <<PCM base: procedures>>
 
 end module pcm_base
 @ %def pcm_base
 @
 \subsection{Core management}
 This object holds information about the cores used by the components
 and allocates the corresponding manager instance.
 
 [[i_component]] is the index of the process component which this core belongs
 to.  The pointer to the core definition is a convenient help in configuring
 the core itself.
 
 We allow for a [[blha_config]] configuration object that covers BLHA cores.
 The BLHA standard is suitable generic to warrant support outside of specific
 type extension (i.e., applies to LO and NLO if requested).  The BLHA
 configuration is allocated only if the core requires it.
 <<PCM base: public>>=
   public :: core_entry_t
 <<PCM base: types>>=
   type :: core_entry_t
      integer :: i_component = 0
      logical :: active = .false.
      class(prc_core_def_t), pointer :: core_def => null ()
      type(blha_template_t), allocatable :: blha_config
      class(prc_core_t), allocatable :: core
    contains
    <<PCM base: core entry: TBP>>
   end type core_entry_t
 
 @ %def core_entry_t
 @
 <<PCM base: core entry: TBP>>=
   procedure :: get_core_ptr => core_entry_get_core_ptr
 <<PCM base: procedures>>=
   function core_entry_get_core_ptr (core_entry) result (core)
     class(core_entry_t), intent(in), target :: core_entry
     class(prc_core_t), pointer :: core
     if (allocated (core_entry%core)) then
        core => core_entry%core
     else
        core => null ()
     end if
   end function core_entry_get_core_ptr
 
 @ %def core_entry_get_core_ptr
 @ Configure the core object after allocation with correct type.  The
 [[core_def]] object pointer and the index [[i_component]] of the associated
 process component are already there.
 <<PCM base: core entry: TBP>>=
   procedure :: configure => core_entry_configure
 <<PCM base: procedures>>=
   subroutine core_entry_configure (core_entry, lib, id)
     class(core_entry_t), intent(inout) :: core_entry
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: id
     call core_entry%core%init &
          (core_entry%core_def, lib, id, core_entry%i_component)
   end subroutine core_entry_configure
 
 @ %def core_entry_configure
 @
 \subsection{Process component manager}
 The process-component manager [[pcm]] is the master component of the
 [[process_t]] object.  It serves two purposes:
 \begin{enumerate}
 \item
   It holds configuration data which allow us to centrally manage the
   components, terms, etc.\ of the process object.
 \item
   It implements the methods that realize the algorithm for constructing
   the process object and computing an integral.  This algorithm makes
   use of the data stored within [[pcm]].
 \end{enumerate}
 To this end, the object is abstract and polymorphic.  The two
 extensions that we support, implement (a) default tree-level
 calculation, optionally including a sum over sub-processes with
 different particle content, or (b) the FKS-NLO subtraction algorithm for
 QCD-corrected processes.  In both cases, the type extensions may hold
 suitable further data.
 
 Data included in the base type:
 
 The number of components determines the [[component_selected]] array.
 
 [[i_phs_config]] is a lookup table that holds the PHS configuration index
 for a given component index.
 
 [[i_core]] is a lookup table that holds the core-entry index for a
 given component index.
 
 [[i_mci]] is a lookup table that holds the integrator (MCI) index for
 a given component index.
 <<PCM base: public>>=
   public :: pcm_t
 <<PCM base: types>>=
   type, abstract :: pcm_t
      logical :: initialized = .false.
      logical :: has_pdfs = .false.
      integer :: n_components = 0
      integer :: n_cores = 0
      integer :: n_mci = 0
      logical, dimension(:), allocatable :: component_selected
      logical, dimension(:), allocatable :: component_active
      integer, dimension(:), allocatable :: i_phs_config
      integer, dimension(:), allocatable :: i_core
      integer, dimension(:), allocatable :: i_mci
      type(blha_template_t) :: blha_defaults
      logical :: uses_blha = .false.
      type(os_data_t) :: os_data
   contains
   <<PCM base: pcm: TBP>>
   end type pcm_t
 
 @ %def pcm_t
 @ The factory method.  We use the [[inout]] intent, so calling this
 again is an error.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_allocate_workspace), deferred :: allocate_workspace
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_allocate_workspace (pcm, work)
        import
        class(pcm_t), intent(in) :: pcm
        class(pcm_workspace_t), intent(inout), allocatable :: work
      end subroutine pcm_allocate_workspace
   end interface
 
 @ %def pcm_allocate_workspace
 @
 <<PCM base: pcm: TBP>>=
   procedure(pcm_is_nlo), deferred :: is_nlo
 <<PCM base: interfaces>>=
   abstract interface
      function pcm_is_nlo (pcm) result (is_nlo)
         import
         logical :: is_nlo
         class(pcm_t), intent(in) :: pcm
      end function pcm_is_nlo
   end interface
 
 @ %def pcm_is_nlo
 @
 <<PCM base: pcm: TBP>>=
   procedure(pcm_final), deferred :: final
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_final (pcm)
         import
         class(pcm_t), intent(inout) :: pcm
      end subroutine pcm_final
   end interface
 
 @ %def pcm_final
 @
 \subsection{Initialization methods}
 The PCM has the duty to coordinate and configure the process-object
 components.
 
 Initialize the PCM configuration itself, using environment data.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_init), deferred :: init
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_init (pcm, env, meta)
        import
        class(pcm_t), intent(out) :: pcm
        type(process_environment_t), intent(in) :: env
        type(process_metadata_t), intent(in) :: meta
      end subroutine pcm_init
   end interface
 
 @ %def pcm_init
 @
 Initialize the BLHA configuration block, the component-independent default
 settings.  This is to be called by [[pcm_init]].  We use the provided variable
 list.
 
 This block is filled regardless of whether BLHA is actually used, because why
 not?  We use a default value for the scheme (not set in unit tests).
 <<PCM base: pcm: TBP>>=
   procedure :: set_blha_defaults => pcm_set_blha_defaults
 <<PCM base: procedures>>=
   subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list)
     class(pcm_t), intent(inout) :: pcm
     type(var_list_t), intent(in) :: var_list
     logical, intent(in) :: polarized_beams
     logical :: muon_yukawa_off
     real(default) :: top_yukawa
     type(string_t) :: ew_scheme
     muon_yukawa_off = &
          var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa"))
     top_yukawa = &
          var_list%get_rval (var_str ("blha_top_yukawa"))
     ew_scheme = &
          var_list%get_sval (var_str ("$blha_ew_scheme"))
     if (ew_scheme == "")  ew_scheme = "Gmu"
     call pcm%blha_defaults%init &
          (polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme)
   end subroutine pcm_set_blha_defaults
 
 @ %def pcm_set_blha_defaults
 @ Read the method settings from the variable list and store them in the BLHA
 master.  The details depend on the [[pcm]] concrete type.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_set_blha_methods), deferred :: set_blha_methods
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_set_blha_methods (pcm, blha_master, var_list)
        import
        class(pcm_t), intent(inout) :: pcm
        type(blha_master_t), intent(inout) :: blha_master
        type(var_list_t), intent(in) :: var_list
      end subroutine pcm_set_blha_methods
   end interface
 
 @ %def pcm_set_blha_methods
 @ Produce the LO and NLO flavor-state tables (as far as available), as
 appropriate for BLHA configuration.  We may inspect either the PCM itself or
 the array of process cores.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), dimension(:), intent(in) :: core_entry
        integer, dimension(:,:), allocatable, intent(out) :: flv_born
        integer, dimension(:,:), allocatable, intent(out) :: flv_real
      end subroutine pcm_get_blha_flv_states
   end interface
 
 @ %def pcm_get_blha_flv_states
 @
 Allocate the right number of process components.  The number is also stored in
 the process meta.  Initially, all components are active but none are
 selected.
 <<PCM base: pcm: TBP>>=
   procedure :: allocate_components => pcm_allocate_components
 <<PCM base: procedures>>=
   subroutine pcm_allocate_components (pcm, comp, meta)
     class(pcm_t), intent(inout) :: pcm
     type(process_component_t), dimension(:), allocatable, intent(out) :: comp
     type(process_metadata_t), intent(in) :: meta
     pcm%n_components = meta%n_components
     allocate (comp (pcm%n_components))
     allocate (pcm%component_selected (pcm%n_components), source = .false.)
     allocate (pcm%component_active (pcm%n_components), source = .true.)
   end subroutine pcm_allocate_components
 
 @ %def pcm_allocate_components
 @ Each process component belongs to a category/type, which we identify by a
 universal integer constant.  The categories can be taken from the process
 definition.  For easy lookup, we store the categories in an array.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_categorize_components), deferred :: categorize_components
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_categorize_components (pcm, config)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_config_data_t), intent(in) :: config
      end subroutine pcm_categorize_components
   end interface
 
 @ %def pcm_categorize_components
 @
 Allocate the right number and type(s) of process-core
 objects, i.e., the interface object between the process and matrix-element
 code.
 
 Within the [[pcm]] block, also associate cores with components and store
 relevant configuration data, including the [[i_core]] lookup table.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_allocate_cores), deferred :: allocate_cores
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_allocate_cores (pcm, config, core_entry)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_config_data_t), intent(in) :: config
        type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
      end subroutine pcm_allocate_cores
   end interface
 
 @ %def pcm_allocate_cores
 @ Generate and interface external code for a single core, if this is
 required.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_prepare_any_external_code), deferred :: &
        prepare_any_external_code
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_prepare_any_external_code &
           (pcm, core_entry, i_core, libname, model, var_list)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), intent(inout) :: core_entry
        integer, intent(in) :: i_core
        type(string_t), intent(in) :: libname
        type(model_data_t), intent(in), target :: model
        type(var_list_t), intent(in) :: var_list
      end subroutine pcm_prepare_any_external_code
   end interface
 
 @ %def pcm_prepare_any_external_code
 @ Prepare the BLHA configuration for a core object that requires it.  This
 does not affect the core object, which may not yet be allocated.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_setup_blha), deferred :: setup_blha
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_setup_blha (pcm, core_entry)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), intent(inout) :: core_entry
      end subroutine pcm_setup_blha
   end interface
 
 @ %def pcm_setup_blha
 @ Configure the BLHA interface for a core object that requires it.  This is
 separate from the previous method, assuming that the [[pcm]] has to allocate
 the actual cores and acquire some data in-between.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_prepare_blha_core (pcm, core_entry, model)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), intent(inout) :: core_entry
        class(model_data_t), intent(in), target :: model
      end subroutine pcm_prepare_blha_core
   end interface
 
 @ %def pcm_prepare_blha_core
 @ Allocate and configure the MCI (multi-channel integrator) records and their
 relation to process components, appropriate for the algorithm implemented by
 [[pcm]].
 
 Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a
 factory method for allocating the [[mci_t]] object with a specific concrete
 type.  The call may depend on the concrete [[pcm]] type.
 <<PCM base: public>>=
   public :: dispatch_mci_proc
 <<PCM base: interfaces>>=
   abstract interface
      subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo)
        import
        class(mci_t), allocatable, intent(out) :: mci
        type(var_list_t), intent(in) :: var_list
        type(string_t), intent(in) :: process_id
        logical, intent(in), optional :: is_nlo
      end subroutine dispatch_mci_proc
   end interface
 
 @ %def dispatch_mci_proc
 <<PCM base: pcm: TBP>>=
   procedure(pcm_setup_mci), deferred :: setup_mci
   procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_setup_mci (pcm, mci_entry)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_mci_entry_t), &
             dimension(:), allocatable, intent(out) :: mci_entry
      end subroutine pcm_setup_mci
   end interface
 
   abstract interface
      subroutine pcm_call_dispatch_mci (pcm, &
           dispatch_mci, var_list, process_id, mci_template)
        import
        class(pcm_t), intent(inout) :: pcm
        procedure(dispatch_mci_proc) :: dispatch_mci
        type(var_list_t), intent(in) :: var_list
        type(string_t), intent(in) :: process_id
        class(mci_t), intent(out), allocatable :: mci_template
      end subroutine pcm_call_dispatch_mci
   end interface
 
 @ %def pcm_setup_mci
 @ %def pcm_call_dispatch_mci
 @ Proceed with PCM configuration based on the core and component
 configuration data.  Base version is empty.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_complete_setup), deferred :: complete_setup
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_complete_setup (pcm, core_entry, component, model)
        import
        class(pcm_t), intent(inout) :: pcm
        type(core_entry_t), dimension(:), intent(in) :: core_entry
        type(process_component_t), dimension(:), intent(inout) :: component
        type(model_t), intent(in), target :: model
      end subroutine pcm_complete_setup
   end interface
 
 @ %def pcm_complete_setup
 @
 \subsubsection{Retrieve information}
 Return the core index that belongs to a particular component.
 <<PCM base: pcm: TBP>>=
   procedure :: get_i_core => pcm_get_i_core
 <<PCM base: procedures>>=
   function pcm_get_i_core (pcm, i_component) result (i_core)
     class(pcm_t), intent(in) :: pcm
     integer, intent(in) :: i_component
     integer :: i_core
     if (allocated (pcm%i_core)) then
        i_core = pcm%i_core(i_component)
     else
        i_core = 0
     end if
   end function pcm_get_i_core
 
 @ %def pcm_get_i_core
 @
 \subsubsection{Phase-space configuration}
 Allocate and initialize the right number and type(s) of phase-space
 configuration entries.  The [[i_phs_config]] lookup table must be set
 accordingly.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_init_phs_config), deferred :: init_phs_config
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_init_phs_config &
           (pcm, phs_entry, meta, env, phs_par, mapping_defs)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_phs_config_t), &
             dimension(:), allocatable, intent(out) :: phs_entry
        type(process_metadata_t), intent(in) :: meta
        type(process_environment_t), intent(in) :: env
        type(mapping_defaults_t), intent(in) :: mapping_defs
        type(phs_parameters_t), intent(in) :: phs_par
      end subroutine pcm_init_phs_config
   end interface
 
 @ %def pcm_init_phs_config
 @
 Initialize a single component.  We require all process-configuration blocks,
 and specific templates for the phase-space and integrator configuration.
 
 We also provide the current component index [[i]] and the [[active]] flag.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_init_component), deferred :: init_component
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_init_component &
           (pcm, component, i, active, phs_config, env, meta, config)
        import
        class(pcm_t), intent(in) :: pcm
        type(process_component_t), intent(out) :: component
        integer, intent(in) :: i
        logical, intent(in) :: active
        class(phs_config_t), allocatable, intent(in) :: phs_config
        type(process_environment_t), intent(in) :: env
        type(process_metadata_t), intent(in) :: meta
        type(process_config_data_t), intent(in) :: config
      end subroutine pcm_init_component
   end interface
 
 @ %def pcm_init_component
 @
 Record components in the process [[meta]] data if they have turned
 out to be inactive.
 <<PCM base: pcm: TBP>>=
   procedure :: record_inactive_components => pcm_record_inactive_components
 <<PCM base: procedures>>=
   subroutine pcm_record_inactive_components (pcm, component, meta)
     class(pcm_t), intent(inout) :: pcm
     type(process_component_t), dimension(:), intent(in) :: component
     type(process_metadata_t), intent(inout) :: meta
     integer :: i
     pcm%component_active = component%active
     do i = 1, pcm%n_components
        if (.not. component(i)%active)  call meta%deactivate_component (i)
     end do
   end subroutine pcm_record_inactive_components
 
 @ %def pcm_record_inactive_components
 @
 \subsection{Manager workspace}
 This object deals with the actual (squared) matrix element values.  It
 holds any central data that are generated and/or used when calculating
 a particular phase-space point.
 
 Since phase-space points are associated with an integrator, we expect the
 instances of this type to correspond to MCI instances.
 <<PCM base: public>>=
   public :: pcm_workspace_t
 <<PCM base: types>>=
   type, abstract :: pcm_workspace_t
 !     class(pcm_t), pointer :: config => null ()
     logical :: bad_point = .false.
   contains
   <<PCM base: pcm instance: TBP>>
   end type pcm_workspace_t
 
 @ %def pcm_workspace_t
 @
 <<PCM base: pcm instance: TBP>>=
   procedure(pcm_work_final), deferred :: final
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_work_final (pcm_work)
         import
         class(pcm_workspace_t), intent(inout) :: pcm_work
      end subroutine pcm_work_final
   end interface
 
 @ %def pcm_work_final
 @
 <<PCM base: pcm instance: TBP>>=
   procedure(pcm_work_is_nlo), deferred :: is_nlo
 <<PCM base: interfaces>>=
   abstract interface
      function pcm_work_is_nlo (pcm_work) result (is_nlo)
         import
         logical :: is_nlo
         class(pcm_workspace_t), intent(inout) :: pcm_work
       end function pcm_work_is_nlo
   end interface
 
 @ %def pcm_work_is_nlo
 @
 <<XXX PCM base: pcm instance: TBP>>=
   procedure :: link_config => pcm_work_link_config
 <<XXX PCM base: procedures>>=
   subroutine pcm_work_link_config (pcm_work, config)
      class(pcm_workspace_t), intent(inout) :: pcm_work
      class(pcm_t), intent(in), target :: config
      pcm_work%config => config
   end subroutine pcm_work_link_config
 
 @ %def pcm_work_link_config
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: is_valid => pcm_work_is_valid
 <<PCM base: procedures>>=
   function pcm_work_is_valid (pcm_work) result (valid)
     logical :: valid
     class(pcm_workspace_t), intent(in) :: pcm_work
     valid = .not. pcm_work%bad_point
   end function pcm_work_is_valid
 
 @ %def pcm_work_is_valid
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: set_bad_point => pcm_work_set_bad_point
 <<PCM base: procedures>>=
   pure subroutine pcm_work_set_bad_point (pcm_work, bad_point)
     class(pcm_workspace_t), intent(inout) :: pcm_work
     logical, intent(in) :: bad_point
     pcm_work%bad_point = pcm_work%bad_point .or. bad_point
   end subroutine pcm_work_set_bad_point
 
 @ %def pcm_work_set_bad_point
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{The process object}
 <<[[process.f90]]>>=
 <<File header>>
 
 module process
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use constants
   use diagnostics
   use numeric_utils
   use lorentz
   use cputime
   use md5
   use rng_base
   use dispatch_rng, only: dispatch_rng_factory
   use dispatch_rng, only: update_rng_seed_in_var_list
   use os_interface
   use sm_qcd
   use integration_results
   use mci_base
   use flavors
   use model_data
   use models
   use physics_defs
   use process_libraries
   use process_constants
   use particles
   use variables
   use beam_structures
   use beams
   use interactions
   use pdg_arrays
   use expr_base
   use sf_base
   use sf_mappings
   use resonances, only: resonance_history_t, resonance_history_set_t
 
   use prc_test_core, only: test_t
   use prc_core_def, only: prc_core_def_t
   use prc_core, only: prc_core_t, helicity_selection_t
   use prc_external, only: prc_external_t
   use prc_recola, only: prc_recola_t
   use blha_olp_interfaces, only: prc_blha_t, blha_template_t
   use prc_threshold, only: prc_threshold_t
   use phs_fks, only: phs_fks_config_t
 
   use phs_base
   use mappings, only: mapping_defaults_t
   use phs_forests, only: phs_parameters_t
   use phs_wood, only: phs_wood_config_t
   use dispatch_phase_space, only: dispatch_phs
   use blha_config, only: blha_master_t
   use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
 
   use parton_states, only: connected_state_t
   use pcm_base
   use pcm
   use process_counter
   use process_config
   use process_mci
 
 <<Standard module head>>
 
 <<Process: public>>
 
 <<Process: public parameters>>
 
 <<Process: types>>
 
 <<Process: interfaces>>
 
 contains
 
 <<Process: procedures>>
 
 end module process
 @ %def process
 @
 \subsection{Process status}
 Store counter and status information in a process object.
 <<Process: types>>=
   type :: process_status_t
      private
   end type process_status_t
 
 @ %def process_status_t
 @
 \subsection{Process status}
 Store integration results in a process object.
 <<Process: types>>=
   type :: process_results_t
      private
   end type process_results_t
 
 @ %def process_results_t
 @
 \subsection{The process type}
 NOTE: The description below represents the intended structure after
 refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies.
 
 A [[process]] object is the internal representation of integration-run
 methods and data, as they are controlled by the user via a Sindarin
 script.  The process object provides access to matrix elements (the
 actual ``process'' definitions that the user has provided before), it
 defines the separation into individually integrable components, and it
 manages phase-space construction, the actual integration over phase
 space, and the accumulation of results.
 
 As a workspace for individual sampling calls, we introduce an
 associated [[process_instance]] object type elsewhere.  The
 [[process]] object contains data that either define the configuration
 or accumulate results from a complete integration pass.
 
 After successful phase-space integration, subsequent event generation
 is not actually represented by the [[process]] object.  However, any
 event generation refers to an existing [[process]] object which
 represents a specific integration pass, and it uses a fresh
 [[process_instance]] workspace for calculations.
 
 The process object consists of several subobjects with their specific
 purposes.  The corresponding types are defined below.  (Technically,
 the subobject type definitions have to come before the process type
 definition, but with NOWEB magic we reverse this order here.)
 
 The [[meta]] object describes the process globally.  All
 contents become fixed when the object is initialized.  Similarly, the
 [[env]] component captures the (Sindarin) environment at the point
 where the process object is initialized.
 
 The [[config]] object holds physical and technical configuration data
 that are collected and derived from the environment during process
 initialization, and which are common to all process components.
 
 The [[pcm]] object (process-component manager) is polymorphic.  This
 is an object which holds data which represent the process-object
 structure and breakdown, and it contains the methods that implement
 the algorithm of managing this structure, accumulating partial
 results, and finally collecting the pieces.  Depending on the generic
 process type, the contents of [[pcm]] do vary.  In particular, there
 is some base-type data content and a simple (default) extension which
 is designed for traditional \oMega\ matrix elements and tree-level
 integration, possibly with several sub-processes to sum over.  The
 second extension is designed for the FKS phase-space and subtraction
 algorithm for NLO QCD, which interfaces external one-loop providers.
 
 The [[component]] subobjects are, first of all, interfaces to the
 original process-component definitions that have been provided by the
 user, which the program has already taken to produce matrix-element
 code and interfaces.  The management of those components is deferred
 by [[pcm]], which contains the information that defines the role of
 each component.  In particular, in the default (LO) version, process
 components correspond to distinct particle combinations which have
 been included in the original process definition.  In the FKS-NLO
 version, the breakdown of a NLO process into Born, real, virtual,
 etc.\ components determines the setup.
 
 The [[phs_config]] subobjects hold data that allow and implement the
 construction of phase-space configurations.  The type
 [[process_phs_config_t]] is a wrapper type around the concrete
 polymorphic [[phs_config_t]] object type, which manages phase-space
 construction, including some bookkeeping required for setting up
 multi-channel integration.  In the LO case, we expect a separate entry
 for each independent sub-process.  For the FKS-NLO algorithm, we
 expect several entries: a default-type entry which implements the
 underlying Born phase space, and additional entries which enable
 the construction of various real-radiation and subtraction kinematics
 configurations.
 
 A [[core_entry]] is the interface to existing matrix-element and
 interaction code.  Depending on the process and its components, there
 may be various distinct matrix elements to compute.
 
 The [[mci_entry]] objects configure distinct MC input parameter sets
 and their associated (multi-channel) integrators.
 
 The [[rng_factory]] object is a single objects which constructs
 individual random-number generators for various tasks, in a uniform
 and well-defined way.
 
 The [[beam_config]] object describes the incoming particles, either the
 decay mother or the scattering beams.  It also contains the spectrum-
 and structure-function setup, which has to interact with the
 phase-space and integrator facilities.
 
 The [[term]] subobjects break down the process in its smallest parts
 which appear in the calculation.  For LO processes, the correspondence
 between terms and components is one-to-one.  The FKS-NLO algorithm
 requires not just separation of Born, real, and virtual components but
 also subtraction terms, and a decomposition of the real phase space
 into singular regions.  The general idea is that the integration
 results of distinct sets of terms are summed over to provide the
 results of individual components.  This is also controlled by the
 [[pcm]] subobject.
 
 The [[process_status]] object is a bookkeeping device that allows us
 to query the status of an ongoing calculation.
 
 The [[process_results]] object collects the integration results for
 external use, including integration history information.
 <<Process: public>>=
   public :: process_t
 <<Process: types>>=
   type :: process_t
      private
      type(process_metadata_t) :: &
           meta
      type(process_environment_t) :: &
           env
      type(process_config_data_t) :: &
           config
      class(pcm_t), allocatable :: &
           pcm
      type(process_component_t), dimension(:), allocatable :: &
           component
      type(process_phs_config_t), dimension(:), allocatable :: &
           phs_entry
      type(core_entry_t), dimension(:), allocatable :: &
           core_entry
      type(process_mci_entry_t), dimension(:), allocatable :: &
           mci_entry
      class(rng_factory_t), allocatable :: &
           rng_factory
      type(process_beam_config_t) :: &
           beam_config
      type(process_term_t), dimension(:), allocatable :: &
           term
      type(process_status_t) :: &
           status
      type(process_results_t) :: &
           result
    contains
    <<Process: process: TBP>>
   end type process_t
 
 @ %def process_t
 @
 \subsection{Process pointer}
 Wrapper type for storing pointers to process objects in arrays.
 <<Process: public>>=
   public :: process_ptr_t
 <<Process: types>>=
   type :: process_ptr_t
      type(process_t), pointer :: p => null ()
   end type process_ptr_t
 
 @ %def process_ptr_t
 @
 \subsection{Output}
 This procedure is an important debugging and inspection tool; it is
 not used during normal operation.  The process object is written
 to a file (identified by unit, which may also be standard output).
 Optional flags determine whether we show everything or just the
 interesting parts.
 
 The shorthand as a traditional TBP.
 <<Process: process: TBP>>=
   procedure :: write => process_write
 <<Process: procedures>>=
   subroutine process_write (process, screen, unit, &
        show_os_data, show_var_list, show_rng, show_expressions, pacify)
     class(process_t), intent(in) :: process
     logical, intent(in) :: screen
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_os_data
     logical, intent(in), optional :: show_var_list
     logical, intent(in), optional :: show_rng
     logical, intent(in), optional :: show_expressions
     logical, intent(in), optional :: pacify
     integer :: u, iostat
     character(0) :: iomsg
     integer, dimension(:), allocatable :: v_list
     u = given_output_unit (unit)
     allocate (v_list (0))
     call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
     call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
     call set_flag (v_list, F_SHOW_RNG, show_rng)
     call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions)
     call set_flag (v_list, F_PACIFY, pacify)
     if (screen) then
        call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
     else
        call process%write_formatted (u, "DT", v_list, iostat, iomsg)
     end if
   end subroutine process_write
 
 @ %def process_write
 @ Standard DTIO procedure with binding.
 
 For the particular application, the screen format is triggered by the
 [[LISTDIRECTED]] option for the [[iotype]] format editor string.  The
 other options activate when the particular parameter value is found in
 [[v_list]].
 
 NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0.
 
 TODO wk 2018: The default could be to show everything, and we should have separate
 switches for all major parts.  Currently, there are only a few.
 <<Process: process: TBP>>=
   ! generic :: write (formatted) => write_formatted
   procedure :: write_formatted => process_write_formatted
 <<Process: procedures>>=
   subroutine process_write_formatted (dtv, unit, iotype, v_list, iostat, iomsg)
     class(process_t), intent(in) :: dtv
     integer, intent(in) :: unit
     character(*), intent(in) :: iotype
     integer, dimension(:), intent(in) :: v_list
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     integer :: u
     logical :: screen
     logical :: var_list
     logical :: rng_factory
     logical :: expressions
     logical :: counters
     logical :: os_data
     logical :: model
     logical :: pacify
     integer :: i
     u = unit
     select case (iotype)
     case ("LISTDIRECTED")
        screen = .true.
     case default
        screen = .false.
     end select
     var_list = flagged (v_list, F_SHOW_VAR_LIST)
     rng_factory = flagged (v_list, F_SHOW_RNG, .true.)
     expressions = flagged (v_list, F_SHOW_EXPRESSIONS)
     counters = .true.
     os_data = flagged (v_list, F_SHOW_OS_DATA)
     model = .false.
     pacify = flagged (v_list, F_PACIFY)
     associate (process => dtv)
       if (screen) then
          write (msg_buffer, "(A)")  repeat ("-", 72)
          call msg_message ()
       else
          call write_separator (u, 2)
       end if
       call process%meta%write (u, screen)
       if (var_list) then
          call process%env%write (u, show_var_list=var_list, &
               show_model=.false., show_lib=.false., &
               show_os_data=os_data)
       else if (.not. screen) then
          write (u, "(1x,A)")  "Variable list: [not shown]"
       end if
       if (process%meta%type == PRC_UNKNOWN) then
          call write_separator (u, 2)
          return
       else if (screen) then
          return
       end if
       call write_separator (u)
       call process%config%write (u, counters, model, expressions)
       if (rng_factory) then
          if (allocated (process%rng_factory)) then
             call write_separator (u)
             call process%rng_factory%write (u)
          end if
       end if
       call write_separator (u, 2)
       if (allocated (process%component)) then
          write (u, "(1x,A)") "Process component configuration:"
          do i = 1, size (process%component)
             call write_separator (u)
             call process%component(i)%write (u)
          end do
       else
          write (u, "(1x,A)") "Process component configuration: [undefined]"
       end if
       call write_separator (u, 2)
       if (allocated (process%term)) then
          write (u, "(1x,A)") "Process term configuration:"
          do i = 1, size (process%term)
             call write_separator (u)
             call process%term(i)%write (u)
          end do
       else
          write (u, "(1x,A)") "Process term configuration: [undefined]"
       end if
       call write_separator (u, 2)
       call process%beam_config%write (u)
       call write_separator (u, 2)
       if (allocated (process%mci_entry)) then
          write (u, "(1x,A)") "Multi-channel integrator configurations:"
          do i = 1, size (process%mci_entry)
             call write_separator (u)
             write (u, "(1x,A,I0,A)")  "MCI #", i, ":"
             call process%mci_entry(i)%write (u, pacify)
          end do
       end if
       call write_separator (u, 2)
     end associate
     iostat = 0
     iomsg = ""
   end subroutine process_write_formatted
 
 @ %def process_write_formatted
 @
 <<Process: process: TBP>>=
   procedure :: write_meta => process_write_meta
 <<Process: procedures>>=
   subroutine process_write_meta (process, unit, testflag)
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u, i
     u = given_output_unit (unit)
     select case (process%meta%type)
     case (PRC_UNKNOWN)
        write (u, "(1x,A)") "Process instance [undefined]"
        return
     case (PRC_DECAY)
        write (u, "(1x,A)", advance="no") "Process instance [decay]:"
     case (PRC_SCATTERING)
        write (u, "(1x,A)", advance="no") "Process instance [scattering]:"
     case default
        call msg_bug ("process_instance_write: undefined process type")
     end select
     write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'"
     write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'"
     if (allocated (process%meta%component_id)) then
        write (u, "(3x,A)")  "Process components:"
        do i = 1, size (process%meta%component_id)
           if (process%pcm%component_selected(i)) then
              write (u, "(3x,'*')", advance="no")
           else
              write (u, "(4x)", advance="no")
           end if
           write (u, "(1x,I0,9A)")  i, ": '", &
                char (process%meta%component_id (i)), "':   ", &
                char (process%meta%component_description (i))
        end do
     end if
   end subroutine process_write_meta
 
 @ %def process_write_meta
 @ Screen output.  Write a short account of the process configuration
 and the current results.  The verbose version lists the components,
 the short version just the results.
 <<Process: process: TBP>>=
   procedure :: show => process_show
 <<Process: procedures>>=
   subroutine process_show (object, unit, verbose)
     class(process_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     logical :: verb
     real(default) :: err_percent
     u = given_output_unit (unit)
     verb = .true.;  if (present (verbose)) verb = verbose
     if (verb) then
        call object%meta%show (u, object%config%model%get_name ())
        select case (object%meta%type)
        case (PRC_DECAY)
           write (u, "(2x,A)", advance="no")  "Computed width ="
        case (PRC_SCATTERING)
           write (u, "(2x,A)", advance="no")  "Computed cross section ="
        case default;  return
        end select
     else
        if (object%meta%run_id /= "") then
           write (u, "('Run',1x,A,':',1x)", advance="no") &
                char (object%meta%run_id)
        end if
        write (u, "(A)", advance="no") char (object%meta%id)
        select case (object%meta%num_id)
        case (0)
           write (u, "(':')")
        case default
           write (u, "(1x,'(',I0,')',':')") object%meta%num_id
        end select
        write (u, "(2x)", advance="no")
     end if
     if (object%has_integral_tot ()) then
        write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") &
             object%get_integral_tot (), object%get_error_tot ()
        select case (object%meta%type)
        case (PRC_DECAY)
           write (u, "(1x,A)", advance="no")  "GeV"
        case (PRC_SCATTERING)
           write (u, "(1x,A)", advance="no")  "fb "
        case default
           write (u, "(1x,A)", advance="no")  "   "
        end select
        if (object%get_integral_tot () /= 0) then
           err_percent = abs (100 &
                * object%get_error_tot () / object%get_integral_tot ())
        else
           err_percent = 0
        end if
        if (err_percent == 0) then
           write (u, "(1x,'(',F4.0,4x,'%)')")  err_percent
        else if (err_percent < 0.1) then
           write (u, "(1x,'(',F7.3,1x,'%)')")  err_percent
        else if (err_percent < 1) then
           write (u, "(1x,'(',F6.2,2x,'%)')")  err_percent
        else if (err_percent < 10) then
           write (u, "(1x,'(',F5.1,3x,'%)')")  err_percent
        else
           write (u, "(1x,'(',F4.0,4x,'%)')")  err_percent
        end if
     else
        write (u, "(A)")  "[integral undefined]"
     end if
   end subroutine process_show
 
 @ %def process_show
 @ Finalizer.  Explicitly iterate over all subobjects that may contain
 allocated pointers.
 
 TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not
 called.  The reason is that this deletes model data local to the process,
 but these could be referenced by pointers (flavor objects) from some
 persistent event record.  Obviously, such side effects should be avoided, but
 this requires refactoring the event-handling procedures.
 <<Process: process: TBP>>=
   procedure :: final => process_final
 <<Process: procedures>>=
   subroutine process_final (process)
     class(process_t), intent(inout) :: process
     integer :: i
     ! call process%meta%final ()
     call process%env%final ()
     ! call process%config%final ()
     if (allocated (process%component)) then
        do i = 1, size (process%component)
           call process%component(i)%final ()
        end do
     end if
     if (allocated (process%term)) then
        do i = 1, size (process%term)
           call process%term(i)%final ()
        end do
     end if
     call process%beam_config%final ()
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           call process%mci_entry(i)%final ()
        end do
     end if
     if (allocated (process%pcm)) then
        call process%pcm%final ()
        deallocate (process%pcm)
     end if
   end subroutine process_final
 
 @ %def process_final
 @
 \subsubsection{Process setup}
 Initialize a process.  We need a process library [[lib]] and the process
 identifier [[proc_id]] (string).  We will fetch the current run ID from the
 variable list [[var_list]].
 
 We collect all important data from the environment and store them in the
 appropriate places.  OS data, model, and variable list are copied
 into [[env]] (true snapshot), also the process library (pointer only).
 
 The [[meta]] subobject is initialized with process ID and attributes taken
 from the process library.
 
 We initialize the [[config]] subobject with all data that are relevant for
 this run, using the settings from [[env]].  These data determine the MD5 sum
 for this run, which allows us to identify the setup and possibly skips in a
 later re-run.
 
 We also allocate and initialize the embedded RNG factory.  We take the seed
 from the [[var_list]], and we should return the [[var_list]] to the caller
 with a new seed.
 
 Finally, we allocate the process component manager [[pcm]], which implements
 the chosen algorithm for process integration.  The first task of the manager
 is to allocate the component array and to determine the component categories
 (e.g., Born/Virtual etc.).
 
 TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we
 eventually want to eliminate dependencies on concrete [[pcm_t]] extensions.
 <<Process: process: TBP>>=
   procedure :: init => process_init
 <<Process: procedures>>=
   subroutine process_init &
        (process, proc_id, lib, os_data, model, var_list, beam_structure)
     class(process_t), intent(out) :: process
     type(string_t), intent(in) :: proc_id
     type(process_library_t), intent(in), target :: lib
     type(os_data_t), intent(in) :: os_data
     class(model_t), intent(in), target :: model
     type(var_list_t), intent(inout), target, optional :: var_list
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer :: next_rng_seed
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_init")
     associate &
          (meta => process%meta, env => process%env, config => process%config)
       call env%init &
            (model, lib, os_data, var_list, beam_structure)
       call meta%init &
            (proc_id, lib, env%get_var_list_ptr ())
       call config%init &
            (meta, env)
       call dispatch_rng_factory &
            (process%rng_factory, env%get_var_list_ptr (), next_rng_seed)
       call update_rng_seed_in_var_list (var_list, next_rng_seed)
       call dispatch_pcm &
            (process%pcm, config%process_def%is_nlo ())
       associate (pcm => process%pcm)
         call pcm%init (env, meta)
         call pcm%allocate_components (process%component, meta)
         call pcm%categorize_components (config)
       end associate
     end associate
   end subroutine process_init
 
 @ %def process_init
 @
 \subsection{Process component manager}
 The [[pcm]] (read: process-component manager) takes the responsibility of
 steering the actual algorithm of configuration and integration.  Depending on
 the concrete type, different algorithms can be implemented.
 
 The first version of this supports just two implementations: leading-order
 (tree-level) integration and event generation, and NLO (QCD/FKS subtraction).
 We thus can start with a single logical for steering the dispatcher.
 
 TODO wk 2018: Eventually, we may eliminate all references to the extensions of
 [[pcm_t]] from this module and therefore move this outside the module as well.
 <<Process: procedures>>=
   subroutine dispatch_pcm (pcm, is_nlo)
     class(pcm_t), allocatable, intent(out) :: pcm
     logical, intent(in) :: is_nlo
     if (.not. is_nlo) then
        allocate (pcm_default_t :: pcm)
     else
        allocate (pcm_nlo_t :: pcm)
     end if
   end subroutine dispatch_pcm
 
 @ %def dispatch_pcm
 @ This step is performed after phase-space and core objects are done: collect
 all missing information and prepare the process component manager for the
 appropriate integration algorithm.
 <<Process: process: TBP>>=
   procedure :: complete_pcm_setup => process_complete_pcm_setup
 <<Process: procedures>>=
   subroutine process_complete_pcm_setup (process)
     class(process_t), intent(inout) :: process
     call process%pcm%complete_setup &
          (process%core_entry, process%component, process%env%get_model_ptr ())
   end subroutine process_complete_pcm_setup
 
 @ %def process_complete_pcm_setup
 @
 \subsection{Core management}
 Allocate cores (interface objects to matrix-element code).
 
 The [[dispatch_core]] procedure is taken as an argument, so we do not depend on
 the implementation, and thus on the specific core types.
 
 The [[helicity_selection]] object collects data that the matrix-element
 code needs for configuring the appropriate behavior.
 
 After the cores have been allocated, and assuming the phs initial
 configuration has been done before, we proceed with computing the [[pcm]]
 internal data.
 <<Process: process: TBP>>=
   procedure :: setup_cores => process_setup_cores
 <<Process: procedures>>=
   subroutine process_setup_cores (process, dispatch_core, &
        helicity_selection, use_color_factors, has_beam_pol)
     class(process_t), intent(inout) :: process
     procedure(dispatch_core_proc) :: dispatch_core
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     logical, intent(in), optional :: use_color_factors
     logical, intent(in), optional :: has_beam_pol
     integer :: i
     associate (pcm => process%pcm)
       call pcm%allocate_cores (process%config, process%core_entry)
       do i = 1, size (process%core_entry)
          call dispatch_core (process%core_entry(i)%core, &
               process%core_entry(i)%core_def, &
               process%config%model, &
               helicity_selection, &
               process%config%qcd, &
               use_color_factors, &
               has_beam_pol)
          call process%core_entry(i)%configure &
               (process%env%get_lib_ptr (), process%meta%id)
          if (process%core_entry(i)%core%uses_blha ()) then
             call pcm%setup_blha (process%core_entry(i))
          end if
       end do
     end associate
   end subroutine process_setup_cores
 
 @ %def process_setup_cores
 <<Process: interfaces>>=
   abstract interface
      subroutine dispatch_core_proc (core, core_def, model, &
           helicity_selection, qcd, use_color_factors, has_beam_pol)
        import
        class(prc_core_t), allocatable, intent(inout) :: core
        class(prc_core_def_t), intent(in) :: core_def
        class(model_data_t), intent(in), target, optional :: model
        type(helicity_selection_t), intent(in), optional :: helicity_selection
        type(qcd_t), intent(in), optional :: qcd
        logical, intent(in), optional :: use_color_factors
        logical, intent(in), optional :: has_beam_pol
      end subroutine dispatch_core_proc
   end interface
 
 @ %def dispatch_core_proc
 @ Use the [[pcm]] to initialize the BLHA interface for each core which
 requires it.
 <<Process: process: TBP>>=
   procedure :: prepare_blha_cores => process_prepare_blha_cores
 <<Process: procedures>>=
   subroutine process_prepare_blha_cores (process)
     class(process_t), intent(inout), target :: process
     integer :: i
     associate (pcm => process%pcm)
       do i = 1, size (process%core_entry)
          associate (core_entry => process%core_entry(i))
            if (core_entry%core%uses_blha ()) then
               pcm%uses_blha = .true.
               call pcm%prepare_blha_core (core_entry, process%config%model)
            end if
          end associate
       end do
     end associate
   end subroutine process_prepare_blha_cores
 
 @ %def process_prepare_blha_cores
 @ Create the BLHA interface data, using PCM for specific data, and write the
 BLHA contract file(s).
 
 We take various configuration data and copy them to the [[blha_master]]
 record, which then creates and writes the contracts.
 
 For assigning the QCD/EW coupling powers, we inspect the first process
 component only.  The other parameters are taken as-is from the process
 environment variables.
 <<Process: process: TBP>>=
   procedure :: create_blha_interface => process_create_blha_interface
 <<Process: procedures>>=
   subroutine process_create_blha_interface (process)
     class(process_t), intent(inout) :: process
     integer :: alpha_power, alphas_power
     integer :: openloops_phs_tolerance, openloops_stability_log
     logical :: use_cms
     type(string_t) :: ew_scheme, correction_type
     type(string_t) :: openloops_extra_cmd
     type(blha_master_t) :: blha_master
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     if (process%pcm%uses_blha) then
        call collect_configuration_parameters (process%get_var_list_ptr ())
        call process%component(1)%config%get_coupling_powers &
             (alpha_power, alphas_power)
        associate (pcm => process%pcm)
          call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ())
          call blha_master%set_ew_scheme (ew_scheme)
          call blha_master%allocate_config_files ()
          call blha_master%set_correction_type (correction_type)
          call blha_master%setup_additional_features ( &
               openloops_phs_tolerance, &
               use_cms, &
               openloops_stability_log, &
               extra_cmd = openloops_extra_cmd, &
               beam_structure = process%env%get_beam_structure ())
          call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real)
          call blha_master%set_photon_characteristics (flv_born, process%config%n_in)
          call blha_master%generate (process%meta%id, &
               process%config%model, process%config%n_in, &
               alpha_power, alphas_power, &
               flv_born, flv_real)
          call blha_master%write_olp (process%meta%id)
        end associate
     end if
   contains
     subroutine collect_configuration_parameters (var_list)
       type(var_list_t), intent(in) :: var_list
       openloops_phs_tolerance = &
            var_list%get_ival (var_str ("openloops_phs_tolerance"))
       openloops_stability_log = &
            var_list%get_ival (var_str ("openloops_stability_log"))
       use_cms = &
            var_list%get_lval (var_str ("?openloops_use_cms"))
       ew_scheme = &
            var_list%get_sval (var_str ("$blha_ew_scheme"))
       correction_type = &
            var_list%get_sval (var_str ("$nlo_correction_type"))
       openloops_extra_cmd = &
            var_list%get_sval (var_str ("$openloops_extra_cmd"))
     end subroutine collect_configuration_parameters
   end subroutine process_create_blha_interface
 
 @ %def process_create_blha_interface
 @ Initialize the process components, one by one.  We require templates for the
 [[mci]] (integrator) and [[phs_config]] (phase-space) configuration data.
 
 The [[active]] flag is set if the component has an associated matrix
 element, so we can compute it.  The case of no core is a unit-test case.
 
 The specifics depend on the algorithm and are delegated to the [[pcm]]
 process-component manager.
 
 The optional [[phs_config]] overrides a pre-generated config array (for unit
 test).
 <<Process: process: TBP>>=
   procedure :: init_components => process_init_components
 <<Process: procedures>>=
   subroutine process_init_components (process, phs_config)
     class(process_t), intent(inout), target :: process
     class(phs_config_t), allocatable, intent(in), optional :: phs_config
     integer :: i, i_core
     class(prc_core_t), pointer :: core
     logical :: active
     associate (pcm => process%pcm)
       do i = 1, pcm%n_components
          i_core = pcm%get_i_core(i)
          if (i_core > 0) then
             core => process%get_core_ptr (i_core)
             active = core%has_matrix_element ()
          else
             active = .true.
          end if
          select type (pcm => process%pcm)
          type is (pcm_nlo_t)
             if (pcm%use_real_partition .and. .not. pcm%use_real_singular) then
                if (pcm%component_type(i) == COMP_REAL_SING) then
                   active = .false.
                end if
             end if
          end select
          if (present (phs_config)) then
             call pcm%init_component (process%component(i), &
               i, &
               active, &
               phs_config, &
               process%env, process%meta, process%config)
          else
             call pcm%init_component (process%component(i), &
               i, &
               active, &
               process%phs_entry(pcm%i_phs_config(i))%phs_config, &
               process%env, process%meta, process%config)
          end if
       end do
     end associate
   end subroutine process_init_components
 
 @ %def process_init_components
 @ If process components have turned out to be inactive, this has to be
 recorded in the [[meta]] block.  Delegate to the [[pcm]].
 <<Process: process: TBP>>=
   procedure :: record_inactive_components => process_record_inactive_components
 <<Process: procedures>>=
   subroutine process_record_inactive_components (process)
     class(process_t), intent(inout) :: process
     associate (pcm => process%pcm)
       call pcm%record_inactive_components (process%component, process%meta)
     end associate
   end subroutine process_record_inactive_components
 
 @ %def process_record_inactive_components
 @ Determine the process terms for each process component.
 <<Process: process: TBP>>=
   procedure :: setup_terms => process_setup_terms
 <<Process: procedures>>=
   subroutine process_setup_terms (process, with_beams)
     class(process_t), intent(inout), target :: process
     logical, intent(in), optional :: with_beams
     class(model_data_t), pointer :: model
     integer :: i, j, k, i_term
     integer, dimension(:), allocatable :: n_entry
     integer :: n_components, n_tot
     integer :: i_sub
     type(string_t) :: subtraction_method
     class(prc_core_t), pointer :: core => null ()
     logical :: setup_subtraction_component, singular_real
     logical :: requires_spin_correlations
     integer :: nlo_type_to_fetch, n_emitters
     i_sub = 0
     model => process%config%model
     n_components = process%meta%n_components
     allocate (n_entry (n_components), source = 0)
     do i = 1, n_components
        associate (component => process%component(i))
          if (component%active) then
             n_entry(i) = 1
             if (component%get_nlo_type () == NLO_REAL) then
                select type (pcm => process%pcm)
                type is (pcm_nlo_t)
                   if (component%component_type /= COMP_REAL_FIN) &
                        n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs ()
                end select
             end if
          end if
        end associate
     end do
     n_tot = sum (n_entry)
     allocate (process%term (n_tot))
     k = 0
     if (process%is_nlo_calculation ()) then
        i_sub = process%component(1)%config%get_associated_subtraction ()
        subtraction_method = process%component(i_sub)%config%get_me_method ()
        if (debug_on) call msg_debug2 &
             (D_PROCESS_INTEGRATION, "process_setup_terms: ", subtraction_method)
     end if
 
     do i = 1, n_components
        associate (component => process%component(i))
          if (.not. component%active)  cycle
            allocate (component%i_term (n_entry(i)))
            do j = 1, n_entry(i)
               singular_real = component%get_nlo_type () == NLO_REAL &
                    .and. component%component_type /= COMP_REAL_FIN
               setup_subtraction_component = singular_real .and. j == n_entry(i)
               i_term = k + j
               component%i_term(j) = i_term
               if (singular_real) then
                  process%term(i_term)%i_sub = k + n_entry(i)
               else
                  process%term(i_term)%i_sub = 0
               end if
               if (setup_subtraction_component) then
                  select type (pcm => process%pcm)
                  class is (pcm_nlo_t)
                     process%term(i_term)%i_core = pcm%i_core(pcm%i_sub)
                  end select
               else
                  process%term(i_term)%i_core = process%pcm%get_i_core(i)
               end if
 
               if (process%term(i_term)%i_core == 0) then
                  call msg_bug ("Process '" // char (process%get_id ()) &
                       // "': core not found!")
               end if
               core => process%get_core_term (i_term)
               if (i_sub > 0) then
                  select type (pcm => process%pcm)
                  type is (pcm_nlo_t)
                     requires_spin_correlations = &
                          pcm%region_data%requires_spin_correlations ()
                     n_emitters = pcm%region_data%get_n_emitters_sc ()
                  class default
                     requires_spin_correlations = .false.
                     n_emitters = 0
                  end select
                  if (requires_spin_correlations) then
                     call process%term(i_term)%init ( &
                          i_term, i, j, core, model, &
                          nlo_type = component%config%get_nlo_type (), &
                          use_beam_pol = with_beams, &
                          subtraction_method = subtraction_method, &
                          has_pdfs = process%pcm%has_pdfs, &
                          n_emitters = n_emitters)
                  else
                     call process%term(i_term)%init ( &
                          i_term, i, j, core, model, &
                          nlo_type = component%config%get_nlo_type (), &
                          use_beam_pol = with_beams, &
                          subtraction_method = subtraction_method, &
                          has_pdfs = process%pcm%has_pdfs)
                  end if
               else
                  call process%term(i_term)%init ( &
                       i_term, i, j, core, model, &
                       nlo_type = component%config%get_nlo_type (), &
                       use_beam_pol = with_beams, &
                       has_pdfs = process%pcm%has_pdfs)
               end if
            end do
        end associate
        k = k + n_entry(i)
     end do
     process%config%n_terms = n_tot
   end subroutine process_setup_terms
 
 @ %def process_setup_terms
 @ Initialize the beam setup.  This is the trivial version where the
 incoming state of the matrix element coincides with the initial state
 of the process.  For a scattering process, we need the c.m. energy,
 all other variables are set to their default values (no polarization,
 lab frame and c.m.\ frame coincide, etc.)
 
 We assume that all components consistently describe a scattering
 process, i.e., two incoming particles.
 
 Note: The current layout of the [[beam_data_t]] record requires that the
 flavor for each beam is unique.  For processes with multiple
 flavors in the initial state, one has to set up beams explicitly.
 This restriction could be removed by extending the code in the
 [[beams]] module.
 <<Process: process: TBP>>=
   procedure :: setup_beams_sqrts => process_setup_beams_sqrts
 <<Process: procedures>>=
   subroutine process_setup_beams_sqrts (process, sqrts, beam_structure, i_core)
     class(process_t), intent(inout) :: process
     real(default), intent(in) :: sqrts
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer, intent(in), optional :: i_core
     type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
     integer, dimension(2) :: pdg_scattering
     type(flavor_t), dimension(2) :: flv_in
     integer :: i, i0, ic
     allocate (pdg_in (2, process%meta%n_components))
     i0 = 0
     do i = 1, process%meta%n_components
        if (process%component(i)%active) then
           if (present (i_core)) then
              ic = i_core
           else
              ic = process%pcm%get_i_core (i)
           end if
           associate (core => process%core_entry(ic)%core)
             pdg_in(:,i) = core%data%get_pdg_in ()
           end associate
           if (i0 == 0)  i0 = i
        end if
     end do
     do i = 1, process%meta%n_components
        if (.not. process%component(i)%active) then
           pdg_in(:,i) = pdg_in(:,i0)
        end if
     end do
     if (all (pdg_array_get_length (pdg_in) == 1) .and. &
          all (pdg_in(1,:) == pdg_in(1,i0)) .and. &
          all (pdg_in(2,:) == pdg_in(2,i0))) then
        pdg_scattering = pdg_array_get (pdg_in(:,i0), 1)
        call flv_in%init (pdg_scattering, process%config%model)
        call process%beam_config%init_scattering (flv_in, sqrts, beam_structure)
     else
        call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", &
            [var_str ("   --------------------------------------------"), &
             var_str ("Inconsistent initial state. This happens if either "), &
             var_str ("several processes with non-matching initial states "), &
             var_str ("have been added, or for a single process with an "), &
             var_str ("initial state flavor sum. In that case, please set beams "), &
             var_str ("explicitly [singling out a flavor / structure function.]")])
     end if
   end subroutine process_setup_beams_sqrts
 
 @ %def process_setup_beams_sqrts
 @ This is the version that applies to decay processes.  The energy is the
 particle mass, hence no extra argument.
 <<Process: process: TBP>>=
   procedure :: setup_beams_decay => process_setup_beams_decay
 <<Process: procedures>>=
   subroutine process_setup_beams_decay (process, rest_frame, beam_structure, i_core)
     class(process_t), intent(inout), target :: process
     logical, intent(in), optional :: rest_frame
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer, intent(in), optional :: i_core
     type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
     integer, dimension(1) :: pdg_decay
     type(flavor_t), dimension(1) :: flv_in
     integer :: i, i0, ic
     allocate (pdg_in (1, process%meta%n_components))
     i0 = 0
     do i = 1, process%meta%n_components
        if (process%component(i)%active) then
           if (present (i_core)) then
              ic = i_core
           else
              ic = process%pcm%get_i_core (i)
           end if
           associate (core => process%core_entry(ic)%core)
             pdg_in(:,i) = core%data%get_pdg_in ()
           end associate
           if (i0 == 0)  i0 = i
        end if
     end do
     do i = 1, process%meta%n_components
        if (.not. process%component(i)%active) then
           pdg_in(:,i) = pdg_in(:,i0)
        end if
     end do
     if (all (pdg_array_get_length (pdg_in) == 1) &
          .and. all (pdg_in(1,:) == pdg_in(1,i0))) then
        pdg_decay = pdg_array_get (pdg_in(:,i0), 1)
        call flv_in%init (pdg_decay, process%config%model)
        call process%beam_config%init_decay (flv_in, rest_frame, beam_structure)
     else
        call msg_fatal ("Setting up decay '" &
             // char (process%meta%id) // "': decaying particle not unique")
     end if
   end subroutine process_setup_beams_decay
 
 @ %def process_setup_beams_decay
 @ We have to make sure that the masses of the various flavors
 in a given position in the particle string coincide.
 <<Process: process: TBP>>=
   procedure :: check_masses => process_check_masses
 <<Process: procedures>>=
   subroutine process_check_masses (process)
     class(process_t), intent(in) :: process
     type(flavor_t), dimension(:), allocatable :: flv
     real(default), dimension(:), allocatable :: mass
     integer :: i, j
     integer :: i_component
     class(prc_core_t), pointer :: core
     do i = 1, process%get_n_terms ()
        i_component = process%term(i)%i_component
        if (.not. process%component(i_component)%active)  cycle
        core => process%get_core_term (i)
        associate (data => core%data)
          allocate (flv (data%n_flv), mass (data%n_flv))
          do j = 1, data%n_in + data%n_out
             call flv%init (data%flv_state(j,:), process%config%model)
             mass = flv%get_mass ()
             if (any (.not. nearly_equal(mass, mass(1)))) then
                call msg_fatal ("Process '" // char (process%meta%id) // "': " &
                     // "mass values in flavor combination do not coincide. ")
             end if
          end do
          deallocate (flv, mass)
        end associate
     end do
   end subroutine process_check_masses
 
 @ %def process_check_masses
 @ Set up index mapping for [[region_data]] for singular regions equivalent w.r.t.
 their amplitudes. Has to be called after [[region_data]] AND the [[core]] are fully
 set up. For processes with structure function, subprocesses which lead to the same
 amplitude for the hard interaction can differ if structure functions are applied.
 In this case we remap flavor structures to themselves if the eqvivalent hard interaction
 flavor structure has no identical initial state.
 <<Process: process: TBP>>=
   procedure :: optimize_nlo_singular_regions => process_optimize_nlo_singular_regions
 <<Process: procedures>>=
   subroutine process_optimize_nlo_singular_regions (process)
     class(process_t), intent(inout) :: process
     class(prc_core_t), pointer :: core, core_sub
     integer, dimension(:), allocatable :: eqv_flv_index_born
     integer, dimension(:), allocatable :: eqv_flv_index_real
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     integer :: i_flv, i_flv2, n_in, i
     integer :: i_component, i_core, i_core_sub
     logical :: fetched_born, fetched_real
     logical :: optimize
     fetched_born = .false.; fetched_real = .false.
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        optimize = pcm%settings%reuse_amplitudes_fks
        if (optimize) then
           do i_component = 1, pcm%n_components
              i_core = pcm%get_i_core(i_component)
              core => process%get_core_ptr (i_core)
              if (.not. core%data_known) cycle
              associate (data => core%data)
                 if (pcm%nlo_type_core(i_core) == NLO_REAL .and. &
                      .not. pcm%component_type(i_component) == COMP_SUB) then
                    if (allocated (core%data%eqv_flv_index)) then
                       eqv_flv_index_real = core%get_equivalent_flv_index ()
                       fetched_real = .true.
                    end if
                    i_core_sub = pcm%get_i_core (pcm%i_sub)
                    core_sub => process%get_core_ptr (i_core_sub)
                    if (allocated (core_sub%data%eqv_flv_index)) then
                       eqv_flv_index_born = core_sub%get_equivalent_flv_index ()
                       fetched_born = .true.
                    end if
                    if (fetched_born .and. fetched_real) exit
                 end if
              end associate
           end do
           if (.not. fetched_born .or. .not. fetched_real) then
              call msg_warning('Failed to fetch flavor equivalence indices. &
                   &Disabling singular region optimization')
              optimize = .false.
              eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
              eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
           end if
           if (optimize .and. pcm%has_pdfs) then
              flv_born = pcm%region_data%get_flv_states_born ()
              flv_real = pcm%region_data%get_flv_states_real ()
              n_in = pcm%region_data%n_in
              do i_flv = 1, size (eqv_flv_index_born)
                 do i_flv2 = 1, i_flv
                    if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= &
                         flv_born(1:n_in, i_flv))) then
                       eqv_flv_index_born(i_flv) = i_flv
                       exit
                    end if
                 end do
              end do
              do i_flv = 1, size (eqv_flv_index_real)
                 do i_flv2 = 1, i_flv
                    if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= &
                         flv_real(1:n_in, i_flv))) then
                       eqv_flv_index_real(i_flv) = i_flv
                       exit
                    end if
                 end do
              end do
           end if
        else
           eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
           eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
        end if
        pcm%region_data%eqv_flv_index_born = eqv_flv_index_born
        pcm%region_data%eqv_flv_index_real = eqv_flv_index_real
        call pcm%region_data%find_eqv_regions (optimize)
     end select
   end subroutine process_optimize_nlo_singular_regions
 
 @ %def process_optimize_nlo_singular_regions
 @ For some structure functions we need to get the list of initial
 state flavors.  This is a two-dimensional array.  The first index is
 the beam index, the second index is the component index.  Each array
 element is itself a PDG array object, which consists of the list of
 incoming PDG values for this beam and component.
 <<Process: process: TBP>>=
   procedure :: get_pdg_in => process_get_pdg_in
 <<Process: procedures>>=
   subroutine process_get_pdg_in (process, pdg_in)
     class(process_t), intent(in), target :: process
     type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in
     integer :: i, i_core
     allocate (pdg_in (process%config%n_in, process%meta%n_components))
     do i = 1, process%meta%n_components
        if (process%component(i)%active) then
           i_core = process%pcm%get_i_core (i)
           associate (core => process%core_entry(i_core)%core)
             pdg_in(:,i) = core%data%get_pdg_in ()
           end associate
        end if
     end do
   end subroutine process_get_pdg_in
 
 @ %def process_get_pdg_in
 @ The phase-space configuration object, in case we need it separately.
 <<Process: process: TBP>>=
   procedure :: get_phs_config => process_get_phs_config
 <<Process: procedures>>=
   function process_get_phs_config (process, i_component) result (phs_config)
     class(phs_config_t), pointer :: phs_config
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_component
     if (allocated (process%component)) then
        phs_config => process%component(i_component)%phs_config
     else
        phs_config => null ()
     end if
   end function process_get_phs_config
 
 @ %def process_get_phs_config
 @ The resonance history set can be extracted from the phase-space
 configuration.  However, this is only possible if the default phase-space
 method (wood) has been chosen.  If [[include_trivial]] is set, we include the
 resonance history with no resonances in the set.
 <<Process: process: TBP>>=
   procedure :: extract_resonance_history_set &
        => process_extract_resonance_history_set
 <<Process: procedures>>=
   subroutine process_extract_resonance_history_set &
        (process, res_set, include_trivial, i_component)
     class(process_t), intent(in), target :: process
     type(resonance_history_set_t), intent(out) :: res_set
     logical, intent(in), optional :: include_trivial
     integer, intent(in), optional :: i_component
     integer :: i
     i = 1;  if (present (i_component))  i = i_component
     select type (phs_config => process%get_phs_config (i))
     class is (phs_wood_config_t)
        call phs_config%extract_resonance_history_set (res_set, include_trivial)
     class default
        call msg_error ("process '" // char (process%get_id ()) &
             // "': extract resonance histories: phase-space method must be &
             &'wood'.  No resonances can be determined.")
     end select
   end subroutine process_extract_resonance_history_set
 
 @ %def process_extract_resonance_history_set
 @ Initialize from a complete beam setup.  If the beam setup does not
 apply directly to the process, choose a fallback option as a straight
 scattering or decay process.
 <<Process: process: TBP>>=
   procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure
 <<Process: procedures>>=
   subroutine process_setup_beams_beam_structure &
        (process, beam_structure, sqrts, decay_rest_frame)
     class(process_t), intent(inout) :: process
     type(beam_structure_t), intent(in) :: beam_structure
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: decay_rest_frame
     integer :: n_in
     logical :: applies
     n_in = process%get_n_in ()
     call beam_structure%check_against_n_in (process%get_n_in (), applies)
     if (applies) then
        call process%beam_config%init_beam_structure &
             (beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame)
     else if (n_in == 2) then
        call process%setup_beams_sqrts (sqrts, beam_structure)
     else
        call process%setup_beams_decay (decay_rest_frame, beam_structure)
     end if
   end subroutine process_setup_beams_beam_structure
 
 @ %def process_setup_beams_beam_structure
 @ Notify the user about beam setup.
 <<Process: process: TBP>>=
   procedure :: beams_startup_message => process_beams_startup_message
 <<Process: procedures>>=
   subroutine process_beams_startup_message (process, unit, beam_structure)
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: unit
     type(beam_structure_t), intent(in), optional :: beam_structure
     call process%beam_config%startup_message (unit, beam_structure)
   end subroutine process_beams_startup_message
 
 @ %def process_beams_startup_message
 @ Initialize phase-space configuration by reading out the environment
 variables.  We return the rebuild flags and store parameters in the blocks
 [[phs_par]] and [[mapping_defs]].
 
 The phase-space configuration object(s) are allocated by [[pcm]].
 <<Process: process: TBP>>=
   procedure :: init_phs_config => process_init_phs_config
 <<Process: procedures>>=
   subroutine process_init_phs_config (process)
     class(process_t), intent(inout) :: process
 
     type(var_list_t), pointer :: var_list
     type(phs_parameters_t) :: phs_par
     type(mapping_defaults_t) :: mapping_defs
 
     var_list => process%env%get_var_list_ptr ()
 
     phs_par%m_threshold_s = &
          var_list%get_rval (var_str ("phs_threshold_s"))
     phs_par%m_threshold_t = &
          var_list%get_rval (var_str ("phs_threshold_t"))
     phs_par%off_shell = &
          var_list%get_ival (var_str ("phs_off_shell"))
     phs_par%keep_nonresonant = &
          var_list%get_lval (var_str ("?phs_keep_nonresonant"))
     phs_par%t_channel = &
          var_list%get_ival (var_str ("phs_t_channel"))
 
     mapping_defs%energy_scale = &
          var_list%get_rval (var_str ("phs_e_scale"))
     mapping_defs%invariant_mass_scale = &
          var_list%get_rval (var_str ("phs_m_scale"))
     mapping_defs%momentum_transfer_scale = &
          var_list%get_rval (var_str ("phs_q_scale"))
     mapping_defs%step_mapping = &
          var_list%get_lval (var_str ("?phs_step_mapping"))
     mapping_defs%step_mapping_exp = &
          var_list%get_lval (var_str ("?phs_step_mapping_exp"))
     mapping_defs%enable_s_mapping = &
          var_list%get_lval (var_str ("?phs_s_mapping"))
 
     associate (pcm => process%pcm)
       call pcm%init_phs_config (process%phs_entry, &
            process%meta, process%env, phs_par, mapping_defs)
     end associate
 
   end subroutine process_init_phs_config
 
 @ %def process_init_phs_config
 @ We complete the kinematics configuration after the beam setup, but before we
 configure the chain of structure functions.  The reason is that we need the
 total energy [[sqrts]] for the kinematics, but the structure-function setup
 requires the number of channels, which depends on the kinematics
 configuration.  For instance, the kinematics module may return the need for
 parameterizing an s-channel resonance.
 <<Process: process: TBP>>=
   procedure :: configure_phs => process_configure_phs
 <<Process: procedures>>=
   subroutine process_configure_phs (process, rebuild, ignore_mismatch, &
      combined_integration, subdir)
     class(process_t), intent(inout) :: process
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     logical, intent(in), optional :: combined_integration
     type(string_t), intent(in), optional :: subdir
     real(default) :: sqrts
     integer :: i, i_born, nlo_type
     class(phs_config_t), pointer :: phs_config_born
     sqrts = process%get_sqrts ()
     do i = 1, process%meta%n_components
        associate (component => process%component(i))
          if (component%active) then
             select type (pcm => process%pcm)
             type is (pcm_default_t)
                call component%configure_phs (sqrts, process%beam_config, &
                     rebuild, ignore_mismatch, subdir)
             class is (pcm_nlo_t)
                nlo_type = component%config%get_nlo_type ()
                select case (nlo_type)
                case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
                   call component%configure_phs (sqrts, process%beam_config, &
                        rebuild, ignore_mismatch, subdir)
                   call check_and_extend_phs (component)
                case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
                   i_born = component%config%get_associated_born ()
                   if (component%component_type /= COMP_REAL_FIN) &
                        call check_and_extend_phs (component)
                   call process%component(i_born)%get_phs_config &
                        (phs_config_born)
                   select type (config => component%phs_config)
                   type is (phs_fks_config_t)
                      select type (phs_config_born)
                      type is (phs_wood_config_t)
                         config%md5sum_born_config = &
                              phs_config_born%md5sum_phs_config
                         call config%set_born_config (phs_config_born)
                         call config%set_mode (component%config%get_nlo_type ())
                      end select
                   end select
                   call component%configure_phs (sqrts, &
                        process%beam_config, rebuild, ignore_mismatch, subdir)
                end select
             class default
                call msg_bug ("process_configure_phs: unsupported PCM type")
             end select
          end if
        end associate
     end do
   contains
     subroutine check_and_extend_phs (component)
       type(process_component_t), intent(inout) :: component
       if (combined_integration) then
          select type (phs_config => component%phs_config)
          class is (phs_wood_config_t)
             phs_config%is_combined_integration = .true.
             call phs_config%increase_n_par ()
          end select
       end if
     end subroutine check_and_extend_phs
   end subroutine process_configure_phs
 
 @ %def process_configure_phs
 @
 <<Process: process: TBP>>=
   procedure :: print_phs_startup_message => process_print_phs_startup_message
 <<Process: procedures>>=
   subroutine process_print_phs_startup_message (process)
     class(process_t), intent(in) :: process
     integer :: i_component
     do i_component = 1, process%meta%n_components
        associate (component => process%component(i_component))
           if (component%active) then
              call component%phs_config%startup_message ()
           end if
        end associate
     end do
   end subroutine process_print_phs_startup_message
 
 @ %def process_print_phs_startup_message
 @ Insert the structure-function configuration data.  First allocate the
 storage, then insert data one by one.  The third procedure declares a
 mapping (of the MC input parameters) for a specific channel and
 structure-function combination.
 
 We take the number of channels from the corresponding entry in the
 [[config_data]] section.
 
 Otherwise, these a simple wrapper routines.  The extra level in the
 call tree may allow for simple addressing of multiple concurrent beam
 configurations, not implemented currently.
 
 If we do not want structure functions, we simply do not call those procedures.
 <<Process: process: TBP>>=
   procedure :: init_sf_chain => process_init_sf_chain
   generic :: set_sf_channel => set_sf_channel_single
   procedure :: set_sf_channel_single => process_set_sf_channel
   generic :: set_sf_channel => set_sf_channel_array
   procedure :: set_sf_channel_array => process_set_sf_channel_array
 <<Process: procedures>>=
   subroutine process_init_sf_chain (process, sf_config, sf_trace_file)
     class(process_t), intent(inout) :: process
     type(sf_config_t), dimension(:), intent(in) :: sf_config
     type(string_t), intent(in), optional :: sf_trace_file
     type(string_t) :: file
     if (present (sf_trace_file)) then
        if (sf_trace_file /= "") then
           file = sf_trace_file
        else
           file = process%get_id () // "_sftrace.dat"
        end if
        call process%beam_config%init_sf_chain (sf_config, file)
     else
        call process%beam_config%init_sf_chain (sf_config)
     end if
   end subroutine process_init_sf_chain
 
   subroutine process_set_sf_channel (process, c, sf_channel)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: c
     type(sf_channel_t), intent(in) :: sf_channel
     call process%beam_config%set_sf_channel (c, sf_channel)
   end subroutine process_set_sf_channel
 
   subroutine process_set_sf_channel_array (process, sf_channel)
     class(process_t), intent(inout) :: process
     type(sf_channel_t), dimension(:), intent(in) :: sf_channel
     integer :: c
     call process%beam_config%allocate_sf_channels (size (sf_channel))
     do c = 1, size (sf_channel)
        call process%beam_config%set_sf_channel (c, sf_channel(c))
     end do
   end subroutine process_set_sf_channel_array
 
 @ %def process_init_sf_chain
 @ %def process_set_sf_channel
 @ Notify about the structure-function setup.
 <<Process: process: TBP>>=
   procedure :: sf_startup_message => process_sf_startup_message
 <<Process: procedures>>=
   subroutine process_sf_startup_message (process, sf_string, unit)
     class(process_t), intent(in) :: process
     type(string_t), intent(in) :: sf_string
     integer, intent(in), optional :: unit
     call process%beam_config%sf_startup_message (sf_string, unit)
   end subroutine process_sf_startup_message
 
 @ %def process_sf_startup_message
 @ As soon as both the kinematics configuration and the
 structure-function setup are complete, we match parameterizations
 (channels) for both.  The matching entries are (re)set in the
 [[component]] phase-space configuration, while the structure-function
 configuration is left intact.
 <<Process: process: TBP>>=
   procedure :: collect_channels => process_collect_channels
 <<Process: procedures>>=
   subroutine process_collect_channels (process, coll)
     class(process_t), intent(inout) :: process
     type(phs_channel_collection_t), intent(inout) :: coll
     integer :: i
     do i = 1, process%meta%n_components
        associate (component => process%component(i))
          if (component%active) &
             call component%collect_channels (coll)
        end associate
     end do
   end subroutine process_collect_channels
 
 @ %def process_collect_channels
 @ Independently, we should be able to check if any component does not
 contain phase-space parameters.  Such a process can only be integrated
 if there are structure functions.
 <<Process: process: TBP>>=
   procedure :: contains_trivial_component => process_contains_trivial_component
 <<Process: procedures>>=
   function process_contains_trivial_component (process) result (flag)
     class(process_t), intent(in) :: process
     logical :: flag
     integer :: i
     flag = .true.
     do i = 1, process%meta%n_components
        associate (component => process%component(i))
          if (component%active) then
             if (component%get_n_phs_par () == 0)  return
          end if
        end associate
     end do
     flag = .false.
   end function process_contains_trivial_component
 
 @ %def process_contains_trivial_component
 @
 <<Process: process: TBP>>=
   procedure :: get_master_component => process_get_master_component
 <<Process: procedures>>=
   function process_get_master_component (process, i_mci) result (i_component)
      integer :: i_component
      class(process_t), intent(in) :: process
      integer, intent(in) :: i_mci
      integer :: i
      i_component = 0
      do i = 1, size (process%component)
         if (process%component(i)%i_mci == i_mci) then
            i_component = i
            return
         end if
      end do
   end function process_get_master_component
 
 
 @ %def process_get_master_component
 @ Determine the MC parameter set structure and the MCI configuration for each
 process component.  We need data from the structure-function and phase-space
 setup, so those should be complete before this is called.  We also
 make a random-number generator instance for each MCI group.
 <<Process: process: TBP>>=
   procedure :: setup_mci => process_setup_mci
 <<Process: procedures>>=
   subroutine process_setup_mci (process, dispatch_mci)
     class(process_t), intent(inout) :: process
     procedure(dispatch_mci_proc) :: dispatch_mci
     class(mci_t), allocatable :: mci_template
     integer :: i, i_mci
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci")
     associate (pcm => process%pcm)
       call pcm%call_dispatch_mci (dispatch_mci, &
            process%get_var_list_ptr (), process%meta%id, mci_template)
       call pcm%setup_mci (process%mci_entry)
       process%config%n_mci = pcm%n_mci
       process%component(:)%i_mci = pcm%i_mci(:)
       do i = 1, pcm%n_components
          i_mci = process%pcm%i_mci(i)
          if (i_mci > 0) then
             associate (component => process%component(i), &
                  mci_entry => process%mci_entry(i_mci))
               call mci_entry%configure (mci_template, &
                    process%meta%type, &
                    i_mci, i, component, process%beam_config%n_sfpar, &
                    process%rng_factory)
               call mci_entry%set_parameters (process%get_var_list_ptr ())
             end associate
          end if
       end do
     end associate
   end subroutine process_setup_mci
 
 @ %def process_setup_mci
 @ Set cuts.  This is a parse node, namely the right-hand side of the [[cut]]
 assignment.  When creating an instance, we compile this into an evaluation
 tree.  The parse node may be null.
 <<Process: process: TBP>>=
   procedure :: set_cuts => process_set_cuts
 <<Process: procedures>>=
   subroutine process_set_cuts (process, ef_cuts)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_cuts
     allocate (process%config%ef_cuts, source = ef_cuts)
   end subroutine process_set_cuts
 
 @ %def process_set_cuts
 @ Analogously for the other expressions.
 <<Process: process: TBP>>=
   procedure :: set_scale => process_set_scale
   procedure :: set_fac_scale => process_set_fac_scale
   procedure :: set_ren_scale => process_set_ren_scale
   procedure :: set_weight => process_set_weight
 <<Process: procedures>>=
   subroutine process_set_scale (process, ef_scale)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_scale
     allocate (process%config%ef_scale, source = ef_scale)
   end subroutine process_set_scale
 
   subroutine process_set_fac_scale (process, ef_fac_scale)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_fac_scale
     allocate (process%config%ef_fac_scale, source = ef_fac_scale)
   end subroutine process_set_fac_scale
 
   subroutine process_set_ren_scale (process, ef_ren_scale)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_ren_scale
     allocate (process%config%ef_ren_scale, source = ef_ren_scale)
   end subroutine process_set_ren_scale
 
   subroutine process_set_weight (process, ef_weight)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_weight
     allocate (process%config%ef_weight, source = ef_weight)
   end subroutine process_set_weight
 
 @ %def process_set_scale
 @ %def process_set_fac_scale
 @ %def process_set_ren_scale
 @ %def process_set_weight
 @
 \subsubsection{MD5 sum}
 The MD5 sum of the process object should reflect the state completely,
 including integration results.  It is used for checking the integrity
 of event files.  This global checksum includes checksums for the
 various parts.  In particular, the MCI object receives a checksum that
 includes the configuration of all configuration parts relevant for an
 individual integration.  This checksum is used for checking the
 integrity of integration grids.
 
 We do not need MD5 sums for the process terms, since these are
 generated from the component definitions.
 <<Process: process: TBP>>=
   procedure :: compute_md5sum => process_compute_md5sum
 <<Process: procedures>>=
   subroutine process_compute_md5sum (process)
     class(process_t), intent(inout) :: process
     integer :: i
     call process%config%compute_md5sum ()
     do i = 1, process%config%n_components
        associate (component => process%component(i))
          if (component%active) then
             call component%compute_md5sum ()
          end if
        end associate
     end do
     call process%beam_config%compute_md5sum ()
     do i = 1, process%config%n_mci
        call process%mci_entry(i)%compute_md5sum &
             (process%config, process%component, process%beam_config)
     end do
   end subroutine process_compute_md5sum
 
 @ %def process_compute_md5sum
 @
 <<Process: process: TBP>>=
   procedure :: sampler_test => process_sampler_test
 <<Process: procedures>>=
   subroutine process_sampler_test (process, sampler, n_calls, i_mci)
     class(process_t), intent(inout) :: process
     class(mci_sampler_t), intent(inout) :: sampler
     integer, intent(in) :: n_calls, i_mci
     call process%mci_entry(i_mci)%sampler_test (sampler, n_calls)
   end subroutine process_sampler_test
 
 @ %def process_sampler_test
 @ The finalizer should be called after all integration passes have been
 completed.  It will, for instance, write a summary of the integration
 results.
 
 [[integrate_dummy]] does a ``dummy'' integration in the sense that
 nothing is done but just empty integration results appended.
 <<Process: process: TBP>>=
   procedure :: final_integration => process_final_integration
   procedure :: integrate_dummy => process_integrate_dummy
 <<Process: procedures>>=
   subroutine process_final_integration (process, i_mci)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     call process%mci_entry(i_mci)%final_integration ()
   end subroutine process_final_integration
 
   subroutine process_integrate_dummy (process)
     class(process_t), intent(inout) :: process
     type(integration_results_t) :: results
     integer :: u_log
     u_log = logfile_unit ()
     call results%init (process%meta%type)
     call results%display_init (screen = .true., unit = u_log)
     call results%new_pass ()
     call results%record (1, 0, 0._default, 0._default, 0._default)
     call results%display_final ()
   end subroutine process_integrate_dummy
 
 @ %def process_final_integration
 @ %def process_integrate_dummy
 @
 <<Process: process: TBP>>=
   procedure :: integrate => process_integrate
 <<Process: procedures>>=
   subroutine process_integrate (process, i_mci, mci_work, &
      mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, &
      pacify, nlo_type)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(mci_work_t), intent(inout) :: mci_work
     class(mci_sampler_t), intent(inout) :: mci_sampler
     integer, intent(in) :: n_it, n_calls
     logical, intent(in), optional :: adapt_grids, adapt_weights
     logical, intent(in), optional :: final
     logical, intent(in), optional :: pacify
     integer, intent(in), optional :: nlo_type
     associate (mci_entry => process%mci_entry(i_mci))
        call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, &
             adapt_grids, adapt_weights, final, pacify, &
             nlo_type = nlo_type)
        call mci_entry%results%display_pass (pacify)
     end associate
   end subroutine process_integrate
 
 @ %def process_integrate
 @
 <<Process: process: TBP>>=
   procedure :: generate_weighted_event => process_generate_weighted_event
 <<Process: procedures>>=
   subroutine process_generate_weighted_event (process, i_mci, mci_work, &
      mci_sampler, keep_failed_events)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(mci_work_t), intent(inout) :: mci_work
     class(mci_sampler_t), intent(inout) :: mci_sampler
     logical, intent(in) :: keep_failed_events
     associate (mci_entry => process%mci_entry(i_mci))
        call mci_entry%generate_weighted_event (mci_work%mci, &
             mci_sampler, keep_failed_events)
     end associate
   end subroutine process_generate_weighted_event
 
 @ %def process_generate_weighted_event
 <<Process: process: TBP>>=
   procedure :: generate_unweighted_event => process_generate_unweighted_event
 <<Process: procedures>>=
   subroutine process_generate_unweighted_event (process, i_mci, &
      mci_work, mci_sampler)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(mci_work_t), intent(inout) :: mci_work
     class(mci_sampler_t), intent(inout) :: mci_sampler
     associate (mci_entry => process%mci_entry(i_mci))
        call mci_entry%generate_unweighted_event &
           (mci_work%mci, mci_sampler)
     end associate
   end subroutine process_generate_unweighted_event
 
 @ %def process_generate_unweighted_event
 @ Display the final results for the sum of all components. This is useful,
 obviously, only if there is more than one component and not if a combined
 integration of all components together has been performed.
 <<Process: process: TBP>>=
   procedure :: display_summed_results => process_display_summed_results
 <<Process: procedures>>=
   subroutine process_display_summed_results (process, pacify)
     class(process_t), intent(inout) :: process
     logical, intent(in) :: pacify
     type(integration_results_t) :: results
     integer :: u_log
     u_log = logfile_unit ()
     call results%init (process%meta%type)
     call results%display_init (screen = .true., unit = u_log)
     call results%new_pass ()
     call results%record (1, 0, &
          process%get_integral (), &
          process%get_error (), &
          process%get_efficiency (), suppress = pacify)
     select type (pcm => process%pcm)
     class is (pcm_nlo_t)
        !!! Check that Born integral is there
        if (.not. pcm%settings%combined_integration .and. &
             process%component_can_be_integrated (1)) then
           call results%record_correction (process%get_correction (), &
                process%get_correction_error ())
        end if
     end select
     call results%display_final ()
   end subroutine process_display_summed_results
 
 @ %def process_display_summed_results
 @ Run LaTeX/Metapost to generate a ps/pdf file for the integration
 history.  We (re)write the driver file -- just in case it has been
 missed before -- then we compile it.
 <<Process: process: TBP>>=
   procedure :: display_integration_history => &
        process_display_integration_history
 <<Process: procedures>>=
   subroutine process_display_integration_history &
        (process, i_mci, filename, os_data, eff_reset)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(string_t), intent(in) :: filename
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: eff_reset
     call integration_results_write_driver &
          (process%mci_entry(i_mci)%results, filename, eff_reset)
     call integration_results_compile_driver &
          (process%mci_entry(i_mci)%results, filename, os_data)
   end subroutine process_display_integration_history
 
 @ %def subroutine process_display_integration_history
 @ Write a complete logfile (with hardcoded name based on the process ID).
 We do not write internal data.
 <<Process: process: TBP>>=
   procedure :: write_logfile => process_write_logfile
 <<Process: procedures>>=
   subroutine process_write_logfile (process, i_mci, filename)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(string_t), intent(in) :: filename
     type(time_t) :: time
     integer :: unit, u
     unit = free_unit ()
     open (unit = unit, file = char (filename), action = "write", &
           status = "replace")
     u = given_output_unit (unit)
     write (u, "(A)")  repeat ("#", 79)
     call process%meta%write (u, .false.)
     write (u, "(A)")  repeat ("#", 79)
     write (u, "(3x,A,ES17.10)")  "Integral   = ", &
          process%mci_entry(i_mci)%get_integral ()
     write (u, "(3x,A,ES17.10)")  "Error      = ", &
          process%mci_entry(i_mci)%get_error ()
     write (u, "(3x,A,ES17.10)")  "Accuracy   = ", &
          process%mci_entry(i_mci)%get_accuracy ()
     write (u, "(3x,A,ES17.10)")  "Chi2       = ", &
          process%mci_entry(i_mci)%get_chi2 ()
     write (u, "(3x,A,ES17.10)")  "Efficiency = ", &
          process%mci_entry(i_mci)%get_efficiency ()
     call process%mci_entry(i_mci)%get_time (time, 10000)
     if (time%is_known ()) then
        write (u, "(3x,A,1x,A)")  "T(10k evt) = ", char (time%to_string_dhms ())
     else
        write (u, "(3x,A)")  "T(10k evt) =  [undefined]"
     end if
     call process%mci_entry(i_mci)%results%write (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%mci_entry(i_mci)%results%write_chain_weights (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%mci_entry(i_mci)%counter%write (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%mci_entry(i_mci)%mci%write_log_entry (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%beam_config%data%write (u)
     write (u, "(A)")  repeat ("#", 79)
     if (allocated (process%config%ef_cuts)) then
        write (u, "(3x,A)") "Cut expression:"
        call process%config%ef_cuts%write (u)
     else
        write (u, "(3x,A)") "No cuts used."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_scale)) then
        write (u, "(3x,A)") "Scale expression:"
        call process%config%ef_scale%write (u)
     else
        write (u, "(3x,A)") "No scale expression was given."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_fac_scale)) then
        write (u, "(3x,A)") "Factorization scale expression:"
        call process%config%ef_fac_scale%write (u)
     else
        write (u, "(3x,A)") "No factorization scale expression was given."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_ren_scale)) then
        write (u, "(3x,A)") "Renormalization scale expression:"
        call process%config%ef_ren_scale%write (u)
     else
        write (u, "(3x,A)") "No renormalization scale expression was given."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_weight)) then
        call write_separator (u)
        write (u, "(3x,A)") "Weight expression:"
        call process%config%ef_weight%write (u)
     else
        write (u, "(3x,A)") "No weight expression was given."
     end if
     write (u, "(A)")  repeat ("#", 79)
     write (u, "(1x,A)") "Summary of quantum-number states:"
     write (u, "(1x,A)")  " + sign: allowed and contributing"
     write (u, "(1x,A)")  " no +  : switched off at runtime"
     call process%write_state_summary (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%env%write (u, show_var_list=.true., &
               show_model=.false., show_lib=.false., show_os_data=.false.)
     write (u, "(A)")  repeat ("#", 79)
     close (u)
   end subroutine process_write_logfile
 
 @ %def process_write_logfile
 @ Display the quantum-number combinations of the process components, and their
 current status (allowed or switched off).
 <<Process: process: TBP>>=
   procedure :: write_state_summary => process_write_state_summary
 <<Process: procedures>>=
   subroutine process_write_state_summary (process, unit)
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: unit
     integer :: i, i_component, u
     u = given_output_unit (unit)
     do i = 1, size (process%term)
        call write_separator (u)
        i_component = process%term(i)%i_component
        if (i_component /= 0) then
           call process%term(i)%write_state_summary &
                (process%get_core_term(i), unit)
        end if
     end do
   end subroutine process_write_state_summary
 
 @ %def process_write_state_summary
 @ Prepare event generation for the specified MCI entry.  This implies, in
 particular, checking the phase-space file.
 <<Process: process: TBP>>=
   procedure :: prepare_simulation => process_prepare_simulation
 <<Process: procedures>>=
   subroutine process_prepare_simulation (process, i_mci)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     call process%mci_entry(i_mci)%prepare_simulation ()
   end subroutine process_prepare_simulation
 
 @ %def process_prepare_simulation
 @
 \subsubsection{Retrieve process data}
 Tell whether integral (and error) are known.
 <<Process: process: TBP>>=
   generic :: has_integral => has_integral_tot, has_integral_mci
   procedure :: has_integral_tot => process_has_integral_tot
   procedure :: has_integral_mci => process_has_integral_mci
 <<Process: procedures>>=
   function process_has_integral_mci (process, i_mci) result (flag)
     logical :: flag
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     if (allocated (process%mci_entry)) then
        flag = process%mci_entry(i_mci)%has_integral ()
     else
        flag = .false.
     end if
   end function process_has_integral_mci
 
   function process_has_integral_tot (process) result (flag)
     logical :: flag
     class(process_t), intent(in) :: process
     integer :: i, j, i_component
     if (allocated (process%mci_entry)) then
        flag = .true.
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated (i_component)) &
                 flag = flag .and. process%mci_entry(i)%has_integral ()
           end do
        end do
     else
        flag = .false.
     end if
   end function process_has_integral_tot
 
 @ %def process_has_integral
 @
 Return the current integral and error obtained by the integrator [[i_mci]].
 <<Process: process: TBP>>=
   generic :: get_integral => get_integral_tot, get_integral_mci
   generic :: get_error => get_error_tot, get_error_mci
   generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci
   procedure :: get_integral_tot => process_get_integral_tot
   procedure :: get_integral_mci => process_get_integral_mci
   procedure :: get_error_tot => process_get_error_tot
   procedure :: get_error_mci => process_get_error_mci
   procedure :: get_efficiency_tot => process_get_efficiency_tot
   procedure :: get_efficiency_mci => process_get_efficiency_mci
 <<Process: procedures>>=
   function process_get_integral_mci (process, i_mci) result (integral)
     real(default) :: integral
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     integral = process%mci_entry(i_mci)%get_integral ()
   end function process_get_integral_mci
 
   function process_get_error_mci (process, i_mci) result (error)
     real(default) :: error
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     error = process%mci_entry(i_mci)%get_error ()
   end function process_get_error_mci
 
   function process_get_efficiency_mci (process, i_mci) result (efficiency)
     real(default) :: efficiency
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     efficiency = process%mci_entry(i_mci)%get_efficiency ()
   end function process_get_efficiency_mci
 
   function process_get_integral_tot (process) result (integral)
     real(default) :: integral
     class(process_t), intent(in) :: process
     integer :: i, j, i_component
     integral = zero
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated(i_component)) &
                   integral = integral + process%mci_entry(i)%get_integral ()
           end do
        end do
     end if
   end function process_get_integral_tot
 
   function process_get_error_tot (process) result (error)
     real(default) :: variance
     class(process_t), intent(in) :: process
     real(default) :: error
     integer :: i, j, i_component
     variance = zero
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated(i_component)) &
                   variance = variance + process%mci_entry(i)%get_error () ** 2
           end do
        end do
     end if
     error = sqrt (variance)
   end function process_get_error_tot
 
   function process_get_efficiency_tot (process) result (efficiency)
     real(default) :: efficiency
     class(process_t), intent(in) :: process
     real(default) :: den, eff, int
     integer :: i, j, i_component
     den = zero
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated(i_component)) then
                 int = process%get_integral (i)
                 if (int > 0) then
                    eff = process%mci_entry(i)%get_efficiency ()
                    if (eff > 0) then
                       den = den + int / eff
                    else
                       efficiency = 0
                       return
                    end if
                 end if
              end if
           end do
        end do
     end if
     if (den > 0) then
        efficiency = process%get_integral () / den
     else
        efficiency = 0
     end if
   end function process_get_efficiency_tot
 
 @ %def process_get_integral process_get_efficiency
 @ Let us call the ratio of the NLO and the LO result $\iota = I_{NLO} / I_{LO}$. Then
 usual error propagation gives
 \begin{equation*}
   \sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2
                    + \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2
                    = \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}.
 \end{equation*}
 <<Process: process: TBP>>=
   procedure :: get_correction => process_get_correction
   procedure :: get_correction_error => process_get_correction_error
 <<Process: procedures>>=
   function process_get_correction (process) result (ratio)
     real(default) :: ratio
     class(process_t), intent(in) :: process
     integer :: i_mci, i_component
     real(default) :: int_born, int_nlo
     int_nlo = zero
     int_born = process%mci_entry(1)%get_integral ()
     i_mci = 2
     do i_component = 2, size (process%component)
        if (process%component_can_be_integrated (i_component)) then
           int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral ()
           i_mci = i_mci + 1
        end if
     end do
     ratio = int_nlo / int_born * 100
   end function process_get_correction
 
   function process_get_correction_error (process) result (error)
     real(default) :: error
     class(process_t), intent(in) :: process
     real(default) :: int_born, sum_int_nlo
     real(default) :: err_born, err2
     integer :: i_mci, i_component
     sum_int_nlo = zero; err2 = zero
     int_born = process%mci_entry(1)%get_integral ()
     err_born = process%mci_entry(1)%get_error ()
     i_mci = 2
     do i_component = 2, size (process%component)
        if (process%component_can_be_integrated (i_component)) then
           sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral ()
           err2 = err2 + process%mci_entry(i_mci)%get_error()**2
           i_mci = i_mci + 1
        end if
     end do
     error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100
   end function process_get_correction_error
 
 @ %def process_get_correction process_get_correction_error
 @
 <<Process: process: TBP>>=
   procedure :: lab_is_cm => process_lab_is_cm
 <<Process: procedures>>=
   pure function process_lab_is_cm (process) result (lab_is_cm)
     logical :: lab_is_cm
     class(process_t), intent(in) :: process
     lab_is_cm = process%beam_config%lab_is_cm
     ! This asks beam_config for the frame
   end function process_lab_is_cm
 
 @ %def process_lab_is_cm
 @
 <<Process: process: TBP>>=
   procedure :: get_component_ptr => process_get_component_ptr
 <<Process: procedures>>=
   function process_get_component_ptr (process, i) result (component)
     type(process_component_t), pointer :: component
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i
     component => process%component(i)
   end function process_get_component_ptr
 
 @ %def process_get_component_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_qcd => process_get_qcd
 <<Process: procedures>>=
   function process_get_qcd (process) result (qcd)
     type(qcd_t) :: qcd
     class(process_t), intent(in) :: process
     qcd = process%config%get_qcd ()
   end function process_get_qcd
 
 @ %def process_get_qcd
 @
 <<Process: process: TBP>>=
   generic :: get_component_type => get_component_type_single
   procedure :: get_component_type_single => process_get_component_type_single
 <<Process: procedures>>=
   elemental function process_get_component_type_single &
      (process, i_component) result (comp_type)
     integer :: comp_type
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     comp_type = process%component(i_component)%component_type
   end function process_get_component_type_single
 
 @ %def process_get_component_type_single
 @
 <<Process: process: TBP>>=
   generic :: get_component_type => get_component_type_all
   procedure :: get_component_type_all => process_get_component_type_all
 <<Process: procedures>>=
   function process_get_component_type_all &
      (process) result (comp_type)
     integer, dimension(:), allocatable :: comp_type
     class(process_t), intent(in) :: process
     allocate (comp_type (size (process%component)))
     comp_type = process%component%component_type
   end function process_get_component_type_all
 
 @ %def process_get_component_type_all
 @
 <<Process: process: TBP>>=
   procedure :: get_component_i_terms => process_get_component_i_terms
 <<Process: procedures>>=
   function process_get_component_i_terms (process, i_component) result (i_term)
      integer, dimension(:), allocatable :: i_term
      class(process_t), intent(in) :: process
      integer, intent(in) :: i_component
      allocate (i_term (size (process%component(i_component)%i_term)))
      i_term = process%component(i_component)%i_term
   end function process_get_component_i_terms
 
 @ %def process_get_component_i_terms
 @
 <<Process: process: TBP>>=
   procedure :: get_n_allowed_born => process_get_n_allowed_born
 <<Process: procedures>>=
   function process_get_n_allowed_born (process, i_born) result (n_born)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_born
     integer :: n_born
     n_born = process%term(i_born)%n_allowed
   end function process_get_n_allowed_born
 
 @ %def process_get_n_allowed_born
 @ Workaround getter. Would be better to remove this.
 <<Process: process: TBP>>=
   procedure :: get_pcm_ptr => process_get_pcm_ptr
 <<Process: procedures>>=
   function process_get_pcm_ptr (process) result (pcm)
     class(pcm_t), pointer :: pcm
     class(process_t), intent(in), target :: process
     pcm => process%pcm
   end function process_get_pcm_ptr
 
 @ %def process_get_pcm_ptr
 <<Process: process: TBP>>=
   generic :: component_can_be_integrated => component_can_be_integrated_single
   generic :: component_can_be_integrated => component_can_be_integrated_all
   procedure :: component_can_be_integrated_single => process_component_can_be_integrated_single
 <<Process: procedures>>=
   function process_component_can_be_integrated_single (process, i_component) &
            result (active)
     logical :: active
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     logical :: combined_integration
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        combined_integration = pcm%settings%combined_integration
     class default
        combined_integration = .false.
     end select
     associate (component => process%component(i_component))
        active = component%can_be_integrated ()
        if (combined_integration) &
             active = active .and. component%component_type <= COMP_MASTER
     end associate
   end function process_component_can_be_integrated_single
 
 @ %def process_component_can_be_integrated_single
 @
 <<Process: process: TBP>>=
   procedure :: component_can_be_integrated_all => process_component_can_be_integrated_all
 <<Process: procedures>>=
   function process_component_can_be_integrated_all (process) result (val)
     logical, dimension(:), allocatable :: val
     class(process_t), intent(in) :: process
     integer :: i
     allocate (val (size (process%component)))
     do i = 1, size (process%component)
        val(i) = process%component_can_be_integrated (i)
     end do
   end function process_component_can_be_integrated_all
 
 @ %def process_component_can_be_integrated_all
 @
 <<Process: process: TBP>>=
   procedure :: reset_selected_cores => process_reset_selected_cores
 <<Process: procedures>>=
   pure subroutine process_reset_selected_cores (process)
     class(process_t), intent(inout) :: process
     process%pcm%component_selected = .false.
   end subroutine process_reset_selected_cores
 
 @ %def process_reset_selected_cores
 @
 <<Process: process: TBP>>=
   procedure :: select_components => process_select_components
 <<Process: procedures>>=
   pure subroutine process_select_components (process, indices)
     class(process_t), intent(inout) :: process
     integer, dimension(:), intent(in) :: indices
     associate (pcm => process%pcm)
       pcm%component_selected(indices) = .true.
     end associate
   end subroutine process_select_components
 
 @ %def process_select_components
 @
 <<Process: process: TBP>>=
   procedure :: component_is_selected => process_component_is_selected
 <<Process: procedures>>=
   pure function process_component_is_selected (process, index) result (val)
     logical :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: index
     associate (pcm => process%pcm)
       val = pcm%component_selected(index)
     end associate
   end function process_component_is_selected
 
 @ %def process_component_is_selected
 @
 <<Process: process: TBP>>=
   procedure :: get_coupling_powers => process_get_coupling_powers
 <<Process: procedures>>=
   pure subroutine process_get_coupling_powers (process, alpha_power, alphas_power)
     class(process_t), intent(in) :: process
     integer, intent(out) :: alpha_power, alphas_power
     call process%component(1)%config%get_coupling_powers (alpha_power, alphas_power)
   end subroutine process_get_coupling_powers
 
 @ %def process_get_coupling_powers
 @
 <<Process: process: TBP>>=
   procedure :: get_real_component => process_get_real_component
 <<Process: procedures>>=
   function process_get_real_component (process) result (i_real)
     integer :: i_real
     class(process_t), intent(in) :: process
     integer :: i_component
     type(process_component_def_t), pointer :: config => null ()
     i_real = 0
     do i_component = 1, size (process%component)
        config => process%get_component_def_ptr (i_component)
        if (config%get_nlo_type () == NLO_REAL) then
           i_real = i_component
           exit
        end if
     end do
   end function process_get_real_component
 
 @ %def process_get_real_component
 @
 <<Process: process: TBP>>=
   procedure :: extract_active_component_mci => process_extract_active_component_mci
 <<Process: procedures>>=
   function process_extract_active_component_mci (process) result (i_active)
     integer :: i_active
     class(process_t), intent(in) :: process
     integer :: i_mci, j, i_component, n_active
     call count_n_active ()
     if (n_active /= 1) i_active = 0
   contains
     subroutine count_n_active ()
        n_active = 0
        do i_mci = 1, size (process%mci_entry)
           associate (mci_entry => process%mci_entry(i_mci))
              do j = 1, size (mci_entry%i_component)
                 i_component = mci_entry%i_component(j)
                 associate (component => process%component (i_component))
                    if (component%can_be_integrated ()) then
                       i_active = i_mci
                       n_active = n_active + 1
                    end if
                 end associate
              end do
           end associate
        end do
     end subroutine count_n_active
   end function process_extract_active_component_mci
 
 @ %def process_extract_active_component_mci
 @
 <<Process: process: TBP>>=
   procedure :: uses_real_partition => process_uses_real_partition
 <<Process: procedures>>=
   function process_uses_real_partition (process) result (val)
      logical :: val
      class(process_t), intent(in) :: process
      val = any (process%mci_entry%real_partition_type /= REAL_FULL)
   end function process_uses_real_partition
 
 @ %def process_uses_real_partition
 @ Return the MD5 sums that summarize the process component
 definitions.  These values should be independent of parameters, beam
 details, expressions, etc.  They can be used for checking the
 integrity of a process when reusing an old event file.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_prc => process_get_md5sum_prc
 <<Process: procedures>>=
   function process_get_md5sum_prc (process, i_component) result (md5sum)
     character(32) :: md5sum
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     if (process%component(i_component)%active) then
        md5sum = process%component(i_component)%config%get_md5sum ()
     else
        md5sum = ""
     end if
   end function process_get_md5sum_prc
 
 @ %def process_get_md5sum_prc
 @ Return the MD5 sums that summarize the state of the MCI integrators.
 These values should encode all process data, integration and phase
 space configuration, etc., and the integration results.  They can thus
 be used for checking the integrity of an event-generation setup when
 reusing an old event file.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_mci => process_get_md5sum_mci
 <<Process: procedures>>=
   function process_get_md5sum_mci (process, i_mci) result (md5sum)
     character(32) :: md5sum
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     md5sum = process%mci_entry(i_mci)%get_md5sum ()
   end function process_get_md5sum_mci
 
 @ %def process_get_md5sum_mci
 @ Return the MD5 sum of the process configuration.  This should encode
 the process setup, data, and expressions, but no integration results.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_cfg => process_get_md5sum_cfg
 <<Process: procedures>>=
   function process_get_md5sum_cfg (process) result (md5sum)
     character(32) :: md5sum
     class(process_t), intent(in) :: process
     md5sum = process%config%md5sum
   end function process_get_md5sum_cfg
 
 @ %def process_get_md5sum_cfg
 @
 <<Process: process: TBP>>=
   procedure :: get_n_cores => process_get_n_cores
 <<Process: procedures>>=
   function process_get_n_cores (process) result (n)
     integer :: n
     class(process_t), intent(in) :: process
     n = process%pcm%n_cores
   end function process_get_n_cores
 
 @ %def process_get_n_cores
 @
 <<Process: process: TBP>>=
   procedure :: get_base_i_term => process_get_base_i_term
 <<Process: procedures>>=
   function process_get_base_i_term (process, i_component) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     i_term = process%component(i_component)%i_term(1)
   end function process_get_base_i_term
 
 @ %def process_get_base_i_term
 @
 <<Process: process: TBP>>=
   procedure :: get_core_term => process_get_core_term
 <<Process: procedures>>=
   function process_get_core_term (process, i_term) result (core)
     class(prc_core_t), pointer :: core
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_term
     integer :: i_core
     i_core = process%term(i_term)%i_core
     core => process%core_entry(i_core)%get_core_ptr ()
   end function process_get_core_term
 
 @ %def process_get_core_term
 @
 <<Process: process: TBP>>=
   procedure :: get_core_ptr => process_get_core_ptr
 <<Process: procedures>>=
   function process_get_core_ptr (process, i_core) result (core)
     class(prc_core_t), pointer :: core
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_core
     if (allocated (process%core_entry)) then
        core => process%core_entry(i_core)%get_core_ptr ()
     else
        core => null ()
     end if
   end function process_get_core_ptr
 
 @ %def process_get_core_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_term_ptr => process_get_term_ptr
 <<Process: procedures>>=
   function process_get_term_ptr (process, i) result (term)
     type(process_term_t), pointer :: term
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i
     term => process%term(i)
   end function process_get_term_ptr
 
 @ %def process_get_term_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_i_term => process_get_i_term
 <<Process: procedures>>=
   function process_get_i_term (process, i_core) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_core
     do i_term = 1, process%get_n_terms ()
        if (process%term(i_term)%i_core == i_core) return
     end do
     i_term = -1
   end function process_get_i_term
 
 @ %def process_get_i_term
 @
 <<Process: process: TBP>>=
   procedure :: get_i_core => process_get_i_core
 <<Process: procedures>>=
   integer function process_get_i_core (process, i_term) result (i_core)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_term
     i_core = process%term(i_term)%i_core
   end function process_get_i_core
 
 @ %def process_get_i_core
 @
 <<Process: process: TBP>>=
   procedure :: set_i_mci_work => process_set_i_mci_work
 <<Process: procedures>>=
   subroutine process_set_i_mci_work (process, i_mci)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     process%mci_entry(i_mci)%i_mci = i_mci
   end subroutine process_set_i_mci_work
 
 @ %def process_set_i_mci_work
 @
 <<Process: process: TBP>>=
   procedure :: get_i_mci_work => process_get_i_mci_work
 <<Process: procedures>>=
   pure function process_get_i_mci_work (process, i_mci) result (i_mci_work)
     integer :: i_mci_work
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     i_mci_work = process%mci_entry(i_mci)%i_mci
   end function process_get_i_mci_work
 
 @ %def process_get_i_mci_work
 @
 <<Process: process: TBP>>=
   procedure :: get_i_sub => process_get_i_sub
 <<Process: procedures>>=
   elemental function process_get_i_sub (process, i_term) result (i_sub)
     integer :: i_sub
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_term
     i_sub = process%term(i_term)%i_sub
   end function process_get_i_sub
 
 @ %def process_get_i_sub
 @
 <<Process: process: TBP>>=
   procedure :: get_i_term_virtual => process_get_i_term_virtual
 <<Process: procedures>>=
   elemental function process_get_i_term_virtual (process) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer :: i_component
     i_term = 0
     do i_component = 1, size (process%component)
        if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) &
             i_term = process%component(i_component)%i_term(1)
     end do
   end function process_get_i_term_virtual
 
 @ %def process_get_i_term_virtual
 @
 <<Process: process: TBP>>=
   generic :: component_is_active => component_is_active_single
   procedure :: component_is_active_single => process_component_is_active_single
 <<Process: procedures>>=
   elemental function process_component_is_active_single (process, i_comp) result (val)
     logical :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_comp
     val = process%component(i_comp)%is_active ()
   end function process_component_is_active_single
 
 @ %def process_component_is_active_single
 @
 <<Process: process: TBP>>=
   generic :: component_is_active => component_is_active_all
   procedure :: component_is_active_all => process_component_is_active_all
 <<Process: procedures>>=
   pure function process_component_is_active_all (process) result (val)
     logical, dimension(:), allocatable :: val
     class(process_t), intent(in) :: process
     allocate (val (size (process%component)))
     val = process%component%is_active ()
   end function process_component_is_active_all
 
 @ %def process_component_is_active_all
 @
 \subsection{Default iterations}
 If the user does not specify the passes and iterations for
 integration, we should be able to give reasonable defaults.  These
 depend on the process, therefore we implement the following procedures
 as methods of the process object.  The algorithm is not very
 sophisticated yet, it may be improved by looking at the process in
 more detail.
 
 We investigate only the first process component, assuming that it
 characterizes the complexity of the process reasonable well.
 
 The number of passes is limited to two: one for adaption, one for
 integration.
 <<Process: process: TBP>>=
   procedure :: get_n_pass_default => process_get_n_pass_default
   procedure :: adapt_grids_default => process_adapt_grids_default
   procedure :: adapt_weights_default => process_adapt_weights_default
 <<Process: procedures>>=
   function process_get_n_pass_default (process) result (n_pass)
     class(process_t), intent(in) :: process
     integer :: n_pass
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (n_eff)
     case (1)
        n_pass = 1
     case default
        n_pass = 2
     end select
   end function process_get_n_pass_default
 
   function process_adapt_grids_default (process, pass) result (flag)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     logical :: flag
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (n_eff)
     case (1)
        flag = .false.
     case default
        select case (pass)
        case (1);  flag = .true.
        case (2);  flag = .false.
        case default
           call msg_bug ("adapt grids default: impossible pass index")
        end select
     end select
   end function process_adapt_grids_default
 
   function process_adapt_weights_default (process, pass) result (flag)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     logical :: flag
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (n_eff)
     case (1)
        flag = .false.
     case default
        select case (pass)
        case (1);  flag = .true.
        case (2);  flag = .false.
        case default
           call msg_bug ("adapt weights default: impossible pass index")
        end select
     end select
   end function process_adapt_weights_default
 
 @ %def process_get_n_pass_default
 @ %def process_adapt_grids_default
 @ %def process_adapt_weights_default
 @ The number of iterations and calls per iteration depends on the
 number of outgoing particles.
 <<Process: process: TBP>>=
   procedure :: get_n_it_default => process_get_n_it_default
   procedure :: get_n_calls_default => process_get_n_calls_default
 <<Process: procedures>>=
   function process_get_n_it_default (process, pass) result (n_it)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     integer :: n_it
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (pass)
     case (1)
        select case (n_eff)
        case (1);   n_it = 1
        case (2);   n_it = 3
        case (3);   n_it = 5
        case (4:5); n_it = 10
        case (6);   n_it = 15
        case (7:);  n_it = 20
        end select
     case (2)
        select case (n_eff)
        case (:3);   n_it = 3
        case (4:);   n_it = 5
        end select
     end select
   end function process_get_n_it_default
 
   function process_get_n_calls_default (process, pass) result (n_calls)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     integer :: n_calls
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (pass)
     case (1)
        select case (n_eff)
        case (1);   n_calls =   100
        case (2);   n_calls =  1000
        case (3);   n_calls =  5000
        case (4);   n_calls = 10000
        case (5);   n_calls = 20000
        case (6:);  n_calls = 50000
        end select
     case (2)
        select case (n_eff)
        case (:3);  n_calls =  10000
        case (4);   n_calls =  20000
        case (5);   n_calls =  50000
        case (6);   n_calls = 100000
        case (7:);  n_calls = 200000
        end select
     end select
   end function process_get_n_calls_default
 
 @ %def process_get_n_it_default
 @ %def process_get_n_calls_default
 @
 \subsection{Constant process data}
 Manually set the Run ID (unit test only).
 <<Process: process: TBP>>=
   procedure :: set_run_id => process_set_run_id
 <<Process: procedures>>=
   subroutine process_set_run_id (process, run_id)
     class(process_t), intent(inout) :: process
     type(string_t), intent(in) :: run_id
     process%meta%run_id = run_id
   end subroutine process_set_run_id
 
 @ %def process_set_run_id
 @
 The following methods return basic process data that stay constant
 after initialization.
 
 The process and IDs.
 <<Process: process: TBP>>=
   procedure :: get_id => process_get_id
   procedure :: get_num_id => process_get_num_id
   procedure :: get_run_id => process_get_run_id
   procedure :: get_library_name => process_get_library_name
 <<Process: procedures>>=
   function process_get_id (process) result (id)
     class(process_t), intent(in) :: process
     type(string_t) :: id
     id = process%meta%id
   end function process_get_id
 
   function process_get_num_id (process) result (id)
     class(process_t), intent(in) :: process
     integer :: id
     id = process%meta%num_id
   end function process_get_num_id
 
   function process_get_run_id (process) result (id)
     class(process_t), intent(in) :: process
     type(string_t) :: id
     id = process%meta%run_id
   end function process_get_run_id
 
   function process_get_library_name (process) result (id)
     class(process_t), intent(in) :: process
     type(string_t) :: id
     id = process%meta%lib_name
   end function process_get_library_name
 
 @ %def process_get_id process_get_num_id
 @ %def process_get_run_id process_get_library_name
 @ The number of incoming particles.
 <<Process: process: TBP>>=
   procedure :: get_n_in => process_get_n_in
 <<Process: procedures>>=
   function process_get_n_in (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%config%n_in
   end function process_get_n_in
 
 @ %def process_get_n_in
 @ The number of MCI data sets.
 <<Process: process: TBP>>=
   procedure :: get_n_mci => process_get_n_mci
 <<Process: procedures>>=
   function process_get_n_mci (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%config%n_mci
   end function process_get_n_mci
 
 @ %def process_get_n_mci
 @ The number of process components, total.
 <<Process: process: TBP>>=
   procedure :: get_n_components => process_get_n_components
 <<Process: procedures>>=
   function process_get_n_components (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%meta%n_components
   end function process_get_n_components
 
 @ %def process_get_n_components
 @ The number of process terms, total.
 <<Process: process: TBP>>=
   procedure :: get_n_terms => process_get_n_terms
 <<Process: procedures>>=
   function process_get_n_terms (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%config%n_terms
   end function process_get_n_terms
 
 @ %def process_get_n_terms
 @ Return the indices of the components that belong to a
 specific MCI entry.
 <<Process: process: TBP>>=
   procedure :: get_i_component => process_get_i_component
 <<Process: procedures>>=
   subroutine process_get_i_component (process, i_mci, i_component)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     integer, dimension(:), intent(out), allocatable :: i_component
     associate (mci_entry => process%mci_entry(i_mci))
       allocate (i_component (size (mci_entry%i_component)))
       i_component = mci_entry%i_component
     end associate
   end subroutine process_get_i_component
 
 @ %def process_get_i_component
 @ Return the ID of a specific component.
 <<Process: process: TBP>>=
   procedure :: get_component_id => process_get_component_id
 <<Process: procedures>>=
   function process_get_component_id (process, i_component) result (id)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     type(string_t) :: id
     id = process%meta%component_id(i_component)
   end function process_get_component_id
 
 @ %def process_get_component_id
 @ Return a pointer to the definition of a specific component.
 <<Process: process: TBP>>=
   procedure :: get_component_def_ptr => process_get_component_def_ptr
 <<Process: procedures>>=
   function process_get_component_def_ptr (process, i_component) result (ptr)
     type(process_component_def_t), pointer :: ptr
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     ptr => process%config%process_def%get_component_def_ptr (i_component)
   end function process_get_component_def_ptr
 
 @ %def process_get_component_def_ptr
 @ These procedures extract and restore (by transferring the
 allocation) the process core.  This is useful for changing process
 parameters from outside this module.
 <<Process: process: TBP>>=
   procedure :: extract_core => process_extract_core
   procedure :: restore_core => process_restore_core
 <<Process: procedures>>=
   subroutine process_extract_core (process, i_term, core)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_term
     class(prc_core_t), intent(inout), allocatable :: core
     integer :: i_core
     i_core = process%term(i_term)%i_core
     call move_alloc (from = process%core_entry(i_core)%core, to = core)
   end subroutine process_extract_core
 
   subroutine process_restore_core (process, i_term, core)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_term
     class(prc_core_t), intent(inout), allocatable :: core
     integer :: i_core
     i_core = process%term(i_term)%i_core
     call move_alloc (from = core, to = process%core_entry(i_core)%core)
   end subroutine process_restore_core
 
 @ %def process_extract_core
 @ %def process_restore_core
 @ The block of process constants.
 <<Process: process: TBP>>=
   procedure :: get_constants => process_get_constants
 <<Process: procedures>>=
   function process_get_constants (process, i_core) result (data)
     type(process_constants_t) :: data
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_core
     data = process%core_entry(i_core)%core%data
   end function process_get_constants
 
 @ %def process_get_constants
 @
 <<Process: process: TBP>>=
   procedure :: get_config => process_get_config
 <<Process: procedures>>=
   function process_get_config (process) result (config)
     type(process_config_data_t) :: config
     class(process_t), intent(in) :: process
     config = process%config
   end function process_get_config
 
 @ %def process_get_config
 @
 Construct an MD5 sum for the constant data, including the NLO type.
 
 For the NLO type [[NLO_MISMATCH]], we pretend that this was
 [[NLO_SUBTRACTION]] instead.
 
 TODO wk 2018: should not depend explicitly on NLO data.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_constants => process_get_md5sum_constants
 <<Process: procedures>>=
   function process_get_md5sum_constants (process, i_component, &
      type_string, nlo_type) result (this_md5sum)
     character(32) :: this_md5sum
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     type(string_t), intent(in) :: type_string
     integer, intent(in) :: nlo_type
     type(process_constants_t) :: data
     integer :: unit
     call process%env%fill_process_constants (process%meta%id, i_component, data)
     unit = data%fill_unit_for_md5sum (.false.)
     write (unit, '(A)') char(type_string)
     select case (nlo_type)
     case (NLO_MISMATCH)
        write (unit, '(I0)')  NLO_SUBTRACTION
     case default
        write (unit, '(I0)')  nlo_type
     end select
     rewind (unit)
     this_md5sum = md5sum (unit)
     close (unit)
   end function process_get_md5sum_constants
 
 @ %def process_get_md5sum_constants
 @ Return the set of outgoing flavors that are associated with a particular
 term. We deduce this from the effective interaction.
 <<Process: process: TBP>>=
   procedure :: get_term_flv_out => process_get_term_flv_out
 <<Process: procedures>>=
   subroutine process_get_term_flv_out (process, i_term, flv)
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_term
     type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
     type(interaction_t), pointer :: int
     int => process%term(i_term)%int_eff
     if (.not. associated (int))  int => process%term(i_term)%int
     call interaction_get_flv_out (int, flv)
   end subroutine process_get_term_flv_out
 
 @ %def process_get_term_flv_out
 @ Return true if there is any unstable particle in any of the process
 terms.  We decide this based on the provided model instance, not the
 one that is stored in the process object.
 <<Process: process: TBP>>=
   procedure :: contains_unstable => process_contains_unstable
 <<Process: procedures>>=
   function process_contains_unstable (process, model) result (flag)
     class(process_t), intent(in) :: process
     class(model_data_t), intent(in), target :: model
     logical :: flag
     integer :: i_term
     type(flavor_t), dimension(:,:), allocatable :: flv
     flag = .false.
     do i_term = 1, process%get_n_terms ()
        call process%get_term_flv_out (i_term, flv)
        call flv%set_model (model)
        flag = .not. all (flv%is_stable ())
        deallocate (flv)
        if (flag)  return
     end do
   end function process_contains_unstable
 
 @ %def process_contains_unstable
 @ The nominal process energy.
 <<Process: process: TBP>>=
   procedure :: get_sqrts => process_get_sqrts
 <<Process: procedures>>=
   function process_get_sqrts (process) result (sqrts)
     class(process_t), intent(in) :: process
     real(default) :: sqrts
     sqrts = process%beam_config%data%get_sqrts ()
   end function process_get_sqrts
 
 @ %def process_get_sqrts
 @ The lab-frame beam energy/energies..
 <<Process: process: TBP>>=
   procedure :: get_energy => process_get_energy
 <<Process: procedures>>=
   function process_get_energy (process) result (e)
     class(process_t), intent(in) :: process
     real(default), dimension(:), allocatable :: e
     e = process%beam_config%data%get_energy ()
   end function process_get_energy
 
 @ %def process_get_energy
 @ The beam polarization in case of simple degrees.
 <<Process: process: TBP>>=
   procedure :: get_polarization => process_get_polarization
 <<Process: procedures>>=
   function process_get_polarization (process) result (pol)
     class(process_t), intent(in) :: process
     real(default), dimension(2) :: pol
     pol = process%beam_config%data%get_polarization ()
   end function process_get_polarization
 
 @ %def process_get_polarization
 @
 <<Process: process: TBP>>=
   procedure :: get_meta => process_get_meta
 <<Process: procedures>>=
   function process_get_meta (process) result (meta)
     type(process_metadata_t) :: meta
     class(process_t), intent(in) :: process
     meta = process%meta
   end function process_get_meta
 
 @ %def process_get_meta
 <<Process: process: TBP>>=
   procedure :: has_matrix_element => process_has_matrix_element
 <<Process: procedures>>=
   function process_has_matrix_element (process, i, is_term_index) result (active)
     logical :: active
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: i
     logical, intent(in), optional :: is_term_index
     integer :: i_component
     logical :: is_term
     is_term = .false.
     if (present (i)) then
        if (present (is_term_index)) is_term = is_term_index
        if (is_term) then
           i_component = process%term(i)%i_component
        else
           i_component = i
        end if
        active = process%component(i_component)%active
     else
        active = any (process%component%active)
     end if
   end function process_has_matrix_element
 
 @ %def process_has_matrix_element
 @ Pointer to the beam data object.
 <<Process: process: TBP>>=
   procedure :: get_beam_data_ptr => process_get_beam_data_ptr
 <<Process: procedures>>=
   function process_get_beam_data_ptr (process) result (beam_data)
     class(process_t), intent(in), target :: process
     type(beam_data_t), pointer :: beam_data
     beam_data => process%beam_config%data
   end function process_get_beam_data_ptr
 
 @ %def process_get_beam_data_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_beam_config => process_get_beam_config
 <<Process: procedures>>=
   function process_get_beam_config (process) result (beam_config)
     type(process_beam_config_t) :: beam_config
     class(process_t), intent(in) :: process
     beam_config = process%beam_config
   end function process_get_beam_config
 
 @ %def process_get_beam_config
 @
 <<Process: process: TBP>>=
   procedure :: get_beam_config_ptr => process_get_beam_config_ptr
 <<Process: procedures>>=
   function process_get_beam_config_ptr (process) result (beam_config)
     type(process_beam_config_t), pointer :: beam_config
     class(process_t), intent(in), target :: process
     beam_config => process%beam_config
   end function process_get_beam_config_ptr
 
 @ %def process_get_beam_config_ptr
 @ Get the PDF set currently in use, if any.
 <<Process: process: TBP>>=
   procedure :: get_pdf_set => process_get_pdf_set
 <<Process: procedures>>=
   function process_get_pdf_set (process) result (pdf_set)
     class(process_t), intent(in) :: process
     integer :: pdf_set
     pdf_set = process%beam_config%get_pdf_set ()
   end function process_get_pdf_set
 
 @ %def process_get_pdf_set
 @
 <<Process: process: TBP>>=
   procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs
 <<Process: procedures>>=
   function process_pcm_contains_pdfs (process) result (has_pdfs)
     logical :: has_pdfs
     class(process_t), intent(in) :: process
     has_pdfs = process%pcm%has_pdfs
   end function process_pcm_contains_pdfs
 
 @ %def process_pcm_contains_pdfs
 @ Get the beam spectrum file currently in use, if any.
 <<Process: process: TBP>>=
   procedure :: get_beam_file => process_get_beam_file
 <<Process: procedures>>=
   function process_get_beam_file (process) result (file)
     class(process_t), intent(in) :: process
     type(string_t) :: file
     file = process%beam_config%get_beam_file ()
   end function process_get_beam_file
 
 @ %def process_get_beam_file
 @ Pointer to the process variable list.
 <<Process: process: TBP>>=
   procedure :: get_var_list_ptr => process_get_var_list_ptr
 <<Process: procedures>>=
   function process_get_var_list_ptr (process) result (ptr)
     class(process_t), intent(in), target :: process
     type(var_list_t), pointer :: ptr
     ptr => process%env%get_var_list_ptr ()
   end function process_get_var_list_ptr
 
 @ %def process_get_var_list_ptr
 @ Pointer to the common model.
 <<Process: process: TBP>>=
   procedure :: get_model_ptr => process_get_model_ptr
 <<Process: procedures>>=
   function process_get_model_ptr (process) result (ptr)
     class(process_t), intent(in) :: process
     class(model_data_t), pointer :: ptr
     ptr => process%config%model
   end function process_get_model_ptr
 
 @ %def process_get_model_ptr
 @ Use the embedded RNG factory to spawn a new random-number generator
 instance.  (This modifies the state of the factory.)
 <<Process: process: TBP>>=
   procedure :: make_rng => process_make_rng
 <<Process: procedures>>=
   subroutine process_make_rng (process, rng)
     class(process_t), intent(inout) :: process
     class(rng_t), intent(out), allocatable :: rng
     if (allocated (process%rng_factory)) then
        call process%rng_factory%make (rng)
     else
        call msg_bug ("Process: make rng: factory not allocated")
     end if
   end subroutine process_make_rng
 
 @ %def process_make_rng
 @
 \subsection{Compute an amplitude}
 Each process variant should allow for computing an amplitude value
 directly, without generating a process instance.
 
 The process component is selected by the index [[i]].  The term within the
 process component is selected by [[j]].  The momentum
 combination is transferred as the array [[p]].  The function sets the specific
 quantum state via the indices of a flavor [[f]], helicity [[h]], and color
 [[c]] combination.  Each index refers to the list of flavor, helicity, and
 color states, respectively, as stored in the process data.
 
 Optionally, we may set factorization and renormalization scale.  If unset, the
 partonic c.m.\ energy is inserted.
 
 The function checks arguments for validity.
 For invalid arguments (quantum states), we return zero.
 <<Process: process: TBP>>=
   procedure :: compute_amplitude => process_compute_amplitude
 <<Process: procedures>>=
   function process_compute_amplitude &
        (process, i_core, i, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced) &
        result (amp)
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_core
     integer, intent(in) :: i, j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in), optional :: fac_scale, ren_scale
     real(default), intent(in), allocatable, optional :: alpha_qcd_forced
     real(default) :: fscale, rscale
     real(default), allocatable :: aqcd_forced
     complex(default) :: amp
     class(prc_core_t), pointer :: core
     amp = 0
     if (0 < i .and. i <= process%meta%n_components) then
        if (process%component(i)%active) then
           associate (core => process%core_entry(i_core)%core)
             associate (data => core%data)
               if (size (p) == data%n_in + data%n_out &
                    .and. 0 < f .and. f <= data%n_flv &
                    .and. 0 < h .and. h <= data%n_hel &
                    .and. 0 < c .and. c <= data%n_col) then
                  if (present (fac_scale)) then
                     fscale = fac_scale
                  else
                     fscale = sum (p(data%n_in+1:)) ** 1
                  end if
                  if (present (ren_scale)) then
                     rscale = ren_scale
                  else
                     rscale = fscale
                  end if
                  if (present (alpha_qcd_forced)) then
                     if (allocated (alpha_qcd_forced)) &
                          allocate (aqcd_forced, source = alpha_qcd_forced)
                  end if
                  amp = core%compute_amplitude (j, p, f, h, c, &
                       fscale, rscale, aqcd_forced)
               end if
             end associate
           end associate
        else
           amp = 0
        end if
     end if
   end function process_compute_amplitude
 
 @ %def process_compute_amplitude
 @ Sanity check for the process library.  We abort the program if it
 has changed after process initialization.
 <<Process: process: TBP>>=
   procedure :: check_library_sanity => process_check_library_sanity
 <<Process: procedures>>=
   subroutine process_check_library_sanity (process)
     class(process_t), intent(in) :: process
     call process%env%check_lib_sanity (process%meta)
   end subroutine process_check_library_sanity
 
 @ %def process_check_library_sanity
 @ Reset the association to a process library.
 <<Process: process: TBP>>=
   procedure :: reset_library_ptr => process_reset_library_ptr
 <<Process: procedures>>=
   subroutine process_reset_library_ptr (process)
     class(process_t), intent(inout) :: process
     call process%env%reset_lib_ptr ()
   end subroutine process_reset_library_ptr
 
 @ %def process_reset_library_ptr
 @
 <<Process: process: TBP>>=
   procedure :: set_component_type => process_set_component_type
 <<Process: procedures>>=
   subroutine process_set_component_type (process, i_component, i_type)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_component, i_type
     process%component(i_component)%component_type = i_type
   end subroutine process_set_component_type
 
 @ %def process_set_component_type
 @
 <<Process: process: TBP>>=
   procedure :: set_counter_mci_entry => process_set_counter_mci_entry
 <<Process: procedures>>=
   subroutine process_set_counter_mci_entry (process, i_mci, counter)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(process_counter_t), intent(in) :: counter
     process%mci_entry(i_mci)%counter = counter
   end subroutine process_set_counter_mci_entry
 
 @ %def process_set_counter_mci_entry
 @ This is for suppression of numerical noise in the integration results
 stored in the [[process_mci_entry]] type. As the error and efficiency
 enter the MD5 sum, we recompute it.
 <<Process: process: TBP>>=
   procedure :: pacify => process_pacify
 <<Process: procedures>>=
   subroutine process_pacify (process, efficiency_reset, error_reset)
     class(process_t), intent(inout) :: process
     logical, intent(in), optional :: efficiency_reset, error_reset
     logical :: eff_reset, err_reset
     integer :: i
     eff_reset = .false.
     err_reset = .false.
     if (present (efficiency_reset))  eff_reset = efficiency_reset
     if (present (error_reset))  err_reset = error_reset
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           call process%mci_entry(i)%results%pacify (efficiency_reset)
           if (allocated (process%mci_entry(i)%mci)) then
              associate (mci => process%mci_entry(i)%mci)
                if (process%mci_entry(i)%mci%error_known &
                     .and. err_reset) &
                     mci%error = 0
                if (process%mci_entry(i)%mci%efficiency_known &
                     .and. eff_reset)  &
                     mci%efficiency = 1
                call mci%pacify (efficiency_reset, error_reset)
                call mci%compute_md5sum ()
              end associate
           end if
        end do
     end if
   end subroutine process_pacify
 
 @ %def process_pacify
 @ The following methods are used only in the unit tests; the access
 process internals directly that would otherwise be hidden.
 <<Process: process: TBP>>=
   procedure :: test_allocate_sf_channels
   procedure :: test_set_component_sf_channel
   procedure :: test_get_mci_ptr
 <<Process: procedures>>=
   subroutine test_allocate_sf_channels (process, n)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: n
     call process%beam_config%allocate_sf_channels (n)
   end subroutine test_allocate_sf_channels
 
   subroutine test_set_component_sf_channel (process, c)
     class(process_t), intent(inout) :: process
     integer, dimension(:), intent(in) :: c
     call process%component(1)%phs_config%set_sf_channel (c)
   end subroutine test_set_component_sf_channel
 
   subroutine test_get_mci_ptr (process, mci)
     class(process_t), intent(in), target :: process
     class(mci_t), intent(out), pointer :: mci
     mci => process%mci_entry(1)%mci
   end subroutine test_get_mci_ptr
 
 @ %def test_allocate_sf_channels
 @ %def test_set_component_sf_channel
 @ %def test_get_mci_ptr
 @
 <<Process: process: TBP>>=
   procedure :: init_mci_work => process_init_mci_work
 <<Process: procedures>>=
   subroutine process_init_mci_work (process, mci_work, i)
     class(process_t), intent(in), target :: process
     type(mci_work_t), intent(out) :: mci_work
     integer, intent(in) :: i
     call mci_work%init (process%mci_entry(i))
   end subroutine process_init_mci_work
 
 @ %def process_init_mci_work
 @
 Prepare the process core with type [[test_me]], or otherwise the externally
 provided [[type_string]] version.  The toy dispatchers as a procedure
 argument come handy, knowing that we need to support only the [[test_me]] and
 [[template]] matrix-element types.
 <<Process: process: TBP>>=
   procedure :: setup_test_cores => process_setup_test_cores
 <<Process: procedures>>=
   subroutine process_setup_test_cores (process, type_string)
     class(process_t), intent(inout) :: process
     class(prc_core_t), allocatable :: core
     type(string_t), intent(in), optional :: type_string
     if (present (type_string)) then
        select case (char (type_string))
        case ("template")
           call process%setup_cores (dispatch_template_core)
        case ("test_me")
           call process%setup_cores (dispatch_test_me_core)
        case default
           call msg_bug ("process setup test cores: unsupported type string")
        end select
     else
        call process%setup_cores (dispatch_test_me_core)
     end if
   end subroutine process_setup_test_cores
 
   subroutine dispatch_test_me_core (core, core_def, model, &
        helicity_selection, qcd, use_color_factors, has_beam_pol)
     use prc_test_core, only: test_t
     class(prc_core_t), allocatable, intent(inout) :: core
     class(prc_core_def_t), intent(in) :: core_def
     class(model_data_t), intent(in), target, optional :: model
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     type(qcd_t), intent(in), optional :: qcd
     logical, intent(in), optional :: use_color_factors
     logical, intent(in), optional :: has_beam_pol
     allocate (test_t :: core)
   end subroutine dispatch_test_me_core
 
   subroutine dispatch_template_core (core, core_def, model, &
        helicity_selection, qcd, use_color_factors, has_beam_pol)
     use prc_template_me, only: prc_template_me_t
     class(prc_core_t), allocatable, intent(inout) :: core
     class(prc_core_def_t), intent(in) :: core_def
     class(model_data_t), intent(in), target, optional :: model
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     type(qcd_t), intent(in), optional :: qcd
     logical, intent(in), optional :: use_color_factors
     logical, intent(in), optional :: has_beam_pol
     allocate (prc_template_me_t :: core)
     select type (core)
     type is (prc_template_me_t)
        call core%set_parameters (model)
     end select
   end subroutine dispatch_template_core
 
 @ %def process_setup_test_cores
 @
 <<Process: process: TBP>>=
   procedure :: get_connected_states => process_get_connected_states
 <<Process: procedures>>=
   function process_get_connected_states (process, i_component, &
          connected_terms) result (connected)
     type(connected_state_t), dimension(:), allocatable :: connected
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     type(connected_state_t), dimension(:), intent(in) :: connected_terms
     integer :: i, i_conn
     integer :: n_conn
     n_conn = 0
     do i = 1, process%get_n_terms ()
        if (process%term(i)%i_component == i_component) then
           n_conn = n_conn + 1
        end if
     end do
     allocate (connected (n_conn))
     i_conn = 1
     do i = 1, process%get_n_terms ()
        if (process%term(i)%i_component == i_component) then
           connected (i_conn) = connected_terms(i)
           i_conn = i_conn + 1
        end if
     end do
   end function process_get_connected_states
 
 @ %def process_get_connected_states
 @
 \subsection{NLO specifics}
 These subroutines (and the NLO specific properties they work on) could
 potentially be moved to [[pcm_nlo_t]] and used more generically in
 [[process_t]] with an appropriate interface in [[pcm_t]]
 
 TODO wk 2018: This is used only by event initialization, which deals with an incomplete
 process object.
 <<Process: process: TBP>>=
   procedure :: init_nlo_settings => process_init_nlo_settings
 <<Process: procedures>>=
   subroutine process_init_nlo_settings (process, var_list)
     class(process_t), intent(inout) :: process
     type(var_list_t), intent(in), target :: var_list
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        call pcm%init_nlo_settings (var_list)
        if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) &
               call pcm%settings%write ()
     class default
        call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!")
     end select
   end subroutine process_init_nlo_settings
 
 @ %def process_init_nlo_settings
 @
 <<Process: process: TBP>>=
   generic :: get_nlo_type_component => get_nlo_type_component_single
   procedure :: get_nlo_type_component_single => process_get_nlo_type_component_single
 <<Process: procedures>>=
   elemental function process_get_nlo_type_component_single (process, i_component) result (val)
     integer :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     val = process%component(i_component)%get_nlo_type ()
   end function process_get_nlo_type_component_single
 
 @ %def process_get_nlo_type_component_single
 @
 <<Process: process: TBP>>=
   generic :: get_nlo_type_component => get_nlo_type_component_all
   procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all
 <<Process: procedures>>=
   pure function process_get_nlo_type_component_all (process) result (val)
     integer, dimension(:), allocatable :: val
     class(process_t), intent(in) :: process
     allocate (val (size (process%component)))
     val = process%component%get_nlo_type ()
   end function process_get_nlo_type_component_all
 
 @ %def process_get_nlo_type_component_all
 @
 <<Process: process: TBP>>=
   procedure :: is_nlo_calculation => process_is_nlo_calculation
 <<Process: procedures>>=
   function process_is_nlo_calculation (process) result (nlo)
     logical :: nlo
     class(process_t), intent(in) :: process
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        nlo = .true.
     class default
        nlo = .false.
     end select
   end function process_is_nlo_calculation
 
 @ %def process_is_nlo_calculation
 @
 <<Process: process: TBP>>=
   procedure :: get_negative_sf => process_get_negative_sf
 <<Process: procedures>>=
   function process_get_negative_sf (process) result (neg_sf)
     logical :: neg_sf
     class(process_t), intent(in) :: process
     neg_sf = process%config%process_def%get_negative_sf ()
   end function process_get_negative_sf
 
 @ %def process_get_negative_sf
 @
 <<Process: process: TBP>>=
   procedure :: is_combined_nlo_integration &
        => process_is_combined_nlo_integration
 <<Process: procedures>>=
   function process_is_combined_nlo_integration (process) result (combined)
     logical :: combined
     class(process_t), intent(in) :: process
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        combined = pcm%settings%combined_integration
     class default
        combined = .false.
     end select
   end function process_is_combined_nlo_integration
 
 @ %def process_is_combined_nlo_integration
 @
 <<Process: process: TBP>>=
   procedure :: component_is_real_finite => process_component_is_real_finite
 <<Process: procedures>>=
   pure function process_component_is_real_finite (process, i_component) &
          result (val)
     logical :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     val = process%component(i_component)%component_type == COMP_REAL_FIN
   end function process_component_is_real_finite
 
 @ %def process_component_is_real_finite
 @ Return nlo data of a process component
 <<Process: process: TBP>>=
   procedure :: get_component_nlo_type => process_get_component_nlo_type
 <<Process: procedures>>=
   elemental function process_get_component_nlo_type (process, i_component) &
            result (nlo_type)
     integer :: nlo_type
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     nlo_type = process%component(i_component)%config%get_nlo_type ()
   end function process_get_component_nlo_type
 
 @ %def process_get_component_nlo_type
 @ Return a pointer to the core that belongs to a component.
 <<Process: process: TBP>>=
   procedure :: get_component_core_ptr => process_get_component_core_ptr
 <<Process: procedures>>=
   function process_get_component_core_ptr (process, i_component) result (core)
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_component
     class(prc_core_t), pointer :: core
     integer :: i_core
     i_core = process%pcm%get_i_core(i_component)
     core => process%core_entry(i_core)%core
   end function process_get_component_core_ptr
 
 @ %def process_get_component_core_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_component_associated_born &
             => process_get_component_associated_born
 <<Process: procedures>>=
   function process_get_component_associated_born (process, i_component) &
            result (i_born)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     integer :: i_born
     i_born = process%component(i_component)%config%get_associated_born ()
   end function process_get_component_associated_born
 
 @ %def process_get_component_associated_born
 @
 <<Process: process: TBP>>=
   procedure :: get_first_real_component => process_get_first_real_component
 <<Process: procedures>>=
   function process_get_first_real_component (process) result (i_real)
      integer :: i_real
      class(process_t), intent(in) :: process
      i_real = process%component(1)%config%get_associated_real ()
   end function process_get_first_real_component
 
 @ %def process_get_first_real_component
 @
 <<Process: process: TBP>>=
   procedure :: get_first_real_term => process_get_first_real_term
 <<Process: procedures>>=
   function process_get_first_real_term (process) result (i_real)
      integer :: i_real
      class(process_t), intent(in) :: process
      integer :: i_component, i_term
      i_component = process%component(1)%config%get_associated_real ()
      i_real = 0
      do i_term = 1, size (process%term)
         if (process%term(i_term)%i_component == i_component) then
            i_real = i_term
            exit
         end if
      end do
      if (i_real == 0) call msg_fatal ("Did not find associated real term!")
   end function process_get_first_real_term
 
 @ %def process_get_first_real_term
 @
 <<Process: process: TBP>>=
   procedure :: get_associated_real_fin => process_get_associated_real_fin
 <<Process: procedures>>=
   elemental function process_get_associated_real_fin (process, i_component) result (i_real)
      integer :: i_real
      class(process_t), intent(in) :: process
      integer, intent(in) :: i_component
      i_real = process%component(i_component)%config%get_associated_real_fin ()
   end function process_get_associated_real_fin
 
 @ %def process_get_associated_real_fin
 @
 <<Process: process: TBP>>=
   procedure :: select_i_term => process_select_i_term
 <<Process: procedures>>=
   pure function process_select_i_term (process, i_mci) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     integer :: i_component, i_sub
     i_component = process%mci_entry(i_mci)%i_component(1)
     i_term = process%component(i_component)%i_term(1)
     i_sub = process%term(i_term)%i_sub
     if (i_sub > 0) &
        i_term = process%term(i_sub)%i_term_global
   end function process_select_i_term
 
 @ %def process_select_i_term
 @ Would be better to do this at the level of the writer of the core but
 one has to bring NLO information there.
 <<Process: process: TBP>>=
   procedure :: prepare_any_external_code &
      => process_prepare_any_external_code
 <<Process: procedures>>=
   subroutine process_prepare_any_external_code (process)
     class(process_t), intent(inout), target :: process
     integer :: i
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "process_prepare_external_code")
     associate (pcm => process%pcm)
       do i = 1, pcm%n_cores
          call pcm%prepare_any_external_code ( &
               process%core_entry(i), i, &
               process%get_library_name (), &
               process%config%model, &
               process%env%get_var_list_ptr ())
       end do
     end associate
   end subroutine process_prepare_any_external_code
 
 @ %def process_prepare_any_external_code
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process config}
 <<[[process_config.f90]]>>=
 <<File header>>
 
 module process_config
 
 <<Use kinds>>
 <<Use strings>>
   use format_utils, only: write_separator
   use io_units
   use md5
   use os_interface
   use diagnostics
   use sf_base
   use sf_mappings
   use mappings, only: mapping_defaults_t
   use phs_forests, only: phs_parameters_t
   use sm_qcd
   use physics_defs
   use integration_results
   use model_data
   use models
   use interactions
   use quantum_numbers
   use flavors
   use helicities
   use colors
   use rng_base
   use state_matrices
   use process_libraries
   use process_constants
   use prc_core
   use prc_external
   use prc_openloops, only: prc_openloops_t
   use prc_threshold, only: prc_threshold_t
   use beams
   use dispatch_beams, only: dispatch_qcd
   use mci_base
   use beam_structures
   use phs_base
   use variables
   use expr_base
   use blha_olp_interfaces, only: prc_blha_t
 
 <<Standard module head>>
 
 <<Process config: public>>
 
 <<Process config: parameters>>
 
 <<Process config: types>>
 
 contains
 
 <<Process config: procedures>>
 
 end module process_config
 @ %def process_config
 @ Identifiers for the NLO setup.
 <<Process config: parameters>>=
   integer, parameter, public :: COMP_DEFAULT = 0
   integer, parameter, public :: COMP_REAL_FIN = 1
   integer, parameter, public :: COMP_MASTER = 2
   integer, parameter, public :: COMP_VIRT = 3
   integer, parameter, public :: COMP_REAL = 4
   integer, parameter, public :: COMP_REAL_SING = 5
   integer, parameter, public :: COMP_MISMATCH = 6
   integer, parameter, public :: COMP_PDF = 7
   integer, parameter, public :: COMP_SUB = 8
   integer, parameter, public :: COMP_RESUM = 9
 
 @
 \subsection{Output selection flags}
 We declare a number of identifiers for write methods, so they only
 displays selected parts.  The identifiers can be supplied to the [[vlist]]
 array argument of the standard F2008 derived-type writer call.
 <<Process config: parameters>>=
   integer, parameter, public :: F_PACIFY = 1
   integer, parameter, public :: F_SHOW_VAR_LIST = 11
   integer, parameter, public :: F_SHOW_EXPRESSIONS = 12
   integer, parameter, public :: F_SHOW_LIB = 13
   integer, parameter, public :: F_SHOW_MODEL = 14
   integer, parameter, public :: F_SHOW_QCD = 15
   integer, parameter, public :: F_SHOW_OS_DATA = 16
   integer, parameter, public :: F_SHOW_RNG = 17
   integer, parameter, public :: F_SHOW_BEAMS = 18
 @ %def SHOW_VAR_LIST
 @ %def SHOW_EXPRESSIONS
 @
 This is a simple function that returns true if a flag value is present in
 [[v_list]], but not its negative.  If neither is present, it returns
 [[default]].
 <<Process config: public>>=
   public :: flagged
 <<Process config: procedures>>=
   function flagged (v_list, id, def) result (flag)
     logical :: flag
     integer, dimension(:), intent(in) :: v_list
     integer, intent(in) :: id
     logical, intent(in), optional :: def
     logical :: default_result
     default_result = .false.;  if (present (def))  default_result = def
     if (default_result) then
        flag = all (v_list /= -id)
     else
        flag = all (v_list /= -id) .and. any (v_list == id)
     end if
   end function flagged
 
 @ %def flagged
 @
 Related: if flag is set (unset), append [[value]] (its negative) to the
 [[v_list]], respectively.  [[v_list]] must be allocated.
 <<Process config: public>>=
   public :: set_flag
 <<Process config: procedures>>=
   subroutine set_flag (v_list, value, flag)
     integer, dimension(:), intent(inout), allocatable :: v_list
     integer, intent(in) :: value
     logical, intent(in), optional :: flag
     if (present (flag)) then
        if (flag) then
           v_list = [v_list, value]
        else
           v_list = [v_list, -value]
        end if
     end if
   end subroutine set_flag
 
 @ %def set_flag
 @
 \subsection{Generic configuration data}
 This information concerns physical and technical properties of the
 process.  It is fixed upon initialization, using data from the
 process specification and the variable list.
 
 The number [[n_in]] is the number of incoming beam particles,
 simultaneously the number of incoming partons, 1 for a decay and 2 for
 a scattering process. (The number of outgoing partons may depend on
 the process component.)
 
 The number [[n_components]] is the number of components that constitute
 the current process.
 
 The number [[n_terms]] is the number of distinct contributions to the
 scattering matrix that constitute the current process.  Each component
 may generate several terms.
 
 The number [[n_mci]] is the number of independent MC
 integration configurations that this process uses.  Distinct process
 components that share a MCI configuration may be combined pointwise.
 (Nevertheless, a given MC variable set may correspond to several
 ``nearby'' kinematical configurations.)  This is also the number of
 distinct sampling-function results that this process can generate.
 Process components that use distinct variable sets are added only once
 after an integration pass has completed.
 
 The [[model]] pointer identifies the physics model and its
 parameters.  This is a pointer to an external object.
 
 Various [[parse_node_t]] objects are taken from the SINDARIN input.
 They encode expressions for evaluating cuts and scales.  The
 workspaces for evaluating those expressions are set up in the
 [[effective_state]] subobjects.  Note that these are really pointers,
 so the actual nodes are not stored inside the process object.
 
 The [[md5sum]] is taken and used to verify the process configuration
 when re-reading data from file.
 <<Process config: public>>=
   public :: process_config_data_t
 <<Process config: types>>=
   type :: process_config_data_t
      class(process_def_t), pointer :: process_def => null ()
      integer :: n_in = 0
      integer :: n_components = 0
      integer :: n_terms = 0
      integer :: n_mci = 0
      type(string_t) :: model_name
      class(model_data_t), pointer :: model => null ()
      type(qcd_t) :: qcd
      class(expr_factory_t), allocatable :: ef_cuts
      class(expr_factory_t), allocatable :: ef_scale
      class(expr_factory_t), allocatable :: ef_fac_scale
      class(expr_factory_t), allocatable :: ef_ren_scale
      class(expr_factory_t), allocatable :: ef_weight
      character(32) :: md5sum = ""
    contains
    <<Process config: process config data: TBP>>
   end type process_config_data_t
 
 @ %def process_config_data_t
 @ Here, we may compress the expressions for cuts etc.
 <<Process config: process config data: TBP>>=
   procedure :: write => process_config_data_write
 <<Process config: procedures>>=
   subroutine process_config_data_write (config, u, counters, model, expressions)
     class(process_config_data_t), intent(in) :: config
     integer, intent(in) :: u
     logical, intent(in) :: counters
     logical, intent(in) :: model
     logical, intent(in) :: expressions
     write (u, "(1x,A)") "Configuration data:"
     if (counters) then
        write (u, "(3x,A,I0)") "Number of incoming particles = ", &
             config%n_in
        write (u, "(3x,A,I0)") "Number of process components = ", &
             config%n_components
        write (u, "(3x,A,I0)") "Number of process terms      = ", &
             config%n_terms
        write (u, "(3x,A,I0)") "Number of MCI configurations = ", &
             config%n_mci
     end if
     if (associated (config%model)) then
        write (u, "(3x,A,A)")  "Model = ", char (config%model_name)
        if (model) then
           call write_separator (u)
           call config%model%write (u)
           call write_separator (u)
        end if
     else
        write (u, "(3x,A,A,A)")  "Model = ", char (config%model_name), &
             " [not associated]"
     end if
     call config%qcd%write (u, show_md5sum = .false.)
     call write_separator (u)
     if (expressions) then
        if (allocated (config%ef_cuts)) then
           call write_separator (u)
           write (u, "(3x,A)") "Cut expression:"
           call config%ef_cuts%write (u)
        end if
        if (allocated (config%ef_scale)) then
           call write_separator (u)
           write (u, "(3x,A)") "Scale expression:"
           call config%ef_scale%write (u)
        end if
        if (allocated (config%ef_fac_scale)) then
           call write_separator (u)
           write (u, "(3x,A)") "Factorization scale expression:"
           call config%ef_fac_scale%write (u)
        end if
        if (allocated (config%ef_ren_scale)) then
           call write_separator (u)
           write (u, "(3x,A)") "Renormalization scale expression:"
           call config%ef_ren_scale%write (u)
        end if
        if (allocated (config%ef_weight)) then
           call write_separator (u)
           write (u, "(3x,A)") "Weight expression:"
           call config%ef_weight%write (u)
        end if
     else
        call write_separator (u)
        write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]"
     end if
     if (config%md5sum /= "") then
        call write_separator (u)
        write (u, "(3x,A,A,A)")  "MD5 sum (config)  = '", config%md5sum, "'"
     end if
   end subroutine process_config_data_write
 
 @ %def process_config_data_write
 @ Initialize.  We use information from the process metadata and from
 the process library, given the process ID.  We also store the
 currently active OS data set.
 
 The model pointer references the model data within the [[env]] record.  That
 should be an instance of the global model.
 
 We initialize the QCD object, unless the environment information is unavailable
 (unit tests).
 
 The RNG factory object is imported by moving the allocation.
 <<Process config: process config data: TBP>>=
   procedure :: init => process_config_data_init
 <<Process config: procedures>>=
   subroutine process_config_data_init (config, meta, env)
     class(process_config_data_t), intent(out) :: config
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     config%process_def => env%lib%get_process_def_ptr (meta%id)
     config%n_in = config%process_def%get_n_in ()
     config%n_components = size (meta%component_id)
     config%model => env%get_model_ptr ()
     config%model_name = config%model%get_name ()
     if (env%got_var_list ()) then
        call dispatch_qcd &
             (config%qcd, env%get_var_list_ptr (), env%get_os_data ())
     end if
   end subroutine process_config_data_init
 
 @ %def process_config_data_init
 @ Current implementation: nothing to finalize.
 <<Process config: process config data: TBP>>=
   procedure :: final => process_config_data_final
 <<Process config: procedures>>=
   subroutine process_config_data_final (config)
     class(process_config_data_t), intent(inout) :: config
   end subroutine process_config_data_final
 
 @ %def process_config_data_final
 @ Return a copy of the QCD data block.
 <<Process config: process config data: TBP>>=
   procedure :: get_qcd => process_config_data_get_qcd
 <<Process config: procedures>>=
   function process_config_data_get_qcd (config) result (qcd)
     class(process_config_data_t), intent(in) :: config
     type(qcd_t) :: qcd
     qcd = config%qcd
   end function process_config_data_get_qcd
 
 @ %def process_config_data_get_qcd
 @ Compute the MD5 sum of the configuration data.  This encodes, in
 particular, the model and the expressions for cut, scales, weight,
 etc.  It should not contain the IDs and number of components, etc.,
 since the MD5 sum should be useful for integrating individual
 components.
 
 This is done only once.  If the MD5 sum is nonempty, the calculation
 is skipped.
 <<Process config: process config data: TBP>>=
   procedure :: compute_md5sum => process_config_data_compute_md5sum
 <<Process config: procedures>>=
   subroutine process_config_data_compute_md5sum (config)
     class(process_config_data_t), intent(inout) :: config
     integer :: u
     if (config%md5sum == "") then
        u = free_unit ()
        open (u, status = "scratch", action = "readwrite")
        call config%write (u, counters = .false., &
             model = .true., expressions = .true.)
        rewind (u)
        config%md5sum = md5sum (u)
        close (u)
     end if
   end subroutine process_config_data_compute_md5sum
 
 @ %def process_config_data_compute_md5sum
 @
 <<Process config: process config data: TBP>>=
   procedure :: get_md5sum => process_config_data_get_md5sum
 <<Process config: procedures>>=
   pure function process_config_data_get_md5sum (config) result (md5)
     character(32) :: md5
     class(process_config_data_t), intent(in) :: config
     md5 = config%md5sum
   end function process_config_data_get_md5sum
 
 @ %def process_config_data_get_md5sum
 @
 \subsection{Environment}
 This record stores a snapshot of the process environment at the point where
 the process object is created.
 
 Model and variable list are implemented as pointer, so they always have the
 [[target]] attribute.
 
 For unit-testing purposes, setting the var list is optional.  If not set, the
 pointer is null.
 <<Process config: public>>=
   public :: process_environment_t
 <<Process config: types>>=
   type :: process_environment_t
      private
      type(model_t), pointer :: model => null ()
      type(var_list_t), pointer :: var_list => null ()
      logical :: var_list_is_set = .false.
      type(process_library_t), pointer :: lib => null ()
      type(beam_structure_t) :: beam_structure
      type(os_data_t) :: os_data
    contains
    <<Process config: process environment: TBP>>
   end type process_environment_t
 
 @ %def process_environment_t
 @ Model and local var list are snapshots and need a finalizer.
 <<Process config: process environment: TBP>>=
   procedure :: final => process_environment_final
 <<Process config: procedures>>=
   subroutine process_environment_final (env)
     class(process_environment_t), intent(inout) :: env
     if (associated (env%model)) then
        call env%model%final ()
        deallocate (env%model)
     end if
     if (associated (env%var_list)) then
        call env%var_list%final (follow_link=.true.)
        deallocate (env%var_list)
     end if
   end subroutine process_environment_final
 
 @ %def process_environment_final
 @ Output, DTIO compatible.
 <<Process config: process environment: TBP>>=
   procedure :: write => process_environment_write
   procedure :: write_formatted => process_environment_write_formatted
   ! generic :: write (formatted) => write_formatted
 <<Process config: procedures>>=
   subroutine process_environment_write (env, unit, &
        show_var_list, show_model, show_lib, show_beams, show_os_data)
     class(process_environment_t), intent(in) :: env
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_var_list
     logical, intent(in), optional :: show_model
     logical, intent(in), optional :: show_lib
     logical, intent(in), optional :: show_beams
     logical, intent(in), optional :: show_os_data
     integer :: u, iostat
     integer, dimension(:), allocatable :: v_list
     character(0) :: iomsg
     u = given_output_unit (unit)
     allocate (v_list (0))
     call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
     call set_flag (v_list, F_SHOW_MODEL, show_model)
     call set_flag (v_list, F_SHOW_LIB, show_lib)
     call set_flag (v_list, F_SHOW_BEAMS, show_beams)
     call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
     call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
   end subroutine process_environment_write
 
 @ %def process_environment_write
 @ DTIO standard write.
 <<Process config: procedures>>=
   subroutine process_environment_write_formatted &
        (dtv, unit, iotype, v_list, iostat, iomsg)
     class(process_environment_t), intent(in) :: dtv
     integer, intent(in) :: unit
     character(*), intent(in) :: iotype
     integer, dimension(:), intent(in) :: v_list
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     associate (env => dtv)
       if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then
          write (unit, "(1x,A)")  "Variable list:"
          if (associated (env%var_list)) then
             call write_separator (unit)
             call env%var_list%write (unit)
          else
             write (unit, "(3x,A)")  "[not allocated]"
          end if
          call write_separator (unit)
       end if
       if (flagged (v_list, F_SHOW_MODEL, .true.)) then
          write (unit, "(1x,A)")  "Model:"
          if (associated (env%model)) then
             call write_separator (unit)
             call env%model%write (unit)
          else
             write (unit, "(3x,A)")  "[not allocated]"
          end if
          call write_separator (unit)
       end if
       if (flagged (v_list, F_SHOW_LIB, .true.)) then
          write (unit, "(1x,A)")  "Process library:"
          if (associated (env%lib)) then
             call write_separator (unit)
             call env%lib%write (unit)
          else
             write (unit, "(3x,A)")  "[not allocated]"
          end if
       end if
       if (flagged (v_list, F_SHOW_BEAMS, .true.)) then
          call write_separator (unit)
          call env%beam_structure%write (unit)
       end if
       if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then
          write (unit, "(1x,A)")  "Operating-system data:"
          call write_separator (unit)
          call env%os_data%write (unit)
       end if
     end associate
     iostat = 0
   end subroutine process_environment_write_formatted
 
 @ %def process_environment_write_formatted
 @ Initialize: Make a snapshot of the provided model.  Make a link to the
 current process library.
 
 Also make a snapshot of the variable list, if provided.  If none is
 provided, there is an empty variable list nevertheless, so a pointer
 lookup does not return null.
 
 If no beam structure is provided, the beam-structure member is empty and will
 yield a number of zero beams when queried.
 <<Process config: process environment: TBP>>=
   procedure :: init => process_environment_init
 <<Process config: procedures>>=
   subroutine process_environment_init &
        (env, model, lib, os_data, var_list, beam_structure)
     class(process_environment_t), intent(out) :: env
     type(model_t), intent(in), target :: model
     type(process_library_t), intent(in), target :: lib
     type(os_data_t), intent(in) :: os_data
     type(var_list_t), intent(in), target, optional :: var_list
     type(beam_structure_t), intent(in), optional :: beam_structure
     allocate (env%model)
     call env%model%init_instance (model)
     env%lib => lib
     env%os_data = os_data
     allocate (env%var_list)
     if (present (var_list)) then
        call env%var_list%init_snapshot (var_list, follow_link=.true.)
        env%var_list_is_set = .true.
     end if
     if (present (beam_structure)) then
        env%beam_structure = beam_structure
     end if
   end subroutine process_environment_init
 
 @ %def process_environment_init
 @ Indicate whether a variable list has been provided upon initialization.
 <<Process config: process environment: TBP>>=
   procedure :: got_var_list => process_environment_got_var_list
 <<Process config: procedures>>=
   function process_environment_got_var_list (env) result (flag)
     class(process_environment_t), intent(in) :: env
     logical :: flag
     flag = env%var_list_is_set
   end function process_environment_got_var_list
 
 @ %def process_environment_got_var_list
 @ Return a pointer to the variable list.
 <<Process config: process environment: TBP>>=
   procedure :: get_var_list_ptr => process_environment_get_var_list_ptr
 <<Process config: procedures>>=
   function process_environment_get_var_list_ptr (env) result (var_list)
     class(process_environment_t), intent(in) :: env
     type(var_list_t), pointer :: var_list
     var_list => env%var_list
   end function process_environment_get_var_list_ptr
 
 @ %def process_environment_get_var_list_ptr
 @ Return a pointer to the model, if it exists.
 <<Process config: process environment: TBP>>=
   procedure :: get_model_ptr => process_environment_get_model_ptr
 <<Process config: procedures>>=
   function process_environment_get_model_ptr (env) result (model)
     class(process_environment_t), intent(in) :: env
     type(model_t), pointer :: model
     model => env%model
   end function process_environment_get_model_ptr
 
 @ %def process_environment_get_model_ptr
 @ Return the process library pointer.
 <<Process config: process environment: TBP>>=
   procedure :: get_lib_ptr => process_environment_get_lib_ptr
 <<Process config: procedures>>=
   function process_environment_get_lib_ptr (env) result (lib)
     class(process_environment_t), intent(inout) :: env
     type(process_library_t), pointer :: lib
     lib => env%lib
   end function process_environment_get_lib_ptr
 
 @ %def process_environment_get_lib_ptr
 @ Clear the process library pointer, in case the library is deleted.
 <<Process config: process environment: TBP>>=
   procedure :: reset_lib_ptr => process_environment_reset_lib_ptr
 <<Process config: procedures>>=
   subroutine process_environment_reset_lib_ptr (env)
     class(process_environment_t), intent(inout) :: env
     env%lib => null ()
   end subroutine process_environment_reset_lib_ptr
 
 @ %def process_environment_reset_lib_ptr
 @ Check whether the process library has changed, in case the library is
 recompiled, etc.
 <<Process config: process environment: TBP>>=
   procedure :: check_lib_sanity => process_environment_check_lib_sanity
 <<Process config: procedures>>=
   subroutine process_environment_check_lib_sanity (env, meta)
     class(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     if (associated (env%lib)) then
        if (env%lib%get_update_counter () /= meta%lib_update_counter) then
           call msg_fatal ("Process '" // char (meta%id) &
                // "': library has been recompiled after integration")
        end if
     end if
   end subroutine process_environment_check_lib_sanity
 
 @ %def process_environment_check_lib_sanity
 @ Fill the [[data]] block using the appropriate process-library access entry.
 <<Process config: process environment: TBP>>=
   procedure :: fill_process_constants => &
        process_environment_fill_process_constants
 <<Process config: procedures>>=
   subroutine process_environment_fill_process_constants &
        (env, id, i_component, data)
     class(process_environment_t), intent(in) :: env
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     type(process_constants_t), intent(out) :: data
     call env%lib%fill_constants (id, i_component, data)
   end subroutine process_environment_fill_process_constants
 
 @ %def process_environment_fill_process_constants
 @ Return the entire beam structure.
 <<Process config: process environment: TBP>>=
   procedure :: get_beam_structure => process_environment_get_beam_structure
 <<Process config: procedures>>=
   function process_environment_get_beam_structure (env) result (beam_structure)
     class(process_environment_t), intent(in) :: env
     type(beam_structure_t) :: beam_structure
     beam_structure = env%beam_structure
   end function process_environment_get_beam_structure
 
 @ %def process_environment_get_beam_structure
 @ Check the beam structure for PDFs.
 <<Process config: process environment: TBP>>=
   procedure :: has_pdfs => process_environment_has_pdfs
 <<Process config: procedures>>=
   function process_environment_has_pdfs (env) result (flag)
     class(process_environment_t), intent(in) :: env
     logical :: flag
     flag = env%beam_structure%has_pdf ()
   end function process_environment_has_pdfs
 
 @ %def process_environment_has_pdfs
 @ Check the beam structure for polarized beams.
 <<Process config: process environment: TBP>>=
   procedure :: has_polarized_beams => process_environment_has_polarized_beams
 <<Process config: procedures>>=
   function process_environment_has_polarized_beams (env) result (flag)
     class(process_environment_t), intent(in) :: env
     logical :: flag
     flag = env%beam_structure%has_polarized_beams ()
   end function process_environment_has_polarized_beams
 
 @ %def process_environment_has_polarized_beams
 @ Return a copy of the OS data block.
 <<Process config: process environment: TBP>>=
   procedure :: get_os_data => process_environment_get_os_data
 <<Process config: procedures>>=
   function process_environment_get_os_data (env) result (os_data)
     class(process_environment_t), intent(in) :: env
     type(os_data_t) :: os_data
     os_data = env%os_data
   end function process_environment_get_os_data
 
 @ %def process_environment_get_os_data
 @
 \subsection{Metadata}
 This information describes the process.  It is fixed upon initialization.
 
 The [[id]] string is the name of the process object, as given by the
 user.  The matrix element generator will use this string for naming
 Fortran procedures and types, so it should qualify as a Fortran name.
 
 The [[num_id]] is meaningful if nonzero.  It is used for communication
 with external programs or file standards which do not support string IDs.
 
 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.
 
 The [[lib_name]] identifies the process library where the process
 definition and the process driver are located.
 
 The [[lib_index]] is the index of entry in the process library that
 corresponds to the current process.
 
 The [[component_id]] array identifies the individual process components.
 
 The [[component_description]] is an array of human-readable strings
 that characterize the process components, for instance [[a, b => c, d]].
 
 The [[active]] mask array marks those components which are active.  The others
 are skipped.
 <<Process config: public>>=
   public :: process_metadata_t
 <<Process config: types>>=
   type :: process_metadata_t
      integer :: type = PRC_UNKNOWN
      type(string_t) :: id
      integer :: num_id = 0
      type(string_t) :: run_id
      type(string_t), allocatable :: lib_name
      integer :: lib_update_counter = 0
      integer :: lib_index = 0
      integer :: n_components = 0
      type(string_t), dimension(:), allocatable :: component_id
      type(string_t), dimension(:), allocatable :: component_description
      logical, dimension(:), allocatable :: active
    contains
    <<Process config: process metadata: TBP>>
   end type process_metadata_t
 
 @ %def process_metadata_t
 @ Output: ID and run ID.
 We write the variable list only upon request.
 <<Process config: process metadata: TBP>>=
   procedure :: write => process_metadata_write
 <<Process config: procedures>>=
   subroutine process_metadata_write (meta, u, screen)
     class(process_metadata_t), intent(in) :: meta
     integer, intent(in) :: u
     logical, intent(in) :: screen
     integer :: i
     select case (meta%type)
     case (PRC_UNKNOWN)
        if (screen) then
           write (msg_buffer, "(A)") "Process [undefined]"
        else
           write (u, "(1x,A)") "Process [undefined]"
        end if
        return
     case (PRC_DECAY)
        if (screen) then
           write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", &
                "'", char (meta%id), "'"
        else
           write (u, "(1x,A)", advance="no") "Process [decay]:"
        end if
     case (PRC_SCATTERING)
        if (screen) then
           write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", &
                "'", char (meta%id), "'"
        else
           write (u, "(1x,A)", advance="no") "Process [scattering]:"
        end if
     case default
        call msg_bug ("process_write: undefined process type")
     end select
     if (screen)  then
        call msg_message ()
     else
        write (u, "(1x,A,A,A)") "'", char (meta%id), "'"
     end if
     if (meta%num_id /= 0) then
        if (screen) then
           write (msg_buffer, "(2x,A,I0)") "ID (num)      = ", meta%num_id
           call msg_message ()
        else
           write (u, "(3x,A,I0)") "ID (num)      = ", meta%num_id
        end if
     end if
     if (screen) then
        if (meta%run_id /= "") then
           write (msg_buffer, "(2x,A,A,A)") "Run ID        = '", &
                char (meta%run_id), "'"
           call msg_message ()
        end if
     else
        write (u, "(3x,A,A,A)") "Run ID        = '", char (meta%run_id), "'"
     end if
     if (allocated (meta%lib_name)) then
        if (screen) then
           write (msg_buffer, "(2x,A,A,A)")  "Library name  = '", &
                char (meta%lib_name), "'"
           call msg_message ()
        else
           write (u, "(3x,A,A,A)")  "Library name  = '", &
                char (meta%lib_name), "'"
        end if
     else
        if (screen) then
           write (msg_buffer, "(2x,A)")  "Library name  = [not associated]"
           call msg_message ()
        else
           write (u, "(3x,A)")  "Library name  = [not associated]"
        end if
     end if
     if (screen) then
        write (msg_buffer, "(2x,A,I0)")  "Process index = ", meta%lib_index
        call msg_message ()
     else
        write (u, "(3x,A,I0)")  "Process index = ", meta%lib_index
     end if
     if (allocated (meta%component_id)) then
        if (screen) then
           if (any (meta%active)) then
              write (msg_buffer, "(2x,A)")  "Process components:"
           else
              write (msg_buffer, "(2x,A)")  "Process components: [none]"
           end if
           call msg_message ()
        else
           write (u, "(3x,A)")  "Process components:"
        end if
        do i = 1, size (meta%component_id)
           if (.not. meta%active(i))  cycle
           if (screen) then
              write (msg_buffer, "(4x,I0,9A)")  i, ": '", &
                   char (meta%component_id (i)), "':   ", &
                   char (meta%component_description (i))
              call msg_message ()
           else
              write (u, "(5x,I0,9A)")  i, ": '", &
                   char (meta%component_id (i)), "':   ", &
                   char (meta%component_description (i))
           end if
        end do
     end if
     if (screen) then
        write (msg_buffer, "(A)")  repeat ("-", 72)
        call msg_message ()
     else
        call write_separator (u)
     end if
   end subroutine process_metadata_write
 
 @ %def process_metadata_write
 @ Short output: list components.
 <<Process config: process metadata: TBP>>=
   procedure :: show => process_metadata_show
 <<Process config: procedures>>=
   subroutine process_metadata_show (meta, u, model_name)
     class(process_metadata_t), intent(in) :: meta
     integer, intent(in) :: u
     type(string_t), intent(in) :: model_name
     integer :: i
     select case (meta%type)
     case (PRC_UNKNOWN)
        write (u, "(A)") "Process: [undefined]"
        return
     case default
        write (u, "(A)", advance="no") "Process:"
     end select
     write (u, "(1x,A)", advance="no") char (meta%id)
     select case (meta%num_id)
     case (0)
     case default
        write (u, "(1x,'(',I0,')')", advance="no") meta%num_id
     end select
     select case (char (model_name))
     case ("")
     case default
        write (u, "(1x,'[',A,']')", advance="no")  char (model_name)
     end select
     write (u, *)
     if (allocated (meta%component_id)) then
        do i = 1, size (meta%component_id)
           if (meta%active(i)) then
              write (u, "(2x,I0,':',1x,A)")  i, &
                   char (meta%component_description (i))
           end if
        end do
     end if
   end subroutine process_metadata_show
 
 @ %def process_metadata_show
 @ Initialize.  Find process ID and run ID.
 
 Also find the process ID in the process library and retrieve some metadata from
 there.
 <<Process config: process metadata: TBP>>=
   procedure :: init => process_metadata_init
 <<Process config: procedures>>=
   subroutine process_metadata_init (meta, id, lib, var_list)
     class(process_metadata_t), intent(out) :: meta
     type(string_t), intent(in) :: id
     type(process_library_t), intent(in), target :: lib
     type(var_list_t), intent(in) :: var_list
     select case (lib%get_n_in (id))
     case (1);  meta%type = PRC_DECAY
     case (2);  meta%type = PRC_SCATTERING
     case default
        call msg_bug ("Process '" // char (id) // "': impossible n_in")
     end select
     meta%id = id
     meta%run_id = var_list%get_sval (var_str ("$run_id"))
     allocate (meta%lib_name)
     meta%lib_name = lib%get_name ()
     meta%lib_update_counter = lib%get_update_counter ()
     if (lib%contains (id)) then
        meta%lib_index = lib%get_entry_index (id)
        meta%num_id = lib%get_num_id (id)
        call lib%get_component_list (id, meta%component_id)
        meta%n_components = size (meta%component_id)
        call lib%get_component_description_list &
             (id, meta%component_description)
        allocate (meta%active (meta%n_components), source = .true.)
     else
        call msg_fatal ("Process library does not contain process '" &
             // char (id) // "'")
     end if
     if (.not. lib%is_active ()) then
        call msg_bug ("Process init: inactive library not handled yet")
     end if
   end subroutine process_metadata_init
 
 @ %def process_metadata_init
 @ Mark a component as inactive.
 <<Process config: process metadata: TBP>>=
   procedure :: deactivate_component => process_metadata_deactivate_component
 <<Process config: procedures>>=
   subroutine process_metadata_deactivate_component (meta, i)
     class(process_metadata_t), intent(inout) :: meta
     integer, intent(in) :: i
     call msg_message ("Process component '" &
          // char (meta%component_id(i)) // "': matrix element vanishes")
     meta%active(i) = .false.
   end subroutine process_metadata_deactivate_component
 
 @ %def process_metadata_deactivate_component
 @
 \subsection{Phase-space configuration}
 A process can have a number of independent phase-space configuration entries,
 depending on the process definition and evaluation algorithm.  Each entry
 holds various configuration-parameter data and the actual [[phs_config_t]]
 record, which can vary in concrete type.
 <<Process config: public>>=
   public :: process_phs_config_t
 <<Process config: types>>=
   type :: process_phs_config_t
      type(phs_parameters_t) :: phs_par
      type(mapping_defaults_t) :: mapping_defs
      class(phs_config_t), allocatable :: phs_config
    contains
    <<Process config: process phs config: TBP>>
   end type process_phs_config_t
 
 @ %def process_phs_config_t
 @ Output, DTIO compatible.
 <<Process config: process phs config: TBP>>=
   procedure :: write => process_phs_config_write
   procedure :: write_formatted => process_phs_config_write_formatted
   ! generic :: write (formatted) => write_formatted
 <<Process config: procedures>>=
   subroutine process_phs_config_write (phs_config, unit)
     class(process_phs_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     integer :: u, iostat
     integer, dimension(:), allocatable :: v_list
     character(0) :: iomsg
     u = given_output_unit (unit)
     allocate (v_list (0))
     call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
   end subroutine process_phs_config_write
 
 @ %def process_phs_config_write
 @ DTIO standard write.
 <<Process config: procedures>>=
   subroutine process_phs_config_write_formatted &
        (dtv, unit, iotype, v_list, iostat, iomsg)
     class(process_phs_config_t), intent(in) :: dtv
     integer, intent(in) :: unit
     character(*), intent(in) :: iotype
     integer, dimension(:), intent(in) :: v_list
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     associate (phs_config => dtv)
       write (unit, "(1x, A)")  "Phase-space configuration entry:"
       call phs_config%phs_par%write (unit)
       call phs_config%mapping_defs%write (unit)
     end associate
     iostat = 0
   end subroutine process_phs_config_write_formatted
 
 @ %def process_phs_config_write_formatted
 @
 \subsection{Beam configuration}
 The object [[data]] holds all details about the initial beam
 configuration.  The allocatable array [[sf]] holds the structure-function
 configuration blocks.  There are [[n_strfun]] entries in the
 structure-function chain (not counting the initial beam object).  We
 maintain [[n_channel]] independent parameterizations of this chain.
 If this is greater than zero, we need a multi-channel sampling
 algorithm, where for each point one channel is selected to generate
 kinematics.
 
 The number of parameters that are required for generating a
 structure-function chain is [[n_sfpar]].
 
 The flag [[azimuthal_dependence]] tells whether the process setup is
 symmetric about the beam axis in the c.m.\ system.  This implies that
 there is no transversal beam polarization.  The flag [[lab_is_cm]] is
 obvious.
 <<Process config: public>>=
   public :: process_beam_config_t
 <<Process config: types>>=
   type :: process_beam_config_t
      type(beam_data_t) :: data
      integer :: n_strfun = 0
      integer :: n_channel = 1
      integer :: n_sfpar = 0
      type(sf_config_t), dimension(:), allocatable :: sf
      type(sf_channel_t), dimension(:), allocatable :: sf_channel
      logical :: azimuthal_dependence = .false.
      logical :: lab_is_cm = .true.
      character(32) :: md5sum = ""
      logical :: sf_trace = .false.
      type(string_t) :: sf_trace_file
    contains
    <<Process config: process beam config: TBP>>
   end type process_beam_config_t
 
 @ %def process_beam_config_t
 @ Here we write beam data only if they are actually used.
 
 The [[verbose]] flag is passed to the beam-data writer.
 <<Process config: process beam config: TBP>>=
   procedure :: write => process_beam_config_write
 <<Process config: procedures>>=
   subroutine process_beam_config_write (object, unit, verbose)
     class(process_beam_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i, c
     u = given_output_unit (unit)
     call object%data%write (u, verbose = verbose)
     if (object%data%initialized) then
        write (u, "(3x,A,L1)")  "Azimuthal dependence    = ", &
             object%azimuthal_dependence
        write (u, "(3x,A,L1)")  "Lab frame is c.m. frame = ", &
             object%lab_is_cm
        if (object%md5sum /= "") then
           write (u, "(3x,A,A,A)")  "MD5 sum (beams/strf) = '", &
                object%md5sum, "'"
        end if
        if (allocated (object%sf)) then
           do i = 1, size (object%sf)
              call object%sf(i)%write (u)
           end do
           if (any_sf_channel_has_mapping (object%sf_channel)) then
              write (u, "(1x,A,L1)")  "Structure-function mappings per channel:"
              do c = 1, object%n_channel
                 write (u, "(3x,I0,':')", advance="no")  c
                 call object%sf_channel(c)%write (u)
              end do
           end if
        end if
     end if
   end subroutine process_beam_config_write
 
 @ %def process_beam_config_write
 @ The beam data have a finalizer.  We assume that there is none for the
 structure-function data.
 <<Process config: process beam config: TBP>>=
   procedure :: final => process_beam_config_final
 <<Process config: procedures>>=
   subroutine process_beam_config_final (object)
     class(process_beam_config_t), intent(inout) :: object
     call object%data%final ()
   end subroutine process_beam_config_final
 
 @ %def process_beam_config_final
 @ Initialize the beam setup with a given beam structure object.
 <<Process config: process beam config: TBP>>=
   procedure :: init_beam_structure => process_beam_config_init_beam_structure
 <<Process config: procedures>>=
   subroutine process_beam_config_init_beam_structure &
        (beam_config, beam_structure, sqrts, model, decay_rest_frame)
     class(process_beam_config_t), intent(out) :: beam_config
     type(beam_structure_t), intent(in) :: beam_structure
     logical, intent(in), optional :: decay_rest_frame
     real(default), intent(in) :: sqrts
     class(model_data_t), intent(in), target :: model
     call beam_config%data%init_structure (beam_structure, &
          sqrts, model, decay_rest_frame)
     beam_config%lab_is_cm = beam_config%data%lab_is_cm
   end subroutine process_beam_config_init_beam_structure
 
 @ %def process_beam_config_init_beam_structure
 @ Initialize the beam setup for a scattering process with specified
 flavor combination, other properties taken from the beam structure
 object (if any).
 <<Process config: process beam config: TBP>>=
   procedure :: init_scattering => process_beam_config_init_scattering
 <<Process config: procedures>>=
   subroutine process_beam_config_init_scattering &
        (beam_config, flv_in, sqrts, beam_structure)
     class(process_beam_config_t), intent(out) :: beam_config
     type(flavor_t), dimension(2), intent(in) :: flv_in
     real(default), intent(in) :: sqrts
     type(beam_structure_t), intent(in), optional :: beam_structure
     if (present (beam_structure)) then
        if (beam_structure%polarized ()) then
           call beam_config%data%init_sqrts (sqrts, flv_in, &
                beam_structure%get_smatrix (), beam_structure%get_pol_f ())
        else
           call beam_config%data%init_sqrts (sqrts, flv_in)
        end if
     else
        call beam_config%data%init_sqrts (sqrts, flv_in)
     end if
   end subroutine process_beam_config_init_scattering
 
 @ %def process_beam_config_init_scattering
 @ Initialize the beam setup for a decay process with specified flavor,
 other properties taken from the beam structure object (if present).
 
 For a cascade decay, we set
 [[rest_frame]] to false, indicating a event-wise varying momentum.
 The beam data itself are initialized for the particle at rest.
 <<Process config: process beam config: TBP>>=
   procedure :: init_decay => process_beam_config_init_decay
 <<Process config: procedures>>=
   subroutine process_beam_config_init_decay &
        (beam_config, flv_in, rest_frame, beam_structure)
     class(process_beam_config_t), intent(out) :: beam_config
     type(flavor_t), dimension(1), intent(in) :: flv_in
     logical, intent(in), optional :: rest_frame
     type(beam_structure_t), intent(in), optional :: beam_structure
     if (present (beam_structure)) then
        if (beam_structure%polarized ()) then
           call beam_config%data%init_decay (flv_in, &
                beam_structure%get_smatrix (), beam_structure%get_pol_f (), &
                rest_frame = rest_frame)
        else
           call beam_config%data%init_decay (flv_in, rest_frame = rest_frame)
        end if
     else
        call beam_config%data%init_decay (flv_in, &
             rest_frame = rest_frame)
     end if
     beam_config%lab_is_cm = beam_config%data%lab_is_cm
   end subroutine process_beam_config_init_decay
 
 @ %def process_beam_config_init_decay
 @ Print an informative message.
 <<Process config: process beam config: TBP>>=
   procedure :: startup_message => process_beam_config_startup_message
 <<Process config: procedures>>=
   subroutine process_beam_config_startup_message &
        (beam_config, unit, beam_structure)
     class(process_beam_config_t), intent(in) :: beam_config
     integer, intent(in), optional :: unit
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer :: u
     u = free_unit ()
     open (u, status="scratch", action="readwrite")
     if (present (beam_structure)) then
        call beam_structure%write (u)
     end if
     call beam_config%data%write (u)
     rewind (u)
     do
        read (u, "(1x,A)", end=1)  msg_buffer
        call msg_message ()
     end do
 1   continue
     close (u)
   end subroutine process_beam_config_startup_message
 
 @ %def process_beam_config_startup_message
 @ Allocate the structure-function array.
 <<Process config: process beam config: TBP>>=
   procedure :: init_sf_chain => process_beam_config_init_sf_chain
 <<Process config: procedures>>=
   subroutine process_beam_config_init_sf_chain &
        (beam_config, sf_config, sf_trace_file)
     class(process_beam_config_t), intent(inout) :: beam_config
     type(sf_config_t), dimension(:), intent(in) :: sf_config
     type(string_t), intent(in), optional :: sf_trace_file
     integer :: i
     beam_config%n_strfun = size (sf_config)
     allocate (beam_config%sf (beam_config%n_strfun))
     do i = 1, beam_config%n_strfun
        associate (sf => sf_config(i))
          call beam_config%sf(i)%init (sf%i, sf%data)
          if (.not. sf%data%is_generator ()) then
             beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par ()
          end if
        end associate
     end do
     if (present (sf_trace_file)) then
        beam_config%sf_trace = .true.
        beam_config%sf_trace_file = sf_trace_file
     end if
   end subroutine process_beam_config_init_sf_chain
 
 @ %def process_beam_config_init_sf_chain
 @ Allocate the structure-function mapping channel array, given the
 requested number of channels.
 <<Process config: process beam config: TBP>>=
   procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels
 <<Process config: procedures>>=
   subroutine process_beam_config_allocate_sf_channels (beam_config, n_channel)
     class(process_beam_config_t), intent(inout) :: beam_config
     integer, intent(in) :: n_channel
     beam_config%n_channel = n_channel
     call allocate_sf_channels (beam_config%sf_channel, &
          n_channel = n_channel, &
          n_strfun = beam_config%n_strfun)
   end subroutine process_beam_config_allocate_sf_channels
 
 @ %def process_beam_config_allocate_sf_channels
 @ Set a structure-function mapping channel for an array of
 structure-function entries, for a single channel.  (The default is no mapping.)
 <<Process config: process beam config: TBP>>=
   procedure :: set_sf_channel => process_beam_config_set_sf_channel
 <<Process config: procedures>>=
   subroutine process_beam_config_set_sf_channel (beam_config, c, sf_channel)
     class(process_beam_config_t), intent(inout) :: beam_config
     integer, intent(in) :: c
     type(sf_channel_t), intent(in) :: sf_channel
     beam_config%sf_channel(c) = sf_channel
   end subroutine process_beam_config_set_sf_channel
 
 @ %def process_beam_config_set_sf_channel
 @ Print an informative startup message.
 <<Process config: process beam config: TBP>>=
   procedure :: sf_startup_message => process_beam_config_sf_startup_message
 <<Process config: procedures>>=
   subroutine process_beam_config_sf_startup_message &
        (beam_config, sf_string, unit)
     class(process_beam_config_t), intent(in) :: beam_config
     type(string_t), intent(in) :: sf_string
     integer, intent(in), optional :: unit
     if (beam_config%n_strfun > 0) then
        call msg_message ("Beam structure: " // char (sf_string), unit = unit)
        write (msg_buffer, "(A,3(1x,I0,1x,A))") &
             "Beam structure:", &
             beam_config%n_channel, "channels,", &
             beam_config%n_sfpar, "dimensions"
        call msg_message (unit = unit)
        if (beam_config%sf_trace) then
           call msg_message ("Beam structure: tracing &
                &values in '" // char (beam_config%sf_trace_file) // "'")
        end if
     end if
   end subroutine process_beam_config_sf_startup_message
 
 @ %def process_beam_config_startup_message
 @ Return the PDF set currently in use, if any.  This should be unique,
 so we scan the structure functions until we get a nonzero number.
 
 (This implies that if the PDF set is not unique (e.g., proton and
 photon structure used together), this does not work correctly.)
 <<Process config: process beam config: TBP>>=
   procedure :: get_pdf_set => process_beam_config_get_pdf_set
 <<Process config: procedures>>=
   function process_beam_config_get_pdf_set (beam_config) result (pdf_set)
     class(process_beam_config_t), intent(in) :: beam_config
     integer :: pdf_set
     integer :: i
     pdf_set = 0
     if (allocated (beam_config%sf)) then
        do i = 1, size (beam_config%sf)
           pdf_set = beam_config%sf(i)%get_pdf_set ()
           if (pdf_set /= 0)  return
        end do
     end if
   end function process_beam_config_get_pdf_set
 
 @ %def process_beam_config_get_pdf_set
 @ Return the beam file.
 <<Process config: process beam config: TBP>>=
   procedure :: get_beam_file => process_beam_config_get_beam_file
 <<Process config: procedures>>=
   function process_beam_config_get_beam_file (beam_config) result (file)
     class(process_beam_config_t), intent(in) :: beam_config
     type(string_t) :: file
     integer :: i
     file = ""
     if (allocated (beam_config%sf)) then
        do i = 1, size (beam_config%sf)
           file = beam_config%sf(i)%get_beam_file ()
           if (file /= "")  return
        end do
     end if
   end function process_beam_config_get_beam_file
 
 @ %def process_beam_config_get_beam_file
 @ Compute the MD5 sum for the complete beam setup.  We rely on the
 default output of [[write]] to contain all relevant data.
 
 This is done only once, when the MD5 sum is still empty.
 <<Process config: process beam config: TBP>>=
   procedure :: compute_md5sum => process_beam_config_compute_md5sum
 <<Process config: procedures>>=
   subroutine process_beam_config_compute_md5sum (beam_config)
     class(process_beam_config_t), intent(inout) :: beam_config
     integer :: u
     if (beam_config%md5sum == "") then
        u = free_unit ()
        open (u, status = "scratch", action = "readwrite")
        call beam_config%write (u, verbose=.true.)
        rewind (u)
        beam_config%md5sum = md5sum (u)
        close (u)
     end if
   end subroutine process_beam_config_compute_md5sum
 
 @ %def process_beam_config_compute_md5sum
 @
 <<Process config: process beam config: TBP>>=
   procedure :: get_md5sum => process_beam_config_get_md5sum
 <<Process config: procedures>>=
   pure function process_beam_config_get_md5sum (beam_config) result (md5)
     character(32) :: md5
     class(process_beam_config_t), intent(in) :: beam_config
     md5 = beam_config%md5sum
   end function process_beam_config_get_md5sum
 
 @ %def process_beam_config_get_md5sum
 @
 <<Process config: process beam config: TBP>>=
   procedure :: has_structure_function => process_beam_config_has_structure_function
 <<Process config: procedures>>=
   pure function process_beam_config_has_structure_function (beam_config) result (has_sf)
     logical :: has_sf
     class(process_beam_config_t), intent(in) :: beam_config
     has_sf = beam_config%n_strfun > 0
   end function process_beam_config_has_structure_function
 
 @ %def process_beam_config_has_structure_function
 @
 \subsection{Process components}
 A process component is an individual contribution to a process
 (scattering or decay) which needs not be physical.  The sum over all
 components should be physical.
 
 The [[index]] indentifies this component within its parent process.
 
 The actual process component is stored in the [[core]] subobject.  We
 use a polymorphic subobject instead of an extension of
 [[process_component_t]], because the individual entries in the array
 of process components can have different types.  In short,
 [[process_component_t]] is a wrapper for the actual process variants.
 
 If the [[active]] flag is false, we should skip this component.  This happens
 if the associated process has vanishing matrix element.
 
 The index array [[i_term]] points to the individual terms generated by
 this component.  The indices refer to the parent process.
 
 The index [[i_mci]] is the index of the MC integrator and parameter set which
 are associated to this process component.
 <<Process config: public>>=
   public :: process_component_t
 <<Process config: types>>=
   type :: process_component_t
      type(process_component_def_t), pointer :: config => null ()
      integer :: index = 0
      logical :: active = .false.
      integer, dimension(:), allocatable :: i_term
      integer :: i_mci = 0
      class(phs_config_t), allocatable :: phs_config
      character(32) :: md5sum_phs = ""
      integer :: component_type = COMP_DEFAULT
    contains
    <<Process config: process component: TBP>>
   end type process_component_t
 
 @ %def process_component_t
 @ Finalizer.  The MCI template may (potentially) need a finalizer.  The process
 configuration finalizer may include closing an open scratch file.
 <<Process config: process component: TBP>>=
   procedure :: final => process_component_final
 <<Process config: procedures>>=
   subroutine process_component_final (object)
     class(process_component_t), intent(inout) :: object
     if (allocated (object%phs_config)) then
        call object%phs_config%final ()
     end if
   end subroutine process_component_final
 
 @ %def process_component_final
 @ The meaning of [[verbose]] depends on the process variant.
 <<Process config: process component: TBP>>=
   procedure :: write => process_component_write
 <<Process config: procedures>>=
   subroutine process_component_write (object, unit)
     class(process_component_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%config)) then
        write (u, "(1x,A,I0)")  "Component #", object%index
        call object%config%write (u)
        if (object%md5sum_phs /= "") then
           write (u, "(3x,A,A,A)")  "MD5 sum (phs)       = '", &
                object%md5sum_phs, "'"
        end if
     else
        write (u, "(1x,A)") "Process component: [not allocated]"
     end if
     if (.not. object%active) then
        write (u, "(1x,A)") "[Inactive]"
        return
     end if
     write (u, "(1x,A)") "Referenced data:"
     if (allocated (object%i_term)) then
        write (u, "(3x,A,999(1x,I0))") "Terms                    =", &
             object%i_term
     else
        write (u, "(3x,A)") "Terms                    = [undefined]"
     end if
     if (object%i_mci /= 0) then
        write (u, "(3x,A,I0)") "MC dataset               = ", object%i_mci
     else
        write (u, "(3x,A)") "MC dataset               = [undefined]"
     end if
     if (allocated (object%phs_config)) then
        call object%phs_config%write (u)
     end if
   end subroutine process_component_write
 
 @ %def process_component_write
 @ Initialize the component.
 <<Process config: process component: TBP>>=
   procedure :: init => process_component_init
 <<Process config: procedures>>=
   subroutine process_component_init (component, &
        i_component, env, meta, config, &
        active, &
        phs_config_template)
     class(process_component_t), intent(out) :: component
     integer, intent(in) :: i_component
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     type(process_config_data_t), intent(in) :: config
     logical, intent(in) :: active
     class(phs_config_t), intent(in), allocatable :: phs_config_template
 
     type(process_constants_t) :: data
 
     component%index = i_component
     component%config => &
          config%process_def%get_component_def_ptr (i_component)
 
     component%active = active
     if (component%active) then
        allocate (component%phs_config, source = phs_config_template)
        call env%fill_process_constants (meta%id, i_component, data)
        call component%phs_config%init (data, config%model)
     end if
   end subroutine process_component_init
 
 @ %def process_component_init
 @
 <<Process config: process component: TBP>>=
   procedure :: is_active => process_component_is_active
 <<Process config: procedures>>=
   elemental function process_component_is_active (component) result (active)
     logical :: active
     class(process_component_t), intent(in) :: component
     active = component%active
   end function process_component_is_active
 
 @ %def process_component_is_active
 @ Finalize the phase-space configuration.
 <<Process config: process component: TBP>>=
   procedure :: configure_phs => process_component_configure_phs
 <<Process config: procedures>>=
   subroutine process_component_configure_phs &
        (component, sqrts, beam_config, rebuild, &
         ignore_mismatch, subdir)
     class(process_component_t), intent(inout) :: component
     real(default), intent(in) :: sqrts
     type(process_beam_config_t), intent(in) :: beam_config
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     type(string_t), intent(in), optional :: subdir
     logical :: no_strfun
     integer :: nlo_type
     no_strfun = beam_config%n_strfun == 0
     nlo_type = component%config%get_nlo_type ()
     call component%phs_config%configure (sqrts, &
          azimuthal_dependence = beam_config%azimuthal_dependence, &
          sqrts_fixed = no_strfun, &
          lab_is_cm = beam_config%lab_is_cm .and. no_strfun, &
          rebuild = rebuild, ignore_mismatch = ignore_mismatch, &
          nlo_type = nlo_type, &
          subdir = subdir)
   end subroutine process_component_configure_phs
 
 @ %def process_component_configure_phs
 @ The process component possesses two MD5 sums: the checksum of the
 component definition, which should be available when the component is
 initialized, and the phase-space MD5 sum, which is available after
 configuration.
 <<Process config: process component: TBP>>=
   procedure :: compute_md5sum => process_component_compute_md5sum
 <<Process config: procedures>>=
   subroutine process_component_compute_md5sum (component)
     class(process_component_t), intent(inout) :: component
     component%md5sum_phs = component%phs_config%get_md5sum ()
   end subroutine process_component_compute_md5sum
 
 @ %def process_component_compute_md5sum
 @ Match phase-space channels with structure-function channels, where
 applicable.
 
 This calls a method of the [[phs_config]] phase-space implementation.
 <<Process config: process component: TBP>>=
   procedure :: collect_channels => process_component_collect_channels
 <<Process config: procedures>>=
   subroutine process_component_collect_channels (component, coll)
     class(process_component_t), intent(inout) :: component
     type(phs_channel_collection_t), intent(inout) :: coll
     call component%phs_config%collect_channels (coll)
   end subroutine process_component_collect_channels
 
 @ %def process_component_collect_channels
 @
 <<Process config: process component: TBP>>=
   procedure :: get_config => process_component_get_config
 <<Process config: procedures>>=
   function process_component_get_config (component) &
          result (config)
     type(process_component_def_t) :: config
     class(process_component_t), intent(in) :: component
     config = component%config
   end function process_component_get_config
 
 @ %def process_component_get_config
 @
 <<Process config: process component: TBP>>=
   procedure :: get_md5sum => process_component_get_md5sum
 <<Process config: procedures>>=
   pure function process_component_get_md5sum (component) result (md5)
     type(string_t) :: md5
     class(process_component_t), intent(in) :: component
     md5 = component%config%get_md5sum () // component%md5sum_phs
   end function process_component_get_md5sum
 
 @ %def process_component_get_md5sum
 @ Return the number of phase-space parameters.
 <<Process config: process component: TBP>>=
   procedure :: get_n_phs_par => process_component_get_n_phs_par
 <<Process config: procedures>>=
   function process_component_get_n_phs_par (component) result (n_par)
     class(process_component_t), intent(in) :: component
     integer :: n_par
     n_par = component%phs_config%get_n_par ()
   end function process_component_get_n_phs_par
 
 @ %def process_component_get_n_phs_par
 @
 <<Process config: process component: TBP>>=
   procedure :: get_phs_config => process_component_get_phs_config
 <<Process config: procedures>>=
   subroutine process_component_get_phs_config (component, phs_config)
     class(process_component_t), intent(in), target :: component
     class(phs_config_t), intent(out), pointer :: phs_config
     phs_config => component%phs_config
   end subroutine process_component_get_phs_config
 
 @ %def process_component_get_phs_config
 @
 <<Process config: process component: TBP>>=
   procedure :: get_nlo_type => process_component_get_nlo_type
 <<Process config: procedures>>=
   elemental function process_component_get_nlo_type (component) result (nlo_type)
      integer :: nlo_type
      class(process_component_t), intent(in) :: component
      nlo_type = component%config%get_nlo_type ()
   end function process_component_get_nlo_type
 
 @ %def process_component_get_nlo_type
 @
 <<Process config: process component: TBP>>=
   procedure :: needs_mci_entry => process_component_needs_mci_entry
 <<Process config: procedures>>=
   function process_component_needs_mci_entry (component, combined_integration) result (value)
     logical :: value
     class(process_component_t), intent(in) :: component
     logical, intent(in), optional :: combined_integration
     value = component%active
     if (present (combined_integration)) then
        if (combined_integration) &
             value = value .and. component%component_type <= COMP_MASTER
     end if
   end function process_component_needs_mci_entry
 
 @ %def process_component_needs_mci_entry
 @
 <<Process config: process component: TBP>>=
   procedure :: can_be_integrated => process_component_can_be_integrated
 <<Process config: procedures>>=
   elemental function process_component_can_be_integrated (component) result (active)
     logical :: active
     class(process_component_t), intent(in) :: component
     active = component%config%can_be_integrated ()
   end function process_component_can_be_integrated
 
 @ %def process_component_can_be_integrated
 @
 \subsection{Process terms}
 For straightforward tree-level calculations, each process component
 corresponds to a unique elementary interaction.  However, in the case
 of NLO calculations with subtraction terms, a process component may
 split into several separate contributions to the scattering, which are
 qualified by interactions with distinct kinematics and particle
 content.  We represent their configuration as [[process_term_t]]
 objects, the actual instances will be introduced below as
 [[term_instance_t]].  In any case, the process term contains an
 elementary interaction with a definite quantum-number and momentum
 content.
 
 The index [[i_term_global]] identifies the term relative to the
 process.
 
 The index [[i_component]] identifies the process component which
 generates this term, relative to the parent process.
 
 The index [[i_term]] identifies the term relative to the process
 component (not the process).
 
 The [[data]] subobject holds all process constants.
 
 The number of allowed flavor/helicity/color combinations is stored as
 [[n_allowed]].  This is the total number of independent entries in the
 density matrix.  For each combination, the index of the flavor,
 helicity, and color state is stored in the arrays [[flv]], [[hel]],
 and [[col]], respectively.
 
 The flag [[rearrange]] is true if we need to rearrange the particles of the
 hard interaction, to obtain the effective parton state.
 
 The interaction [[int]] holds the quantum state for the (resolved) hard
 interaction, the parent-child relations of the particles, and their momenta.
 The momenta are not filled yet; this is postponed to copies of [[int]] which
 go into the process instances.
 
 If recombination is in effect, we should allocate [[int_eff]] to describe the
 rearranged partonic state.
 
 This type is public only for use in a unit test.
 <<Process config: public>>=
   public :: process_term_t
 <<Process config: types>>=
   type :: process_term_t
      integer :: i_term_global = 0
      integer :: i_component = 0
      integer :: i_term = 0
      integer :: i_sub = 0
      integer :: i_core = 0
      integer :: n_allowed = 0
      type(process_constants_t) :: data
      real(default) :: alpha_s = 0
      integer, dimension(:), allocatable :: flv, hel, col
      integer :: n_sub, n_sub_color, n_sub_spin
      type(interaction_t) :: int
      type(interaction_t), pointer :: int_eff => null ()
    contains
    <<Process config: process term: TBP>>
   end type process_term_t
 
 @ %def process_term_t
 @ For the output, we skip the process constants and the tables of
 allowed quantum numbers.  Those can also be read off from the
 interaction object.
 <<Process config: process term: TBP>>=
   procedure :: write => process_term_write
 <<Process config: procedures>>=
   subroutine process_term_write (term, unit)
     class(process_term_t), intent(in) :: term
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A,I0)")  "Term #", term%i_term_global
     write (u, "(3x,A,I0)")  "Process component index      = ", &
          term%i_component
     write (u, "(3x,A,I0)")  "Term index w.r.t. component  = ", &
          term%i_term
     call write_separator (u)
     write (u, "(1x,A)")  "Hard interaction:"
     call write_separator (u)
     call term%int%basic_write (u)
   end subroutine process_term_write
 
 @ %def process_term_write
 @ Write an account of all quantum number states and their current status.
 <<Process config: process term: TBP>>=
   procedure :: write_state_summary => process_term_write_state_summary
 <<Process config: procedures>>=
   subroutine process_term_write_state_summary (term, core, unit)
     class(process_term_t), intent(in) :: term
     class(prc_core_t), intent(in) :: core
     integer, intent(in), optional :: unit
     integer :: u, i, f, h, c
     type(state_iterator_t) :: it
     character :: sgn
     u = given_output_unit (unit)
     write (u, "(1x,A,I0)")  "Term #", term%i_term_global
     call it%init (term%int%get_state_matrix_ptr ())
     do while (it%is_valid ())
        i = it%get_me_index ()
        f = term%flv(i)
        h = term%hel(i)
        if (allocated (term%col)) then
           c = term%col(i)
        else
           c = 1
        end if
        if (core%is_allowed (term%i_term, f, h, c)) then
           sgn = "+"
        else
           sgn = " "
        end if
        write (u, "(1x,A1,1x,I0,2x)", advance="no")  sgn, i
        call quantum_numbers_write (it%get_quantum_numbers (), u)
        write (u, *)
        call it%advance ()
     end do
   end subroutine process_term_write_state_summary
 
 @ %def process_term_write_state_summary
 @ Finalizer: the [[int]] and potentially [[int_eff]] components have a
 finalizer that we must call.
 <<Process config: process term: TBP>>=
   procedure :: final => process_term_final
 <<Process config: procedures>>=
   subroutine process_term_final (term)
     class(process_term_t), intent(inout) :: term
     call term%int%final ()
   end subroutine process_term_final
 
 @ %def process_term_final
 @ Initialize the term.  We copy the process constants from the [[core]]
 object and set up the [[int]] hard interaction accordingly.
 
 The [[alpha_s]] value is useful for writing external event records.  This is
-the constant value which may be overridden by a event-specific running value.
+the constant value which may be overridden by an event-specific running value.
 If the model does not contain the strong coupling, the value is zero.
 
 The [[rearrange]] part is commented out; this or something equivalent
 could become relevant for NLO algorithms.
 <<Process config: process term: TBP>>=
   procedure :: init => process_term_init
 <<Process config: procedures>>=
   subroutine process_term_init &
        (term, i_term_global, i_component, i_term, core, model, &
         nlo_type, use_beam_pol, subtraction_method, &
         has_pdfs, n_emitters)
     class(process_term_t), intent(inout), target :: term
     integer, intent(in) :: i_term_global
     integer, intent(in) :: i_component
     integer, intent(in) :: i_term
     class(prc_core_t), intent(inout) :: core
     class(model_data_t), intent(in), target :: model
     integer, intent(in), optional :: nlo_type
     logical, intent(in), optional :: use_beam_pol
     type(string_t), intent(in), optional :: subtraction_method
     logical, intent(in), optional :: has_pdfs
     integer, intent(in), optional :: n_emitters
     class(modelpar_data_t), pointer :: alpha_s_ptr
     logical :: use_internal_color
     term%i_term_global = i_term_global
     term%i_component = i_component
     term%i_term = i_term
     call core%get_constants (term%data, i_term)
     alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas"))
     if (associated (alpha_s_ptr)) then
        term%alpha_s = alpha_s_ptr%get_real ()
     else
        term%alpha_s = -1
     end if
     use_internal_color = .false.
     if (present (subtraction_method)) &
          use_internal_color = (char (subtraction_method) == 'omega') &
          .or. (char (subtraction_method) == 'threshold')
     call term%setup_interaction (core, model, nlo_type = nlo_type, &
          pol_beams = use_beam_pol, use_internal_color = use_internal_color, &
          has_pdfs = has_pdfs, n_emitters = n_emitters)
   end subroutine process_term_init
 
 @ %def process_term_init
 @ We fetch the process constants which determine the quantum numbers and
 use those to create the interaction.  The interaction contains
 incoming and outgoing particles, no virtuals.  The incoming particles
 are parents of the outgoing ones.
 
 Keeping previous \whizard\ conventions, we invert the color assignment
 (but not flavor or helicity) for the incoming particles.  When the
 color-flow square matrix is evaluated, this inversion is done again,
 so in the color-flow sequence we get the color assignments of the
 matrix element.
 
 \textbf{Why are these four subtraction entries for structure-function
 aware interactions?} Taking the soft or collinear limit of the real-emission
 matrix element, the behavior of the parton energy fractions has to be
 taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$
 are given by
 \begin{equation*}
   x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}}
              \sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}},
   \quad
   x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}}
              \sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}.
 \end{equation*}
 In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$
 and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$,
 it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$.
 Likewise, in the anti-collinear limit $y \to -1$, the inverse relation holds.
 We therefore have to distinguish four cases with the PDF assignments
 $f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$,
 $f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and
 $f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$.
 
 The [[n_emitters]] optional argument is provided by the caller if this term
 requires spin-correlated matrix elements, and thus involves additional
 subtractions.
 <<Process config: process term: TBP>>=
   procedure :: setup_interaction => process_term_setup_interaction
 <<Process config: procedures>>=
   subroutine process_term_setup_interaction (term, core, model, &
      nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters)
     class(process_term_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     class(model_data_t), intent(in), target :: model
     logical, intent(in), optional :: pol_beams
     logical, intent(in), optional :: has_pdfs
     integer, intent(in), optional :: nlo_type
     logical, intent(in), optional :: use_internal_color
     integer, intent(in), optional :: n_emitters
     integer :: n, n_tot
     type(flavor_t), dimension(:), allocatable :: flv
     type(color_t), dimension(:), allocatable :: col
     type(helicity_t), dimension(:), allocatable :: hel
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     logical :: is_pol, use_color
     integer :: nlo_t, n_sub
     is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams
     nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type
     n_tot = term%data%n_in + term%data%n_out
     call count_number_of_states ()
     term%n_allowed = n
     call compute_n_sub (n_emitters, has_pdfs)
     call fill_quantum_numbers ()
     call term%int%basic_init &
          (term%data%n_in, 0, term%data%n_out, set_relations = .true.)
     select type (core)
     class is (prc_blha_t)
        call setup_states_blha_olp ()
     type is (prc_threshold_t)
        call setup_states_threshold ()
     class is (prc_external_t)
        call setup_states_other_prc_external ()
     class default
        call setup_states_omega ()
     end select
     call term%int%freeze ()
   contains
     subroutine count_number_of_states ()
       integer :: f, h, c
       n = 0
       select type (core)
       class is (prc_external_t)
          do f = 1, term%data%n_flv
             do h = 1, term%data%n_hel
                do c = 1, term%data%n_col
                   n = n + 1
                end do
             end do
          end do
       class default !!! Omega and all test cores
          do f = 1, term%data%n_flv
             do h = 1, term%data%n_hel
                do c = 1, term%data%n_col
                   if (core%is_allowed (term%i_term, f, h, c))  n = n + 1
                end do
             end do
          end do
       end select
     end subroutine count_number_of_states
 
     subroutine compute_n_sub (n_emitters, has_pdfs)
       integer, intent(in), optional :: n_emitters
       logical, intent(in), optional :: has_pdfs
       logical :: can_have_sub
       integer :: n_sub_color, n_sub_spin
       use_color = .false.; if (present (use_internal_color)) &
            use_color = use_internal_color
       can_have_sub = nlo_t == NLO_VIRTUAL .or. &
            (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
            nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
       n_sub_color = 0; n_sub_spin = 0
       if (can_have_sub) then
          if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2
          if (nlo_t == NLO_REAL) then
             if (present (n_emitters)) then
                n_sub_spin = 6 * n_emitters
             end if
          end if
       end if
       n_sub = n_sub_color + n_sub_spin
       !!! For the virtual subtraction we also need the finite virtual contribution
       !!! corresponding to the $\epsilon^0$-pole
       if (nlo_t == NLO_VIRTUAL)  n_sub = n_sub + 1
       if (present (has_pdfs)) then
          if (has_pdfs &
               .and. ((nlo_t == NLO_REAL .and. can_have_sub) &
               .or. nlo_t == NLO_DGLAP)) then
             !!! necessary dummy, needs refactoring,
             !!! c.f. [[term_instance_evaluate_interaction_userdef_tree]]
             n_sub = n_sub + n_beams_rescaled
          end if
       end if
       term%n_sub = n_sub
       term%n_sub_color = n_sub_color
       term%n_sub_spin = n_sub_spin
     end subroutine compute_n_sub
 
     subroutine fill_quantum_numbers ()
       integer :: nn
       logical :: can_have_sub
       select type (core)
       class is (prc_external_t)
          can_have_sub = nlo_t == NLO_VIRTUAL .or. &
               (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
               nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
          if (can_have_sub) then
             nn = (n_sub + 1) * n
          else
             nn = n
          end if
       class default
          nn = n
       end select
       allocate (term%flv (nn), term%col (nn), term%hel (nn))
       allocate (flv (n_tot), col (n_tot), hel (n_tot))
       allocate (qn (n_tot))
     end subroutine fill_quantum_numbers
 
     subroutine setup_states_blha_olp ()
       integer :: s, f, c, h, i
       i = 0
       associate (data => term%data)
          do s = 0, n_sub
              do f = 1, data%n_flv
                 do h = 1, data%n_hel
                    do c = 1, data%n_col
                       i = i + 1
                       term%flv(i) = f
                       term%hel(i) = h
                       !!! Dummy-initialization of color
                       term%col(i) = c
                       call flv%init (data%flv_state (:,f), model)
                       call color_init_from_array (col, &
                            data%col_state(:,:,c), data%ghost_flag(:,c))
                       call col(1:data%n_in)%invert ()
                       if (is_pol) then
                          select type (core)
                          type is (prc_openloops_t)
                             call hel%init (data%hel_state (:,h))
                             call qn%init (flv, hel, col, s)
                          class default
                             call msg_fatal ("Polarized beams only supported by OpenLoops")
                          end select
                       else
                          call qn%init (flv, col, s)
                       end if
                       call qn%tag_hard_process ()
                       call term%int%add_state (qn)
                   end do
                end do
              end do
          end do
       end associate
     end subroutine setup_states_blha_olp
 
     subroutine setup_states_threshold ()
       integer :: s, f, c, h, i
       i = 0
       n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
       associate (data => term%data)
          do s = 0, n_sub
             do f = 1, term%data%n_flv
                do h = 1, data%n_hel
                   do c = 1, data%n_col
                      i = i + 1
                      term%flv(i) = f
                      term%hel(i) = h
                      !!! Dummy-initialization of color
                      term%col(i) = 1
                      call flv%init (term%data%flv_state (:,f), model)
                      if (is_pol) then
                         call hel%init (data%hel_state (:,h))
                         call qn%init (flv, hel, s)
                      else
                         call qn%init (flv, s)
                      end if
                      call qn%tag_hard_process ()
                      call term%int%add_state (qn)
                   end do
                end do
             end do
          end do
       end associate
     end subroutine setup_states_threshold
 
     subroutine setup_states_other_prc_external ()
       integer :: s, f, i, c, h
       if (is_pol) &
          call msg_fatal ("Polarized beams only supported by OpenLoops")
       i = 0
       !!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
       associate (data => term%data)
         do s = 0, n_sub
            do f = 1, data%n_flv
               do h = 1, data%n_hel
                  do c = 1, data%n_col
                     i = i + 1
                     term%flv(i) = f
                     term%hel(i) = h
                     !!! Dummy-initialization of color
                     term%col(i) = c
                     call flv%init (data%flv_state (:,f), model)
                     call color_init_from_array (col, &
                          data%col_state(:,:,c), data%ghost_flag(:,c))
                     call col(1:data%n_in)%invert ()
                     call qn%init (flv, col, s)
                     call qn%tag_hard_process ()
                     call term%int%add_state (qn)
                  end do
               end do
            end do
         end do
       end associate
     end subroutine setup_states_other_prc_external
 
     subroutine setup_states_omega ()
       integer :: f, h, c, i
       i = 0
       associate (data => term%data)
          do f = 1, data%n_flv
             do h = 1, data%n_hel
               do c = 1, data%n_col
                  if (core%is_allowed (term%i_term, f, h, c)) then
                     i = i + 1
                     term%flv(i) = f
                     term%hel(i) = h
                     term%col(i) = c
                     call flv%init (data%flv_state(:,f), model)
                     call color_init_from_array (col, &
                          data%col_state(:,:,c), &
                          data%ghost_flag(:,c))
                     call col(:data%n_in)%invert ()
                     call hel%init (data%hel_state(:,h))
                     call qn%init (flv, col, hel)
                     call qn%tag_hard_process ()
                     call term%int%add_state (qn)
                  end if
               end do
             end do
          end do
       end associate
     end subroutine setup_states_omega
 
   end subroutine process_term_setup_interaction
 
 @ %def process_term_setup_interaction
 @
 <<Process config: process term: TBP>>=
   procedure :: get_process_constants => process_term_get_process_constants
 <<Process config: procedures>>=
    subroutine process_term_get_process_constants &
        (term, prc_constants)
     class(process_term_t), intent(inout) :: term
     type(process_constants_t), intent(out) :: prc_constants
     prc_constants = term%data
   end subroutine process_term_get_process_constants
 
 @ %def process_term_get_process_constants
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process call statistics}
 Very simple object for statistics.  Could be moved to a more basic chapter.
 <<[[process_counter.f90]]>>=
 <<File header>>
 
 module process_counter
 
   use io_units
 
 <<Standard module head>>
 
 <<Process counter: public>>
 
 <<Process counter: parameters>>
 
 <<Process counter: types>>
 
 contains
 
 <<Process counter: procedures>>
 
 end module process_counter
 @ %def process_counter
 @ This object can record process calls, categorized by evaluation
 status.  It is a part of the [[mci_entry]] component below.
 <<Process counter: public>>=
   public :: process_counter_t
 <<Process counter: types>>=
   type :: process_counter_t
      integer :: total = 0
      integer :: failed_kinematics = 0
      integer :: failed_cuts = 0
      integer :: has_passed = 0
      integer :: evaluated = 0
      integer :: complete = 0
    contains
    <<Process counter: process counter: TBP>>
   end type process_counter_t
 
 @ %def process_counter_t
 @ Here are the corresponding numeric codes:
 <<Process counter: parameters>>=
   integer, parameter, public :: STAT_UNDEFINED = 0
   integer, parameter, public :: STAT_INITIAL = 1
   integer, parameter, public :: STAT_ACTIVATED = 2
   integer, parameter, public :: STAT_BEAM_MOMENTA = 3
   integer, parameter, public :: STAT_FAILED_KINEMATICS = 4
   integer, parameter, public :: STAT_SEED_KINEMATICS = 5
   integer, parameter, public :: STAT_HARD_KINEMATICS = 6
   integer, parameter, public :: STAT_EFF_KINEMATICS = 7
   integer, parameter, public :: STAT_FAILED_CUTS = 8
   integer, parameter, public :: STAT_PASSED_CUTS = 9
   integer, parameter, public :: STAT_EVALUATED_TRACE = 10
   integer, parameter, public :: STAT_EVENT_COMPLETE = 11
 
 @ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED
 @ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS
 @ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS
 @ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE
 @ Output.
 <<Process counter: process counter: TBP>>=
   procedure :: write => process_counter_write
 <<Process counter: procedures>>=
   subroutine process_counter_write (object, unit)
     class(process_counter_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     if (object%total > 0) then
        write (u, "(1x,A)")  "Call statistics (current run):"
        write (u, "(3x,A,I0)")  "total       = ", object%total
        write (u, "(3x,A,I0)")  "failed kin. = ", object%failed_kinematics
        write (u, "(3x,A,I0)")  "failed cuts = ", object%failed_cuts
        write (u, "(3x,A,I0)")  "passed cuts = ", object%has_passed
        write (u, "(3x,A,I0)")  "evaluated   = ", object%evaluated
     else
        write (u, "(1x,A)")  "Call statistics (current run): [no calls]"
     end if
   end subroutine process_counter_write
 
 @ %def process_counter_write
 @ Reset.  Just enforce default initialization.
 <<Process counter: process counter: TBP>>=
   procedure :: reset => process_counter_reset
 <<Process counter: procedures>>=
   subroutine process_counter_reset (counter)
     class(process_counter_t), intent(out) :: counter
     counter%total = 0
     counter%failed_kinematics = 0
     counter%failed_cuts = 0
     counter%has_passed = 0
     counter%evaluated = 0
     counter%complete = 0
   end subroutine process_counter_reset
 
 @ %def process_counter_reset
 @ We record an event according to the lowest status code greater or
 equal to the actual status.  This is actually done by the process
 instance; the process object just copies the instance counter.
 <<Process counter: process counter: TBP>>=
   procedure :: record => process_counter_record
 <<Process counter: procedures>>=
   subroutine process_counter_record (counter, status)
     class(process_counter_t), intent(inout) :: counter
     integer, intent(in) :: status
     if (status <= STAT_FAILED_KINEMATICS) then
        counter%failed_kinematics = counter%failed_kinematics + 1
     else if (status <= STAT_FAILED_CUTS) then
        counter%failed_cuts = counter%failed_cuts + 1
     else if (status <= STAT_PASSED_CUTS) then
        counter%has_passed = counter%has_passed + 1
     else
        counter%evaluated = counter%evaluated + 1
     end if
     counter%total = counter%total + 1
   end subroutine process_counter_record
 
 @ %def process_counter_record
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Multi-channel integration}
 <<[[process_mci.f90]]>>=
 <<File header>>
 
 module process_mci
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use diagnostics
   use physics_defs
   use md5
   use cputime
   use rng_base
   use mci_base
   use variables
   use integration_results
   use process_libraries
   use phs_base
   use process_counter
   use process_config
 
 
 <<Standard module head>>
 
 <<Process mci: public>>
 
 <<Process mci: parameters>>
 
 <<Process mci: types>>
 
 contains
 
 <<Process mci: procedures>>
 
 end module process_mci
 @ %def process_mci
 \subsection{Process MCI entry}
 The [[process_mci_entry_t]] block contains, for each process component that is
 integrated independently, the configuration data for its MC input parameters.
 Each input parameter set is handled by a [[mci_t]] integrator.
 
 The MC input parameter set is broken down into the parameters required by the
 structure-function chain and the parameters required by the phase space of the
 elementary process.
 
 The MD5 sum collects all information about the associated processes
 that may affect the integration.  It does not contain the MCI object
 itself or integration results.
 
 MC integration is organized in passes.  Each pass may consist of
 several iterations, and for each iteration there is a number of
 calls.  We store explicitly the values that apply to the current
 pass.  Previous values are archived in the [[results]] object.
 
 The [[counter]] receives the counter statistics from the associated
 process instance, for diagnostics.
 
 The [[results]] object records results, broken down in passes and iterations.
 <<Process mci: public>>=
   public :: process_mci_entry_t
 <<Process mci: types>>=
   type :: process_mci_entry_t
      integer :: i_mci = 0
      integer, dimension(:), allocatable :: i_component
      integer :: process_type = PRC_UNKNOWN
      integer :: n_par = 0
      integer :: n_par_sf = 0
      integer :: n_par_phs = 0
      character(32) :: md5sum = ""
      integer :: pass = 0
      integer :: n_it = 0
      integer :: n_calls = 0
      logical :: activate_timer = .false.
      real(default) :: error_threshold = 0
      class(mci_t), allocatable :: mci
      type(process_counter_t) :: counter
      type(integration_results_t) :: results
      logical :: negative_weights = .false.
      logical :: combined_integration = .false.
      integer :: real_partition_type = REAL_FULL
    contains
    <<Process mci: process mci entry: TBP>>
   end type process_mci_entry_t
 
 @ %def process_mci_entry_t
 @ Finalizer for the [[mci]] component.
 <<Process mci: process mci entry: TBP>>=
   procedure :: final => process_mci_entry_final
 <<Process mci: procedures>>=
   subroutine process_mci_entry_final (object)
     class(process_mci_entry_t), intent(inout) :: object
     if (allocated (object%mci))  call object%mci%final ()
   end subroutine process_mci_entry_final
 
 @ %def process_mci_entry_final
 @ Output.  Write pass/iteration information only if set (the pass
 index is nonzero).  Write the MCI block only if it exists (for some
 self-tests it does not).  Write results only if there are any.
 <<Process mci: process mci entry: TBP>>=
   procedure :: write => process_mci_entry_write
 <<Process mci: procedures>>=
   subroutine process_mci_entry_write (object, unit, pacify)
     class(process_mci_entry_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacify
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A,I0)")  "Associated components = ", object%i_component
     write (u, "(3x,A,I0)")  "MC input parameters   = ", object%n_par
     write (u, "(3x,A,I0)")  "MC parameters (SF)    = ", object%n_par_sf
     write (u, "(3x,A,I0)")  "MC parameters (PHS)   = ", object%n_par_phs
     if (object%pass > 0) then
        write (u, "(3x,A,I0)")  "Current pass          = ", object%pass
        write (u, "(3x,A,I0)")  "Number of iterations  = ", object%n_it
        write (u, "(3x,A,I0)")  "Number of calls       = ", object%n_calls
     end if
     if (object%md5sum /= "") then
        write (u, "(3x,A,A,A)") "MD5 sum (components)  = '", object%md5sum, "'"
     end if
     if (allocated (object%mci)) then
        call object%mci%write (u)
     end if
     call object%counter%write (u)
     if (object%results%exist ()) then
        call object%results%write (u, suppress = pacify)
        call object%results%write_chain_weights (u)
     end if
   end subroutine process_mci_entry_write
 
 @ %def process_mci_entry_write
 @ Configure the MCI entry.  This is intent(inout) since some specific settings
 may be done before this.  The actual [[mci_t]] object is an instance of the
 [[mci_template]] argument, which determines the concrete types.
 
 In a unit-test context, the [[mci_template]] argument may be unallocated.
 
 We obtain the number of channels and the number of parameters, separately for
 the structure-function chain and for the associated process component.  We
 assume that the phase-space object has already been configured.
 
 We assume that there is only one process component directly associated with a
 MCI entry.
 <<Process mci: process mci entry: TBP>>=
   procedure :: configure => process_mci_entry_configure
 <<Process mci: procedures>>=
   subroutine process_mci_entry_configure (mci_entry, mci_template, &
        process_type, i_mci, i_component, component, &
        n_sfpar, rng_factory)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_t), intent(in), allocatable :: mci_template
     integer, intent(in) :: process_type
     integer, intent(in) :: i_mci
     integer, intent(in) :: i_component
     type(process_component_t), intent(in), target :: component
     integer, intent(in) :: n_sfpar
     class(rng_factory_t), intent(inout) :: rng_factory
     class(rng_t), allocatable :: rng
     associate (phs_config => component%phs_config)
       mci_entry%i_mci = i_mci
       call mci_entry%create_component_list (i_component, component%get_config ())
       mci_entry%n_par_sf = n_sfpar
       mci_entry%n_par_phs = phs_config%get_n_par ()
       mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs
       mci_entry%process_type = process_type
       if (allocated (mci_template)) then
          allocate (mci_entry%mci, source = mci_template)
          call mci_entry%mci%record_index (mci_entry%i_mci)
          call mci_entry%mci%set_dimensions &
               (mci_entry%n_par, phs_config%get_n_channel ())
          call mci_entry%mci%declare_flat_dimensions &
               (phs_config%get_flat_dimensions ())
          if (phs_config%provides_equivalences) then
             call mci_entry%mci%declare_equivalences &
                  (phs_config%channel, mci_entry%n_par_sf)
          end if
          if (phs_config%provides_chains) then
             call mci_entry%mci%declare_chains (phs_config%chain)
          end if
          call rng_factory%make (rng)
          call mci_entry%mci%import_rng (rng)
       end if
       call mci_entry%results%init (process_type)
     end associate
   end subroutine process_mci_entry_configure
 
 @ %def process_mci_entry_configure
 @
 <<Process mci: parameters>>=
   integer, parameter, public :: REAL_FULL = 0
   integer, parameter, public :: REAL_SINGULAR = 1
   integer, parameter, public :: REAL_FINITE = 2
 @
 <<Process mci: process mci entry: TBP>>=
   procedure :: create_component_list => &
      process_mci_entry_create_component_list
 <<Process mci: procedures>>=
   subroutine process_mci_entry_create_component_list (mci_entry, &
      i_component, component_config)
     class (process_mci_entry_t), intent(inout) :: mci_entry
     integer, intent(in) :: i_component
     type(process_component_def_t), intent(in) :: component_config
     integer, dimension(:), allocatable :: i_list
     integer :: n
     integer, save :: i_rfin_offset = 0
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list")
     if (mci_entry%combined_integration) then
        if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
             "mci_entry%real_partition_type", mci_entry%real_partition_type)
        n = get_n_components (mci_entry%real_partition_type)
        allocate (i_list (n))
        select case (mci_entry%real_partition_type)
        case (REAL_FULL)
           i_list = component_config%get_association_list ()
           allocate (mci_entry%i_component (size (i_list)))
           mci_entry%i_component = i_list
        case (REAL_SINGULAR)
           i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN)
           allocate (mci_entry%i_component (size(i_list)))
           mci_entry%i_component = i_list
        case (REAL_FINITE)
           allocate (mci_entry%i_component (1))
           mci_entry%i_component(1) = &
                component_config%get_associated_real_fin () + i_rfin_offset
           i_rfin_offset = i_rfin_offset + 1
        end select
     else
        allocate (mci_entry%i_component (1))
        mci_entry%i_component(1) = i_component
     end if
   contains
     function get_n_components (real_partition_type) result (n_components)
       integer :: n_components
       integer, intent(in) :: real_partition_type
       select case (real_partition_type)
       case (REAL_FULL)
          n_components = size (component_config%get_association_list ())
       case (REAL_SINGULAR)
          n_components = size (component_config%get_association_list &
             (ASSOCIATED_REAL_FIN))
       end select
       if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "n_components", n_components)
     end function get_n_components
   end subroutine process_mci_entry_create_component_list
 
 @ %def process_mci_entry_create_component_list
 @ Set some additional parameters.
 <<Process mci: process mci entry: TBP>>=
   procedure :: set_parameters => process_mci_entry_set_parameters
 <<Process mci: procedures>>=
   subroutine process_mci_entry_set_parameters (mci_entry, var_list)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     type(var_list_t), intent(in) :: var_list
     integer :: integration_results_verbosity
     real(default) :: error_threshold
     integration_results_verbosity = &
          var_list%get_ival (var_str ("integration_results_verbosity"))
     error_threshold = &
          var_list%get_rval (var_str ("error_threshold"))
     mci_entry%activate_timer = &
          var_list%get_lval (var_str ("?integration_timer"))
     call mci_entry%results%set_verbosity (integration_results_verbosity)
     call mci_entry%results%set_error_threshold (error_threshold)
   end subroutine process_mci_entry_set_parameters
 
 @ %def process_mci_entry_set_parameters
 @ Compute an MD5 sum that summarizes all information that could
 influence integration results, for the associated process components.
 We take the process-configuration MD5 sum which represents parameters,
 cuts, etc., the MD5 sums for the process component definitions and
 their phase space objects (which should be configured), and the beam
 configuration MD5 sum.  (The QCD setup is included in the process
 configuration data MD5 sum.)
 
 Done only once, when the MD5 sum is still empty.
 <<Process mci: process mci entry: TBP>>=
   procedure :: compute_md5sum => process_mci_entry_compute_md5sum
 <<Process mci: procedures>>=
   subroutine process_mci_entry_compute_md5sum (mci_entry, &
        config, component, beam_config)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     type(process_config_data_t), intent(in) :: config
     type(process_component_t), dimension(:), intent(in) :: component
     type(process_beam_config_t), intent(in) :: beam_config
     type(string_t) :: buffer
     integer :: i
     if (mci_entry%md5sum == "") then
        buffer = config%get_md5sum () // beam_config%get_md5sum ()
        do i = 1, size (component)
           if (component(i)%is_active ()) then
              buffer = buffer // component(i)%get_md5sum ()
           end if
        end do
        mci_entry%md5sum = md5sum (char (buffer))
     end if
     if (allocated (mci_entry%mci)) then
        call mci_entry%mci%set_md5sum (mci_entry%md5sum)
     end if
   end subroutine process_mci_entry_compute_md5sum
 
 @ %def process_mci_entry_compute_md5sum
 @ Test the MCI sampler by calling it a given number of time, discarding the
 results.  The instance should be initialized.
 
 The [[mci_entry]] is [[intent(inout)]] because the integrator contains
 the random-number state.
 <<Process mci: process mci entry: TBP>>=
   procedure :: sampler_test => process_mci_entry_sampler_test
 <<Process mci: procedures>>=
   subroutine process_mci_entry_sampler_test (mci_entry, mci_sampler, n_calls)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_sampler_t), intent(inout), target :: mci_sampler
     integer, intent(in) :: n_calls
     call mci_entry%mci%sampler_test (mci_sampler, n_calls)
   end subroutine process_mci_entry_sampler_test
 
 @ %def process_mci_entry_sampler_test
 @ Integrate.
 
 The [[integrate]] method counts as an integration pass; the pass count is
 increased by one.  We transfer the pass parameters (number of iterations and
 number of calls) to the actual integration routine.
 
 The [[mci_entry]] is [[intent(inout)]] because the integrator contains
 the random-number state.
 
 Note: The results are written to screen and to logfile.  This behavior
 is hardcoded.
 <<Process mci: process mci entry: TBP>>=
   procedure :: integrate => process_mci_entry_integrate
   procedure :: final_integration => process_mci_entry_final_integration
 <<Process mci: procedures>>=
   subroutine process_mci_entry_integrate (mci_entry, mci_instance, &
          mci_sampler, n_it, n_calls, &
        adapt_grids, adapt_weights, final, pacify, &
        nlo_type)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_instance_t), intent(inout) :: mci_instance
     class(mci_sampler_t), intent(inout) :: mci_sampler
     integer, intent(in) :: n_it
     integer, intent(in) :: n_calls
     logical, intent(in), optional :: adapt_grids
     logical, intent(in), optional :: adapt_weights
     logical, intent(in), optional :: final, pacify
     integer, intent(in), optional :: nlo_type
     integer :: u_log
     u_log = logfile_unit ()
     mci_entry%pass = mci_entry%pass + 1
     mci_entry%n_it = n_it
     mci_entry%n_calls = n_calls
     if (mci_entry%pass == 1)  &
          call mci_entry%mci%startup_message (n_calls = n_calls)
     call mci_entry%mci%set_timer (active = mci_entry%activate_timer)
     call mci_entry%results%display_init (screen = .true., unit = u_log)
     call mci_entry%results%new_pass ()
     if (present (nlo_type)) then
        select case (nlo_type)
        case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
           mci_instance%negative_weights = .true.
        end select
     end if
     call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final)
     call mci_entry%mci%start_timer ()
     call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, &
          n_calls, mci_entry%results, pacify = pacify)
     call mci_entry%mci%stop_timer ()
     if (signal_is_pending ())  return
   end subroutine process_mci_entry_integrate
 
   subroutine process_mci_entry_final_integration (mci_entry)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     call mci_entry%results%display_final ()
     call mci_entry%time_message ()
   end subroutine process_mci_entry_final_integration
 
 @ %def process_mci_entry_integrate
 @ %def process_mci_entry_final_integration
 @ If appropriate, issue an informative message about the expected time
 for an event sample.
 <<Process mci: process mci entry: TBP>>=
   procedure :: get_time => process_mci_entry_get_time
   procedure :: time_message => process_mci_entry_time_message
 <<Process mci: procedures>>=
   subroutine process_mci_entry_get_time (mci_entry, time, sample)
     class(process_mci_entry_t), intent(in) :: mci_entry
     type(time_t), intent(out) :: time
     integer, intent(in) :: sample
     real(default) :: time_last_pass, efficiency, calls
     time_last_pass = mci_entry%mci%get_time ()
     calls = mci_entry%results%get_n_calls ()
     efficiency = mci_entry%mci%get_efficiency ()
     if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then
        time = nint (time_last_pass / calls / efficiency * sample)
     end if
   end subroutine process_mci_entry_get_time
 
   subroutine process_mci_entry_time_message (mci_entry)
     class(process_mci_entry_t), intent(in) :: mci_entry
     type(time_t) :: time
     integer :: sample
     sample = 10000
     call mci_entry%get_time (time, sample)
     if (time%is_known ()) then
        call msg_message ("Time estimate for generating 10000 events: " &
             // char (time%to_string_dhms ()))
     end if
   end subroutine process_mci_entry_time_message
 
 @ %def process_mci_entry_time_message
 @ Prepare event generation.  (For the test integrator, this does nothing.  It
 is relevant for the VAMP integrator.)
 <<Process mci: process mci entry: TBP>>=
   procedure :: prepare_simulation => process_mci_entry_prepare_simulation
 <<Process mci: procedures>>=
   subroutine process_mci_entry_prepare_simulation (mci_entry)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     call mci_entry%mci%prepare_simulation ()
   end subroutine process_mci_entry_prepare_simulation
 
 @ %def process_mci_entry_prepare_simulation
 @ Generate an event.  The instance should be initialized,
 otherwise event generation is directed by the [[mci]] integrator
 subobject.  The integrator instance is contained in a [[mci_work]]
 subobject of the process instance, which simultaneously serves as the
 sampler object.  (We avoid the anti-aliasing rules if we assume that
 the sampling itself does not involve the integrator instance contained in the
 process instance.)
 
 Regarding weighted events, we only take events which are valid, which
 means that they have valid kinematics and have passed cuts.
 Therefore, we have a rejection loop.  For unweighted events, the
 unweighting routine should already take care of this.
 
 The [[keep_failed]] flag determines whether events which failed cuts
 are nevertheless produced, to be recorded with zero weight.
 Alternatively, failed events are dropped, and this fact is recorded by
 the counter [[n_dropped]].
 <<Process mci: process mci entry: TBP>>=
   procedure :: generate_weighted_event => &
        process_mci_entry_generate_weighted_event
   procedure :: generate_unweighted_event => &
        process_mci_entry_generate_unweighted_event
 <<Process mci: procedures>>=
   subroutine process_mci_entry_generate_weighted_event (mci_entry, &
       mci_instance, mci_sampler, keep_failed)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_instance_t), intent(inout) :: mci_instance
     class(mci_sampler_t), intent(inout) :: mci_sampler
     logical, intent(in) :: keep_failed
     logical :: generate_new
     generate_new = .true.
     call mci_instance%reset_n_event_dropped ()
     REJECTION: do while (generate_new)
        call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler)
        if (signal_is_pending ())  return
        if (.not. mci_sampler%is_valid()) then
           if (keep_failed) then
              generate_new = .false.
           else
              call mci_instance%record_event_dropped ()
              generate_new = .true.
           end if
        else
           generate_new = .false.
        end if
     end do REJECTION
   end subroutine process_mci_entry_generate_weighted_event
 
   subroutine process_mci_entry_generate_unweighted_event (mci_entry, mci_instance, mci_sampler)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_instance_t), intent(inout) :: mci_instance
     class(mci_sampler_t), intent(inout) :: mci_sampler
     call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler)
   end subroutine process_mci_entry_generate_unweighted_event
 
 @ %def process_mci_entry_generate_weighted_event
 @ %def process_mci_entry_generate_unweighted_event
 @ Extract results.
 <<Process mci: process mci entry: TBP>>=
   procedure :: has_integral => process_mci_entry_has_integral
   procedure :: get_integral => process_mci_entry_get_integral
   procedure :: get_error => process_mci_entry_get_error
   procedure :: get_accuracy => process_mci_entry_get_accuracy
   procedure :: get_chi2 => process_mci_entry_get_chi2
   procedure :: get_efficiency => process_mci_entry_get_efficiency
 <<Process mci: procedures>>=
   function process_mci_entry_has_integral (mci_entry) result (flag)
     class(process_mci_entry_t), intent(in) :: mci_entry
     logical :: flag
     flag = mci_entry%results%exist ()
   end function process_mci_entry_has_integral
 
   function process_mci_entry_get_integral (mci_entry) result (integral)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: integral
     integral = mci_entry%results%get_integral ()
   end function process_mci_entry_get_integral
 
   function process_mci_entry_get_error (mci_entry) result (error)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: error
     error = mci_entry%results%get_error ()
   end function process_mci_entry_get_error
 
   function process_mci_entry_get_accuracy (mci_entry) result (accuracy)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: accuracy
     accuracy = mci_entry%results%get_accuracy ()
   end function process_mci_entry_get_accuracy
 
   function process_mci_entry_get_chi2 (mci_entry) result (chi2)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: chi2
     chi2 = mci_entry%results%get_chi2 ()
   end function process_mci_entry_get_chi2
 
   function process_mci_entry_get_efficiency (mci_entry) result (efficiency)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: efficiency
     efficiency = mci_entry%results%get_efficiency ()
   end function process_mci_entry_get_efficiency
 
 @ %def process_mci_entry_get_integral process_mci_entry_get_error
 @ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2
 @ %def process_mci_entry_get_efficiency
 @ Return the MCI checksum.  This may be the one used for
 configuration, but may also incorporate results, if they change the
 state of the integrator (adaptation).
 <<Process mci: process mci entry: TBP>>=
   procedure :: get_md5sum => process_mci_entry_get_md5sum
 <<Process mci: procedures>>=
   pure function process_mci_entry_get_md5sum (entry) result (md5sum)
     class(process_mci_entry_t), intent(in) :: entry
     character(32) :: md5sum
     md5sum = entry%mci%get_md5sum ()
   end function process_mci_entry_get_md5sum
 
 @ %def process_mci_entry_get_md5sum
 @
 \subsection{MC parameter set and MCI instance}
 For each process component that is associated with a multi-channel integration
 (MCI) object, the [[mci_work_t]] object contains the currently active
 parameter set.  It also holds the implementation of the [[mci_instance_t]]
 that the integrator needs for doing its work.
 <<Process mci: public>>=
   public :: mci_work_t
 <<Process mci: types>>=
   type :: mci_work_t
      type(process_mci_entry_t), pointer :: config => null ()
      real(default), dimension(:), allocatable :: x
      class(mci_instance_t), pointer :: mci => null ()
      type(process_counter_t) :: counter
      logical :: keep_failed_events = .false.
      integer :: n_event_dropped = 0
    contains
    <<Process mci: mci work: TBP>>
   end type mci_work_t
 
 @ %def mci_work_t
 @ First write configuration data, then the current values.
 <<Process mci: mci work: TBP>>=
   procedure :: write => mci_work_write
 <<Process mci: procedures>>=
   subroutine mci_work_write (mci_work, unit, testflag)
     class(mci_work_t), intent(in) :: mci_work
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A,I0,A)")  "Active MCI instance #", &
          mci_work%config%i_mci, " ="
     write (u, "(2x)", advance="no")
     do i = 1, mci_work%config%n_par
        write (u, "(1x,F7.5)", advance="no")  mci_work%x(i)
        if (i == mci_work%config%n_par_sf) &
             write (u, "(1x,'|')", advance="no")
     end do
     write (u, *)
     if (associated (mci_work%mci)) then
        call mci_work%mci%write (u, pacify = testflag)
        call mci_work%counter%write (u)
     end if
   end subroutine mci_work_write
 
 @ %def mci_work_write
 @ The [[mci]] component may require finalization.
 <<Process mci: mci work: TBP>>=
   procedure :: final => mci_work_final
 <<Process mci: procedures>>=
   subroutine mci_work_final (mci_work)
     class(mci_work_t), intent(inout) :: mci_work
     if (associated (mci_work%mci)) then
        call mci_work%mci%final ()
        deallocate (mci_work%mci)
     end if
   end subroutine mci_work_final
 
 @ %def mci_work_final
 @ Initialize with the maximum length that we will need.  Contents are
 not initialized.
 
 The integrator inside the [[mci_entry]] object is responsible for
 allocating and initializing its own instance, which is referred to by
 a pointer in the [[mci_work]] object.
 <<Process mci: mci work: TBP>>=
   procedure :: init => mci_work_init
 <<Process mci: procedures>>=
   subroutine mci_work_init (mci_work, mci_entry)
     class(mci_work_t), intent(out) :: mci_work
     type(process_mci_entry_t), intent(in), target :: mci_entry
     mci_work%config => mci_entry
     allocate (mci_work%x (mci_entry%n_par))
     if (allocated (mci_entry%mci)) then
        call mci_entry%mci%allocate_instance (mci_work%mci)
        call mci_work%mci%init (mci_entry%mci)
     end if
   end subroutine mci_work_init
 
 @ %def mci_work_init
 @ Set parameters explicitly, either all at once, or separately for the
 structure-function and process parts.
 <<Process mci: mci work: TBP>>=
   procedure :: set => mci_work_set
   procedure :: set_x_strfun => mci_work_set_x_strfun
   procedure :: set_x_process => mci_work_set_x_process
 <<Process mci: procedures>>=
   subroutine mci_work_set (mci_work, x)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), dimension(:), intent(in) :: x
     mci_work%x = x
   end subroutine mci_work_set
 
   subroutine mci_work_set_x_strfun (mci_work, x)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), dimension(:), intent(in) :: x
     mci_work%x(1 : mci_work%config%n_par_sf) = x
   end subroutine mci_work_set_x_strfun
 
   subroutine mci_work_set_x_process (mci_work, x)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), dimension(:), intent(in) :: x
     mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x
   end subroutine mci_work_set_x_process
 
 @ %def mci_work_set
 @ %def mci_work_set_x_strfun
 @ %def mci_work_set_x_process
 @ Return the array of active components, i.e., those that correspond
 to the currently selected MC parameter set.
 <<Process mci: mci work: TBP>>=
   procedure :: get_active_components => mci_work_get_active_components
 <<Process mci: procedures>>=
   function mci_work_get_active_components (mci_work) result (i_component)
     class(mci_work_t), intent(in) :: mci_work
     integer, dimension(:), allocatable :: i_component
     allocate (i_component (size (mci_work%config%i_component)))
     i_component = mci_work%config%i_component
   end function mci_work_get_active_components
 
 @ %def mci_work_get_active_components
 @ Return the active parameters as a simple array with correct length.
 Do this separately for the structure-function parameters and the
 process parameters.
 <<Process mci: mci work: TBP>>=
   procedure :: get_x_strfun => mci_work_get_x_strfun
   procedure :: get_x_process => mci_work_get_x_process
 <<Process mci: procedures>>=
   pure function mci_work_get_x_strfun (mci_work) result (x)
     class(mci_work_t), intent(in) :: mci_work
     real(default), dimension(mci_work%config%n_par_sf) :: x
     x = mci_work%x(1 : mci_work%config%n_par_sf)
   end function mci_work_get_x_strfun
 
   pure function mci_work_get_x_process (mci_work) result (x)
     class(mci_work_t), intent(in) :: mci_work
     real(default), dimension(mci_work%config%n_par_phs) :: x
     x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par)
   end function mci_work_get_x_process
 
 @ %def mci_work_get_x_strfun
 @ %def mci_work_get_x_process
 @ Initialize and finalize event generation for the specified MCI
 entry.  This also resets the counter.
 <<Process mci: mci work: TBP>>=
   procedure :: init_simulation => mci_work_init_simulation
   procedure :: final_simulation => mci_work_final_simulation
 <<Process mci: procedures>>=
   subroutine mci_work_init_simulation (mci_work, safety_factor, keep_failed_events)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), intent(in), optional :: safety_factor
     logical, intent(in), optional :: keep_failed_events
     call mci_work%mci%init_simulation (safety_factor)
     call mci_work%counter%reset ()
     if (present (keep_failed_events)) &
        mci_work%keep_failed_events = keep_failed_events
   end subroutine mci_work_init_simulation
 
   subroutine mci_work_final_simulation (mci_work)
     class(mci_work_t), intent(inout) :: mci_work
     call mci_work%mci%final_simulation ()
   end subroutine mci_work_final_simulation
 
 @ %def mci_work_init_simulation
 @ %def mci_work_final_simulation
 @ Counter.
 <<Process mci: mci work: TBP>>=
   procedure :: reset_counter => mci_work_reset_counter
   procedure :: record_call => mci_work_record_call
   procedure :: get_counter => mci_work_get_counter
 <<Process mci: procedures>>=
   subroutine mci_work_reset_counter (mci_work)
     class(mci_work_t), intent(inout) :: mci_work
     call mci_work%counter%reset ()
   end subroutine mci_work_reset_counter
 
   subroutine mci_work_record_call (mci_work, status)
     class(mci_work_t), intent(inout) :: mci_work
     integer, intent(in) :: status
     call mci_work%counter%record (status)
   end subroutine mci_work_record_call
 
   pure function mci_work_get_counter (mci_work) result (counter)
     class(mci_work_t), intent(in) :: mci_work
     type(process_counter_t) :: counter
     counter = mci_work%counter
   end function mci_work_get_counter
 
 @ %def mci_work_reset_counter
 @ %def mci_work_record_call
 @ %def mci_work_get_counter
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process component manager}
 <<[[pcm.f90]]>>=
 <<File header>>
 
 module pcm
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use constants, only: zero, two
   use diagnostics
   use lorentz
   use phs_points, only: assignment(=)
   use io_units, only: free_unit
   use os_interface
   use process_constants, only: process_constants_t
   use physics_defs
   use model_data, only: model_data_t
   use models, only: model_t
   use interactions, only: interaction_t
   use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t
   use flavors, only: flavor_t
   use variables, only: var_list_t
   use nlo_data, only: nlo_settings_t
   use mci_base, only: mci_t
   use phs_base, only: phs_config_t
   use mappings, only: mapping_defaults_t
   use phs_forests, only: phs_parameters_t
   use phs_fks, only: isr_kinematics_t, real_kinematics_t
   use phs_fks, only: phs_identifier_t
   use dispatch_fks, only: dispatch_fks_s
   use fks_regions, only: region_data_t
   use nlo_data, only: fks_template_t
   use phs_fks, only: phs_fks_generator_t
   use phs_fks, only: dalitz_plot_t
   use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories
   use dispatch_phase_space, only: dispatch_phs
   use process_libraries, only: process_component_def_t
   use real_subtraction, only: real_subtraction_t, soft_mismatch_t
   use real_subtraction, only: FIXED_ORDER_EVENTS, POWHEG
   use real_subtraction, only: real_partition_t, powheg_damping_simple_t
   use real_subtraction, only: real_partition_fixed_order_t
   use virtual, only: virtual_t
   use dglap_remnant, only: dglap_remnant_t
   use prc_threshold, only: threshold_def_t
   use resonances, only: resonance_history_t, resonance_history_set_t
   use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
   use blha_config, only: blha_master_t
   use blha_olp_interfaces, only: prc_blha_t
 
   use pcm_base
   use process_config
   use process_mci, only: process_mci_entry_t
   use process_mci, only: REAL_SINGULAR, REAL_FINITE
 
 <<Standard module head>>
 
 <<Pcm: public>>
 
 <<Pcm: types>>
 
 contains
 
 <<Pcm: procedures>>
 
 end module pcm
 @ %def pcm
 @
 \subsection{Default process component manager}
 This is the configuration object which has the duty of allocating the
 corresponding instance.  The default version is trivial.
 <<Pcm: public>>=
   public :: pcm_default_t
 <<Pcm: types>>=
   type, extends (pcm_t) :: pcm_default_t
    contains
    <<Pcm: pcm default: TBP>>
   end type pcm_default_t
 
 @ %def pcm_default_t
 <<Pcm: pcm default: TBP>>=
   procedure :: allocate_workspace => pcm_default_allocate_workspace
 <<Pcm: procedures>>=
   subroutine pcm_default_allocate_workspace (pcm, work)
     class(pcm_default_t), intent(in) :: pcm
     class(pcm_workspace_t), intent(inout), allocatable :: work
     allocate (pcm_default_workspace_t :: work)
   end subroutine pcm_default_allocate_workspace
 
 @ %def pcm_default_allocate_workspace
 @
 Finalizer: apply to core manager.
 <<Pcm: pcm default: TBP>>=
   procedure :: final => pcm_default_final
 <<Pcm: procedures>>=
   subroutine pcm_default_final (pcm)
     class(pcm_default_t), intent(inout) :: pcm
   end subroutine pcm_default_final
 
 @ %def pcm_default_final
 @
 <<Pcm: pcm default: TBP>>=
   procedure :: is_nlo => pcm_default_is_nlo
 <<Pcm: procedures>>=
   function pcm_default_is_nlo (pcm) result (is_nlo)
     logical :: is_nlo
     class(pcm_default_t), intent(in) :: pcm
     is_nlo = .false.
   end function pcm_default_is_nlo
 
 @ %def pcm_default_is_nlo
 @
 Initialize configuration data, using environment variables.
 <<Pcm: pcm default: TBP>>=
   procedure :: init => pcm_default_init
 <<Pcm: procedures>>=
   subroutine pcm_default_init (pcm, env, meta)
     class(pcm_default_t), intent(out) :: pcm
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     pcm%has_pdfs = env%has_pdfs ()
     call pcm%set_blha_defaults &
          (env%has_polarized_beams (), env%get_var_list_ptr ())
     pcm%os_data = env%get_os_data ()
   end subroutine pcm_default_init
 
 @ %def pcm_default_init
 @
 <<Pcm: types>>=
   type, extends (pcm_workspace_t) :: pcm_default_workspace_t
   contains
   <<Pcm: pcm instance default: TBP>>
   end type pcm_default_workspace_t
 
 @ %def pcm_default_workspace_t
 @
 <<Pcm: pcm instance default: TBP>>=
   procedure :: final => pcm_default_workspace_final
 <<Pcm: procedures>>=
   subroutine pcm_default_workspace_final (pcm_work)
     class(pcm_default_workspace_t), intent(inout) :: pcm_work
   end subroutine pcm_default_workspace_final
 
 @ %def pcm_default_workspace_final
 @
 <<Pcm: pcm instance default: TBP>>=
   procedure :: is_nlo => pcm_default_workspace_is_nlo
 <<Pcm: procedures>>=
   function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo)
     logical :: is_nlo
     class(pcm_default_workspace_t), intent(inout) :: pcm_work
     is_nlo = .false.
   end function pcm_default_workspace_is_nlo
 
 @ %def pcm_default_workspace_is_nlo
 @
 \subsection{Implementations for the default manager}
 Categorize components.  Nothing to do here, all components are of Born type.
 <<Pcm: pcm default: TBP>>=
   procedure :: categorize_components => pcm_default_categorize_components
 <<Pcm: procedures>>=
   subroutine pcm_default_categorize_components (pcm, config)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
   end subroutine pcm_default_categorize_components
 
 @ %def pcm_default_categorize_components
 @
 \subsubsection{Phase-space configuration}
 Default setup for tree processes: a single phase-space configuration that is
 valid for all components.
 <<Pcm: pcm default: TBP>>=
   procedure :: init_phs_config => pcm_default_init_phs_config
 <<Pcm: procedures>>=
   subroutine pcm_default_init_phs_config &
        (pcm, phs_entry, meta, env, phs_par, mapping_defs)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_phs_config_t), &
          dimension(:), allocatable, intent(out) :: phs_entry
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     type(mapping_defaults_t), intent(in) :: mapping_defs
     type(phs_parameters_t), intent(in) :: phs_par
     allocate (phs_entry (1))
     allocate (pcm%i_phs_config (pcm%n_components), source=1)
     call dispatch_phs (phs_entry(1)%phs_config, &
          env%get_var_list_ptr (), &
          env%get_os_data (), &
          meta%id, &
          mapping_defs, phs_par)
   end subroutine pcm_default_init_phs_config
 
 @ %def pcm_default_init_phs_config
 @
 \subsubsection{Core management}
 The default component manager assigns one core per component.  We allocate and
 configure the core objects, using the process-component configuration data.
 <<Pcm: pcm default: TBP>>=
   procedure :: allocate_cores => pcm_default_allocate_cores
 <<Pcm: procedures>>=
   subroutine pcm_default_allocate_cores (pcm, config, core_entry)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
     type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
     type(process_component_def_t), pointer :: component_def
     integer :: i
     allocate (pcm%i_core (pcm%n_components), source = 0)
     pcm%n_cores = pcm%n_components
     allocate (core_entry (pcm%n_cores))
     do i = 1, pcm%n_cores
        pcm%i_core(i) = i
        core_entry(i)%i_component = i
        component_def => config%process_def%get_component_def_ptr (i)
        core_entry(i)%core_def => component_def%get_core_def_ptr ()
        core_entry(i)%active = component_def%can_be_integrated ()
     end do
   end subroutine pcm_default_allocate_cores
 
 @ %def pcm_default_allocate_cores
 @ Extra code is required for certain core types (threshold) or if BLHA uses an
 external OLP (Born only, this case) for getting its matrix elements.
 <<Pcm: pcm default: TBP>>=
   procedure :: prepare_any_external_code => &
        pcm_default_prepare_any_external_code
 <<Pcm: procedures>>=
   subroutine pcm_default_prepare_any_external_code &
        (pcm, core_entry, i_core, libname, model, var_list)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     integer, intent(in) :: i_core
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     type(var_list_t), intent(in) :: var_list
     if (core_entry%active) then
        associate (core => core_entry%core)
          if (core%needs_external_code ()) then
             call core%prepare_external_code &
                  (core%data%flv_state, &
                  var_list, pcm%os_data, libname, model, i_core, .false.)
          end if
          call core%set_equivalent_flv_hel_indices ()
        end associate
     end if
   end subroutine pcm_default_prepare_any_external_code
 
 @ %def pcm_default_prepare_any_external_code
 @ Allocate and configure the BLHA record for a specific core, assuming that
 the core type requires it.  In the default case, this is a Born
 configuration.
 <<Pcm: pcm default: TBP>>=
   procedure :: setup_blha => pcm_default_setup_blha
 <<Pcm: procedures>>=
   subroutine pcm_default_setup_blha (pcm, core_entry)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     allocate (core_entry%blha_config, source = pcm%blha_defaults)
     call core_entry%blha_config%set_born ()
   end subroutine pcm_default_setup_blha
 
 @ %def pcm_default_setup_blha
 @ Apply the configuration, using [[pcm]] data.
 <<Pcm: pcm default: TBP>>=
   procedure :: prepare_blha_core => pcm_default_prepare_blha_core
 <<Pcm: procedures>>=
   subroutine pcm_default_prepare_blha_core (pcm, core_entry, model)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     integer :: n_legs
     integer :: n_flv
     integer :: n_hel
     select type (core => core_entry%core)
     class is (prc_blha_t)
        associate (blha_config => core_entry%blha_config)
          n_in = core%data%n_in
          n_legs = core%data%get_n_tot ()
          n_flv = core%data%n_flv
          n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
          call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
          call core%init_driver (pcm%os_data)
        end associate
     end select
   end subroutine pcm_default_prepare_blha_core
 
 @ %def pcm_default_prepare_blha_core
 @ Read the method settings from the variable list and store them in the BLHA
 master.  This version: no NLO flag.
 <<Pcm: pcm default: TBP>>=
   procedure :: set_blha_methods => pcm_default_set_blha_methods
 <<Pcm: procedures>>=
   subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list)
     class(pcm_default_t), intent(inout) :: pcm
     type(blha_master_t), intent(inout) :: blha_master
     type(var_list_t), intent(in) :: var_list
     call blha_master%set_methods (.false., var_list)
   end subroutine pcm_default_set_blha_methods
 
 @ %def pcm_default_set_blha_methods
 @ Produce the LO and NLO flavor-state tables (as far as available), as
 appropriate for BLHA configuration.
 
 The default version looks at the first process core only, to get the Born
 data.  (Multiple cores are thus unsupported.)  The NLO flavor table is left
 unallocated.
 <<Pcm: pcm default: TBP>>=
   procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states
 <<Pcm: procedures>>=
   subroutine pcm_default_get_blha_flv_states &
        (pcm, core_entry, flv_born, flv_real)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     integer, dimension(:,:), allocatable, intent(out) :: flv_born
     integer, dimension(:,:), allocatable, intent(out) :: flv_real
     flv_born = core_entry(1)%core%data%flv_state
   end subroutine pcm_default_get_blha_flv_states
 
 @ %def pcm_default_get_blha_flv_states
 @ Allocate and configure the MCI (multi-channel integrator) records.  There is
 one record per active process component.  Second procedure: call the MCI
 dispatcher with default-setup arguments.
 <<Pcm: pcm default: TBP>>=
   procedure :: setup_mci => pcm_default_setup_mci
   procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci
 <<Pcm: procedures>>=
   subroutine pcm_default_setup_mci (pcm, mci_entry)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_mci_entry_t), &
          dimension(:), allocatable, intent(out) :: mci_entry
     class(mci_t), allocatable :: mci_template
     integer :: i, i_mci
     pcm%n_mci = count (pcm%component_active)
     allocate (pcm%i_mci (pcm%n_components), source = 0)
     i_mci = 0
     do i = 1, pcm%n_components
        if (pcm%component_active(i)) then
           i_mci = i_mci + 1
           pcm%i_mci(i) = i_mci
        end if
     end do
     allocate (mci_entry (pcm%n_mci))
   end subroutine pcm_default_setup_mci
 
   subroutine pcm_default_call_dispatch_mci (pcm, &
           dispatch_mci, var_list, process_id, mci_template)
     class(pcm_default_t), intent(inout) :: pcm
     procedure(dispatch_mci_proc) :: dispatch_mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     class(mci_t), allocatable, intent(out) :: mci_template
     call dispatch_mci (mci_template, var_list, process_id)
   end subroutine pcm_default_call_dispatch_mci
 
 @ %def pcm_default_setup_mci
 @ %def pcm_default_call_dispatch_mci
 @ Nothing left to do for the default algorithm.
 <<Pcm: pcm default: TBP>>=
   procedure :: complete_setup => pcm_default_complete_setup
 <<Pcm: procedures>>=
   subroutine pcm_default_complete_setup (pcm, core_entry, component, model)
     class(pcm_default_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     type(process_component_t), dimension(:), intent(inout) :: component
     type(model_t), intent(in), target :: model
   end subroutine pcm_default_complete_setup
 
 @ %def pcm_default_complete_setup
 @
 \subsubsection{Component management}
 Initialize a single component.  We require all process-configuration blocks,
 and specific templates for the phase-space and integrator configuration.
 
 We also provide the current component index [[i]] and the [[active]] flag.
 
 In the default mode, all components are marked as master components.
 <<Pcm: pcm default: TBP>>=
   procedure :: init_component => pcm_default_init_component
 <<Pcm: procedures>>=
   subroutine pcm_default_init_component &
           (pcm, component, i, active, &
           phs_config, env, meta, config)
     class(pcm_default_t), intent(in) :: pcm
     type(process_component_t), intent(out) :: component
     integer, intent(in) :: i
     logical, intent(in) :: active
     class(phs_config_t), allocatable, intent(in) :: phs_config
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     type(process_config_data_t), intent(in) :: config
     call component%init (i, &
          env, meta, config, &
          active, &
          phs_config)
     component%component_type = COMP_MASTER
   end subroutine pcm_default_init_component
 
 @ %def pcm_default_init_component
 @
 \subsection{NLO process component manager}
 The NLO-aware version of the process-component manager.
 
 This is the configuration object, which has the duty of allocating the
 corresponding instance.  This is the nontrivial NLO version.
 <<Pcm: public>>=
   public :: pcm_nlo_t
 <<Pcm: types>>=
   type, extends (pcm_t) :: pcm_nlo_t
      type(string_t) :: id
      logical :: combined_integration = .false.
      logical :: vis_fks_regions = .false.
      integer, dimension(:), allocatable :: nlo_type
      integer, dimension(:), allocatable :: nlo_type_core
      integer, dimension(:), allocatable :: component_type
      integer :: i_born = 0
      integer :: i_real = 0
      integer :: i_sub = 0
      type(nlo_settings_t) :: settings
      type(region_data_t) :: region_data
      logical :: use_real_partition = .false.
      logical :: use_real_singular = .false.
      real(default) :: real_partition_scale = 0
      class(real_partition_t), allocatable :: real_partition
      type(dalitz_plot_t) :: dalitz_plot
      type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born
   contains
   <<Pcm: pcm nlo: TBP>>
   end type pcm_nlo_t
 
 @ %def pcm_nlo_t
 @
 Initialize configuration data, using environment variables.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init => pcm_nlo_init
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init (pcm, env, meta)
     class(pcm_nlo_t), intent(out) :: pcm
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     type(var_list_t), pointer :: var_list
     type(fks_template_t) :: fks_template
     pcm%id = meta%id
     pcm%has_pdfs = env%has_pdfs ()
     var_list => env%get_var_list_ptr ()
     call dispatch_fks_s (fks_template, var_list)
     call pcm%settings%init (var_list, fks_template)
     pcm%combined_integration = &
          var_list%get_lval (var_str ('?combined_nlo_integration'))
     select case (char (var_list%get_sval (var_str ("$real_partition_mode"))))
     case ("default", "off")
        pcm%use_real_partition = .false.
        pcm%use_real_singular = .false.
     case ("all", "on", "singular")
        pcm%use_real_partition = .true.
        pcm%use_real_singular = .true.
     case ("finite")
        pcm%use_real_partition = .true.
        pcm%use_real_singular = .false.
     case default
        call msg_fatal ("The real partition mode can only be " // &
             "default, off, all, on, singular or finite.")
     end select
     pcm%real_partition_scale = &
          var_list%get_rval (var_str ("real_partition_scale"))
     pcm%vis_fks_regions = &
          var_list%get_lval (var_str ("?vis_fks_regions"))
     call pcm%set_blha_defaults &
          (env%has_polarized_beams (), env%get_var_list_ptr ())
     pcm%os_data = env%get_os_data ()
   end subroutine pcm_nlo_init
 
 @ %def pcm_nlo_init
 @ Init/rewrite NLO settings without the FKS template.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_nlo_settings (pcm, var_list)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(var_list_t), intent(in), target :: var_list
     call pcm%settings%init (var_list)
   end subroutine pcm_nlo_init_nlo_settings
 
 @ %def pcm_nlo_init_nlo_settings
 @
 As appropriate for the NLO/FKS algorithm, the category defined by the
 process, is called [[nlo_type]].  We refine this by setting the component
 category [[component_type]] separately.
 
 The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only
 if the algorithm uses combined integration.  Otherwise, they are set to
 [[COMP_DEFAULT]].
 
 The component type [[COMP_REAL]] is further distinguished between
 [[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real
 partitions.  The former acts as a reference component for the latter, and we
 always assume that it is the first real component.
 
 Each component is assigned its own core.  Exceptions: the finite-real
 component gets the same core as the singular-real component.  The mismatch
 component gets the same core as the subtraction component.
 
 TODO wk 2018: this convention for real components can be improved.  Check whether
 all component types should be assigned, not just for combined
 integration.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: categorize_components => pcm_nlo_categorize_components
 <<Pcm: procedures>>=
   subroutine pcm_nlo_categorize_components (pcm, config)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
     type(process_component_def_t), pointer :: component_def
     integer :: i
     allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED)
     allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT)
     do i = 1, pcm%n_components
        component_def => config%process_def%get_component_def_ptr (i)
        pcm%nlo_type(i) = component_def%get_nlo_type ()
        if (pcm%combined_integration) then
           select case (pcm%nlo_type(i))
           case (BORN)
              pcm%i_born = i
              pcm%component_type(i) = COMP_MASTER
           case (NLO_REAL)
              pcm%component_type(i) = COMP_REAL
           case (NLO_VIRTUAL)
              pcm%component_type(i) = COMP_VIRT
           case (NLO_MISMATCH)
              pcm%component_type(i) = COMP_MISMATCH
           case (NLO_DGLAP)
              pcm%component_type(i) = COMP_PDF
           case (NLO_SUBTRACTION)
              pcm%component_type(i) = COMP_SUB
              pcm%i_sub = i
           end select
        else
           select case (pcm%nlo_type(i))
           case (BORN)
              pcm%i_born = i
              pcm%component_type(i) = COMP_MASTER
           case (NLO_REAL)
              pcm%component_type(i) = COMP_REAL
           case (NLO_VIRTUAL)
              pcm%component_type(i) = COMP_VIRT
           case (NLO_MISMATCH)
              pcm%component_type(i) = COMP_MISMATCH
           case (NLO_SUBTRACTION)
              pcm%i_sub = i
           end select
        end if
     end do
     call refine_real_type ( &
          pack ([(i, i=1, pcm%n_components)], &
          pcm%component_type==COMP_REAL))
   contains
     subroutine refine_real_type (i_real)
       integer, dimension(:), intent(in) :: i_real
       pcm%i_real = i_real(1)
       if (pcm%use_real_partition) then
          pcm%component_type (i_real(1)) = COMP_REAL_SING
          pcm%component_type (i_real(2:)) = COMP_REAL_FIN
       end if
     end subroutine refine_real_type
   end subroutine pcm_nlo_categorize_components
 
 @ %def pcm_nlo_categorize_components
 @
 \subsubsection{Phase-space initial configuration}
 Setup for the NLO/PHS processes: two phase-space configurations, (1)
 Born/wood, (2) real correction/FKS.  All components use either one of these
 two configurations.
 
 TODO wk 2018: The [[first_real_component]] identifier is really ugly.
 Nothing should rely on the ordering.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_phs_config => pcm_nlo_init_phs_config
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_phs_config &
        (pcm, phs_entry, meta, env, phs_par, mapping_defs)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_phs_config_t), &
          dimension(:), allocatable, intent(out) :: phs_entry
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     type(mapping_defaults_t), intent(in) :: mapping_defs
     type(phs_parameters_t), intent(in) :: phs_par
     integer :: i
     logical :: first_real_component
     allocate (phs_entry (2))
     call dispatch_phs (phs_entry(1)%phs_config, &
          env%get_var_list_ptr (), &
          env%get_os_data (), &
          meta%id, &
          mapping_defs, phs_par, &
          var_str ("wood"))
     call dispatch_phs (phs_entry(2)%phs_config, &
          env%get_var_list_ptr (), &
          env%get_os_data (), &
          meta%id, &
          mapping_defs, phs_par, &
          var_str ("fks"))
     allocate (pcm%i_phs_config (pcm%n_components), source=0)
     first_real_component = .true.
     do i = 1, pcm%n_components
        select case (pcm%nlo_type(i))
        case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
           pcm%i_phs_config(i) = 1
        case (NLO_REAL)
           if (pcm%use_real_partition) then
              if (pcm%use_real_singular) then
                 if (first_real_component) then
                    pcm%i_phs_config(i) = 2
                    first_real_component = .false.
                 else
                    pcm%i_phs_config(i) = 1
                 end if
              else
                 pcm%i_phs_config(i) = 1
              end if
           else
              pcm%i_phs_config(i) = 2
           end if
        case (NLO_MISMATCH, NLO_DGLAP, GKS)
           pcm%i_phs_config(i) = 2
        end select
     end do
   end subroutine pcm_nlo_init_phs_config
 
 @ %def pcm_nlo_init_phs_config
 @
 \subsubsection{Core management}
 Allocate the core (matrix-element interface) objects that we will need for
 evaluation.  Every component gets an associated core, except for the
 real-finite and mismatch components (if any).  Those components are associated
 with their previous corresponding real-singular and subtraction cores,
 respectively.
 
 After cores are allocated, configure the region-data block that is maintained
 by the NLO process-component manager.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: allocate_cores => pcm_nlo_allocate_cores
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_cores (pcm, config, core_entry)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
     type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
         type(process_component_def_t), pointer :: component_def
     integer :: i, i_core
     allocate (pcm%i_core (pcm%n_components), source = 0)
     pcm%n_cores = pcm%n_components &
          - count (pcm%component_type(:) == COMP_REAL_FIN) &
          - count (pcm%component_type(:) == COMP_MISMATCH)
     allocate (core_entry (pcm%n_cores))
     allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN)
     i_core = 0
     do i = 1, pcm%n_components
        select case (pcm%component_type(i))
        case default
           i_core = i_core + 1
           pcm%i_core(i) = i_core
           pcm%nlo_type_core(i_core) = pcm%nlo_type(i)
           core_entry(i_core)%i_component = i
           component_def => config%process_def%get_component_def_ptr (i)
           core_entry(i_core)%core_def => component_def%get_core_def_ptr ()
           select case (pcm%nlo_type(i))
           case default
              core_entry(i)%active = component_def%can_be_integrated ()
           case (NLO_REAL, NLO_SUBTRACTION)
              core_entry(i)%active = .true.
           end select
        case (COMP_REAL_FIN)
           pcm%i_core(i) = pcm%i_core(pcm%i_real)
        case (COMP_MISMATCH)
           pcm%i_core(i) = pcm%i_core(pcm%i_sub)
        end select
     end do
   end subroutine pcm_nlo_allocate_cores
 
 @ %def pcm_nlo_allocate_cores
 @ Extra code is required for certain core types (threshold) or if BLHA uses an
 external OLP for getting its matrix elements.  OMega matrix elements, by
 definition, do not need extra code.  NLO-virtual or subtraction
 matrix elements always need extra code.
 
 More precisely: for the Born and virtual matrix element, the extra code is
 accessed only if the component is active.  The radiation (real) and the
 subtraction corrections (singular and finite), extra code is accessed in any
 case.
 
 The flavor state is taken from the [[region_data]] table in the [[pcm]]
 record.  We use the Born and real flavor-state tables as appropriate.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: prepare_any_external_code => &
        pcm_nlo_prepare_any_external_code
 <<Pcm: procedures>>=
   subroutine pcm_nlo_prepare_any_external_code &
        (pcm, core_entry, i_core, libname, model, var_list)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     integer, intent(in) :: i_core
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     type(var_list_t), intent(in) :: var_list
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     integer :: i
     call pcm%region_data%get_all_flv_states (flv_born, flv_real)
     if (core_entry%active) then
        associate (core => core_entry%core)
          if (core%needs_external_code ()) then
             select case (pcm%nlo_type (core_entry%i_component))
             case default
                call core%data%set_flv_state (flv_born)
             case (NLO_REAL)
                call core%data%set_flv_state (flv_real)
             end select
             call core%prepare_external_code &
                  (core%data%flv_state, &
                  var_list, pcm%os_data, libname, model, i_core, .true.)
          end if
          call core%set_equivalent_flv_hel_indices ()
        end associate
     end if
   end subroutine pcm_nlo_prepare_any_external_code
 
 @ %def pcm_nlo_prepare_any_external_code
 @ Allocate and configure the BLHA record for a specific core, assuming that
 the core type requires it.  The configuration depends on the NLO type of the
 core.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_blha => pcm_nlo_setup_blha
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_blha (pcm, core_entry)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     allocate (core_entry%blha_config, source = pcm%blha_defaults)
     select case (pcm%nlo_type(core_entry%i_component))
     case (BORN)
        call core_entry%blha_config%set_born ()
     case (NLO_REAL)
        call core_entry%blha_config%set_real_trees ()
     case (NLO_VIRTUAL)
        call core_entry%blha_config%set_loop ()
     case (NLO_SUBTRACTION)
        call core_entry%blha_config%set_subtraction ()
        call core_entry%blha_config%set_internal_color_correlations ()
     case (NLO_DGLAP)
        call core_entry%blha_config%set_dglap ()
     end select
   end subroutine pcm_nlo_setup_blha
 
 @ %def pcm_nlo_setup_blha
 @ After phase-space configuration data and core entries are available, we fill
 tables and compute the remaining NLO data that will steer the integration
 and subtraction algorithm.
 
 There are three parts: recognize a threshold-type process core (if it exists),
 prepare the region-data tables (always), and prepare for real partitioning (if
 requested).
 
 The real-component phase space acts as the source for resonance-history
 information, required for the region data.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: complete_setup => pcm_nlo_complete_setup
 <<Pcm: procedures>>=
   subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     type(process_component_t), dimension(:), intent(inout) :: component
     type(model_t), intent(in), target :: model
     integer :: alpha_power, alphas_power
     call pcm%handle_threshold_core (core_entry)
     call component(1)%config%get_coupling_powers (alpha_power, alphas_power)
     call pcm%setup_region_data &
          (core_entry, component(pcm%i_real)%phs_config, model, alpha_power, alphas_power)
     call pcm%setup_real_partition ()
   end subroutine pcm_nlo_complete_setup
 
 @ %def pcm_nlo_complete_setup
 @ Apply the BLHA configuration to a core object, using the region data from
 [[pcm]] for determining the particle content.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core
 <<Pcm: procedures>>=
   subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     integer :: n_legs
     integer :: n_flv
     integer :: n_hel
     select type (core => core_entry%core)
     class is (prc_blha_t)
        associate (blha_config => core_entry%blha_config)
          n_in = core%data%n_in
          select case (pcm%nlo_type(core_entry%i_component))
          case (NLO_REAL)
             n_legs = pcm%region_data%get_n_legs_real ()
             n_flv = pcm%region_data%get_n_flv_real ()
          case default
             n_legs = pcm%region_data%get_n_legs_born ()
             n_flv = pcm%region_data%get_n_flv_born ()
          end select
          n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
          call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
          call core%init_driver (pcm%os_data)
        end associate
     end select
   end subroutine pcm_nlo_prepare_blha_core
 
 @ %def pcm_nlo_prepare_blha_core
 @ Read the method settings from the variable list and store them in the BLHA
 master.  This version: NLO flag set.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: set_blha_methods => pcm_nlo_set_blha_methods
 <<Pcm: procedures>>=
   subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(blha_master_t), intent(inout) :: blha_master
     type(var_list_t), intent(in) :: var_list
     call blha_master%set_methods (.true., var_list)
     call pcm%blha_defaults%set_loop_method (blha_master)
   end subroutine pcm_nlo_set_blha_methods
 
 @ %def pcm_nlo_set_blha_methods
 @ Produce the LO and NLO flavor-state tables (as far as available), as
 appropriate for BLHA configuration.
 
 The NLO version copies the tables from the region data inside [[pcm]].  The
 core array is not needed.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states
 <<Pcm: procedures>>=
   subroutine pcm_nlo_get_blha_flv_states &
        (pcm, core_entry, flv_born, flv_real)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     integer, dimension(:,:), allocatable, intent(out) :: flv_born
     integer, dimension(:,:), allocatable, intent(out) :: flv_real
     call pcm%region_data%get_all_flv_states (flv_born, flv_real)
   end subroutine pcm_nlo_get_blha_flv_states
 
 @ %def pcm_nlo_get_blha_flv_states
 @ Allocate and configure the MCI (multi-channel integrator) records.  The
 relation depends on the [[combined_integration]] setting.  If we integrate
 components separately, each component gets its own record, except for the
 subtraction component.  If we do the combination, there is one record for
 the master (Born) component and a second one for the real-finite component,
 if present.
 
 Each entry acquires some NLO-specific initialization.  Generic configuration
 follows later.
 
 Second procedure: call the MCI dispatcher with NLO-setup arguments.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_mci => pcm_nlo_setup_mci
   procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_mci (pcm, mci_entry)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_mci_entry_t), &
          dimension(:), allocatable, intent(out) :: mci_entry
     class(mci_t), allocatable :: mci_template
     integer :: i, i_mci
     if (pcm%combined_integration) then
        pcm%n_mci = 1 &
             + count (pcm%component_active(:) &
             &        .and. pcm%component_type(:) == COMP_REAL_FIN)
        allocate (pcm%i_mci (pcm%n_components), source = 0)
        do i = 1, pcm%n_components
           if (pcm%component_active(i)) then
              select case (pcm%component_type(i))
              case (COMP_MASTER)
                 pcm%i_mci(i) = 1
              case (COMP_REAL_FIN)
                 pcm%i_mci(i) = 2
              end select
           end if
        end do
     else
        pcm%n_mci = count (pcm%component_active(:) &
             &             .and. pcm%nlo_type(:) /= NLO_SUBTRACTION)
        allocate (pcm%i_mci (pcm%n_components), source = 0)
        i_mci = 0
        do i = 1, pcm%n_components
           if (pcm%component_active(i)) then
              select case (pcm%nlo_type(i))
              case default
                 i_mci = i_mci + 1
                 pcm%i_mci(i) = i_mci
              case (NLO_SUBTRACTION)
              end select
           end if
        end do
     end if
     allocate (mci_entry (pcm%n_mci))
     mci_entry(:)%combined_integration = pcm%combined_integration
     if (pcm%use_real_partition) then
        do i = 1, pcm%n_components
           i_mci = pcm%i_mci(i)
           if (i_mci > 0) then
              select case (pcm%component_type(i))
              case (COMP_REAL_FIN)
                 mci_entry(i_mci)%real_partition_type = REAL_FINITE
              case default
                 mci_entry(i_mci)%real_partition_type = REAL_SINGULAR
              end select
           end if
        end do
     end if
   end subroutine pcm_nlo_setup_mci
 
   subroutine pcm_nlo_call_dispatch_mci (pcm, &
           dispatch_mci, var_list, process_id, mci_template)
     class(pcm_nlo_t), intent(inout) :: pcm
     procedure(dispatch_mci_proc) :: dispatch_mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     class(mci_t), allocatable, intent(out) :: mci_template
     call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.)
   end subroutine pcm_nlo_call_dispatch_mci
 
 @ %def pcm_nlo_setup_mci
 @ %def pcm_nlo_call_dispatch_mci
 @ Check for a threshold core and adjust the configuration accordingly, before
 singular region data are considered.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core
 <<Pcm: procedures>>=
   subroutine pcm_nlo_handle_threshold_core (pcm, core_entry)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     integer :: i
     do i = 1, size (core_entry)
        select type (core => core_entry(i)%core_def)
        type is (threshold_def_t)
           pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD
           return
        end select
     end do
   end subroutine pcm_nlo_handle_threshold_core
 
 @ %def pcm_nlo_handle_threshold_core
 @ Configure the singular-region tables based on the process data for the Born
 and Real (singular) cores, using also the appropriate FKS phase-space
 configuration object.
 
 In passing, we may create a table of resonance histories that are relevant for
 the singular-region configuration.
 
 TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout).
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_region_data => pcm_nlo_setup_region_data
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_region_data &
        (pcm, core_entry, phs_config, model, alpha_power, alphas_power)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     class(phs_config_t), intent(inout) :: phs_config
     type(model_t), intent(in), target :: model
     type(process_constants_t) :: data_born, data_real
     integer, dimension (:,:), allocatable :: flavor_born, flavor_real
     type(resonance_history_t), dimension(:), allocatable :: resonance_histories
     type(var_list_t), pointer :: var_list
     integer, intent(in) :: alpha_power, alphas_power
     logical :: success
     data_born = core_entry(pcm%i_core(pcm%i_born))%core%data
     data_real = core_entry(pcm%i_core(pcm%i_real))%core%data
     call data_born%get_flv_state (flavor_born)
     call data_real%get_flv_state (flavor_real)
     call pcm%region_data%init &
          (data_born%n_in, model, flavor_born, flavor_real, &
          pcm%settings%nlo_correction_type, alpha_power, alphas_power)
     associate (template => pcm%settings%fks_template)
       if (template%mapping_type == FKS_RESONANCES) then
          select type (phs_config)
          type is (phs_fks_config_t)
             call get_filtered_resonance_histories (phs_config, &
                  data_born%n_in, flavor_born, model, &
                  template%excluded_resonances, &
                  resonance_histories, success)
          end select
          if (.not. success) template%mapping_type = FKS_DEFAULT
       end if
       call pcm%region_data%setup_fks_mappings (template, data_born%n_in)
 !!! Check again, mapping_type might have changed
       if (template%mapping_type == FKS_RESONANCES) then
          call pcm%region_data%set_resonance_mappings (resonance_histories)
          call pcm%region_data%init_resonance_information ()
          pcm%settings%use_resonance_mappings = .true.
       end if
     end associate
     if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
        call pcm%region_data%set_isr_pseudo_regions ()
        call pcm%region_data%split_up_interference_regions_for_threshold ()
     end if
     call pcm%region_data%compute_number_of_phase_spaces ()
     call pcm%region_data%set_i_phs_to_i_con ()
     call pcm%region_data%write_to_file &
          (pcm%id, pcm%vis_fks_regions, pcm%os_data)
     if (debug_active (D_SUBTRACTION)) &
          call pcm%region_data%check_consistency (.true.)
   end subroutine pcm_nlo_setup_region_data
 
 @ %def pcm_nlo_setup_region_data
 @ After region data are set up, we allocate and configure the
 [[real_partition]] objects, if requested.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_real_partition => pcm_nlo_setup_real_partition
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_real_partition (pcm)
     class(pcm_nlo_t), intent(inout) :: pcm
     if (pcm%use_real_partition) then
        if (.not. allocated (pcm%real_partition)) then
           allocate (real_partition_fixed_order_t :: pcm%real_partition)
           select type (partition => pcm%real_partition)
           type is (real_partition_fixed_order_t)
              call pcm%region_data%get_all_ftuples (partition%fks_pairs)
              partition%scale = pcm%real_partition_scale
           end select
        end if
     end if
   end subroutine pcm_nlo_setup_real_partition
 
 @ %def pcm_nlo_setup_real_partition
 @
 Initialize a single component.  We require all process-configuration blocks,
 and specific templates for the phase-space and integrator configuration.
 
 We also provide the current component index [[i]] and the [[active]] flag.
 For a subtraction component, the [[active]] flag is overridden.
 
 In the nlo mode, the component types have been determined before.
 
 TODO wk 2018: the component type need not be stored in the component; we may remove
 this when everything is controlled by [[pcm]].
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_component => pcm_nlo_init_component
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_component &
           (pcm, component, i, active, &
           phs_config, env, meta, config)
     class(pcm_nlo_t), intent(in) :: pcm
     type(process_component_t), intent(out) :: component
     integer, intent(in) :: i
     logical, intent(in) :: active
     class(phs_config_t), allocatable, intent(in) :: phs_config
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     type(process_config_data_t), intent(in) :: config
     logical :: activate
     select case (pcm%nlo_type(i))
     case default;            activate = active
     case (NLO_SUBTRACTION);  activate = .false.
     end select
     call component%init (i, &
          env, meta, config, &
          activate, &
          phs_config)
     component%component_type = pcm%component_type(i)
   end subroutine pcm_nlo_init_component
 
 @ %def pcm_nlo_init_component
 @
 Override the base method: record the active components in the PCM object, and
 report inactive components (except for the subtraction component).
 <<Pcm: pcm nlo: TBP>>=
   procedure :: record_inactive_components => pcm_nlo_record_inactive_components
 <<Pcm: procedures>>=
   subroutine pcm_nlo_record_inactive_components (pcm, component, meta)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_component_t), dimension(:), intent(in) :: component
     type(process_metadata_t), intent(inout) :: meta
     integer :: i
     pcm%component_active = component%active
     do i = 1, pcm%n_components
        select case (pcm%nlo_type(i))
        case (NLO_SUBTRACTION)
        case default
           if (.not. component(i)%active)  call meta%deactivate_component (i)
        end select
     end do
   end subroutine pcm_nlo_record_inactive_components
 
 @ %def pcm_nlo_record_inactive_components
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: core_is_radiation => pcm_nlo_core_is_radiation
 <<Pcm: procedures>>=
   function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad)
     logical :: is_rad
     class(pcm_nlo_t), intent(in) :: pcm
     integer, intent(in) :: i_core
     is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core)
   end function pcm_nlo_core_is_radiation
 
 @ %def pcm_nlo_core_is_radiation
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born
 <<Pcm: procedures>>=
   function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv)
     integer :: n_flv
     class(pcm_nlo_t), intent(in) :: pcm_nlo
     n_flv = pcm_nlo%region_data%n_flv_born
   end function pcm_nlo_get_n_flv_born
 
 @ %def pcm_nlo_get_n_flv_born
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real
 <<Pcm: procedures>>=
   function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv)
     integer :: n_flv
     class(pcm_nlo_t), intent(in) :: pcm_nlo
     n_flv = pcm_nlo%region_data%n_flv_real
   end function pcm_nlo_get_n_flv_real
 
 @ %def pcm_nlo_get_n_flv_real
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_n_alr => pcm_nlo_get_n_alr
 <<Pcm: procedures>>=
   function pcm_nlo_get_n_alr (pcm) result (n_alr)
     integer :: n_alr
     class(pcm_nlo_t), intent(in) :: pcm
     n_alr = pcm%region_data%n_regions
   end function pcm_nlo_get_n_alr
 
 @ %def pcm_nlo_get_n_alr
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_flv_states => pcm_nlo_get_flv_states
 <<Pcm: procedures>>=
   function pcm_nlo_get_flv_states (pcm, born) result (flv)
     integer, dimension(:,:), allocatable :: flv
     class(pcm_nlo_t), intent(in) :: pcm
     logical, intent(in) :: born
     if (born) then
        flv = pcm%region_data%get_flv_states_born ()
     else
        flv = pcm%region_data%get_flv_states_real ()
     end if
   end function pcm_nlo_get_flv_states
 
 @ %def pcm_nlo_get_flv_states
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_qn => pcm_nlo_get_qn
 <<Pcm: procedures>>=
   function pcm_nlo_get_qn (pcm, born) result (qn)
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     class(pcm_nlo_t), intent(in) :: pcm
     logical, intent(in) :: born
     if (born) then
        qn = pcm%qn_born
     else
        qn = pcm%qn_real
     end if
   end function pcm_nlo_get_qn
 
 @ %def pcm_nlo_get_qn
 @ Check if there are massive emitters. Since the mass-structure of all
 underlying Born configurations have to be the same (\textbf{This does
 not have to be the case when different components are generated at LO})
 , we just use the first one to determine this.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter
 <<Pcm: procedures>>=
   function pcm_nlo_has_massive_emitter (pcm) result (val)
     logical :: val
     class(pcm_nlo_t), intent(in) :: pcm
     integer :: i
     val = .false.
     associate (reg_data => pcm%region_data)
        do i = reg_data%n_in + 1, reg_data%n_legs_born
           if (any (i == reg_data%emitters)) &
              val = val .or. reg_data%flv_born(1)%massive(i)
        end do
     end associate
   end function pcm_nlo_has_massive_emitter
 
 @ %def pcm_nlo_has_massive_emitter
 @ Returns an array which specifies if the particle at position [[i]] is massive.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_mass_info => pcm_nlo_get_mass_info
 <<Pcm: procedures>>=
   function pcm_nlo_get_mass_info (pcm, i_flv) result (massive)
     class(pcm_nlo_t), intent(in) :: pcm
     integer, intent(in) :: i_flv
     logical, dimension(:), allocatable :: massive
     allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive)))
     massive = pcm%region_data%flv_born(i_flv)%massive
   end function pcm_nlo_get_mass_info
 
 @ %def pcm_nlo_get_mass_info
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: allocate_workspace => pcm_nlo_allocate_workspace
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_workspace (pcm, work)
     class(pcm_nlo_t), intent(in) :: pcm
     class(pcm_workspace_t), intent(inout), allocatable :: work
     allocate (pcm_nlo_workspace_t :: work)
   end subroutine pcm_nlo_allocate_workspace
 
 @ %def pcm_nlo_allocate_workspace
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_qn => pcm_nlo_init_qn
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_qn (pcm, model)
     class(pcm_nlo_t), intent(inout) :: pcm
     class(model_data_t), intent(in) :: model
     integer, dimension(:,:), allocatable :: flv_states
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     allocate (flv_states (pcm%region_data%n_legs_born, pcm%region_data%n_flv_born))
     flv_states = pcm%get_flv_states (.true.)
     allocate (pcm%qn_born (size (flv_states, dim = 1), size (flv_states, dim = 2)))
     allocate (flv (size (flv_states, dim = 1)))
     allocate (qn (size (flv_states, dim = 1)))
     do i = 1, pcm%get_n_flv_born ()
        call flv%init (flv_states (:,i), model)
        call qn%init (flv)
        pcm%qn_born(:,i) = qn
     end do
     deallocate (flv); deallocate (qn)
     deallocate (flv_states)
     allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real))
     flv_states = pcm%get_flv_states (.false.)
     allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2)))
     allocate (flv (size (flv_states, dim = 1)))
     allocate (qn (size (flv_states, dim = 1)))
     do i = 1, pcm%get_n_flv_real ()
        call flv%init (flv_states (:,i), model)
        call qn%init (flv)
        pcm%qn_real(:,i) = qn
     end do
   end subroutine pcm_nlo_init_qn
 
 @ %def pcm_nlo_init_qn
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_ps_matching (pcm)
     class(pcm_nlo_t), intent(inout) :: pcm
     if (.not. allocated (pcm%real_partition)) then
        allocate (powheg_damping_simple_t :: pcm%real_partition)
     end if
   end subroutine pcm_nlo_allocate_ps_matching
 
 @ %def pcm_nlo_allocate_ps_matching
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot
 <<Pcm: procedures>>=
   subroutine pcm_nlo_activate_dalitz_plot (pcm, filename)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(string_t), intent(in) :: filename
     call pcm%dalitz_plot%init (free_unit (), filename, .false.)
     call pcm%dalitz_plot%write_header ()
   end subroutine pcm_nlo_activate_dalitz_plot
 
 @ %def pcm_nlo_activate_dalitz_plot
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot
 <<Pcm: procedures>>=
   subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p)
     class(pcm_nlo_t), intent(inout) :: pcm
     integer, intent(in) :: emitter
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: k0_n, k0_np1
     k0_n = p(emitter)%p(0)
     k0_np1 = p(size(p))%p(0)
     call pcm%dalitz_plot%register (k0_n, k0_np1)
   end subroutine pcm_nlo_register_dalitz_plot
 
 @ %def pcm_nlo_register_dalitz_plot
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, &
      sqrts, mode, singular_jacobian)
     class(pcm_nlo_t), intent(in) :: pcm
     type(phs_fks_generator_t), intent(inout) :: generator
     type(pcm_nlo_workspace_t), intent(in), target :: pcm_work
     real(default), intent(in) :: sqrts
     integer, intent(in), optional:: mode
     logical, intent(in), optional :: singular_jacobian
     logical :: yorn
     yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian
     call generator%connect_kinematics (pcm_work%isr_kinematics, &
          pcm_work%real_kinematics, pcm%has_massive_emitter ())
     generator%n_in = pcm%region_data%n_in
     call generator%set_sqrts_hat (sqrts)
     call generator%set_emitters (pcm%region_data%emitters)
     call generator%setup_masses (pcm%region_data%n_legs_born)
     generator%is_massive = pcm%get_mass_info (1)
     generator%singular_jacobian = yorn
     if (present (mode)) generator%mode = mode
     call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, &
          pcm%settings%fks_template%y_max)
   end subroutine pcm_nlo_setup_phs_generator
 
 @ %def pcm_nlo_setup_phs_generator
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: final => pcm_nlo_final
 <<Pcm: procedures>>=
   subroutine pcm_nlo_final (pcm)
     class(pcm_nlo_t), intent(inout) :: pcm
     if (allocated (pcm%real_partition)) deallocate (pcm%real_partition)
     call pcm%dalitz_plot%final ()
   end subroutine pcm_nlo_final
 
 @ %def pcm_nlo_final
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: is_nlo => pcm_nlo_is_nlo
 <<Pcm: procedures>>=
   function pcm_nlo_is_nlo (pcm) result (is_nlo)
     logical :: is_nlo
     class(pcm_nlo_t), intent(in) :: pcm
     is_nlo = .true.
   end function pcm_nlo_is_nlo
 
 @ %def pcm_nlo_is_nlo
 @ As a first implementation, it acts as a wrapper for the NLO controller
 object and the squared matrix-element collector.
 <<Pcm: public>>=
   public :: pcm_nlo_workspace_t
 <<Pcm: types>>=
   type, extends (pcm_workspace_t) :: pcm_nlo_workspace_t
      type(real_kinematics_t), pointer :: real_kinematics => null ()
      type(isr_kinematics_t), pointer :: isr_kinematics => null ()
      type(real_subtraction_t) :: real_sub
      type(virtual_t) :: virtual
      type(soft_mismatch_t) :: soft_mismatch
      type(dglap_remnant_t) :: dglap_remnant
      integer, dimension(:), allocatable :: i_mci_to_real_component
   contains
   <<Pcm: pcm instance: TBP>>
   end type pcm_nlo_workspace_t
 
 @ %def pcm_nlo_workspace_t
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_radiation_event => pcm_nlo_workspace_set_radiation_event
   procedure :: set_subtraction_event => pcm_nlo_workspace_set_subtraction_event
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_radiation_event (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     pcm_work%real_sub%radiation_event = .true.
     pcm_work%real_sub%subtraction_event = .false.
   end subroutine pcm_nlo_workspace_set_radiation_event
 
   subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     pcm_work%real_sub%radiation_event = .false.
     pcm_work%real_sub%subtraction_event = .true.
   end subroutine pcm_nlo_workspace_set_subtraction_event
 
 @ %def pcm_nlo_workspace_set_radiation_event
 @ %def pcm_nlo_workspace_set_subtraction_event
 <<Pcm: pcm instance: TBP>>=
   procedure :: disable_subtraction => pcm_nlo_workspace_disable_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_disable_subtraction (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     pcm_work%real_sub%subtraction_deactivated = .true.
   end subroutine pcm_nlo_workspace_disable_subtraction
 
 @ %def pcm_nlo_workspace_disable_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_config => pcm_nlo_workspace_init_config
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, active_components, &
      nlo_types, energy, i_real_fin, model)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     logical, intent(in), dimension(:) :: active_components
     integer, intent(in), dimension(:) :: nlo_types
     real(default), intent(in), dimension(:) :: energy
     integer, intent(in) :: i_real_fin
     class(model_data_t), intent(in) :: model
     integer :: i_component
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "pcm_nlo_workspace_init_config")
     call pcm_work%init_real_and_isr_kinematics (pcm, energy)
     select type (pcm)
     type is (pcm_nlo_t)
        do i_component = 1, size (active_components)
           if (active_components(i_component) .or. pcm%settings%combined_integration) then
              select case (nlo_types(i_component))
              case (NLO_REAL)
                 if (i_component /= i_real_fin) then
                    call pcm_work%setup_real_component (pcm, &
                         pcm%settings%fks_template%subtraction_disabled)
                 end if
              case (NLO_VIRTUAL)
                 call pcm_work%init_virtual (pcm, model)
              case (NLO_MISMATCH)
                 call pcm_work%init_soft_mismatch (pcm)
              case (NLO_DGLAP)
                 call pcm_work%init_dglap_remnant (pcm)
              end select
           end if
        end do
     end select
   end subroutine pcm_nlo_workspace_init_config
 
 @ %def pcm_nlo_workspace_init_config
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: setup_real_component => pcm_nlo_workspace_setup_real_component
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, &
      subtraction_disabled)
     class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
     class(pcm_t), intent(in) :: pcm
     logical, intent(in) :: subtraction_disabled
     select type (pcm)
     type is (pcm_nlo_t)
        call pcm_work%init_real_subtraction (pcm)
        if (subtraction_disabled)  call pcm_work%disable_subtraction ()
     end select
   end subroutine pcm_nlo_workspace_setup_real_component
 
 @ %def pcm_nlo_workspace_setup_real_component
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_real_and_isr_kinematics => &
        pcm_nlo_workspace_init_real_and_isr_kinematics
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_init_real_and_isr_kinematics (pcm_work, pcm, energy)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     real(default), dimension(:), intent(in) :: energy
     integer :: n_contr
     allocate (pcm_work%real_kinematics)
     allocate (pcm_work%isr_kinematics)
     select type (pcm)
     type is (pcm_nlo_t)
        associate (region_data => pcm%region_data)
           if (allocated (region_data%alr_contributors)) then
              n_contr = size (region_data%alr_contributors)
           else if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
              n_contr = 2
           else
              n_contr = 1
           end if
           call pcm_work%real_kinematics%init &
                (region_data%n_legs_real, region_data%n_phs, &
                region_data%n_regions, n_contr)
           if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
              call pcm_work%real_kinematics%init_onshell &
                   (region_data%n_legs_real, region_data%n_phs)
           pcm_work%isr_kinematics%n_in = region_data%n_in
        end associate
     end select
     pcm_work%isr_kinematics%beam_energy = energy
   end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics
 
 @ %def pcm_nlo_workspace_init_real_and_isr_kinematics
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_real_and_isr_kinematics => &
       pcm_nlo_workspace_set_real_and_isr_kinematics
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_real_and_isr_kinematics (pcm_work, phs_identifiers, sqrts)
     class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     real(default), intent(in) :: sqrts
     call pcm_work%real_sub%set_real_kinematics &
          (pcm_work%real_kinematics)
     call pcm_work%real_sub%set_isr_kinematics &
          (pcm_work%isr_kinematics)
   end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics
 
 @ %def pcm_nlo_workspace_set_real_and_isr_kinematics
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_real_subtraction => pcm_nlo_workspace_init_real_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm)
     class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
     class(pcm_t), intent(in) :: pcm
     select type (pcm)
     type is (pcm_nlo_t)
        associate (region_data => pcm%region_data)
           call pcm_work%real_sub%init (region_data, pcm%settings)
           if (allocated (pcm%settings%selected_alr)) then
               associate (selected_alr => pcm%settings%selected_alr)
                 if (any (selected_alr < 0)) then
                    call msg_fatal ("Fixed alpha region must be non-negative!")
                 else if (any (selected_alr > region_data%n_regions)) then
                    call msg_fatal ("Fixed alpha region is larger than the total"&
                         &" number of singular regions!")
                 else
                    allocate (pcm_work%real_sub%selected_alr (size (selected_alr)))
                    pcm_work%real_sub%selected_alr = selected_alr
                 end if
              end associate
           end if
        end associate
     end select
   end subroutine pcm_nlo_workspace_init_real_subtraction
 
 @ %def pcm_nlo_workspace_init_real_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_momenta_and_scales_virtual => &
      pcm_nlo_workspace_set_momenta_and_scales_virtual
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual (pcm_work, p, &
      ren_scale, fac_scale, es_scale)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), allocatable, intent(in) :: ren_scale
     real(default), intent(in) :: fac_scale
     real(default), allocatable, intent(in) :: es_scale
     associate (virtual => pcm_work%virtual)
       call virtual%set_ren_scale (ren_scale)
       call virtual%set_fac_scale (p, fac_scale)
       call virtual%set_ellis_sexton_scale (es_scale)
     end associate
   end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual
 
 @ %def pcm_nlo_workspace_set_momenta_and_scales_virtual
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_fac_scale => pcm_nlo_workspace_set_fac_scale
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     real(default), intent(in) :: fac_scale
     pcm_work%isr_kinematics%fac_scale = fac_scale
   end subroutine pcm_nlo_workspace_set_fac_scale
 
 @ %def pcm_nlo_workspace_set_fac_scale
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_momenta => pcm_nlo_workspace_set_momenta
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_momenta (pcm_work, p_born, p_real, i_phs, cms)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     type(vector4_t), dimension(:), intent(in) :: p_born, p_real
     integer, intent(in) :: i_phs
     logical, intent(in), optional :: cms
     logical :: yorn
     yorn = .false.; if (present (cms)) yorn = cms
     associate (kinematics => pcm_work%real_kinematics)
        if (yorn) then
           if (.not. kinematics%p_born_cms%initialized) &
                call kinematics%p_born_cms%init (size (p_born), 1)
           if (.not. kinematics%p_real_cms%initialized) &
                call kinematics%p_real_cms%init (size (p_real), 1)
           kinematics%p_born_cms%phs_point(1) = p_born
           kinematics%p_real_cms%phs_point(i_phs) = p_real
        else
           if (.not. kinematics%p_born_lab%initialized) &
                call kinematics%p_born_lab%init (size (p_born), 1)
           if (.not. kinematics%p_real_lab%initialized) &
                call kinematics%p_real_lab%init (size (p_real), 1)
           kinematics%p_born_lab%phs_point(1) = p_born
           kinematics%p_real_lab%phs_point(i_phs) = p_real
        end if
     end associate
   end subroutine pcm_nlo_workspace_set_momenta
 
 @ %def pcm_nlo_workspace_set_momenta
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_momenta => pcm_nlo_workspace_get_momenta
 <<Pcm: procedures>>=
   function pcm_nlo_workspace_get_momenta (pcm_work, pcm, &
        i_phs, born_phsp, cms) result (p)
     type(vector4_t), dimension(:), allocatable :: p
     class(pcm_nlo_workspace_t), intent(in) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     integer, intent(in) :: i_phs
     logical, intent(in) :: born_phsp
     logical, intent(in), optional :: cms
     logical :: yorn
     yorn = .false.; if (present (cms)) yorn = cms
     select type (pcm)
     type is (pcm_nlo_t)
        if (born_phsp) then
           if (yorn) then
              p = pcm_work%real_kinematics%p_born_cms%phs_point(1)
           else
              p =pcm_work%real_kinematics%p_born_lab%phs_point(1)
           end if
        else
           if (yorn) then
              p = pcm_work%real_kinematics%p_real_cms%phs_point(i_phs)
           else
              p = pcm_work%real_kinematics%p_real_lab%phs_point(i_phs)
           end if
        end if
     end select
   end function pcm_nlo_workspace_get_momenta
 
 @ %def pcm_nlo_workspace_get_momenta
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_xi_max => pcm_nlo_workspace_get_xi_max
 <<Pcm: procedures>>=
   function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max)
     real(default) :: xi_max
     class(pcm_nlo_workspace_t), intent(in) :: pcm_work
     integer, intent(in) :: alr
     integer :: i_phs
     i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr)
     xi_max = pcm_work%real_kinematics%xi_max (i_phs)
   end function pcm_nlo_workspace_get_xi_max
 
 @ %def pcm_nlo_workspace_get_xi_max
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_x_rad => pcm_nlo_workspace_set_x_rad
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     real(default), intent(in), dimension(:) :: x_tot
     integer :: n_par
     n_par = size (x_tot)
     if (n_par < 3) then
        pcm_work%real_kinematics%x_rad = zero
     else
        pcm_work%real_kinematics%x_rad = x_tot (n_par - 2 : n_par)
     end if
   end subroutine pcm_nlo_workspace_set_x_rad
 
 @ %def pcm_nlo_workspace_set_x_rad
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_virtual => pcm_nlo_workspace_init_virtual
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model)
     class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
     class(pcm_t), intent(in) :: pcm
     class(model_data_t), intent(in) :: model
     select type (pcm)
     type is (pcm_nlo_t)
        associate (region_data => pcm%region_data)
          call pcm_work%virtual%init (region_data%get_flv_states_born (), &
               region_data%n_in, pcm%settings, model, pcm%has_pdfs)
        end associate
     end select
   end subroutine pcm_nlo_workspace_init_virtual
 
 @ %def pcm_nlo_workspace_init_virtual
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: disable_virtual_subtraction => pcm_nlo_workspace_disable_virtual_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
   end subroutine pcm_nlo_workspace_disable_virtual_subtraction
 
 @ %def pcm_nlo_workspace_disable_virtual_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_virt => pcm_nlo_workspace_compute_sqme_virt
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, &
          alpha_coupling, separate_uborns, sqme_virt)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), dimension(2), intent(in) :: alpha_coupling
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_virt
     type(vector4_t), dimension(:), allocatable :: pp
     associate (virtual => pcm_work%virtual)
        allocate (pp (size (p)))
        if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
           pp = pcm_work%real_kinematics%p_born_onshell%get_momenta (1)
        else
           pp = p
        end if
        select type (pcm)
        type is (pcm_nlo_t)
           if (separate_uborns) then
              allocate (sqme_virt (pcm%get_n_flv_born ()))
           else
              allocate (sqme_virt (1))
           end if
           sqme_virt = zero
           call virtual%evaluate (pcm%region_data, &
                alpha_coupling, pp, separate_uborns, sqme_virt)
        end select
     end associate
   end subroutine pcm_nlo_workspace_compute_sqme_virt
 
 @ %def pcm_nlo_workspace_compute_sqme_virt
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_mismatch => pcm_nlo_workspace_compute_sqme_mismatch
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, &
            alpha_s, separate_uborns, sqme_mism)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     real(default), intent(in) :: alpha_s
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
     select type (pcm)
     type is (pcm_nlo_t)
        if (separate_uborns) then
           allocate (sqme_mism (pcm%get_n_flv_born ()))
        else
           allocate (sqme_mism (1))
        end if
        sqme_mism = zero
        sqme_mism = pcm_work%soft_mismatch%evaluate (alpha_s)
     end select
   end subroutine pcm_nlo_workspace_compute_sqme_mismatch
 
 @ %def pcm_nlo_workspace_compute_sqme_mismatch
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_dglap_remnant => pcm_nlo_workspace_compute_sqme_dglap_remnant
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, pcm, &
             alpha_coupling, separate_uborns, sqme_dglap)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     real(default), dimension(2), intent(in) :: alpha_coupling
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
     select type (pcm)
     type is (pcm_nlo_t)
        if (separate_uborns) then
           allocate (sqme_dglap (pcm%get_n_flv_born ()))
        else
           allocate (sqme_dglap (1))
        end if
     end select
     sqme_dglap = zero
     call pcm_work%dglap_remnant%evaluate (alpha_coupling, separate_uborns, sqme_dglap)
   end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant
 
 @ %def pcm_nlo_workspace_compute_sqme_dglap_remnant
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_fixed_order_event_mode => pcm_nlo_workspace_set_fixed_order_event_mode
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     pcm_work%real_sub%purpose = FIXED_ORDER_EVENTS
   end subroutine pcm_nlo_workspace_set_fixed_order_event_mode
 
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_powheg_mode => pcm_nlo_workspace_set_powheg_mode
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_set_powheg_mode (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     pcm_work%real_sub%purpose = POWHEG
   end subroutine pcm_nlo_workspace_set_powheg_mode
 
 @ %def pcm_nlo_workspace_set_fixed_order_event_mode
 @ %def pcm_nlo_workspace_set_powheg_mode
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_soft_mismatch => pcm_nlo_workspace_init_soft_mismatch
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     select type (pcm)
     type is (pcm_nlo_t)
        call pcm_work%soft_mismatch%init (pcm%region_data, &
             pcm_work%real_kinematics, pcm%settings%factorization_mode)
     end select
   end subroutine pcm_nlo_workspace_init_soft_mismatch
 
 @ %def pcm_nlo_workspace_init_soft_mismatch
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_dglap_remnant => pcm_nlo_workspace_init_dglap_remnant
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     class(pcm_t), intent(in) :: pcm
     select type (pcm)
     type is (pcm_nlo_t)
        call pcm_work%dglap_remnant%init ( &
             pcm%settings, &
             pcm%region_data, &
             pcm_work%isr_kinematics)
     end select
   end subroutine pcm_nlo_workspace_init_dglap_remnant
 
 @ %def pcm_nlo_workspace_init_dglap_remnant
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: is_fixed_order_nlo_events &
        => pcm_nlo_workspace_is_fixed_order_nlo_events
 <<Pcm: procedures>>=
   function pcm_nlo_workspace_is_fixed_order_nlo_events (pcm_work) result (is_fnlo)
     logical :: is_fnlo
     class(pcm_nlo_workspace_t), intent(in) :: pcm_work
     is_fnlo = pcm_work%real_sub%purpose == FIXED_ORDER_EVENTS
   end function pcm_nlo_workspace_is_fixed_order_nlo_events
 
 @ %def pcm_nlo_workspace_is_fixed_order_nlo_events
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: final => pcm_nlo_workspace_final
 <<Pcm: procedures>>=
   subroutine pcm_nlo_workspace_final (pcm_work)
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     call pcm_work%real_sub%final ()
     call pcm_work%virtual%final ()
     call pcm_work%soft_mismatch%final ()
     call pcm_work%dglap_remnant%final ()
     if (associated (pcm_work%real_kinematics)) then
        call pcm_work%real_kinematics%final ()
        nullify (pcm_work%real_kinematics)
     end if
     if (associated (pcm_work%isr_kinematics)) then
        nullify (pcm_work%isr_kinematics)
     end if
   end subroutine pcm_nlo_workspace_final
 
 @ %def pcm_nlo_workspace_final
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: is_nlo => pcm_nlo_workspace_is_nlo
 <<Pcm: procedures>>=
   function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo)
     logical :: is_nlo
     class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     is_nlo = .true.
   end function pcm_nlo_workspace_is_nlo
 
 @ %def pcm_nlo_workspace_is_nlo
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Kinematics instance}
 In this data type we combine all objects (instances) necessary for
 generating (or recovering) a kinematical configuration.  The
 components work together as an implementation of multi-channel phase
 space.
 
 [[sf_chain]] is an instance of the structure-function chain.  It is
 used both for generating kinematics and, after the proper scale has
 been determined, evaluating the structure function entries.
 
 [[phs]] is an instance of the phase space for the elementary process.
 
 The array [[f]] contains the products of the Jacobians that originate
 from parameter mappings in the structure-function chain or in the
 phase space.  We allocate this explicitly if either [[sf_chain]] or
 [[phs]] are explicitly allocated, otherwise we can take over a pointer.
 
 All components are implemented as pointers to (anonymous) targets.
 For each component, there is a flag that tells whether this component
 is to be regarded as a proper component (`owned' by the object) or as
 a pointer.
 @
 <<[[kinematics.f90]]>>=
 <<File header>>
 
 module kinematics
 
 <<Use kinds>>
 <<Use debug>>
   use format_utils, only: write_separator
   use diagnostics
   use io_units
   use lorentz
   use phs_points, only: assignment(=), size
   use physics_defs
   use sf_base
   use phs_base
   use interactions
   use mci_base
   use phs_fks
   use fks_regions
   use process_config
   use process_mci
   use pcm_base, only: pcm_t, pcm_workspace_t
   use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t
   use ttv_formfactors, only: m1s_to_mpole
 
 <<Standard module head>>
 
 <<Kinematics: public>>
 
 <<Kinematics: types>>
 
 contains
 
 <<Kinematics: procedures>>
 
 end module kinematics
 @ %def kinematics
 <<Kinematics: public>>=
   public :: kinematics_t
 <<Kinematics: types>>=
   type :: kinematics_t
      integer :: n_in = 0
      integer :: n_channel = 0
      integer :: selected_channel = 0
      type(sf_chain_instance_t), pointer :: sf_chain => null ()
      class(phs_t), pointer :: phs => null ()
      real(default), dimension(:), pointer :: f => null ()
      real(default) :: phs_factor
      logical :: sf_chain_allocated = .false.
      logical :: phs_allocated = .false.
      logical :: f_allocated = .false.
      integer :: emitter = -1
      integer :: i_phs = 0
      integer :: i_con = 0
      logical :: only_cm_frame = .false.
      logical :: new_seed = .true.
      logical :: threshold = .false.
    contains
    <<Kinematics: kinematics: TBP>>
   end type kinematics_t
 
 @ %def kinematics_t
 @ Output.  Show only those components which are marked as owned.
 <<Kinematics: kinematics: TBP>>=
   procedure :: write => kinematics_write
 <<Kinematics: procedures>>=
   subroutine kinematics_write (object, unit)
     class(kinematics_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, c
     u = given_output_unit (unit)
     if (object%f_allocated) then
        write (u, "(1x,A)")  "Flux * PHS volume:"
        write (u, "(2x,ES19.12)")  object%phs_factor
        write (u, "(1x,A)")  "Jacobian factors per channel:"
        do c = 1, size (object%f)
           write (u, "(3x,I0,':',1x,ES14.7)", advance="no")  c, object%f(c)
           if (c == object%selected_channel) then
              write (u, "(1x,A)")  "[selected]"
           else
              write (u, *)
           end if
        end do
     end if
     if (object%sf_chain_allocated) then
        call write_separator (u)
        call object%sf_chain%write (u)
     end if
     if (object%phs_allocated) then
        call write_separator (u)
        call object%phs%write (u)
     end if
   end subroutine kinematics_write
 
 @ %def kinematics_write
 @ Finalizer.  Delete only those components which are marked as owned.
 <<Kinematics: kinematics: TBP>>=
   procedure :: final => kinematics_final
 <<Kinematics: procedures>>=
   subroutine kinematics_final (object)
     class(kinematics_t), intent(inout) :: object
     if (object%sf_chain_allocated) then
        call object%sf_chain%final ()
        deallocate (object%sf_chain)
        object%sf_chain_allocated = .false.
     end if
     if (object%phs_allocated) then
        call object%phs%final ()
        deallocate (object%phs)
        object%phs_allocated = .false.
     end if
     if (object%f_allocated) then
        deallocate (object%f)
        object%f_allocated = .false.
     end if
   end subroutine kinematics_final
 
 @ %def kinematics_final
 @ Configure the kinematics object.  This consists of several
 configuration steps which correspond to individual procedures.  In
 essence, we configure the structure-function part, the partonic
 phase-space part, and various NLO items.
 
 TODO wk 19-03-01: This includes some region-data setup within [[pcm]],
 hence [[pcm]] is intent(inout).  This should be moved elsewhere, so
 [[pcm]] can become strictly intent(in).
 <<Kinematics: kinematics: TBP>>=
   procedure :: configure => kinematics_configure
 <<Kinematics: procedures>>=
   subroutine kinematics_configure (kin, pcm, pcm_work, &
        sf_chain, beam_config, phs_config, nlo_type, is_i_sub)
     class(kinematics_t), intent(out) :: kin
     class(pcm_t), intent(inout) :: pcm
     class(pcm_workspace_t), intent(in) :: pcm_work
     type(sf_chain_t), intent(in), target :: sf_chain
     type(process_beam_config_t), intent(in), target :: beam_config
     class(phs_config_t), intent(in), target :: phs_config
     integer, intent(in) :: nlo_type
     logical, intent(in) :: is_i_sub
     logical :: extended_sf
     extended_sf = nlo_type == NLO_DGLAP .or. (nlo_type == NLO_REAL .and. is_i_sub)
     call kin%init_sf_chain (sf_chain, beam_config, &
          extended_sf = pcm%has_pdfs .and. extended_sf)
     !!! Add one for additional Born matrix element
     call kin%init_phs (phs_config)
     call kin%set_nlo_info (nlo_type)
     select type (phs => kin%phs)
     type is (phs_fks_t)
        call phs%allocate_momenta (phs_config, .not. (nlo_type == NLO_REAL))
        select type (pcm)
        type is (pcm_nlo_t)
           call pcm%region_data%init_phs_identifiers (phs%phs_identifiers)
           !!! The triple select type pyramid of doom
           select type (pcm_work)
           type is (pcm_nlo_workspace_t)
              if (allocated (pcm_work%real_kinematics%alr_to_i_phs)) &
                   call pcm%region_data%set_alr_to_i_phs (phs%phs_identifiers, &
                        pcm_work%real_kinematics%alr_to_i_phs)
           end select
        end select
     end select
   end subroutine kinematics_configure
   
 @ %def kinematics_configure
 @ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter.
 <<Kinematics: kinematics: TBP>>=
   procedure :: set_nlo_info => kinematics_set_nlo_info
 <<Kinematics: procedures>>=
   subroutine kinematics_set_nlo_info (k, nlo_type)
     class(kinematics_t), intent(inout) :: k
     integer, intent(in) :: nlo_type
     if (nlo_type == NLO_VIRTUAL)  k%only_cm_frame = .true.
   end subroutine kinematics_set_nlo_info
 
 @ %def kinematics_set_nlo_info
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: set_threshold => kinematics_set_threshold
 <<Kinematics: procedures>>=
   subroutine kinematics_set_threshold (kin, factorization_mode)
     class(kinematics_t), intent(inout) :: kin
     integer, intent(in) :: factorization_mode
     kin%threshold = factorization_mode == FACTORIZATION_THRESHOLD
   end subroutine kinematics_set_threshold
 
 @ %def kinematics_set_threshold
 @ Allocate the structure-function chain instance, initialize it as a
 copy of the [[sf_chain]] template, and prepare it for evaluation.
 
 The [[sf_chain]] remains a target because the (usually constant) beam momenta
 are taken from there.
 <<Kinematics: kinematics: TBP>>=
   procedure :: init_sf_chain => kinematics_init_sf_chain
 <<Kinematics: procedures>>=
   subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf)
     class(kinematics_t), intent(inout) :: k
     type(sf_chain_t), intent(in), target :: sf_chain
     type(process_beam_config_t), intent(in) :: config
     logical, intent(in), optional :: extended_sf
     integer :: n_strfun, n_channel
     integer :: c
     k%n_in = config%data%get_n_in ()
     n_strfun = config%n_strfun
     n_channel = config%n_channel
     allocate (k%sf_chain)
     k%sf_chain_allocated = .true.
     call k%sf_chain%init (sf_chain, n_channel)
     if (n_strfun /= 0) then
        do c = 1, n_channel
           call k%sf_chain%set_channel (c, config%sf_channel(c))
        end do
     end if
     call k%sf_chain%link_interactions ()
     call k%sf_chain%exchange_mask ()
     call k%sf_chain%init_evaluators (extended_sf = extended_sf)
   end subroutine kinematics_init_sf_chain
 
 @ %def kinematics_init_sf_chain
 @ Allocate and initialize the phase-space part and the array of
 Jacobian factors.
 <<Kinematics: kinematics: TBP>>=
   procedure :: init_phs => kinematics_init_phs
 <<Kinematics: procedures>>=
   subroutine kinematics_init_phs (k, config)
     class(kinematics_t), intent(inout) :: k
     class(phs_config_t), intent(in), target :: config
     k%n_channel = config%get_n_channel ()
     call config%allocate_instance (k%phs)
     call k%phs%init (config)
     k%phs_allocated = .true.
     allocate (k%f (k%n_channel))
     k%f = 0
     k%f_allocated = .true.
   end subroutine kinematics_init_phs
 
 @ %def kinematics_init_phs
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: evaluate_radiation_kinematics => kinematics_evaluate_radiation_kinematics
 <<Kinematics: procedures>>=
   subroutine kinematics_evaluate_radiation_kinematics (k, r_in)
     class(kinematics_t), intent(inout) :: k
     real(default), intent(in), dimension(:) :: r_in
     select type (phs => k%phs)
     type is (phs_fks_t)
        if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then
           call phs%generate_radiation_variables &
                (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), threshold = k%threshold)
           call phs%compute_cms_energy ()
        end if
     end select
   end subroutine kinematics_evaluate_radiation_kinematics
 
 @ %def kinematics_evaluate_radiation_kinematics
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: generate_fsr_in => kinematics_generate_fsr_in
 <<Kinematics: procedures>>=
   subroutine kinematics_generate_fsr_in (kin)
     class(kinematics_t), intent(inout) :: kin
     select type (phs => kin%phs)
     type is (phs_fks_t)
        call phs%generate_fsr_in ()
     end select
   end subroutine kinematics_generate_fsr_in
 
 @ %def kinematics_generate_fsr_in
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta
 <<Kinematics: procedures>>=
   subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type)
     class(kinematics_t), intent(inout) :: k
     type(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: nlo_type
     logical :: use_contributors
     use_contributors = allocated (reg_data%alr_contributors)
     select type (phs => k%phs)
     type is (phs_fks_t)
        if (use_contributors) then
           call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors)
        else if (k%threshold) then
           if (.not. is_subtraction_component (k%emitter, nlo_type)) &
                call phs%compute_xi_ref_momenta_threshold ()
        else
           call phs%compute_xi_ref_momenta ()
        end if
     end select
   end subroutine kinematics_compute_xi_ref_momenta
 
 @ %def kinematics_compute_xi_ref_momenta
 @ Generate kinematics, given a phase-space channel and a MC
 parameter set. The main result is the momentum array [[p]], but we
 also fill the momentum entries in the structure-function chain and the
 Jacobian-factor array [[f]].  Regarding phase space, we fill only the
 parameter arrays for the selected channel.
 <<Kinematics: kinematics: TBP>>=
   procedure :: compute_selected_channel => kinematics_compute_selected_channel
 <<Kinematics: procedures>>=
   subroutine kinematics_compute_selected_channel &
        (k, mci_work, phs_channel, p, success)
     class(kinematics_t), intent(inout) :: k
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     type(vector4_t), dimension(:), intent(out) :: p
     logical, intent(out) :: success
     integer :: sf_channel
     k%selected_channel = phs_channel
     sf_channel = k%phs%config%get_sf_channel (phs_channel)
     call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ())
     call k%sf_chain%get_out_momenta (p(1:k%n_in))
     call k%phs%set_incoming_momenta (p(1:k%n_in))
     call k%phs%compute_flux ()
     call k%phs%select_channel (phs_channel)
     call k%phs%evaluate_selected_channel (phs_channel, &
          mci_work%get_x_process ())
 
     select type (phs => k%phs)
     type is (phs_fks_t)
        if (debug_on)  call msg_debug2 (D_REAL, "phase space is phs_FKS")
        if (phs%q_defined) then
           call phs%get_born_momenta (p)
           if (debug_on) then
              call msg_debug2 (D_REAL, "q is defined")
              call msg_debug2 (D_REAL, "get_born_momenta called")
           end if
           k%phs_factor = phs%get_overall_factor ()
           success = .true.
       else
          k%phs_factor = 0
          success = .false.
       end if
     class default
       if (phs%q_defined) then
          call k%phs%get_outgoing_momenta (p(k%n_in + 1 :))
          k%phs_factor = k%phs%get_overall_factor ()
          success = .true.
       else
          k%phs_factor = 0
          success = .false.
       end if
     end select
   end subroutine kinematics_compute_selected_channel
 
 @ %def kinematics_compute_selected_channel
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: redo_sf_chain => kinematics_redo_sf_chain
 <<Kinematics: procedures>>=
   subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel)
     class(kinematics_t), intent(inout) :: kin
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     real(default), dimension(:), allocatable :: x
     integer :: sf_channel, n
     real(default) :: xi, y
     n = size (mci_work%get_x_strfun ())
     if (n > 0) then
        allocate (x(n))
        x = mci_work%get_x_strfun ()
        sf_channel = kin%phs%config%get_sf_channel (phs_channel)
        call kin%sf_chain%compute_kinematics (sf_channel, x)
     end if
   end subroutine kinematics_redo_sf_chain
 
 @ %def kinematics_redo_sf_chain
 @ Complete kinematics by filling the non-selected phase-space parameter
 arrays.
 <<Kinematics: kinematics: TBP>>=
   procedure :: compute_other_channels => kinematics_compute_other_channels
 <<Kinematics: procedures>>=
   subroutine kinematics_compute_other_channels (k, mci_work, phs_channel)
     class(kinematics_t), intent(inout) :: k
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     integer :: c, c_sf
     call k%phs%evaluate_other_channels (phs_channel)
     do c = 1, k%n_channel
        c_sf = k%phs%config%get_sf_channel (c)
        k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
     end do
   end subroutine kinematics_compute_other_channels
 
 @ %def kinematics_compute_other_channels
 @ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which
 become the incoming (seed) momenta of the hard interaction.
 
 This is a stripped down-version of the above which we use when
 recovering kinematics.  Momenta are known, but no MC parameters yet.
 
 (We do not use the [[get_out_momenta]] method of the chain, since this
 relies on the structure-function interactions, which are not necessary
 filled here.  We do rely on the momenta of the last evaluator in the
 chain, however.)
 <<Kinematics: kinematics: TBP>>=
   procedure :: get_incoming_momenta => kinematics_get_incoming_momenta
 <<Kinematics: procedures>>=
   subroutine kinematics_get_incoming_momenta (k, p)
     class(kinematics_t), intent(in) :: k
     type(vector4_t), dimension(:), intent(out) :: p
     type(interaction_t), pointer :: int
     integer :: i
     int => k%sf_chain%get_out_int_ptr ()
     do i = 1, k%n_in
        p(i) = int%get_momentum (k%sf_chain%get_out_i (i))
     end do
   end subroutine kinematics_get_incoming_momenta
 
 @ %def kinematics_get_incoming_momenta
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: get_boost_to_lab => kinematics_get_boost_to_lab
 <<Kinematics: procedures>>=
   function kinematics_get_boost_to_lab (kin) result (lt)
     type(lorentz_transformation_t) :: lt
     class(kinematics_t), intent(in) :: kin
     lt = kin%phs%get_lorentz_transformation ()
   end function kinematics_get_boost_to_lab
 
 @ %def kinematics_get_boost_to_lab
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: get_boost_to_cms => kinematics_get_boost_to_cms
 <<Kinematics: procedures>>=
   function kinematics_get_boost_to_cms (kin) result (lt)
     type(lorentz_transformation_t) :: lt
     class(kinematics_t), intent(in) :: kin
     lt = inverse (kin%phs%get_lorentz_transformation ())
   end function kinematics_get_boost_to_cms
 
 @ %def kinematics_get_boost_to_cms
 @ This inverts the remainder of the above [[compute]] method.  We know
 the momenta and recover the rest, as far as needed.  If we select a
 channel, we can complete the inversion and reconstruct the
 MC parameter set.
 <<Kinematics: kinematics: TBP>>=
   procedure :: recover_mcpar => kinematics_recover_mcpar
 <<Kinematics: procedures>>=
   subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p)
     class(kinematics_t), intent(inout) :: k
     type(mci_work_t), intent(inout) :: mci_work
     integer, intent(in) :: phs_channel
     type(vector4_t), dimension(:), intent(in) :: p
     integer :: c, c_sf
     real(default), dimension(:), allocatable :: x_sf, x_phs
     c = phs_channel
     c_sf = k%phs%config%get_sf_channel (c)
     k%selected_channel = c
     call k%sf_chain%recover_kinematics (c_sf)
     call k%phs%set_incoming_momenta (p(1:k%n_in))
     call k%phs%compute_flux ()
     call k%phs%set_outgoing_momenta (p(k%n_in+1:))
     call k%phs%inverse ()
     do c = 1, k%n_channel
        c_sf = k%phs%config%get_sf_channel (c)
        k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
     end do
     k%phs_factor = k%phs%get_overall_factor ()
     c = phs_channel
     c_sf = k%phs%config%get_sf_channel (c)
     allocate (x_sf (k%sf_chain%config%get_n_bound ()))
     allocate (x_phs (k%phs%config%get_n_par ()))
     call k%phs%select_channel (c)
     call k%sf_chain%get_mcpar (c_sf, x_sf)
     call k%phs%get_mcpar (c, x_phs)
     call mci_work%set_x_strfun (x_sf)
     call mci_work%set_x_process (x_phs)
   end subroutine kinematics_recover_mcpar
 
 @ %def kinematics_recover_mcpar
 @ This first part of [[recover_mcpar]]: just handle the sfchain.
 <<Kinematics: kinematics: TBP>>=
   procedure :: recover_sfchain => kinematics_recover_sfchain
 <<Kinematics: procedures>>=
   subroutine kinematics_recover_sfchain (k, channel, p)
     class(kinematics_t), intent(inout) :: k
     integer, intent(in) :: channel
     type(vector4_t), dimension(:), intent(in) :: p
     k%selected_channel = channel
     call k%sf_chain%recover_kinematics (channel)
   end subroutine kinematics_recover_sfchain
 
 @ %def kinematics_recover_sfchain
 @ Retrieve the MC input parameter array for a specific channel.  We assume
 that the kinematics is complete, so this is known for all channels.
 <<Kinematics: kinematics: TBP>>=
   procedure :: get_mcpar => kinematics_get_mcpar
 <<Kinematics: procedures>>=
   subroutine kinematics_get_mcpar (k, phs_channel, r)
     class(kinematics_t), intent(in) :: k
     integer, intent(in) :: phs_channel
     real(default), dimension(:), intent(out) :: r
     integer :: sf_channel, n_par_sf, n_par_phs
     sf_channel = k%phs%config%get_sf_channel (phs_channel)
     n_par_phs = k%phs%config%get_n_par ()
     n_par_sf = k%sf_chain%config%get_n_bound ()
     if (n_par_sf > 0) then
        call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf))
     end if
     if (n_par_phs > 0) then
        call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:))
     end if
   end subroutine kinematics_get_mcpar
 
 @ %def kinematics_get_mcpar
 @ Evaluate the structure function chain, assuming that kinematics is known.
 
 The status must be precisely [[SF_DONE_KINEMATICS]].  We thus avoid
 evaluating the chain twice via different pointers to the same target.
 <<Kinematics: kinematics: TBP>>=
   procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain
 <<Kinematics: procedures>>=
   subroutine kinematics_evaluate_sf_chain (k, fac_scale, negative_sf, sf_rescale)
     class(kinematics_t), intent(inout) :: k
     real(default), intent(in) :: fac_scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(inout), optional :: sf_rescale
     select case (k%sf_chain%get_status ())
     case (SF_DONE_KINEMATICS)
        call k%sf_chain%evaluate (fac_scale, negative_sf = negative_sf, sf_rescale = sf_rescale)
     end select
   end subroutine kinematics_evaluate_sf_chain
 
 @ %def kinematics_evaluate_sf_chain
 @ Recover beam momenta, i.e., return the beam momenta stored in the
 current [[sf_chain]] to their source.  This is a side effect.
 <<Kinematics: kinematics: TBP>>=
   procedure :: return_beam_momenta => kinematics_return_beam_momenta
 <<Kinematics: procedures>>=
   subroutine kinematics_return_beam_momenta (k)
     class(kinematics_t), intent(in) :: k
     call k%sf_chain%return_beam_momenta ()
   end subroutine kinematics_return_beam_momenta
 
 @ %def kinematics_return_beam_momenta
 @ Check wether the phase space is configured in the center-of-mass frame.
 Relevant for using the proper momenta input for BLHA matrix elements.
 <<Kinematics: kinematics: TBP>>=
   procedure :: lab_is_cm => kinematics_lab_is_cm
 <<Kinematics: procedures>>=
   function kinematics_lab_is_cm (k) result (lab_is_cm)
      logical :: lab_is_cm
      class(kinematics_t), intent(in) :: k
      lab_is_cm = k%phs%config%lab_is_cm
   end function kinematics_lab_is_cm
 
 @ %def kinematics_lab_is_cm
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: modify_momenta_for_subtraction => kinematics_modify_momenta_for_subtraction
 <<Kinematics: procedures>>=
   subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out)
     class(kinematics_t), intent(inout) :: k
     type(vector4_t), intent(in), dimension(:) :: p_in
     type(vector4_t), intent(out), dimension(:), allocatable :: p_out
     allocate (p_out (size (p_in)))
     if (k%threshold) then
        select type (phs => k%phs)
        type is (phs_fks_t)
           p_out = phs%get_onshell_projected_momenta ()
        end select
     else
        p_out = p_in
     end if
   end subroutine kinematics_modify_momenta_for_subtraction
 
 @ %def kinematics_modify_momenta_for_subtraction
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: threshold_projection => kinematics_threshold_projection
 <<Kinematics: procedures>>=
   subroutine kinematics_threshold_projection (k, pcm_work, nlo_type)
     class(kinematics_t), intent(inout) :: k
     type(pcm_nlo_workspace_t), intent(inout) :: pcm_work
     integer, intent(in) :: nlo_type
     real(default) :: sqrts, mtop
     type(lorentz_transformation_t) :: L_to_cms
     type(vector4_t), dimension(:), allocatable :: p_tot, p_onshell
     integer :: n_tot
     n_tot = k%phs%get_n_tot ()
     allocate (p_tot (size (pcm_work%real_kinematics%p_born_cms%phs_point(1))))
     select type (phs => k%phs)
     type is (phs_fks_t)
        p_tot = pcm_work%real_kinematics%p_born_cms%phs_point(1)
     class default
        p_tot(1 : k%n_in) = phs%p
        p_tot(k%n_in + 1 : n_tot) = phs%q
     end select
     sqrts = sum (p_tot (1:k%n_in))**1
     mtop = m1s_to_mpole (sqrts)
     L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop)
     call pcm_work%real_kinematics%p_born_cms%set_momenta (1, p_tot)
     p_onshell = pcm_work%real_kinematics%p_born_onshell%phs_point(1)
     call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell)
     pcm_work%real_kinematics%p_born_onshell%phs_point(1) = p_onshell
     if (debug2_active (D_THRESHOLD)) then
        print *, 'On-shell projected Born: '
        call vector4_write_set (p_onshell)
     end if
   end subroutine kinematics_threshold_projection
 
 @ %def kinematics_threshold_projection
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: evaluate_radiation => kinematics_evaluate_radiation
 <<Kinematics: procedures>>=
   subroutine kinematics_evaluate_radiation (k, p_in, p_out, success)
     class(kinematics_t), intent(inout) :: k
     type(vector4_t), intent(in), dimension(:) :: p_in
     type(vector4_t), intent(out), dimension(:), allocatable :: p_out
     logical, intent(out) :: success
     type(vector4_t), dimension(:), allocatable :: p_real
     type(vector4_t), dimension(:), allocatable :: p_born
     real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi
     select type (phs => k%phs)
     type is (phs_fks_t)
        allocate (p_born (size (p_in)))
        if (k%threshold) then
           p_born = phs%get_onshell_projected_momenta ()
        else
           p_born = p_in
        end if
        if (.not. k%phs%lab_is_cm () .and. .not. k%threshold) then
             p_born = inverse (k%phs%lt_cm_to_lab) * p_born
        end if
        call phs%compute_xi_max (p_born, k%threshold)
        if (k%emitter >= 0) then
           allocate (p_real (size (p_born) + 1))
           allocate (p_out (size (p_born) + 1))
           if (k%emitter <= k%n_in) then
              call phs%generate_isr (k%i_phs, p_real)
           else
              if (k%threshold) then
                 jac_rand_dummy = 1._default
                 call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), &
                      phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
                      k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, &
                      y_offshell)
                 call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, &
                      phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
                      xi_max_offshell)
                 xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde
                 phi = phs%generator%real_kinematics%phi
                 call phs%generate_fsr (k%emitter, k%i_phs, p_real, &
                      xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.)
                 call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real)
                 call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real)
                 if (debug2_active (D_SUBTRACTION)) &
                      call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs)
              else if (k%i_con > 0) then
                 call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con)
              else
                 call phs%generate_fsr (k%emitter, k%i_phs, p_real)
              end if
           end if
           success = check_scalar_products (p_real)
           if (debug2_active (D_SUBTRACTION)) then
              call msg_debug2 (D_SUBTRACTION, "Real phase-space: ")
              call vector4_write_set (p_real)
           end if
           p_out = p_real
        else
           allocate (p_out (size (p_in))); p_out = p_in
           success = .true.
        end if
     end select
   contains
     subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs)
       integer, intent(in) :: emitter, i_phs
       integer :: ii_phs, this_emitter
       select type (phs => k%phs)
       type is (phs_fks_t)
          do ii_phs = 1, size (phs%phs_identifiers)
             this_emitter = phs%phs_identifiers(ii_phs)%emitter
             if (ii_phs /= i_phs .and. this_emitter /= emitter) &
                  call phs%generate_fsr_threshold (this_emitter, i_phs)
          end do
       end select
     end subroutine
   end subroutine kinematics_evaluate_radiation
 
 @ %def kinematics_evaluate_radiation
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Instances}
 
 <<[[instances.f90]]>>=
 <<File header>>
 
 module instances
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use constants
   use diagnostics
   use os_interface
   use numeric_utils
   use lorentz
   use mci_base
   use particles
   use sm_qcd, only: qcd_t
   use interactions
   use quantum_numbers
   use model_data
   use helicities
   use flavors
   use beam_structures
   use variables
   use pdg_arrays, only: is_quark
   use sf_base
   use physics_defs
   use process_constants
   use process_libraries
   use state_matrices
   use integration_results
   use phs_base
   use prc_core, only: prc_core_t, prc_core_state_t
 
   !!! We should depend less on these modules (move it to pcm_nlo_t e.g.)
   use phs_wood, only: phs_wood_t
   use phs_fks
   use blha_olp_interfaces, only: prc_blha_t
   use blha_config, only: BLHA_AMP_COLOR_C
   use prc_external, only: prc_external_t, prc_external_state_t
   use prc_threshold, only: prc_threshold_t
   use blha_olp_interfaces, only: blha_result_array_size
   use prc_openloops, only: prc_openloops_t, openloops_state_t
   use prc_recola, only: prc_recola_t
   use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag
 
   use ttv_formfactors, only: m1s_to_mpole
   !!! local modules
   use parton_states
   use process_counter
   use pcm_base
   use pcm
   use process_config
   use process_mci
   use process
   use kinematics
 
 <<Standard module head>>
 
 <<Instances: public>>
 
 <<Instances: types>>
 
 <<Instances: interfaces>>
 
 contains
 
 <<Instances: procedures>>
 
 end module instances
 @ %def instances
 @
 \subsection{Term instance}
 A [[term_instance_t]] object contains all data that describe a term.  Each
 process component consists of one or more distinct terms which may differ in
 kinematics, but whose squared transition matrices have to be added pointwise.
 
 The [[active]] flag is set when this term is connected to an active
 process component.  Inactive terms are skipped for kinematics and evaluation.
 
 The [[amp]] array stores the amplitude values when we get them from evaluating
 the associated matrix-element code.
 
 The [[int_hard]] interaction describes the elementary hard process.
 It receives the momenta and the amplitude entries for each sampling point.
 
 The [[isolated]] object holds the effective parton state for the
 elementary interaction.  The amplitude entries are
 computed from [[int_hard]].
 
 The [[connected]] evaluator set
 convolutes this scattering matrix with the beam (and possibly
 structure-function) density matrix.
 
 The [[checked]] flag is set once we have applied cuts on this term.
 The result of this is stored in the [[passed]] flag.
 
 Although each [[term_instance]] carries a [[weight]], this currently
 always keeps the value $1$ and is only used to be given to routines
 to fulfill their signature.
 <<Instances: types>>=
   type :: term_instance_t
      type(process_term_t), pointer :: config => null ()
      class(pcm_t), pointer :: pcm => null ()
      class(pcm_workspace_t), pointer :: pcm_work => null ()
      logical :: active = .false.
      complex(default), dimension(:), allocatable :: amp
      type(interaction_t) :: int_hard
      type(isolated_state_t) :: isolated
      type(connected_state_t) :: connected
      class(prc_core_state_t), allocatable :: core_state
      logical :: checked = .false.
      logical :: passed = .false.
      real(default) :: scale = 0
      real(default), allocatable :: fac_scale
      real(default), allocatable :: ren_scale
      real(default), allocatable :: es_scale
      real(default), allocatable :: alpha_qcd_forced
      real(default) :: weight = 1
      type(vector4_t), dimension(:), allocatable :: p_seed
      type(vector4_t), dimension(:), allocatable :: p_hard
      integer :: nlo_type = BORN
      integer, dimension(:), allocatable :: same_kinematics
      logical :: negative_sf = .false.
    contains
    <<Instances: term instance: TBP>>
   end type term_instance_t
 
 @ %def term_instance_t
 @
 <<Instances: term instance: TBP>>=
   procedure :: write => term_instance_write
 <<Instances: procedures>>=
   subroutine term_instance_write (term, unit, kin, show_eff_state, testflag)
     class(term_instance_t), intent(in) :: term
     integer, intent(in), optional :: unit
     type(kinematics_t), intent(in), optional :: kin
     logical, intent(in), optional :: show_eff_state
     logical, intent(in), optional :: testflag
     real(default) :: fac_scale, ren_scale
     integer :: u
     logical :: state
     u = given_output_unit (unit)
     state = .true.;  if (present (show_eff_state))  state = show_eff_state
     if (term%active) then
        if (associated (term%config)) then
           write (u, "(1x,A,I0,A,I0,A)")  "Term #", term%config%i_term, &
                " (component #", term%config%i_component, ")"
        else
           write (u, "(1x,A)")  "Term [undefined]"
        end if
     else
        write (u, "(1x,A,I0,A)")  "Term #", term%config%i_term, &
             " [inactive]"
     end if
     if (term%checked) then
        write (u, "(3x,A,L1)")      "passed cuts           = ", term%passed
     end if
     if (term%passed) then
        write (u, "(3x,A,ES19.12)")  "overall scale         = ", term%scale
        write (u, "(3x,A,ES19.12)")  "factorization scale   = ", term%get_fac_scale ()
        write (u, "(3x,A,ES19.12)")  "renormalization scale = ", term%get_ren_scale ()
        if (allocated (term%alpha_qcd_forced)) then
           write (u, "(3x,A,ES19.12)")  "alpha(QCD) forced     = ", &
                term%alpha_qcd_forced
        end if
        write (u, "(3x,A,ES19.12)")  "reweighting factor    = ", term%weight
     end if
     !!! This used to be a member of term_instance
     if (present (kin)) then
        call kin%write (u)
     end if
     call write_separator (u)
     write (u, "(1x,A)")  "Amplitude (transition matrix of the &
          &hard interaction):"
     call write_separator (u)
     call term%int_hard%basic_write (u, testflag = testflag)
     if (state .and. term%isolated%has_trace) then
        call write_separator (u)
        write (u, "(1x,A)")  "Evaluators for the hard interaction:"
        call term%isolated%write (u, testflag = testflag)
     end if
     if (state .and. term%connected%has_trace) then
        call write_separator (u)
        write (u, "(1x,A)")  "Evaluators for the connected process:"
        call term%connected%write (u, testflag = testflag)
     end if
   end subroutine term_instance_write
 
 @ %def term_instance_write
 @ The interactions and evaluators must be finalized.
 <<Instances: term instance: TBP>>=
   procedure :: final => term_instance_final
 <<Instances: procedures>>=
   subroutine term_instance_final (term)
     class(term_instance_t), intent(inout) :: term
     if (allocated (term%amp)) deallocate (term%amp)
     if (allocated (term%core_state)) deallocate (term%core_state)
     if (allocated (term%ren_scale))  deallocate (term%ren_scale)
     if (allocated (term%fac_scale))  deallocate (term%fac_scale)
     if (allocated (term%es_scale))  deallocate (term%es_scale)
     if (allocated (term%alpha_qcd_forced)) &
        deallocate (term%alpha_qcd_forced)
     if (allocated (term%p_seed)) deallocate(term%p_seed)
     if (allocated (term%p_hard)) deallocate (term%p_hard)
     call term%connected%final ()
     call term%isolated%final ()
     call term%int_hard%final ()
     term%pcm => null ()
     term%pcm_work => null ()
   end subroutine term_instance_final
 
 @ %def term_instance_final
 @ For a new term object, we configure the structure-function
 interface, the phase space, the matrix-element (interaction)
 interface, etc.
 <<Instances: term instance: TBP>>=
   procedure :: configure => term_instance_configure
 <<Instances: procedures>>=
   subroutine term_instance_configure (term_instance, process, i, pcm_work, sf_chain, kin)
     class(term_instance_t), intent(out), target :: term_instance
     type(process_t), intent(in), target :: process
     integer, intent(in) :: i
     class(pcm_workspace_t), intent(in), target :: pcm_work
     type(sf_chain_t), intent(in), target :: sf_chain
     type(kinematics_t), intent(inout), target :: kin
     type(process_term_t) :: term
     integer :: i_component
     logical :: requires_extended_sf
     term = process%get_term_ptr (i)
     i_component = term%i_component
     if (i_component /= 0) then
        call term_instance%init &
             (process%get_pcm_ptr (), pcm_work, process%get_nlo_type_component (i_component))
        requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. &
               (term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i)
        call term_instance%setup_dynamics (process, i, kin, &
             real_finite = process%component_is_real_finite (i_component))
        select type (phs => kin%phs)
        type is (phs_fks_t)
           call term_instance%set_emitter (kin)
           call term_instance%setup_fks_kinematics (kin, &
                process%get_var_list_ptr (), &
                process%get_beam_config_ptr ())
        end select
        select type (pcm => term_instance%pcm)
        type is (pcm_nlo_t)
           call kin%set_threshold (pcm%settings%factorization_mode)
        end select
        call term_instance%setup_expressions (process%get_meta (), process%get_config ())
     end if
   end subroutine term_instance_configure
 
 @ %def term_instance_configure
 @ First part of term-instance configuration: initialize by assigning pointers to the
 overall [[pcm]] and the associated [[pcm_workspace]] objects.
 <<Instances: term instance: TBP>>=
   procedure :: init => term_instance_init
 <<Instances: procedures>>=
   subroutine term_instance_init (term_instance, pcm, pcm_work, nlo_type)
     class(term_instance_t), intent(out) :: term_instance
     class(pcm_t), intent(in), target :: pcm
     class(pcm_workspace_t), intent(in), target :: pcm_work
     integer, intent(in) :: nlo_type
     term_instance%pcm => pcm
     term_instance%pcm_work => pcm_work
     term_instance%nlo_type = nlo_type
   end subroutine term_instance_init
     
 @ %def term_instance_init
 @ The second part of term-instance configuration concerns dynamics, i.e., the
 interface to the matrix-element (interaction), and the parton-state
 objects that combine all kinematics and matrix-element data for evaluation.
 
 The hard interaction (incoming momenta) is linked to the structure
 function instance.  In the isolated state, we either set pointers to
 both, or we create modified copies ([[rearrange]]) as effective
 structure-function chain and interaction, respectively.
 
 Finally, we set up the [[subevt]] component that will be used for
 evaluating observables, collecting particles from the trace evaluator
 in the effective connected state.  Their quantum numbers must be
 determined by following back source links and set explicitly, since
 they are already eliminated in that trace.
 
 The [[rearrange]] parts are still commented out; they could become
 relevant for a NLO algorithm.
 <<Instances: term instance: TBP>>=
   procedure :: setup_dynamics => term_instance_setup_dynamics
 <<Instances: procedures>>=
   subroutine term_instance_setup_dynamics (term, process, i_term, kin, real_finite)
     class(term_instance_t), intent(inout), target :: term
     type(process_t), intent(in), target:: process
     integer, intent(in) :: i_term
     type(kinematics_t), intent(in) :: kin
     logical, intent(in), optional :: real_finite
     class(prc_core_t), pointer :: core => null ()
     type(process_beam_config_t) :: beam_config
     type(interaction_t), pointer :: sf_chain_int
     type(interaction_t), pointer :: src_int
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
     type(state_matrix_t), pointer :: state_matrix
     type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(flavor_t), dimension(:,:), allocatable :: flv_pdf
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf
     integer :: n_in, n_vir, n_out, n_tot, n_sub
     integer :: n_flv_born, n_flv_real, n_flv_total
     integer :: i, j
     logical :: me_already_squared, keep_fs_flavors
     logical :: decrease_n_tot
     logical :: requires_extended_sf
     me_already_squared = .false.
     keep_fs_flavors = .false.
     term%config => process%get_term_ptr (i_term)
     term%int_hard = term%config%int
     core => process%get_core_term (i_term)
     term%negative_sf = process%get_negative_sf ()
     call core%allocate_workspace (term%core_state)
     select type (core)
     class is (prc_external_t)
        call reduce_interaction (term%int_hard, &
             core%includes_polarization (), .true., .false.)
        me_already_squared = .true.
        allocate (term%amp (term%int_hard%get_n_matrix_elements ()))
     class default
        allocate (term%amp (term%config%n_allowed))
     end select
     if (allocated (term%core_state)) then
        select type (core_state => term%core_state)
        type is (openloops_state_t)
           call core_state%init_threshold (process%get_model_ptr ())
        end select
     end if
     term%amp = cmplx (0, 0, default)
     decrease_n_tot = term%nlo_type == NLO_REAL .and. &
          term%config%i_term_global /= term%config%i_sub
     if (present (real_finite)) then
        if (real_finite) decrease_n_tot = .false.
     end if
     if (decrease_n_tot) then
        allocate (term%p_seed (term%int_hard%get_n_tot () - 1))
     else
        allocate (term%p_seed (term%int_hard%get_n_tot ()))
     end if
     allocate (term%p_hard (term%int_hard%get_n_tot ()))
     sf_chain_int => kin%sf_chain%get_out_int_ptr ()
     n_in = term%int_hard%get_n_in ()
     do j = 1, n_in
        i = kin%sf_chain%get_out_i (j)
        call term%int_hard%set_source_link (j, sf_chain_int, i)
     end do
     call term%isolated%init (kin%sf_chain, term%int_hard)
     allocate (mask_in (n_in))
     mask_in = kin%sf_chain%get_out_mask ()
     select type (phs => kin%phs)
       type is (phs_wood_t)
          if (me_already_squared) then
             call term%isolated%setup_identity_trace &
                  (core, mask_in, .true., .false.)
          else
             call term%isolated%setup_square_trace &
                  (core, mask_in, term%config%col, .false.)
          end if
       type is (phs_fks_t)
          select case (phs%mode)
          case (PHS_MODE_ADDITIONAL_PARTICLE)
             if (me_already_squared) then
                call term%isolated%setup_identity_trace &
                     (core, mask_in, .true., .false.)
             else
                keep_fs_flavors = term%config%data%n_flv > 1
                call term%isolated%setup_square_trace &
                     (core, mask_in, term%config%col, &
                     keep_fs_flavors)
             end if
          case (PHS_MODE_COLLINEAR_REMNANT)
             if (me_already_squared) then
                call term%isolated%setup_identity_trace &
                     (core, mask_in, .true., .false.)
             else
                call term%isolated%setup_square_trace &
                     (core, mask_in, term%config%col, .false.)
             end if
          end select
       class default
          call term%isolated%setup_square_trace &
               (core, mask_in, term%config%col, .false.)
     end select
     if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. &
          term%config%i_term_global == term%config%i_sub) .or. &
          term%nlo_type == NLO_MISMATCH) then
        n_sub = term%get_n_sub ()
     else if (term%nlo_type == NLO_DGLAP) then
        n_sub = n_beams_rescaled + term%get_n_sub ()
     else
        !!! No integration of real subtraction in interactions yet
        n_sub = 0
     end if
     keep_fs_flavors = keep_fs_flavors .or. me_already_squared
     requires_extended_sf = term%nlo_type == NLO_DGLAP .or. &
          (term%is_subtraction () .and. process%pcm_contains_pdfs ())
     call term%connected%setup_connected_trace (term%isolated, &
          undo_helicities = undo_helicities (core, me_already_squared), &
          keep_fs_flavors = keep_fs_flavors, &
          requires_extended_sf = requires_extended_sf)
     associate (int_eff => term%isolated%int_eff)
       state_matrix => int_eff%get_state_matrix_ptr ()
       n_tot = int_eff%get_n_tot  ()
       flv_int = quantum_numbers_get_flavor &
            (state_matrix%get_quantum_number (1))
       allocate (f_in (n_in))
       f_in = flv_int(1:n_in)
       deallocate (flv_int)
     end associate
     n_in = term%connected%trace%get_n_in ()
     n_vir = term%connected%trace%get_n_vir ()
     n_out = term%connected%trace%get_n_out ()
     allocate (f_out (n_out))
     do j = 1, n_out
        call term%connected%trace%find_source &
             (n_in + n_vir + j, src_int, i)
        if (associated (src_int)) then
           state_matrix => src_int%get_state_matrix_ptr ()
           flv_src = quantum_numbers_get_flavor &
                (state_matrix%get_quantum_number (1))
           f_out(j) = flv_src(i)
           deallocate (flv_src)
        end if
     end do
 
     beam_config = process%get_beam_config ()
 
     call term%connected%setup_subevt (term%isolated%sf_chain_eff, &
          beam_config%data%flv, f_in, f_out)
     call term%connected%setup_var_list &
          (process%get_var_list_ptr (), beam_config%data)
     ! Does connected%trace never have any helicity qn?
     call term%init_interaction_qn_index (core, term%connected%trace, n_sub, &
          process%get_model_ptr (), is_polarized = .false.)
     call term%init_interaction_qn_index (core, term%int_hard, n_sub, process%get_model_ptr ())
     if (requires_extended_sf) then
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           n_in = pcm%region_data%get_n_in ()
           flv_born = pcm%region_data%get_flv_states_born ()
           flv_real = pcm%region_data%get_flv_states_real ()
           n_flv_born = pcm%region_data%get_n_flv_born ()
           n_flv_real = pcm%region_data%get_n_flv_real ()
           n_flv_total = n_flv_born + n_flv_real
           allocate (flv_pdf(n_in, n_flv_total), &
                qn_pdf(n_in, n_flv_total))
           call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :))
           call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :))
           call qn_pdf%init (flv_pdf)
           call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real)
        end select
     end if
   contains
 
    function undo_helicities (core, me_squared) result (val)
      logical :: val
      class(prc_core_t), intent(in) :: core
      logical, intent(in) :: me_squared
      select type (core)
      class is (prc_external_t)
         val = me_squared .and. .not. core%includes_polarization ()
      class default
         val = .false.
      end select
    end function undo_helicities
 
    subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, &
       keep_colors)
      type(interaction_t), intent(inout) :: int
      logical, intent(in) :: polarized_beams
      logical, intent(in) :: keep_fs_flavors, keep_colors
      type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
      logical, dimension(:), allocatable :: mask_f, mask_c, mask_h
      integer :: n_tot, n_in
      n_in = int%get_n_in (); n_tot = int%get_n_tot ()
      allocate (qn_mask (n_tot))
      allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot))
      mask_c = .not. keep_colors
      mask_f (1 : n_in) = .false.
      if (keep_fs_flavors) then
         mask_f (n_in + 1 : ) = .false.
      else
         mask_f (n_in + 1 : ) = .true.
      end if
      if (polarized_beams) then
         mask_h (1 : n_in) = .false.
      else
         mask_h (1 : n_in) = .true.
      end if
      mask_h (n_in + 1 : ) = .true.
      call qn_mask%init (mask_f, mask_c, mask_h)
      call int%reduce_state_matrix (qn_mask, keep_order = .true.)
    end subroutine reduce_interaction
 end subroutine term_instance_setup_dynamics
 
 @ %def term_instance_setup_dynamics
 @ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]].
 <<Instances: public>>=
   public :: setup_interaction_qn_index
 <<Instances: procedures>>=
   subroutine setup_interaction_qn_index (int, data, qn_config, n_sub, is_polarized)
     class(interaction_t), intent(inout) :: int
     class(process_constants_t), intent(in) :: data
     type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config
     integer, intent(in) :: n_sub
     logical, intent(in) :: is_polarized
     integer :: i
     type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
     if (is_polarized) then
        call setup_interaction_qn_hel (int, data, qn_hel)
        call int%init_qn_index (qn_config, n_sub, qn_hel)
        call int%set_qn_index_helicity_flip (.true.)
     else
        call int%init_qn_index (qn_config, n_sub)
     end if
   end subroutine setup_interaction_qn_index
 
 @ %def setup_interaction_qn_index
 @ Set up beam polarisation quantum numbers, if beam polarisation is required.
 
 We retrieve the full helicity information from [[term%config%data]] and reduce
 the information only to the inital state. Afterwards, we uniquify the initial
 state polarization by a applying an index (hash) table.
 
 The helicity information is fed into an array of quantum numbers to assign
 flavor, helicity and subtraction indices correctly to their matrix element.
 <<Instances: public>>=
   public :: setup_interaction_qn_hel
 <<Instances: procedures>>=
    subroutine setup_interaction_qn_hel (int, data, qn_hel)
      class(interaction_t), intent(in) :: int
      class(process_constants_t), intent(in) :: data
      type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: qn_hel
      type(helicity_t), dimension(:), allocatable :: hel
      integer, dimension(:), allocatable :: index_table
      integer, dimension(:, :), allocatable :: hel_state
      integer :: i, j, n_hel_unique
      associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ())
        allocate (hel_state (n_tot, data%get_n_hel ()), &
             source = data%hel_state)
        allocate (index_table (data%get_n_hel ()), &
             source = 0)
        forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0
        n_hel_unique = 0
        HELICITY: do i = 1, data%get_n_hel ()
           do j = 1, data%get_n_hel ()
              if (index_table (j) == 0) then
                 index_table(j) = i; n_hel_unique = n_hel_unique + 1
                 cycle HELICITY
              else if (all (hel_state(:, i) == &
                   hel_state(:, index_table(j)))) then
                 cycle HELICITY
              end if
           end do
        end do HELICITY
        allocate (qn_hel (n_tot, n_hel_unique))
        allocate (hel (n_tot))
        do j = 1, n_hel_unique
           call hel%init (hel_state(:, index_table(j)))
           call qn_hel(:, j)%init (hel)
        end do
      end associate
    end subroutine setup_interaction_qn_hel
 
 @ %def setup_interaction_qn_hel
 @
 <<Instances: term instance: TBP>>=
   procedure :: init_interaction_qn_index => term_instance_init_interaction_qn_index
 <<Instances: procedures>>=
   subroutine term_instance_init_interaction_qn_index (term, core, int, n_sub, &
          model, is_polarized)
     class(term_instance_t), intent(inout), target :: term
     class(prc_core_t), intent(in) :: core
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: n_sub
     class(model_data_t), intent(in) :: model
     logical, intent(in), optional :: is_polarized
     logical :: polarized
     type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config
     integer, dimension(:,:), allocatable :: flv_born
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     select type (core)
     class is (prc_external_t)
        if (present (is_polarized)) then
           polarized = is_polarized
        else
           polarized = core%includes_polarization ()
        end if
        select type (pcm_work => term%pcm_work)
        type is (pcm_nlo_workspace_t)
           associate (is_born => .not. (term%nlo_type == NLO_REAL .and. &
                   .not. term%is_subtraction ()))
              select type (pcm => term%pcm)
              type is (pcm_nlo_t)
                 qn_config = pcm%get_qn (is_born)
              end select
              call setup_interaction_qn_index (int, term%config%data, &
                   qn_config, n_sub, polarized)
           end associate
        class default
           call term%config%data%get_flv_state (flv_born)
           allocate (flv (size (flv_born, dim = 1)))
           allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2)))
           do i = 1, core%data%n_flv
              call flv%init (flv_born(:,i), model)
              call qn_config(:, i)%init (flv)
           end do
           call setup_interaction_qn_index (int, term%config%data, &
                qn_config, n_sub, polarized)
        end select
     class default
        call int%init_qn_index ()
     end select
   end subroutine term_instance_init_interaction_qn_index
 
 @ %def term_instance_init_interaction_qn_index
 @
 <<Instances: term instance: TBP>>=
   procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_setup_fks_kinematics (term, kin, var_list, beam_config)
     class(term_instance_t), intent(inout), target :: term
     type(kinematics_t), intent(inout) :: kin
     type(var_list_t), intent(in) :: var_list
     type(process_beam_config_t), intent(in) :: beam_config
     integer :: mode
     logical :: singular_jacobian
     if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. &
        term%nlo_type == NLO_MISMATCH)) return
     singular_jacobian = var_list%get_lval (var_str ("?powheg_use_singular_jacobian"))
     if (term%nlo_type == NLO_REAL) then
        mode = check_generator_mode (GEN_REAL_PHASE_SPACE)
     else if (term%nlo_type == NLO_MISMATCH) then
        mode = check_generator_mode (GEN_SOFT_MISMATCH)
     else
        mode = PHS_MODE_UNDEFINED
     end if
     select type (phs => kin%phs)
     type is (phs_fks_t)
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           select type (pcm_work => term%pcm_work)
           type is (pcm_nlo_workspace_t)
              call pcm%setup_phs_generator (pcm_work, &
                   phs%generator, phs%config%sqrts, mode, singular_jacobian)
              if (beam_config%has_structure_function ()) then
                 pcm_work%isr_kinematics%isr_mode = SQRTS_VAR
              else
                 pcm_work%isr_kinematics%isr_mode = SQRTS_FIXED
              end if
              if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_work%isr_kinematics%isr_mode)
           end select
        end select
     class default
        call msg_fatal ("Phase space should be an FKS phase space!")
     end select
   contains
     function check_generator_mode (gen_mode_default) result (gen_mode)
        integer :: gen_mode
        integer, intent(in) :: gen_mode_default
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           associate (settings => pcm%settings)
              if (settings%test_coll_limit .and. settings%test_anti_coll_limit) &
                 call msg_fatal ("You cannot check the collinear and anti-collinear limit "&
                      &"at the same time!")
              if (settings%test_soft_limit .and. .not. settings%test_coll_limit &
                   .and. .not. settings%test_anti_coll_limit) then
                 gen_mode = GEN_SOFT_LIMIT_TEST
              else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then
                 gen_mode = GEN_COLL_LIMIT_TEST
              else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then
                 gen_mode = GEN_ANTI_COLL_LIMIT_TEST
              else if (settings%test_soft_limit .and. settings%test_coll_limit) then
                 gen_mode = GEN_SOFT_COLL_LIMIT_TEST
              else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then
                 gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST
              else
                 gen_mode = gen_mode_default
              end if
           end associate
        end select
     end function check_generator_mode
   end subroutine term_instance_setup_fks_kinematics
 
 @ %def term_instance_setup_fks_kinematics
 @ Set up seed kinematics, starting from the MC parameter set given as
 argument.  As a result, the [[k_seed]] kinematics object is evaluated
 (except for the structure-function matrix-element evaluation, which we
 postpone until we know the factorization scale), and we have a valid
 [[p_seed]] momentum array.
 <<Instances: term instance: TBP>>=
   procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_compute_seed_kinematics &
        (term, kin, mci_work, phs_channel, success)
     class(term_instance_t), intent(inout), target :: term
     type(kinematics_t), intent(inout) :: kin
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     logical, intent(out) :: success
     call kin%compute_selected_channel &
          (mci_work, phs_channel, term%p_seed, success)
   end subroutine term_instance_compute_seed_kinematics
 
 @ %def term_instance_compute_seed_kinematics
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_projections => term_instance_evaluate_projections
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_projections (term, kin)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(inout) :: kin
     if (kin%threshold .and. term%nlo_type > BORN) then
        if (debug2_active (D_THRESHOLD)) &
             print *, 'Evaluate on-shell projection: ', &
             char (component_status (term%nlo_type))
        select type (pcm_work => term%pcm_work)
        type is (pcm_nlo_workspace_t)
           call kin%threshold_projection (pcm_work, term%nlo_type)
        end select
     end if
   end subroutine term_instance_evaluate_projections
 
 @ %def term_instance_evaluate_projections
 @ Compute the momenta in the hard interactions, one for each term that
 constitutes this process component.  In simple cases this amounts to
 just copying momenta.  In more advanced cases, we may generate
 distinct sets of momenta from the seed kinematics.
 
 The interactions in the term instances are accessed individually.  We may
 choose to calculate all terms at once together with the seed kinematics, use
 [[component%core_state]] for storage, and just fill the interactions here.
 <<Instances: term instance: TBP>>=
   procedure :: compute_hard_kinematics => &
        term_instance_compute_hard_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_compute_hard_kinematics &
        (term, kin, recover, skip_term, success)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(inout) :: kin
     integer, intent(in), optional :: skip_term
     logical, intent(in), optional :: recover
     logical, intent(out) :: success
     type(vector4_t), dimension(:), allocatable :: p
     if (allocated (term%core_state)) &
        call term%core_state%reset_new_kinematics ()
     if (present (skip_term)) then
        if (term%config%i_term_global == skip_term) return
     end if
 
     if (present (recover)) then
        if (recover) return
     end if
     if (term%nlo_type == NLO_REAL .and. kin%emitter >= 0) then
        call kin%evaluate_radiation (term%p_seed, p, success)
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           if (pcm%dalitz_plot%active) then
              if (kin%emitter > kin%n_in) then
                 if (p(kin%emitter)**2 > tiny_07) &
                      call pcm%register_dalitz_plot (kin%emitter, p)
              end if
           end if
        end select
     else if (is_subtraction_component (kin%emitter, term%nlo_type)) then
        call kin%modify_momenta_for_subtraction (term%p_seed, p)
        success = .true.
     else
        allocate (p (size (term%p_seed))); p = term%p_seed
        success = .true.
     end if
     call term%int_hard%set_momenta (p)
     if (debug_on) then
        call msg_debug2 (D_REAL, "inside compute_hard_kinematics")
        if (debug2_active (D_REAL))  call vector4_write_set (p)
     end if
   end subroutine term_instance_compute_hard_kinematics
 
 @ %def term_instance_compute_hard_kinematics
 @ Here, we invert this.  We fetch the incoming momenta which reside
 in the appropriate [[sf_chain]] object, stored within the [[k_seed]]
 subobject.  On the other hand, we have the outgoing momenta of the
 effective interaction.  We rely on the process core to compute the
 remaining seed momenta and to fill the momenta within the hard
 interaction.  (The latter is trivial if hard and effective interaction
 coincide.)
 
 After this is done, the incoming momenta in the trace evaluator that
 corresponds to the hard (effective) interaction, are still
 left undefined.  We remedy this by calling [[receive_kinematics]] once.
 <<Instances: term instance: TBP>>=
   procedure :: recover_seed_kinematics => &
        term_instance_recover_seed_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_recover_seed_kinematics (term, kin, p_seed_ref)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(in) :: kin
     integer :: n_in
     type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref
     n_in = kin%n_in
     call kin%get_incoming_momenta (term%p_seed(1:n_in))
     associate (int_eff => term%isolated%int_eff)
        call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.)
        if (present (p_seed_ref)) then
           term%p_seed(n_in + 1 : ) = p_seed_ref
        else
           term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.)
        end if
     end associate
     call term%isolated%receive_kinematics ()
   end subroutine term_instance_recover_seed_kinematics
 
 @ %def term_instance_recover_seed_kinematics
 @ Compute the integration parameters for all channels except the selected
 one.
 JRR: Obsolete now.
 <<XXX Instances: term instance: TBP>>=
   procedure :: compute_other_channels => &
        term_instance_compute_other_channels
 <<XXX Instances: procedures>>=
   subroutine term_instance_compute_other_channels &
        (term, mci_work, phs_channel)
     class(term_instance_t), intent(inout), target :: term
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     call term%k_term%compute_other_channels (mci_work, phs_channel)
   end subroutine term_instance_compute_other_channels
 
 @ %def term_instance_compute_other_channels
 @ Recover beam momenta, i.e., return the beam momenta as currently
 stored in the kinematics subobject to their source.  This is a side effect.
 JRR: Obsolete now.
 <<XXX Instances: term instance: TBP>>=
   procedure :: return_beam_momenta => term_instance_return_beam_momenta
 <<XXX Instances: procedures>>=
   subroutine term_instance_return_beam_momenta (term)
     class(term_instance_t), intent(in) :: term
     call term%k_term%return_beam_momenta ()
   end subroutine term_instance_return_beam_momenta
  
 @ %def term_instance_return_beam_momenta
 @ 
 Applies the real partition by computing the real partition function $F(\Phi)$
 and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or
 $\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$.
 <<Instances: term instance: TBP>>=
   procedure :: apply_real_partition => term_instance_apply_real_partition
 <<Instances: procedures>>=
   subroutine term_instance_apply_real_partition (term, kin, process)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(in) :: kin
     type(process_t), intent(in) :: process
     real(default) :: f, sqme
     integer :: i_component
     integer :: i_amp, n_amps, qn_index
     logical :: is_subtraction
     i_component = term%config%i_component
     if (process%component_is_selected (i_component) .and. &
            process%get_component_nlo_type (i_component) == NLO_REAL) then
        is_subtraction = process%get_component_type (i_component) == COMP_REAL_SING &
             .and. kin%emitter < 0
        if (is_subtraction) return
        select case (process%get_component_type (i_component))
        case (COMP_REAL_FIN)
           call term%connected%trace%set_duplicate_flv_zero()
        end select
        select type (pcm => process%get_pcm_ptr ())
        type is (pcm_nlo_t)
           f = pcm%real_partition%get_f (term%p_hard)
        end select
        n_amps = term%connected%trace%get_n_matrix_elements ()
        do i_amp = 1, n_amps
           qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0)
           sqme = real (term%connected%trace%get_matrix_element (qn_index))
           if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition")
           select type (pcm => term%pcm)
           type is (pcm_nlo_t)
              select case (process%get_component_type (i_component))
              case (COMP_REAL_FIN, COMP_REAL_SING)
                 select case (process%get_component_type (i_component))
                 case (COMP_REAL_FIN)
                    if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite")
                    sqme = sqme * (one - f)
                 case (COMP_REAL_SING)
                    if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular")
                    sqme = sqme * f
                 end select
              end select
           end select
           if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme)
           call term%connected%trace%set_matrix_element (qn_index, cmplx (sqme, zero, default))
        end do
     end if
   end subroutine term_instance_apply_real_partition
 
 @ %def term_instance_apply_real_partition
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_p_hard => term_instance_get_p_hard
 <<Instances: procedures>>=
   pure function term_instance_get_p_hard (term_instance) result (p_hard)
     type(vector4_t), dimension(:), allocatable :: p_hard
     class(term_instance_t), intent(in) :: term_instance
     allocate (p_hard (size (term_instance%p_hard)))
     p_hard = term_instance%p_hard
   end function term_instance_get_p_hard
 
 @ %def term_instance_get_p_hard
 @
 <<Instances: term instance: TBP>>=
   procedure :: set_emitter => term_instance_set_emitter
 <<Instances: procedures>>=
   subroutine term_instance_set_emitter (term, kin)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(inout) :: kin
     integer :: i_phs
     logical :: set_emitter
     select type (pcm => term%pcm)
     type is (pcm_nlo_t)
        select type (phs => kin%phs)
        type is (phs_fks_t)
           !!! Without resonances, i_alr = i_phs
           i_phs = term%config%i_term
           kin%i_phs = i_phs
           set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL
           if (set_emitter) then
              kin%emitter = phs%phs_identifiers(i_phs)%emitter
              select type (pcm => term%pcm)
              type is (pcm_nlo_t)
                 if (allocated (pcm%region_data%i_phs_to_i_con)) &
                    kin%i_con = pcm%region_data%i_phs_to_i_con (i_phs)
              end select
           end if
        end select
     end select
   end subroutine term_instance_set_emitter
 
 @ %def term_instance_set_emitter
 @ For initializing the expressions, we need the local variable list and the
 parse trees.
 <<Instances: term instance: TBP>>=
   procedure :: setup_expressions => term_instance_setup_expressions
 <<Instances: procedures>>=
   subroutine term_instance_setup_expressions (term, meta, config)
     class(term_instance_t), intent(inout), target :: term
     type(process_metadata_t), intent(in), target :: meta
     type(process_config_data_t), intent(in) :: config
     if (allocated (config%ef_cuts)) &
          call term%connected%setup_cuts (config%ef_cuts)
     if (allocated (config%ef_scale)) &
          call term%connected%setup_scale (config%ef_scale)
     if (allocated (config%ef_fac_scale)) &
          call term%connected%setup_fac_scale (config%ef_fac_scale)
     if (allocated (config%ef_ren_scale)) &
          call term%connected%setup_ren_scale (config%ef_ren_scale)
     if (allocated (config%ef_weight)) &
          call term%connected%setup_weight (config%ef_weight)
   end subroutine term_instance_setup_expressions
 
 @ %def term_instance_setup_expressions
 @ Prepare the extra evaluators that we need for processing events.
 
 The matrix elements we get from OpenLoops and GoSam are already squared
 and summed over color and helicity. They should not be squared again.
 <<Instances: term instance: TBP>>=
   procedure :: setup_event_data => term_instance_setup_event_data
 <<Instances: procedures>>=
   subroutine term_instance_setup_event_data (term, kin, core, model)
     class(term_instance_t), intent(inout), target :: term
     type(kinematics_t), intent(in) :: kin
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     logical :: mask_color
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
     n_in = term%int_hard%get_n_in ()
     allocate (mask_in (n_in))
     mask_in = kin%sf_chain%get_out_mask ()
     call setup_isolated (term%isolated, core, model, mask_in, term%config%col)
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        mask_color = pcm_work%is_fixed_order_nlo_events ()
     class default
        mask_color = .false.
     end select
     call setup_connected (term%connected, term%isolated, core, &
          term%nlo_type, mask_color)
   contains
     subroutine setup_isolated (isolated, core, model, mask, color)
       type(isolated_state_t), intent(inout), target :: isolated
       class(prc_core_t), intent(in) :: core
       class(model_data_t), intent(in), target :: model
       type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask
       integer, intent(in), dimension(:) :: color
       select type (core)
       class is (prc_blha_t)
          call isolated%matrix%init_identity(isolated%int_eff)
          isolated%has_matrix = .true.
       class default
          call isolated%setup_square_matrix (core, model, mask, color)
       end select
       !!! TODO (PS-09-10-20) We should not square the flows
       !!! if they come from BLHA either
       call isolated%setup_square_flows (core, model, mask)
     end subroutine setup_isolated
 
     subroutine setup_connected (connected, isolated, core, nlo_type, mask_color)
       type(connected_state_t), intent(inout), target :: connected
       type(isolated_state_t), intent(in), target :: isolated
       class(prc_core_t), intent(in) :: core
       integer, intent(in) :: nlo_type
       logical, intent(in) :: mask_color
       type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
       call connected%setup_connected_matrix (isolated)
       if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL &
            .and. term%config%i_term_global == term%config%i_sub) &
            .or. term%nlo_type == NLO_DGLAP) then
          !!! We do not care about the subtraction matrix elements in
          !!! connected%matrix, because all entries there are supposed
          !!! to be squared. To be able to match with flavor quantum numbers,
          !!! we remove the subtraction quantum entries from the state matrix.
          allocate (mask (connected%matrix%get_n_tot()))
          call mask%set_sub (1)
          call connected%matrix%reduce_state_matrix (mask, keep_order = .true.)
       end if
       call term%init_interaction_qn_index (core, connected%matrix, 0, model, &
            is_polarized = .false.)
       select type (core)
       class is (prc_blha_t)
          call connected%setup_connected_flows &
               (isolated, mask_color = mask_color)
       class default
          call connected%setup_connected_flows (isolated)
       end select
       call connected%setup_state_flv (isolated%get_n_out ())
     end subroutine setup_connected
   end subroutine term_instance_setup_event_data
 
 @ %def term_instance_setup_event_data
 @ Color-correlated matrix elements should be obtained from
 the external BLHA provider. According to the standard, the
 matrix elements output is a one-dimensional array. For FKS
 subtraction, we require the  matrix $B_{ij}$. BLHA prescribes
 a mapping $(i, j) \to k$, where $k$ is the index of the matrix
 element in the output array. It focusses on the off-diagonal entries,
 i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes
 this mapping. The diagonal entries can simply be obtained as
 the product of the Born matrix element and either $C_A$ or $C_F$,
 which is achieved by [[blha_color_c_fill_diag]].
 For simple processes, i.e. those with only one color line, it is
 $B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing
 color correlations by a multiplication of the Born matrix element with $C_F$.
 It is triggered by the [[use_internal_color_correlations]] flag and should
 be used only for testing purposes. However, it is also used for
 the threshold computation where the process is well-defined and fixed.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_color_correlations => &
      term_instance_evaluate_color_correlations
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_color_correlations (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     integer :: i_flv_born
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           if (debug_on) call msg_debug2 (D_SUBTRACTION, &
                "term_instance_evaluate_color_correlations: " // &
                "use_internal_color_correlations:", &
                pcm%settings%use_internal_color_correlations)
           if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%get_fac_scale ())
           do i_flv_born = 1, pcm%region_data%n_flv_born
              select case (term%nlo_type)
              case (NLO_REAL)
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      pcm_work%real_sub%sqme_born (i_flv_born), &
                      pcm_work%real_sub%sqme_born_color_c (:, :, i_flv_born))
              case (NLO_MISMATCH)
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      pcm_work%soft_mismatch%sqme_born (i_flv_born), &
                      pcm_work%soft_mismatch%sqme_born_color_c (:, :, i_flv_born))
              case (NLO_VIRTUAL)
                 !!! This is just a copy of the above with a different offset and can for sure be unified
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      -one, pcm_work%virtual%sqme_color_c (:, :, i_flv_born))
               case (NLO_DGLAP)
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      pcm_work%dglap_remnant%sqme_born (i_flv_born), &
                      pcm_work%dglap_remnant%sqme_color_c_extra (:, :, i_flv_born))
              end select
           end do
        end select
     end select
   contains
     function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij)
       integer, intent(in) :: n_tot, factorization_mode
       integer, intent(in), dimension(:) :: flv
       real(default), dimension(n_tot, n_tot) :: beta_ij
       if (factorization_mode == NO_FACTORIZATION) then
          beta_ij = get_trivial_cf_factors_default (n_tot, flv)
       else
          beta_ij = get_trivial_cf_factors_threshold (n_tot, flv)
       end if
     end function get_trivial_cf_factors
 
     function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij)
       integer, intent(in) :: n_tot
       integer, intent(in), dimension(:) :: flv
       real(default), dimension(n_tot, n_tot) :: beta_ij
       integer :: i, j
       beta_ij = zero
       if (count (is_quark (flv)) == 2) then
          do i = 1, n_tot
             do j = 1, n_tot
                if (is_quark(flv(i)) .and. is_quark(flv(j))) then
                   if (i == j) then
                      beta_ij(i,j)= -cf
                   else
                      beta_ij(i,j) = cf
                   end if
                end if
             end do
          end do
       end if
     end function get_trivial_cf_factors_default
 
     function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij)
       integer, intent(in) :: n_tot
       integer, intent(in), dimension(:) :: flv
       real(default), dimension(n_tot, n_tot) :: beta_ij
       integer :: i
       beta_ij = zero
       do i = 1, 4
          beta_ij(i,i) = -cf
       end do
       beta_ij(1,2) = cf; beta_ij(2,1) = cf
       beta_ij(3,4) = cf; beta_ij(4,3) = cf
     end function get_trivial_cf_factors_threshold
 
     subroutine transfer_me_array_to_bij (pcm, i_flv, &
          sqme_born, sqme_color_c)
       type(pcm_nlo_t), intent(in) :: pcm
       integer, intent(in) :: i_flv
       real(default), intent(in) :: sqme_born
       real(default), dimension(:,:), intent(inout) :: sqme_color_c
       logical :: special_case_interferences
       integer :: i_color_c, i_sub, n_offset
       real(default), dimension(:), allocatable :: sqme
       if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij")
       if (pcm%settings%use_internal_color_correlations) then
          !!! A negative value for sqme_born indicates that the Born matrix
          !!! element is multiplied at a different place, e.g. in the case
          !!! of the virtual component
          sqme_color_c = get_trivial_cf_factors &
               (pcm%region_data%get_n_legs_born (), &
               pcm%region_data%get_flv_states_born (i_flv), &
               pcm%settings%factorization_mode)
          if (sqme_born > zero) then
             sqme_color_c = sqme_born * sqme_color_c
          else if (sqme_born == zero) then
             sqme_color_c = zero
          end if
       else
          special_case_interferences = pcm%region_data%nlo_correction_type == "EW"
          n_offset = 0
          if (term%nlo_type == NLO_VIRTUAL) then
             n_offset = 1
          else if (pcm%has_pdfs .and. (term%is_subtraction () &
                 .or. term%nlo_type == NLO_DGLAP)) then
             n_offset = n_beams_rescaled
          end if
          allocate (sqme (term%get_n_sub_color ()), source = zero)
          do i_sub = 1, term%get_n_sub_color ()
             sqme(i_sub) = real(term%connected%trace%get_matrix_element ( &
                  term%connected%trace%get_qn_index (i_flv, i_sub = i_sub + n_offset)), &
                  default)
          end do
          call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, &
               sqme, sqme_color_c)
          call blha_color_c_fill_diag (real(term%connected%trace%get_matrix_element ( &
               term%connected%trace%get_qn_index (i_flv, i_sub = 0)), default), &
               pcm%region_data%get_flv_states_born (i_flv), &
               sqme_color_c, special_case_interferences)
       end if
     end subroutine transfer_me_array_to_bij
   end subroutine term_instance_evaluate_color_correlations
 
 @ %def term_instance_evaluate_color_correlations
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_charge_correlations => &
      term_instance_evaluate_charge_correlations
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_charge_correlations (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     integer :: i_flv_born
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           do i_flv_born = 1, pcm%region_data%n_flv_born
              select case (term%nlo_type)
              case (NLO_REAL)
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      pcm_work%real_sub%sqme_born (i_flv_born), &
                      pcm_work%real_sub%sqme_born_charge_c (:, :, i_flv_born))
              case (NLO_MISMATCH)
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      pcm_work%soft_mismatch%sqme_born (i_flv_born), &
                      pcm_work%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born))
              case (NLO_VIRTUAL)
                 call transfer_me_array_to_bij (pcm, i_flv_born, &
                      one, pcm_work%virtual%sqme_charge_c (:, :, i_flv_born))
              end select
           end do
        end select
     end select
   contains
     subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c)
       type(pcm_nlo_t), intent(in) :: pcm
       integer, intent(in) :: i_flv
       real(default), intent(in) :: sqme_born
       real(default), dimension(:,:), intent(inout) :: sqme_charge_c
       integer :: n_legs_born, i, j
       real(default), dimension(:), allocatable :: sigma
       real(default), dimension(:), allocatable :: Q
       n_legs_born = pcm%region_data%n_legs_born
       associate (flv_born => pcm%region_data%flv_born(i_flv))
          allocate (sigma (n_legs_born), Q (size (flv_born%charge)))
          Q = flv_born%charge
          sigma(1:flv_born%n_in) = -one
          sigma(flv_born%n_in + 1: ) = one
       end associate
       do i = 1, n_legs_born
          do j = 1, n_legs_born
             sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one)
          end do
       end do
       sqme_charge_c = sqme_charge_c * sqme_born
     end subroutine transfer_me_array_to_bij
   end subroutine term_instance_evaluate_charge_correlations
 
 @ %def term_instance_evaluate_charge_correlations
 @ The information about spin correlations is not stored in the [[nlo_settings]] because
 it is only available after the [[fks_regions]] have been created.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_spin_correlations => term_instance_evaluate_spin_correlations
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_spin_correlations (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     integer :: i_flv, i_sub, i_emitter, emitter
     integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j
     real(default), dimension(1:3, 1:3) :: sqme_spin_c
     real(default), dimension(:), allocatable :: sqme_spin_c_all
     real(default), dimension(:), allocatable :: sqme_spin_c_arr
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_spin_correlations")
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        if (pcm_work%real_sub%requires_spin_correlations () &
             .and. term%nlo_type == NLO_REAL) then
           select type (core)
           type is (prc_openloops_t)
              select type (pcm => term%pcm)
              type is (pcm_nlo_t)
                 n_flv = term%connected%trace%get_qn_index_n_flv ()
                 n_sub_color = term%get_n_sub_color ()
                 n_sub_spin = term%get_n_sub_spin ()
                 n_offset = 0; if(pcm%has_pdfs) n_offset = n_beams_rescaled
                 allocate (sqme_spin_c_arr(6))
                 do i_flv = 1, n_flv
                    allocate (sqme_spin_c_all(n_sub_spin))
                    do i_sub = 1, n_sub_spin
                       sqme_spin_c_all(i_sub) = real(term%connected%trace%get_matrix_element &
                            (term%connected%trace%get_qn_index (i_flv, &
                            i_sub = i_sub + n_offset + n_sub_color)), default)
                    end do
                    do i_emitter = 1, pcm%region_data%n_emitters
                       emitter = pcm%region_data%emitters(i_emitter)
                       if (emitter > 0) then
                          call split_array (sqme_spin_c_all, sqme_spin_c_arr)
                          do j = 1, size (sqme_spin_c, dim=2)
                             do i = j, size (sqme_spin_c, dim=1)
                                !!! Restoring the symmetric matrix packed into a 1-dim array
                                !!! c.f. [[prc_openloops_compute_sqme_spin_c]]
                                sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2)
                                if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j)
                             end do
                          end do
                          pcm_work%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c
                       end if
                    end do
                    deallocate (sqme_spin_c_all)
                 end do
              end select
           class default
              call msg_fatal ("Spin correlations so far only supported by OpenLoops.")
           end select
        end if
     end select
   end subroutine term_instance_evaluate_spin_correlations
 
 @ %def term_instance_evaluate_spin_correlations
 @@
 <<Instances: term instance: TBP>>=
   procedure :: apply_fks => term_instance_apply_fks
 <<Instances: procedures>>=
   subroutine term_instance_apply_fks (term, kin, alpha_s_sub, alpha_qed_sub)
     class(term_instance_t), intent(inout) :: term
     class(kinematics_t), intent(inout) :: kin
     real(default), intent(in) :: alpha_s_sub, alpha_qed_sub
     real(default), dimension(:), allocatable :: sqme
     integer :: i, i_phs, emitter
     logical :: is_subtraction
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) then
              allocate (sqme (pcm%get_n_alr ()))
           else
              allocate (sqme (1))
           end if
           sqme = zero
           select type (phs => kin%phs)
           type is (phs_fks_t)
              if (pcm%has_pdfs .and. &
                   pcm%settings%use_internal_color_correlations) then
                 call msg_fatal ("Color correlations for proton processes " // &
                      "so far only supported by OpenLoops.")
              end if
              call pcm_work%set_real_and_isr_kinematics &
                   (phs%phs_identifiers, kin%phs%get_sqrts ())
              if (kin%emitter < 0) then
                 call pcm_work%set_subtraction_event ()
                 do i_phs = 1, pcm%region_data%n_phs
                    emitter = phs%phs_identifiers(i_phs)%emitter
                    call pcm_work%real_sub%compute (emitter, &
                         i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme)
                 end do
              else
                 call pcm_work%set_radiation_event ()
                 emitter = kin%emitter; i_phs = kin%i_phs
                 do i = 1, term%connected%trace%get_qn_index_n_flv ()
                    pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = &
                      real (term%connected%trace%get_matrix_element ( &
                      term%connected%trace%get_qn_index (i)))
                 end do
                 call pcm_work%real_sub%compute (emitter, i_phs, alpha_s_sub, &
                      alpha_qed_sub, term%connected%has_matrix, sqme)
              end if
           end select
        end select
     end select
     if (term%connected%has_trace) &
          call term%connected%trace%set_only_matrix_element &
               (1, cmplx (sum(sqme), 0, default))
     select type (pcm => term%pcm)
     type is (pcm_nlo_t)
        is_subtraction = kin%emitter < 0
        if (term%connected%has_matrix) &
             call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
                 pcm%get_qn (is_subtraction), &
                 pcm%region_data%get_flavor_indices (is_subtraction), &
                 term%connected%matrix)
        if (term%connected%has_flows) &
             call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
                  pcm%get_qn (is_subtraction), &
                  pcm%region_data%get_flavor_indices (is_subtraction), &
                  term%connected%flows)
     end select
   end subroutine term_instance_apply_fks
 
 @ %def term_instance_apply_fks
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed)
      class(term_instance_t), intent(inout) :: term
      real(default), intent(in) :: alpha_s, alpha_qed
      real(default), dimension(2) :: alpha_coupling
      type(vector4_t), dimension(:), allocatable :: p_born
      real(default), dimension(:), allocatable :: sqme_virt
      integer :: i_flv
      if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal &
         ("Trying to evaluate virtual matrix element with unsuited term_instance.")
      if (debug2_active (D_VIRTUAL)) then
         call msg_debug2 (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements")
         print *, 'ren_scale: ', term%get_ren_scale ()
         print *, 'fac_scale: ', term%get_fac_scale ()
         if (allocated (term%es_scale)) then
            print *, 'ES  scale: ', term%es_scale
         else
            print *, 'ES  scale: ', term%get_ren_scale ()
         end if
      end if
      select type (pcm => term%pcm)
      type is (pcm_nlo_t)
         select type (pcm_work => term%pcm_work)
         type is (pcm_nlo_workspace_t)
            alpha_coupling = [alpha_s, alpha_qed] 
            if (debug2_active (D_VIRTUAL)) then
               print *, 'alpha_s: ', alpha_coupling (1)
               print *, 'alpha_qed: ', alpha_coupling (2)
            end if
            allocate (p_born (pcm%region_data%n_legs_born))
            if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
               p_born = pcm_work%real_kinematics%p_born_onshell%get_momenta(1)
            else
               p_born = term%int_hard%get_momenta ()
            end if
            call pcm_work%set_momenta_and_scales_virtual &
                 (p_born, term%ren_scale, term%get_fac_scale (), &
                 term%es_scale)
            select type (pcm_work => term%pcm_work)
            type is (pcm_nlo_workspace_t)
               associate (virtual => pcm_work%virtual)
                 do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
                     virtual%sqme_born(i_flv) = &
                         real (term%connected%trace%get_matrix_element ( &
                         term%connected%trace%get_qn_index (i_flv, i_sub = 0)))
                    virtual%sqme_virt_fin(i_flv) = &
                         real (term%connected%trace%get_matrix_element ( &
                         term%connected%trace%get_qn_index (i_flv, i_sub = 1)))
                 end do
               end associate
            end select
            call pcm_work%compute_sqme_virt (term%pcm, term%p_hard, alpha_coupling, &
                 term%connected%has_matrix, sqme_virt)
            call term%connected%trace%set_only_matrix_element &
                 (1, cmplx (sum(sqme_virt), 0, default))
            if (term%connected%has_matrix) &
               call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
                    pcm%get_qn (.true.), &
                    remove_duplicates_from_int_array ( &
                    pcm%region_data%get_flavor_indices (.true.)), &
                    term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
                     pcm%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     pcm%region_data%get_flavor_indices (.true.)), &
                     term%connected%flows)
         end select
      end select
   end subroutine term_instance_evaluate_sqme_virt
 
 @ %def term_instance_evaluate_sqme_virt
-@
+@ Needs generalization to electroweak corrections.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s
     real(default), dimension(:), allocatable :: sqme_mism
     if (term%nlo_type /= NLO_MISMATCH) call msg_fatal &
        ("Trying to evaluate soft mismatch with unsuited term_instance.")
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        call pcm_work%compute_sqme_mismatch &
             (term%pcm, alpha_s, term%connected%has_matrix, sqme_mism)
     end select
     call term%connected%trace%set_only_matrix_element &
          (1, cmplx (sum (sqme_mism) * term%weight, 0, default))
     if (term%connected%has_matrix) then
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) &
                call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
                     pcm%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     pcm%region_data%get_flavor_indices (.true.)), &
                     term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
                     pcm%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     pcm%region_data%get_flavor_indices (.true.)), &
                     term%connected%flows)
        end select
     end if
   end subroutine term_instance_evaluate_sqme_mismatch
 
 @ %def term_instance_evaluate_sqme_mismatch
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_sqme_dglap (term, alpha_s, alpha_qed)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s, alpha_qed
     real(default), dimension(2) :: alpha_coupling
     real(default), dimension(:), allocatable :: sqme_dglap
     integer :: i_flv
     if (term%nlo_type /= NLO_DGLAP) call msg_fatal &
        ("Trying to evaluate DGLAP remnant with unsuited term_instance.")
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap")
     select type (pcm => term%pcm)
     type is (pcm_nlo_t)       
        select type (pcm_work => term%pcm_work)
        type is (pcm_nlo_workspace_t)
           alpha_coupling = [alpha_s,alpha_qed]
           if (debug2_active (D_PROCESS_INTEGRATION)) then
              associate (n_flv => pcm_work%dglap_remnant%reg_data%n_flv_born)
                print *, "size(sqme_born) = ", size (pcm_work%dglap_remnant%sqme_born)
                call term%connected%trace%write ()
              end associate
           end if
           call pcm_work%compute_sqme_dglap_remnant (pcm, alpha_coupling, &
                term%connected%has_matrix, sqme_dglap)
        end select
     end select
     call term%connected%trace%set_only_matrix_element &
          (1, cmplx (sum (sqme_dglap) * term%weight, 0, default))
     if (term%connected%has_matrix) then
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
                pcm%get_qn (.true.), &
                remove_duplicates_from_int_array ( &
                pcm%region_data%get_flavor_indices (.true.)), &
                term%connected%matrix)
           if (term%connected%has_flows) then
              call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
                   pcm%get_qn (.true.), &
                   remove_duplicates_from_int_array ( &
                   pcm%region_data%get_flavor_indices (.true.)), &
                   term%connected%flows)
           end if
        end select
     end if
   end subroutine term_instance_evaluate_sqme_dglap
 
 @ %def term_instance_evaluate_sqme_dglap
 @ Reset the term instance: clear the parton-state expressions and deactivate.
 <<Instances: term instance: TBP>>=
   procedure :: reset => term_instance_reset
 <<Instances: procedures>>=
   subroutine term_instance_reset (term)
     class(term_instance_t), intent(inout) :: term
     call term%connected%reset_expressions ()
     if (allocated (term%alpha_qcd_forced))  deallocate (term%alpha_qcd_forced)
     term%active = .false.
   end subroutine term_instance_reset
 
 @ %def term_instance_reset
 @ Force an $\alpha_s$ value that should be used in the matrix-element
 calculation.
 <<Instances: term instance: TBP>>=
   procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced
 <<Instances: procedures>>=
   subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_qcd
     if (allocated (term%alpha_qcd_forced)) then
        term%alpha_qcd_forced = alpha_qcd
     else
        allocate (term%alpha_qcd_forced, source = alpha_qcd)
     end if
   end subroutine term_instance_set_alpha_qcd_forced
 
 @ %def term_instance_set_alpha_qcd_forced
 @ Complete the kinematics computation for the effective parton states.
 
 We assume that the [[compute_hard_kinematics]] method of the process
 component instance has already been called, so the [[int_hard]]
 contains the correct hard kinematics.  The duty of this procedure is
 first to compute the effective kinematics and store this in the
 [[int_eff]] effective interaction inside the [[isolated]] parton
 state.  The effective kinematics may differ from the kinematics in the hard
 interaction.  It may involve parton recombination or parton splitting.
 The [[rearrange_partons]] method is responsible for this part.
 
 We may also call a method to compute the effective structure-function
 chain at this point.  This is not implemented yet.
 
 In the simple case that no rearrangement is necessary, as indicated by
 the [[rearrange]] flag, the effective interaction is a pointer to the
 hard interaction, and we can skip the rearrangement method.  Similarly
 for the effective structure-function chain.
 
 The final step of kinematics setup is to transfer the effective
 kinematics to the evaluators and to the [[subevt]].
 <<Instances: term instance: TBP>>=
   procedure :: compute_eff_kinematics => &
        term_instance_compute_eff_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_compute_eff_kinematics (term)
     class(term_instance_t), intent(inout) :: term
     term%checked = .false.
     term%passed = .false.
     call term%isolated%receive_kinematics ()
     call term%connected%receive_kinematics ()
   end subroutine term_instance_compute_eff_kinematics
 
 @ %def term_instance_compute_eff_kinematics
 @ Inverse.  Reconstruct the connected state from the momenta in the
 trace evaluator (which we assume to be set), then reconstruct the
 isolated state as far as possible.  The second part finalizes the
 momentum configuration, using the incoming seed momenta
 <<Instances: term instance: TBP>>=
   procedure :: recover_hard_kinematics => &
        term_instance_recover_hard_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_recover_hard_kinematics (term)
     class(term_instance_t), intent(inout) :: term
     term%checked = .false.
     term%passed = .false.
     call term%connected%send_kinematics ()
     call term%isolated%send_kinematics ()
   end subroutine term_instance_recover_hard_kinematics
 
 @ %def term_instance_recover_hard_kinematics
 @ Check the term whether it passes cuts and, if successful, evaluate
 scales and weights.  The factorization scale is also given to the term
 kinematics, enabling structure-function evaluation.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_expressions => &
        term_instance_evaluate_expressions
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_expressions (term, scale_forced)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in), allocatable, optional :: scale_forced
     call term%connected%evaluate_expressions (term%passed, &
          term%scale, term%fac_scale, term%ren_scale, term%weight, &
          scale_forced, force_evaluation = .true.)
     term%checked = .true.
   end subroutine term_instance_evaluate_expressions
 
 @ %def term_instance_evaluate_expressions
 @ Evaluate the trace: first evaluate the hard interaction, then the trace
 evaluator.  We use the [[evaluate_interaction]] method of the process
 component which generated this term.  The [[subevt]] and cut expressions are
 not yet filled.
 
 The [[component]] argument is intent(inout) because the [[compute_amplitude]]
 method may modify the [[core_state]] workspace object.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction => term_instance_evaluate_interaction
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction (term, core, kin)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in), pointer :: core
     type(kinematics_t), intent(inout) :: kin
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction")
     if (kin%only_cm_frame .and. (.not. kin%lab_is_cm())) then
          term%p_hard = kin%get_boost_to_cms () * term%int_hard%get_momenta ()
     else
          term%p_hard = term%int_hard%get_momenta ()
     end if
     select type (core)
     class is (prc_external_t)
        call term%evaluate_interaction_userdef (core, kin)
     class default
        call term%evaluate_interaction_default (core)
     end select
     call term%int_hard%set_matrix_element (term%amp)
   end subroutine term_instance_evaluate_interaction
 
 @ %def term_instance_evaluate_interaction
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_default &
      => term_instance_evaluate_interaction_default
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_default (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in) :: core
     real(default) :: fac_scale, ren_scale    
     integer :: i
     if (allocated (term%fac_scale)) then
        fac_scale = term%fac_scale
     else
        fac_scale = term%scale
     end if
     if (allocated (term%ren_scale)) then
        ren_scale = term%ren_scale
     else
        ren_scale = term%scale
     end if
     do i = 1, term%config%n_allowed
        term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, &
             term%config%flv(i), term%config%hel(i), term%config%col(i), &
             fac_scale, ren_scale, term%alpha_qcd_forced, &
             term%core_state)
     end do
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        call pcm_work%set_fac_scale (fac_scale)
     end select
   end subroutine term_instance_evaluate_interaction_default
 
 @ %def term_instance_evaluate_interaction_default
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_userdef &
      => term_instance_evaluate_interaction_userdef
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_userdef (term, core, kin)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     type(kinematics_t), intent(inout) :: kin
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction_userdef")
     select type (core_state => term%core_state)
     type is (openloops_state_t)
        select type (core)
        type is (prc_openloops_t)
           call core%compute_alpha_s (core_state, term%get_ren_scale ())
           if (allocated (core_state%threshold_data)) &
                call evaluate_threshold_parameters (core_state, core, kin%phs%get_sqrts ())
        end select
     class is (prc_external_state_t)
        select type (core)
        class is (prc_external_t)
           call core%compute_alpha_s (core_state, term%get_ren_scale ())
        end select
     end select
     call evaluate_threshold_interaction ()
     if (term%nlo_type == NLO_VIRTUAL) then
        call term%evaluate_interaction_userdef_loop (core)
     else
        call term%evaluate_interaction_userdef_tree (core)
     end if
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        call pcm_work%set_fac_scale (term%get_fac_scale ())
     end select
 
   contains
     subroutine evaluate_threshold_parameters (core_state, core, sqrts)
        type(openloops_state_t), intent(inout) :: core_state
        type(prc_openloops_t), intent(inout) :: core
        real(default), intent(in) :: sqrts
        real(default) :: mtop, wtop
        mtop = m1s_to_mpole (sqrts)
        wtop = core_state%threshold_data%compute_top_width &
               (mtop, core_state%alpha_qcd)
        call core%set_mass_and_width (6, mtop, wtop)
     end subroutine
 
     subroutine evaluate_threshold_interaction ()
        integer :: leg
        select type (core)
        type is (prc_threshold_t)
           if (term%nlo_type > BORN) then
              select type (pcm_work => term%pcm_work)
              type is (pcm_nlo_workspace_t)
                 if (kin%emitter >= 0) then
                    call core%set_offshell_momenta &
                         (pcm_work%real_kinematics%p_real_cms%get_momenta(term%config%i_term))
                    leg = thr_leg (kin%emitter)
                    call core%set_leg (leg)
                    call core%set_onshell_momenta &
                         (pcm_work%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term))
                 else
                    call core%set_leg (0)
                    call core%set_offshell_momenta &
                         (pcm_work%real_kinematics%p_born_cms%get_momenta(1))
                 end if
              end select
           else
              call core%set_leg (-1)
              call core%set_offshell_momenta (term%p_hard)
           end if
        end select
     end subroutine evaluate_threshold_interaction
   end subroutine term_instance_evaluate_interaction_userdef
 
 @ %def term_instance_evaluate_interaction_userdef
 @ Retrieve the matrix elements from a matrix element provider and place them
 into [[term%amp]].
 
 For the handling of NLO calculations, FKS applies a book keeping handling
 flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in
 order to calculate the subtraction terms. Therefore, we have to insert the
 calculated matrix elements correctly into the state matrix where each entry
 corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of
 quantum numbers provided by FKS to the hard process [[int_hard]].
 
 The calculated matrix elements are insert into [[term%amp]] in the following
 way. The first [[n_born]] particles are the matrix element of the hard process.
 In non-trivial beams, we store another [[n_beams_rescaled]] copies of these
 matrix elements as the first [[n_beams_rescaled]] subtractions. This is a remnant
 from times before the method [[term_instance_set_sf_factors]] and these entries are
 not used anymore. However, eliminating these entries involves deeper changes in how
 the connection tables for the evaluator product are set up and should therefore be
 part of a larger refactoring of the interactions \& state matrices.
 The next $n_{\text{born}}\times n_{sub_color}$ are color-correlated Born matrix elements,
 with then again the next $n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being
 spin-correlated Born matrix elements.
 
 If two or more flavor structures would produce the same amplitude we only compute
 one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result
 to improve performance.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_userdef_tree &
      => term_instance_evaluate_interaction_userdef_tree
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_userdef_tree (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     real(default) :: sqme
     real(default), dimension(:), allocatable :: sqme_color_c
     real(default), dimension(:), allocatable :: sqme_spin_c
     real(default), dimension(6) :: sqme_spin_c_tmp
     integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off
     integer :: i_flv, i_hel, i_sub, i_color_c, i_color_c_eqv, i_spin_c, i_spin_c_eqv
     integer :: i_flv_eqv, i_hel_eqv
     integer :: emitter, i_emitter
     logical :: bad_point, bp
     logical, dimension(:,:), allocatable :: eqv_me_evaluated
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction_userdef_tree")
     allocate (sqme_color_c (blha_result_array_size &
          (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
     n_flv = term%int_hard%get_qn_index_n_flv ()
     n_hel = term%int_hard%get_qn_index_n_hel ()
     n_sub_color = term%get_n_sub_color ()
     n_sub_spin = term%get_n_sub_spin ()
     allocate (eqv_me_evaluated(n_flv,n_hel))
     eqv_me_evaluated = .false.
     do i_flv = 1, n_flv
        do i_hel = 1, n_hel
           i_flv_eqv = core%data%eqv_flv_index(i_flv)
           i_hel_eqv = core%data%eqv_hel_index(i_hel)
           if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
              select type (core)
              class is (prc_external_t)
                 call core%update_alpha_s (term%core_state, term%get_ren_scale ())
                 call core%compute_sqme (i_flv, i_hel, term%p_hard, &
                      term%get_ren_scale (), sqme, bad_point)
                 call term%pcm_work%set_bad_point (bad_point)
                 associate (i_int => term%int_hard%get_qn_index &
                      (i_flv = i_flv, i_hel = i_hel, i_sub = 0))
                   term%amp(i_int) = cmplx (sqme, 0, default)
                 end associate
              end select
              n_pdf_off = 0
              if (term%pcm%has_pdfs .and. &
                   (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
                 n_pdf_off = n_pdf_off + n_beams_rescaled
                 do i_sub = 1, n_pdf_off
                    term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
                         term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
                 end do
              end if
              if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then
                 sqme_color_c = zero
                 select type (pcm => term%pcm)
                 type is (pcm_nlo_t)
                    if (pcm%settings%nlo_correction_type == "EW" .and. &
                       pcm%region_data%alphas_power > 0) then
                       select type (core)
                       class is (prc_blha_t)
                          call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                               term%p_hard, term%get_ren_scale (), sqme_color_c, &
                               bad_point)
                          call term%pcm_work%set_bad_point (bad_point)
                       class is (prc_recola_t)
                          call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                               term%p_hard, term%get_ren_scale (), sqme_color_c, &
                               bad_point)
                          call term%pcm_work%set_bad_point (bad_point)
                       end select
                    end if
                 end select
                 do i_sub = 1, n_sub_color
                    i_color_c = term%int_hard%get_qn_index &
                         (i_flv, i_hel, i_sub + n_pdf_off)
                    term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
                 end do
              end if
              if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
                   term%nlo_type == NLO_MISMATCH) then
                 sqme_color_c = zero
                 select type (core)
                 class is (prc_blha_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
                    call term%pcm_work%set_bad_point (bad_point)
                 class is (prc_recola_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
                    call term%pcm_work%set_bad_point (bad_point)
                 end select
                 do i_sub = 1, n_sub_color
                    i_color_c = term%int_hard%get_qn_index &
                         (i_flv, i_hel, i_sub + n_pdf_off)
                    term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
                 end do
                 if (n_sub_spin > 0) then
                    bad_point = .false.
                    allocate (sqme_spin_c(0))
                    select type (core)
                    type is (prc_openloops_t)
                       select type (pcm => term%pcm)
                       type is (pcm_nlo_t)
                          do i_emitter = 1, pcm%region_data%n_emitters
                             emitter = pcm%region_data%emitters(i_emitter)
                             if (emitter > 0) then
                                call core%compute_sqme_spin_c &
                                     (i_flv, &
                                     i_hel, &
                                     emitter, &
                                     term%p_hard, &
                                     term%get_ren_scale (), &
                                     sqme_spin_c_tmp, &
                                     bp)
                                sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp]
                                bad_point = bad_point .or. bp
                             end if
                          end do
                       end select
                       do i_sub = 1, n_sub_spin
                          i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
                               i_sub + n_pdf_off + n_sub_color)
                          term%amp(i_spin_c) = cmplx &
                               (sqme_spin_c(i_sub), 0, default)
                       end do
                    end select
                    deallocate (sqme_spin_c)
                 end if
              end if
              eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
           else
              associate (i_int => term%int_hard%get_qn_index &
                      (i_flv = i_flv, i_hel = i_hel, i_sub = 0), &
                      i_int_eqv => term%int_hard%get_qn_index &
                      (i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0))
                 term%amp(i_int) = term%amp(i_int_eqv)
              end associate
              n_pdf_off = 0
              if (term%pcm%has_pdfs .and. &
                   (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
                 n_pdf_off = n_pdf_off + n_beams_rescaled
                 do i_sub = 1, n_pdf_off
                    term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
                         term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
                 end do
              end if
              if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then
                 do i_sub = 1, n_sub_color
                    i_color_c = term%int_hard%get_qn_index &
                         (i_flv, i_hel, i_sub + n_pdf_off)
                    i_color_c_eqv = term%int_hard%get_qn_index &
                         (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
                    term%amp(i_color_c) = term%amp(i_color_c_eqv)
                 end do
              end if
              if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
                   term%nlo_type == NLO_MISMATCH) then
                 do i_sub = 1, n_sub_color
                    i_color_c = term%int_hard%get_qn_index &
                         (i_flv, i_hel, i_sub + n_pdf_off)
                    i_color_c_eqv = term%int_hard%get_qn_index &
                         (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
                    term%amp(i_color_c) = term%amp(i_color_c_eqv)
                 end do
                 do i_sub = 1, n_sub_spin
                    i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
                         i_sub + n_pdf_off + n_sub_color)
                    i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, &
                         i_sub + n_pdf_off + n_sub_color)
                    term%amp(i_spin_c) = term%amp(i_spin_c_eqv)
                 end do
              end if
           end if
        end do
     end do
   end subroutine term_instance_evaluate_interaction_userdef_tree
 
 @ %def term_instance_evaluate_interaction_userdef_tree
 @ Same as for [[term_instance_evaluate_interaction_userdef_tree]], but
 for the integrated-subtraction and finite one-loop terms. We only need
 color-correlated Born matrix elements, but an additional entry per
 flavor structure for the finite one-loop contribution. We thus have
 $2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and
 [[i_hel]] combination.
 
 If two or more flavor structures would produce the same amplitude we only compute
 one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result
 to improve performance.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_userdef_loop &
      => term_instance_evaluate_interaction_userdef_loop
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_userdef_loop (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in) :: core
     integer :: n_hel, n_sub, n_flv
     integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c, i_color_c_eqv
     integer :: i_flv_eqv, i_hel_eqv
     real(default), dimension(4) :: sqme_virt
     real(default), dimension(:), allocatable :: sqme_color_c
     real(default) :: es_scale
     logical :: bad_point
     logical, dimension(:,:), allocatable :: eqv_me_evaluated
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction_userdef_loop")
     allocate (sqme_color_c (blha_result_array_size &
          (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
     n_flv = term%int_hard%get_qn_index_n_flv ()
     n_hel = term%int_hard%get_qn_index_n_hel ()
     n_sub = term%int_hard%get_qn_index_n_sub ()
     allocate (eqv_me_evaluated(n_flv,n_hel))
     eqv_me_evaluated = .false.
     i_virt = 1
     do i_flv = 1, n_flv
        do i_hel = 1, n_hel
           i_flv_eqv = core%data%eqv_flv_index(i_flv)
           i_hel_eqv = core%data%eqv_hel_index(i_hel)
           if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
              select type (core)
              class is (prc_external_t)
                 if (allocated (term%es_scale)) then
                    es_scale = term%es_scale
                 else
                    es_scale = term%get_ren_scale ()
                 end if
                 call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
                      term%get_ren_scale (), es_scale, &
                      term%pcm%blha_defaults%loop_method, &
                      sqme_virt, bad_point)
                 call term%pcm_work%set_bad_point (bad_point)
              end select
              associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
                   i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt))
                term%amp(i_loop) = cmplx (sqme_virt(3), 0, default)
                term%amp(i_born) = cmplx (sqme_virt(4), 0, default)
              end associate
              select type (pcm => term%pcm)
              type is (pcm_nlo_t)
                 select type (core)
                 class is (prc_blha_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%get_ren_scale (), &
                         sqme_color_c, bad_point)
                    call term%pcm_work%set_bad_point (bad_point)
                    do i_sub = 1 + i_virt, n_sub
                       i_color_c = term%int_hard%get_qn_index &
                            (i_flv, i_hel = i_hel, i_sub = i_sub)
                       ! Index shift: i_sub - i_virt
                       term%amp(i_color_c) = &
                            cmplx (sqme_color_c(i_sub - i_virt), 0, default)
                    end do
                 type is (prc_recola_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
                    call term%pcm_work%set_bad_point (bad_point)
                    do i_sub = 1 + i_virt, n_sub
                       i_color_c = term%int_hard%get_qn_index &
                            (i_flv, i_hel = i_hel, i_sub = i_sub)
                       ! Index shift: i_sub - i_virt
                       term%amp(i_color_c) = &
                            cmplx (sqme_color_c(i_sub - i_virt), 0, default)
                    end do
                 end select
              end select
              eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
           else
              associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
                   i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), &
                   i_born_eqv => term%int_hard%get_qn_index &
                   (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), &
                   i_loop_eqv => term%int_hard%get_qn_index &
                   (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1))
                term%amp(i_loop) = term%amp(i_loop_eqv)
                term%amp(i_born) = term%amp(i_born_eqv)
              end associate
              do i_sub = 1 + i_virt, n_sub
                 i_color_c = term%int_hard%get_qn_index &
                      (i_flv, i_hel = i_hel, i_sub = i_sub)
                 i_color_c_eqv = term%int_hard%get_qn_index &
                      (i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub)
                 ! Index shift: i_sub - i_virt
                 term%amp(i_color_c) = term%amp(i_color_c_eqv)
              end do
           end if
        end do
     end do
    end subroutine term_instance_evaluate_interaction_userdef_loop
 
 @ %def term_instance_evaluate_interaction_userdef_loop
 @ Evaluate the trace.  First evaluate the
 structure-function chain (i.e., the density matrix of the incoming
 partons).  Do this twice, in case the sf-chain instances within
 [[kin]] and [[isolated]] differ.  Next, evaluate the hard
 interaction, then compute the convolution with the initial state.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_trace => term_instance_evaluate_trace
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_trace (term, kin)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(inout) :: kin
     real(default) :: fac_scale
     if (allocated (term%fac_scale)) then
        fac_scale = term%fac_scale
     else
        fac_scale = term%scale
     end if
     call kin%evaluate_sf_chain (fac_scale, term%negative_sf)
     call term%evaluate_scaled_sf_chains (kin)
     call term%isolated%evaluate_sf_chain (fac_scale)
     call term%isolated%evaluate_trace ()
     call term%connected%evaluate_trace ()
   end subroutine term_instance_evaluate_trace
 
 @ %def term_instance_evaluate_trace
 @ Include rescaled structure functions due to NLO calculation.
 We rescale the structure function for the real subtraction [[sf_rescale_collinear]],
 the collinear counter terms [[sf_rescale_dglap_t]] and for the case, in which we have
 an emitter in the initial state, we rescale the kinematics for it using [[sf_rescale_real_t]].\\
 References: arXiv:0709.2092, (2.35)-(2.42).\\
 Obviously, it is completely irrelevant, which beam is treated.
 It becomes problematic when handling [[e, p]]-beams.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_scaled_sf_chains (term, kin)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(inout) :: kin
     class(sf_rescale_t), allocatable :: sf_rescale
     if (.not. term%pcm%has_pdfs) return
     if (term%nlo_type == NLO_REAL) then
        if (term%is_subtraction ()) then
           allocate (sf_rescale_collinear_t :: sf_rescale)
           select type (pcm_work => term%pcm_work)
           type is (pcm_nlo_workspace_t)
              select type (sf_rescale)
              type is (sf_rescale_collinear_t)
                 call sf_rescale%set (pcm_work%real_kinematics%xi_tilde)
              end select
           end select
           call kin%sf_chain%evaluate (term%get_fac_scale (), &
                term%negative_sf, sf_rescale)
           deallocate (sf_rescale)
        else if (kin%emitter >= 0 .and. kin%emitter <= kin%n_in) then
           allocate (sf_rescale_real_t :: sf_rescale)
           select type (pcm_work => term%pcm_work)
           type is (pcm_nlo_workspace_t)
              select type (sf_rescale)
              type is (sf_rescale_real_t)
                 call sf_rescale%set (pcm_work%real_kinematics%xi_tilde * &
                      pcm_work%real_kinematics%xi_max (kin%i_phs), &
                      pcm_work%real_kinematics%y (kin%i_phs))
              end select
           end select
           call kin%sf_chain%evaluate (term%get_fac_scale (), &
                term%negative_sf, sf_rescale)
           deallocate (sf_rescale)
        else
           call kin%sf_chain%evaluate (term%get_fac_scale (), term%negative_sf)
        end if
     else if (term%nlo_type == NLO_DGLAP) then
        allocate (sf_rescale_dglap_t :: sf_rescale)
        select type (pcm_work => term%pcm_work)
        type is (pcm_nlo_workspace_t)
           select type (sf_rescale)
           type is (sf_rescale_dglap_t)
              call sf_rescale%set (pcm_work%isr_kinematics%z)
           end select
        end select
        call kin%sf_chain%evaluate (term%get_fac_scale (), &
             term%negative_sf, sf_rescale)
        deallocate (sf_rescale)
     end if
   end subroutine term_instance_evaluate_scaled_sf_chains
 
 @ %def term_instance_evaluate_scaled_sf_chains
 @ Evaluate the extra data that we need for processing the object as a
 physical event.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_event_data => term_instance_evaluate_event_data
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_event_data (term)
     class(term_instance_t), intent(inout) :: term
     logical :: only_momenta
     only_momenta = term%nlo_type > BORN
     call term%isolated%evaluate_event_data (only_momenta)
     call term%connected%evaluate_event_data (only_momenta)
   end subroutine term_instance_evaluate_event_data
 
 @ %def term_instance_evaluate_event_data
 @
 <<Instances: term instance: TBP>>=
   procedure :: set_fac_scale => term_instance_set_fac_scale
 <<Instances: procedures>>=
   subroutine term_instance_set_fac_scale (term, fac_scale)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: fac_scale
     term%fac_scale = fac_scale
   end subroutine term_instance_set_fac_scale
 
 @ %def term_instance_set_fac_scale
 @ Return data that might be useful for external processing.  The
 factorization scale and renormalization scale are identical to the 
 general scale if not explicitly set:
 <<Instances: term instance: TBP>>=
   procedure :: get_fac_scale => term_instance_get_fac_scale
   procedure :: get_ren_scale => term_instance_get_ren_scale
 <<Instances: procedures>>=
   function term_instance_get_fac_scale (term) result (fac_scale)
     class(term_instance_t), intent(in) :: term
     real(default) :: fac_scale
     if (allocated (term%fac_scale)) then
        fac_scale = term%fac_scale
     else
        fac_scale = term%scale
     end if
   end function term_instance_get_fac_scale
 
   function term_instance_get_ren_scale (term) result (ren_scale)
     class(term_instance_t), intent(in) :: term
     real(default) :: ren_scale
     if (allocated (term%ren_scale)) then
        ren_scale = term%ren_scale
     else
        ren_scale = term%scale
     end if
   end function term_instance_get_ren_scale
 
 @ %def term_instance_get_fac_scale term_instance_get_ren_scale
 @ We take the strong coupling from the process core.  The value is calculated
 when a new event is requested, so we should call it only after the event has
 been evaluated.  If it is not available there (a negative number is returned),
 we take the value stored in the term configuration, which should be determined
 by the model.  If the model does not provide a value, the result is zero.
 <<Instances: term instance: TBP>>=
   procedure :: get_alpha_s => term_instance_get_alpha_s
 <<Instances: procedures>>=
   function term_instance_get_alpha_s (term, core) result (alpha_s)
     class(term_instance_t), intent(in) :: term
     class(prc_core_t), intent(in) :: core
     real(default) :: alpha_s
     alpha_s = core%get_alpha_s (term%core_state)
     if (alpha_s < zero)  alpha_s = term%config%alpha_s
   end function term_instance_get_alpha_s
 
 @ %def term_instance_get_alpha_s
 @ The second helicity for [[helicities]] comes with a minus sign
 because OpenLoops inverts the helicity index of antiparticles.
 <<Instances: term instance: TBP>>=
   procedure :: get_helicities_for_openloops => term_instance_get_helicities_for_openloops
 <<Instances: procedures>>=
   subroutine term_instance_get_helicities_for_openloops (term, helicities)
     class(term_instance_t), intent(in) :: term
     integer, dimension(:,:), allocatable, intent(out) :: helicities
     type(helicity_t), dimension(:), allocatable :: hel
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     type(quantum_numbers_mask_t) :: qn_mask
     integer :: h, i, j, n_in
     call qn_mask%set_sub (1)
     call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn)
     n_in = term%int_hard%get_n_in ()
     allocate (helicities (size (qn, dim=1), n_in))
     allocate (hel (n_in))
     do i = 1, size (qn, dim=1)
        do j = 1, n_in
           hel(j) = qn(i, j)%get_helicity ()
           call hel(j)%diagonalize ()
           call hel(j)%get_indices (h, h)
           helicities (i, j) = h
        end do
     end do
   end subroutine term_instance_get_helicities_for_openloops
 
 @ %def term_instance_get_helicities_for_openloops
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_i_term_global => term_instance_get_i_term_global
 <<Instances: procedures>>=
   elemental function term_instance_get_i_term_global (term) result (i_term)
     integer :: i_term
     class(term_instance_t), intent(in) :: term
     i_term = term%config%i_term_global
   end function term_instance_get_i_term_global
 
 @ %def term_instance_get_i_term_global
 @
 <<Instances: term instance: TBP>>=
   procedure :: is_subtraction => term_instance_is_subtraction
 <<Instances: procedures>>=
   elemental function term_instance_is_subtraction (term) result (sub)
     logical :: sub
     class(term_instance_t), intent(in) :: term
     sub = term%config%i_term_global == term%config%i_sub
   end function term_instance_is_subtraction
 
 @ %def term_instance_is_subtraction
 @ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]].
 <<Instances: term instance: TBP>>=
   procedure :: get_n_sub => term_instance_get_n_sub
   procedure :: get_n_sub_color => term_instance_get_n_sub_color
   procedure :: get_n_sub_spin => term_instance_get_n_sub_spin
 <<Instances: procedures>>=
   function term_instance_get_n_sub (term) result (n_sub)
     integer :: n_sub
     class(term_instance_t), intent(in) :: term
     n_sub = term%config%n_sub
   end function term_instance_get_n_sub
 
   function term_instance_get_n_sub_color (term) result (n_sub_color)
     integer :: n_sub_color
     class(term_instance_t), intent(in) :: term
     n_sub_color = term%config%n_sub_color
   end function term_instance_get_n_sub_color
 
   function term_instance_get_n_sub_spin (term) result (n_sub_spin)
     integer :: n_sub_spin
     class(term_instance_t), intent(in) :: term
     n_sub_spin = term%config%n_sub_spin
   end function term_instance_get_n_sub_spin
 
 @ %def term_instance_get_n_sub
 @ %def term_instance_get_n_sub_color
 @ %def term_instance_get_n_sub_spin
 @
 \subsection{The process instance}
 NOTE: The description below represents the intended structure after
 refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies.
 
 A process instance contains all process data that depend on the
 sampling point and thus change often.  In essence, it is an event
 record at the elementary (parton) level.  We do not call it such, to
 avoid confusion with the actual event records.  If decays are
 involved, the latter are compositions of several elementary processes
 (i.e., their instances).
 
 We implement the process instance as an extension of the
 [[mci_sampler_t]] that we need for computing integrals and generate
 events.
 
 The base type contains: the [[integrand]], the [[selected_channel]],
 the two-dimensional array [[x]] of parameters, and the one-dimensional
 array [[f]] of Jacobians.  These subobjects are public and used for
 communicating with the multi-channel integrator.
 
 The [[process]] pointer accesses the process of which this record is
 an instance.  It is required whenever the calculation needs invariant
 configuration data, therefore the process should stay in memory for
 the whole lifetime of its instances.
 
 The [[pcm]] pointer is a shortcut to the [[pcm]] (process-component
 manager) component of the associated process, which we need wherever
 the calculation depends on the overall algorithm.
 
 The [[pcm_work]] component is the workspace for the [[pcm]] object
 referenced above.
 
 The [[evaluation_status]] code is used to check the current status.
 In particular, failure at various stages is recorded there.
 
 The [[count]] object records process evaluations, broken down
 according to status.
 
 The [[sqme]] value is the single real number that results from
 evaluating and tracing the kinematics and matrix elements.  This
 is the number that is handed over to an integration routine.
 
 The [[weight]] value is the event weight.  It is defined when an event
 has been generated from the process instance, either weighted or
 unweighted.  The value is the [[sqme]] value times Jacobian weights
 from the integration, or unity, respectively.
 
 The [[i_mci]] index chooses a subset of components that are associated with
 a common parameter set and integrator, i.e., that are added coherently.
 
 The [[sf_chain]] subobject is a realization of the beam and
 structure-function configuration in the [[process]] object.  It is not
 used for calculation directly but serves as the template for the
 sf-chain instances that are contained in the [[component]] objects.
 
 The [[kinematics]] array contains the set of phase-space points that
 are associated with the current calculation.  The entries may correspond
 to different process components and terms.  (TODO wk 19-02-22: Not implemented yet.)
 
 TODO wk 19-02-22: May include extra arrays for storing (squared) amplitude
 data.  The [[term]] data set may be reduced to just results, or
 be removed altogether.
 
 The [[term]] subobjects are workspace for evaluating kinematics,
 matrix elements, cuts etc.  The array entries correspond to the [[term]]
 configuration entries in the associated process object.
 
 The [[mci_work]] subobject contains the array of real input parameters (random
 numbers) that generates the kinematical point.  It also contains the workspace
 for the MC integrators.  The active entry of the [[mci_work]] array is
 selected by the [[i_mci]] index above.
 
 The [[hook]] pointer accesses a list of after evaluate objects which are
 evalutated after the matrix element.
 <<Instances: public>>=
   public :: process_instance_t
 <<Instances: types>>=
   type, extends (mci_sampler_t) :: process_instance_t
      type(process_t), pointer :: process => null ()
      class(pcm_t), pointer :: pcm => null ()
      class(pcm_workspace_t), allocatable :: pcm_work
      integer :: evaluation_status = STAT_UNDEFINED
      real(default) :: sqme = 0
      real(default) :: weight = 0
      real(default) :: excess = 0
      integer :: n_dropped = 0
      integer :: i_mci = 0
      integer :: selected_channel = 0
      type(sf_chain_t) :: sf_chain
      type(kinematics_t), dimension(:), allocatable :: kin
      type(term_instance_t), dimension(:), allocatable :: term
      type(mci_work_t), dimension(:), allocatable :: mci_work
      class(process_instance_hook_t), pointer :: hook => null ()
    contains
    <<Instances: process instance: TBP>>
   end type process_instance_t
 
 @ %def process_instance
 @
 Wrapper type for storing pointers to process instance objects in arrays.
 <<Instances: public>>=
   public :: process_instance_ptr_t
 <<Instances: types>>=
   type :: process_instance_ptr_t
      type(process_instance_t), pointer :: p => null ()
   end type process_instance_ptr_t
 
 @ %def process_instance_ptr_t
 @ The process hooks are first-in-last-out list of objects which are evaluated
 after the phase space and matrixelement are evaluated. It is possible to
 retrieve the sampler object and read the sampler information.
 
 The hook object are part of the [[process_instance]] and therefore, share a
 common lifetime. A data transfer, after the usual lifetime of the
 [[process_instance]], is not provided, as such the finalisation procedure has to take care
 of this! E.g. write the object to file from which later the collected
 information can then be retrieved.
 <<Instances: public>>=
   public :: process_instance_hook_t
 <<Instances: types>>=
   type, abstract :: process_instance_hook_t
      class(process_instance_hook_t), pointer :: next => null ()
    contains
      procedure(process_instance_hook_init), deferred :: init
      procedure(process_instance_hook_final), deferred :: final
      procedure(process_instance_hook_evaluate), deferred :: evaluate
   end type process_instance_hook_t
 
 @ %def process_instance_hook_t
 @ We have to provide a [[init]], a [[final]] procedure and, for after evaluation, the
 [[evaluate]] procedure.
 
 The [[init]] procedures accesses [[var_list]] and current [[instance]] object.
 <<Instances: public>>=
   public :: process_instance_hook_final, process_instance_hook_evaluate
 <<Instances: interfaces>>=
   abstract interface
      subroutine process_instance_hook_init (hook, var_list, instance)
        import :: process_instance_hook_t, var_list_t, process_instance_t
        class(process_instance_hook_t), intent(inout), target :: hook
        type(var_list_t), intent(in) :: var_list
        class(process_instance_t), intent(in), target :: instance
      end subroutine process_instance_hook_init
 
      subroutine process_instance_hook_final (hook)
        import :: process_instance_hook_t
        class(process_instance_hook_t), intent(inout) :: hook
      end subroutine process_instance_hook_final
 
      subroutine process_instance_hook_evaluate (hook, instance)
        import :: process_instance_hook_t, process_instance_t
        class(process_instance_hook_t), intent(inout) :: hook
        class(process_instance_t), intent(in), target :: instance
      end subroutine process_instance_hook_evaluate
   end interface
 
 @ %def process_instance_hook_final, process_instance_hook_evaluate
 @ The output routine contains a header with the most relevant
 information about the process, copied from
 [[process_metadata_write]].  We mark the active components by an asterisk.
 
 The next section is the MC parameter input.  The following sections
 are written only if the evaluation status is beyond setting the
 parameters, or if the [[verbose]] option is set.
 <<Instances: process instance: TBP>>=
   procedure :: write_header => process_instance_write_header
   procedure :: write => process_instance_write
 <<Instances: procedures>>=
   subroutine process_instance_write_header (object, unit, testflag)
     class(process_instance_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     if (associated (object%process)) then
        call object%process%write_meta (u, testflag)
     else
        write (u, "(1x,A)") "Process instance [undefined process]"
        return
     end if
     write (u, "(3x,A)", advance = "no")  "status = "
     select case (object%evaluation_status)
     case (STAT_INITIAL);            write (u, "(A)")  "initialized"
     case (STAT_ACTIVATED);          write (u, "(A)")  "activated"
     case (STAT_BEAM_MOMENTA);       write (u, "(A)")  "beam momenta set"
     case (STAT_FAILED_KINEMATICS);  write (u, "(A)")  "failed kinematics"
     case (STAT_SEED_KINEMATICS);    write (u, "(A)")  "seed kinematics"
     case (STAT_HARD_KINEMATICS);    write (u, "(A)")  "hard kinematics"
     case (STAT_EFF_KINEMATICS);     write (u, "(A)")  "effective kinematics"
     case (STAT_FAILED_CUTS);        write (u, "(A)")  "failed cuts"
     case (STAT_PASSED_CUTS);        write (u, "(A)")  "passed cuts"
     case (STAT_EVALUATED_TRACE);    write (u, "(A)")  "evaluated trace"
        call write_separator (u)
        write (u, "(3x,A,ES19.12)")  "sqme   = ", object%sqme
     case (STAT_EVENT_COMPLETE);   write (u, "(A)")  "event complete"
        call write_separator (u)
        write (u, "(3x,A,ES19.12)")  "sqme   = ", object%sqme
        write (u, "(3x,A,ES19.12)")  "weight = ", object%weight
        if (.not. vanishes (object%excess)) &
             write (u, "(3x,A,ES19.12)")  "excess = ", object%excess
     case default;                 write (u, "(A)")  "undefined"
     end select
     if (object%i_mci /= 0) then
        call write_separator (u)
        call object%mci_work(object%i_mci)%write (u, testflag)
     end if
     call write_separator (u, 2)
   end subroutine process_instance_write_header
 
   subroutine process_instance_write (object, unit, testflag)
     class(process_instance_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u, i
     u = given_output_unit (unit)
     call object%write_header (u)
     if (object%evaluation_status >= STAT_BEAM_MOMENTA) then
        call object%sf_chain%write (u)
        call write_separator (u, 2)
        if (object%evaluation_status >= STAT_SEED_KINEMATICS) then
           if (object%evaluation_status >= STAT_HARD_KINEMATICS) then
              call write_separator (u, 2)
              write (u, "(1x,A)") "Active terms:"
              if (any (object%term%active)) then
                 do i = 1, size (object%term)
                    if (object%term(i)%active) then
                       call write_separator (u)
                       call object%term(i)%write (u, &
                            kin = object%kin(i), &
                            show_eff_state = &
                            object%evaluation_status >= STAT_EFF_KINEMATICS, &
                            testflag = testflag)
                    end if
                 end do
              end if
           end if
           call write_separator (u, 2)
        end if
     end if
   end subroutine process_instance_write
 
 @ %def process_instance_write_header
 @ %def process_instance_write
 @ Initialization connects the instance with a process.  All initial
 information is transferred from the process object.  The process
 object contains templates for the interaction subobjects (beam and
 term), but no evaluators.  The initialization routine
 creates evaluators for the matrix element trace, other evaluators
 are left untouched.
 
 Before we start generating, we double-check if the process library
 has been updated after the process was initializated
 ([[check_library_sanity]]).  This may happen if between integration
 and event generation the library has been recompiled, so all links
 become broken.
 
 The [[instance]] object must have the [[target]] attribute (also in
 any caller) since the initialization routine assigns various pointers
 to subobject of [[instance]].
 <<Instances: process instance: TBP>>=
   procedure :: init => process_instance_init
 <<Instances: procedures>>=
   subroutine process_instance_init (instance, process)
     class(process_instance_t), intent(out), target :: instance
     type(process_t), intent(inout), target :: process
     integer :: i
     class(pcm_t), pointer :: pcm
     type(process_term_t), pointer :: term
     type(var_list_t), pointer :: var_list
     integer :: i_born, i_real, i_real_fin, i_component
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init")
     instance%process => process
     instance%pcm => process%get_pcm_ptr ()
     call instance%process%check_library_sanity ()
     call instance%setup_sf_chain (process%get_beam_config_ptr ())
     allocate (instance%mci_work (process%get_n_mci ()))
     do i = 1, size (instance%mci_work)
        call instance%process%init_mci_work (instance%mci_work(i), i)
     end do
     call instance%process%reset_selected_cores ()
     pcm => instance%process%get_pcm_ptr ()
     call pcm%allocate_workspace (instance%pcm_work)
     select type (pcm)
     type is (pcm_nlo_t)
        !!! The process is kept when the integration is finalized, but not the
        !!! process_instance. Thus, we check whether pcm has been initialized
        !!! but set up the pcm_work each time.
        i_real_fin = process%get_associated_real_fin (1)
        if (.not. pcm%initialized) then
           i_born = pcm%get_i_core (pcm%i_born)
           i_real = pcm%get_i_core (pcm%i_real)
           call pcm%init_qn (process%get_model_ptr ())
           if (i_real_fin > 0) call pcm%allocate_ps_matching ()
           var_list => process%get_var_list_ptr ()
           if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) &
                call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot")))
        end if
        pcm%initialized = .true.
        select type (pcm_work => instance%pcm_work)
        type is (pcm_nlo_workspace_t)
           call pcm_work%init_config (pcm, &
                process%component_can_be_integrated (), &
                process%get_nlo_type_component (), process%get_energy (), &
                i_real_fin, process%get_model_ptr ())
        end select
     end select
     ! TODO wk-03-01 n_terms will eventually acquire a different meaning 
     allocate (instance%kin (process%get_n_terms ()))
     do i = 1, process%get_n_terms ()
        term => process%get_term_ptr (i)
        i_component = term%i_component
        call instance%kin(i)%configure (pcm, instance%pcm_work, &
             instance%sf_chain, &
             process%get_beam_config_ptr (), &
             process%get_phs_config (i_component), &
             process%get_nlo_type_component (i_component), &
             term%i_sub == i)
     end do
     ! TODO wk-03-01 n_terms will eventually acquire a different meaning 
     allocate (instance%term (process%get_n_terms ()))
     do i = 1, process%get_n_terms ()
        call instance%term(i)%configure (process, i, instance%pcm_work, &
             instance%sf_chain, instance%kin(i))
     end do
     call instance%set_i_mci_to_real_component ()
     call instance%find_same_kinematics ()
     instance%evaluation_status = STAT_INITIAL
   end subroutine process_instance_init
 
 @ %def process_instance_init
 @
 @ Finalize all subobjects that may contain allocated pointers.
 <<Instances: process instance: TBP>>=
   procedure :: final => process_instance_final
 <<Instances: procedures>>=
   subroutine process_instance_final (instance)
     class(process_instance_t), intent(inout) :: instance
     class(process_instance_hook_t), pointer :: current
     integer :: i
     instance%process => null ()
     if (allocated (instance%mci_work)) then
        do i = 1, size (instance%mci_work)
           call instance%mci_work(i)%final ()
        end do
        deallocate (instance%mci_work)
     end if
     call instance%sf_chain%final ()
     if (allocated (instance%kin)) then
        do i = 1, size (instance%kin)
           call instance%kin(i)%final ()
        end do
        deallocate (instance%kin)
     end if
     if (allocated (instance%term)) then
        do i = 1, size (instance%term)
           call instance%term(i)%final ()
        end do
        deallocate (instance%term)
     end if
     call instance%pcm_work%final ()
     instance%evaluation_status = STAT_UNDEFINED
     do while (associated (instance%hook))
        current => instance%hook
        call current%final ()
        instance%hook => current%next
        deallocate (current)
     end do
     instance%hook => null ()
   end subroutine process_instance_final
 
 @ %def process_instance_final
 @ Revert the process instance to initial state.  We do not deallocate
 anything, just reset the state index and deactivate all components and
 terms.
 
 We do not reset the choice of the MCI set [[i_mci]] unless this is
 required explicitly.
 <<Instances: process instance: TBP>>=
   procedure :: reset => process_instance_reset
 <<Instances: procedures>>=
   subroutine process_instance_reset (instance, reset_mci)
     class(process_instance_t), intent(inout), target :: instance
     logical, intent(in), optional :: reset_mci
     integer :: i
     call instance%process%reset_selected_cores ()
     do i = 1, size (instance%term)
        call instance%term(i)%reset ()
     end do
     instance%term%checked = .false.
     instance%term%passed = .false.
     instance%kin%new_seed = .true.
     if (present (reset_mci)) then
        if (reset_mci)  instance%i_mci = 0
     end if
     instance%selected_channel = 0
     instance%evaluation_status = STAT_INITIAL
   end subroutine process_instance_reset
 
 @ %def process_instance_reset
 @
 \subsubsection{Integration and event generation}
 The sampler test should just evaluate the squared matrix element [[n_calls]]
 times, discarding the results, and return.  This can be done before
 integration, e.g., for timing estimates.
 <<Instances: process instance: TBP>>=
   procedure :: sampler_test => process_instance_sampler_test
 <<Instances: procedures>>=
   subroutine process_instance_sampler_test (instance, i_mci, n_calls)
     class(process_instance_t), intent(inout), target :: instance
     integer, intent(in) :: i_mci
     integer, intent(in) :: n_calls
     integer :: i_mci_work
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     call instance%reset_counter ()
     call instance%process%sampler_test (instance, n_calls, i_mci_work)
     call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
   end subroutine process_instance_sampler_test
 
 @ %def process_instance_sampler_test
 @ Generate a weighted event.  We select one of the available MCI
 integrators by its index [[i_mci]] and thus generate an event for the
 associated (group of) process component(s).  The arguments exactly
 correspond to the initializer and finalizer above.
 
 The resulting event is stored in the [[process_instance]] object,
 which also holds the workspace of the integrator.
 
 Note: The [[process]] object contains the random-number state, which
 changes for each event.
 Otherwise, all volatile data are inside the [[instance]] object.
 <<Instances: process instance: TBP>>=
   procedure :: generate_weighted_event => process_instance_generate_weighted_event
 <<Instances: procedures>>=
   subroutine process_instance_generate_weighted_event (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     integer :: i_mci_work
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     associate (mci_work => instance%mci_work(i_mci_work))
        call instance%process%generate_weighted_event &
           (i_mci_work, mci_work, instance, &
            instance%keep_failed_events ())
     end associate
   end subroutine process_instance_generate_weighted_event
 
 @ %def process_instance_generate_weighted_event
 @
 <<Instances: process instance: TBP>>=
   procedure :: generate_unweighted_event => process_instance_generate_unweighted_event
 <<Instances: procedures>>=
   subroutine process_instance_generate_unweighted_event (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     integer :: i_mci_work
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     associate (mci_work => instance%mci_work(i_mci_work))
        call instance%process%generate_unweighted_event &
           (i_mci_work, mci_work, instance)
     end associate
   end subroutine process_instance_generate_unweighted_event
 
 @ %def process_instance_generate_unweighted_event
 @
 This replaces the event generation methods for the situation that the
 process instance object has been filled by other means (i.e., reading
 and/or recalculating its contents).  We just have to fill in missing
 MCI data, especially the event weight.
 <<Instances: process instance: TBP>>=
   procedure :: recover_event => process_instance_recover_event
 <<Instances: procedures>>=
   subroutine process_instance_recover_event (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_mci
     i_mci = instance%i_mci
     call instance%process%set_i_mci_work (i_mci)
     associate (mci_instance => instance%mci_work(i_mci)%mci)
       call mci_instance%fetch (instance, instance%selected_channel)
     end associate
   end subroutine process_instance_recover_event
 
 @ %def process_instance_recover_event
 @
 @ Activate the components and terms that correspond to a currently
 selected MCI parameter set.
 <<Instances: process instance: TBP>>=
   procedure :: activate => process_instance_activate
 <<Instances: procedures>>=
   subroutine process_instance_activate (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i, j
     integer, dimension(:), allocatable :: i_term
     associate (mci_work => instance%mci_work(instance%i_mci))
        call instance%process%select_components (mci_work%get_active_components ())
     end associate
     associate (process => instance%process)
        do i = 1, instance%process%get_n_components ()
           if (instance%process%component_is_selected (i)) then
              allocate (i_term (size (process%get_component_i_terms (i))))
              i_term = process%get_component_i_terms (i)
              do j = 1, size (i_term)
                 instance%term(i_term(j))%active = .true.
              end do
           end if
           if (allocated (i_term)) deallocate (i_term)
        end do
     end associate
     instance%evaluation_status = STAT_ACTIVATED
   end subroutine process_instance_activate
 
 @ %def process_instance_activate
 @
 <<Instances: process instance: TBP>>=
   procedure :: find_same_kinematics => process_instance_find_same_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_find_same_kinematics (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_term1, i_term2, k, n_same
     do i_term1 = 1, size (instance%term)
        if (.not. allocated (instance%term(i_term1)%same_kinematics)) then
           n_same = 1 !!! Index group includes the index of its term_instance
           do i_term2 = 1, size (instance%term)
              if (i_term1 == i_term2) cycle
              if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1
           end do
           allocate (instance%term(i_term1)%same_kinematics (n_same))
           associate (same_kinematics1 => instance%term(i_term1)%same_kinematics)
              same_kinematics1 = 0
              k = 1
              do i_term2 = 1, size (instance%term)
                 if (compare_md5s (i_term1, i_term2)) then
                    same_kinematics1(k) = i_term2
                    k = k + 1
                 end if
              end do
              do k = 1, size (same_kinematics1)
                 if (same_kinematics1(k) == i_term1) cycle
                 i_term2 = same_kinematics1(k)
                 allocate (instance%term(i_term2)%same_kinematics (n_same))
                 instance%term(i_term2)%same_kinematics = same_kinematics1
              end do
           end associate
        end if
     end do
   contains
     function compare_md5s (i, j) result (same)
       logical :: same
       integer, intent(in) :: i, j
       character(32) :: md5sum_1, md5sum_2
       integer :: mode_1, mode_2
       mode_1 = 0; mode_2 = 0
       select type (phs => instance%kin(i)%phs%config)
       type is (phs_fks_config_t)
          md5sum_1 = phs%md5sum_born_config
          mode_1 = phs%mode
       class default
          md5sum_1 = phs%md5sum_phs_config
       end select
       select type (phs => instance%kin(j)%phs%config)
       type is (phs_fks_config_t)
          md5sum_2 = phs%md5sum_born_config
          mode_2 = phs%mode
       class default
          md5sum_2 = phs%md5sum_phs_config
       end select
       same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2)
     end function compare_md5s
   end subroutine process_instance_find_same_kinematics
 
 @ %def process_instance_find_same_kinematics
 @
 <<Instances: process instance: TBP>>=
   procedure :: transfer_same_kinematics => process_instance_transfer_same_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_transfer_same_kinematics (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: i, i_term_same
     associate (same_kinematics => instance%term(i_term)%same_kinematics)
       do i = 1, size (same_kinematics)
          i_term_same = same_kinematics(i)
          instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed
          associate (phs => instance%kin(i_term_same)%phs)
            call phs%set_lorentz_transformation &
                 (instance%kin(i_term)%phs%get_lorentz_transformation ())
            select type (phs)
            type is (phs_fks_t)
               call phs%set_momenta (instance%term(i_term_same)%p_seed)
               if (i_term_same /= i_term) then
                  call phs%set_reference_frames (.false.)
               end if
            end select
          end associate
          instance%kin(i_term_same)%new_seed = .false.
       end do
     end associate
   end subroutine process_instance_transfer_same_kinematics
 
 @ %def process_instance_transfer_same_kinematics
 @
 <<Instances: process instance: TBP>>=
   procedure :: redo_sf_chains => process_instance_redo_sf_chains
 <<Instances: procedures>>=
   subroutine process_instance_redo_sf_chains (instance, i_term, phs_channel)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), dimension(:) :: i_term
     integer, intent(in) :: phs_channel
     integer :: i
     do i = 1, size (i_term)
        call instance%kin(i_term(i))%redo_sf_chain &
             (instance%mci_work(instance%i_mci), phs_channel)
     end do
   end subroutine process_instance_redo_sf_chains
 
 @ %def process_instance_redo_sf_chains
 @ Integrate the process, using a previously initialized process
 instance.  We select one of the available MCI integrators by its index
 [[i_mci]] and thus integrate over (structure functions and) phase
 space for the associated (group of) process component(s).
 <<Instances: process instance: TBP>>=
   procedure :: integrate => process_instance_integrate
 <<Instances: procedures>>=
   subroutine process_instance_integrate (instance, i_mci, n_it, n_calls, &
        adapt_grids, adapt_weights, final, pacify)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     integer, intent(in) :: n_it
     integer, intent(in) :: n_calls
     logical, intent(in), optional :: adapt_grids
     logical, intent(in), optional :: adapt_weights
     logical, intent(in), optional :: final, pacify
     integer :: nlo_type, i_mci_work
     nlo_type = instance%process%get_component_nlo_type (i_mci)
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     call instance%reset_counter ()
     associate (mci_work => instance%mci_work(i_mci_work), &
                process => instance%process)
        call process%integrate (i_mci_work, mci_work, &
             instance, n_it, n_calls, adapt_grids, adapt_weights, &
             final, pacify, nlo_type = nlo_type)
        call process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
     end associate
   end subroutine process_instance_integrate
 
 @ %def process_instance_integrate
 @ Subroutine of the initialization above: initialize the beam and
 structure-function chain template.  We establish pointers to the
 configuration data, so [[beam_config]] must have a [[target]]
 attribute.
 
 The resulting chain is not used directly for calculation.  It will
 acquire instances which are stored in the process-component instance
 objects.
 <<Instances: process instance: TBP>>=
   procedure :: setup_sf_chain => process_instance_setup_sf_chain
 <<Instances: procedures>>=
   subroutine process_instance_setup_sf_chain (instance, config)
     class(process_instance_t), intent(inout) :: instance
     type(process_beam_config_t), intent(in), target :: config
     integer :: n_strfun
     n_strfun = config%n_strfun
     if (n_strfun /= 0) then
        call instance%sf_chain%init (config%data, config%sf)
     else
        call instance%sf_chain%init (config%data)
     end if
     if (config%sf_trace) then
        call instance%sf_chain%setup_tracing (config%sf_trace_file)
     end if
   end subroutine process_instance_setup_sf_chain
 
 @ %def process_instance_setup_sf_chain
 @ This initialization routine should be called only for process
 instances which we intend as a source for physical events.  It
 initializes the evaluators in the parton states of the terms.  They
 describe the (semi-)exclusive transition matrix and the distribution
 of color flow for the partonic process, convoluted with the beam and
 structure-function chain.
 
 If the model is not provided explicitly, we may use the model instance that
 belongs to the process.  However, an explicit model allows us to override
 particle settings.
 <<Instances: process instance: TBP>>=
   procedure :: setup_event_data => process_instance_setup_event_data
 <<Instances: procedures>>=
   subroutine process_instance_setup_event_data (instance, model, i_core)
     class(process_instance_t), intent(inout), target :: instance
     class(model_data_t), intent(in), optional, target :: model
     integer, intent(in), optional :: i_core
     class(model_data_t), pointer :: current_model
     integer :: i
     class(prc_core_t), pointer :: core => null ()
     if (present (model)) then
        current_model => model
     else
        current_model => instance%process%get_model_ptr ()
     end if
     do i = 1, size (instance%term)
        associate (term => instance%term(i), kin => instance%kin(i))
          if (associated (term%config)) then
             core => instance%process%get_core_term (i)
             call term%setup_event_data (kin, core, current_model)
          end if
        end associate
     end do
     core => null ()
   end subroutine process_instance_setup_event_data
 
 @ %def process_instance_setup_event_data
 @ Choose a MC parameter set and the corresponding integrator.
 The choice persists beyond calls of the [[reset]] method above.  This method
 is automatically called here.
 <<Instances: process instance: TBP>>=
   procedure :: choose_mci => process_instance_choose_mci
 <<Instances: procedures>>=
   subroutine process_instance_choose_mci (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     instance%i_mci = i_mci
     call instance%reset ()
   end subroutine process_instance_choose_mci
 
 @ %def process_instance_choose_mci
 @ Explicitly set a MC parameter set.  Works only if we are in initial
 state.  We assume that the length of the parameter set is correct.
 
 After setting the parameters, activate the components and terms that
 correspond to the chosen MC parameter set.
 
 The [[warmup_flag]] is used when a dummy phase-space point is computed
 for the warmup of e.g. OpenLoops helicities. The setting of the
 the [[evaluation_status]] has to be avoided then.
 <<Instances: process instance: TBP>>=
   procedure :: set_mcpar => process_instance_set_mcpar
 <<Instances: procedures>>=
   subroutine process_instance_set_mcpar (instance, x, warmup_flag)
     class(process_instance_t), intent(inout) :: instance
     real(default), dimension(:), intent(in) :: x
     logical, intent(in), optional :: warmup_flag
     logical :: activate
     activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag
     if (instance%evaluation_status == STAT_INITIAL) then
        associate (mci_work => instance%mci_work(instance%i_mci))
           call mci_work%set (x)
        end associate
        if (activate) call instance%activate ()
     end if
   end subroutine process_instance_set_mcpar
 
 @ %def process_instance_set_mcpar
 @ Receive the beam momentum/momenta from a source interaction.  This
 applies to a cascade decay process instance, where the `beam' momentum
 varies event by event.
 
 The master beam momentum array is contained in the main structure
 function chain subobject [[sf_chain]].  The sf-chain instance that
 reside in the components will take their beam momenta from there.
 
 The procedure transforms the instance status into
 [[STAT_BEAM_MOMENTA]].  For process instance with fixed beam, this
 intermediate status is skipped.
 <<Instances: process instance: TBP>>=
   procedure :: receive_beam_momenta => process_instance_receive_beam_momenta
 <<Instances: procedures>>=
   subroutine process_instance_receive_beam_momenta (instance)
     class(process_instance_t), intent(inout) :: instance
     if (instance%evaluation_status >= STAT_INITIAL) then
        call instance%sf_chain%receive_beam_momenta ()
        instance%evaluation_status = STAT_BEAM_MOMENTA
     end if
   end subroutine process_instance_receive_beam_momenta
 
 @ %def process_instance_receive_beam_momenta
 @ Set the beam momentum/momenta explicitly.  Otherwise, analogous to
 the previous procedure.
 <<Instances: process instance: TBP>>=
   procedure :: set_beam_momenta => process_instance_set_beam_momenta
 <<Instances: procedures>>=
   subroutine process_instance_set_beam_momenta (instance, p)
     class(process_instance_t), intent(inout) :: instance
     type(vector4_t), dimension(:), intent(in) :: p
     if (instance%evaluation_status >= STAT_INITIAL) then
        call instance%sf_chain%set_beam_momenta (p)
        instance%evaluation_status = STAT_BEAM_MOMENTA
     end if
   end subroutine process_instance_set_beam_momenta
 
 @ %def process_instance_set_beam_momenta
 @ Recover the initial beam momenta (those in the [[sf_chain]]
 component), given a valid (recovered) [[sf_chain_instance]] in one of
 the active components.  We need to do this only if the lab frame is
 not the c.m.\ frame, otherwise those beams would be fixed anyway.
 <<Instances: process instance: TBP>>=
   procedure :: recover_beam_momenta => process_instance_recover_beam_momenta
 <<Instances: procedures>>=
   subroutine process_instance_recover_beam_momenta (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     if (.not. instance%process%lab_is_cm ()) then
        if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
           call instance%kin(i_term)%return_beam_momenta ()
        end if
     end if
   end subroutine process_instance_recover_beam_momenta
 
 @ %def process_instance_recover_beam_momenta
 @ Explicitly choose MC integration channel.  We assume here that the channel
 count is identical for all active components.
 <<Instances: process instance: TBP>>=
   procedure :: select_channel => process_instance_select_channel
 <<Instances: procedures>>=
   subroutine process_instance_select_channel (instance, channel)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     instance%selected_channel = channel
   end subroutine process_instance_select_channel
 
 @ %def process_instance_select_channel
 @ First step of process evaluation: set up seed kinematics.  That is, for each
 active process component, compute a momentum array from the MC input
 parameters.
 
 If [[skip_term]] is set, we skip the component that accesses this
 term.  We can assume that the associated data have already been
 recovered, and we are just computing the rest.
 <<Instances: process instance: TBP>>=
   procedure :: compute_seed_kinematics => &
        process_instance_compute_seed_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_compute_seed_kinematics &
        (instance, recover, skip_term)
     class(process_instance_t), intent(inout) :: instance
     logical, intent(in), optional :: recover
     integer, intent(in), optional :: skip_term
     integer :: channel, skip_component, i, j
     logical :: success
     integer, dimension(:), allocatable :: i_term
     channel = instance%selected_channel
     if (channel == 0) then
        call msg_bug ("Compute seed kinematics: undefined integration channel")
     end if
     if (present (skip_term)) then
        skip_component = instance%term(skip_term)%config%i_component
     else
        skip_component = 0
     end if
     if (present (recover)) then
        if (recover) return
     end if
     if (instance%evaluation_status >= STAT_ACTIVATED) then
        success = .true.
        do i = 1, instance%process%get_n_components ()
           if (i == skip_component)  cycle
           if (instance%process%component_is_selected (i)) then
              allocate (i_term (size (instance%process%get_component_i_terms (i))))
              i_term = instance%process%get_component_i_terms (i)
              do j = 1, size (i_term)
                 associate (term => instance%term(i_term(j)), kin => instance%kin(i_term(j)))
                   if (kin%new_seed) then
                      call term%compute_seed_kinematics (kin, &
                           instance%mci_work(instance%i_mci), channel, success)
                      call instance%transfer_same_kinematics (i_term(j))
                   end if
                   if (.not. success)  exit
                   select type (pcm => instance%pcm)
                   class is (pcm_nlo_t)
                      call term%evaluate_projections (kin)
                      call kin%evaluate_radiation_kinematics &
                           (instance%mci_work(instance%i_mci)%get_x_process ())
                      call kin%generate_fsr_in ()
                      call kin%compute_xi_ref_momenta (pcm%region_data, term%nlo_type)
                   end select
                 end associate
              end do
           end if
           if (allocated (i_term)) deallocate (i_term)
        end do
        if (success) then
           instance%evaluation_status = STAT_SEED_KINEMATICS
        else
           instance%evaluation_status = STAT_FAILED_KINEMATICS
        end if
     end if
     associate (mci_work => instance%mci_work(instance%i_mci))
        select type (pcm_work => instance%pcm_work)
        class is (pcm_nlo_workspace_t)
           call pcm_work%set_x_rad (mci_work%get_x_process ())
        end select
     end associate
   end subroutine process_instance_compute_seed_kinematics
 
 @ %def process_instance_compute_seed_kinematics
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_x_process => process_instance_get_x_process
 <<Instances: procedures>>=
   pure function process_instance_get_x_process (instance) result (x)
     real(default), dimension(:), allocatable :: x
     class(process_instance_t), intent(in) :: instance
     allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ())))
     x = instance%mci_work(instance%i_mci)%get_x_process ()
   end function process_instance_get_x_process
 
 @ %def process_instance_get_x_process
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_active_component_type => process_instance_get_active_component_type
 <<Instances: procedures>>=
   pure function process_instance_get_active_component_type (instance) &
          result (nlo_type)
     integer :: nlo_type
     class(process_instance_t), intent(in) :: instance
     nlo_type = instance%process%get_component_nlo_type (instance%i_mci)
   end function process_instance_get_active_component_type
 
 @ %def process_instance_get_active_component_type
 @ Inverse: recover missing parts of the kinematics from the momentum
 configuration, which we know for a single term and component.   Given
 a channel, reconstruct the MC parameter set.
 <<Instances: process instance: TBP>>=
   procedure :: recover_mcpar => process_instance_recover_mcpar
 <<Instances: procedures>>=
   subroutine process_instance_recover_mcpar (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: channel, i
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        channel = instance%selected_channel
        if (channel == 0) then
           call msg_bug ("Recover MC parameters: undefined integration channel")
        end if
        call instance%kin(i_term)%recover_mcpar &
             (instance%mci_work(instance%i_mci), channel, instance%term(i_term)%p_seed)
        if (instance%term(i_term)%nlo_type == NLO_REAL) then
           do i = 1, size (instance%term)
              if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then
                 if (instance%term(i)%active) then
                    call instance%kin(i)%recover_mcpar &
                         (instance%mci_work(instance%i_mci), channel, &
                          instance%term(i)%p_seed)
                 end if
              end if
           end do
        end if
     end if
   end subroutine process_instance_recover_mcpar
 
 @ %def process_instance_recover_mcpar
 @ This is part of [[recover_mcpar]], extracted for the case when there is
 no phase space and parameters to recover, but we still need the structure
 function kinematics for evaluation.
 <<Instances: process instance: TBP>>=
   procedure :: recover_sfchain => process_instance_recover_sfchain
 <<Instances: procedures>>=
   subroutine process_instance_recover_sfchain (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: channel
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        channel = instance%selected_channel
        if (channel == 0) then
           call msg_bug ("Recover sfchain: undefined integration channel")
        end if
        call instance%kin(i_term)%recover_sfchain (channel, instance%term(i_term)%p_seed)
     end if
   end subroutine process_instance_recover_sfchain
 
 @ %def process_instance_recover_sfchain
 @ Second step of process evaluation: compute all momenta, for all active
 components, from the seed kinematics.
 <<Instances: process instance: TBP>>=
   procedure :: compute_hard_kinematics => &
        process_instance_compute_hard_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_compute_hard_kinematics (instance, recover, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     logical, intent(in), optional :: recover
     integer :: i
     logical :: success
     success = .true.
     if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i), kin => instance%kin(i))
             if (term%active) then
                call term%compute_hard_kinematics &
                     (kin, recover, skip_term, success)
                if (.not. success) exit
                !!! Ren scale is zero when this is commented out! Understand!
                if (term%nlo_type == NLO_REAL) &
                   call kin%redo_sf_chain (instance%mci_work(instance%i_mci), &
                       instance%selected_channel)
             end if
           end associate
        end do
        if (success) then
           instance%evaluation_status = STAT_HARD_KINEMATICS
        else
           instance%evaluation_status = STAT_FAILED_KINEMATICS
        end if
     end if
   end subroutine process_instance_compute_hard_kinematics
 
 @ %def process_instance_setup_compute_hard_kinematics
 @ Inverse: recover seed kinematics.  We know the beam momentum
 configuration and the outgoing momenta of the effective interaction,
 for one specific term.
 <<Instances: process instance: TBP>>=
   procedure :: recover_seed_kinematics => &
        process_instance_recover_seed_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_recover_seed_kinematics (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     type(vector4_t), dimension(:), allocatable :: p_seed_ref
     integer :: i
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        call instance%term(i_term)%recover_seed_kinematics (instance%kin(i_term))
        if (instance%term(i_term)%nlo_type == NLO_REAL) then
           allocate (p_seed_ref (instance%term(i_term)%isolated%int_eff%get_n_out ()))
           p_seed_ref = instance%term(i_term)%isolated%int_eff%get_momenta &
                (outgoing = .true.)
           do i = 1, size (instance%term)
              if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then
                 if (instance%term(i)%active) then
                    call instance%term(i)%recover_seed_kinematics &
                         (instance%kin(i), p_seed_ref)
                 end if
              end if
           end do
        end if
     end if
   end subroutine process_instance_recover_seed_kinematics
 
 @ %def process_instance_recover_seed_kinematics
 @ Third step of process evaluation: compute the effective momentum
 configurations, for all active terms, from the hard kinematics.
 <<Instances: process instance: TBP>>=
   procedure :: compute_eff_kinematics => &
        process_instance_compute_eff_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_compute_eff_kinematics (instance, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: i
     if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then
        do i = 1, size (instance%term)
           if (present (skip_term)) then
              if (i == skip_term)  cycle
           end if
           if (instance%term(i)%active) then
              call instance%term(i)%compute_eff_kinematics ()
           end if
        end do
        instance%evaluation_status = STAT_EFF_KINEMATICS
     end if
   end subroutine process_instance_compute_eff_kinematics
 
 @ %def process_instance_setup_compute_eff_kinematics
 @ Inverse: recover the hard kinematics from effective kinematics for
 one term, then compute effective kinematics for the other terms.
 <<Instances: process instance: TBP>>=
   procedure :: recover_hard_kinematics => &
        process_instance_recover_hard_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_recover_hard_kinematics (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: i
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        call instance%term(i_term)%recover_hard_kinematics ()
        do i = 1, size (instance%term)
           if (i /= i_term) then
              if (instance%term(i)%active) then
                 call instance%term(i)%compute_eff_kinematics ()
              end if
           end if
        end do
        instance%evaluation_status = STAT_EFF_KINEMATICS
     end if
   end subroutine process_instance_recover_hard_kinematics
 
 @ %def recover_hard_kinematics
 @ Fourth step of process evaluation: check cuts for all terms.  Where
 successful, compute any scales and weights.  Otherwise, deactive the term.
 If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]].
 
 The argument [[scale_forced]], if present, will override the scale calculation
 in the term expressions.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_expressions => &
        process_instance_evaluate_expressions
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_expressions (instance, scale_forced)
     class(process_instance_t), intent(inout) :: instance
     real(default), intent(in), allocatable, optional :: scale_forced
     integer :: i
     logical :: passed_real
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        do i = 1, size (instance%term)
           if (instance%term(i)%active) then
              call instance%term(i)%evaluate_expressions (scale_forced)
           end if
        end do
        call evaluate_real_scales_and_cuts ()
        call set_ellis_sexton_scale ()
        if (.not. passed_real) then
           instance%evaluation_status = STAT_FAILED_CUTS
        else
           if (any (instance%term%passed)) then
              instance%evaluation_status = STAT_PASSED_CUTS
           else
              instance%evaluation_status = STAT_FAILED_CUTS
           end if
        end if
     end if
   contains
     subroutine evaluate_real_scales_and_cuts ()
       integer :: i
       passed_real = .true.
       select type (pcm => instance%pcm)
       type is (pcm_nlo_t)
          do i = 1, size (instance%term)
             if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then
                if (pcm%settings%cut_all_real_sqmes) &
                     passed_real = passed_real .and. instance%term(i)%passed
                if (pcm%settings%use_born_scale) &
                     call replace_scales (instance%term(i))
             end if
          end do
       end select
     end subroutine evaluate_real_scales_and_cuts
 
     subroutine replace_scales (this_term)
       type(term_instance_t), intent(inout) :: this_term
       integer :: i_sub
       i_sub = this_term%config%i_sub
       if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then
          this_term%ren_scale = instance%term(i_sub)%ren_scale
          this_term%fac_scale = instance%term(i_sub)%fac_scale
       end if
     end subroutine replace_scales
 
     subroutine set_ellis_sexton_scale ()
       real(default) :: es_scale
       type(var_list_t), pointer :: var_list
       integer :: i
       var_list => instance%process%get_var_list_ptr ()
       es_scale = var_list%get_rval (var_str ("ellis_sexton_scale"))
       do i = 1, size (instance%term)
          if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then
             if (es_scale > zero) then
                if (allocated (instance%term(i)%es_scale)) then
                   instance%term(i)%es_scale = es_scale
                else
                   allocate (instance%term(i)%es_scale, source=es_scale)
                end if
             end if
          end if
       end do
     end subroutine set_ellis_sexton_scale
   end subroutine process_instance_evaluate_expressions
 
 @ %def process_instance_evaluate_expressions
 @ Fifth step of process evaluation: fill the parameters for the non-selected
 channels, that have not been used for seeding.  We should do this after
 evaluating cuts, since we may save some expensive calculations if the phase
 space point fails the cuts.
 
 If [[skip_term]] is set, we skip the component that accesses this
 term.  We can assume that the associated data have already been
 recovered, and we are just computing the rest.
 <<Instances: process instance: TBP>>=
   procedure :: compute_other_channels => &
        process_instance_compute_other_channels
 <<Instances: procedures>>=
   subroutine process_instance_compute_other_channels (instance, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: channel, skip_component, i, j
     integer, dimension(:), allocatable :: i_term
     channel = instance%selected_channel
     if (channel == 0) then
        call msg_bug ("Compute other channels: undefined integration channel")
     end if
     if (present (skip_term)) then
        skip_component = instance%term(skip_term)%config%i_component
     else
        skip_component = 0
     end if
     if (instance%evaluation_status >= STAT_PASSED_CUTS) then
        do i = 1, instance%process%get_n_components ()
           if (i == skip_component)  cycle
           if (instance%process%component_is_selected (i)) then
              allocate (i_term (size (instance%process%get_component_i_terms (i))))
              i_term = instance%process%get_component_i_terms (i)
              do j = 1, size (i_term)
                 call instance%kin(i_term(j))%compute_other_channels &
                      (instance%mci_work(instance%i_mci), channel)
              end do
           end if
           if (allocated (i_term)) deallocate (i_term)
        end do
     end if
   end subroutine process_instance_compute_other_channels
 
 @ %def process_instance_compute_other_channels
 @ If not done otherwise, we flag the kinematics as new for the core state,
 such that the routine below will actually compute the matrix element and not
 just look it up.
 <<Instances: process instance: TBP>>=
   procedure :: reset_core_kinematics => process_instance_reset_core_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_reset_core_kinematics (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i
     if (instance%evaluation_status >= STAT_PASSED_CUTS) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i))
             if (term%active .and. term%passed) then
                if (allocated (term%core_state)) &
                     call term%core_state%reset_new_kinematics ()
             end if
           end associate
        end do
     end if
   end subroutine process_instance_reset_core_kinematics
 
 @ %def process_instance_reset_core_kinematics
 @ Sixth step of process evaluation: evaluate the matrix elements, and compute
 the trace (summed over quantum numbers) for all terms.  Finally, sum up the
 terms, iterating over all active process components.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_trace => process_instance_evaluate_trace
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_trace (instance, recover)
     class(process_instance_t), intent(inout) :: instance
     logical, intent(in), optional :: recover
     class(prc_core_t), pointer :: core => null ()
     integer :: i, i_real_fin, i_core
     real(default) :: alpha_s, alpha_qed
     class(prc_core_t), pointer :: core_sub => null ()
     class(model_data_t), pointer :: model => null ()
     logical :: has_pdfs
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace")
     has_pdfs = instance%process%pcm_contains_pdfs ()
     instance%sqme = zero
     call instance%reset_matrix_elements ()
     if (instance%evaluation_status >= STAT_PASSED_CUTS) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i), kin => instance%kin(i))
             if (term%active .and. term%passed) then
                core => instance%process%get_core_term (i)
                select type (pcm => instance%process%get_pcm_ptr ())
                class is (pcm_nlo_t)
                   i_core = pcm%get_i_core (pcm%i_sub)
                   core_sub => instance%process%get_core_ptr (i_core)
                end select
                call term%evaluate_interaction (core, kin)
                call term%evaluate_trace (kin)
                i_real_fin = instance%process%get_associated_real_fin (1)
                if (instance%process%uses_real_partition ()) &
                     call term%apply_real_partition (kin, instance%process)
                if (term%config%i_component /= i_real_fin) then
                   if ((term%nlo_type == NLO_REAL .and. kin%emitter < 0) &
                        .or. term%nlo_type == NLO_MISMATCH &
                        .or. term%nlo_type == NLO_DGLAP) &
                        call term%set_born_sqmes (core)
                   if (term%is_subtraction () .or. &
                        term%nlo_type == NLO_DGLAP) &
                        call term%set_sf_factors (kin, has_pdfs)
                   if (term%nlo_type > BORN) then
                      if (.not. (term%nlo_type == NLO_REAL .and. &
                           kin%emitter >= 0)) then
                         select type (pcm => term%pcm)
                         type is (pcm_nlo_t)
                            if (char (pcm%settings%nlo_correction_type) == "QCD" .or. &
                                 char (pcm%settings%nlo_correction_type) == "Full") &
                                 call term%evaluate_color_correlations (core_sub)
                            if (char (pcm%settings%nlo_correction_type) == "EW" .or. &
                                 char (pcm%settings%nlo_correction_type) == "Full") then
                               call term%evaluate_charge_correlations (core_sub)
                               select type (pcm => term%pcm)
                               type is (pcm_nlo_t)
                                  associate (reg_data => pcm%region_data)
                                    if (reg_data%alphas_power > 0) &
                                         call term%evaluate_color_correlations (core_sub)
                                  end associate
                               end select
                            end if
                         end select
                      end if
                      if (term%is_subtraction ()) then
                         call term%evaluate_spin_correlations (core_sub)
                      end if
                   end if
                   alpha_s = core%get_alpha_s (term%core_state)
-                  alpha_qed = core%get_alpha_qed ()
+                  alpha_qed = core%get_alpha_qed (term%core_state)
                   if (term%nlo_type > BORN) then
                      select type (pcm => term%pcm)
                      type is (pcm_nlo_t)
                         if (alpha_qed == -1 .and. (&
                              char (pcm%settings%nlo_correction_type) == "EW" .or. &
                              char (pcm%settings%nlo_correction_type) == "Full")) then
                            call msg_bug("Attempting to compute EW corrections with alpha_qed = -1")
                         end if
                      end select
                   end if
                   if (present (recover)) then
                      if (recover)  return
                   end if
                   select case (term%nlo_type)
                   case (NLO_REAL)
                      call term%apply_fks (kin, alpha_s, alpha_qed)
                   case (NLO_VIRTUAL)
                      call term%evaluate_sqme_virt (alpha_s, alpha_qed)
                   case (NLO_MISMATCH)
                      call term%evaluate_sqme_mismatch (alpha_s)
                   case (NLO_DGLAP)
                      call term%evaluate_sqme_dglap (alpha_s, alpha_qed)
                   end select
                end if
             end if
             core_sub => null ()
             instance%sqme = instance%sqme + real (sum (&
                  term%connected%trace%get_matrix_element () * &
                  term%weight))
           end associate
        end do
        core => null ()
        if (instance%pcm_work%is_valid ()) then
           instance%evaluation_status = STAT_EVALUATED_TRACE
        else
           instance%evaluation_status = STAT_FAILED_KINEMATICS
        end if
     else
        !!! Failed kinematics or failed cuts: set sqme to zero
        instance%sqme = zero
     end if
   end subroutine process_instance_evaluate_trace
 
 @ %def process_instance_evaluate_trace
 <<Instances: term instance: TBP>>=
   procedure :: set_born_sqmes => term_instance_set_born_sqmes
 <<Instances: procedures>>=
   subroutine term_instance_set_born_sqmes (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in) :: core
     integer :: i_flv, ii_flv
     real(default) :: sqme
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
           ii_flv = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
           sqme = real (term%connected%trace%get_matrix_element (ii_flv))
           select case (term%nlo_type)
           case (NLO_REAL)
              pcm_work%real_sub%sqme_born(i_flv) = sqme
           case (NLO_MISMATCH)
              pcm_work%soft_mismatch%sqme_born(i_flv) = sqme
           case (NLO_DGLAP)
              pcm_work%dglap_remnant%sqme_born(i_flv) = sqme
           end select
        end do
     end select
   end subroutine term_instance_set_born_sqmes
 
 @ %def term_instance_set_born_sqmes
 @ Calculates and then saves the ratio of the value of the (rescaled) real
 structure function chain of each ISR alpha region over the value of the
 corresponding underlying born flavor structure.
 In the case of emitter 0 we also need the rescaled ratio for emitter 1 and 2
 in that region for the (soft-)collinear limits.
 If the emitter is 1 or 2 in some cases, e. g. for EW corrections where a photon in the
 proton is required, there can be the possibility of soft radiation off the initial state.
 For that purpose the unrescaled ratio is needed and as a default we always save these
 numbers in [[sf_factors(:, 0)]].
 Altough this procedure is implying functionality for general structure functions,
 it should be reviewed for anything else besides PDFs, as there might be complications
 in the details. The general idea of getting the ratio in this way should hold up in
 these cases as well, however.
 <<Instances: term instance: TBP>>=
   procedure :: set_sf_factors => term_instance_set_sf_factors
 <<Instances: procedures>>=
   subroutine term_instance_set_sf_factors (term, kin, has_pdfs)
     class(term_instance_t), intent(inout) :: term
     type(kinematics_t), intent(inout) :: kin
     logical, intent(in) :: has_pdfs
     type(interaction_t), pointer :: sf_chain_int
     real(default) :: factor_born, factor_real
     integer :: n_in, alr, em
     integer :: i_born, i_real
     select type (pcm_work => term%pcm_work)
     type is (pcm_nlo_workspace_t)
        if (.not. has_pdfs) then
           pcm_work%real_sub%sf_factors = one
           return
        end if
        select type (pcm => term%pcm)
        type is (pcm_nlo_t)
           sf_chain_int => kin%sf_chain%get_out_int_ptr ()
           associate (reg_data => pcm%region_data)
              n_in = reg_data%get_n_in ()
              do alr = 1, reg_data%n_regions
                 em = reg_data%regions(alr)%emitter
                 if (em <= n_in) then
                    i_born = reg_data%regions(alr)%uborn_index
                    i_real = reg_data%regions(alr)%real_index
                    factor_born = sf_chain_int%get_matrix_element &
                         (sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0))
                    factor_real = sf_chain_int%get_matrix_element &
                         (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
                    call set_factor (pcm_work, alr, em, factor_born, factor_real)
                    if (em == 0) then
                       do em = 1, 2
                          factor_real = sf_chain_int%get_matrix_element &
                               (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
                          call set_factor (pcm_work, alr, em, factor_born, factor_real)
                       end do
                    else
                       factor_real = sf_chain_int%get_matrix_element &
                            (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = 0))
                       call set_factor (pcm_work, alr, 0, factor_born, factor_real)
                    end if
                 end if
              end do
           end associate
        end select
     end select
   contains
     subroutine set_factor (pcm_work, alr, em, factor_born, factor_real)
       type(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
       integer, intent(in) :: alr, em
       real(default), intent(in) :: factor_born, factor_real
       real(default) :: factor
       if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then
          factor = zero
       else
          factor = factor_real / factor_born
       end if
       select case (term%nlo_type)
       case (NLO_REAL)
          pcm_work%real_sub%sf_factors(alr, em) = factor
       case (NLO_DGLAP)
          pcm_work%dglap_remnant%sf_factors(alr, em) = factor
       end select
     end subroutine
   end subroutine term_instance_set_sf_factors
 
 @ %def term_instance_set_sf_factors
 @
 <<Instances: process instance: TBP>>=
   procedure :: apply_real_partition => process_instance_apply_real_partition
 <<Instances: procedures>>=
   subroutine process_instance_apply_real_partition (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_component, i_term
     integer, dimension(:), allocatable :: i_terms
     associate (process => instance%process)
        i_component = process%get_first_real_component ()
        if (process%component_is_selected (i_component) .and. &
               process%get_component_nlo_type (i_component) == NLO_REAL) then
           allocate (i_terms (size (process%get_component_i_terms (i_component))))
           i_terms = process%get_component_i_terms (i_component)
           do i_term = 1, size (i_terms)
              call instance%term(i_terms(i_term))%apply_real_partition ( &
                   instance%kin(i_terms(i_term)), &
                   process)
           end do
        end if
        if (allocated (i_terms)) deallocate (i_terms)
     end associate
   end subroutine process_instance_apply_real_partition
 
 @ %def process_instance_apply_real_partition
 @
 <<Instances: process instance: TBP>>=
   procedure :: set_i_mci_to_real_component => process_instance_set_i_mci_to_real_component
 <<Instances: procedures>>=
   subroutine process_instance_set_i_mci_to_real_component (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_mci, i_component
     type(process_component_t), pointer :: component => null ()
     select type (pcm_work => instance%pcm_work)
     type is (pcm_nlo_workspace_t)
        if (allocated (pcm_work%i_mci_to_real_component)) then
           call msg_warning ("i_mci_to_real_component already allocated - replace it")
           deallocate (pcm_work%i_mci_to_real_component)
        end if
        allocate (pcm_work%i_mci_to_real_component (size (instance%mci_work)))
        do i_mci = 1, size (instance%mci_work)
           do i_component = 1, instance%process%get_n_components ()
              component => instance%process%get_component_ptr (i_component)
              if (component%i_mci /= i_mci) cycle
              select case (component%component_type)
              case (COMP_MASTER, COMP_REAL)
                 pcm_work%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real ()
              case (COMP_REAL_FIN)
                 pcm_work%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real_fin ()
              case (COMP_REAL_SING)
                 pcm_work%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real_sing ()
              end select
           end do
        end do
        component => null ()
     end select
   end subroutine process_instance_set_i_mci_to_real_component
 
 @ %def process_instance_set_i_mci_to_real_component
 @ Final step of process evaluation: evaluate the matrix elements, and compute
 the trace (summed over quantum numbers) for all terms.  Finally, sum up the
 terms, iterating over all active process components.
 
 If [[weight]] is provided, we already know the kinematical event
 weight (the MCI weight which depends on the kinematics sampling
 algorithm, but not on the matrix element), so we do not need to take
 it from the MCI record.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_event_data => process_instance_evaluate_event_data
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_event_data (instance, weight)
     class(process_instance_t), intent(inout) :: instance
     real(default), intent(in), optional :: weight
     integer :: i
     if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i))
             if (term%active) then
                call term%evaluate_event_data ()
             end if
           end associate
        end do
        if (present (weight)) then
           instance%weight = weight
        else
           instance%weight = &
                instance%mci_work(instance%i_mci)%mci%get_event_weight ()
           instance%excess = &
                instance%mci_work(instance%i_mci)%mci%get_event_excess ()
        end if
        instance%n_dropped = &
             instance%mci_work(instance%i_mci)%mci%get_n_event_dropped ()
        instance%evaluation_status = STAT_EVENT_COMPLETE
     else
        !!! failed kinematics etc.: set weight to zero
        instance%weight = zero
        !!! Maybe we want to process and keep the event nevertheless
        if (instance%keep_failed_events ()) then
           do i = 1, size (instance%term)
              associate (term => instance%term(i))
                if (term%active) then
                   call term%evaluate_event_data ()
                end if
              end associate
           end do
 !           do i = 1, size (instance%term)
 !              instance%term(i)%fac_scale = zero
 !           end do
           instance%evaluation_status = STAT_EVENT_COMPLETE
        end if
     end if
   end subroutine process_instance_evaluate_event_data
 
 @ %def process_instance_evaluate_event_data
 @ Computes the real-emission matrix element for externally supplied momenta
 for the term instance with index [[i_term]] and a phase space point set with
 index [[i_phs]]. In addition, for the real emission, each term instance
 corresponds to one emitter. Also, e.g. for Powheg, there is the possibility
 to supply an external $\alpha_s$.
 <<Instances: process instance: TBP>>=
   procedure :: compute_sqme_rad => process_instance_compute_sqme_rad
 <<Instances: procedures>>=
   subroutine process_instance_compute_sqme_rad &
          (instance, i_term, i_phs, is_subtraction, alpha_s_external)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term, i_phs
     logical, intent(in) :: is_subtraction
     real(default), intent(in), optional :: alpha_s_external
     class(prc_core_t), pointer :: core
     integer :: i_real_fin
     logical :: has_pdfs
     has_pdfs = instance%process%pcm_contains_pdfs ()
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad")
     select type (pcm_work => instance%pcm_work)
     type is (pcm_nlo_workspace_t)
        associate (term => instance%term(i_term), kin => instance%kin(i_term))
           core => instance%process%get_core_term (i_term)
           if (is_subtraction) then
              call pcm_work%set_subtraction_event ()
           else
              call pcm_work%set_radiation_event ()
           end if
           call term%int_hard%set_momenta (pcm_work%get_momenta &
                (term%pcm, i_phs = i_phs, born_phsp = is_subtraction))
           if (allocated (term%core_state)) &
                call term%core_state%reset_new_kinematics ()
           if (present (alpha_s_external)) &
                call term%set_alpha_qcd_forced (alpha_s_external)
           call term%compute_eff_kinematics ()
           call term%evaluate_expressions ()
           call term%evaluate_interaction (core, kin)
           call term%evaluate_trace (kin)
           if (term%is_subtraction ()) then
              call term%set_sf_factors (kin, has_pdfs)
              select type (pcm => instance%pcm)
              type is (pcm_nlo_t)
                 if (char (pcm%settings%nlo_correction_type) == "QCD" .or. &
                      char (pcm%settings%nlo_correction_type) == "Full") &
                      call term%evaluate_color_correlations (core)
                 if (char (pcm%settings%nlo_correction_type) == "EW" .or. &
                      char (pcm%settings%nlo_correction_type) == "Full") &
                      call term%evaluate_charge_correlations (core)
              end select
              call term%evaluate_spin_correlations (core)
           end if
           i_real_fin = instance%process%get_associated_real_fin (1)
           if (term%config%i_component /= i_real_fin) &
                call term%apply_fks (kin, core%get_alpha_s (term%core_state), &
-                                    core%get_alpha_qed ())
+                                    core%get_alpha_qed (term%core_state))
           if (instance%process%uses_real_partition ()) &
                call instance%apply_real_partition ()
        end associate
     end select
     core => null ()
   end subroutine process_instance_compute_sqme_rad
 
 @ %def process_instance_compute_sqme_rad
 @ For unweighted event generation, we should reset the reported event
 weight to unity (signed) or zero.  The latter case is appropriate for
 an event which failed for whatever reason.
 <<Instances: process instance: TBP>>=
   procedure :: normalize_weight => process_instance_normalize_weight
 <<Instances: procedures>>=
   subroutine process_instance_normalize_weight (instance)
     class(process_instance_t), intent(inout) :: instance
     if (.not. vanishes (instance%weight)) then
        instance%weight = sign (1._default, instance%weight)
     end if
   end subroutine process_instance_normalize_weight
 
 @ %def process_instance_normalize_weight
 @ This is a convenience routine that performs the computations of the
 steps 1 to 5 in a single step.  The arguments are the input for
 [[set_mcpar]].  After this, the evaluation status should be either
 [[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]].
 
 Before calling this, we should call [[choose_mci]].
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_sqme => process_instance_evaluate_sqme
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_sqme (instance, channel, x)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     real(default), dimension(:), intent(in) :: x
     call instance%reset ()
     call instance%set_mcpar (x)
     call instance%select_channel (channel)
     call instance%compute_seed_kinematics ()
     call instance%compute_hard_kinematics ()
     call instance%compute_eff_kinematics ()
     call instance%evaluate_expressions ()
     call instance%compute_other_channels ()
     call instance%evaluate_trace ()
   end subroutine process_instance_evaluate_sqme
 
 @ %def process_instance_evaluate_sqme
 @ This is the inverse.  Assuming that the final trace evaluator
 contains a valid momentum configuration, recover kinematics
 and recalculate the matrix elements and their trace.
 
 To be precise, we first recover kinematics for the given term and
 associated component, then recalculate from that all other terms and
 active components.  The [[channel]] is not really required to obtain
 the matrix element, but it allows us to reconstruct the exact MC
 parameter set that corresponds to the given phase space point.
 
 Before calling this, we should call [[choose_mci]].
 <<Instances: process instance: TBP>>=
   procedure :: recover => process_instance_recover
 <<Instances: procedures>>=
   subroutine process_instance_recover &
        (instance, channel, i_term, update_sqme, recover_phs, scale_forced)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     integer, intent(in) :: i_term
     logical, intent(in) :: update_sqme
     logical, intent(in) :: recover_phs
     real(default), intent(in), allocatable, optional :: scale_forced
     logical :: skip_phs, recover
     call instance%activate ()
     instance%evaluation_status = STAT_EFF_KINEMATICS
     call instance%recover_hard_kinematics (i_term)
     call instance%recover_seed_kinematics (i_term)
     call instance%select_channel (channel)    
     recover = instance%pcm_work%is_nlo ()
     if (recover_phs) then
        call instance%recover_mcpar (i_term)
        call instance%recover_beam_momenta (i_term)
        call instance%compute_seed_kinematics &
             (recover = recover, skip_term = i_term)
        call instance%compute_hard_kinematics &
             (recover = recover, skip_term = i_term)
        call instance%compute_eff_kinematics (i_term)
        call instance%compute_other_channels (i_term)
     else
        call instance%recover_sfchain (i_term)
     end if
     call instance%evaluate_expressions (scale_forced)
     if (update_sqme) then
        call instance%reset_core_kinematics ()
        call instance%evaluate_trace (recover)
     end if
   end subroutine process_instance_recover
 
 @ %def process_instance_recover
 @ The [[evaluate]] method is required by the [[sampler_t]] base type of which
 the process instance is an extension.
 
 The requirement is that after the process instance is evaluated, the
 integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are
 exposed by the [[sampler_t]] object.
 
 We allow for the additional [[hook]] to be called, if associated, for outlying
 object to access information from the current state of the [[sampler]].
 <<Instances: process instance: TBP>>=
   procedure :: evaluate => process_instance_evaluate
 <<Instances: procedures>>=
   subroutine process_instance_evaluate (sampler, c, x_in, val, x, f)
     class(process_instance_t), intent(inout) :: sampler
     integer, intent(in) :: c
     real(default), dimension(:), intent(in) :: x_in
     real(default), intent(out) :: val
     real(default), dimension(:,:), intent(out) :: x
     real(default), dimension(:), intent(out) :: f
     call sampler%evaluate_sqme (c, x_in)
     if (sampler%is_valid ()) then
        call sampler%fetch (val, x, f)
     end if
     call sampler%record_call ()
     call sampler%evaluate_after_hook ()
   end subroutine process_instance_evaluate
 
 @ %def process_instance_evaluate
 @ The phase-space point is valid if the event has valid kinematics and
 has passed the cuts.
 <<Instances: process instance: TBP>>=
   procedure :: is_valid => process_instance_is_valid
 <<Instances: procedures>>=
   function process_instance_is_valid (sampler) result (valid)
     class(process_instance_t), intent(in) :: sampler
     logical :: valid
     valid = sampler%evaluation_status >= STAT_PASSED_CUTS
   end function process_instance_is_valid
 
 @ %def process_instance_is_valid
 @ Add a [[process_instance_hook]] object..
 <<Instances: process instance: TBP>>=
   procedure :: append_after_hook => process_instance_append_after_hook
 <<Instances: procedures>>=
   subroutine process_instance_append_after_hook (sampler, new_hook)
     class(process_instance_t), intent(inout), target :: sampler
     class(process_instance_hook_t), intent(inout), target :: new_hook
     class(process_instance_hook_t), pointer :: last
     if (associated (new_hook%next)) then
        call msg_bug ("process_instance_append_after_hook: reuse of SAME hook object is forbidden.")
     end if
     if (associated (sampler%hook)) then
        last => sampler%hook
        do while (associated (last%next))
           last => last%next
        end do
        last%next => new_hook
     else
        sampler%hook => new_hook
     end if
   end subroutine process_instance_append_after_hook
 
 @ %def process_instance_append_after_evaluate_hook
 @ Evaluate the after hook as first in, last out.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_after_hook => process_instance_evaluate_after_hook
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_after_hook (sampler)
     class(process_instance_t), intent(in) :: sampler
     class(process_instance_hook_t), pointer :: current
     current => sampler%hook
     do while (associated(current))
        call current%evaluate (sampler)
        current => current%next
     end do
   end subroutine process_instance_evaluate_after_hook
 
 @ %def process_instance_evaluate_after_hook
 @ The [[rebuild]] method should rebuild the kinematics section out of
 the [[x_in]] parameter set.  The integrand value [[val]] should not be
 computed, but is provided as input.
 <<Instances: process instance: TBP>>=
   procedure :: rebuild => process_instance_rebuild
 <<Instances: procedures>>=
   subroutine process_instance_rebuild (sampler, c, x_in, val, x, f)
     class(process_instance_t), intent(inout) :: sampler
     integer, intent(in) :: c
     real(default), dimension(:), intent(in) :: x_in
     real(default), intent(in) :: val
     real(default), dimension(:,:), intent(out) :: x
     real(default), dimension(:), intent(out) :: f
     call msg_bug ("process_instance_rebuild not implemented yet")
     x = 0
     f = 0
   end subroutine process_instance_rebuild
 
 @ %def process_instance_rebuild
 @ This is another method required by the [[sampler_t]] base type:
 fetch the data that are relevant for the MCI record.
 <<Instances: process instance: TBP>>=
   procedure :: fetch => process_instance_fetch
 <<Instances: procedures>>=
   subroutine process_instance_fetch (sampler, val, x, f)
     class(process_instance_t), intent(in) :: sampler
     real(default), intent(out) :: val
     real(default), dimension(:,:), intent(out) :: x
     real(default), dimension(:), intent(out) :: f
     integer, dimension(:), allocatable :: i_terms
     integer :: i, i_term_base, cc
     integer :: n_channel
 
     val = 0
     associate (process => sampler%process)
        FIND_COMPONENT: do i = 1, process%get_n_components ()
          if (sampler%process%component_is_selected (i)) then
             allocate (i_terms (size (process%get_component_i_terms (i))))
             i_terms = process%get_component_i_terms (i)
             i_term_base = i_terms(1)
             associate (k => sampler%kin(i_term_base))
               n_channel = k%n_channel
               do cc = 1, n_channel
                  call k%get_mcpar (cc, x(:,cc))
               end do
               f = k%f
               val = sampler%sqme * k%phs_factor
             end associate
             if (allocated (i_terms)) deallocate (i_terms)
             exit FIND_COMPONENT
          end if
        end do FIND_COMPONENT
     end associate
   end subroutine process_instance_fetch
 
 @ %def process_instance_fetch
 @ Initialize and finalize event generation for the specified MCI
 entry.
 <<Instances: process instance: TBP>>=
   procedure :: init_simulation => process_instance_init_simulation
   procedure :: final_simulation => process_instance_final_simulation
 <<Instances: procedures>>=
   subroutine process_instance_init_simulation (instance, i_mci, &
      safety_factor, keep_failed_events)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     real(default), intent(in), optional :: safety_factor
     logical, intent(in), optional :: keep_failed_events
     call instance%mci_work(i_mci)%init_simulation (safety_factor, keep_failed_events)
   end subroutine process_instance_init_simulation
 
   subroutine process_instance_final_simulation (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     call instance%mci_work(i_mci)%final_simulation ()
   end subroutine process_instance_final_simulation
 
 @ %def process_instance_init_simulation
 @ %def process_instance_final_simulation
 @
 \subsubsection{Accessing the process instance}
 Once the seed kinematics is complete, we can retrieve the MC input parameters
 for all channels, not just the seed channel.
 
 Note: We choose the first active component.  This makes sense only if the seed
 kinematics is identical for all active components.
 <<Instances: process instance: TBP>>=
   procedure :: get_mcpar => process_instance_get_mcpar
 <<Instances: procedures>>=
   subroutine process_instance_get_mcpar (instance, channel, x)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     real(default), dimension(:), intent(out) :: x
     integer :: i
     if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
        do i = 1, size (instance%term)
           if (instance%term(i)%active) then
              call instance%kin(i)%get_mcpar (channel, x)
              return
           end if
        end do
        call msg_bug ("Process instance: get_mcpar: no active channels")
     else
        call msg_bug ("Process instance: get_mcpar: no seed kinematics")
     end if
   end subroutine process_instance_get_mcpar
 
 @ %def process_instance_get_mcpar
 @ Return true if the [[sqme]] value is known.  This also implies that the
 event is kinematically valid and has passed all cuts.
 <<Instances: process instance: TBP>>=
   procedure :: has_evaluated_trace => process_instance_has_evaluated_trace
 <<Instances: procedures>>=
   function process_instance_has_evaluated_trace (instance) result (flag)
     class(process_instance_t), intent(in) :: instance
     logical :: flag
     flag = instance%evaluation_status >= STAT_EVALUATED_TRACE
   end function process_instance_has_evaluated_trace
 
 @ %def process_instance_has_evaluated_trace
 @ Return true if the event is complete.  In particular, the event must
 be kinematically valid, passed all cuts, and the event data have been
 computed.
 <<Instances: process instance: TBP>>=
   procedure :: is_complete_event => process_instance_is_complete_event
 <<Instances: procedures>>=
   function process_instance_is_complete_event (instance) result (flag)
     class(process_instance_t), intent(in) :: instance
     logical :: flag
     flag = instance%evaluation_status >= STAT_EVENT_COMPLETE
   end function process_instance_is_complete_event
 
 @ %def process_instance_is_complete_event
 @ Select the term for the process instance that will provide the basic
 event record (used in [[evt_trivial_make_particle_set]]).  It might be
 necessary to write out additional events corresponding to other terms
 (done in [[evt_nlo]]).
 <<Instances: process instance: TBP>>=
   procedure :: select_i_term => process_instance_select_i_term
 <<Instances: procedures>>=
   function process_instance_select_i_term (instance) result (i_term)
     integer :: i_term
     class(process_instance_t), intent(in) :: instance
     integer :: i_mci
     i_mci = instance%i_mci
     i_term = instance%process%select_i_term (i_mci)
   end function process_instance_select_i_term
 
 @ %def process_instance_select_i_term
 @ Return pointer to the master beam interaction.
 <<Instances: process instance: TBP>>=
   procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr
 <<Instances: procedures>>=
   function process_instance_get_beam_int_ptr (instance) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     type(interaction_t), pointer :: ptr
     ptr => instance%sf_chain%get_beam_int_ptr ()
   end function process_instance_get_beam_int_ptr
 
 @ %def process_instance_get_beam_int_ptr
 @ Return pointers to the matrix and flows interactions, given a term index.
 <<Instances: process instance: TBP>>=
   procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr
   procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr
   procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr
 <<Instances: procedures>>=
   function process_instance_get_trace_int_ptr (instance, i_term) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(interaction_t), pointer :: ptr
     ptr => instance%term(i_term)%connected%get_trace_int_ptr ()
   end function process_instance_get_trace_int_ptr
 
   function process_instance_get_matrix_int_ptr (instance, i_term) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(interaction_t), pointer :: ptr
     ptr => instance%term(i_term)%connected%get_matrix_int_ptr ()
   end function process_instance_get_matrix_int_ptr
 
   function process_instance_get_flows_int_ptr (instance, i_term) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(interaction_t), pointer :: ptr
     ptr => instance%term(i_term)%connected%get_flows_int_ptr ()
   end function process_instance_get_flows_int_ptr
 
 @ %def process_instance_get_trace_int_ptr
 @ %def process_instance_get_matrix_int_ptr
 @ %def process_instance_get_flows_int_ptr
 @ Return the complete account of flavor combinations in the underlying
 interaction object, including beams, radiation, and hard interaction.
 <<Instances: process instance: TBP>>=
   procedure :: get_state_flv => process_instance_get_state_flv
 <<Instances: procedures>>=
   function process_instance_get_state_flv (instance, i_term) result (state_flv)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     type(state_flv_content_t) :: state_flv
     state_flv = instance%term(i_term)%connected%get_state_flv ()
   end function process_instance_get_state_flv
 
 @ %def process_instance_get_state_flv
 @ Return pointers to the parton states of a selected term.
 <<Instances: process instance: TBP>>=
   procedure :: get_isolated_state_ptr => &
        process_instance_get_isolated_state_ptr
   procedure :: get_connected_state_ptr => &
        process_instance_get_connected_state_ptr
 <<Instances: procedures>>=
   function process_instance_get_isolated_state_ptr (instance, i_term) &
        result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(isolated_state_t), pointer :: ptr
     ptr => instance%term(i_term)%isolated
   end function process_instance_get_isolated_state_ptr
 
   function process_instance_get_connected_state_ptr (instance, i_term) &
        result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(connected_state_t), pointer :: ptr
     ptr => instance%term(i_term)%connected
   end function process_instance_get_connected_state_ptr
 
 @ %def process_instance_get_isolated_state_ptr
 @ %def process_instance_get_connected_state_ptr
 @ Return the indices of the beam particles and incoming partons within the
 currently active state matrix, respectively.
 <<Instances: process instance: TBP>>=
   procedure :: get_beam_index => process_instance_get_beam_index
   procedure :: get_in_index => process_instance_get_in_index
 <<Instances: procedures>>=
   subroutine process_instance_get_beam_index (instance, i_term, i_beam)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     integer, dimension(:), intent(out) :: i_beam
     call instance%term(i_term)%connected%get_beam_index (i_beam)
   end subroutine process_instance_get_beam_index
 
   subroutine process_instance_get_in_index (instance, i_term, i_in)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     integer, dimension(:), intent(out) :: i_in
     call instance%term(i_term)%connected%get_in_index (i_in)
   end subroutine process_instance_get_in_index
 
 @ %def process_instance_get_beam_index
 @ %def process_instance_get_in_index
 @ Return squared matrix element and event weight, and event weight
 excess where applicable.  [[n_dropped]] is a number that can be
 nonzero when a weighted event has been generated, dropping events with
 zero weight (failed cuts) on the fly.
 <<Instances: process instance: TBP>>=
   procedure :: get_sqme => process_instance_get_sqme
   procedure :: get_weight => process_instance_get_weight
   procedure :: get_excess => process_instance_get_excess
   procedure :: get_n_dropped => process_instance_get_n_dropped
 <<Instances: procedures>>=
   function process_instance_get_sqme (instance, i_term) result (sqme)
     real(default) :: sqme
     class(process_instance_t), intent(in) :: instance
     integer, intent(in), optional :: i_term
     if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
        if (present (i_term)) then
           sqme = instance%term(i_term)%connected%trace%get_matrix_element (1)
        else
           sqme = instance%sqme
        end if
     else
        sqme = 0
     end if
   end function process_instance_get_sqme
 
   function process_instance_get_weight (instance) result (weight)
     real(default) :: weight
     class(process_instance_t), intent(in) :: instance
     if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
        weight = instance%weight
     else
        weight = 0
     end if
   end function process_instance_get_weight
 
   function process_instance_get_excess (instance) result (excess)
     real(default) :: excess
     class(process_instance_t), intent(in) :: instance
     if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
        excess = instance%excess
     else
        excess = 0
     end if
   end function process_instance_get_excess
 
   function process_instance_get_n_dropped (instance) result (n_dropped)
     integer :: n_dropped
     class(process_instance_t), intent(in) :: instance
     if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
        n_dropped = instance%n_dropped
     else
        n_dropped = 0
     end if
   end function process_instance_get_n_dropped
 
 @ %def process_instance_get_sqme
 @ %def process_instance_get_weight
 @ %def process_instance_get_excess
 @ %def process_instance_get_n_dropped
 @ Return the currently selected MCI channel.
 <<Instances: process instance: TBP>>=
   procedure :: get_channel => process_instance_get_channel
 <<Instances: procedures>>=
   function process_instance_get_channel (instance) result (channel)
     integer :: channel
     class(process_instance_t), intent(in) :: instance
     channel = instance%selected_channel
   end function process_instance_get_channel
 
 @ %def process_instance_get_channel
 @
 <<Instances: process instance: TBP>>=
   procedure :: set_fac_scale => process_instance_set_fac_scale
 <<Instances: procedures>>=
   subroutine process_instance_set_fac_scale (instance, fac_scale)
     class(process_instance_t), intent(inout) :: instance
     real(default), intent(in) :: fac_scale
     integer :: i_term
     i_term = 1
     call instance%term(i_term)%set_fac_scale (fac_scale)
   end subroutine process_instance_set_fac_scale
 
 @ %def process_instance_set_fac_scale
 @ Return factorization scale and strong coupling.  We have to select a
 term instance.
 <<Instances: process instance: TBP>>=
   procedure :: get_fac_scale => process_instance_get_fac_scale
   procedure :: get_alpha_s => process_instance_get_alpha_s
 <<Instances: procedures>>=
   function process_instance_get_fac_scale (instance, i_term) result (fac_scale)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     real(default) :: fac_scale
     fac_scale = instance%term(i_term)%get_fac_scale ()
   end function process_instance_get_fac_scale
 
   function process_instance_get_alpha_s (instance, i_term) result (alpha_s)
     real(default) :: alpha_s
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     class(prc_core_t), pointer :: core => null ()
     core => instance%process%get_core_term (i_term)
     alpha_s = instance%term(i_term)%get_alpha_s (core)
     core => null ()
   end function process_instance_get_alpha_s
 
 @ %def process_instance_get_fac_scale
 @ %def process_instance_get_alpha_s
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_qcd => process_instance_get_qcd
 <<Instances: procedures>>=
   function process_instance_get_qcd (process_instance) result (qcd)
     type(qcd_t) :: qcd
     class(process_instance_t), intent(in) :: process_instance
     qcd = process_instance%process%get_qcd ()
   end function process_instance_get_qcd
 
 @ %def process_instance_get_qcd
 @ Counter.
 <<Instances: process instance: TBP>>=
   procedure :: reset_counter => process_instance_reset_counter
   procedure :: record_call => process_instance_record_call
   procedure :: get_counter => process_instance_get_counter
 <<Instances: procedures>>=
   subroutine process_instance_reset_counter (process_instance)
     class(process_instance_t), intent(inout) :: process_instance
     call process_instance%mci_work(process_instance%i_mci)%reset_counter ()
   end subroutine process_instance_reset_counter
 
   subroutine process_instance_record_call (process_instance)
     class(process_instance_t), intent(inout) :: process_instance
     call process_instance%mci_work(process_instance%i_mci)%record_call &
          (process_instance%evaluation_status)
   end subroutine process_instance_record_call
 
   pure function process_instance_get_counter (process_instance) result (counter)
     class(process_instance_t), intent(in) :: process_instance
     type(process_counter_t) :: counter
     counter = process_instance%mci_work(process_instance%i_mci)%get_counter ()
   end function process_instance_get_counter
 
 @ %def process_instance_reset_counter
 @ %def process_instance_record_call
 @ %def process_instance_get_counter
 @ Sum up the total number of calls for all MCI records.
 <<Instances: process instance: TBP>>=
   procedure :: get_actual_calls_total => process_instance_get_actual_calls_total
 <<Instances: procedures>>=
   pure function process_instance_get_actual_calls_total (process_instance) &
        result (n)
     class(process_instance_t), intent(in) :: process_instance
     integer :: n
     integer :: i
     type(process_counter_t) :: counter
     n = 0
     do i = 1, size (process_instance%mci_work)
        counter = process_instance%mci_work(i)%get_counter ()
        n = n + counter%total
     end do
   end function process_instance_get_actual_calls_total
 
 @ %def process_instance_get_actual_calls_total
 @
 <<Instances: process instance: TBP>>=
   procedure :: reset_matrix_elements => process_instance_reset_matrix_elements
 <<Instances: procedures>>=
   subroutine process_instance_reset_matrix_elements (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_term
     do i_term = 1, size (instance%term)
        call instance%term(i_term)%connected%trace%set_matrix_element (cmplx (0, 0, default))
        call instance%term(i_term)%connected%matrix%set_matrix_element (cmplx (0, 0, default))
     end do
   end subroutine process_instance_reset_matrix_elements
 
 @ %def process_instance_reset_matrix_elements
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_test_phase_space_point &
      => process_instance_get_test_phase_space_point
 <<Instances: procedures>>=
   subroutine process_instance_get_test_phase_space_point (instance, &
          i_component, i_core, p)
     type(vector4_t), dimension(:), allocatable, intent(out) :: p
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_component, i_core
     real(default), dimension(:), allocatable :: x
     logical :: success
     integer :: i_term
     instance%i_mci = i_component
     i_term = instance%process%get_i_term (i_core)
     associate (term => instance%term(i_term), kin => instance%kin(i_term))
        allocate (x (instance%mci_work(i_component)%config%n_par))
        x = 0.5_default
        call instance%set_mcpar (x, .true.)
        call instance%select_channel (1)
        call term%compute_seed_kinematics &
             (kin, instance%mci_work(i_component), 1, success)
        call kin%evaluate_radiation_kinematics &
             (instance%mci_work(instance%i_mci)%get_x_process ())
        call term%compute_hard_kinematics (kin, success = success)
        allocate (p (size (term%p_hard)))
        p = term%int_hard%get_momenta ()
     end associate
   end subroutine process_instance_get_test_phase_space_point
 
 @ %def process_instance_get_test_phase_space_point
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_p_hard => process_instance_get_p_hard
 <<Instances: procedures>>=
   pure function process_instance_get_p_hard (process_instance, i_term) &
          result (p_hard)
     type(vector4_t), dimension(:), allocatable :: p_hard
     class(process_instance_t), intent(in) :: process_instance
     integer, intent(in) :: i_term
     allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ())))
     p_hard = process_instance%term(i_term)%get_p_hard ()
   end function process_instance_get_p_hard
 
 @ %def process_instance_get_p_hard
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_first_active_i_term => process_instance_get_first_active_i_term
 <<Instances: procedures>>=
   function process_instance_get_first_active_i_term (instance) result (i_term)
     integer :: i_term
     class(process_instance_t), intent(in) :: instance
     integer :: i
     i_term = 0
     do i = 1, size (instance%term)
        if (instance%term(i)%active) then
           i_term = i
           exit
        end if
     end do
   end function process_instance_get_first_active_i_term
 
 @ %def process_instance_get_first_active_i_term
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_real_of_mci => process_instance_get_real_of_mci
 <<Instances: procedures>>=
   function process_instance_get_real_of_mci (instance) result (i_real)
     integer :: i_real
     class(process_instance_t), intent(in) :: instance
     select type (pcm_work => instance%pcm_work)
     type is (pcm_nlo_workspace_t)
        i_real = pcm_work%i_mci_to_real_component (instance%i_mci)
     end select
   end function process_instance_get_real_of_mci
 
 @ %def process_instance_get_real_of_mci
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_connected_states => process_instance_get_connected_states
 <<Instances: procedures>>=
   function process_instance_get_connected_states (instance, i_component) result (connected)
     type(connected_state_t), dimension(:), allocatable :: connected
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_component
     connected = instance%process%get_connected_states (i_component, &
         instance%term(:)%connected)
   end function process_instance_get_connected_states
 
 @ %def process_instance_get_connected_states
 @ Get the hadronic center-of-mass energy
 <<Instances: process instance: TBP>>=
   procedure :: get_sqrts => process_instance_get_sqrts
 <<Instances: procedures>>=
   function process_instance_get_sqrts (instance) result (sqrts)
     class(process_instance_t), intent(in) :: instance
     real(default) :: sqrts
     sqrts = instance%process%get_sqrts ()
   end function process_instance_get_sqrts
 
 @ %def process_instance_get_sqrts
 @ Get the polarizations
 <<Instances: process instance: TBP>>=
   procedure :: get_polarization => process_instance_get_polarization
 <<Instances: procedures>>=
   function process_instance_get_polarization (instance) result (pol)
     class(process_instance_t), intent(in) :: instance
     real(default), dimension(2) :: pol
     pol = instance%process%get_polarization ()
   end function process_instance_get_polarization
 
 @ %def process_instance_get_polarization
 @ Get the beam spectrum
 <<Instances: process instance: TBP>>=
   procedure :: get_beam_file => process_instance_get_beam_file
 <<Instances: procedures>>=
   function process_instance_get_beam_file (instance) result (file)
     class(process_instance_t), intent(in) :: instance
     type(string_t) :: file
     file = instance%process%get_beam_file ()
   end function process_instance_get_beam_file
 
 @ %def process_instance_get_beam_file
 @ Get the process name
 <<Instances: process instance: TBP>>=
   procedure :: get_process_name => process_instance_get_process_name
 <<Instances: procedures>>=
   function process_instance_get_process_name (instance) result (name)
     class(process_instance_t), intent(in) :: instance
     type(string_t) :: name
     name = instance%process%get_id ()
   end function process_instance_get_process_name
 
 @ %def process_instance_get_process_name
 @
 \subsubsection{Particle sets}
 Here we provide two procedures that convert the process instance
 from/to a particle set.  The conversion applies to the trace evaluator
 which has no quantum-number information, thus it involves only the
 momenta and the parent-child relations.  We keep virtual particles.
 
 If [[n_incoming]] is provided, the status code of the first
 [[n_incoming]] particles will be reset to incoming.  Otherwise, they
 would be classified as virtual.
 
 Nevertheless, it is possible to reconstruct the complete structure
 from a particle set.  The reconstruction implies a re-evaluation of
 the structure function and matrix-element codes.
 
 The [[i_term]] index is needed for both input and output, to select
 among different active trace evaluators.
 
 In both cases, the [[instance]] object must be properly initialized.
 
 NB: The [[recover_beams]] option should be used only when the particle
 set originates from an external event file, and the user has asked for
 it.  It should be switched off when reading from raw event file.
 <<Instances: process instance: TBP>>=
   procedure :: get_trace => process_instance_get_trace
   procedure :: set_trace => process_instance_set_trace
 <<Instances: procedures>>=
   subroutine process_instance_get_trace (instance, pset, i_term, n_incoming)
     class(process_instance_t), intent(in), target :: instance
     type(particle_set_t), intent(out) :: pset
     integer, intent(in) :: i_term
     integer, intent(in), optional :: n_incoming
     type(interaction_t), pointer :: int
     logical :: ok
     int => instance%get_trace_int_ptr (i_term)
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true., n_incoming)
   end subroutine process_instance_get_trace
 
   subroutine process_instance_set_trace &
        (instance, pset, i_term, recover_beams, check_match, success)
     class(process_instance_t), intent(inout), target :: instance
     type(particle_set_t), intent(in) :: pset
     integer, intent(in) :: i_term
     logical, intent(in), optional :: recover_beams, check_match
     logical, intent(out), optional :: success
     type(interaction_t), pointer :: int
     integer :: n_in
     int => instance%get_trace_int_ptr (i_term)
     n_in = instance%process%get_n_in ()
     call pset%fill_interaction (int, n_in, &
          recover_beams = recover_beams, &
          check_match = check_match, &
          state_flv = instance%get_state_flv (i_term), &
          success = success)
   end subroutine process_instance_set_trace
 
 @ %def process_instance_get_trace
 @ %def process_instance_set_trace
 @ This procedure allows us to override any QCD setting of the WHIZARD process
 and directly set the coupling value that comes together with a particle set.
 <<Instances: process instance: TBP>>=
   procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced
 <<Instances: procedures>>=
   subroutine process_instance_set_alpha_qcd_forced (instance, i_term, alpha_qcd)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     real(default), intent(in) :: alpha_qcd
     call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd)
   end subroutine process_instance_set_alpha_qcd_forced
 
 @ %def process_instance_set_alpha_qcd_forced
 @
 <<Instances: process instance: TBP>>=
   procedure :: has_nlo_component => process_instance_has_nlo_component
 <<Instances: procedures>>=
   function process_instance_has_nlo_component (instance) result (nlo)
     class(process_instance_t), intent(in) :: instance
     logical :: nlo
     nlo = instance%process%is_nlo_calculation ()
   end function process_instance_has_nlo_component
 
 @ %def process_instance_has_nlo_component
 @
 <<Instances: process instance: TBP>>=
   procedure :: keep_failed_events => process_instance_keep_failed_events
 <<Instances: procedures>>=
   function process_instance_keep_failed_events (instance) result (keep)
     logical :: keep
     class(process_instance_t), intent(in) :: instance
     keep = instance%mci_work(instance%i_mci)%keep_failed_events
   end function process_instance_keep_failed_events
 
 @ %def process_instance_keep_failed_events
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_term_indices => process_instance_get_term_indices
 <<Instances: procedures>>=
   function process_instance_get_term_indices (instance, nlo_type) result (i_term)
     integer, dimension(:), allocatable :: i_term
     class(process_instance_t), intent(in) :: instance
     integer :: nlo_type
     allocate (i_term (count (instance%term%nlo_type == nlo_type)))
     i_term = pack (instance%term%get_i_term_global (), instance%term%nlo_type == nlo_type)
   end function process_instance_get_term_indices
 
 @ %def process_instance_get_term_indices
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_boost_to_lab => process_instance_get_boost_to_lab
 <<Instances: procedures>>=
   function process_instance_get_boost_to_lab (instance, i_term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     lt = instance%kin(i_term)%get_boost_to_lab ()
   end function process_instance_get_boost_to_lab
 
 @ %def process_instance_get_boost_to_lab
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_boost_to_cms => process_instance_get_boost_to_cms
 <<Instances: procedures>>=
   function process_instance_get_boost_to_cms (instance, i_term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     lt = instance%kin(i_term)%get_boost_to_cms ()
   end function process_instance_get_boost_to_cms
 
 @ %def process_instance_get_boost_to_cms
 @
 <<Instances: process instance: TBP>>=
   procedure :: lab_is_cm => process_instance_lab_is_cm
 <<Instances: procedures>>=
   function process_instance_lab_is_cm (instance, i_term) result (lab_is_cm)
     logical :: lab_is_cm
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     lab_is_cm = instance%kin(i_term)%phs%lab_is_cm ()
   end function process_instance_lab_is_cm
 
 @ %def process_instance_lab_is_cm
 @
 The [[pacify]] subroutine has the purpose of setting numbers to zero
 which are (by comparing with a [[tolerance]] parameter) considered
 equivalent with zero.  We do this in some unit tests.  Here, we a
 apply this to the phase space subobject of the process instance.
 <<Instances: public>>=
   public :: pacify
 <<Instances: interfaces>>=
   interface pacify
      module procedure pacify_process_instance
   end interface pacify
 
 <<Instances: procedures>>=
   subroutine pacify_process_instance (instance)
     type(process_instance_t), intent(inout) :: instance
     integer :: i
     do i = 1, size (instance%kin)
        call pacify (instance%kin(i)%phs)
     end do
   end subroutine pacify_process_instance
 
 @ %def pacify
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[processes_ut.f90]]>>=
 <<File header>>
 
 module processes_ut
   use unit_tests
   use processes_uti
 
 <<Standard module head>>
 
 <<Processes: public test>>
 
 <<Processes: public test auxiliary>>
 
 contains
 
 <<Processes: test driver>>
 
 end module processes_ut
 @ %def processes_ut
 @
 <<[[processes_uti.f90]]>>=
 <<File header>>
 
 module processes_uti
 
 <<Use kinds>>
 <<Use strings>>
   use format_utils, only: write_separator
   use constants, only: TWOPI4
   use physics_defs, only: CONV
   use os_interface
   use sm_qcd
   use lorentz
   use pdg_arrays
   use model_data
   use models
   use var_base, only: vars_t
   use variables, only: var_list_t
   use model_testbed, only: prepare_model
   use particle_specifiers, only: new_prt_spec
   use flavors
   use interactions, only: reset_interaction_counter
   use particles
   use rng_base
   use mci_base
   use mci_none, only: mci_none_t
   use mci_midpoint
   use sf_mappings
   use sf_base
   use phs_base
   use phs_single
   use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
   use phs_wood, only: phs_wood_config_t
   use resonances, only: resonance_history_set_t
   use process_constants
   use prc_core_def, only: prc_core_def_t
   use prc_core
   use prc_test, only: prc_test_create_library
   use prc_template_me, only: template_me_def_t
   use process_libraries
   use prc_test_core
 
   use process_counter
   use process_config, only: process_term_t
   use process, only: process_t
   use instances, only: process_instance_t, process_instance_hook_t
 
   use rng_base_ut, only: rng_test_factory_t
   use sf_base_ut, only: sf_test_data_t
   use mci_base_ut, only: mci_test_t
   use phs_base_ut, only: phs_test_config_t
 
 <<Standard module head>>
 
 <<Processes: public test auxiliary>>
 
 <<Processes: test declarations>>
 
 <<Processes: test types>>
 
 contains
 
 <<Processes: tests>>
 
 <<Processes: test auxiliary>>
 
 end module processes_uti
 
 @ %def processes_uti
 @ API: driver for the unit tests below.
 <<Processes: public test>>=
   public :: processes_test
 <<Processes: test driver>>=
   subroutine processes_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Processes: execute tests>>
   end subroutine processes_test
 
 @ %def processes_test
 \subsubsection{Write an empty process object}
 The most trivial test is to write an uninitialized process object.
 <<Processes: execute tests>>=
   call test (processes_1, "processes_1", &
        "write an empty process object", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_1
 <<Processes: tests>>=
   subroutine processes_1 (u)
     integer, intent(in) :: u
     type(process_t) :: process
 
     write (u, "(A)")  "* Test output: processes_1"
     write (u, "(A)")  "*   Purpose: display an empty process object"
     write (u, "(A)")
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_1"
 
   end subroutine processes_1
 
 @ %def processes_1
 @
 \subsubsection{Initialize a process object}
 Initialize a process and display it.
 <<Processes: execute tests>>=
   call test (processes_2, "processes_2", &
        "initialize a simple process object", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_2
 <<Processes: tests>>=
   subroutine processes_2 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable :: process
     class(mci_t), allocatable :: mci_template
     class(phs_config_t), allocatable :: phs_config_template
 
     write (u, "(A)")  "* Test output: processes_2"
     write (u, "(A)")  "*   Purpose: initialize a simple process object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes2"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     write (u, "(A)")  "* Initialize a process object"
     write (u, "(A)")
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
     call process%set_run_id (var_str ("run_2"))
     call process%setup_test_cores ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     call process%setup_mci (dispatch_mci_empty)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_2"
 
   end subroutine processes_2
 
 @ %def processes_2
 @ Trivial for testing: do not allocate the MCI record.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
   end subroutine dispatch_mci_empty
 
 @ %def dispatch_mci_empty
 @
 \subsubsection{Compute a trivial matrix element}
 Initialize a process, retrieve some information and compute a matrix
 element.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Processes: execute tests>>=
   call test (processes_3, "processes_3", &
        "retrieve a trivial matrix element", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_3
 <<Processes: tests>>=
   subroutine processes_3 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_constants_t) :: data
     type(vector4_t), dimension(:), allocatable :: p
 
     write (u, "(A)")  "* Test output: processes_3"
     write (u, "(A)")  "*   Purpose: create a process &
          &and compute a matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes3"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
     call process%setup_test_cores ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
     call process%setup_mci (dispatch_mci_test3)
 
     write (u, "(A)")  "* Return the number of process components"
     write (u, "(A)")
 
     write (u, "(A,I0)")  "n_components = ", process%get_n_components ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Return the number of flavor states"
     write (u, "(A)")
 
     data = process%get_constants (1)
 
     write (u, "(A,I0)")  "n_flv(1) = ", data%n_flv
 
     write (u, "(A)")
     write (u, "(A)")  "* Return the first flavor state"
     write (u, "(A)")
 
     write (u, "(A,4(1x,I0))")  "flv_state(1) =", data%flv_state (:,1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up kinematics &
          &[arbitrary, the matrix element is constant]"
 
     allocate (p (4))
 
     write (u, "(A)")
     write (u, "(A)")  "* Retrieve the matrix element"
     write (u, "(A)")
 
 
     write (u, "(A,F5.3,' + ',F5.3,' I')")  "me (1, p, 1, 1, 1) = ", &
          process%compute_amplitude (1, 1, 1, p, 1, 1, 1)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_3"
 
   end subroutine processes_3
 
 @ %def processes_3
 @ MCI record with some contents.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_test_t :: mci)
     select type (mci)
     type is (mci_test_t)
        call mci%set_dimensions (2, 2)
        call mci%set_divisions (100)
     end select
   end subroutine dispatch_mci_test3
 
 @ %def dispatch_mci_test3
 @
 \subsubsection{Generate a process instance}
 Initialize a process and process instance, choose a sampling point and
 fill the process instance.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Processes: execute tests>>=
   call test (processes_4, "processes_4", &
        "create and fill a process instance (partonic event)", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_4
 <<Processes: tests>>=
   subroutine processes_4 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_4"
     write (u, "(A)")  "*   Purpose: create a process &
          &and fill a process instance"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a test process"
     write (u, "(A)")
 
     libname = "processes4"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_empty)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inject a set of random numbers"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%set_mcpar ([0._default, 0._default])
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up hard kinematics"
     write (u, "(A)")
 
     call process_instance%select_channel (1)
     call process_instance%compute_seed_kinematics ()
     call process_instance%compute_hard_kinematics ()
     call process_instance%compute_eff_kinematics ()
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels ()
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
 
     call process_instance%activate ()
     process_instance%evaluation_status = STAT_EFF_KINEMATICS
     call process_instance%recover_hard_kinematics (i_term = 1)
     call process_instance%recover_seed_kinematics (i_term = 1)
     call process_instance%select_channel (1)
     call process_instance%recover_mcpar (i_term = 1)
 
     call process_instance%compute_seed_kinematics (skip_term = 1)
     call process_instance%compute_hard_kinematics (skip_term = 1)
     call process_instance%compute_eff_kinematics (skip_term = 1)
 
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels (skip_term = 1)
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_4"
 
   end subroutine processes_4
 
 @ %def processes_4
 @
 \subsubsection{Structure function configuration}
 Configure structure functions (multi-channel) in a process object.
 <<Processes: execute tests>>=
   call test (processes_7, "processes_7", &
        "process configuration with structure functions", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_7
 <<Processes: tests>>=
   subroutine processes_7 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t), dimension(2) :: sf_channel
 
     write (u, "(A)")  "* Test output: processes_7"
     write (u, "(A)")  "*   Purpose: initialize a process with &
          &structure functions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes7"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call process%test_allocate_sf_channels (3)
 
     call sf_channel(1)%init (2)
     call sf_channel(1)%activate_mapping ([1,2])
     call process%set_sf_channel (2, sf_channel(1))
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%set_s_mapping ([1,2])
     call process%set_sf_channel (3, sf_channel(2))
 
     call process%setup_mci (dispatch_mci_empty)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_7"
 
   end subroutine processes_7
 
 @ %def processes_7
 @
 \subsubsection{Evaluating a process with structure function}
 Configure structure functions (single-channel) in a process object,
 create an instance, compute kinematics and evaluate.
 
 Note the order of operations when setting up structure functions and
 phase space.  The beams are first, they determine the [[sqrts]] value.
 We can also set up the chain of structure functions.  We then
 configure the phase space.  From this, we can obtain information about
 special configurations (resonances, etc.), which we need for
 allocating the possible structure-function channels (parameterizations
 and mappings).  Finally, we match phase-space channels onto
 structure-function channels.
 
 In the current example, this matching is trivial; we only have one
 structure-function channel.
 <<Processes: execute tests>>=
   call test (processes_8, "processes_8", &
        "process evaluation with structure functions", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_8
 <<Processes: tests>>=
   subroutine processes_8 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t) :: sf_channel
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_8"
     write (u, "(A)")  "*   Purpose: evaluate a process with &
          &structure functions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes8"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call process%configure_phs ()
 
     call process%test_allocate_sf_channels (1)
 
     call sf_channel%init (2)
     call sf_channel%activate_mapping ([1,2])
     call process%set_sf_channel (1, sf_channel)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_mci (dispatch_mci_empty)
     call process%setup_terms ()
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Set up kinematics and evaluate"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%evaluate_sqme (1, &
          [0.8_default, 0.8_default, 0.1_default, 0.2_default])
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (2)
 
     allocate (process_instance)
     call process_instance%init (process)
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover &
          (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_8"
 
   end subroutine processes_8
 
 @ %def processes_8
 @
 \subsubsection{Multi-channel phase space and structure function}
 This is an extension of the previous example.  This time, we have two
 distinct structure-function channels which are matched to the two
 distinct phase-space channels.
 <<Processes: execute tests>>=
   call test (processes_9, "processes_9", &
        "multichannel kinematics and structure functions", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_9
 <<Processes: tests>>=
   subroutine processes_9 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t) :: sf_channel
     real(default), dimension(4) :: x_saved
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_9"
     write (u, "(A)")  "*   Purpose: evaluate a process with &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes9"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call process%configure_phs ()
 
     call process%test_allocate_sf_channels (2)
 
     call sf_channel%init (2)
     call process%set_sf_channel (1, sf_channel)
 
     call sf_channel%init (2)
     call sf_channel%activate_mapping ([1,2])
     call process%set_sf_channel (2, sf_channel)
 
     call process%test_set_component_sf_channel ([1, 2])
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_mci (dispatch_mci_empty)
     call process%setup_terms ()
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Set up kinematics in channel 1 and evaluate"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%evaluate_sqme (1, &
          [0.8_default, 0.8_default, 0.1_default, 0.2_default])
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract MC input parameters"
     write (u, "(A)")
 
     write (u, "(A)")  "Channel 1:"
     call process_instance%get_mcpar (1, x_saved)
     write (u, "(2x,9(1x,F7.5))")  x_saved
 
     write (u, "(A)")  "Channel 2:"
     call process_instance%get_mcpar (2, x_saved)
     write (u, "(2x,9(1x,F7.5))")  x_saved
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up kinematics in channel 2 and evaluate"
     write (u, "(A)")
 
     call process_instance%evaluate_sqme (2, x_saved)
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance for channel 2"
     write (u, "(A)")
 
     call reset_interaction_counter (2)
 
     allocate (process_instance)
     call process_instance%init (process)
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover &
          (channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_9"
 
   end subroutine processes_9
 
 @ %def processes_9
 @
 \subsubsection{Event generation}
 Activate the MC integrator for the process object and use it to
 generate a single event.  Note that the test integrator does not
 require integration in preparation for generating events.
 <<Processes: execute tests>>=
   call test (processes_10, "processes_10", &
        "event generation", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_10
 <<Processes: tests>>=
   subroutine processes_10 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(mci_t), pointer :: mci
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
 
     write (u, "(A)")  "* Test output: processes_10"
     write (u, "(A)")  "*   Purpose: generate events for a process without &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes10"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     call process%setup_mci (dispatch_mci_test10)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Generate weighted event"
     write (u, "(A)")
 
     call process%test_get_mci_ptr (mci)
     select type (mci)
     type is (mci_test_t)
        ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
        call mci%rng%init (3)
        ! Include the constant PHS factor in the stored maximum of the integrand
        call mci%set_max_factor (conv * twopi4 &
             / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2))))
     end select
 
     call process_instance%generate_weighted_event (1)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate unweighted event"
     write (u, "(A)")
 
     call process_instance%generate_unweighted_event (1)
     call process%test_get_mci_ptr (mci)
     select type (mci)
     type is (mci_test_t)
        write (u, "(A,I0)")  " Success in try ", mci%tries
        write (u, "(A)")
     end select
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_10"
 
   end subroutine processes_10
 
 @ %def processes_10
 @ MCI record with some contents.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_test_t :: mci)
     select type (mci)
     type is (mci_test_t);  call mci%set_divisions (100)
     end select
   end subroutine dispatch_mci_test10
 
 @ %def dispatch_mci_test10
 @
 \subsubsection{Integration}
 Activate the MC integrator for the process object and use it to
 integrate over phase space.
 <<Processes: execute tests>>=
   call test (processes_11, "processes_11", &
        "integration", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_11
 <<Processes: tests>>=
   subroutine processes_11 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(mci_t), allocatable :: mci_template
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
 
     write (u, "(A)")  "* Test output: processes_11"
     write (u, "(A)")  "*   Purpose: integrate a process without &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes11"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     call process%setup_mci (dispatch_mci_test10)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Integrate with default test parameters"
     write (u, "(A)")
 
     call process_instance%integrate (1, n_it=1, n_calls=10000)
     call process%final_integration (1)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A,ES13.7)")  " Integral divided by phs factor = ", &
          process%get_integral (1) &
          / process_instance%kin(1)%phs_factor
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_11"
 
   end subroutine processes_11
 
 @ %def processes_11
 @
 \subsubsection{Complete events}
 For the purpose of simplifying further tests, we implement a
 convenience routine that initializes a process and prepares a single
 event.  This is a wrapup of the test [[processes_10]].
 
 The procedure is re-exported by the [[processes_ut]] module.
 <<Processes: public test auxiliary>>=
   public :: prepare_test_process
 <<Processes: test auxiliary>>=
   subroutine prepare_test_process &
        (process, process_instance, model, var_list, run_id)
     type(process_t), intent(out), target :: process
     type(process_instance_t), intent(out), target :: process_instance
     class(model_data_t), intent(in), target :: model
     type(var_list_t), intent(inout), optional :: var_list
     type(string_t), intent(in), optional :: run_id
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), allocatable, target :: process_model
     class(mci_t), pointer :: mci
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     libname = "processes_test"
     procname = libname
     call os_data%init ()
     call prc_test_create_library (libname, lib)
     call reset_interaction_counter ()
     allocate (process_model)
     call process_model%init (model%get_name (), &
          model%get_n_real (), &
          model%get_n_complex (), &
          model%get_n_field (), &
          model%get_n_vtx ())
     call process_model%copy_from (model)
     call process%init (procname, lib, os_data, process_model, var_list)
     if (present (run_id))  call process%set_run_id (run_id)
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_test10)
     call process%setup_terms ()
     call process_instance%init (process)
     call process%test_get_mci_ptr (mci)
     select type (mci)
     type is (mci_test_t)
        ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
        call mci%rng%init (3)
        ! Include the constant PHS factor in the stored maximum of the integrand
        call mci%set_max_factor (conv * twopi4 &
             / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2))))
     end select
     call process%reset_library_ptr ()  ! avoid dangling pointer
     call process_model%final ()
   end subroutine prepare_test_process
 
 @ %def prepare_test_process
 @ Here we do the cleanup of the process and process instance emitted
 by the previous routine.
 <<Processes: public test auxiliary>>=
   public :: cleanup_test_process
 <<Processes: test auxiliary>>=
   subroutine cleanup_test_process (process, process_instance)
     type(process_t), intent(inout) :: process
     type(process_instance_t), intent(inout) :: process_instance
     call process_instance%final ()
     call process%final ()
   end subroutine cleanup_test_process
 
 @ %def cleanup_test_process
 @
 This is the actual test.  Prepare the test process and event, fill
 all evaluators, and display the results.  Use a particle set as
 temporary storage, read kinematics and recalculate the event.
 <<Processes: execute tests>>=
   call test (processes_12, "processes_12", &
        "event post-processing", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_12
 <<Processes: tests>>=
   subroutine processes_12 (u)
     integer, intent(in) :: u
     type(process_t), allocatable, target :: process
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: processes_12"
     write (u, "(A)")  "*   Purpose: generate a complete partonic event"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Build and initialize process and process instance &
          &and generate event"
     write (u, "(A)")
 
     allocate (process)
     allocate (process_instance)
     call prepare_test_process (process, process_instance, model, &
          run_id = var_str ("run_12"))
     call process_instance%setup_event_data (i_core = 1)
 
     call process%prepare_simulation (1)
     call process_instance%init_simulation (1)
     call process_instance%generate_weighted_event (1)
     call process_instance%evaluate_event_data ()
 
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
 
     call process_instance%final_simulation (1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover kinematics and recalculate"
     write (u, "(A)")
 
     call reset_interaction_counter (2)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%setup_event_data ()
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover &
          (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
 
     call process_instance%recover_event ()
     call process_instance%evaluate_event_data ()
 
     call process_instance%write (u)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call cleanup_test_process (process, process_instance)
     deallocate (process_instance)
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_12"
 
   end subroutine processes_12
 
 @ %def processes_12
 @
 \subsubsection{Colored interaction}
 This test specifically checks the transformation of process data
 (flavor, helicity, and color) into an interaction in a process term.
 
 We use the [[test_t]] process core (which has no nontrivial
 particles), but call only the [[is_allowed]] method, which always
 returns true.
 <<Processes: execute tests>>=
   call test (processes_13, "processes_13", &
        "colored interaction", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_13
 <<Processes: tests>>=
   subroutine processes_13 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(process_term_t) :: term
     class(prc_core_t), allocatable :: core
 
     write (u, "(A)")  "* Test output: processes_13"
     write (u, "(A)")  "*   Purpose: initialized a colored interaction"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a process constants block"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_sm_test ()
 
     allocate (test_t :: core)
 
     associate (data => term%data)
       data%n_in = 2
       data%n_out = 3
       data%n_flv = 2
       data%n_hel = 2
       data%n_col = 2
       data%n_cin = 2
 
       allocate (data%flv_state (5, 2))
       data%flv_state (:,1) = [ 1, 21, 1, 21, 21]
       data%flv_state (:,2) = [ 2, 21, 2, 21, 21]
 
       allocate (data%hel_state (5, 2))
       data%hel_state (:,1) = [1, 1, 1, 1, 0]
       data%hel_state (:,2) = [1,-1, 1,-1, 0]
 
       allocate (data%col_state (2, 5, 2))
       data%col_state (:,:,1) = &
            reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5])
       data%col_state (:,:,2) = &
            reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5])
 
       allocate (data%ghost_flag (5, 2))
       data%ghost_flag(1:4,:) = .false.
       data%ghost_flag(5,:) = .true.
 
     end associate
 
     write (u, "(A)")  "* Set up the interaction"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call term%setup_interaction (core, model)
     call term%int%basic_write (u)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_13"
   end subroutine processes_13
 
 @ %def processes_13
 @
 \subsubsection{MD5 sums}
 Configure a process with structure functions (multi-channel) and
 compute MD5 sums
 <<Processes: execute tests>>=
   call test (processes_14, "processes_14", &
        "process configuration and MD5 sum", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_14
 <<Processes: tests>>=
   subroutine processes_14 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t), dimension(3) :: sf_channel
 
     write (u, "(A)")  "* Test output: processes_14"
     write (u, "(A)")  "*   Purpose: initialize a process with &
          &structure functions"
     write (u, "(A)")  "*            and compute MD5 sum"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes7"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
     call lib%compute_md5sum ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     call process%test_allocate_sf_channels (3)
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call sf_channel(1)%init (2)
     call process%set_sf_channel (1, sf_channel(1))
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([1,2])
     call process%set_sf_channel (2, sf_channel(2))
 
     call sf_channel(3)%init (2)
     call sf_channel(3)%set_s_mapping ([1,2])
     call process%set_sf_channel (3, sf_channel(3))
 
     call process%setup_mci (dispatch_mci_empty)
 
     call process%compute_md5sum ()
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_14"
 
   end subroutine processes_14
 
 @ %def processes_14
 @
 \subsubsection{Decay Process Evaluation}
 Initialize an evaluate a decay process.
 <<Processes: execute tests>>=
   call test (processes_15, "processes_15", &
        "decay process", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_15
 <<Processes: tests>>=
   subroutine processes_15 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_15"
     write (u, "(A)")  "*   Purpose: initialize a decay process object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes15"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib, scattering = .false., &
          decay = .true.)
 
     call model%init_test ()
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
 
     write (u, "(A)")  "* Initialize a process object"
     write (u, "(A)")
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_single_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     call process%setup_beams_decay (i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_empty)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inject a set of random numbers"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%set_mcpar ([0._default, 0._default])
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up hard kinematics"
     write (u, "(A)")
 
     call process_instance%select_channel (1)
     call process_instance%compute_seed_kinematics ()
     call process_instance%compute_hard_kinematics ()
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%compute_eff_kinematics ()
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels ()
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover (1, 1, .true., .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_15"
 
   end subroutine processes_15
 
 @ %def processes_15
 @
 \subsubsection{Integration: decay}
 Activate the MC integrator for the decay object and use it to
 integrate over phase space.
 <<Processes: execute tests>>=
   call test (processes_16, "processes_16", &
        "decay integration", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_16
 <<Processes: tests>>=
   subroutine processes_16 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_instance_t), allocatable, target :: process_instance
 
     write (u, "(A)")  "* Test output: processes_16"
     write (u, "(A)")  "*   Purpose: integrate a process without &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes16"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib, scattering = .false., &
          decay = .true.)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_single_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     call process%setup_beams_decay (i_core = 1)
     call process%configure_phs ()
 
     call process%setup_mci (dispatch_mci_test_midpoint)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Integrate with default test parameters"
     write (u, "(A)")
 
     call process_instance%integrate (1, n_it=1, n_calls=10000)
     call process%final_integration (1)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A,ES13.7)")  " Integral divided by phs factor = ", &
          process%get_integral (1) &
          / process_instance%kin(1)%phs_factor
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_16"
 
   end subroutine processes_16
 
 @ %def processes_16
 @ MCI record prepared for midpoint integrator.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_midpoint_t :: mci)
   end subroutine dispatch_mci_test_midpoint
 
 @ %def dispatch_mci_test_midpoint
 @
 \subsubsection{Decay Process Evaluation}
 Initialize an evaluate a decay process for a moving particle.
 <<Processes: execute tests>>=
   call test (processes_17, "processes_17", &
        "decay of moving particle", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_17
 <<Processes: tests>>=
   subroutine processes_17 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
     type(flavor_t) :: flv_beam
     real(default) :: m, p, E
 
     write (u, "(A)")  "* Test output: processes_17"
     write (u, "(A)")  "*   Purpose: initialize a decay process object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes17"
     procname = libname
 
     call os_data%init ()
 
     call prc_test_create_library (libname, lib, scattering = .false., &
          decay = .true.)
 
     write (u, "(A)")  "* Initialize a process object"
     write (u, "(A)")
 
     call model%init_test ()
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_single_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     call process%setup_beams_decay (rest_frame = .false., i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_empty)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parent momentum and random numbers"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%set_mcpar ([0._default, 0._default])
 
     call flv_beam%init (25, process%get_model_ptr ())
     m = flv_beam%get_mass ()
     p = 3 * m / 4
     E = sqrt (m**2 + p**2)
     call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)])
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up hard kinematics"
     write (u, "(A)")
 
     call process_instance%select_channel (1)
     call process_instance%compute_seed_kinematics ()
     call process_instance%compute_hard_kinematics ()
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%compute_eff_kinematics ()
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels ()
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover (1, 1, .true., .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_17"
 
   end subroutine processes_17
 
 @ %def processes_17
 @
 \subsubsection{Resonances in Phase Space}
 This test demonstrates the extraction of the resonance-history set from the
 generated phase space.  We need a nontrivial process, but no matrix element.
 This is provided by the [[prc_template]] method, using the [[SM]] model.  We
 also need the [[phs_wood]] method, otherwise we would not have resonances in
 the phase space configuration.
 <<Processes: execute tests>>=
   call test (processes_18, "processes_18", &
        "extract resonance history set", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_18
 <<Processes: tests>>=
   subroutine processes_18 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(string_t) :: model_name
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     class(vars_t), pointer :: vars
     type(process_t), pointer :: process
     type(resonance_history_set_t) :: res_set
     integer :: i
 
     write (u, "(A)")  "* Test output: processes_18"
     write (u, "(A)")  "*   Purpose: extra resonance histories"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes_18_lib"
     procname = "processes_18_p"
 
     call os_data%init ()
 
     call syntax_phs_forest_init ()
 
     model_name = "SM"
     model => null ()
     call prepare_model (model, model_name, vars)
 
     write (u, "(A)")  "* Initialize a process library with one process"
     write (u, "(A)")
 
     select type (model)
     class is (model_t)
        call prepare_resonance_test_library (lib, libname, procname, model, os_data, u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize a process object with phase space"
 
     allocate (process)
     select type (model)
     class is (model_t)
        call prepare_resonance_test_process (process, lib, procname, model, os_data)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
     write (u, "(A)")
 
     call process%extract_resonance_history_set (res_set)
     call res_set%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
     deallocate (model)
 
     call syntax_phs_forest_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_18"
 
   end subroutine processes_18
 
 @ %def processes_18
 @ Auxiliary subroutine that constructs the process library for the above test.
 <<Processes: test auxiliary>>=
   subroutine prepare_resonance_test_library &
        (lib, libname, procname, model, os_data, u)
     type(process_library_t), target, intent(out) :: lib
     type(string_t), intent(in) :: libname
     type(string_t), intent(in) :: procname
     type(model_t), intent(in), target :: model
     type(os_data_t), intent(in) :: os_data
     integer, intent(in) :: u
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
 
     call lib%init (libname)
 
     allocate (prt_in (2), prt_out (3))
     prt_in = [var_str ("e+"), var_str ("e-")]
     prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")]
 
     allocate (template_me_def_t :: def)
     select type (def)
     type is (template_me_def_t)
        call def%init (model, prt_in, prt_out, unity = .false.)
     end select
     allocate (entry)
     call entry%init (procname, &
          model_name = model%get_name (), &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("template"), &
          variant = def)
     call entry%write (u)
 
     call lib%append (entry)
 
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
   end subroutine prepare_resonance_test_library
 
 @ %def prepare_resonance_test_library
 @ We want a test process which has been initialized up to the point where we
 can evaluate the matrix element.  This is in fact rather complicated.  We copy
 the steps from [[integration_setup_process]] in the [[integrate]] module,
 which is not available at this point.
 <<Processes: test auxiliary>>=
   subroutine prepare_resonance_test_process &
        (process, lib, procname, model, os_data)
     class(process_t), intent(out), target :: process
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: procname
     type(model_t), intent(in), target :: model
     type(os_data_t), intent(in) :: os_data
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
 
     call process%init (procname, lib, os_data, model)
 
     allocate (phs_wood_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     call process%setup_test_cores (type_string = var_str ("template"))
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_none)
 
     call process%setup_terms ()
 
   end subroutine prepare_resonance_test_process
 
 @ %def prepare_resonance_test_process
 @ MCI record prepared for the none (dummy) integrator.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_none_t :: mci)
   end subroutine dispatch_mci_none
 
 @ %def dispatch_mci_none
 @
 \subsubsection{Add after evaluate hook(s)}
 Initialize a process and process instance, add a trivial process hook,
 choose a sampling point and fill the process instance.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Processes: test types>>=
   type, extends(process_instance_hook_t) :: process_instance_hook_test_t
     integer :: unit
     character(len=15) :: name
   contains
     procedure :: init => process_instance_hook_test_init
     procedure :: final => process_instance_hook_test_final
     procedure :: evaluate => process_instance_hook_test_evaluate
   end type process_instance_hook_test_t
 
 @
 <<Processes: test auxiliary>>=
   subroutine process_instance_hook_test_init (hook, var_list, instance)
     class(process_instance_hook_test_t), intent(inout), target :: hook
     type(var_list_t), intent(in) :: var_list
     class(process_instance_t), intent(in), target :: instance
   end subroutine process_instance_hook_test_init
 
   subroutine process_instance_hook_test_final (hook)
     class(process_instance_hook_test_t), intent(inout) :: hook
   end subroutine process_instance_hook_test_final
 
   subroutine process_instance_hook_test_evaluate (hook, instance)
     class(process_instance_hook_test_t), intent(inout) :: hook
     class(process_instance_t), intent(in), target :: instance
     write (hook%unit, "(A)") "Execute hook:"
     write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")"
   end subroutine process_instance_hook_test_evaluate
 
 @
 <<Processes: execute tests>>=
   call test (processes_19, "processes_19", &
        "add trivial hooks to a process instance ", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_19
 <<Processes: tests>>=
   subroutine processes_19 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t) :: process_instance
     class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_19"
     write (u, "(A)")  "*   Purpose: allocate process instance &
          &and add an after evaluate hook"
     write (u, "(A)")
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate a process instance"
     write (u, "(A)")
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate hook and add to process instance"
     write (u, "(A)")
 
     allocate (process_instance_hook_test_t :: process_instance_hook)
     call process_instance%append_after_hook (process_instance_hook)
 
     allocate (process_instance_hook_test_t :: process_instance_hook2)
     call process_instance%append_after_hook (process_instance_hook2)
 
     select type (process_instance_hook)
     type is (process_instance_hook_test_t)
        process_instance_hook%unit = u
        process_instance_hook%name = "Hook 1"
     end select
     select type (process_instance_hook2)
     type is (process_instance_hook_test_t)
        process_instance_hook2%unit = u
        process_instance_hook2%name = "Hook 2"
     end select
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%evaluate_after_hook ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance_hook%final ()
     deallocate (process_instance_hook)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_19"
 
   end subroutine processes_19
 
 @ %def processes_19
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process Stacks}
 
 For storing and handling multiple processes, we define process stacks.
 These are ordinary stacks where new process entries are pushed onto
 the top.  We allow for multiple entries with identical process ID, but
 distinct run ID.
 
 The implementation is essentially identical to the [[prclib_stacks]] module
 above.  Unfortunately, Fortran supports no generic programming, so we do not
 make use of this fact.
 
 When searching for a specific process ID, we will get (a pointer to)
 the topmost process entry with that ID on the stack, which was entered
 last.  Usually, this is the best version of the process (in terms of
 integral, etc.)  Thus the stack terminology makes sense.
 <<[[process_stacks.f90]]>>=
 <<File header>>
 
 module process_stacks
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: write_separator
   use diagnostics
   use os_interface
   use sm_qcd
   use model_data
   use rng_base
   use variables
   use observables
   use process_libraries
   use process
 
 <<Standard module head>>
 
 <<Process stacks: public>>
 
 <<Process stacks: types>>
 
 contains
 
 <<Process stacks: procedures>>
 
 end module process_stacks
 @ %def process_stacks
 @
 \subsection{The process entry type}
 A process entry is a process object, augmented by a pointer to the
 next entry.  We do not need specific methods, all relevant methods are
 inherited.
 
 On higher level, processes should be prepared as process entry objects.
 <<Process stacks: public>>=
   public :: process_entry_t
 <<Process stacks: types>>=
   type, extends (process_t) :: process_entry_t
      type(process_entry_t), pointer :: next => null ()
   end type process_entry_t
 
 @ %def process_entry_t
 @
 \subsection{The process stack type}
 For easy conversion and lookup it is useful to store the filling
 number in the object.  The content is stored as a linked list.
 
 The [[var_list]] component stores process-specific results, so they
 can be retrieved as (pseudo) variables.
 
 The process stack can be linked to another one.  This allows us to
 work with stacks of local scope.
 <<Process stacks: public>>=
   public :: process_stack_t
 <<Process stacks: types>>=
   type :: process_stack_t
      integer :: n = 0
      type(process_entry_t), pointer :: first => null ()
      type(var_list_t), pointer :: var_list => null ()
      type(process_stack_t), pointer :: next => null ()
    contains
    <<Process stacks: process stack: TBP>>
   end type process_stack_t
 
 @ %def process_stack_t
 @ Finalize partly: deallocate the process stack and variable list
 entries, but keep the variable list as an empty object.  This way, the
 variable list links are kept.
 <<Process stacks: process stack: TBP>>=
   procedure :: clear => process_stack_clear
 <<Process stacks: procedures>>=
   subroutine process_stack_clear (stack)
     class(process_stack_t), intent(inout) :: stack
     type(process_entry_t), pointer :: process
     if (associated (stack%var_list)) then
        call stack%var_list%final ()
     end if
     do while (associated (stack%first))
        process => stack%first
        stack%first => process%next
        call process%final ()
        deallocate (process)
     end do
     stack%n = 0
   end subroutine process_stack_clear
 
 @ %def process_stack_clear
 @ Finalizer.  Clear and deallocate the variable list.
 <<Process stacks: process stack: TBP>>=
   procedure :: final => process_stack_final
 <<Process stacks: procedures>>=
   subroutine process_stack_final (object)
     class(process_stack_t), intent(inout) :: object
     call object%clear ()
     if (associated (object%var_list)) then
        deallocate (object%var_list)
     end if
   end subroutine process_stack_final
 
 @ %def process_stack_final
 @ Output.  The processes on the stack will be ordered LIFO, i.e.,
 backwards.
 <<Process stacks: process stack: TBP>>=
   procedure :: write => process_stack_write
 <<Process stacks: procedures>>=
   recursive subroutine process_stack_write (object, unit, pacify)
     class(process_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacify
     type(process_entry_t), pointer :: process
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     select case (object%n)
     case (0)
        write (u, "(1x,A)")  "Process stack: [empty]"
        call write_separator (u, 2)
     case default
        write (u, "(1x,A)")  "Process stack:"
        process => object%first
        do while (associated (process))
           call process%write (.false., u, pacify = pacify)
           process => process%next
        end do
     end select
     if (associated (object%next)) then
        write (u, "(1x,A)")  "[Processes from context environment:]"
        call object%next%write (u, pacify)
     end if
   end subroutine process_stack_write
 
 @ %def process_stack_write
 @ The variable list is printed by a separate routine, since
 it should be linked to the global variable list, anyway.
 <<Process stacks: process stack: TBP>>=
   procedure :: write_var_list => process_stack_write_var_list
 <<Process stacks: procedures>>=
   subroutine process_stack_write_var_list (object, unit)
     class(process_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     if (associated (object%var_list)) then
        call var_list_write (object%var_list, unit)
     end if
   end subroutine process_stack_write_var_list
 
 @ %def process_stack_write_var_list
 @ Short output.
 
 Since this is a stack, the default output ordering for each stack will be
 last-in, first-out.  To enable first-in, first-out, which is more likely to be
 requested, there is an optional [[fifo]] argument.
 <<Process stacks: process stack: TBP>>=
   procedure :: show => process_stack_show
 <<Process stacks: procedures>>=
   recursive subroutine process_stack_show (object, unit, fifo)
     class(process_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: fifo
     type(process_entry_t), pointer :: process
     logical :: reverse
     integer :: u, i, j
     u = given_output_unit (unit)
     reverse = .false.;  if (present (fifo))  reverse = fifo
     select case (object%n)
     case (0)
     case default
        if (.not. reverse) then
           process => object%first
           do while (associated (process))
              call process%show (u, verbose=.false.)
              process => process%next
           end do
        else
           do i = 1, object%n
              process => object%first
              do j = 1, object%n - i
                 process => process%next
              end do
              call process%show (u, verbose=.false.)
           end do
        end if
     end select
     if (associated (object%next))  call object%next%show ()
   end subroutine process_stack_show
 
 @ %def process_stack_show
 @
 \subsection{Link}
 Link the current process stack to a global one.
 <<Process stacks: process stack: TBP>>=
   procedure :: link => process_stack_link
 <<Process stacks: procedures>>=
   subroutine process_stack_link (local_stack, global_stack)
     class(process_stack_t), intent(inout) :: local_stack
     type(process_stack_t), intent(in), target :: global_stack
     local_stack%next => global_stack
   end subroutine process_stack_link
 
 @ %def process_stack_link
 @ Initialize the process variable list and link the main variable list
 to it.
 <<Process stacks: process stack: TBP>>=
   procedure :: init_var_list => process_stack_init_var_list
 <<Process stacks: procedures>>=
   subroutine process_stack_init_var_list (stack, var_list)
     class(process_stack_t), intent(inout) :: stack
     type(var_list_t), intent(inout), optional :: var_list
     allocate (stack%var_list)
     if (present (var_list))  call var_list%link (stack%var_list)
   end subroutine process_stack_init_var_list
 
 @ %def process_stack_init_var_list
 @ Link the process variable list to a global
 variable list.
 <<Process stacks: process stack: TBP>>=
   procedure :: link_var_list => process_stack_link_var_list
 <<Process stacks: procedures>>=
   subroutine process_stack_link_var_list (stack, var_list)
     class(process_stack_t), intent(inout) :: stack
     type(var_list_t), intent(in), target :: var_list
     call stack%var_list%link (var_list)
   end subroutine process_stack_link_var_list
 
 @ %def process_stack_link_var_list
 @
 \subsection{Push}
 We take a process pointer and push it onto the stack.  The previous
 pointer is nullified.  Subsequently, the process is `owned' by the
 stack and will be finalized when the stack is deleted.
 <<Process stacks: process stack: TBP>>=
   procedure :: push => process_stack_push
 <<Process stacks: procedures>>=
   subroutine process_stack_push (stack, process)
     class(process_stack_t), intent(inout) :: stack
     type(process_entry_t), intent(inout), pointer :: process
     process%next => stack%first
     stack%first => process
     process => null ()
     stack%n = stack%n + 1
   end subroutine process_stack_push
 
 @ %def process_stack_push
 @ Inverse: Remove the last process pointer in the list and return it.
 <<Process stacks: process stack: TBP>>=
   procedure :: pop_last => process_stack_pop_last
 <<Process stacks: procedures>>=
   subroutine process_stack_pop_last (stack, process)
     class(process_stack_t), intent(inout) :: stack
     type(process_entry_t), intent(inout), pointer :: process
     type(process_entry_t), pointer :: previous
     integer :: i
     select case (stack%n)
     case (:0)
        process => null ()
     case (1)
        process => stack%first
        stack%first => null ()
        stack%n = 0
     case (2:)
        process => stack%first
        do i = 2, stack%n
           previous => process
           process => process%next
        end do
        previous%next => null ()
        stack%n = stack%n - 1
     end select
   end subroutine process_stack_pop_last
 
 @ %def process_stack_pop_last
 @ Initialize process variables for a given process ID, without setting
 values.
 <<Process stacks: process stack: TBP>>=
   procedure :: init_result_vars => process_stack_init_result_vars
 <<Process stacks: procedures>>=
   subroutine process_stack_init_result_vars (stack, id)
     class(process_stack_t), intent(inout) :: stack
     type(string_t), intent(in) :: id
     call var_list_init_num_id (stack%var_list, id)
     call var_list_init_process_results (stack%var_list, id)
   end subroutine process_stack_init_result_vars
 
 @ %def process_stack_init_result_vars
 @ Fill process variables with values.  This is executed after the
 integration pass.
 
 Note: We set only integral and error.  With multiple MCI records
 possible, the results for [[n_calls]], [[chi2]] etc. are not
 necessarily unique.  (We might set the efficiency, though.)
 <<Process stacks: process stack: TBP>>=
   procedure :: fill_result_vars => process_stack_fill_result_vars
 <<Process stacks: procedures>>=
   subroutine process_stack_fill_result_vars (stack, id)
     class(process_stack_t), intent(inout) :: stack
     type(string_t), intent(in) :: id
     type(process_t), pointer :: process
     process => stack%get_process_ptr (id)
     if (associated (process)) then
        call var_list_init_num_id (stack%var_list, id, process%get_num_id ())
        if (process%has_integral ()) then
           call var_list_init_process_results (stack%var_list, id, &
                integral = process%get_integral (), &
                error = process%get_error ())
        end if
     else
        call msg_bug ("process_stack_fill_result_vars: unknown process ID")
     end if
   end subroutine process_stack_fill_result_vars
 
 @ %def process_stack_fill_result_vars
 @ If one of the result variables has a local image in [[var_list_local]],
 update the value there as well.
 <<Process stacks: process stack: TBP>>=
   procedure :: update_result_vars => process_stack_update_result_vars
 <<Process stacks: procedures>>=
   subroutine process_stack_update_result_vars (stack, id, var_list_local)
     class(process_stack_t), intent(inout) :: stack
     type(string_t), intent(in) :: id
     type(var_list_t), intent(inout) :: var_list_local
     call update ("integral(" // id // ")")
     call update ("error(" // id // ")")
   contains
     subroutine update (var_name)
       type(string_t), intent(in) :: var_name
       real(default) :: value
       if (var_list_local%contains (var_name, follow_link = .false.)) then
          value = stack%var_list%get_rval (var_name)
          call var_list_local%set_real (var_name, value, is_known = .true.)
       end if
     end subroutine update
   end subroutine process_stack_update_result_vars
 
 @ %def process_stack_update_result_vars
 @
 \subsection{Data Access}
 Tell if a process exists.
 <<Process stacks: process stack: TBP>>=
   procedure :: exists => process_stack_exists
 <<Process stacks: procedures>>=
   function process_stack_exists (stack, id) result (flag)
     class(process_stack_t), intent(in) :: stack
     type(string_t), intent(in) :: id
     logical :: flag
     type(process_t), pointer :: process
     process => stack%get_process_ptr (id)
     flag = associated (process)
   end function process_stack_exists
 
 @ %def process_stack_exists
 @ Return a pointer to a process with specific ID.  Look also at a
 linked stack, if necessary.
 <<Process stacks: process stack: TBP>>=
   procedure :: get_process_ptr => process_stack_get_process_ptr
 <<Process stacks: procedures>>=
   recursive function process_stack_get_process_ptr (stack, id) result (ptr)
     class(process_stack_t), intent(in) :: stack
     type(string_t), intent(in) :: id
     type(process_t), pointer :: ptr
     type(process_entry_t), pointer :: entry
     ptr => null ()
     entry => stack%first
     do while (associated (entry))
        if (entry%get_id () == id) then
           ptr => entry%process_t
           return
        end if
        entry => entry%next
     end do
     if (associated (stack%next))  ptr => stack%next%get_process_ptr (id)
   end function process_stack_get_process_ptr
 
 @ %def process_stack_get_process_ptr
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[process_stacks_ut.f90]]>>=
 <<File header>>
 
 module process_stacks_ut
   use unit_tests
   use process_stacks_uti
 
 <<Standard module head>>
 
 <<Process stacks: public test>>
 
 contains
 
 <<Process stacks: test driver>>
 
 end module process_stacks_ut
 @ %def process_stacks_ut
 @
 <<[[process_stacks_uti.f90]]>>=
 <<File header>>
 
 module process_stacks_uti
 
 <<Use strings>>
   use os_interface
   use sm_qcd
   use models
   use model_data
   use variables, only: var_list_t
   use process_libraries
   use rng_base
   use prc_test, only: prc_test_create_library
   use process, only: process_t
   use instances, only: process_instance_t
   use processes_ut, only: prepare_test_process
 
   use process_stacks
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<Process stacks: test declarations>>
 
 contains
 
 <<Process stacks: tests>>
 
 end module process_stacks_uti
 
 @ %def process_stacks_uti
 @ API: driver for the unit tests below.
 <<Process stacks: public test>>=
   public :: process_stacks_test
 <<Process stacks: test driver>>=
   subroutine process_stacks_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Process stacks: execute tests>>
   end subroutine process_stacks_test
 
 @ %def process_stacks_test
 @
 \subsubsection{Write an empty process stack}
 The most trivial test is to write an uninitialized process stack.
 <<Process stacks: execute tests>>=
   call test (process_stacks_1, "process_stacks_1", &
        "write an empty process stack", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_1
 <<Process stacks: tests>>=
   subroutine process_stacks_1 (u)
     integer, intent(in) :: u
     type(process_stack_t) :: stack
 
     write (u, "(A)")  "* Test output: process_stacks_1"
     write (u, "(A)")  "*   Purpose: display an empty process stack"
     write (u, "(A)")
 
     call stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_1"
 
   end subroutine process_stacks_1
 
 @ %def process_stacks_1
 @
 \subsubsection{Fill a process stack}
 Fill a process stack with two (identical) processes.
 <<Process stacks: execute tests>>=
   call test (process_stacks_2, "process_stacks_2", &
        "fill a process stack", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_2
 <<Process stacks: tests>>=
   subroutine process_stacks_2 (u)
     integer, intent(in) :: u
     type(process_stack_t) :: stack
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(var_list_t) :: var_list
     type(process_entry_t), pointer :: process => null ()
 
     write (u, "(A)")  "* Test output: process_stacks_2"
     write (u, "(A)")  "*   Purpose: fill a process stack"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build, initialize and store two test processes"
     write (u, "(A)")
 
     libname = "process_stacks2"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call model%init_test ()
     call var_list%append_string (var_str ("$run_id"))
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
     call var_list%append_int (var_str ("seed"), 0)
 
     allocate (process)
 
     call var_list%set_string &
          (var_str ("$run_id"), var_str ("run1"), is_known=.true.)
     call process%init (procname, lib, os_data, model, var_list)
     call stack%push (process)
 
     allocate (process)
 
     call var_list%set_string &
          (var_str ("$run_id"), var_str ("run2"), is_known=.true.)
     call process%init (procname, lib, os_data, model, var_list)
     call stack%push (process)
 
     call stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_2"
 
   end subroutine process_stacks_2
 
 @ %def process_stacks_2
 @
 \subsubsection{Fill a process stack}
 Fill a process stack with two (identical) processes.
 <<Process stacks: execute tests>>=
   call test (process_stacks_3, "process_stacks_3", &
        "process variables", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_3
 <<Process stacks: tests>>=
   subroutine process_stacks_3 (u)
     integer, intent(in) :: u
     type(process_stack_t) :: stack
     type(model_t), target :: model
     type(string_t) :: procname
     type(process_entry_t), pointer :: process => null ()
     type(process_instance_t), target :: process_instance
 
     write (u, "(A)")  "* Test output: process_stacks_3"
     write (u, "(A)")  "*   Purpose: setup process variables"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     procname = "processes_test"
     call model%init_test ()
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     call stack%init_var_list ()
     call stack%init_result_vars (procname)
     call stack%write_var_list (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build and integrate a test process"
     write (u, "(A)")
 
     allocate (process)
     call prepare_test_process (process%process_t, process_instance, model)
     call process_instance%integrate (1, 1, 1000)
     call process_instance%final ()
     call process%final_integration (1)
     call stack%push (process)
 
     write (u, "(A)")  "* Fill process variables"
     write (u, "(A)")
 
     call stack%fill_result_vars (procname)
     call stack%write_var_list (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_3"
 
   end subroutine process_stacks_3
 
 @ %def process_stacks_3
 @
 \subsubsection{Linked a process stack}
 Fill two process stack, linked to each other.
 <<Process stacks: execute tests>>=
   call test (process_stacks_4, "process_stacks_4", &
        "linked stacks", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_4
 <<Process stacks: tests>>=
   subroutine process_stacks_4 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(process_stack_t), target :: stack1, stack2
     type(model_t), target :: model
     type(string_t) :: libname
     type(string_t) :: procname1, procname2
     type(os_data_t) :: os_data
     type(process_entry_t), pointer :: process => null ()
 
     write (u, "(A)")  "* Test output: process_stacks_4"
     write (u, "(A)")  "*   Purpose: link process stacks"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     libname = "process_stacks_4_lib"
     procname1 = "process_stacks_4a"
     procname2 = "process_stacks_4b"
 
     call os_data%init ()
 
     write (u, "(A)")  "* Initialize first process"
     write (u, "(A)")
 
     call prc_test_create_library (procname1, lib)
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname1, lib, os_data, model)
     call stack1%push (process)
 
     write (u, "(A)")  "* Initialize second process"
     write (u, "(A)")
 
     call stack2%link (stack1)
 
     call prc_test_create_library (procname2, lib)
 
     allocate (process)
 
     call process%init (procname2, lib, os_data, model)
     call stack2%push (process)
 
     write (u, "(A)")  "* Show linked stacks"
     write (u, "(A)")
 
     call stack2%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack2%final ()
     call stack1%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_4"
 
   end subroutine process_stacks_4
 
 @ %def process_stacks_4
 @
Index: trunk/src/me_methods/me_methods.nw
===================================================================
--- trunk/src/me_methods/me_methods.nw	(revision 8766)
+++ trunk/src/me_methods/me_methods.nw	(revision 8767)
@@ -1,7011 +1,7031 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: matrix elements and process libraries
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Interface for Matrix Element Objects}
 \includemodulegraph{me_methods}
 
 These modules manage internal and, in particular, external
 matrix-element code.
 \begin{description}
 \item[prc\_core]
   We define the abstract [[prc_core_t]] type which handles all specific
   features of kinematics matrix-element evaluation that depend on a particular
   class of processes.  This abstract type supplements the
   [[prc_core_def_t]] type and related types in another module.
   Together, they provide a complete set of matrix-element handlers
   that are implemented in the concrete types below.
 \end{description}
 
 These are the implementations:
 \begin{description}
 \item[prc\_template\_me]
   Implements matrix-element code without actual content (trivial
   value), but full-fledged interface.  This can be used for injecting
   user-defined matrix-element code.
 \item[prc\_omega]
   Matrix elements calculated by \oMega\ are the default for WHIZARD.
   Here, we provide all necessary support.
 \item[prc\_external]
   Matrix elements provided or using external (not \oMega) code or libraries.
   This is an abstract type, with concrete extensions below:
 \item[prc\_external\_test]
   Concrete implementation of the external-code type, actually using some
   pre-defined test matrix elements.
 \item[prc\_gosam]
   Interface for matrix elements computed using \gosam.
 \item[prc\_openloops]
   Interface for matrix elements computed using OpenLoops.
 \item[prc\_recola]
   Interface for matrix elements computed using Recola.
 \item[prc\_threshold]
   Interface for matrix elements for the top-pair threshold, that use external
   libraries.
 \end{description}
 
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Abstract process core}
 In this module we provide abstract data types for process classes.  Each
 process class represents a set of processes which are handled by a common
 ``method'', e.g., by the \oMega\ matrix-element generator.  The process class
 is also able to select a particular implementation for the phase-space and
 integration modules.
 
 For a complete implementation of a process class, we have to
 provide extensions of the following abstract types:
 \begin{description}
 \item[prc\_core\_def\_t] process and matrix-element configuration
 \item[prc\_writer\_t] (optional) writing external matrix-element code
 \item[prc\_driver\_t] accessing the matrix element (internal or external)
 \item[prc\_core\_t] evaluating kinematics and matrix element.  The process
   core also selects phase-space and integrator implementations as appropriate
   for the process class and configuration.
 \end{description}
 
 In the actual process-handling data structures, each process component
 contains an instance of such a process class as its core.  This allows us to
 keep the [[processes]] module below, which supervises matrix-element
 evaluation, integration, and event generation, free of any reference to
 concrete implementations (for the process class, phase space, and
 integrator).
 
 There are no unit tests, these are deferred to the [[processes]] module.
 <<[[prc_core.f90]]>>=
 <<File header>>
 module prc_core
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use diagnostics
   use os_interface, only: os_data_t
   use lorentz
   use interactions
   use variables, only: var_list_t
   use model_data, only: model_data_t
 
   use process_constants
   use prc_core_def
   use process_libraries
   use sf_base
 
 <<Standard module head>>
 
 <<Prc core: public>>
 
 <<Prc core: types>>
 
 <<Prc core: interfaces>>
 
 contains
 
 <<Prc core: procedures>>
 
 end module prc_core
 @ %def prc_core
 @
 \subsection{The process core}
 The process core is of abstract data type.  Different types of matrix
 elements will be represented by different implementations.
 <<Prc core: public>>=
   public :: prc_core_t
 <<Prc core: types>>=
   type, abstract :: prc_core_t
      class(prc_core_def_t), pointer :: def => null ()
      logical :: data_known = .false.
      type(process_constants_t) :: data
      class(prc_core_driver_t), allocatable :: driver
      logical :: use_color_factors = .false.
      integer :: nc = 3
    contains
    <<Prc core: process core: TBP>>
   end type prc_core_t
 
 @ %def prc_core_t
 @ In any case there must be an output routine.
 <<Prc core: process core: TBP>>=
   procedure(prc_core_write), deferred :: write
 <<Prc core: interfaces>>=
   abstract interface
      subroutine prc_core_write (object, unit)
        import
        class(prc_core_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine prc_core_write
   end interface
 
 @ %def prc_core_write
 @ Just type the name of the actual core method.
 <<Prc core: process core: TBP>>=
   procedure(prc_core_write_name), deferred :: write_name
 <<Prc core: interfaces>>=
   abstract interface
      subroutine prc_core_write_name (object, unit)
        import
        class(prc_core_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine prc_core_write_name
   end interface
 
 @ %def prc_core_write_name
 @ For initialization, we assign a pointer to the process entry in the
 relevant library.  This allows us to access all process functions via
 the implementation of [[prc_core_t]].
 
 We declare the [[object]] as [[intent(inout)]], since just after
 allocation it may be useful to store some extra data in the object,
 which we can then use in the actual initialization.  This applies to
 extensions of [[prc_core]] which override the [[init]] method.
 <<Prc core: process core: TBP>>=
   procedure :: init => prc_core_init
   procedure :: base_init => prc_core_init
 <<Prc core: procedures>>=
   subroutine prc_core_init (object, def, lib, id, i_component)
     class(prc_core_t), intent(inout) :: object
     class(prc_core_def_t), intent(in), target :: def
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     object%def => def
     call lib%connect_process (id, i_component, object%data, object%driver)
     object%data_known = .true.
   end subroutine prc_core_init
 
 @ %def prc_core_init
 @ Return true if the matrix element generation was successful.  This can be
 tested by looking at the number of generated flavor states, which should be
 nonzero.
 <<Prc core: process core: TBP>>=
   procedure :: has_matrix_element => prc_core_has_matrix_element
 <<Prc core: procedures>>=
   function prc_core_has_matrix_element (object) result (flag)
     class(prc_core_t), intent(in) :: object
     logical :: flag
     flag = object%data%n_flv /= 0
   end function prc_core_has_matrix_element
 
 @ %def prc_core_has_matrix_element
 @
 Return true if this process-core type needs extra code that has to be compiled
 and/or linked, beyond the default \oMega\ framework.  This depends only on the
 concrete type, and the default is no.
 <<Prc core: process core: TBP>>=
   procedure, nopass :: needs_external_code => prc_core_needs_external_code
 <<Prc core: procedures>>=
   function prc_core_needs_external_code () result (flag)
     logical :: flag
     flag = .false.
   end function prc_core_needs_external_code
 
 @ %def prc_core_needs_external_code
 @ The corresponding procedure to create and load extra libraries.  The base
 procedure must not be called but has to be overridden, if extra code is
 required.
 <<Prc core: process core: TBP>>=
   procedure :: prepare_external_code => &
        prc_core_prepare_external_code
 <<Prc core: procedures>>=
   subroutine prc_core_prepare_external_code &
        (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo)
     class(prc_core_t), intent(inout) :: core
     integer, intent(in), dimension(:,:), allocatable :: flv_states
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: i_core
     logical, intent(in) :: is_nlo
     call core%write ()
     call msg_bug ("prc_core_prepare_external_code called &
          &but not overridden")
   end subroutine prc_core_prepare_external_code
 
 @ %def prc_core_prepare_external_code
 @
 Return true if this process-core type uses the BLHA interface.  This depends
 only on the concrete type, and the default is no.
 <<Prc core: process core: TBP>>=
   procedure, nopass :: uses_blha => prc_core_uses_blha
 <<Prc core: procedures>>=
   function prc_core_uses_blha () result (flag)
     logical :: flag
     flag = .false.
   end function prc_core_uses_blha
 
 @ %def prc_core_uses_blha
 @
 Tell whether a particular combination of flavor/helicity/color state
 is allowed for the matrix element.
 <<Prc core: process core: TBP>>=
   procedure(prc_core_is_allowed), deferred :: is_allowed
 <<Prc core: interfaces>>=
   abstract interface
      function prc_core_is_allowed (object, i_term, f, h, c) result (flag)
        import
        class(prc_core_t), intent(in) :: object
        integer, intent(in) :: i_term, f, h, c
        logical :: flag
      end function prc_core_is_allowed
   end interface
 
 @ %def prc_core_is_allowed
 @ Set the constant process data for a specific term.  By default,
 these are the constants stored inside the object, ignoring the term
 index.  Type extensions may override this and provide term-specific data.
 <<Prc core: process core: TBP>>=
   procedure :: get_constants => prc_core_get_constants
 <<Prc core: procedures>>=
   subroutine prc_core_get_constants (object, data, i_term)
     class(prc_core_t), intent(in) :: object
     type(process_constants_t), intent(out) :: data
     integer, intent(in) :: i_term
     data = object%data
   end subroutine prc_core_get_constants
 
 @ %def prc_core_get_constants
 @ The strong coupling is not among the process constants.  The default
 implementation is to return a negative number, which indicates that $\alpha_s$
 is not available.  This may be overridden by an implementation that provides
 an (event-specific) value.  The value can be stored in the
 process-specific workspace.
 <<Prc core: process core: TBP>>=
   procedure :: get_alpha_s => prc_core_get_alpha_s
 <<Prc core: procedures>>=
   function prc_core_get_alpha_s (object, core_state) result (alpha_qcd)
     class(prc_core_t), intent(in) :: object
     class(prc_core_state_t), intent(in), allocatable :: core_state
     real(default) :: alpha_qcd
     alpha_qcd = -1
   end function prc_core_get_alpha_s
 
 @ %def prc_core_get_alpha_s
 @ We follow the same strategy for the electromagnetic coupling $\alpha_\text{em}$.
 <<Prc core: process core: TBP>>=
   procedure :: get_alpha_qed => prc_core_get_alpha_qed
 <<Prc core: procedures>>=
-  function prc_core_get_alpha_qed (object) result (alpha_qed)
+  function prc_core_get_alpha_qed (object, core_state) result (alpha_qed)
     class(prc_core_t), intent(in) :: object
+    class(prc_core_state_t), intent(in), allocatable :: core_state
     real(default) :: alpha_qed
     alpha_qed = -1
   end function prc_core_get_alpha_qed
 
 @ %def prc_core_get_alpha_qed
 @
 Setup an index mapping for flavor structures and helicities that give the same matrix
 element. The index mapping is according to the order of flavor structures known to the
 [[prc_core]] class. This procedure here acts as a fallback in case there is no overridden
 procedure in the [[prc_core]] extension.
 <<Prc core: process core: TBP>>=
   procedure :: set_equivalent_flv_hel_indices => prc_core_set_equivalent_flv_hel_indices
 <<Prc core: procedures>>=
   subroutine prc_core_set_equivalent_flv_hel_indices (object)
     class(prc_core_t), intent(inout) :: object
     integer :: i, n_flv, n_hel
     n_flv = object%data%n_flv
     n_hel = object%data%n_hel
     if (.not. allocated (object%data%eqv_flv_index)) &
          allocate (object%data%eqv_flv_index(n_flv))
     if (.not. allocated (object%data%eqv_hel_index)) &
          allocate (object%data%eqv_hel_index(n_hel))
     if (size (object%data%eqv_flv_index) /= n_flv) &
          call msg_bug ("BLHA Core: Size mismatch between eqv_flv_index and number of flavors.")
     if (size (object%data%eqv_hel_index) /= n_hel) &
          call msg_bug ("BLHA Core: Size mismatch between eqv_hel_index and number of helicities.")
     object%data%eqv_flv_index = [(i, i = 1, n_flv)]
     object%data%eqv_hel_index = [(i, i = 1, n_hel)]
   end subroutine prc_core_set_equivalent_flv_hel_indices
 
 @ %def prc_core_set_equivalent_flv_hel_indices
 @ Get the index mappings for flavor and helicity mappings set up in
 [[prc_core_get_equivalent_flv_index]] or any overriding variation.
 <<Prc core: process core: TBP>>=
   procedure :: get_equivalent_flv_index => prc_core_get_equivalent_flv_index
   procedure :: get_equivalent_hel_index => prc_core_get_equivalent_hel_index
 <<Prc core: procedures>>=
   function prc_core_get_equivalent_flv_index (object) result (eqv_flv_index)
     class(prc_core_t), intent(in) :: object
     integer, dimension(:), allocatable :: eqv_flv_index
     eqv_flv_index = object%data%eqv_flv_index
   end function prc_core_get_equivalent_flv_index
 
   function prc_core_get_equivalent_hel_index (object) result (eqv_hel_index)
     class(prc_core_t), intent(in) :: object
     integer, dimension(:), allocatable :: eqv_hel_index
     eqv_hel_index = object%data%eqv_hel_index
   end function prc_core_get_equivalent_hel_index
 
 @ %def prc_core_get_equivalent_flv_index prc_core_get_equivalent_hel_index
 @ Allocate the workspace associated to a process component.  The default is
 that there is no workspace, so we do nothing.  A type extension may override
 this and allocate a workspace object of appropriate type, which can be used in
 further calculations.
 
 In any case, the [[intent(out)]] attribute deletes any previously allocated
 workspace.
 <<Prc core: process core: TBP>>=
   procedure :: allocate_workspace => prc_core_ignore_workspace
 <<Prc core: procedures>>=
   subroutine prc_core_ignore_workspace (object, core_state)
     class(prc_core_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
   end subroutine prc_core_ignore_workspace
 
 @ %def prc_core_ignore_workspace
 @ Compute the momenta in the hard interaction, taking the seed
 kinematics as input.  The [[i_term]] index tells us which term we want
 to compute.  (The standard method is to just transfer the momenta to the hard
 interaction.)
 <<Prc core: process core: TBP>>=
   procedure(prc_core_compute_hard_kinematics), deferred :: &
        compute_hard_kinematics
 <<Prc core: interfaces>>=
   abstract interface
      subroutine prc_core_compute_hard_kinematics &
           (object, p_seed, i_term, int_hard, core_state)
        import
        class(prc_core_t), intent(in) :: object
        type(vector4_t), dimension(:), intent(in) :: p_seed
        integer, intent(in) :: i_term
        type(interaction_t), intent(inout) :: int_hard
        class(prc_core_state_t), intent(inout), allocatable :: core_state
      end subroutine prc_core_compute_hard_kinematics
   end interface
 
 @ %def prc_core_compute_hard_kinematics
 @ Compute the momenta in the effective interaction, taking the hard
 kinematics as input.  (This is called only if parton recombination is to be
 applied for the process variant.)
 <<Prc core: process core: TBP>>=
   procedure(prc_core_compute_eff_kinematics), deferred :: &
        compute_eff_kinematics
 <<Prc core: interfaces>>=
   abstract interface
      subroutine prc_core_compute_eff_kinematics &
           (object, i_term, int_hard, int_eff, core_state)
        import
        class(prc_core_t), intent(in) :: object
        integer, intent(in) :: i_term
        type(interaction_t), intent(in) :: int_hard
        type(interaction_t), intent(inout) :: int_eff
        class(prc_core_state_t), intent(inout), allocatable :: core_state
      end subroutine prc_core_compute_eff_kinematics
   end interface
 
 @ %def prc_core_compute_eff_kinematics
 @ The process core must implement this function.  Here, [[j]] is the index
 of the particular term we want to compute.  The amplitude may depend on the
 factorization and renormalization scales.
 
 The [[core_state]] (workspace) argument may be used if it is provided by the caller.
 Otherwise, the routine should compute the result directly.
 <<Prc core: process core: TBP>>=
   procedure(prc_core_compute_amplitude), deferred :: compute_amplitude
 <<Prc core: interfaces>>=
   abstract interface
      function prc_core_compute_amplitude &
           (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
           core_state) result (amp)
        import
        complex(default) :: amp
        class(prc_core_t), intent(in) :: object
        integer, intent(in) :: j
        type(vector4_t), dimension(:), intent(in) :: p
        integer, intent(in) :: f, h, c
        real(default), intent(in) :: fac_scale, ren_scale
        real(default), intent(in), allocatable :: alpha_qcd_forced
        class(prc_core_state_t), intent(inout), allocatable, optional :: &
             core_state
      end function prc_core_compute_amplitude
   end interface
 
 @ %def prc_core_compute_amplitude
 @
 \subsection{Storage for intermediate results}
 
 The abstract [[prc_core_state_t]] type allows process cores to set up temporary
 workspace.  The object is an extra argument for each of the individual
 calculations between kinematics setup and matrix-element evaluation.
 <<Prc core: public>>=
   public :: prc_core_state_t
 <<Prc core: types>>=
   type, abstract :: prc_core_state_t
    contains
      procedure(workspace_write), deferred :: write
      procedure(workspace_reset_new_kinematics), deferred :: reset_new_kinematics
   end type prc_core_state_t
 
 @ %def prc_core_state_t
 @ For debugging, we should at least have an output routine.
 <<Prc core: interfaces>>=
   abstract interface
      subroutine workspace_write (object, unit)
        import
        class(prc_core_state_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine workspace_write
   end interface
 
 @ %def workspace_write
 @ This is used during the NLO calculation, see there for more information.
 <<Prc core: interfaces>>=
   abstract interface
     subroutine workspace_reset_new_kinematics (object)
       import
       class(prc_core_state_t), intent(inout) :: object
     end subroutine workspace_reset_new_kinematics
   end interface
 
 @ %def workspace_reset_new_kinematics
 @
 \subsection{Helicity selection data}
 This is intended for use with \oMega, but may also be made available to other
 process methods.  We set thresholds for counting the times a specific
 helicity amplitude is zero.  When the threshold is reached, we skip this
 amplitude in subsequent calls.
 
 For initializing the helicity counters, we need an object that holds the two
 parameters, the threshold (large real number) and the cutoff (integer).
 
 A helicity value suppressed by more than [[threshold]] (a value which
 multiplies [[epsilon]], to be compared with the average of the current
 amplitude, default is $10^{10}$) is treated as zero.  A matrix element is
 assumed to be zero and not called again if it has been zero [[cutoff]] times.
 <<Prc core: public>>=
   public :: helicity_selection_t
 <<Prc core: types>>=
   type :: helicity_selection_t
      logical :: active = .false.
      real(default) :: threshold = 0
      integer :: cutoff = 0
    contains
    <<Prc core: helicity selection: TBP>>
   end type helicity_selection_t
 
 @ %def helicity_selection_t
 @ Output.  If the selection is inactive, print nothing.
 <<Prc core: helicity selection: TBP>>=
   procedure :: write => helicity_selection_write
 <<Prc core: procedures>>=
   subroutine helicity_selection_write (object, unit)
     class(helicity_selection_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     if (object%active) then
        write (u, "(3x,A)")  "Helicity selection data:"
        write (u, "(5x,A,ES17.10)") &
             "threshold =", object%threshold
        write (u, "(5x,A,I0)") &
             "cutoff    = ", object%cutoff
     end if
   end subroutine helicity_selection_write
 
 @ %def helicity_selection_write
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Test process type}
 For the following tests, we define a simple implementation of the abstract
 [[prc_core_t]], designed such as to complement the [[prc_test_t]]
 process definition type.
 
 Note that it is not given that the actual process is defined as
 [[prc_test_t]] type.  We enforce this by calling
 [[prc_test_create_library]].  The driver component in the process core
 will then become of type [[prc_test_t]].
 @
 <<[[prc_test_core.f90]]>>=
 <<File header>>
 
 module prc_test_core
 
 <<Use kinds>>
   use io_units
   use lorentz
   use interactions
   use prc_test
   use prc_core
 
 <<Standard module head>>
 
 <<Prc test core: public>>
 
 <<Prc test core: types>>
 
 contains
 
 <<Prc test core: procedures>>
 
 end module prc_test_core
 @ %def prc_test_core
 <<Prc test core: public>>=
   public :: test_t
 <<Prc test core: types>>=
   type, extends (prc_core_t) :: test_t
    contains
    <<Prc test core: test type: TBP>>
   end type test_t
 
 @ %def test_t
 <<Prc test core: test type: TBP>>=
   procedure :: write => test_write
 <<Prc test core: procedures>>=
   subroutine test_write (object, unit)
     class(test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A)")  "test type implementing prc_test"
   end subroutine test_write
 
 @ %def test_write
 <<Prc test core: test type: TBP>>=
   procedure :: write_name => test_write_name
 <<Prc test core: procedures>>=
   subroutine test_write_name (object, unit)
     class(test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(1x,A)")  "Core: prc_test"
   end subroutine test_write_name
 
 @ %def test_write_name
 @ This process type always needs a MC parameter set and a
 single term.  This only state is always allowed.
 <<Prc test core: test type: TBP>>=
   procedure :: needs_mcset => test_needs_mcset
   procedure :: get_n_terms => test_get_n_terms
   procedure :: is_allowed => test_is_allowed
 <<Prc test core: procedures>>=
   function test_needs_mcset (object) result (flag)
     class(test_t), intent(in) :: object
     logical :: flag
     flag = .true.
   end function test_needs_mcset
 
   function test_get_n_terms (object) result (n)
     class(test_t), intent(in) :: object
     integer :: n
     n = 1
   end function test_get_n_terms
 
   function test_is_allowed (object, i_term, f, h, c) result (flag)
     class(test_t), intent(in) :: object
     integer, intent(in) :: i_term, f, h, c
     logical :: flag
     flag = .true.
   end function test_is_allowed
 
 @ %def test_needs_mcset
 @ %def test_get_n_terms
 @ %def test_is_allowed
 @ Transfer the generated momenta directly to the hard interaction in
 the (only) term.  We assume that everything has been set up correctly,
 so the array fits.
 <<Prc test core: test type: TBP>>=
   procedure :: compute_hard_kinematics => test_compute_hard_kinematics
 <<Prc test core: procedures>>=
   subroutine test_compute_hard_kinematics &
        (object, p_seed, i_term, int_hard, core_state)
     class(test_t), intent(in) :: object
     type(vector4_t), dimension(:), intent(in) :: p_seed
     integer, intent(in) :: i_term
     type(interaction_t), intent(inout) :: int_hard
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     call int_hard%set_momenta (p_seed)
   end subroutine test_compute_hard_kinematics
 
 @ %def test_compute_hard_kinematics
 @ This procedure is not called for [[test_t]], just a placeholder.
 <<Prc test core: test type: TBP>>=
   procedure :: compute_eff_kinematics => test_compute_eff_kinematics
 <<Prc test core: procedures>>=
   subroutine test_compute_eff_kinematics &
        (object, i_term, int_hard, int_eff, core_state)
     class(test_t), intent(in) :: object
     integer, intent(in) :: i_term
     type(interaction_t), intent(in) :: int_hard
     type(interaction_t), intent(inout) :: int_eff
     class(prc_core_state_t), intent(inout), allocatable :: core_state
   end subroutine test_compute_eff_kinematics
 
 @ %def test_compute_eff_kinematics
 @ Transfer the incoming momenta of [[p_seed]] directly to the
 effective interaction, and vice versa for the outgoing momenta.
 
 [[int_hard]] is left untouched since [[int_eff]] is an alias (via
 pointer) to it.
 <<Prc test core: test type: TBP>>=
   procedure :: recover_kinematics => test_recover_kinematics
 <<Prc test core: procedures>>=
   subroutine test_recover_kinematics &
        (object, p_seed, int_hard, int_eff, core_state)
     class(test_t), intent(in) :: object
     type(vector4_t), dimension(:), intent(inout) :: p_seed
     type(interaction_t), intent(inout) :: int_hard
     type(interaction_t), intent(inout) :: int_eff
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     integer :: n_in
     n_in = int_eff%get_n_in ()
     call int_eff%set_momenta (p_seed(1:n_in), outgoing = .false.)
     p_seed(n_in+1:) = int_eff%get_momenta (outgoing = .true.)
   end subroutine test_recover_kinematics
 
 @ %def test_recover_kinematics
 @ Compute the amplitude.  The driver ignores all quantum numbers and,
 in fact, returns a constant.  Nevertheless, we properly transfer the
 momentum vectors.
 <<Prc test core: test type: TBP>>=
   procedure :: compute_amplitude => test_compute_amplitude
 <<Prc test core: procedures>>=
   function test_compute_amplitude &
        (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, core_state) &
        result (amp)
     class(test_t), intent(in) :: object
     integer, intent(in) :: j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in) :: fac_scale, ren_scale
     real(default), intent(in), allocatable :: alpha_qcd_forced
     class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
     complex(default) :: amp
     real(default), dimension(:,:), allocatable :: parray
     integer :: i, n_tot
     select type (driver => object%driver)
     type is (prc_test_t)
        if (driver%scattering) then
           n_tot = 4
        else
           n_tot = 3
        end if
        allocate (parray (0:3,n_tot))
        forall (i = 1:n_tot)  parray(:,i) = vector4_get_components (p(i))
        amp = driver%get_amplitude (parray)
     end select
   end function test_compute_amplitude
 
 @ %def test_compute_amplitude
 @
 @
 \section{Template matrix elements}
 
 Here, we provide template matrix elements that are in structure
 very similar to \oMega\ matrix elements, but do not need its
 infrastructure. Per default, the matrix elements are flat, i.e.
 they have the constant value one. Analogous to the \oMega\
 implementation, this section implements the interface
 to the templates (via the makefile) and the driver.
 <<[[prc_template_me.f90]]>>=
 <<File header>>
 
 module prc_template_me
 
   use, intrinsic ::  iso_c_binding !NODEP!
 
   use kinds
 <<Use strings>>
   use io_units
   use system_defs, only: TAB
   use diagnostics
   use os_interface
   use lorentz
   use flavors
   use interactions
   use model_data
 
   use particle_specifiers, only: new_prt_spec
   use process_constants
   use prclib_interfaces
   use prc_core_def
   use process_libraries
   use prc_core
 
 <<Standard module head>>
 
 <<Template matrix elements: public>>
 
 <<Template matrix elements: types>>
 
 <<Template matrix elements: interfaces>>
 
 contains
 
 <<Template matrix elements: procedures>>
 
 end module prc_template_me
 @ %def prc_template_me
 @
 \subsection{Process definition}
 For the process definition we implement an extension of the
 [[prc_core_def_t]] abstract type.
 <<Template matrix elements: public>>=
   public :: template_me_def_t
 <<Template matrix elements: types>>=
   type, extends (prc_core_def_t) :: template_me_def_t
    contains
    <<Template matrix elements: template ME def: TBP>>
   end type template_me_def_t
 
 @ %def template_me_def_t
 <<Template matrix elements: template ME def: TBP>>=
   procedure, nopass :: type_string => template_me_def_type_string
 <<Template matrix elements: procedures>>=
   function template_me_def_type_string () result (string)
     type(string_t) :: string
     string = "template"
   end function template_me_def_type_string
 
 @ %def template_me_def_type_string
 @ Initialization: allocate the writer for the template matrix element.
 Also set any data for this process that the writer needs.
 <<Template matrix elements: template ME def: TBP>>=
   procedure :: init => template_me_def_init
 <<Template matrix elements: procedures>>=
   subroutine template_me_def_init &
        (object, model, prt_in, prt_out, unity)
     class(template_me_def_t), intent(out) :: object
     class(model_data_t), intent(in), target :: model
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     logical, intent(in) :: unity
     allocate (template_me_writer_t :: object%writer)
     select type (writer => object%writer)
     type is (template_me_writer_t)
        call writer%init (model, prt_in, prt_out, unity)
     end select
   end subroutine template_me_def_init
 
 @ %def template_me_def_init
 @ Write/read process- and method-specific data.
 <<Template matrix elements: template ME def: TBP>>=
   procedure :: write => template_me_def_write
 <<Template matrix elements: procedures>>=
   subroutine template_me_def_write (object, unit)
     class(template_me_def_t), intent(in) :: object
     integer, intent(in) :: unit
     select type (writer => object%writer)
     type is (template_me_writer_t)
        call writer%write (unit)
     end select
   end subroutine template_me_def_write
 
 @ %def template_me_def_write
 @
 <<Template matrix elements: template ME def: TBP>>=
   procedure :: read => template_me_def_read
 <<Template matrix elements: procedures>>=
   subroutine template_me_def_read (object, unit)
     class(template_me_def_t), intent(out) :: object
     integer, intent(in) :: unit
     call msg_bug &
          ("WHIZARD template process definition: input not supported (yet)")
   end subroutine template_me_def_read
 
 @ %def template_me_def_read
 @ Allocate the driver for template matrix elements.
 <<Template matrix elements: template ME def: TBP>>=
   procedure :: allocate_driver => template_me_def_allocate_driver
 <<Template matrix elements: procedures>>=
   subroutine template_me_def_allocate_driver (object, driver, basename)
     class(template_me_def_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     allocate (template_me_driver_t :: driver)
   end subroutine template_me_def_allocate_driver
 
 @ %def template_me_def_allocate_driver
 @ We need code:
 <<Template matrix elements: template ME def: TBP>>=
   procedure, nopass :: needs_code => template_me_def_needs_code
 <<Template matrix elements: procedures>>=
   function template_me_def_needs_code () result (flag)
     logical :: flag
     flag = .true.
   end function template_me_def_needs_code
 
 @ %def template_me_def_needs_code
 @ These are the features that a template matrix element provides.
 <<Template matrix elements: template ME def: TBP>>=
   procedure, nopass :: get_features => template_me_def_get_features
 <<Template matrix elements: procedures>>=
   subroutine template_me_def_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (5))
     features = [ &
          var_str ("init"), &
          var_str ("update_alpha_s"), &
          var_str ("is_allowed"), &
          var_str ("new_event"), &
          var_str ("get_amplitude")]
   end subroutine template_me_def_get_features
 
 @ %def template_me_def_get_features
 @ The interface of the specific features.
 <<Template matrix elements: interfaces>>=
   abstract interface
      subroutine init_t (par, scheme) bind(C)
        import
        real(c_default_float), dimension(*), intent(in) :: par
        integer(c_int), intent(in) :: scheme
      end subroutine init_t
   end interface
 
   abstract interface
      subroutine update_alpha_s_t (alpha_s) bind(C)
        import
        real(c_default_float), intent(in) :: alpha_s
      end subroutine update_alpha_s_t
   end interface
 
   abstract interface
      subroutine is_allowed_t (flv, hel, col, flag) bind(C)
        import
        integer(c_int), intent(in) :: flv, hel, col
        logical(c_bool), intent(out) :: flag
      end subroutine is_allowed_t
   end interface
 
   abstract interface
      subroutine new_event_t (p) bind(C)
        import
        real(c_default_float), dimension(0:3,*), intent(in) :: p
      end subroutine new_event_t
   end interface
 
   abstract interface
      subroutine get_amplitude_t (flv, hel, col, amp) bind(C)
        import
        integer(c_int), intent(in) :: flv, hel, col
        complex(c_default_complex), intent(out):: amp
      end subroutine get_amplitude_t
   end interface
 
 @ %def init_t update_alpha_s_t
 @ %def is_allowed_t new_event_t get_amplitude_t
 @ Connect the template matrix element features with the process driver.
 <<Template matrix elements: template ME def: TBP>>=
   procedure :: connect => template_me_def_connect
 <<Template matrix elements: procedures>>=
   subroutine template_me_def_connect (def, lib_driver, i, proc_driver)
     class(template_me_def_t), intent(in) :: def
     class(prclib_driver_t), intent(in) :: lib_driver
     integer, intent(in) :: i
     class(prc_core_driver_t), intent(inout) :: proc_driver
     integer(c_int) :: pid, fid
     type(c_funptr) :: fptr
     select type (proc_driver)
     type is  (template_me_driver_t)
        pid = i
        fid = 1
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%init)
        fid = 2
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%update_alpha_s)
        fid = 3
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%is_allowed)
        fid = 4
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%new_event)
        fid = 5
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%get_amplitude)
     end select
   end subroutine template_me_def_connect
 
 @ %def template_me_def_connect
 @
 \subsection{The Template Matrix element writer}
 Unlike \oMega, the template matrix element is directly written by the main
 \whizard\ program, so there will be no entry in the makefile for
 calling an external program. The template matrix element writer is
 responsible for writing interfaces and wrappers.
 <<Template matrix elements: types>>=
   type, extends (prc_writer_f_module_t) :: template_me_writer_t
      class(model_data_t), pointer :: model => null ()
      type(string_t) :: model_name
      logical :: unity
      type(string_t), dimension(:), allocatable :: prt_in
      type(string_t), dimension(:), allocatable :: prt_out
      integer :: n_in
      integer :: n_out
      integer :: n_tot
    contains
    <<Template matrix elements: template ME writer: TBP>>
   end type template_me_writer_t
 
 @ %def template_me_writer_t
 @ The reported type is the same as for the [[template_me_def_t]] type.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure, nopass :: type_name => template_me_writer_type_name
 <<Template matrix elements: procedures>>=
   function template_me_writer_type_name () result (string)
     type(string_t) :: string
     string = "template"
   end function template_me_writer_type_name
 
 @ %def template_me_writer_type_name
 @ Taking into account the prefix for template ME module names.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure, nopass :: get_module_name => template_me_writer_get_module_name
 <<Template matrix elements: procedures>>=
   function template_me_writer_get_module_name (id) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: id
     name = "tpr_" // id
   end function template_me_writer_get_module_name
 
 @ %def template_me_writer_get_module_name
 @ Output.  This is called by [[template_me_def_write]].
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: write => template_me_writer_write
 <<Template matrix elements: procedures>>=
   subroutine template_me_writer_write (object, unit)
     class(template_me_writer_t), intent(in) :: object
     integer, intent(in) :: unit
     integer :: i, j
     write (unit, "(5x,A,I0)") "# incoming part. = ", object%n_in
     write (unit, "(7x,A)", advance="no") &
                               "   Initial state: "
     do i = 1, object%n_in - 1
        write (unit, "(1x,A)", advance="no") char (object%prt_in(i))
     end do
     write (unit, "(1x,A)") char (object%prt_in(object%n_in))
     write (unit, "(5x,A,I0)") "# outgoing part. = ", object%n_out
     write (unit, "(7x,A)", advance="no") &
                               "   Final state:   "
     do j = 1, object%n_out - 1
        write (unit, "(1x,A)", advance="no") char (object%prt_out(j))
     end do
     write (unit, "(1x,A)") char (object%prt_out(object%n_out))
     write (unit, "(5x,A,I0)") "# part. (total) = ", object%n_tot
   end subroutine template_me_writer_write
 
 @ %def template_me_writer_write
 @ Initialize with process data.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: init => template_me_writer_init
 <<Template matrix elements: procedures>>=
   subroutine template_me_writer_init (writer, model, &
        prt_in, prt_out, unity)
     class(template_me_writer_t), intent(out) :: writer
     class(model_data_t), intent(in), target :: model
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     logical, intent(in) :: unity
     writer%model => model
     writer%model_name = model%get_name ()
     writer%n_in = size (prt_in)
     writer%n_out = size (prt_out)
     writer%n_tot = size (prt_in) + size (prt_out)
     allocate (writer%prt_in (size (prt_in)), source = prt_in)
     allocate (writer%prt_out (size (prt_out)), source = prt_out)
     writer%unity = unity
   end subroutine template_me_writer_init
 
 @ %def template_me_writer_init
 @ The makefile is the driver file for the test matrix elements.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: write_makefile_code => template_me_write_makefile_code
 <<Template matrix elements: procedures>>=
   subroutine template_me_write_makefile_code &
        (writer, unit, id, os_data, verbose, testflag)
     class(template_me_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     logical, intent(in), optional :: testflag
     write (unit, "(5A)")  "SOURCES += ", char (id), ".f90"
     write (unit, "(5A)")  "OBJECTS += ", char (id), ".lo"
     write (unit, "(5A)")  "clean-", char (id), ":"
     if (verbose) then
        write (unit, "(5A)")  TAB, "rm -f tpr_", char (id), ".mod"
        write (unit, "(5A)")  TAB, "rm -f ", char (id), ".lo"
     else
        write (unit, "(5A)")  TAB // '@echo  "  RM        ', &
             trim (char (id)), '.mod"'
        write (unit, "(5A)")  TAB, "@rm -f tpr_", char (id), ".mod"
        write (unit, "(5A)")  TAB // '@echo  "  RM        ', &
             trim (char (id)), '.lo"'
        write (unit, "(5A)")  TAB, "@rm -f ", char (id), ".lo"
     end if
     write (unit, "(5A)")  "CLEAN_SOURCES += ", char (id), ".f90"
     write (unit, "(5A)")  "CLEAN_OBJECTS += tpr_", char (id), ".mod"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), ".lo"
     write (unit, "(5A)")  char (id), ".lo: ", char (id), ".f90"
     if (.not. verbose) then
        write (unit, "(5A)")  TAB // '@echo  "  FC       " $@'
     end if
     write (unit, "(5A)")  TAB, "$(LTFCOMPILE) $<"
   end subroutine template_me_write_makefile_code
 
 @ %def template_me_write_makefile_code
 @ The source is written by this routine.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: write_source_code => template_me_write_source_code
 <<Template matrix elements: procedures>>=
   subroutine template_me_write_source_code (writer, id)
     class(template_me_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     integer, dimension(writer%n_in) :: prt_in, mult_in, col_in
     type(flavor_t), dimension(1:writer%n_in) :: flv_in
     integer, dimension(writer%n_out) :: prt_out, mult_out
     integer, dimension(writer%n_tot) :: prt, mult
     integer, dimension(:,:), allocatable :: sxxx
     integer :: dummy, status
     type(flavor_t), dimension(1:writer%n_out) :: flv_out
     type(string_t) :: proc_str, comment_str, col_str
     integer :: u, i, j
     integer :: hel, hel_in, hel_out, fac, factor, col_fac
     type(string_t) :: filename
     comment_str = ""
     do i = 1, writer%n_in
        comment_str = comment_str // writer%prt_in(i) // " "
     end do
     do j = 1, writer%n_out
        comment_str = comment_str // writer%prt_out(j) // " "
     end do
     do i = 1, writer%n_in
        prt_in(i) = writer%model%get_pdg (writer%prt_in(i))
        call flv_in(i)%init (prt_in(i), writer%model)
        mult_in(i) = flv_in(i)%get_multiplicity ()
        col_in(i) = abs (flv_in(i)%get_color_type ())
        mult(i) = mult_in(i)
        end do
     do j = 1, writer%n_out
        prt_out(j) = writer%model%get_pdg (writer%prt_out(j))
        call flv_out(j)%init (prt_out(j), writer%model)
        mult_out(j) = flv_out(j)%get_multiplicity ()
        mult(writer%n_in + j) = mult_out(j)
        end do
     prt(1:writer%n_in) = prt_in(1:writer%n_in)
     prt(writer%n_in+1:writer%n_tot) = prt_out(1:writer%n_out)
     proc_str = converter (prt)
     hel_in = product (mult_in)
     hel_out = product (mult_out)
     col_fac = product (col_in)
     hel = hel_in * hel_out
     fac = hel
     dummy = 1
     factor = 1
     if (writer%n_out >= 3) then
        do i = 3, writer%n_out
           factor = factor * (i - 2) * (i - 1)
        end do
     end if
     factor = factor * col_fac
     allocate (sxxx(1:hel,1:writer%n_tot))
     call create_spin_table (dummy,hel,fac,mult,sxxx)
     call msg_message ("Writing test matrix element for process '" &
          // char (id) // "'")
     filename = id // ".f90"
     u = free_unit ()
     open (unit=u, file=char(filename), action="write")
     write (u, "(A)") "! File generated automatically by WHIZARD"
     write (u, "(A)") "!                                        "
     write (u, "(A)") "! Note that irresp. of what you demanded WHIZARD"
     write (u, "(A)") "! treats this as colorless process       "
     write (u, "(A)") "!                                        "
     write (u, "(A)") "module tpr_" // char(id)
     write (u, "(A)") "                                         "
     write (u, "(A)") "  use kinds"
     write (u, "(A)") "  use omega_color, OCF => omega_color_factor"
     write (u, "(A)") "                                         "
     write (u, "(A)") "  implicit none"
     write (u, "(A)") "  private"
     write (u, "(A)") "                                         "
     write (u, "(A)") "  public :: md5sum"
     write (u, "(A)") "  public :: number_particles_in, number_particles_out"
     write (u, "(A)") "  public :: number_spin_states, spin_states"
     write (u, "(A)") "  public :: number_flavor_states, flavor_states"
     write (u, "(A)") "  public :: number_color_flows, color_flows"
     write (u, "(A)") "  public :: number_color_indices, number_color_factors, &"
     write (u, "(A)") "     color_factors, color_sum, openmp_supported"
     write (u, "(A)") "  public :: init, final, update_alpha_s"
     write (u, "(A)") "                                         "
     write (u, "(A)") "  public :: new_event, is_allowed, get_amplitude"
     write (u, "(A)") "       "
     write (u, "(A)") "  real(default), parameter :: &"
     write (u, "(A)") "       & conv = 0.38937966e12_default"
     write (u, "(A)") "       "
     write (u, "(A)") "  real(default), parameter :: &"
     write (u, "(A)") "       & pi = 3.1415926535897932384626433832795028841972_default"
     write (u, "(A)") "       "
     write (u, "(A)") "  real(default), parameter :: &"
     if (writer%unity) then
        write (u, "(A)") "                   & const = 1"
     else
        write (u, "(A,1x,I0,A)") "       & const = (16 * pi / conv) * " &
           // "(16 * pi**2)**(", writer%n_out, "-2) "
     end if
     write (u, "(A)") "       "
     write (u, "(A,1x,I0)") "  integer, parameter, private :: n_prt =  ", &
        writer%n_tot
     write (u, "(A,1x,I0)") "  integer, parameter, private :: n_in = ", &
        writer%n_in
     write (u, "(A,1x,I0)") "  integer, parameter, private :: n_out = ", &
        writer%n_out
     write (u, "(A)") "  integer, parameter, private :: n_cflow = 1"
     write (u, "(A)") "  integer, parameter, private :: n_cindex = 2"
     write (u, "(A)") "  !!! We ignore tensor products and take only one flavor state."
     write (u, "(A)") "  integer, parameter, private :: n_flv = 1"
     write (u, "(A,1x,I0)") "  integer, parameter, private :: n_hel = ", hel
     write (u, "(A)") "                                           "
     write (u, "(A)") "  logical, parameter, private :: T = .true."
     write (u, "(A)") "  logical, parameter, private :: F = .false."
     write (u, "(A)") "                                           "
     do i = 1, hel
        write (u, "(A)") "  integer, dimension(n_prt), parameter, private :: &"
        write (u, "(A)") "    " // s_conv(i) // " = [ " // &
             char(converter(sxxx(i,1:writer%n_tot))) // " ]"
     end do
     write (u, "(A)") "  integer, dimension(n_prt,n_hel), parameter, private :: table_spin_states = &"
     write (u, "(A)") "    reshape ( [ & "
     do i = 1, hel-1
        write (u, "(A)") "                 " // s_conv(i) // ", & "
     end do
     write (u, "(A)") "                 " // s_conv(hel) // " & "
     write (u, "(A)") "              ], [ n_prt, n_hel ] )"
     write (u, "(A)") "                                                 "
     write (u, "(A)") "  integer, dimension(n_prt), parameter, private :: &"
     write (u, "(A)") "    f0001 = [ " // char(proc_str) // " ]   !  " // char(comment_str)
     write (u, "(A)") "  integer, dimension(n_prt,n_flv), parameter, private :: table_flavor_states = &"
     write (u, "(A)") "    reshape ( [ f0001 ], [ n_prt, n_flv ] )"
     write (u, "(A)") "                                                 "
     write (u, "(A)") "  integer, dimension(n_cindex, n_prt), parameter, private :: &"
     !!! This produces non-matching color flows, better keep it completely colorless
     ! write (u, "(A)") "    c0001 = reshape ( [ " // char (dummy_colorizer (flv_in)) // &
     !                          " " // &
     select case (writer%n_in)
     case (1)
        col_str = "0,0,"
     case (2)
        col_str = "0,0,0,0,"
     end select
     write (u, "(A)") "    c0001 = reshape ( [" // char (col_str) // &
       (repeat ("0,0, ", writer%n_out-1)) // "0,0 ], " // " [ n_cindex, n_prt ] )"
     write (u, "(A)") "  integer, dimension(n_cindex, n_prt, n_cflow), parameter, private :: &"
     write (u, "(A)") "  table_color_flows = reshape ( [ c0001 ], [ n_cindex, n_prt, n_cflow ] )"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  logical, dimension(n_prt), parameter, private :: & "
     write (u, "(A)") "    g0001 = [ "  // (repeat ("F, ", writer%n_tot-1)) // "F ] "
     write (u, "(A)") "  logical, dimension(n_prt, n_cflow), parameter, private " &
          // ":: table_ghost_flags = &"
     write (u, "(A)") "    reshape ( [ g0001 ], [ n_prt, n_cflow ] )"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  integer, parameter, private :: n_cfactors = 1"
     write (u, "(A)") "  type(OCF), dimension(n_cfactors), parameter, private :: &"
     write (u, "(A)") "    table_color_factors = [  OCF(1,1,+1._default) ]"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  logical, dimension(n_flv), parameter, private :: a0001 = [ T ]"
     write (u, "(A)") "  logical, dimension(n_flv, n_cflow), parameter, private :: &"
     write (u, "(A)") "    flv_col_is_allowed = reshape ( [ a0001 ], [ n_flv, n_cflow ] )"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  complex(default), dimension (n_flv, n_hel, n_cflow), private, save :: amp"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  logical, dimension(n_hel), private, save :: hel_is_allowed = T"
     write (u, "(A)") "                                           "
     write (u, "(A)") "contains"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function md5sum ()"
     write (u, "(A)") "    character(len=32) :: md5sum"
     write (u, "(A)") "    ! DON'T EVEN THINK of modifying the following line!"
     write (u, "(A)") "    md5sum = """ // writer%md5sum // """"
     write (u, "(A)") "  end function md5sum"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  subroutine init (par, scheme)"
     write (u, "(A)") "    real(default), dimension(*), intent(in) :: par"
     write (u, "(A)") "    integer, intent(in) :: scheme"
     write (u, "(A)") "  end subroutine init"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  subroutine final ()"
     write (u, "(A)") "  end subroutine final"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  subroutine update_alpha_s (alpha_s)"
     write (u, "(A)") "    real(default), intent(in) :: alpha_s"
     write (u, "(A)") "  end subroutine update_alpha_s"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_particles_in () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = n_in"
     write (u, "(A)") "  end function number_particles_in"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_particles_out () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = n_out"
     write (u, "(A)") "  end function number_particles_out"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_spin_states () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = size (table_spin_states, dim=2)"
     write (u, "(A)") "  end function number_spin_states"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure subroutine spin_states (a)"
     write (u, "(A)") "    integer, dimension(:,:), intent(out) :: a"
     write (u, "(A)") "    a = table_spin_states"
     write (u, "(A)") "  end subroutine spin_states"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_flavor_states () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = 1"
     write (u, "(A)") "  end function number_flavor_states"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure subroutine flavor_states (a)"
     write (u, "(A)") "    integer, dimension(:,:), intent(out) :: a"
     write (u, "(A)") "    a = table_flavor_states"
     write (u, "(A)") "  end subroutine flavor_states"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_color_indices () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = size(table_color_flows, dim=1)"
     write (u, "(A)") "  end function number_color_indices"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure subroutine color_factors (cf)"
     write (u, "(A)") "    type(OCF), dimension(:), intent(out) :: cf"
     write (u, "(A)") "    cf = table_color_factors"
     write (u, "(A)") "  end subroutine color_factors"
     write (u, "(A)") "                                           "
     !pure unless OpenMP
     !write (u, "(A)") "  pure function color_sum (flv, hel) result (amp2)"
     write (u, "(A)") "  function color_sum (flv, hel) result (amp2)"
     write (u, "(A)") "    integer, intent(in) :: flv, hel"
     write (u, "(A)") "    real(kind=default) :: amp2"
     write (u, "(A)") "    amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))"
     write (u, "(A)") "  end function color_sum"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_color_flows () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = size (table_color_flows, dim=3)"
     write (u, "(A)") "  end function number_color_flows"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure subroutine color_flows (a, g)"
     write (u, "(A)") "    integer, dimension(:,:,:), intent(out) :: a"
     write (u, "(A)") "    logical, dimension(:,:), intent(out) :: g"
     write (u, "(A)") "    a = table_color_flows"
     write (u, "(A)") "    g = table_ghost_flags"
     write (u, "(A)") "  end subroutine color_flows"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function number_color_factors () result (n)"
     write (u, "(A)") "    integer :: n"
     write (u, "(A)") "    n = size (table_color_factors)"
     write (u, "(A)") "  end function number_color_factors"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function openmp_supported () result (status)"
     write (u, "(A)") "    logical :: status"
     write (u, "(A)") "    status = .false."
     write (u, "(A)") "  end function openmp_supported"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  subroutine new_event (p)"
     write (u, "(A)") "    real(default), dimension(0:3,*), intent(in) :: p"
     write (u, "(A)") "    call calculate_amplitudes (amp, p)"
     write (u, "(A)") "  end subroutine new_event"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function is_allowed (flv, hel, col) result (yorn)"
     write (u, "(A)") "    logical :: yorn"
     write (u, "(A)") "    integer, intent(in) :: flv, hel, col"
     write (u, "(A)") "    yorn = hel_is_allowed(hel) .and. flv_col_is_allowed(flv,col)"
     write (u, "(A)") "  end function is_allowed"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure function get_amplitude (flv, hel, col) result (amp_result)"
     write (u, "(A)") "    complex(default) :: amp_result"
     write (u, "(A)") "    integer, intent(in) :: flv, hel, col"
     write (u, "(A)") "    amp_result = amp (flv, hel, col)"
     write (u, "(A)") "  end function get_amplitude"
     write (u, "(A)") "                                           "
     write (u, "(A)") "  pure subroutine calculate_amplitudes (amp, k)"
     write (u, "(A)") "    complex(default), dimension(:,:,:), intent(out) :: amp"
     write (u, "(A)") "    real(default), dimension(0:3,*), intent(in) :: k"
     write (u, "(A)") "    real(default) :: fac"
     write (u, "(A)") "    integer :: i"
     write (u, "(A)") "    ! We give all helicities the same weight!"
     if (writer%unity) then
        write (u, "(A,1x,I0,1x,A)") "    fac = ", col_fac
        write (u, "(A)") "    amp = const * sqrt(fac)"
     else
        write (u, "(A,1x,I0,1x,A)") "    fac = ", factor
        write (u, "(A)") "    amp = sqrt((2 * (k(0,1)*k(0,2) &"
        write (u, "(A,1x,I0,A)") "         - dot_product (k(1:,1), k(1:,2)))) ** (3-", &
                                   writer%n_out, ")) * sqrt(const * fac)"
     end if
     write (u, "(A,1x,I0,A)") "    amp = amp / sqrt(", hel_out, "._default)"
     write (u, "(A)") "  end subroutine calculate_amplitudes"
     write (u, "(A)") "                                           "
     write (u, "(A)") "end module tpr_" // char(id)
     close (u, iostat=status)
     deallocate (sxxx)
   contains
     function s_conv (num) result (chrt)
       integer, intent(in) :: num
       character(len=10) :: chrt
       write (chrt, "(I10)") num
       chrt = trim(adjustl(chrt))
       if (num < 10) then
          chrt = "s000" // chrt
       else if (num < 100) then
          chrt = "s00" // chrt
       else if (num < 1000) then
          chrt = "s0" // chrt
       else
          chrt = "s" // chrt
       end if
     end function s_conv
     function converter (flv) result (str)
       integer, dimension(:), intent(in) :: flv
       type(string_t) :: str
       character(len=150), dimension(size(flv)) :: chrt
       integer :: i
       str = ""
       do i = 1, size(flv) - 1
          write (chrt(i), "(I10)") flv(i)
          str = str // var_str(trim(adjustl(chrt(i)))) // ", "
       end do
       write (chrt(size(flv)), "(I10)") flv(size(flv))
       str = str // trim(adjustl(chrt(size(flv))))
     end function converter
     integer function sj (j,m)
       integer, intent(in) :: j, m
       if (((j == 1) .and. (m == 1)) .or. &
           ((j == 2) .and. (m == 2)) .or. &
           ((j == 3) .and. (m == 3)) .or. &
           ((j == 4) .and. (m == 3)) .or. &
           ((j == 5) .and. (m == 4))) then
          sj = 1
       else if (((j == 2) .and. (m == 1)) .or. &
           ((j == 3) .and. (m == 1)) .or. &
           ((j == 4) .and. (m == 2)) .or. &
           ((j == 5) .and. (m == 2))) then
          sj = -1
       else if (((j == 3) .and. (m == 2)) .or. &
           ((j == 5) .and. (m == 3))) then
          sj = 0
       else if (((j == 4) .and. (m == 1)) .or. &
           ((j == 5) .and. (m == 1))) then
          sj = -2
       else if (((j == 4) .and. (m == 4)) .or. &
           ((j == 5) .and. (m == 5))) then
          sj = 2
       else
          call msg_fatal ("template_me_write_source_code: Wrong spin type")
       end if
     end function sj
     recursive subroutine create_spin_table (index, nhel, fac, mult, inta)
       integer, intent(inout) :: index, fac
       integer, intent(in) :: nhel
       integer, dimension(:), intent(in) :: mult
       integer, dimension(nhel,size(mult)), intent(out) :: inta
       integer :: j
       if (index > size(mult)) return
       fac = fac / mult(index)
       do j = 1, nhel
          inta(j,index) = sj (mult(index),mod(((j-1)/fac),mult(index))+1)
       end do
       index = index + 1
       call create_spin_table (index, nhel, fac, mult, inta)
     end subroutine create_spin_table
     function dummy_colorizer (flv) result (str)
       type(flavor_t), dimension(:), intent(in) :: flv
       type(string_t) :: str
       integer :: i, k
       str = ""
       k = 0
       do i = 1, size(flv)
          k = k + 1
          select case (flv(i)%get_color_type ())
 	 case (1,-1)
 	    str = str // "0,0, "
 	 case (3)
 	    str = str // int2string(k) // ",0, "
 	 case (-3)
 	    str = str // "0," // int2string(-k) // ", "
 	 case (8)
 	    str = str // int2string(k) // "," // int2string(-k-1) // ", "
 	    k = k + 1
 	 case default
 	    call msg_error ("Color type not supported.")
 	 end select
       end do
       str = adjustl(trim(str))
     end function dummy_colorizer
   end subroutine template_me_write_source_code
 
 @ %def template_me_write_source_code
 @ Nothing to be done here.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: before_compile => template_me_before_compile
   procedure :: after_compile => template_me_after_compile
 <<Template matrix elements: procedures>>=
   subroutine template_me_before_compile (writer, id)
     class(template_me_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine template_me_before_compile
 
   subroutine template_me_after_compile (writer, id)
     class(template_me_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine template_me_after_compile
 
 @ %def template_me_before_compile
 @ %def template_me_after_compile
 @ Return the name of a procedure that implements a given feature, as
 it is provided by the template matrix-element code.  Template ME names
 are chosen completely in analogy to the \oMega\ matrix element
 conventions.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure, nopass :: get_procname => template_me_writer_get_procname
 <<Template matrix elements: procedures>>=
   function template_me_writer_get_procname (feature) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: feature
     select case (char (feature))
     case ("n_in");   name = "number_particles_in"
     case ("n_out");  name = "number_particles_out"
     case ("n_flv");  name = "number_flavor_states"
     case ("n_hel");  name = "number_spin_states"
     case ("n_col");  name = "number_color_flows"
     case ("n_cin");  name = "number_color_indices"
     case ("n_cf");   name = "number_color_factors"
     case ("flv_state");  name = "flavor_states"
     case ("hel_state");  name = "spin_states"
     case ("col_state");  name = "color_flows"
     case default
        name = feature
     end select
   end function template_me_writer_get_procname
 
 @ %def template_me_writer_get_procname
 @ The interfaces for the template-specific features.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: write_interface => template_me_write_interface
 <<Template matrix elements: procedures>>=
   subroutine template_me_write_interface (writer, unit, id, feature)
     class(template_me_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(string_t), intent(in) :: feature
     type(string_t) :: name
     name = writer%get_c_procname (id, feature)
     write (unit, "(2x,9A)")  "interface"
     select case (char (feature))
     case ("init")
        write (unit, "(5x,9A)")  "subroutine ", char (name), &
             " (par, scheme) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), dimension(*), &
             &intent(in) :: par"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: scheme"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("update_alpha_s")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " (alpha_s) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), intent(in) :: alpha_s"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("is_allowed")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(flv, hel, col, flag) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(7x,9A)")  "logical(c_bool), intent(out) :: flag"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("new_event")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " (p) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), dimension(0:3,*), &
             &intent(in) :: p"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("get_amplitude")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(flv, hel, col, amp) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(7x,9A)")  "complex(c_default_complex), intent(out) &
             &:: amp"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     end select
     write (unit, "(2x,9A)")  "end interface"
   end subroutine template_me_write_interface
 
 @ %def template_me_write_interface
 @ The wrappers have to take into account conversion between C and
 Fortran data types.
 
 NOTE: The case [[c_default_float]] $\neq$ [[default]] is not yet covered.
 <<Template matrix elements: template ME writer: TBP>>=
   procedure :: write_wrapper => template_me_write_wrapper
 <<Template matrix elements: procedures>>=
   subroutine template_me_write_wrapper (writer, unit, id, feature)
     class(template_me_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     type(string_t) :: name
     name = writer%get_c_procname (id, feature)
     write (unit, *)
     select case (char (feature))
     case ("init")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (par, scheme) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use tpr_", char (id)
        write (unit, "(2x,9A)")  "real(c_default_float), dimension(*), &
             &intent(in) :: par"
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: scheme"
        if (c_default_float == default .and. c_int == kind(1)) then
           write (unit, "(2x,9A)")  "call ", char (feature), " (par, scheme)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("update_alpha_s")
        write (unit, "(9A)")  "subroutine ", char (name), " (alpha_s) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use tpr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), intent(in) &
                &:: alpha_s"
           write (unit, "(2x,9A)")  "call ", char (feature), " (alpha_s)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("is_allowed")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (flv, hel, col, flag) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use tpr_", char (id)
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(2x,9A)")  "logical(c_bool), intent(out) :: flag"
        write (unit, "(2x,9A)")  "flag = ", char (feature), &
             " (int (flv), int (hel), int (col))"
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("new_event")
        write (unit, "(9A)")  "subroutine ", char (name), " (p) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use tpr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), dimension(0:3,*), &
                &intent(in) :: p"
           write (unit, "(2x,9A)")  "call ", char (feature), " (p)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("get_amplitude")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (flv, hel, col, amp) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use tpr_", char (id)
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(2x,9A)")  "complex(c_default_complex), intent(out) &
             &:: amp"
        write (unit, "(2x,9A)")  "amp = ", char (feature), &
             " (int (flv), int (hel), int (col))"
        write (unit, "(9A)")  "end subroutine ", char (name)
     end select
   end subroutine template_me_write_wrapper
 
 @ %def template_me_write_wrapper
 @
 \subsection{Driver}
 <<Template matrix elements: public>>=
   public :: template_me_driver_t
 <<Template matrix elements: types>>=
   type, extends (prc_core_driver_t) :: template_me_driver_t
      procedure(init_t), nopass, pointer :: &
           init => null ()
      procedure(update_alpha_s_t), nopass, pointer :: &
           update_alpha_s => null ()
      procedure(is_allowed_t), nopass, pointer :: &
           is_allowed => null ()
      procedure(new_event_t), nopass, pointer :: &
           new_event => null ()
      procedure(get_amplitude_t), nopass, pointer :: &
           get_amplitude => null ()
    contains
    <<Template matrix elements: template ME driver: TBP>>
   end type template_me_driver_t
 
 @ %def template_me_driver_t
 @ The reported type is the same as for the [[template_me_def_t]] type.
 <<Template matrix elements: template ME driver: TBP>>=
   procedure, nopass :: type_name => template_me_driver_type_name
 <<Template matrix elements: procedures>>=
   function template_me_driver_type_name () result (string)
     type(string_t) :: string
     string = "template"
   end function template_me_driver_type_name
 
 @ %def template_me_driver_type_name
 @
 \subsection{High-level process definition}
 This procedure wraps the details filling a process-component
 definition entry as appropriate for an template matrix element.
 <<Template matrix elements: public>>=
   public :: template_me_make_process_component
 <<Template matrix elements: procedures>>=
   subroutine template_me_make_process_component (entry, component_index, &
          model, model_name, prt_in, prt_out, unity)
     class(process_def_entry_t), intent(inout) :: entry
     integer, intent(in) :: component_index
     type(string_t), intent(in) :: model_name
     class(model_data_t), intent(in), target :: model
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     logical, intent(in) :: unity
     class(prc_core_def_t), allocatable :: def
     allocate (template_me_def_t :: def)
     select type (def)
     type is (template_me_def_t)
        call def%init (model, prt_in, prt_out, unity)
     end select
     call entry%import_component (component_index, &
          n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method = var_str ("template"), &
          variant = def)
   end subroutine template_me_make_process_component
 
 @ %def template_me_make_process_component
 @
 \subsection{The [[prc_template_me_t]] wrapper}
 This is an instance of the generic [[prc_core_t]] object.  It contains a
 pointer to the process definition ([[template_me_def_t]]), a data component
 ([[process_constants_t]]), and the matrix-element driver
 ([[template_me_driver_t]]).
 <<Template matrix elements: public>>=
   public :: prc_template_me_t
 <<Template matrix elements: types>>=
   type, extends (prc_core_t) :: prc_template_me_t
      real(default), dimension(:), allocatable :: par
      integer :: scheme = 0
    contains
    <<Template matrix elements: prc template ME: TBP>>
   end type prc_template_me_t
 
 @ %def prc_template_me_t
 @ The workspace associated to a [[prc_template_me_t]] object contains a single flag.
 The flag is used to suppress re-evaluating the matrix element for each
 quantum-number combination, after the first amplitude belonging to a given
 kinematics has been computed.
 
 We can also store the value of a running coupling once it has been calculated
 for an event.  The default value is negative, which indicates an undefined
 value in this context.
 <<Template matrix elements: types>>=
   type, extends (prc_core_state_t) :: template_me_state_t
      logical :: new_kinematics = .true.
      real(default) :: alpha_qcd = -1
+     real(default) :: alpha_qed = -1
    contains
      procedure :: write => template_me_state_write
      procedure :: reset_new_kinematics => template_me_state_reset_new_kinematics
   end type template_me_state_t
 
 @ %def template_me_state_t
 <<Template matrix elements: procedures>>=
   subroutine template_me_state_write (object, unit)
     class(template_me_state_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A,L1)")  "Template ME state: new kinematics = ", &
          object%new_kinematics
   end subroutine template_me_state_write
 
 @ %def template_me_state_write
 @
 <<Template matrix elements: procedures>>=
   subroutine template_me_state_reset_new_kinematics (object)
     class(template_me_state_t), intent(inout) :: object
   end subroutine template_me_state_reset_new_kinematics
 
 @
 @ Allocate the workspace with the above specific type.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: allocate_workspace => prc_template_me_allocate_workspace
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_allocate_workspace (object, core_state)
     class(prc_template_me_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     allocate (template_me_state_t :: core_state)
   end subroutine prc_template_me_allocate_workspace
 
 @ %def prc_template_me_allocate_workspace
 @ The following procedures are inherited from the base type as deferred, thus
 must be implemented.  The corresponding unit tests are skipped here; the
 procedures are tested when called from the [[processes]] module.
 
 Output: print just the ID of the associated matrix element.  Then display any
 stored parameters.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: write => prc_template_me_write
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_write (object, unit)
     class(prc_template_me_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(3x,A)", advance="no")  "Template process core:"
     if (object%data_known) then
        write (u, "(1x,A)")  char (object%data%id)
     else
        write (u, "(1x,A)")  "[undefined]"
     end if
     if (allocated (object%par)) then
        write (u, "(3x,A)")  "Parameter array:"
        do i = 1, size (object%par)
           write (u, "(5x,I0,1x,ES17.10)")  i, object%par(i)
        end do
     end if
   end subroutine prc_template_me_write
 
 @ %def prc_template_me_write
 @
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: write_name => prc_template_me_write_name
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_write_name (object, unit)
     class(prc_template_me_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(1x,A)") "Core: template"
   end subroutine prc_template_me_write_name
 
 @ %def prc_template_me_write_name
 @ Temporarily store the parameter array inside the [[prc_template_me]]
 object, so we can use it later during the actual initialization.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: set_parameters => prc_template_me_set_parameters
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_set_parameters (prc_template_me, model)
     class(prc_template_me_t), intent(inout) :: prc_template_me
     class(model_data_t), intent(in), target, optional :: model
     if (present (model)) then
        if (.not. allocated (prc_template_me%par)) &
             allocate (prc_template_me%par (model%get_n_real ()))
        call model%real_parameters_to_array (prc_template_me%par)
        prc_template_me%scheme = model%get_scheme_num ()
     end if
   end subroutine prc_template_me_set_parameters
 
 @ %def prc_template_me_set_parameters
 @ To fully initialize the process core, we perform base
 initialization, then initialize the external matrix element code.
 
 This procedure overrides the [[init]] method of the base type, which
 we nevertheless can access via its binding [[base_init]].  When done, we
 have an allocated driver.  The driver will call the [[init]] procedure
 for the external matrix element, and thus transfer the parameter set to
 where it finally belongs.
 
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: init => prc_template_me_init
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_init (object, def, lib, id, i_component)
     class(prc_template_me_t), intent(inout) :: object
     class(prc_core_def_t), intent(in), target :: def
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     call object%base_init (def, lib, id, i_component)
     call object%activate_parameters ()
   end subroutine prc_template_me_init
 
 @ %def prc_template_me_init
 @ Activate the stored parameters by transferring them to the external
 matrix element.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: activate_parameters => prc_template_me_activate_parameters
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_activate_parameters (object)
     class (prc_template_me_t), intent(inout) :: object
     if (allocated (object%driver)) then
        if (allocated (object%par)) then
           select type (driver => object%driver)
           type is (template_me_driver_t)
              if (associated (driver%init)) then
                 call driver%init (object%par, object%scheme)
              end if
           end select
        else
           call msg_bug ("prc_template_me_activate: parameter set is not allocated")
        end if
     else
        call msg_bug ("prc_template_me_activate: driver is not allocated")
     end if
   end subroutine prc_template_me_activate_parameters
 
 @ %def prc_template_me_activate_parameters
 @ Tell whether a particular combination of flavor, helicity, color is
 allowed.  Here we have to consult the matrix-element driver.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: is_allowed => prc_template_me_is_allowed
 <<Template matrix elements: procedures>>=
  function prc_template_me_is_allowed (object, i_term, f, h, c) result (flag)
     class(prc_template_me_t), intent(in) :: object
     integer, intent(in) :: i_term, f, h, c
     logical :: flag
     logical(c_bool) :: cflag
     select type (driver => object%driver)
     type is (template_me_driver_t)
        call driver%is_allowed (f, h, c, cflag)
        flag = cflag
     end select
   end function prc_template_me_is_allowed
 
 @ %def prc_template_me_is_allowed
 @ Transfer the generated momenta directly to the hard interaction in
 the (only) term.  We assume that everything has been set up correctly,
 so the array fits.
 
 %We reset the [[new_kinematics]] flag, so that the next call to
 %[[compute_amplitude]] will evaluate the matrix element.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: compute_hard_kinematics => &
        prc_template_me_compute_hard_kinematics
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_compute_hard_kinematics &
        (object, p_seed, i_term, int_hard, core_state)
     class(prc_template_me_t), intent(in) :: object
     type(vector4_t), dimension(:), intent(in) :: p_seed
     integer, intent(in) :: i_term
     type(interaction_t), intent(inout) :: int_hard
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     call int_hard%set_momenta (p_seed)
   end subroutine prc_template_me_compute_hard_kinematics
 
 @ %def prc_template_me_compute_hard_kinematics
 @ This procedure is not called for [[prc_template_me_t]], just a placeholder.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: compute_eff_kinematics => &
        prc_template_me_compute_eff_kinematics
 <<Template matrix elements: procedures>>=
   subroutine prc_template_me_compute_eff_kinematics &
        (object, i_term, int_hard, int_eff, core_state)
     class(prc_template_me_t), intent(in) :: object
     integer, intent(in) :: i_term
     type(interaction_t), intent(in) :: int_hard
     type(interaction_t), intent(inout) :: int_eff
     class(prc_core_state_t), intent(inout), allocatable :: core_state
   end subroutine prc_template_me_compute_eff_kinematics
 
 @ %def prc_template_me_compute_eff_kinematics
 @ Compute the amplitude.  For the tree-level process, we can ignore the scale
 settings.  The term index [[j]] is also irrelevant.
 
 We first call [[new_event]] for the given momenta (which we must unpack), then
 retrieve the amplitude value for the given quantum numbers.
 
 If the [[core_state]] status flag is present, we can make sure that we call
 [[new_event]] only once for a given kinematics.  After the first call, we
 unset the [[new_kinematics]] flag.
 <<Template matrix elements: prc template ME: TBP>>=
   procedure :: compute_amplitude => prc_template_me_compute_amplitude
 <<Template matrix elements: procedures>>=
   function prc_template_me_compute_amplitude &
        (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
        core_state)  result (amp)
     class(prc_template_me_t), intent(in) :: object
     integer, intent(in) :: j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in) :: fac_scale, ren_scale
     real(default), intent(in), allocatable :: alpha_qcd_forced
     class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
     complex(default) :: amp
     integer :: n_tot, i
     real(c_default_float), dimension(:,:), allocatable :: parray
     complex(c_default_complex) :: camp
     logical :: new_event
     select type (driver => object%driver)
     type is (template_me_driver_t)
        new_event = .true.
        if (present (core_state)) then
           if (allocated (core_state)) then
              select type (core_state)
              type is (template_me_state_t)
                 new_event = core_state%new_kinematics
                 core_state%new_kinematics = .false.
              end select
           end if
        end if
        if (new_event) then
           n_tot = object%data%n_in + object%data%n_out
           allocate (parray (0:3, n_tot))
           forall (i = 1:n_tot)  parray(:,i) = vector4_get_components (p(i))
           call driver%new_event (parray)
        end if
        if (object%is_allowed (1, f, h, c)) then
           call driver%get_amplitude &
                (int (f, c_int), int (h, c_int), int (c, c_int), camp)
           amp = camp
        else
           amp = 0
        end if
     end select
   end function prc_template_me_compute_amplitude
 
 @ %def prc_template_me_compute_amplitude
 @ We do not overwrite the [[prc_core_t]] routine for $\alpha_s$.
 
 \subsection{Unit Test}
 Test module, followed by the corresponding implementation module.
 <<[[prc_template_me_ut.f90]]>>=
 <<File header>>
 
 module prc_template_me_ut
   use unit_tests
   use prc_template_me_uti
 
 <<Standard module head>>
 
 <<Template matrix elements: public test>>
 
 contains
 
 <<Template matrix elements: test driver>>
 
 end module prc_template_me_ut
 @ %def prc_template_me_ut
 @
 <<[[prc_template_me_uti.f90]]>>=
 <<File header>>
 
 module prc_template_me_uti
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
 <<Use strings>>
   use os_interface
   use particle_specifiers, only: new_prt_spec
   use model_data
   use prc_core_def
   use process_constants
   use process_libraries
   use model_testbed, only: prepare_model, cleanup_model
 
   use prc_template_me
 
 <<Standard module head>>
 
 <<Template matrix elements: test declarations>>
 
 contains
 
 <<Template matrix elements: tests>>
 
 end module prc_template_me_uti
 @ %def prc_template_me_ut
 @ API: driver for the unit tests below.
 <<Template matrix elements: public test>>=
   public :: prc_template_me_test
 <<Template matrix elements: test driver>>=
   subroutine prc_template_me_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Template matrix elements: execute tests>>
 end subroutine prc_template_me_test
 
 @ %def prc_template_me_test
 @
 \subsubsection{Generate, compile and load a simple process matrix element}
 The process is $e^+ e^- \to \mu^+\mu^-$ for vanishing masses and
 $e=0.3$.  We initialize the process, build the library, and compute a
 particular matrix element for momenta of unit energy and right-angle
 scattering.  The matrix element, as it happens, is equal to $e^2$.
 (Note that are no conversion factors applied, so this result is
 exact.)
 
 For [[GNU make]], [[makeflags]] is set to [[-j1]].  This eliminates a
 potential clash with a [[-j<n>]] flag if this test is called from a
 parallel make.
 <<Template matrix elements: execute tests>>=
   call test (prc_template_me_1, "prc_template_me_1", &
        "build and load simple template process", &
        u, results)
 <<Template matrix elements: test declarations>>=
   public :: prc_template_me_1
 <<Template matrix elements: tests>>=
   subroutine prc_template_me_1 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     type(string_t) :: model_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(process_constants_t) :: data
     class(prc_core_driver_t), allocatable :: driver
     integer, parameter :: cdf = c_default_float
     integer, parameter :: ci = c_int
     real(cdf), dimension(4) :: par
     real(cdf), dimension(0:3,4) :: p
     logical(c_bool) :: flag
     complex(c_default_complex) :: amp
     integer :: i
 
     write (u, "(A)")  "* Test output: prc_template_me_1"
     write (u, "(A)")  "*   Purpose: create a template matrix element,"
     write (u, "(A)")  "*            normalized to give unit integral,"
     write (u, "(A)")  "*            build a library, link, load, and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("template_me1"))
     call os_data%init ()
 
     model_name = "QED"
     model => null ()
     call prepare_model (model, model_name)
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e+"), var_str ("e-")]
     prt_out = [var_str ("m+"), var_str ("m-")]
 
     allocate (template_me_def_t :: def)
     select type (def)
     type is (template_me_def_t)
        call def%init (model, prt_in, prt_out, unity = .false.)
     end select
     allocate (entry)
     call entry%init (var_str ("template_me1_a"), model_name = model_name, &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("template"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Write makefile"
     write (u, "(A)")
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
 
     write (u, "(A)")  "* Clean any left-over files"
     write (u, "(A)")
     call lib%clean (os_data, distclean = .false.)
 
     write (u, "(A)")  "* Write driver"
     write (u, "(A)")
     call lib%write_driver (force = .true.)
 
     write (u, "(A)")  "* Write process source code, compile, link, load"
     write (u, "(A)")
     call lib%load (os_data)
 
     call lib%write (u, libpath = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Constants of template_me1_a_i1:"
     write (u, "(A)")
 
     call lib%connect_process (var_str ("template_me1_a"), 1, data, driver)
 
     write (u, "(1x,A,A)")  "component ID     = ", char (data%id)
     write (u, "(1x,A,A)")  "model name       = ", char (data%model_name)
     write (u, "(1x,A,A,A)")  "md5sum           = '", data%md5sum, "'"
     write (u, "(1x,A,I0)") "n_in  = ", data%n_in
     write (u, "(1x,A,I0)") "n_out = ", data%n_out
     write (u, "(1x,A,I0)") "n_flv = ", data%n_flv
     write (u, "(1x,A,I0)") "n_hel = ", data%n_hel
     write (u, "(1x,A,I0)") "n_col = ", data%n_col
     write (u, "(1x,A,I0)") "n_cin = ", data%n_cin
     write (u, "(1x,A,I0)") "n_cf  = ", data%n_cf
     write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state
     write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1)
     do i = 2, 16
        write (u, "(12x,4(1x,I2))")  data%hel_state(:,i)
     end do
     write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state
     write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag
     write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors
     write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters for template_me1_a and initialize:"
     write (u, "(A)")
 
     par = [0.3_cdf, 0.0_cdf, 0.0_cdf, 0.0_cdf]
     write (u, "(2x,A,F6.4)")  "ee   = ", par(1)
     write (u, "(2x,A,F6.4)")  "me   = ", par(2)
     write (u, "(2x,A,F6.4)")  "mmu  = ", par(3)
     write (u, "(2x,A,F6.4)")  "mtau = ", par(4)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_cdf, 0.0_cdf, 0.0_cdf, 1.0_cdf, &
          1.0_cdf, 0.0_cdf, 0.0_cdf,-1.0_cdf, &
          1.0_cdf, 1.0_cdf, 0.0_cdf, 0.0_cdf, &
          1.0_cdf,-1.0_cdf, 0.0_cdf, 0.0_cdf &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.4))")  "p", i, " =", p(:,i)
     end do
 
     select type (driver)
     type is (template_me_driver_t)
        call driver%init (par, 0)
 
        call driver%new_event (p)
 
        write (u, "(A)")
        write (u, "(A)")  "* Compute matrix element:"
        write (u, "(A)")
 
        call driver%is_allowed (1_ci, 6_ci, 1_ci, flag)
        write (u, "(1x,A,L1)") "is_allowed (1, 6, 1) = ", flag
 
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
     end select
 
     call lib%final ()
     call cleanup_model (model)
     deallocate (model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_template_me_1"
 
   end subroutine prc_template_me_1
 
 @ %def prc_template_me_1
 @
 <<Template matrix elements: execute tests>>=
   call test (prc_template_me_2, "prc_template_me_2", &
        "build and load simple template_unity process", &
        u, results)
 <<Template matrix elements: test declarations>>=
   public :: prc_template_me_2
 <<Template matrix elements: tests>>=
   subroutine prc_template_me_2 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     type(string_t) :: model_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(process_constants_t) :: data
     class(prc_core_driver_t), allocatable :: driver
     integer, parameter :: cdf = c_default_float
     integer, parameter :: ci = c_int
     real(cdf), dimension(4) :: par
     real(cdf), dimension(0:3,4) :: p
     logical(c_bool) :: flag
     complex(c_default_complex) :: amp
     integer :: i
 
     write (u, "(A)")  "* Test output: prc_template_me_1"
     write (u, "(A)")  "*   Purpose: create a template matrix element,"
     write (u, "(A)")  "*            being identical to unity,"
     write (u, "(A)")  "*            build a library, link, load, and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("template_me2"))
     call os_data%init ()
 
     model_name = "QED"
     model => null ()
     call prepare_model (model, model_name)
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e+"), var_str ("e-")]
     prt_out = [var_str ("m+"), var_str ("m-")]
 
     allocate (template_me_def_t :: def)
     select type (def)
     type is (template_me_def_t)
        call def%init (model, prt_in, prt_out, unity = .true.)
     end select
     allocate (entry)
     call entry%init (var_str ("template_me2_a"), model_name = model_name, &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("template_unity"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Write makefile"
     write (u, "(A)")
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
 
     write (u, "(A)")  "* Clean any left-over files"
     write (u, "(A)")
     call lib%clean (os_data, distclean = .false.)
 
     write (u, "(A)")  "* Write driver"
     write (u, "(A)")
     call lib%write_driver (force = .true.)
 
     write (u, "(A)")  "* Write process source code, compile, link, load"
     write (u, "(A)")
     call lib%load (os_data)
 
     call lib%write (u, libpath = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Constants of template_me2_a_i1:"
     write (u, "(A)")
 
     call lib%connect_process (var_str ("template_me2_a"), 1, data, driver)
 
     write (u, "(1x,A,A)")  "component ID     = ", char (data%id)
     write (u, "(1x,A,A)")  "model name       = ", char (data%model_name)
     write (u, "(1x,A,A,A)")  "md5sum           = '", data%md5sum, "'"
     write (u, "(1x,A,I0)") "n_in  = ", data%n_in
     write (u, "(1x,A,I0)") "n_out = ", data%n_out
     write (u, "(1x,A,I0)") "n_flv = ", data%n_flv
     write (u, "(1x,A,I0)") "n_hel = ", data%n_hel
     write (u, "(1x,A,I0)") "n_col = ", data%n_col
     write (u, "(1x,A,I0)") "n_cin = ", data%n_cin
     write (u, "(1x,A,I0)") "n_cf  = ", data%n_cf
     write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state
     write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1)
     do i = 2, 16
        write (u, "(12x,4(1x,I2))")  data%hel_state(:,i)
     end do
     write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state
     write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag
     write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors
     write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters for template_me2_a and initialize:"
     write (u, "(A)")
 
     par = [0.3_cdf, 0.0_cdf, 0.0_cdf, 0.0_cdf]
     write (u, "(2x,A,F6.4)")  "ee   = ", par(1)
     write (u, "(2x,A,F6.4)")  "me   = ", par(2)
     write (u, "(2x,A,F6.4)")  "mmu  = ", par(3)
     write (u, "(2x,A,F6.4)")  "mtau = ", par(4)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_cdf, 0.0_cdf, 0.0_cdf, 1.0_cdf, &
          1.0_cdf, 0.0_cdf, 0.0_cdf,-1.0_cdf, &
          1.0_cdf, 1.0_cdf, 0.0_cdf, 0.0_cdf, &
          1.0_cdf,-1.0_cdf, 0.0_cdf, 0.0_cdf &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.4))")  "p", i, " =", p(:,i)
     end do
 
     select type (driver)
     type is (template_me_driver_t)
        call driver%init (par, 0)
 
        call driver%new_event (p)
 
        write (u, "(A)")
        write (u, "(A)")  "* Compute matrix element:"
        write (u, "(A)")
 
        call driver%is_allowed (1_ci, 6_ci, 1_ci, flag)
        write (u, "(1x,A,L1)") "is_allowed (1, 6, 1) = ", flag
 
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
     end select
 
     call lib%final ()
     call cleanup_model (model)
     deallocate (model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_template_me_2"
 
   end subroutine prc_template_me_2
 
 @ %def prc_template_me_2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{\oMega\ Interface}
 
 The standard method for process computation with \whizard\ is the
 \oMega\ matrix element generator.
 
 This section implements the interface to the code generator (via
 the makefile) and the driver for the features provided by the \oMega\
 matrix element.
 
 There are actually two different methods steered by this interface, the
 traditional one which delivers compiled Fortran code, while the \oMega\
 virtual machine (OVM) produces bytecode with look-up tables.
 <<[[prc_omega.f90]]>>=
 <<File header>>
 
 module prc_omega
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
 <<Use strings>>
   use io_units
   use system_defs, only: TAB
   use constants, only: one
   use diagnostics
   use os_interface
   use lorentz
   use sm_qcd
   use sm_qed
   use interactions
   use model_data
 
   use particle_specifiers, only: new_prt_spec
   use process_constants
   use prclib_interfaces
   use prc_core_def
   use process_libraries
   use prc_core
 
 <<Standard module head>>
 
 <<Omega interface: public>>
 
 <<Omega interface: types>>
 
 <<Omega interface: interfaces>>
 
 contains
 
 <<Omega interface: procedures>>
 
 end module prc_omega
 @ %def prc_omega
 @
 \subsection{Process definition}
 For the process definition we implement an extension of the
 [[prc_core_def_t]] abstract type.
 <<Omega interface: public>>=
   public :: omega_def_t
 <<Omega interface: types>>=
   type, extends (prc_core_def_t) :: omega_def_t
      logical :: ufo = .false.
      logical :: ovm = .false.
    contains
    <<Omega interface: omega def: TBP>>
   end type omega_def_t
 
 @ %def omega_def_t
 @
 <<Omega interface: omega def: TBP>>=
   procedure, nopass :: type_string => omega_def_type_string
 <<Omega interface: procedures>>=
   function omega_def_type_string () result (string)
     type(string_t) :: string
     string = "omega"
   end function omega_def_type_string
 
 @ %def omega_omega_def_type_string
 @
 Initialization: allocate the writer for the \oMega\ matrix element.
 The writer type depends on the settings of the [[ufo]] and [[ovm]] flags.
 Also set any data for this process that the writer needs.
 <<Omega interface: omega def: TBP>>=
   procedure :: init => omega_def_init
 <<Omega interface: procedures>>=
   subroutine omega_def_init (object, &
        model_name, prt_in, prt_out, &
        ovm, ufo, ufo_path, &
        restrictions, cms_scheme, &
        openmp_support, report_progress, write_phs_output, extra_options, diags, diags_color)
     class(omega_def_t), intent(out) :: object
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     logical, intent(in) :: ovm
     logical, intent(in) :: ufo
     type(string_t), intent(in), optional :: ufo_path
     type(string_t), intent(in), optional :: restrictions
     logical, intent(in), optional :: cms_scheme
     logical, intent(in), optional :: openmp_support
     logical, intent(in), optional :: report_progress
     logical, intent(in), optional :: write_phs_output
     type(string_t), intent(in), optional :: extra_options
     logical, intent(in), optional :: diags, diags_color
     object%ufo = ufo
     object%ovm = ovm
     if (object%ufo) then
        if (object%ovm) then
           call msg_fatal ("Omega process: OVM method does not support UFO model")
        else
           allocate (omega_ufo_writer_t :: object%writer)
        end if
     else
        if (object%ovm) then
           allocate (omega_ovm_writer_t :: object%writer)
        else
           allocate (omega_omega_writer_t :: object%writer)
        end if
     end if
     select type (writer => object%writer)
     class is (omega_writer_t)
        call writer%init (model_name, prt_in, prt_out, &
             ufo_path, restrictions, cms_scheme, &
             openmp_support, report_progress, write_phs_output, extra_options, diags, diags_color)
     end select
   end subroutine omega_def_init
 
 @ %def omega_def_init
 @ Write/read process- and method-specific data.
 <<Omega interface: omega def: TBP>>=
   procedure :: write => omega_def_write
 <<Omega interface: procedures>>=
   subroutine omega_def_write (object, unit)
     class(omega_def_t), intent(in) :: object
     integer, intent(in) :: unit
     select type (writer => object%writer)
     class is (omega_writer_t)
        call writer%write (unit)
     end select
   end subroutine omega_def_write
 
 @ %def omega_def_write
 @
 <<Omega interface: omega def: TBP>>=
   procedure :: read => omega_def_read
 <<Omega interface: procedures>>=
   subroutine omega_def_read (object, unit)
     class(omega_def_t), intent(out) :: object
     integer, intent(in) :: unit
     call msg_bug ("O'Mega process definition: input not supported yet")
   end subroutine omega_def_read
 
 @ %def omega_def_read
 @ Allocate the driver for \oMega matrix elements.
 <<Omega interface: omega def: TBP>>=
   procedure :: allocate_driver => omega_def_allocate_driver
 <<Omega interface: procedures>>=
   subroutine omega_def_allocate_driver (object, driver, basename)
     class(omega_def_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     allocate (omega_driver_t :: driver)
   end subroutine omega_def_allocate_driver
 
 @ %def omega_def_allocate_driver
 @ We need code:
 <<Omega interface: omega def: TBP>>=
   procedure, nopass :: needs_code => omega_def_needs_code
 <<Omega interface: procedures>>=
   function omega_def_needs_code () result (flag)
     logical :: flag
     flag = .true.
   end function omega_def_needs_code
 
 @ %def omega_def_needs_code
 @ These are the features that an \oMega\ matrix element provides.
 <<Omega interface: omega def: TBP>>=
   procedure, nopass :: get_features => omega_def_get_features
 <<Omega interface: procedures>>=
   subroutine omega_def_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (6))
     features = [ &
          var_str ("init"), &
          var_str ("update_alpha_s"), &
          var_str ("reset_helicity_selection"), &
          var_str ("is_allowed"), &
          var_str ("new_event"), &
          var_str ("get_amplitude")]
   end subroutine omega_def_get_features
 
 @ %def omega_def_get_features
 @ The interface of the specific features.
 <<Omega interface: interfaces>>=
   abstract interface
      subroutine init_t (par, scheme) bind(C)
        import
        real(c_default_float), dimension(*), intent(in) :: par
        integer(c_int), intent(in) :: scheme
      end subroutine init_t
   end interface
 
   abstract interface
      subroutine update_alpha_s_t (alpha_s) bind(C)
        import
        real(c_default_float), intent(in) :: alpha_s
      end subroutine update_alpha_s_t
   end interface
 
   abstract interface
      subroutine reset_helicity_selection_t (threshold, cutoff) bind(C)
        import
        real(c_default_float), intent(in) :: threshold
        integer(c_int), intent(in) :: cutoff
      end subroutine reset_helicity_selection_t
   end interface
 
   abstract interface
      subroutine is_allowed_t (flv, hel, col, flag) bind(C)
        import
        integer(c_int), intent(in) :: flv, hel, col
        logical(c_bool), intent(out) :: flag
      end subroutine is_allowed_t
   end interface
 
   abstract interface
      subroutine new_event_t (p) bind(C)
        import
        real(c_default_float), dimension(0:3,*), intent(in) :: p
      end subroutine new_event_t
   end interface
 
   abstract interface
      subroutine get_amplitude_t (flv, hel, col, amp) bind(C)
        import
        integer(c_int), intent(in) :: flv, hel, col
        complex(c_default_complex), intent(out):: amp
      end subroutine get_amplitude_t
   end interface
 
 @ %def init_t update_alpha_s_t reset_helicity_selection_t
 @ %def is_allowed_t new_event_t get_amplitude_t
 @ Connect the \oMega\ features with the process driver.
 <<Omega interface: omega def: TBP>>=
   procedure :: connect => omega_def_connect
 <<Omega interface: procedures>>=
   subroutine omega_def_connect (def, lib_driver, i, proc_driver)
     class(omega_def_t), intent(in) :: def
     class(prclib_driver_t), intent(in) :: lib_driver
     integer, intent(in) :: i
     class(prc_core_driver_t), intent(inout) :: proc_driver
     integer(c_int) :: pid, fid
     type(c_funptr) :: fptr
     select type (proc_driver)
     type is  (omega_driver_t)
        pid = i
        fid = 1
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%init)
        fid = 2
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%update_alpha_s)
        fid = 3
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%reset_helicity_selection)
        fid = 4
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%is_allowed)
        fid = 5
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%new_event)
        fid = 6
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%get_amplitude)
     end select
   end subroutine omega_def_connect
 
 @ %def omega_def_connect
 @
 \subsection{The \oMega\ writer}
 The \oMega\ writer is responsible for inserting the appropriate lines
 in the makefile that call \oMega, and for writing interfaces and
 wrappers.
 <<Omega interface: types>>=
   type, extends (prc_writer_f_module_t), abstract :: omega_writer_t
      type(string_t) :: model_name
      type(string_t) :: process_mode
      type(string_t) :: process_string
      type(string_t) :: restrictions
      logical :: openmp_support = .false.
      logical :: report_progress = .false.
      logical :: diags = .false.
      logical :: diags_color = .false.
      logical :: complex_mass_scheme = .false.
      logical :: write_phs_output = .false.
      type(string_t) :: extra_options
    contains
    <<Omega interface: omega writer: TBP>>
   end type omega_writer_t
 
 @ %def omega_writer_t
 @
 <<Omega interface: types>>=
   type, extends (omega_writer_t) :: omega_omega_writer_t
    contains
    <<Omega interface: omega omega writer: TBP>>
   end type omega_omega_writer_t
 
 @ %def omega_omega_writer_t
 @
 <<Omega interface: types>>=
   type, extends (omega_omega_writer_t) :: omega_ufo_writer_t
      type(string_t) :: ufo_path
    contains
    <<Omega interface: omega ufo writer: TBP>>
   end type omega_ufo_writer_t
 
 @ %def omega_ufo_writer_t
 @
 <<Omega interface: types>>=
   type, extends (omega_writer_t) :: omega_ovm_writer_t
    contains
    <<Omega interface: omega ovm writer: TBP>>
   end type omega_ovm_writer_t
 
 @ %def omega_ovm_writer_t
 @
 <<Omega interface: omega omega writer: TBP>>=
   procedure, nopass :: type_name => omega_omega_writer_type_name
 <<Omega interface: procedures>>=
   function omega_omega_writer_type_name () result (string)
     type(string_t) :: string
     string = "omega"
   end function omega_omega_writer_type_name
 
 @ %def omega_omega_writer_type_name
 @
 <<Omega interface: omega ufo writer: TBP>>=
   procedure, nopass :: type_name => omega_ufo_writer_type_name
 <<Omega interface: procedures>>=
   function omega_ufo_writer_type_name () result (string)
     type(string_t) :: string
     string = "omega/UFO"
   end function omega_ufo_writer_type_name
 
 @ %def omega_ufo_writer_type_name
 @
 <<Omega interface: omega ovm writer: TBP>>=
   procedure, nopass :: type_name => omega_ovm_writer_type_name
 <<Omega interface: procedures>>=
   function omega_ovm_writer_type_name () result (string)
     type(string_t) :: string
     string = "ovm"
   end function omega_ovm_writer_type_name
 
 @ %def omega_ovm_writer_type_name
 @
 @ Taking into account the prefix for \oMega\ module names.
 <<Omega interface: omega writer: TBP>>=
   procedure, nopass :: get_module_name => omega_writer_get_module_name
 <<Omega interface: procedures>>=
   function omega_writer_get_module_name (id) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: id
     name = "opr_" // id
   end function omega_writer_get_module_name
 
 @ %def omega_writer_get_module_name
 @ Output.  This is called by [[omega_def_write]].
 <<Omega interface: omega writer: TBP>>=
   procedure :: write => omega_writer_write
 <<Omega interface: procedures>>=
   subroutine omega_writer_write (object, unit)
     class(omega_writer_t), intent(in) :: object
     integer, intent(in) :: unit
     write (unit, "(5x,A,A)")  "Model name        = ", &
          '"' // char (object%model_name) // '"'
     write (unit, "(5x,A,A)")  "Mode string       = ", &
          '"' // char (object%process_mode) // '"'
     write (unit, "(5x,A,A)")  "Process string    = ", &
          '"' // char (object%process_string) // '"'
     write (unit, "(5x,A,A)")  "Restrictions      = ", &
          '"' // char (object%restrictions) // '"'
     write (unit, "(5x,A,L1)")  "OpenMP support    = ", object%openmp_support
     write (unit, "(5x,A,L1)")  "Report progress   = ", object%report_progress
     ! write (unit, "(5x,A,L1)")  "Write phs output  = ", object%write_phs_output
     write (unit, "(5x,A,A)")  "Extra options     = ", &
          '"' // char (object%extra_options) // '"'
     write (unit, "(5x,A,L1)")  "Write diagrams    = ", object%diags
     write (unit, "(5x,A,L1)")  "Write color diag. = ", object%diags_color
     write (unit, "(5x,A,L1)")  "Complex Mass S.   = ", &
          object%complex_mass_scheme
   end subroutine omega_writer_write
 
 @ %def omega_writer_write
 @ Initialize with process data.
 <<Omega interface: omega writer: TBP>>=
   procedure :: init => omega_writer_init
 <<Omega interface: procedures>>=
   subroutine omega_writer_init (writer, model_name, prt_in, prt_out, &
        ufo_path, restrictions, cms_scheme, openmp_support, &
        report_progress, write_phs_output, extra_options, diags, diags_color)
     class(omega_writer_t), intent(out) :: writer
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     type(string_t), intent(in), optional :: ufo_path
     type(string_t), intent(in), optional :: restrictions
     logical, intent(in), optional :: cms_scheme
     logical, intent(in), optional :: openmp_support
     logical, intent(in), optional :: report_progress
     logical, intent(in), optional :: write_phs_output
     type(string_t), intent(in), optional :: extra_options
     logical, intent(in), optional :: diags, diags_color
     integer :: i
     writer%model_name = model_name
     select type (writer)
     type is (omega_ufo_writer_t)
        if (present (ufo_path)) then
           writer%ufo_path = ufo_path
        else
           call msg_fatal ("O'Mega: UFO model option is selected, but UFO model path is unset")
        end if
     end select
     if (present (restrictions)) then
        writer%restrictions = restrictions
     else
        writer%restrictions = ""
     end if
     if (present (cms_scheme))  writer%complex_mass_scheme = cms_scheme
     if (present (openmp_support))  writer%openmp_support = openmp_support
     if (present (report_progress))  writer%report_progress = report_progress
     if (present (write_phs_output)) writer%write_phs_output = write_phs_output
     if (present (extra_options)) then
        writer%extra_options = " " // extra_options
     else
        writer%extra_options = ""
     end if
     if (present (diags))  writer%diags = diags
     if (present (diags_color))  writer%diags_color = diags_color
     select case (size (prt_in))
     case (1);  writer%process_mode = " -decay"
     case (2);  writer%process_mode = " -scatter"
     end select
     associate (s => writer%process_string)
       s = " '"
       do i = 1, size (prt_in)
          if (i > 1)  s = s // " "
          s = s // prt_in(i)
       end do
       s = s // " ->"
       do i = 1, size (prt_out)
          s = s // " " // prt_out(i)
       end do
       s = s // "'"
     end associate
   end subroutine omega_writer_init
 
 @ %def omega_writer_init
 @ The makefile implements the actual \oMega\ call. For old \LaTeX\
 distributions, we filter out the hyperref options for \oMega\
 diagrams, at least in the testsuite.
 <<Omega interface: omega writer: TBP>>=
   procedure :: write_makefile_code => omega_write_makefile_code
 <<Omega interface: procedures>>=
   subroutine omega_write_makefile_code &
        (writer, unit, id, os_data, verbose, testflag)
     class(omega_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     logical, intent(in), optional :: testflag
     type(string_t) :: omega_binary, omega_path
     type(string_t) :: restrictions_string
     type(string_t) :: openmp_string
     type(string_t) :: kmatrix_string
     type(string_t) :: progress_string
     type(string_t) :: diagrams_string
     type(string_t) :: cms_string
     type(string_t) :: write_phs_output_string
     type(string_t) :: parameter_module
     logical :: escape_hyperref
     escape_hyperref = .false.
     if (present (testflag))  escape_hyperref = testflag
     select type (writer)
     type is (omega_omega_writer_t)
        omega_binary = "omega_" // writer%model_name // ".opt"
     type is (omega_ufo_writer_t)
        omega_binary = "omega_UFO.opt"
     type is (omega_ovm_writer_t)
        select case (char (writer%model_name))
        case ("SM", "SM_CKM", "SM_Higgs", "THDM", "THDM_CKM", &
              "HSExt", "QED", "QCD", "Zprime")
        case default
           call msg_fatal ("The model " // char (writer%model_name) &
                // " is not available for the O'Mega VM.")
        end select
        omega_binary = "omega_" // writer%model_name // "_VM.opt"
     end select
     omega_path = os_data%whizard_omega_binpath // "/" // omega_binary
     if (.not. verbose)  omega_path = "@" // omega_path
     if (writer%restrictions /= "") then
        restrictions_string = " -cascade '" // writer%restrictions // "'"
     else
        restrictions_string = ""
     end if
     if (writer%openmp_support) then
        openmp_string = " -target:openmp"
     else
        openmp_string = ""
     end if
     if (writer%report_progress) then
        progress_string = " -fusion:progress"
     else
        progress_string = ""
     end if
     if (writer%diags) then
        if (writer%diags_color) then
           diagrams_string = " -diagrams:C " // char(id) // &
                "_diags -diagrams_LaTeX"
        else
           diagrams_string = " -diagrams " // char(id) // &
                "_diags -diagrams_LaTeX"
        end if
     else
        if (writer%diags_color) then
           diagrams_string = " -diagrams:c " // char(id) // &
                "_diags -diagrams_LaTeX"
        else
           diagrams_string = ""
        end if
     end if
     if (writer%complex_mass_scheme) then
        cms_string = " -model:cms_width"
     else
        cms_string = ""
     end if
     if (writer%write_phs_output) then
        write_phs_output_string = " -phase_space " // char (id) // ".fds"
     else
        write_phs_output_string = ""
     endif
     select case (char (writer%model_name))
     case ("SM_rx", "SSC", "NoH_rx", "AltH")
        kmatrix_string = " -target:kmatrix_2_write"
     case ("SSC_2", "SSC_AltT", "SM_ul")
        kmatrix_string = " -target:kmatrix_write"
     case default
        kmatrix_string = ""
     end select
     write (unit, "(5A)")  "SOURCES += ", char (id), ".f90"
     select type (writer)
     type is (omega_ovm_writer_t)
        write (unit, "(5A)")  "SOURCES += ", char (id), ".hbc"
     end select
     if (writer%diags .or. writer%diags_color) then
        write (unit, "(5A)")  "TEX_SOURCES += ", char (id), "_diags.tex"
        if (os_data%event_analysis_pdf) then
           write (unit, "(5A)")  "TEX_OBJECTS += ", char (id), "_diags.pdf"
        else
           write (unit, "(5A)")  "TEX_OBJECTS += ", char (id), "_diags.ps"
        end if
     end if
     write (unit, "(5A)")  "OBJECTS += ", char (id), ".lo"
     select type (writer)
     type is (omega_omega_writer_t)
        write (unit, "(5A)")  char (id), ".f90:"
        if (.not. verbose) then
           write (unit, "(5A)")  TAB // '@echo  "  OMEGA     ', trim (char (id)), '.f90"'
        end if
        write (unit, "(99A)")  TAB, char (omega_path), &
             " -o ", char (id), ".f90", &
             " -target:whizard", &
             " -target:parameter_module parameters_", char (writer%model_name), &
             " -target:module opr_", char (id), &
             " -target:md5sum '", writer%md5sum, "'", &
             char (cms_string), &
             char (openmp_string), &
             char (progress_string), &
             char (kmatrix_string), &
             char (writer%process_mode), char (writer%process_string), &
             char (restrictions_string), char (diagrams_string), &
             char (writer%extra_options), char (write_phs_output_string)
     type is (omega_ufo_writer_t)
        parameter_module = char (id) // "_par_" // replace (char (writer%model_name), &
             "-", "_", every=.true.)
        write (unit, "(5A)")  char (id), ".f90: ", char (parameter_module), ".lo"
        if (.not. verbose) then
           write (unit, "(5A)")  TAB // '@echo  "  OMEGA[UFO]', trim (char (id)), '.f90"'
        end if
        write (unit, "(99A)")  TAB, char (omega_path), &
             " -o ", char (id), ".f90", &
             " -model:UFO_dir ", &
             char (writer%ufo_path), "/", char (writer%model_name), &
             " -model:exec", &
             " -target:whizard", &
             " -target:parameter_module ", char (parameter_module), &
             " -target:module opr_", char (id), &
             " -target:md5sum '", writer%md5sum, "'", &
             char (cms_string), &
             char (openmp_string), &
             char (progress_string), &
             char (kmatrix_string), &
             char (writer%process_mode), char (writer%process_string), &
             char (restrictions_string), char (diagrams_string), &
             char (writer%extra_options), char (write_phs_output_string)
        write (unit, "(5A)") "SOURCES += ", char (parameter_module), ".f90"
        write (unit, "(5A)") "OBJECTS += ", char (parameter_module), ".lo"
        write (unit, "(5A)")  char (parameter_module), ".f90:"
        write (unit, "(99A)")  TAB, char (omega_path), &
             " -model:UFO_dir ", &
             char (writer%ufo_path), "/", char (writer%model_name), &
             " -model:exec", &
             " -target:parameter_module ", char (parameter_module), &
             " -params", &
             " -o $@"
        write (unit, "(5A)")  char (parameter_module), ".lo: ", char (parameter_module), ".f90"
        if (.not. verbose) then
           write (unit, "(5A)")  TAB // '@echo  "  FC       " $@'
        end if
        write (unit, "(5A)")  TAB, "$(LTFCOMPILE) $<"
     type is (omega_ovm_writer_t)
        write (unit, "(5A)")  char (id), ".hbc:"
        write (unit, "(99A)")  TAB, char (omega_path), &
             " -o ", char (id), ".hbc", &
             char (progress_string), &
             char (cms_string), &
             char (writer%process_mode), char (writer%process_string), &
             char (restrictions_string), char (diagrams_string), &
             char (writer%extra_options), char (write_phs_output_string)
        write (unit, "(5A)")  char (id), ".f90:"
        if (.not. verbose) then
           write (unit, "(5A)")  TAB // '@echo  "  OVM       ', trim (char (id)), '.f90"'
        end if
        write (unit, "(99A)")  TAB, char (omega_path), &
             " -o ", char (id), ".f90 -params", &
             " -target:whizard ", &
             " -target:bytecode_file ", char (id), ".hbc", &
             " -target:wrapper_module opr_", char (id), &
             " -target:parameter_module_external parameters_", &
             char (writer%model_name), &
             " -target:md5sum '", writer%md5sum, "'", &
             char (openmp_string)
     end select
     if (writer%diags .or. writer%diags_color) &
        write (unit, "(5A)")  char (id), "_diags.tex: ", char (id), ".f90"
     write (unit, "(5A)")  "clean-", char (id), ":"
     if (verbose) then
        write (unit, "(5A)")  TAB, "rm -f ", char (id), ".f90"
        write (unit, "(5A)")  TAB, "rm -f opr_", char (id), ".mod"
        write (unit, "(5A)")  TAB, "rm -f ", char (id), ".lo"
     else
        write (unit, "(5A)")  TAB // '@echo  "  RM        ', &
             trim (char (id)), '.f90,.mod,.lo"'
        write (unit, "(5A)")  TAB, "@rm -f ", char (id), ".f90"
        write (unit, "(5A)")  TAB, "@rm -f opr_", char (id), ".mod"
        write (unit, "(5A)")  TAB, "@rm -f ", char (id), ".lo"
     end if
     write (unit, "(5A)")  "CLEAN_SOURCES += ", char (id), ".f90"
     select type (writer)
     type is (omega_ufo_writer_t)
        write (unit, "(5A)")  "CLEAN_SOURCES += ", char (writer%model_name), ".mdl"
        write (unit, "(5A)")  "CLEAN_SOURCES += ", char (parameter_module), ".f90"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (parameter_module), ".mod"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (parameter_module), ".lo"
     type is (omega_ovm_writer_t)
        write (unit, "(5A)")  "CLEAN_SOURCES += ", char (id), ".hbc"
     end select
     if (writer%diags .or. writer%diags_color) then
        write (unit, "(5A)")  "CLEAN_SOURCES += ", char (id), "_diags.tex"
     end if
     write (unit, "(5A)")  "CLEAN_OBJECTS += opr_", char (id), ".mod"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), ".lo"
     if (writer%diags .or. writer%diags_color) then
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.aux"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.log"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.dvi"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.toc"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.out"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.[1-9]"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.[1-9][0-9]"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.[1-9][0-9][0-9]"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.t[1-9]"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.t[1-9][0-9]"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.t[1-9][0-9][0-9]"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.mp"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags-fmf.log"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.dvi"
        write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.ps"
        if (os_data%event_analysis_pdf) &
             write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_diags.pdf"
     end if
     write (unit, "(5A)")  char (id), ".lo: ", char (id), ".f90"
     write (unit, "(5A)")  TAB, "$(LTFCOMPILE) $<"
     if (writer%diags .or. writer%diags_color) then
        if (os_data%event_analysis_ps) then
           if (os_data%event_analysis_pdf) then
              write (unit, "(5A)")  char (id), "_diags.pdf: ", char (id), "_diags.tex"
           else
              write (unit, "(5A)")  char (id), "_diags.ps: ", char (id), "_diags.tex"
           end if
           if (escape_hyperref) then
              if (verbose) then
                 write (unit, "(5A)")  TAB, "-cat ", char (id), "_diags.tex | \"
              else
                 write (unit, "(5A)")  TAB // '@echo  "  HYPERREF  ', &
                      trim (char (id)) // '_diags.tex"'
                 write (unit, "(5A)")  TAB, "@cat ", char (id), "_diags.tex | \"
              end if
              write (unit, "(5A)")  TAB, "   sed -e" // &
                   "'s/\\usepackage\[colorlinks\]{hyperref}.*/%\\usepackage" // &
                   "\[colorlinks\]{hyperref}/' > \"
              write (unit, "(5A)")  TAB, "   ", char (id), "_diags.tex.tmp"
              if (verbose) then
                 write (unit, "(5A)")  TAB, "mv -f ", char (id), "_diags.tex.tmp \"
              else
                 write (unit, "(5A)")  TAB, "@mv -f ", char (id), "_diags.tex.tmp \"
              end if
              write (unit, "(5A)")  TAB, "   ", char (id), "_diags.tex"
           end if
           if (verbose) then
              write (unit, "(5A)")  TAB, "-TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
                   char (id) // "_diags.tex"
              write (unit, "(5A)")  TAB, "MPINPUTS=$(MP_FLAGS) $(MPOST) " // &
                   char (id) // "_diags-fmf.mp"
              write (unit, "(5A)")  TAB, "TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
                   char (id) // "_diags.tex"
              write (unit, "(5A)")  TAB, "$(DVIPS) -o " // char (id) // "_diags.ps " // &
                   char (id) // "_diags.dvi"
           else
              write (unit, "(5A)")  TAB // '@echo  "  LATEX     ', &
                   trim (char (id)) // '_diags.tex"'
              write (unit, "(5A)")  TAB, "@TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
                   char (id) // "_diags.tex > /dev/null"
              write (unit, "(5A)")  TAB // '@echo  "  METAPOST  ', &
                   trim (char (id)) // '_diags-fmf.mp"'
              write (unit, "(5A)")  TAB, "@MPINPUTS=$(MP_FLAGS) $(MPOST) " // &
                   char (id) // "_diags-fmf.mp  > /dev/null"
              write (unit, "(5A)")  TAB // '@echo  "  LATEX     ', &
                   trim (char (id)) // '_diags.tex"'
              write (unit, "(5A)")  TAB, "@TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
                   char (id) // "_diags.tex > /dev/null"
              write (unit, "(5A)")  TAB // '@echo  "  DVIPS     ', &
                   trim (char (id)) // '_diags.dvi"'
              write (unit, "(5A)")  TAB, "@$(DVIPS) -q -o " // char (id) &
                   // "_diags.ps " // char (id) // "_diags.dvi"
           end if
           if (os_data%event_analysis_pdf) then
              if (verbose) then
                 write (unit, "(5A)")  TAB, "$(PS2PDF) " // char (id) // "_diags.ps"
              else
                 write (unit, "(5A)")  TAB // '@echo  "  PS2PDF    ', &
                      trim (char (id)) // '_diags.ps"'
                 write (unit, "(5A)")  TAB, "@$(PS2PDF) " // char (id) // "_diags.ps"
              end if
           end if
        end if
     end if
   end subroutine omega_write_makefile_code
 
 @ %def omega_write_makefile_code
 @ The source is written by the makefile, so nothing to do here.
 <<Omega interface: omega writer: TBP>>=
   procedure :: write_source_code => omega_write_source_code
 <<Omega interface: procedures>>=
   subroutine omega_write_source_code (writer, id)
     class(omega_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine omega_write_source_code
 
 @ %def omega_write_source_code
 @ Nothing to be done here.
 <<Omega interface: omega writer: TBP>>=
   procedure :: before_compile => omega_before_compile
   procedure :: after_compile => omega_after_compile
 <<Omega interface: procedures>>=
   subroutine omega_before_compile (writer, id)
     class(omega_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine omega_before_compile
 
   subroutine omega_after_compile (writer, id)
     class(omega_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
   end subroutine omega_after_compile
 
 @ %def omega_before_compile
 @ %def omega_after_compile
 @ Return the name of a procedure that implements a given feature, as
 it is provided by the external matrix-element code.  \oMega\ names
 some procedures differently, therefore we translate here and override
 the binding of the base type.
 <<Omega interface: omega writer: TBP>>=
   procedure, nopass :: get_procname => omega_writer_get_procname
 <<Omega interface: procedures>>=
   function omega_writer_get_procname (feature) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: feature
     select case (char (feature))
     case ("n_in");   name = "number_particles_in"
     case ("n_out");  name = "number_particles_out"
     case ("n_flv");  name = "number_flavor_states"
     case ("n_hel");  name = "number_spin_states"
     case ("n_col");  name = "number_color_flows"
     case ("n_cin");  name = "number_color_indices"
     case ("n_cf");   name = "number_color_factors"
     case ("flv_state");  name = "flavor_states"
     case ("hel_state");  name = "spin_states"
     case ("col_state");  name = "color_flows"
     case default
        name = feature
     end select
   end function omega_writer_get_procname
 
 @ %def omega_writer_get_procname
 @ The interfaces for the \oMega-specific features.
 <<Omega interface: omega writer: TBP>>=
   procedure :: write_interface => omega_write_interface
 <<Omega interface: procedures>>=
   subroutine omega_write_interface (writer, unit, id, feature)
     class(omega_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(string_t), intent(in) :: feature
     type(string_t) :: name
     name = writer%get_c_procname (id, feature)
     write (unit, "(2x,9A)")  "interface"
     select case (char (feature))
     case ("init")
        write (unit, "(5x,9A)")  "subroutine ", char (name), &
             " (par, scheme) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), dimension(*), &
             &intent(in) :: par"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: scheme"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("update_alpha_s")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " (alpha_s) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), intent(in) :: alpha_s"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("reset_helicity_selection")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(threshold, cutoff) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), intent(in) :: threshold"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: cutoff"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("is_allowed")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(flv, hel, col, flag) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(7x,9A)")  "logical(c_bool), intent(out) :: flag"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("new_event")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " (p) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), dimension(0:3,*), &
             &intent(in) :: p"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("get_amplitude")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(flv, hel, col, amp) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(7x,9A)")  "complex(c_default_complex), intent(out) &
             &:: amp"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     end select
     write (unit, "(2x,9A)")  "end interface"
   end subroutine omega_write_interface
 
 @ %def omega_write_interface
 @ The wrappers have to take into account conversion between C and
 Fortran data types.
 
 NOTE: The case [[c_default_float]] $\neq$ [[default]] is not yet covered.
 <<Omega interface: omega writer: TBP>>=
   procedure :: write_wrapper => omega_write_wrapper
 <<Omega interface: procedures>>=
   subroutine omega_write_wrapper (writer, unit, id, feature)
     class(omega_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     type(string_t) :: name
     name = writer%get_c_procname (id, feature)
     write (unit, *)
     select case (char (feature))
     case ("init")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (par, scheme) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        write (unit, "(2x,9A)")  "real(c_default_float), dimension(*), &
             &intent(in) :: par"
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: scheme"
        if (c_default_float == default .and. c_int == kind(1)) then
           write (unit, "(2x,9A)")  "call ", char (feature), " (par, scheme)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("update_alpha_s")
        write (unit, "(9A)")  "subroutine ", char (name), " (alpha_s) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), intent(in) &
                &:: alpha_s"
           write (unit, "(2x,9A)")  "call ", char (feature), " (alpha_s)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("reset_helicity_selection")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (threshold, cutoff) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), intent(in) &
                &:: threshold"
           write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: cutoff"
           write (unit, "(2x,9A)")  "call ", char (feature), &
                " (threshold, int (cutoff))"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("is_allowed")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (flv, hel, col, flag) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(2x,9A)")  "logical(c_bool), intent(out) :: flag"
        write (unit, "(2x,9A)")  "flag = ", char (feature), &
             " (int (flv), int (hel), int (col))"
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("new_event")
        write (unit, "(9A)")  "subroutine ", char (name), " (p) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), dimension(0:3,*), &
                &intent(in) :: p"
           write (unit, "(2x,9A)")  "call ", char (feature), " (p)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("get_amplitude")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (flv, hel, col, amp) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(2x,9A)")  "complex(c_default_complex), intent(out) &
             &:: amp"
        write (unit, "(2x,9A)")  "amp = ", char (feature), &
             " (int (flv), int (hel), int (col))"
        write (unit, "(9A)")  "end subroutine ", char (name)
     end select
   end subroutine omega_write_wrapper
 
 @ %def omega_write_wrapper
 @
 \subsection{Driver}
 <<Omega interface: public>>=
   public :: omega_driver_t
 <<Omega interface: types>>=
   type, extends (prc_core_driver_t) :: omega_driver_t
      procedure(init_t), nopass, pointer :: &
           init => null ()
      procedure(update_alpha_s_t), nopass, pointer :: &
           update_alpha_s => null ()
      procedure(reset_helicity_selection_t), nopass, pointer :: &
           reset_helicity_selection => null ()
      procedure(is_allowed_t), nopass, pointer :: &
           is_allowed => null ()
      procedure(new_event_t), nopass, pointer :: &
           new_event => null ()
      procedure(get_amplitude_t), nopass, pointer :: &
           get_amplitude => null ()
    contains
    <<Omega interface: omega driver: TBP>>
   end type omega_driver_t
 
 @ %def omega_driver_t
 @ The reported type is the same as for the [[omega_def_t]] type.
 <<Omega interface: omega driver: TBP>>=
   procedure, nopass :: type_name => omega_driver_type_name
 <<Omega interface: procedures>>=
   function omega_driver_type_name () result (string)
     type(string_t) :: string
     string = "omega"
   end function omega_driver_type_name
 
 @ %def omega_driver_type_name
 @
 \subsection{High-level process definition}
 This procedure wraps the details filling a process-component
 definition entry as appropriate for an
 \oMega\ matrix element.
 <<Omega interface: public>>=
   public :: omega_make_process_component
 <<Omega interface: procedures>>=
   subroutine omega_make_process_component (entry, component_index, &
          model_name, prt_in, prt_out, &
          ufo, ufo_path, restrictions, cms_scheme, &
          openmp_support, report_progress, write_omega_output, extra_options, diags, diags_color)
     class(process_def_entry_t), intent(inout) :: entry
     integer, intent(in) :: component_index
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: prt_in
     type(string_t), dimension(:), intent(in) :: prt_out
     logical, intent(in), optional :: ufo
     type(string_t), intent(in), optional :: ufo_path
     type(string_t), intent(in), optional :: restrictions
     logical, intent(in), optional :: cms_scheme
     logical, intent(in), optional :: openmp_support
     logical, intent(in), optional :: report_progress
     logical, intent(in), optional :: write_omega_output
     type(string_t), intent(in), optional :: extra_options
     logical, intent(in), optional :: diags, diags_color
     logical :: ufo_model
     class(prc_core_def_t), allocatable :: def
     ufo_model = .false.;  if (present (ufo))  ufo_model = ufo
     allocate (omega_def_t :: def)
     select type (def)
     class is (omega_def_t)
        call def%init (model_name, prt_in, prt_out, &
             .false., ufo_model, ufo_path, &
             restrictions, cms_scheme, &
             openmp_support, report_progress, write_omega_output, extra_options, diags, diags_color)
     end select
     call entry%import_component (component_index, &
          n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method = var_str ("omega"), &
          variant = def)
   end subroutine omega_make_process_component
 
 @ %def omega_make_process_component
 @
 \subsection{The [[prc_omega_t]] wrapper}
 This is an instance of the generic [[prc_core_t]] object.  It contains a
 pointer to the process definition ([[omega_def_t]]), a data component
 ([[process_constants_t]]), and the matrix-element driver
 ([[omega_driver_t]]).
 <<Omega interface: public>>=
   public :: prc_omega_t
 <<Omega interface: types>>=
   type, extends (prc_core_t) :: prc_omega_t
      real(default), dimension(:), allocatable :: par
      integer :: scheme = 0
      type(helicity_selection_t) :: helicity_selection
      type(qcd_t) :: qcd
      type(qed_t) :: qed
    contains
    <<Omega interface: prc omega: TBP>>
   end type prc_omega_t
 
 @ %def prc_omega_t
 @ The workspace associated to a [[prc_omega_t]] object contains a single flag.
 The flag is used to suppress re-evaluating the matrix element for each
 quantum-number combination, after the first amplitude belonging to a given
 kinematics has been computed.
 
 We can also store the value of a running coupling once it has been calculated
 for an event.  The default value is negative, which indicates an undefined
 value in this context.
 <<Omega interface: public>>=
   public :: omega_state_t
 <<Omega interface: types>>=
   type, extends (prc_core_state_t) :: omega_state_t
      logical :: new_kinematics = .true.
      real(default) :: alpha_qcd = -1
+     real(default) :: alpha_qed = -1
    contains
   <<Omega interface: omega state: TBP>>
   end type omega_state_t
 
 @ %def omega_state_t
 @
 <<Omega interface: omega state: TBP>>=
   procedure :: write => omega_state_write
 <<Omega interface: procedures>>=
   subroutine omega_state_write (object, unit)
     class(omega_state_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A,L1)")  "O'Mega state: new kinematics = ", &
          object%new_kinematics
   end subroutine omega_state_write
 
 @ %def omega_state_write
 <<Omega interface: omega state: TBP>>=
   procedure :: reset_new_kinematics => omega_state_reset_new_kinematics
 <<Omega interface: procedures>>=
   subroutine omega_state_reset_new_kinematics (object)
     class(omega_state_t), intent(inout) :: object
     object%new_kinematics = .true.
   end subroutine omega_state_reset_new_kinematics
 
 @ %def omega_state_reset_new_kinematics
 @ Allocate the workspace with the above specific type.
 <<Omega interface: prc omega: TBP>>=
   procedure :: allocate_workspace => prc_omega_allocate_workspace
 <<Omega interface: procedures>>=
   subroutine prc_omega_allocate_workspace (object, core_state)
     class(prc_omega_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     allocate (omega_state_t :: core_state)
   end subroutine prc_omega_allocate_workspace
 
 @ %def prc_omega_allocate_workspace
 @ The following procedures are inherited from the base type as deferred, thus
 must be implemented.  The corresponding unit tests are skipped here; the
 procedures are tested when called from the [[processes]] module.
 
 Output: print just the ID of the associated matrix element.  Then display any
 stored parameters and the helicity selection data.  (The latter are printed
 only if active.)
 <<Omega interface: prc omega: TBP>>=
   procedure :: write => prc_omega_write
 <<Omega interface: procedures>>=
   subroutine prc_omega_write (object, unit)
     class(prc_omega_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(3x,A)", advance="no")  "O'Mega process core:"
     if (object%data_known) then
        write (u, "(1x,A)")  char (object%data%id)
     else
        write (u, "(1x,A)")  "[undefined]"
     end if
     if (allocated (object%par)) then
        write (u, "(3x,A)")  "Parameter array:"
        do i = 1, size (object%par)
           write (u, "(5x,I0,1x,ES17.10)")  i, object%par(i)
        end do
     end if
     call object%helicity_selection%write (u)
     call object%qcd%write (u)
     call object%qed%write (u)
   end subroutine prc_omega_write
 
 @ %def prc_omega_write
 @
 <<Omega interface: prc omega: TBP>>=
   procedure :: write_name => prc_omega_write_name
 <<Omega interface: procedures>>=
   subroutine prc_omega_write_name (object, unit)
     class(prc_omega_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(1x,A)") "Core: O'Mega"
   end subroutine prc_omega_write_name
 
 @ %def prc_omega_write_name
 @ Temporarily store the parameter array inside the [[prc_omega]]
 object, so we can use it later during the actual initialization.  Also
 store threshold and cutoff for helicity selection.
 <<Omega interface: prc omega: TBP>>=
   procedure :: set_parameters => prc_omega_set_parameters
 <<Omega interface: procedures>>=
   subroutine prc_omega_set_parameters (prc_omega, model, &
        helicity_selection, qcd, use_color_factors)
     class(prc_omega_t), intent(inout) :: prc_omega
     class(model_data_t), intent(in), target, optional :: model
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     type(qcd_t), intent(in), optional :: qcd
     type(qed_t) :: qed
     logical, intent(in), optional :: use_color_factors
     if (present (model)) then
        if (.not. allocated (prc_omega%par)) &
             allocate (prc_omega%par (model%get_n_real ()))
        call model%real_parameters_to_array (prc_omega%par)
        prc_omega%scheme = model%get_scheme_num ()
        if (associated (model%get_par_data_ptr (var_str ('alpha_em_i')))) then
-          call qed%set_alpha_qed (one / model%get_real (var_str ('alpha_em_i')))
+          allocate (alpha_qed_fixed_t :: qed%alpha)
+          select type (alpha => qed%alpha)
+          type is (alpha_qed_fixed_t)
+             alpha%val = one / model%get_real (var_str ('alpha_em_i'))
+          end select
        end if
        prc_omega%qed = qed
     end if
     if (present (helicity_selection)) then
        prc_omega%helicity_selection = helicity_selection
     end if
     if (present (qcd)) then
        prc_omega%qcd = qcd
     end if
     if (present (use_color_factors)) then
        prc_omega%use_color_factors = use_color_factors
     end if
   end subroutine prc_omega_set_parameters
 
 @ %def prc_omega_set_parameters
 @ To fully initialize the process core, we perform base
 initialization, then initialize the external matrix element code.
 
 This procedure overrides the [[init]] method of the base type, which
 we nevertheless can access via its binding [[base_init]].  When done, we
 have an allocated driver.  The driver will call the [[init]] procedure
 for the external matrix element, and thus transfer the parameter set to
 where it finally belongs.
 
 If requested, we initialize the helicity selction counter.
 <<Omega interface: prc omega: TBP>>=
   procedure :: init => prc_omega_init
 <<Omega interface: procedures>>=
   subroutine prc_omega_init (object, def, lib, id, i_component)
     class(prc_omega_t), intent(inout) :: object
     class(prc_core_def_t), intent(in), target :: def
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     call object%base_init (def, lib, id, i_component)
     call object%activate_parameters ()
   end subroutine prc_omega_init
 
 @ %def prc_omega_init
 @ Activate the stored parameters by transferring them to the external
 matrix element.  Also reset the helicity selection, if requested.
 <<Omega interface: prc omega: TBP>>=
   procedure :: activate_parameters => prc_omega_activate_parameters
 <<Omega interface: procedures>>=
   subroutine prc_omega_activate_parameters (object)
     class (prc_omega_t), intent(inout) :: object
     if (allocated (object%driver)) then
        if (allocated (object%par)) then
           select type (driver => object%driver)
           type is (omega_driver_t)
              if (associated (driver%init)) then
                 call driver%init (object%par, object%scheme)
              end if
           end select
        else
           call msg_bug ("prc_omega_activate: parameter set is not allocated")
        end if
        call object%reset_helicity_selection ()
     else
        call msg_bug ("prc_omega_activate: driver is not allocated")
     end if
   end subroutine prc_omega_activate_parameters
 
 @ %def prc_omega_activate_parameters
 @ Tell whether a particular combination of flavor, helicity, color is
 allowed.  Here we have to consult the matrix-element driver.
 <<Omega interface: prc omega: TBP>>=
   procedure :: is_allowed => prc_omega_is_allowed
 <<Omega interface: procedures>>=
  function prc_omega_is_allowed (object, i_term, f, h, c) result (flag)
     class(prc_omega_t), intent(in) :: object
     integer, intent(in) :: i_term, f, h, c
     logical :: flag
     logical(c_bool) :: cflag
     select type (driver => object%driver)
     type is (omega_driver_t)
        call driver%is_allowed (f, h, c, cflag)
        flag = cflag
     end select
   end function prc_omega_is_allowed
 
 @ %def prc_omega_is_allowed
 @ Transfer the generated momenta directly to the hard interaction in
 the (only) term.  We assume that everything has been set up correctly,
 so the array fits.
 
 We don't reset the [[new_kinematics]] flag here.  This has to be done
 explicitly by the caller ([[reset_new_kinematics]]) when a new kinematics
 configuration is to be considered.
 <<Omega interface: prc omega: TBP>>=
   procedure :: compute_hard_kinematics => prc_omega_compute_hard_kinematics
 <<Omega interface: procedures>>=
   subroutine prc_omega_compute_hard_kinematics &
        (object, p_seed, i_term, int_hard, core_state)
     class(prc_omega_t), intent(in) :: object
     type(vector4_t), dimension(:), intent(in) :: p_seed
     integer, intent(in) :: i_term
     type(interaction_t), intent(inout) :: int_hard
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     call int_hard%set_momenta (p_seed)
   end subroutine prc_omega_compute_hard_kinematics
 
 @ %def prc_omega_compute_hard_kinematics
 @ This procedure is not called for [[prc_omega_t]], just a placeholder.
 <<Omega interface: prc omega: TBP>>=
   procedure :: compute_eff_kinematics => prc_omega_compute_eff_kinematics
 <<Omega interface: procedures>>=
   subroutine prc_omega_compute_eff_kinematics &
        (object, i_term, int_hard, int_eff, core_state)
     class(prc_omega_t), intent(in) :: object
     integer, intent(in) :: i_term
     type(interaction_t), intent(in) :: int_hard
     type(interaction_t), intent(inout) :: int_eff
     class(prc_core_state_t), intent(inout), allocatable :: core_state
   end subroutine prc_omega_compute_eff_kinematics
 
 @ %def prc_omega_compute_eff_kinematics
 @ Reset the helicity selection counters and start counting zero
 helicities.  We assume that the [[helicity_selection]] object is allocated.
 Otherwise, reset and switch off helicity counting.
 
 In the test routine, the driver is allocated but the driver methods are not.
 Therefore, guard against a disassociated method.
 <<Omega interface: prc omega: TBP>>=
   procedure :: reset_helicity_selection => prc_omega_reset_helicity_selection
 <<Omega interface: procedures>>=
   subroutine prc_omega_reset_helicity_selection (object)
     class(prc_omega_t), intent(inout) :: object
     select type (driver => object%driver)
     type is (omega_driver_t)
        if (associated (driver%reset_helicity_selection)) then
           if (object%helicity_selection%active) then
              call driver%reset_helicity_selection &
                   (real (object%helicity_selection%threshold, &
                   c_default_float), &
                   int (object%helicity_selection%cutoff, c_int))
           else
              call driver%reset_helicity_selection &
                   (0._c_default_float, 0_c_int)
           end if
        end if
     end select
   end subroutine prc_omega_reset_helicity_selection
 
 @ %def reset_helicity_selection
 @ Compute the amplitude.  For the tree-level process, we can ignore the scale
 settings.  The term index [[j]] is also irrelevant.
 
 We first call [[new_event]] for the given momenta (which we must unpack), then
 retrieve the amplitude value for the given quantum numbers.
 
 If the [[core_state]] status flag is present, we can make sure that we call
 [[new_event]] only once for a given kinematics.  After the first call, we
 unset the [[new_kinematics]] flag.
 
 The core objects computes the appropriate $\alpha_s$ value via the [[qcd]]
 subobject, taking into account the provided [[ren_scale]] value.  However, if
 the extra parameter [[alpha_qcd_forced]] is allocated, it overrides this
 setting.
 
 The [[is_allowed]] query is not redundant, since the status may change during
 the run if helicities are switched off.
 <<Omega interface: prc omega: TBP>>=
   procedure :: compute_amplitude => prc_omega_compute_amplitude
 <<Omega interface: procedures>>=
   function prc_omega_compute_amplitude &
        (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
        core_state)  result (amp)
     class(prc_omega_t), intent(in) :: object
     integer, intent(in) :: j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in) :: fac_scale, ren_scale
     real(default), intent(in), allocatable :: alpha_qcd_forced
     class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
     real(default) :: alpha_qcd
     complex(default) :: amp
     integer :: n_tot, i
     real(c_default_float), dimension(:,:), allocatable :: parray
     complex(c_default_complex) :: camp
     logical :: new_event
     select type (driver => object%driver)
     type is (omega_driver_t)
        new_event = .true.
        if (present (core_state)) then
           if (allocated (core_state)) then
              select type (core_state)
              type is (omega_state_t)
                 new_event = core_state%new_kinematics
                 core_state%new_kinematics = .false.
              end select
           end if
        end if
        if (new_event) then
           if (allocated (object%qcd%alpha)) then
              if (allocated (alpha_qcd_forced)) then
                 alpha_qcd = alpha_qcd_forced
              else
                 alpha_qcd = object%qcd%alpha%get (ren_scale)
              end if
              call driver%update_alpha_s (alpha_qcd)
              if (present (core_state)) then
                 if (allocated (core_state)) then
                    select type (core_state)
                    type is (omega_state_t)
                       core_state%alpha_qcd = alpha_qcd
                    end select
                 end if
              end if
           end if
           n_tot = object%data%get_n_tot ()
           allocate (parray (0:3, n_tot))
           do i = 1, n_tot
              parray(:,i) = vector4_get_components (p(i))
           end do
           call driver%new_event (parray)
        end if
        if (object%is_allowed (1, f, h, c)) then
           call driver%get_amplitude &
                (int (f, c_int), int (h, c_int), int (c, c_int), camp)
           amp = camp
        else
           amp = 0
        end if
     end select
   end function prc_omega_compute_amplitude
 
 @ %def prc_omega_compute_amplitude
 @ After the amplitude has been computed, we may read off the current value of
 $\alpha_s$.  This works only if $\alpha_s$ varies, and if the workspace
 [[core_state]] is present which stores this value.
 <<Omega interface: prc omega: TBP>>=
   procedure :: get_alpha_s => prc_omega_get_alpha_s
 <<Omega interface: procedures>>=
   function prc_omega_get_alpha_s (object, core_state) result (alpha_qcd)
     class(prc_omega_t), intent(in) :: object
     class(prc_core_state_t), intent(in), allocatable :: core_state
     real(default) :: alpha_qcd
     alpha_qcd = -1
     if (allocated (object%qcd%alpha) .and. allocated (core_state)) then
        select type (core_state)
        type is (omega_state_t)
           alpha_qcd = core_state%alpha_qcd
        end select
     end if
   end function prc_omega_get_alpha_s
 
 @ %def prc_omega_get_alpha_s
-@ $\alpha_\text{em}$ is not updated after computing the amplitude
-because we currently only support a fixed $\alpha_\text{em}$ but
-we still need a routine to get the value of [[alpha_qed]].
+@ After the amplitude has been computed, we may read off the current value of
+$\alpha$.  This works only if $\alpha$ varies, and if the workspace
+[[core_state]] is present which stores this value.
 <<Omega interface: prc omega: TBP>>=
   procedure :: get_alpha_qed => prc_omega_get_alpha_qed
 <<Omega interface: procedures>>=
-  function prc_omega_get_alpha_qed (object) result (alpha_qed)
+  function prc_omega_get_alpha_qed (object, core_state) result (alpha_qed)
     class(prc_omega_t), intent(in) :: object
+    class(prc_core_state_t), intent(in), allocatable :: core_state
     real(default) :: alpha_qed
-    alpha_qed = object%qed%get_alpha_qed ()
+    alpha_qed = -1
+    if (allocated (object%qed%alpha) .and. allocated (core_state)) then
+       select type (core_state)
+       type is (omega_state_t)
+          alpha_qed = core_state%alpha_qed
+       end select
+    end if
   end function prc_omega_get_alpha_qed
 
 @ %def prc_omega_get_alpha_qed
 @
 \subsection{Unit Test}
 Test module, followed by the corresponding implementation module.
 There is a separate test for testing \oMega\ diagram generation as
 this depends on a working analysis setup.
 <<[[prc_omega_ut.f90]]>>=
 <<File header>>
 
 module prc_omega_ut
   use unit_tests
   use prc_omega_uti
 
 <<Standard module head>>
 
 <<Omega interface: public test>>
 
 contains
 
 <<Omega interface: test driver>>
 
 end module prc_omega_ut
 @ %def prc_omega_ut
 @
 <<[[prc_omega_uti.f90]]>>=
 <<File header>>
 
 module prc_omega_uti
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
 <<Use strings>>
   use io_units
   use file_utils, only: delete_file
   use os_interface
   use sm_qcd
   use lorentz
   use model_data
   use var_base
   use particle_specifiers, only: new_prt_spec
   use prc_core_def
   use process_constants
   use process_libraries
   use prc_core
   use model_testbed, only: prepare_model, cleanup_model
 
   use prc_omega
 
 <<Standard module head>>
 
 <<Omega interface: test declarations>>
 
 contains
 
 <<Omega interface: tests>>
 
 end module prc_omega_uti
 @ %def prc_omega_ut
 @ API: driver for the unit tests below.
 <<Omega interface: public test>>=
   public :: prc_omega_test
 <<Omega interface: test driver>>=
   subroutine prc_omega_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Omega interface: execute tests>>
 end subroutine prc_omega_test
 
 @ %def prc_omega_test
 @
 <<Omega interface: public test>>=
   public :: prc_omega_diags_test
 <<Omega interface: test driver>>=
   subroutine prc_omega_diags_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Omega interface: execute diags tests>>
 end subroutine prc_omega_diags_test
 
 @ %def prc_omega_diags_test
 @
 \subsubsection{Generate, compile and load a simple process matrix element}
 The process is $e^+ e^- \to \mu^+\mu^-$ for vanishing masses and
 $e=0.3$.  We initialize the process, build the library, and compute a
 particular matrix element for momenta of unit energy and right-angle
 scattering.  The matrix element, as it happens, is equal to $e^2$.
 (Note that are no conversion factors applied, so this result is
 exact.)
 
 For [[GNU make]], [[makeflags]] is set to [[-j1]].  This eliminates a
 potential clash with a [[-j<n>]] flag if this test is called from a
 parallel make.
 <<Omega interface: execute tests>>=
   call test (prc_omega_1, "prc_omega_1", &
        "build and load simple OMega process", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_1
 <<Omega interface: tests>>=
   subroutine prc_omega_1 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     type(string_t) :: model_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(process_constants_t) :: data
     class(prc_core_driver_t), allocatable :: driver
     integer, parameter :: cdf = c_default_float
     integer, parameter :: ci = c_int
     real(cdf), dimension(4) :: par
     real(cdf), dimension(0:3,4) :: p
     logical(c_bool) :: flag
     complex(c_default_complex) :: amp
     integer :: i
 
     write (u, "(A)")  "* Test output: prc_omega_1"
     write (u, "(A)")  "*   Purpose: create a simple process with OMega"
     write (u, "(A)")  "*            build a library, link, load, and &
          &access the matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("omega1"))
     call os_data%init ()
 
     model_name = "QED"
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e+"), var_str ("e-")]
     prt_out = [var_str ("m+"), var_str ("m-")]
 
     allocate (omega_def_t :: def)
     select type (def)
     type is (omega_def_t)
        call def%init (model_name, prt_in, prt_out, &
             ufo = .false., ovm = .false.)
     end select
     allocate (entry)
     call entry%init (var_str ("omega1_a"), model_name = model_name, &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("omega"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure library"
     write (u, "(A)")
     call lib%configure (os_data)
 
     write (u, "(A)")  "* Write makefile"
     write (u, "(A)")
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
 
     write (u, "(A)")  "* Clean any left-over files"
     write (u, "(A)")
     call lib%clean (os_data, distclean = .false.)
 
     write (u, "(A)")  "* Write driver"
     write (u, "(A)")
     call lib%write_driver (force = .true.)
 
     write (u, "(A)")  "* Write process source code, compile, link, load"
     write (u, "(A)")
     call lib%load (os_data)
 
     call lib%write (u, libpath = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Constants of omega1_a_i1:"
     write (u, "(A)")
 
     call lib%connect_process (var_str ("omega1_a"), 1, data, driver)
 
     write (u, "(1x,A,A)")  "component ID     = ", char (data%id)
     write (u, "(1x,A,A)")  "model name       = ", char (data%model_name)
     write (u, "(1x,A,A,A)")  "md5sum           = '", data%md5sum, "'"
     write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported
     write (u, "(1x,A,I0)") "n_in  = ", data%n_in
     write (u, "(1x,A,I0)") "n_out = ", data%n_out
     write (u, "(1x,A,I0)") "n_flv = ", data%n_flv
     write (u, "(1x,A,I0)") "n_hel = ", data%n_hel
     write (u, "(1x,A,I0)") "n_col = ", data%n_col
     write (u, "(1x,A,I0)") "n_cin = ", data%n_cin
     write (u, "(1x,A,I0)") "n_cf  = ", data%n_cf
     write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state
     write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1)
     do i = 2, 16
        write (u, "(12x,4(1x,I2))")  data%hel_state(:,i)
     end do
     write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state
     write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag
     write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors
     write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters for omega1_a and initialize:"
     write (u, "(A)")
 
     par = [0.3_cdf, 0.0_cdf, 0.0_cdf, 0.0_cdf]
     write (u, "(2x,A,F6.4)")  "ee   = ", par(1)
     write (u, "(2x,A,F6.4)")  "me   = ", par(2)
     write (u, "(2x,A,F6.4)")  "mmu  = ", par(3)
     write (u, "(2x,A,F6.4)")  "mtau = ", par(4)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_cdf, 0.0_cdf, 0.0_cdf, 1.0_cdf, &
          1.0_cdf, 0.0_cdf, 0.0_cdf,-1.0_cdf, &
          1.0_cdf, 1.0_cdf, 0.0_cdf, 0.0_cdf, &
          1.0_cdf,-1.0_cdf, 0.0_cdf, 0.0_cdf &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.4))")  "p", i, " =", p(:,i)
     end do
 
     select type (driver)
     type is (omega_driver_t)
        call driver%init (par, 0)
 
        call driver%new_event (p)
 
        write (u, "(A)")
        write (u, "(A)")  "* Compute matrix element:"
        write (u, "(A)")
 
        call driver%is_allowed (1_ci, 6_ci, 1_ci, flag)
        write (u, "(1x,A,L1)") "is_allowed (1, 6, 1) = ", flag
 
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_1"
 
   end subroutine prc_omega_1
 
 @ %def prc_omega_1
 @
 \subsubsection{Check [[prc_omega_t]] wrapper and options}
 The process is $e^- e^+ \to e^- e^+$ for vanishing masses and
 $e=0.3$.  We build the library using the high-level procedure
 [[omega_make_process_component]] and the ``black box''
 [[prc_omega_t]] object.  Two variants with different settings for
 restrictions and OpenMP.
 
 For [[GNU make]], [[makeflags]] is set to [[-j1]].  This eliminates a
 potential clash with a [[-j<n>]] flag if this test is called from a
 parallel make.
 <<Omega interface: execute tests>>=
   call test (prc_omega_2, "prc_omega_2", &
        "OMega option passing", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_2
 <<Omega interface: tests>>=
   subroutine prc_omega_2 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     type(string_t) :: model_name
     class(model_data_t), pointer :: model
     class(vars_t), pointer :: vars
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(string_t) :: restrictions
     type(process_component_def_t), pointer :: config
     type(prc_omega_t) :: prc1, prc2
     type(process_constants_t) :: data
     integer, parameter :: cdf = c_default_float
     integer, parameter :: ci = c_int
     real(cdf), dimension(:), allocatable :: par
     real(cdf), dimension(0:3,4) :: p
     complex(c_default_complex) :: amp
     integer :: i
     logical :: exist
 
     write (u, "(A)")  "* Test output: prc_omega_2"
     write (u, "(A)")  "*   Purpose: create simple processes with OMega"
     write (u, "(A)")  "*            use the prc_omega wrapper for this"
     write (u, "(A)")  "*            and check OMega options"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with two entries, &
          &different options."
     write (u, "(A)")  "* (1) e- e+ -> e- e+   &
          &(all diagrams, no OpenMP, report progress)"
     write (u, "(A)")  "* (2) e- e+ -> e- e+   &
          &(s-channel only, with OpenMP, report progress to file)"
 
     call lib%init (var_str ("omega2"))
     call os_data%init ()
 
     model_name = "QED"
     model => null ()
     call prepare_model (model, model_name, vars)
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e-"), var_str ("e+")]
     prt_out = prt_in
     restrictions = "3+4~A"
 
     allocate (entry)
     call entry%init (var_str ("omega2_a"), &
          model, n_in = 2, n_components = 2)
 
     call omega_make_process_component (entry, 1, &
          model_name, prt_in, prt_out, &
          report_progress=.true.)
     call omega_make_process_component (entry, 2, &
          model_name, prt_in, prt_out, &
          restrictions=restrictions, openmp_support=.true., &
          extra_options=var_str ("-fusion:progress_file omega2.log"))
 
     call lib%append (entry)
 
     write (u, "(A)")
     write (u, "(A)")  "* Remove left-over file"
     write (u, "(A)")
 
     call delete_file ("omega2.log")
     inquire (file="omega2.log", exist=exist)
     write (u, "(1x,A,L1)")  "omega2.log exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Build and load library"
 
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Check extra output of OMega"
     write (u, "(A)")
 
     inquire (file="omega2.log", exist=exist)
     write (u, "(1x,A,L1)")  "omega2.log exists = ", exist
 
     write (u, "(A)")
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters for omega2_a and initialize:"
     write (u, "(A)")
 
     call vars%set_rval (var_str ("ee"), 0.3_default)
     call vars%set_rval (var_str ("me"), 0._default)
     call vars%set_rval (var_str ("mmu"), 0._default)
     call vars%set_rval (var_str ("mtau"), 0._default)
     allocate (par (model%get_n_real ()))
     call model%real_parameters_to_c_array (par)
 
     write (u, "(2x,A,F6.4)")  "ee   = ", par(1)
     write (u, "(2x,A,F6.4)")  "me   = ", par(2)
     write (u, "(2x,A,F6.4)")  "mmu  = ", par(3)
     write (u, "(2x,A,F6.4)")  "mtau = ", par(4)
 
     call prc1%set_parameters (model)
     call prc2%set_parameters (model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Constants of omega2_a_i1:"
     write (u, "(A)")
 
     entry => lib%get_process_def_ptr (var_str ("omega2_a"))
     config => entry%get_component_def_ptr (1)
     call prc1%init (config%get_core_def_ptr (), &
          lib, var_str ("omega2_a"), 1)
     call prc1%get_constants (data, 1)
 
     write (u, "(1x,A,A)")  "component ID     = ", &
          char (data%id)
     write (u, "(1x,A,L1)") "openmp supported = ", &
          data%openmp_supported
     write (u, "(1x,A,A,A)") "model name       = '", &
          char (data%model_name), "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Constants of omega2_a_i2:"
     write (u, "(A)")
 
     config => entry%get_component_def_ptr (2)
     call prc2%init (config%get_core_def_ptr (), &
          lib, var_str ("omega2_a"), 2)
     call prc2%get_constants (data, 1)
 
     write (u, "(1x,A,A)")  "component ID     = ", &
          char (data%id)
     write (u, "(1x,A,L1)") "openmp supported = ", &
          data%openmp_supported
     write (u, "(1x,A,A,A)") "model name       = '", &
          char (data%model_name), "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_cdf, 0.0_cdf, 0.0_cdf, 1.0_cdf, &
          1.0_cdf, 0.0_cdf, 0.0_cdf,-1.0_cdf, &
          1.0_cdf, 1.0_cdf, 0.0_cdf, 0.0_cdf, &
          1.0_cdf,-1.0_cdf, 0.0_cdf, 0.0_cdf &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.4))")  "p", i, " =", p(:,i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute matrix element:"
     write (u, "(A)")
 
     select type (driver => prc1%driver)
     type is (omega_driver_t)
        call driver%new_event (p)
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(2x,A,1x,E11.4)") "(1) |amp (1, 6, 1)| =", abs (amp)
     end select
 
     select type (driver => prc2%driver)
     type is (omega_driver_t)
        call driver%new_event (p)
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(2x,A,1x,E11.4)") "(2) |amp (1, 6, 1)| =", abs (amp)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_cdf, 0.0_cdf, 0.0_cdf, 1.0_cdf, &
          1.0_cdf, 0.0_cdf, 0.0_cdf,-1.0_cdf, &
          1.0_cdf, sqrt(0.5_cdf), 0.0_cdf, sqrt(0.5_cdf), &
          1.0_cdf,-sqrt(0.5_cdf), 0.0_cdf,-sqrt(0.5_cdf) &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.4))")  "p", i, " =", p(:,i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute matrix element:"
     write (u, "(A)")
 
     select type (driver => prc1%driver)
     type is (omega_driver_t)
        call driver%new_event (p)
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(2x,A,1x,E11.4)") "(1) |amp (1, 6, 1)| =", abs (amp)
     end select
 
     select type (driver => prc2%driver)
     type is (omega_driver_t)
        call driver%new_event (p)
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(2x,A,1x,E11.4)") "(2) |amp (1, 6, 1)| =", abs (amp)
     end select
 
     call lib%final ()
     call cleanup_model (model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_2"
 
   end subroutine prc_omega_2
 
 @ %def prc_omega_2
 @
 \subsubsection{Check helicity selection}
 The process is $e^- e^+ \to e^- e^+$ for vanishing masses.  We call
 the matrix element several times to verify the switching off of
 irrelevant helicities.
 <<Omega interface: execute tests>>=
   call test (prc_omega_3, "prc_omega_3", &
        "helicity selection", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_3
 <<Omega interface: tests>>=
   subroutine prc_omega_3 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     type(string_t) :: model_name
     class(model_data_t), pointer :: model
     class(vars_t), pointer :: vars => null ()
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(process_component_def_t), pointer :: config
     type(prc_omega_t) :: prc1
     type(process_constants_t) :: data
     integer, parameter :: cdf = c_default_float
     real(cdf), dimension(:), allocatable :: par
     real(cdf), dimension(0:3,4) :: p
     type(helicity_selection_t) :: helicity_selection
     integer :: i, h
 
     write (u, "(A)")  "* Test output: prc_omega_3"
     write (u, "(A)")  "*   Purpose: create simple process with OMega"
     write (u, "(A)")  "*            and check helicity selection"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library."
     write (u, "(A)")  "* (1) e- e+ -> e- e+   (all diagrams, no OpenMP)"
 
     call lib%init (var_str ("omega3"))
     call os_data%init ()
 
     model_name = "QED"
     model => null ()
     call prepare_model (model, model_name, vars)
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e-"), var_str ("e+")]
     prt_out = prt_in
 
     allocate (entry)
     call entry%init (var_str ("omega3_a"), &
          model, n_in = 2, n_components = 1)
 
     call omega_make_process_component (entry, 1, &
          model_name, prt_in, prt_out)
     call lib%append (entry)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build and load library"
 
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters for omega3_a and initialize:"
     write (u, "(A)")
 
     call vars%set_rval (var_str ("ee"), 0.3_default)
     call vars%set_rval (var_str ("me"), 0._default)
     call vars%set_rval (var_str ("mmu"), 0._default)
     call vars%set_rval (var_str ("mtau"), 0._default)
     allocate (par (model%get_n_real ()))
     call model%real_parameters_to_c_array (par)
 
     write (u, "(2x,A,F6.4)")  "ee   = ", par(1)
     write (u, "(2x,A,F6.4)")  "me   = ", par(2)
     write (u, "(2x,A,F6.4)")  "mmu  = ", par(3)
     write (u, "(2x,A,F6.4)")  "mtau = ", par(4)
 
     call prc1%set_parameters (model, helicity_selection=helicity_selection)
 
     write (u, "(A)")
     write (u, "(A)")  "* Helicity states of omega3_a_i1:"
     write (u, "(A)")
 
     entry => lib%get_process_def_ptr (var_str ("omega3_a"))
     config => entry%get_component_def_ptr (1)
     call prc1%init (config%get_core_def_ptr (), &
          lib, var_str ("omega3_a"), 1)
     call prc1%get_constants (data, 1)
 
     do i = 1, data%n_hel
        write (u, "(3x,I2,':',4(1x,I2))") i, data%hel_state(:,i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Initially allowed helicities:"
     write (u, "(A)")
 
     write (u, "(4x,16(1x,I2))")  [(h, h = 1, data%n_hel)]
     write (u, "(4x)", advance = "no")
     do h = 1, data%n_hel
        write (u, "(2x,L1)", advance = "no")  prc1%is_allowed (1, 1, h, 1)
     end do
     write (u, "(A)")
 
     write (u, "(A)")
     write (u, "(A)")  "* Reset helicity selection (cutoff = 4)"
     write (u, "(A)")
 
     helicity_selection%active = .true.
     helicity_selection%threshold = 1e10_default
     helicity_selection%cutoff = 4
     call helicity_selection%write (u)
 
     call prc1%set_parameters (model, helicity_selection=helicity_selection)
     call prc1%reset_helicity_selection ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Allowed helicities:"
     write (u, "(A)")
 
     write (u, "(4x,16(1x,I2))")  [(h, h = 1, data%n_hel)]
     write (u, "(4x)", advance = "no")
     do h = 1, data%n_hel
        write (u, "(2x,L1)", advance = "no")  prc1%is_allowed (1, 1, h, 1)
     end do
     write (u, "(A)")
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          1.0_cdf, 0.0_cdf, 0.0_cdf, 1.0_cdf, &
          1.0_cdf, 0.0_cdf, 0.0_cdf,-1.0_cdf, &
          1.0_cdf, 1.0_cdf, 0.0_cdf, 0.0_cdf, &
          1.0_cdf,-1.0_cdf, 0.0_cdf, 0.0_cdf &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.4))")  "p", i, " =", p(:,i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute scattering matrix 5 times"
     write (u, "(A)")
 
     write (u, "(4x,16(1x,I2))")  [(h, h = 1, data%n_hel)]
 
     select type (driver => prc1%driver)
     type is (omega_driver_t)
        do i = 1, 5
           call driver%new_event (p)
           write (u, "(2x,I2)", advance = "no")  i
           do h = 1, data%n_hel
              write (u, "(2x,L1)", advance = "no")  prc1%is_allowed (1, 1, h, 1)
           end do
           write (u, "(A)")
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Reset helicity selection again"
     write (u, "(A)")
 
     call prc1%activate_parameters ()
 
     write (u, "(A)")  "* Allowed helicities:"
     write (u, "(A)")
 
     write (u, "(4x,16(1x,I2))")  [(h, h = 1, data%n_hel)]
     write (u, "(4x)", advance = "no")
     do h = 1, data%n_hel
        write (u, "(2x,L1)", advance = "no")  prc1%is_allowed (1, 1, h, 1)
     end do
     write (u, "(A)")
 
     call lib%final ()
     call cleanup_model (model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_3"
 
   end subroutine prc_omega_3
 
 @ %def prc_omega_3
 @
 \subsubsection{QCD coupling}
 The process is $u\bar u \to d\bar d$ for vanishing masses.  We compute
 the amplitude for a fixed configuration once, then reset $\alpha_s$,
 then compute again.
 
 For [[GNU make]], [[makeflags]] is set to [[-j1]].  This eliminates a
 potential clash with a [[-j<n>]] flag if this test is called from a
 parallel make.
 <<Omega interface: execute tests>>=
   call test (prc_omega_4, "prc_omega_4", &
        "update QCD alpha", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_4
 <<Omega interface: tests>>=
   subroutine prc_omega_4 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     type(string_t) :: model_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(process_constants_t) :: data
     class(prc_core_driver_t), allocatable :: driver
     integer, parameter :: cdf = c_default_float
     integer, parameter :: ci = c_int
     real(cdf), dimension(8) :: par
     real(cdf), dimension(0:3,4) :: p
     logical(c_bool) :: flag
     complex(c_default_complex) :: amp
     integer :: i
     real(cdf) :: alpha_s
 
     write (u, "(A)")  "* Test output: prc_omega_4"
     write (u, "(A)")  "*   Purpose: create a QCD process with OMega"
     write (u, "(A)")  "*            and check alpha_s dependence"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("prc_omega_4_lib"))
     call os_data%init ()
 
     model_name = "QCD"
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("u"), var_str ("ubar")]
     prt_out = [var_str ("d"), var_str ("dbar")]
 
     allocate (omega_def_t :: def)
     select type (def)
     type is (omega_def_t)
        call def%init (model_name, prt_in, prt_out, &
             ufo = .false., ovm = .false.)
     end select
     allocate (entry)
     call entry%init (var_str ("prc_omega_4_p"), model_name = model_name, &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("omega"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure and compile process"
     write (u, "(A)")
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active = ", lib%is_active ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters:"
     write (u, "(A)")
 
     alpha_s = 0.1178_cdf
 
     par = [alpha_s, &
          0._cdf, 0._cdf, 0._cdf, 0._cdf, 0._cdf, 173.1_cdf, 1.523_cdf]
     write (u, "(2x,A,F8.4)")  "alpha_s = ", par(1)
     write (u, "(2x,A,F8.4)")  "md      = ", par(2)
     write (u, "(2x,A,F8.4)")  "mu      = ", par(3)
     write (u, "(2x,A,F8.4)")  "ms      = ", par(4)
     write (u, "(2x,A,F8.4)")  "mc      = ", par(5)
     write (u, "(2x,A,F8.4)")  "mb      = ", par(6)
     write (u, "(2x,A,F8.4)")  "mtop    = ", par(7)
     write (u, "(2x,A,F8.4)")  "wtop    = ", par(8)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics:"
     write (u, "(A)")
 
     p = reshape ([ &
          100.0_cdf, 0.0_cdf, 0.0_cdf, 100.0_cdf, &
          100.0_cdf, 0.0_cdf, 0.0_cdf,-100.0_cdf, &
          100.0_cdf, 100.0_cdf, 0.0_cdf, 0.0_cdf, &
          100.0_cdf,-100.0_cdf, 0.0_cdf, 0.0_cdf &
          ], [4,4])
     do i = 1, 4
        write (u, "(2x,A,I0,A,4(1x,F7.1))")  "p", i, " =", p(:,i)
     end do
 
     call lib%connect_process (var_str ("prc_omega_4_p"), 1, data, driver)
 
     select type (driver)
     type is (omega_driver_t)
        call driver%init (par, 0)
 
        write (u, "(A)")
        write (u, "(A)")  "* Compute matrix element:"
        write (u, "(A)")
 
        call driver%new_event (p)
 
        call driver%is_allowed (1_ci, 6_ci, 1_ci, flag)
        write (u, "(1x,A,L1)") "is_allowed (1, 6, 1) = ", flag
 
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
 
        write (u, "(A)")
        write (u, "(A)")  "* Double alpha_s and compute matrix element again:"
        write (u, "(A)")
 
        call driver%update_alpha_s (2 * alpha_s)
        call driver%new_event (p)
 
        call driver%is_allowed (1_ci, 6_ci, 1_ci, flag)
        write (u, "(1x,A,L1)") "is_allowed (1, 6, 1) = ", flag
 
        call driver%get_amplitude (1_ci, 6_ci, 1_ci, amp)
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
     end select
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_4"
 
   end subroutine prc_omega_4
 
 @ %def prc_omega_4
 @
 \subsubsection{Amplitude and QCD coupling}
 The same process as before.  Here, we initialize with a running $\alpha_s$
 coupling and compute twice with different scales.  We use the high-level
 method [[compute_amplitude]].
 <<Omega interface: execute tests>>=
   call test (prc_omega_5, "prc_omega_5", &
        "running QCD alpha", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_5
 <<Omega interface: tests>>=
   subroutine prc_omega_5 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_component_def_t), pointer :: cdef_ptr
     class(prc_core_def_t), pointer :: def_ptr
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     type(string_t) :: model_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(qcd_t) :: qcd
     class(prc_core_t), allocatable :: core
     class(prc_core_state_t), allocatable :: core_state
     type(vector4_t), dimension(4) :: p
     complex(default) :: amp
     real(default) :: ren_scale
     real(default), allocatable :: alpha_qcd_forced
     integer :: i
 
     write (u, "(A)")  "* Test output: prc_omega_5"
     write (u, "(A)")  "*   Purpose: create a QCD process with OMega"
     write (u, "(A)")  "*            and check alpha_s dependence"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("prc_omega_5_lib"))
     call os_data%init ()
 
     model_name = "QCD"
     model => null ()
     call prepare_model (model, model_name)
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("u"), var_str ("ubar")]
     prt_out = [var_str ("d"), var_str ("dbar")]
 
     allocate (omega_def_t :: def)
     select type (def)
     type is (omega_def_t)
        call def%init (model_name, prt_in, prt_out, &
             ufo = .false., ovm = .false.)
     end select
     allocate (entry)
     call entry%init (var_str ("prc_omega_5_p"), model_name = model_name, &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("omega"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure and compile process"
     write (u, "(A)")
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
     write (u, "(A)")  "* Probe library API"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active = ", lib%is_active ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics"
     write (u, "(A)")
 
     p(1) = vector4_moving (100._default, 100._default, 3)
     p(2) = vector4_moving (100._default,-100._default, 3)
     p(3) = vector4_moving (100._default, 100._default, 1)
     p(4) = vector4_moving (100._default,-100._default, 1)
     do i = 1, 4
        call vector4_write (p(i), u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup QCD data"
     write (u, "(A)")
 
     allocate (alpha_qcd_from_scale_t :: qcd%alpha)
 
     write (u, "(A)")  "* Setup process core"
     write (u, "(A)")
 
     allocate (prc_omega_t :: core)
     entry => lib%get_process_def_ptr (var_str ("prc_omega_5_p"))
     cdef_ptr => entry%get_component_def_ptr (1)
     def_ptr => cdef_ptr%get_core_def_ptr ()
 
     select type (core)
     type is (prc_omega_t)
        call core%allocate_workspace (core_state)
        call core%set_parameters (model, qcd = qcd)
        call core%init (def_ptr, lib, var_str ("prc_omega_5_p"), 1)
        call core%write (u)
 
        write (u, "(A)")
        write (u, "(A)")  "* Compute matrix element"
        write (u, "(A)")
 
        ren_scale = 100
        write (u, "(1x,A,F4.0)")  "renormalization scale = ", ren_scale
 
        amp = core%compute_amplitude &
             (1, p, 1, 6, 1, 100._default, ren_scale, alpha_qcd_forced)
 
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
 
        write (u, "(A)")
        write (u, "(A)")  "* Modify renormalization scale and &
             &compute matrix element again"
        write (u, "(A)")
 
        ren_scale = 200
        write (u, "(1x,A,F4.0)")  "renormalization scale = ", ren_scale
 
        amp = core%compute_amplitude &
             (1, p, 1, 6, 1, 100._default, ren_scale, alpha_qcd_forced)
 
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
 
        write (u, "(A)")
        write (u, "(A)")  "* Set alpha(QCD) directly and &
             &compute matrix element again"
        write (u, "(A)")
 
        allocate (alpha_qcd_forced, source = 0.1_default)
        write (u, "(1x,A,F6.4)")  "alpha_qcd = ", alpha_qcd_forced
 
        amp = core%compute_amplitude &
             (1, p, 1, 6, 1, 100._default, ren_scale, alpha_qcd_forced)
 
        write (u, "(1x,A,1x,E11.4)") "|amp (1, 6, 1)| =", abs (amp)
 
     end select
 
     call lib%final ()
     call cleanup_model (model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_5"
 
   end subroutine prc_omega_5
 
 @ %def prc_omega_5
 @
 \subsubsection{UFO model file support}
 Again, the process is $e^- e^+ \to e^- e^+$ for vanishing masses and
 $e=0.3$.  We build the library using the high-level procedure
 [[omega_make_process_component]] and the ``black box''
 [[prc_omega_t]] object.  OMega must be able to digest the specified
 UFO file and provide use with a fresh model file that can be read
 after producing the process code.
 
 For [[GNU make]], [[makeflags]] is set to [[-j1]].  This eliminates a
 potential clash with a [[-j<n>]] flag if this test is called from a
 parallel make.
 <<Omega interface: execute tests>>=
   call test (prc_omega_6, "prc_omega_6", &
        "OMega UFO support", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_6
 <<Omega interface: tests>>=
   subroutine prc_omega_6 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     type(string_t) :: model_name
     class(model_data_t), pointer :: model
     class(vars_t), pointer :: vars
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(string_t) :: restrictions
     type(process_component_def_t), pointer :: config
     type(prc_omega_t) :: prc1, prc2
     type(process_constants_t) :: data
     integer, parameter :: cdf = c_default_float
     integer, parameter :: ci = c_int
     real(cdf), dimension(:), allocatable :: par
     real(cdf), dimension(0:3,4) :: p
     complex(c_default_complex) :: amp
     integer :: i
     logical :: exist
 
     write (u, "(A)")  "* Test output: prc_omega_6"
     write (u, "(A)")  "*   Purpose: create simple process with OMega / UFO file"
     write (u, "(A)")
 
     call os_data%init ()
 
     model_name = "SM"
     model => null ()
 
     os_data%whizard_modelpath_ufo = "../models/UFO"
 
     write (u, "(A)")  "* Create process library entry"
     write (u, "(A)")
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("e-"), var_str ("e+")]
     prt_out = prt_in
     restrictions = "3+4~A"
 
     allocate (entry)
     call entry%init (var_str ("omega_6_a"), &
          model_name = model_name, n_in = 2, n_components = 1)
 
     call omega_make_process_component (entry, 1, &
          model_name, prt_in, prt_out, &
          ufo=.true., ufo_path=os_data%whizard_modelpath_ufo, &
          report_progress=.true.)
 
     call entry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build and load library"
 
     call lib%init (var_str ("omega_6"))
     call lib%append (entry)
 
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
     write (u, "(A)")
     write (u, "(A)")  "* Probe library API:"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active                 = ", &
          lib%is_active ()
     write (u, "(1x,A,I0)")  "n_processes               = ", &
          lib%get_n_processes ()
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_6"
 
   end subroutine prc_omega_6
 
 @ %def prc_omega_6
 @
 \subsubsection{Generate matrix element diagrams}
 The same process as before. No amplitude is computed here, instead we just
 generate Feynman (and color flow) diagrams, and check whether PS and PDF
 files have been generated. This test is only run if event analysis is
 possible.
 <<Omega interface: execute diags tests>>=
   call test (prc_omega_diags_1, "prc_omega_diags_1", &
        "generate Feynman diagrams", &
        u, results)
 <<Omega interface: test declarations>>=
   public :: prc_omega_diags_1
 <<Omega interface: tests>>=
   subroutine prc_omega_diags_1 (u)
     integer, intent(in) :: u
     type(process_library_t) :: lib
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
     type(os_data_t) :: os_data
     type(string_t) :: model_name
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     type(string_t) :: diags_file, pdf_file, ps_file
     logical :: exist, exist_pdf, exist_ps
     integer :: iostat, u_diags
     character(128) :: buffer
 
     write (u, "(A)")  "* Test output: prc_omega_diags_1"
     write (u, "(A)")  "*   Purpose: generate Feynman diagrams"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process library with one entry"
     write (u, "(A)")
     call lib%init (var_str ("prc_omega_diags_1_lib"))
     call os_data%init ()
 
     model_name = "SM"
 
     allocate (prt_in (2), prt_out (2))
     prt_in = [var_str ("u"), var_str ("ubar")]
     prt_out = [var_str ("d"), var_str ("dbar")]
 
     allocate (omega_def_t :: def)
     select type (def)
     type is (omega_def_t)
        call def%init (model_name, prt_in, prt_out, &
             ufo = .false., ovm = .false., &
             diags = .true., diags_color = .true.)
     end select
     allocate (entry)
     call entry%init (var_str ("prc_omega_diags_1_p"), model_name = model_name, &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("omega"), &
          variant = def)
     call lib%append (entry)
 
     write (u, "(A)")  "* Configure and compile process"
     write (u, "(A)")  "    and generate diagrams"
     write (u, "(A)")
     call lib%configure (os_data)
     call lib%write_makefile &
          (os_data, force = .true., verbose = .false., testflag = .true.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
     write (u, "(A)")  "* Probe library API"
     write (u, "(A)")
 
     write (u, "(1x,A,L1)")  "is active = ", lib%is_active ()
 
     write (u, "(A)")  "* Check produced diagram files"
     write (u, "(A)")
 
     diags_file = "prc_omega_diags_1_p_i1_diags.tex"
     ps_file  = "prc_omega_diags_1_p_i1_diags.ps"
     pdf_file = "prc_omega_diags_1_p_i1_diags.pdf"
     inquire (file = char (diags_file), exist = exist)
     if (exist) then
        u_diags = free_unit ()
        open (u_diags, file = char (diags_file), action = "read", status = "old")
        iostat = 0
        do while (iostat == 0)
           read (u_diags, "(A)", iostat = iostat)  buffer
           if (iostat == 0)  write (u, "(A)")  trim (buffer)
        end do
        close (u_diags)
     else
        write (u, "(A)")  "[Feynman diagrams LaTeX file is missing]"
     end if
     inquire (file = char (ps_file), exist = exist_ps)
     if (exist_ps) then
        write (u, "(A)")  "[Feynman diagrams Postscript file exists and is nonempty]"
     else
        write (u, "(A)")  "[Feynman diagrams Postscript file is missing/non-regular]"
     end if
     inquire (file = char (pdf_file), exist = exist_pdf)
     if (exist_pdf) then
        write (u, "(A)")  "[Feynman diagrams PDF file exists and is nonempty]"
     else
        write (u, "(A)")  "[Feynman diagrams PDF file is missing/non-regular]"
     end if
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call lib%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: prc_omega_diags_1"
 
   end subroutine prc_omega_diags_1
 
 @ %def prc_omega_diags_1
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{External matrix elements (squared)}
 This defines an abstract framework that can handle matrix elements which are
 computed outside of \whizard.  Such matrix elements typically (i) require
 extra code or libraries to be configured linked at execution time, and (ii)
 provide only plain or correlated squared matrix elements instead of
 amplitudes.
 
 In particular, matrix-element libraries that conform to the BLHA standard
 belong to this class.  They have their own (also abstract) extension of the
 abstract [[prc_external_t]] type introduced here.
 [[prc_external_t]]-type.
 <<[[prc_external.f90]]>>=
 <<File header>>
 module prc_external
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
   use constants
   use io_units
 <<Use strings>>
 <<Use debug>>
   use system_defs, only: TAB
   use physics_defs, only: CF
   use diagnostics
   use os_interface
   use lorentz
   use interactions
   use sm_qcd
   use sm_qed
   use variables, only: var_list_t
 
   use model_data
   use prclib_interfaces
   use prc_core_def
   use prc_core
   use prc_omega, only: omega_state_t
 
   use sf_base
   use sf_pdf_builtin, only: pdf_builtin_t
   use sf_lhapdf, only: lhapdf_t
   use pdg_arrays, only: is_gluon, is_quark
 
 <<Standard module head>>
 
 <<Prc external: public>>
 
 <<Prc external: parameters>>
 
 <<Prc external: types>>
 
 <<Prc external: interfaces>>
 
 contains
 
 <<Prc external: procedures>>
 
 end module prc_external
 @ %def prc_external
 @
 \subsection{Handling of structure functions}
 External matrix elements do not have access to the structure functions
 stored in the evaluators. The current solution to this problem is to
 just apply them explicitly after the computation of the matrix element.
 <<Prc external: parameters>>=
   integer, parameter :: LEPTONS = 1
   integer, parameter :: HADRONS = 2
 <<Prc external: types>>=
   type :: sf_handler_t
      integer :: initial_state_type = 0
      integer :: n_sf = -1
      real(default) :: val = one
   contains
   <<Prc external: sf handler: TBP>>
   end type sf_handler_t
 
 @ %def sf_handler_t
 @
 <<Prc external: sf handler: TBP>>=
   procedure :: init => sf_handler_init
 <<Prc external: procedures>>=
   subroutine sf_handler_init (sf_handler, sf_chain)
     class(sf_handler_t), intent(out) :: sf_handler
     type(sf_chain_instance_t), intent(in) :: sf_chain
     integer :: i
     sf_handler%n_sf = size (sf_chain%sf)
     if (sf_handler%n_sf == 0) then
        sf_handler%initial_state_type = LEPTONS
     else
        do i = 1, sf_handler%n_sf
           select type (int => sf_chain%sf(i)%int)
           type is (pdf_builtin_t)
              sf_handler%initial_state_type = HADRONS
           type is (lhapdf_t)
              sf_handler%initial_state_type = HADRONS
           class default
              sf_handler%initial_state_type = LEPTONS
           end select
        end do
      end if
   end subroutine sf_handler_init
 
 @ %def sf_handler_init
 @
 <<Prc external: sf handler: TBP>>=
   procedure :: init_dummy => sf_handler_init_dummy
 <<Prc external: procedures>>=
   subroutine sf_handler_init_dummy (sf_handler)
     class(sf_handler_t), intent(out) :: sf_handler
     sf_handler%n_sf = 0
     sf_handler%initial_state_type = LEPTONS
   end subroutine sf_handler_init_dummy
 
 @ %def sf_handler_init_dummy
 @
 <<Prc external: sf handler: TBP>>=
   procedure :: apply_structure_functions => sf_handler_apply_structure_functions
 <<Prc external: procedures>>=
   subroutine sf_handler_apply_structure_functions (sf_handler, sf_chain, flavors)
      class(sf_handler_t), intent(inout) :: sf_handler
      type(sf_chain_instance_t), intent(in) :: sf_chain
      integer, intent(in), dimension(2) :: flavors
      integer :: i
      real(default), dimension(:), allocatable :: f
      if (sf_handler%n_sf < 0) call msg_fatal ("sf_handler not initialized")
      sf_handler%val = one
      do i = 1, sf_handler%n_sf
         select case (sf_handler%initial_state_type)
         case (HADRONS)
            sf_handler%val = sf_handler%val * sf_handler%get_pdf (sf_chain, i, flavors(i))
         case (LEPTONS)
            call sf_chain%get_matrix_elements (i, f)
            sf_handler%val = sf_handler%val * f(1)
         case default
            call msg_fatal ("sf_handler not initialized")
         end select
      end do
   end subroutine sf_handler_apply_structure_functions
 
 @ %def sf_handler_apply_structure_functions
 @
 <<Prc external: sf handler: TBP>>=
   procedure :: get_pdf => sf_handler_get_pdf
 <<Prc external: procedures>>=
   function sf_handler_get_pdf (sf_handler, sf_chain, i, flavor) result (f)
      real(default) :: f
      class(sf_handler_t), intent(in) :: sf_handler
      type(sf_chain_instance_t), intent(in) :: sf_chain
      integer, intent(in) :: i, flavor
      integer :: k
      real(default), dimension(:), allocatable :: ff
      integer, parameter :: n_flv_light = 6
 
      call sf_chain%get_matrix_elements (i, ff)
 
      if (is_gluon (flavor)) then
         k = n_flv_light + 1
      else if (is_quark (abs(flavor))) then
         k = n_flv_light + 1 + flavor
      else
         call msg_fatal ("Not a colored particle")
      end if
 
      f = ff(k)
    end function sf_handler_get_pdf
 
 @ %def sf_handler_get_pdf
 @
 \subsection{Abstract interface to external matrix elements}
 This process class allows us to factor out common necessities of processes
 that involve external code or libraries.
 
 \subsubsection{Workspace}
 This is the workspace that is available for external matrix elements.
 <<Prc external: public>>=
   public :: prc_external_state_t
 <<Prc external: types>>=
   type, abstract, extends (prc_core_state_t) :: prc_external_state_t
     logical :: new_kinematics = .true.
     real(default) :: alpha_qcd = -1
+    real(default) :: alpha_qed = -1
   contains
   <<Prc external: external state: TBP>>
   end type prc_external_state_t
 
 @ %def prc_external_state_t
 @
 <<Prc external: external state: TBP>>=
   procedure :: reset_new_kinematics => prc_external_state_reset_new_kinematics
 <<Prc external: procedures>>=
   subroutine prc_external_state_reset_new_kinematics (object)
     class(prc_external_state_t), intent(inout) :: object
     object%new_kinematics = .true.
   end subroutine prc_external_state_reset_new_kinematics
 
 @ %def prc_external_state_reset_new_kinematics
 @
-<<Prc external: external state: TBP>>=
-  procedure :: get_alpha_qcd => prc_external_state_get_alpha_qcd
-<<Prc external: procedures>>=
-  function prc_external_state_get_alpha_qcd (object) result (alpha_qcd)
-    real(default) :: alpha_qcd
-    class(prc_external_state_t), intent(in) :: object
-    alpha_qcd = object%alpha_qcd
-  end function prc_external_state_get_alpha_qcd
-
-@ %def prc_external_state_get_alpha_qcd
-@
 \subsubsection{Driver}
 We have to add two O'Mega-routines to the external matrix-element driver to
 ensure proper process setup.  The problem is that during the setup of
 the real component, the particle and flavor data are taken from the Born
 component to set up the subtraction terms.  However, the Born component
 expects this data to be obtained from the Omega code, accessed by the
 driver.
 <<Prc external: public>>=
   public :: prc_external_driver_t
 <<Prc external: types>>=
   type, abstract, extends (prc_core_driver_t) :: prc_external_driver_t
      procedure(omega_update_alpha_s), nopass, pointer :: &
               update_alpha_s => null ()
      procedure(omega_is_allowed), nopass, pointer :: &
               is_allowed => null ()
   end type prc_external_driver_t
 
 @ %def prc_external_driver_t
 @
 \subsubsection{Core}
 <<Prc external: public>>=
   public :: prc_external_t
 <<Prc external: types>>=
   type, abstract, extends (prc_core_t) :: prc_external_t
     type(qcd_t) :: qcd
     type(qed_t) :: qed
     integer :: n_flv = 1
     real(default), dimension(:), allocatable :: par
     integer :: scheme = 0
     type(sf_handler_t) :: sf_handler
     real(default) :: maximum_accuracy = 10000.0
   contains
   <<Prc external: prc external: TBP>>
   end type prc_external_t
 
 @ %def prc_external_t
 @ By definition, this class of process-core types require extra code.
 <<Prc external: prc external: TBP>>=
   procedure, nopass :: needs_external_code => &
        prc_external_needs_external_code
 <<Prc external: procedures>>=
   function prc_external_needs_external_code () result (flag)
     logical :: flag
     flag = .true.
   end function prc_external_needs_external_code
 
 @ %def prc_external_needs_external_code
 @
 <<Prc external: prc external: TBP>>=
   procedure :: get_n_flvs => prc_external_get_n_flvs
 <<Prc external: procedures>>=
   pure function prc_external_get_n_flvs (object, i_flv) result (n)
     integer :: n
     class(prc_external_t), intent(in) :: object
     integer, intent(in) :: i_flv
     n = size (object%data%flv_state (:,i_flv))
   end function prc_external_get_n_flvs
 
 @ %def prc_external_get_n_flvs
 @
 <<Prc external: prc external: TBP>>=
   procedure :: get_flv_state => prc_external_get_flv_state
 <<Prc external: procedures>>=
   function prc_external_get_flv_state (object, i_flv) result (flv)
     integer, dimension(:), allocatable :: flv
     class(prc_external_t), intent(in) :: object
     integer, intent(in) :: i_flv
     allocate (flv (size (object%data%flv_state (:,i_flv))))
     flv = object%data%flv_state (:,i_flv)
   end function prc_external_get_flv_state
 
 @ %def prc_external_get_flv_state
 @ Return one single squared test matrix element. It is fixed to 1,
 therefore the integration output will be the phase space volume.
 <<Prc external: prc external: TBP>>=
   procedure :: compute_sqme => prc_external_compute_sqme
 <<Prc external: procedures>>=
   subroutine prc_external_compute_sqme (object, i_flv, i_hel, p, &
          ren_scale, sqme, bad_point)
      class(prc_external_t), intent(in) :: object
      integer, intent(in) :: i_flv, i_hel
      type(vector4_t), dimension(:), intent(in) :: p
      real(default), intent(in) :: ren_scale
      real(default), intent(out) :: sqme
      logical, intent(out) :: bad_point
      sqme = one
      bad_point = .false.
   end subroutine prc_external_compute_sqme
 
 @ %def prc_external_compute_sqme
 @ Return an array of 4 numbers corresponding to the BLHA output convention.
 Used for testing.
 <<Prc external: prc external: TBP>>=
   procedure :: compute_sqme_virt => prc_external_compute_sqme_virt
 <<Prc external: procedures>>=
   subroutine prc_external_compute_sqme_virt (object, i_flv, i_hel, &
      p, ren_scale, es_scale, loop_method, sqme, bad_point)
     class(prc_external_t), intent(in) :: object
     integer, intent(in) :: i_flv, i_hel
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: ren_scale, es_scale
     integer, intent(in) :: loop_method
     logical, intent(out) :: bad_point
     real(default), dimension(4), intent(out) :: sqme
     if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_external_compute_sqme_virt")
     sqme(1) = 0.001_default
     sqme(2) = 0.001_default
     sqme(3) = 0.001_default
     sqme(4) = 0.0015_default
     bad_point = .false.
   end subroutine prc_external_compute_sqme_virt
 
 @ %def prc_external_compute_sqme_virt
 @ Also return test output for color-correlated matrix elements. We only
   give a sensible result for the processes used in the functional tests,
   which have 2 -> 2 topology. All other processes will obtain a vanishing
   dummy color-correlation. This effectively switches off the subtraction
   contributions, reproducing the real phase-space volume.
 <<Prc external: prc external: TBP>>=
   procedure :: compute_sqme_color_c => prc_external_compute_sqme_color_c
 <<Prc external: procedures>>=
   subroutine prc_external_compute_sqme_color_c (object, i_flv, i_hel, p, &
      ren_scale, born_color_c, bad_point, born_out)
     class(prc_external_t), intent(inout) :: object
     integer, intent(in) :: i_flv, i_hel
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale
     real(default), intent(inout), dimension(:,:) :: born_color_c
     logical, intent(out) :: bad_point
     real(default), intent(out), optional :: born_out
     if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_external_compute_sqme_color_c")
     if (size (p) == 4) then
        if (present (born_out)) then
           born_out = 0.0015_default
           born_color_c = zero
           born_color_c(3,3) = - CF * born_out
           born_color_c(4,4) = - CF * born_out
           born_color_c(3,4) = CF * born_out
           born_color_c(4,3) = born_color_c(3,4)
           bad_point = .false.
        end if
     else
        if (present (born_out)) born_out = zero
        born_color_c = zero
     end if
   end subroutine prc_external_compute_sqme_color_c
 
 @ %def prc_external_compute_sqme_color_c
 @
 <<Prc external: prc external: TBP>>=
   procedure :: compute_alpha_s => prc_external_compute_alpha_s
 <<Prc external: procedures>>=
   subroutine prc_external_compute_alpha_s &
        (object, core_state, ren_scale)
     class(prc_external_t), intent(in) :: object
     class(prc_external_state_t), intent(inout) :: core_state
     real(default), intent(in) :: ren_scale
     core_state%alpha_qcd = object%qcd%alpha%get (ren_scale)
   end subroutine prc_external_compute_alpha_s
 
 @ %def prc_external_compute_alpha_s
 @
 <<Prc external: prc external: TBP>>=
   procedure :: get_alpha_s => prc_external_get_alpha_s
 <<Prc external: procedures>>=
   function prc_external_get_alpha_s (object, core_state) result (alpha_qcd)
     class(prc_external_t), intent(in) :: object
     class(prc_core_state_t), intent(in), allocatable :: core_state
     real(default) :: alpha_qcd
     if (allocated (core_state)) then
       select type (core_state)
       class is (prc_external_state_t)
          alpha_qcd = core_state%alpha_qcd
       type is (omega_state_t)
          alpha_qcd = core_state%alpha_qcd
       class default
          alpha_qcd = zero
       end select
     else
        alpha_qcd = zero
     end if
   end function prc_external_get_alpha_s
 
 @ %def prc_external_get_alpha_s
 @ Getter for [[alpha_qed]]
 <<Prc external: prc external: TBP>>=
   procedure :: get_alpha_qed => prc_external_get_alpha_qed
 <<Prc external: procedures>>=
-  function prc_external_get_alpha_qed (object) result (alpha_qed)
+  function prc_external_get_alpha_qed (object, core_state) result (alpha_qed)
     class(prc_external_t), intent(in) :: object
+    class(prc_core_state_t), intent(in), allocatable :: core_state
     real(default) :: alpha_qed
-    alpha_qed = object%qed%get_alpha_qed ()
+    if (allocated (core_state)) then
+       select type (core_state)
+       class is (prc_external_state_t)
+          alpha_qed = core_state%alpha_qed
+       type is (omega_state_t)
+          alpha_qed = core_state%alpha_qed
+       class default
+          alpha_qed = zero
+       end select
+    else
+       alpha_qed = zero
+    end if
   end function prc_external_get_alpha_qed
 
 @ %def prc_external_get_alpha_qed
 @
 <<Prc external: prc external: TBP>>=
   procedure :: is_allowed => prc_external_is_allowed
 <<Prc external: procedures>>=
   function prc_external_is_allowed (object, i_term, f, h, c) result (flag)
     class(prc_external_t), intent(in) :: object
     integer, intent(in) :: i_term, f, h, c
     logical :: flag
     logical(c_bool) :: cflag
     select type (driver => object%driver)
     class is (prc_external_driver_t)
        call driver%is_allowed (f, h, c, cflag)
        flag = cflag
     class default
        call msg_fatal &
           ("Driver does not fit to prc_external_t")
     end select
   end function prc_external_is_allowed
 
 @
 @ %def prc_external_is_allowed
 <<Prc external: prc external: TBP>>=
   procedure :: get_nflv => prc_external_get_nflv
 <<Prc external: procedures>>=
   function prc_external_get_nflv (object) result (n_flv)
     class(prc_external_t), intent(in) :: object
     integer :: n_flv
     n_flv = object%n_flv
   end function prc_external_get_nflv
 
 @ %def prc_external_get_nflv
 @
 <<Prc external: prc external: TBP>>=
   procedure :: compute_hard_kinematics => prc_external_compute_hard_kinematics
 <<Prc external: procedures>>=
   subroutine prc_external_compute_hard_kinematics &
        (object, p_seed, i_term, int_hard, core_state)
     class(prc_external_t), intent(in) :: object
     type(vector4_t), dimension(:), intent(in) :: p_seed
     integer, intent(in) :: i_term
     type(interaction_t), intent(inout) :: int_hard
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     call int_hard%set_momenta (p_seed)
     if (allocated (core_state)) then
       select type (core_state)
       class is (prc_external_state_t); core_state%new_kinematics = .true.
       end select
     end if
   end subroutine prc_external_compute_hard_kinematics
 
 @
 @ %def prc_external_compute_hard_kinematics
 <<Prc external: prc external: TBP>>=
   procedure :: compute_eff_kinematics => prc_external_compute_eff_kinematics
 <<Prc external: procedures>>=
   subroutine prc_external_compute_eff_kinematics &
        (object, i_term, int_hard, int_eff, core_state)
     class(prc_external_t), intent(in) :: object
     integer, intent(in) :: i_term
     type(interaction_t), intent(in) :: int_hard
     type(interaction_t), intent(inout) :: int_eff
     class(prc_core_state_t), intent(inout), allocatable :: core_state
   end subroutine prc_external_compute_eff_kinematics
 
 @
 @ %def prc_external_compute_eff_kinematics
 @
 <<Prc external: prc external: TBP>>=
   procedure :: set_parameters => prc_external_set_parameters
 <<Prc external: procedures>>=
   subroutine prc_external_set_parameters (object, qcd, model)
     class(prc_external_t), intent(inout) :: object
     type(qcd_t), intent(in) :: qcd
     type(qed_t) :: qed
     class(model_data_t), intent(in), target, optional :: model
     object%qcd = qcd
     if (present (model)) then
        if (.not. allocated (object%par)) &
             allocate (object%par (model%get_n_real ()))
        call model%real_parameters_to_array (object%par)
        object%scheme = model%get_scheme_num ()
        if (associated (model%get_par_data_ptr (var_str ('alpha_em_i')))) then
-          call qed%set_alpha_qed (one / model%get_real (var_str ('alpha_em_i')))
+          allocate (alpha_qed_fixed_t :: qed%alpha)
+          select type (alpha => qed%alpha)
+          type is (alpha_qed_fixed_t)
+             alpha%val = one / model%get_real (var_str ('alpha_em_i'))
+          end select
        end if
        object%qed = qed
     end if
   end subroutine prc_external_set_parameters
 
 @ %def prc_external_set_parameters
 @
 <<Prc external: prc external: TBP>>=
   procedure :: update_alpha_s => prc_external_update_alpha_s
 <<Prc external: procedures>>=
   subroutine prc_external_update_alpha_s (object, core_state, scale)
     class(prc_external_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     real(default), intent(in) :: scale
     real(default) :: alpha_qcd
     if (allocated (object%qcd%alpha)) then
        alpha_qcd = object%qcd%alpha%get (scale)
        select type (driver => object%driver)
        class is (prc_external_driver_t)
           call driver%update_alpha_s (alpha_qcd)
        end select
        select type (core_state)
        class is (prc_external_state_t)
           core_state%alpha_qcd = alpha_qcd
        type is (omega_state_t)
           core_state%alpha_qcd = alpha_qcd
        end select
     end if
   end subroutine prc_external_update_alpha_s
 
 @ %def prc_external_update_alpha_s
 @
 <<Prc external: prc external: TBP>>=
   procedure :: init_sf_handler => prc_external_init_sf_handler
 <<Prc external: procedures>>=
   subroutine prc_external_init_sf_handler (core, sf_chain)
      class(prc_external_t), intent(inout) :: core
      type(sf_chain_instance_t), intent(in) :: sf_chain
      if (allocated (sf_chain%sf)) then
         call core%sf_handler%init (sf_chain)
      else
         call core%sf_handler%init_dummy ()
      end if
   end subroutine prc_external_init_sf_handler
 
 @ %def prc_external_init_sf_handler
 @
 <<Prc external: prc external: TBP>>=
   procedure :: init_sf_handler_dummy => prc_external_init_sf_handler_dummy
 <<Prc external: procedures>>=
   subroutine prc_external_init_sf_handler_dummy (core)
      class(prc_external_t), intent(inout) :: core
      call core%sf_handler%init_dummy ()
   end subroutine prc_external_init_sf_handler_dummy
 
 @ %def prc_external_init_sf_handler_dummy
 @
 <<Prc external: prc external: TBP>>=
   procedure :: apply_structure_functions => prc_external_apply_structure_functions
 <<Prc external: procedures>>=
   subroutine prc_external_apply_structure_functions (core, sf_chain, flavors)
     class(prc_external_t), intent(inout) :: core
     type(sf_chain_instance_t), intent(in) :: sf_chain
     integer, dimension(2), intent(in) :: flavors
     call core%sf_handler%apply_structure_functions (sf_chain, flavors)
   end subroutine prc_external_apply_structure_functions
 
 @ %def prc_external_apply_structure_functions
 @
 <<Prc external: prc external: TBP>>=
   procedure :: get_sf_value => prc_external_get_sf_value
 <<Prc external: procedures>>=
   function prc_external_get_sf_value (core) result (val)
     real(default) :: val
     class(prc_external_t), intent(in) :: core
     val = core%sf_handler%val
   end function prc_external_get_sf_value
 
 @ %def prc_external_get_sf_value
 @
 <<Prc external: prc external: TBP>>=
   procedure(prc_external_includes_polarization), deferred :: &
     includes_polarization
 <<Prc external: interfaces>>=
   abstract interface
     function prc_external_includes_polarization (object) result (polarized)
       import
       logical :: polarized
       class(prc_external_t), intent(in) :: object
     end function prc_external_includes_polarization
   end interface
 
 @ %def prc_external_includes_polarization
 @
 \subsubsection{Configuration}
 This is the abstract external matrix-element interface.
 <<Prc external: public>>=
   public :: prc_external_def_t
 <<Prc external: types>>=
   type, abstract, extends (prc_core_def_t) :: prc_external_def_t
     type(string_t) :: basename
   contains
   <<Prc external: external def: TBP>>
   end type prc_external_def_t
 
 @ %def prc_external_def_t
 @
 <<Prc external: external def: TBP>>=
   procedure :: set_active_writer => prc_external_def_set_active_writer
 <<Prc external: procedures>>=
   subroutine prc_external_def_set_active_writer (def, active)
     class(prc_external_def_t), intent(inout) :: def
     logical, intent(in) :: active
     select type (writer => def%writer)
     class is (prc_external_writer_t)
        writer%active = active
     end select
   end subroutine prc_external_def_set_active_writer
 
 @ %def_prc_external_def_set_active_writer
 @
 <<Prc external: external def: TBP>>=
   procedure, nopass :: get_features => prc_external_def_get_features
 <<Prc external: procedures>>=
   subroutine prc_external_def_get_features (features)
     type(string_t), dimension(:), allocatable, intent(out) :: features
     allocate (features (6))
     features = [ &
          var_str ("init"), &
          var_str ("update_alpha_s"), &
          var_str ("reset_helicity_selection"), &
          var_str ("is_allowed"), &
          var_str ("new_event"), &
          var_str ("get_amplitude")]
   end subroutine prc_external_def_get_features
 
 @
 @ %def prc_external_def_get_features
 <<Prc external: external def: TBP>>=
   procedure :: connect => prc_external_def_connect
   procedure :: omega_connect => prc_external_def_connect
 <<Prc external: procedures>>=
   subroutine prc_external_def_connect (def, lib_driver, i, proc_driver)
     class(prc_external_def_t), intent(in) :: def
     class(prclib_driver_t), intent(in) :: lib_driver
     integer, intent(in) :: i
     class(prc_core_driver_t), intent(inout) :: proc_driver
     integer :: pid, fid
     type(c_funptr) :: fptr
     select type (proc_driver)
     class is (prc_external_driver_t)
        pid = i
        fid = 2
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%update_alpha_s)
        fid = 4
        call lib_driver%get_fptr (pid, fid, fptr)
        call c_f_procpointer (fptr, proc_driver%is_allowed)
     end select
   end subroutine prc_external_def_connect
 
 @ %def prc_external_def_connect
 @
 <<Prc external: external def: TBP>>=
   procedure, nopass :: needs_code => prc_external_def_needs_code
 <<Prc external: procedures>>=
   function prc_external_def_needs_code () result (flag)
     logical :: flag
     flag = .true.
   end function prc_external_def_needs_code
 
 @  %def prc_external_def_needs_code
 @
 <<Prc external: interfaces>>=
   abstract interface
      subroutine omega_update_alpha_s (alpha_s) bind(C)
        import
        real(c_default_float), intent(in) :: alpha_s
      end subroutine omega_update_alpha_s
   end interface
 
   abstract interface
      subroutine omega_is_allowed (flv, hel, col, flag) bind(C)
        import
        integer(c_int), intent(in) :: flv, hel, col
        logical(c_bool), intent(out) :: flag
      end subroutine omega_is_allowed
   end interface
 
 @ %def omega-interfaces
 @
 \subsubsection{Writer}
 <<Prc external: public>>=
   public :: prc_external_writer_t
 <<Prc external: types>>=
   type, abstract, extends (prc_writer_f_module_t) :: prc_external_writer_t
     type(string_t) :: model_name
     type(string_t) :: process_mode
     type(string_t) :: process_string
     type(string_t) :: restrictions
     integer :: n_in = 0
     integer :: n_out = 0
     logical :: active = .true.
     logical :: amp_triv = .true.
   contains
   <<Prc external: external writer: TBP>>
   end type prc_external_writer_t
 
 @ %def prc_external_writer_t
 @
 <<Prc external: external writer: TBP>>=
   procedure :: init => prc_external_writer_init
   procedure :: base_init => prc_external_writer_init
 <<Prc external: procedures>>=
   pure subroutine prc_external_writer_init &
        (writer, model_name, prt_in, prt_out, restrictions)
     class(prc_external_writer_t), intent(inout) :: writer
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: prt_in, prt_out
     type(string_t), intent(in), optional :: restrictions
     integer :: i
     writer%model_name = model_name
     if (present (restrictions)) then
        writer%restrictions = restrictions
     else
        writer%restrictions = ""
     end if
     writer%n_in = size (prt_in)
     writer%n_out = size (prt_out)
     select case (size (prt_in))
        case(1); writer%process_mode = " -decay"
        case(2); writer%process_mode = " -scatter"
     end select
     associate (s => writer%process_string)
       s = " '"
       do i = 1, size (prt_in)
          if (i > 1) s = s // " "
          s = s // prt_in(i)
       end do
       s = s // " ->"
       do i = 1, size (prt_out)
          s = s // " " // prt_out(i)
       end do
       s = s // "'"
     end associate
   end subroutine prc_external_writer_init
 
 @ %def prc_external_writer_init
 @
 <<Prc external: external writer: TBP>>=
   procedure, nopass :: get_module_name => prc_external_writer_get_module_name
 <<Prc external: procedures>>=
   function prc_external_writer_get_module_name (id) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: id
     name = "opr_" // id
   end function prc_external_writer_get_module_name
 
 @ %def prc_external_writer_get_module_name
 @
 <<Prc external: external writer: TBP>>=
   procedure :: write_wrapper => prc_external_writer_write_wrapper
 <<Prc external: procedures>>=
   subroutine prc_external_writer_write_wrapper (writer, unit, id, feature)
     class(prc_external_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id, feature
     type(string_t) :: name
     name = writer%get_c_procname (id, feature)
     write (unit, *)
     select case (char (feature))
     case ("init")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (par, scheme) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        write (unit, "(2x,9A)")  "real(c_default_float), dimension(*), &
             &intent(in) :: par"
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: scheme"
        if (c_default_float == default .and. c_int == kind (1)) then
           write (unit, "(2x,9A)")  "call ", char (feature), " (par, scheme)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("update_alpha_s")
        write (unit, "(9A)")  "subroutine ", char (name), " (alpha_s) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), intent(in) &
                &:: alpha_s"
           write (unit, "(2x,9A)")  "call ", char (feature), " (alpha_s)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("reset_helicity_selection")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (threshold, cutoff) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), intent(in) &
                &:: threshold"
           write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: cutoff"
           write (unit, "(2x,9A)")  "call ", char (feature), &
                " (threshold, int (cutoff))"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("is_allowed")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (flv, hel, col, flag) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(2x,9A)")  "logical(c_bool), intent(out) :: flag"
        write (unit, "(2x,9A)")  "flag = ", char (feature), &
             " (int (flv), int (hel), int (col))"
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("new_event")
        write (unit, "(9A)")  "subroutine ", char (name), " (p) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        if (c_default_float == default) then
           write (unit, "(2x,9A)")  "real(c_default_float), dimension(0:3,*), &
                &intent(in) :: p"
           write (unit, "(2x,9A)")  "call ", char (feature), " (p)"
        end if
        write (unit, "(9A)")  "end subroutine ", char (name)
     case ("get_amplitude")
        write (unit, "(9A)")  "subroutine ", char (name), &
             " (flv, hel, col, amp) bind(C)"
        write (unit, "(2x,9A)")  "use iso_c_binding"
        write (unit, "(2x,9A)")  "use kinds"
        write (unit, "(2x,9A)")  "use opr_", char (id)
        write (unit, "(2x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(2x,9A)")  "complex(c_default_complex), intent(out) &
             &:: amp"
        write (unit, "(2x,9A)")  "amp = ", char (feature), &
             " (int (flv), int (hel), int (col))"
        write (unit, "(9A)")  "end subroutine ", char (name)
     end select
 
   end subroutine prc_external_writer_write_wrapper
 
 @
 @ %def prc_external_writer_write_wrapper
 <<Prc external: external writer: TBP>>=
   procedure :: write_interface => prc_external_writer_write_interface
 <<Prc external: procedures>>=
   subroutine prc_external_writer_write_interface (writer, unit, id, feature)
     class(prc_external_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(string_t), intent(in) :: feature
     type(string_t) :: name
     name = writer%get_c_procname (id, feature)
     write (unit, "(2x,9A)")  "interface"
     select case (char (feature))
     case ("init")
        write (unit, "(5x,9A)")  "subroutine ", char (name), &
             " (par, scheme) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), dimension(*), &
             &intent(in) :: par"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: scheme"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("update_alpha_s")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " (alpha_s) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), intent(in) :: alpha_s"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("reset_helicity_selection")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(threshold, cutoff) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), intent(in) :: threshold"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: cutoff"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("is_allowed")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(flv, hel, col, flag) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(7x,9A)")  "logical(c_bool), intent(out) :: flag"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("new_event")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " (p) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "real(c_default_float), dimension(0:3,*), &
             &intent(in) :: p"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     case ("get_amplitude")
        write (unit, "(5x,9A)")  "subroutine ", char (name), " &
             &(flv, hel, col, amp) bind(C)"
        write (unit, "(7x,9A)")  "import"
        write (unit, "(7x,9A)")  "integer(c_int), intent(in) :: flv, hel, col"
        write (unit, "(7x,9A)")  "complex(c_default_complex), intent(out) &
             &:: amp"
        write (unit, "(5x,9A)")  "end subroutine ", char (name)
     end select
     write (unit, "(2x,9A)")  "end interface"
   end subroutine prc_external_writer_write_interface
 
 @ %def prc_external_writer_write_interface
 @ Empty, but can be overridden.
 <<Prc external: external writer: TBP>>=
   procedure :: write_source_code => prc_external_writer_write_source_code
 <<Prc external: procedures>>=
   subroutine prc_external_writer_write_source_code (writer, id)
     class(prc_external_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     if (debug_on) call msg_debug (D_ME_METHODS, &
          "prc_external_writer_write_source_code (no-op)")
     !!! This is a dummy
   end subroutine prc_external_writer_write_source_code
 
 @ %def prc_external_writer_write_source_code
 @ Empty, but can be overridden.
 <<Prc external: external writer: TBP>>=
   procedure :: before_compile => prc_external_writer_before_compile
   procedure :: after_compile => prc_external_writer_after_compile
 <<Prc external: procedures>>=
   subroutine prc_external_writer_before_compile (writer, id)
     class(prc_external_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     if (debug_on) call msg_debug (D_ME_METHODS, &
          "prc_external_writer_before_compile (no-op)")
     !!! This is a dummy
   end subroutine prc_external_writer_before_compile
 
   subroutine prc_external_writer_after_compile (writer, id)
     class(prc_external_writer_t), intent(in) :: writer
     type(string_t), intent(in) :: id
     if (debug_on) call msg_debug (D_ME_METHODS, &
          "prc_external_writer_after_compile (no-op)")
     !!! This is a dummy
   end subroutine prc_external_writer_after_compile
 
 @ %def prc_external_writer_before_compile
 @ %def prc_external_writer_after_compile
 @ Standard Makefile, set up to call \oMega.  Additionally, the \oMega\ output
 can be exploited for its data-management parts.
 <<Prc external: external writer: TBP>>=
   procedure :: write_makefile_code => prc_external_writer_write_makefile_code
   procedure :: base_write_makefile_code => prc_external_writer_write_makefile_code
 <<Prc external: procedures>>=
   subroutine prc_external_writer_write_makefile_code &
        (writer, unit, id, os_data, verbose, testflag)
     class(prc_external_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     logical, intent(in), optional :: testflag
     type(string_t) :: omega_binary, omega_path
     type(string_t) :: restrictions_string, amp_triv_string
     omega_binary = "omega_" // writer%model_name // ".opt"
     omega_path = os_data%whizard_omega_binpath // "/" // omega_binary
     if (.not. verbose)  omega_path = "@" // omega_path
     if (writer%restrictions /= "") then
        restrictions_string = " -cascade '" // writer%restrictions // "'"
     else
        restrictions_string = ""
     end if
     amp_triv_string = ""
     if (writer%amp_triv)  amp_triv_string = " -target:amp_triv"
     write (unit, "(5A)")  "OBJECTS += ", char (id), ".lo"
     write (unit, "(5A)")  char (id), ".f90:"
     if (.not. verbose) then
        write (unit, "(5A)")  TAB // '@echo  "  OMEGA     ', trim (char (id)), '.f90"'
     end if
     write (unit, "(99A)")  TAB, char (omega_path), &
          " -o ", char (id), ".f90", &
          " -target:whizard", char (amp_triv_string), &
          " -target:parameter_module parameters_", char (writer%model_name), &
          " -target:module opr_", char (id), &
          " -target:md5sum '", writer%md5sum, "'", &
          char (writer%process_mode), char (writer%process_string), &
          char (restrictions_string)
     write (unit, "(5A)")  "clean-", char (id), ":"
     write (unit, "(5A)")  TAB, "rm -f ", char (id), ".f90"
     write (unit, "(5A)")  TAB, "rm -f opr_", char (id), ".mod"
     write (unit, "(5A)")  TAB, "rm -f ", char (id), ".lo"
     write (unit, "(5A)")  "CLEAN_SOURCES += ", char (id), ".f90"
     write (unit, "(5A)")  "CLEAN_OBJECTS += opr_", char (id), ".mod"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), ".lo"
     write (unit, "(5A)")  char (id), ".lo: ", char (id), ".f90"
     if (.not. verbose) then
        write (unit, "(5A)")  TAB // '@echo  "  FC       " $@'
     end if
     write (unit, "(5A)")  TAB, "$(LTFCOMPILE) $<"
 
   end subroutine prc_external_writer_write_makefile_code
 
 @ %def prc_external_writer_write_makefile_code
 @
 <<Prc external: external writer: TBP>>=
   procedure, nopass:: get_procname => prc_external_writer_writer_get_procname
 <<Prc external: procedures>>=
   function prc_external_writer_writer_get_procname (feature) result (name)
     type(string_t) :: name
     type(string_t), intent(in) :: feature
     select case (char (feature))
     case ("n_in");   name = "number_particles_in"
     case ("n_out");  name = "number_particles_out"
     case ("n_flv");  name = "number_flavor_states"
     case ("n_hel");  name = "number_spin_states"
     case ("n_col");  name = "number_color_flows"
     case ("n_cin");  name = "number_color_indices"
     case ("n_cf");   name = "number_color_factors"
     case ("flv_state");  name = "flavor_states"
     case ("hel_state");  name = "spin_states"
     case ("col_state");  name = "color_flows"
     case default
        name = feature
     end select
   end function prc_external_writer_writer_get_procname
 
 @ %def prc_external_writer_writer_get_procname
 @
 \subsection{external test}
 \subsubsection{Writer}
 <<Prc external: public>>=
   public :: prc_external_test_writer_t
 <<Prc external: types>>=
   type, extends (prc_external_writer_t) :: prc_external_test_writer_t
   contains
   <<Prc external: external test writer: TBP>>
   end type prc_external_test_writer_t
 
 @ %def prc_external_test_writer_t
 @
 <<Prc external: external test writer: TBP>>=
   procedure, nopass :: type_name => prc_external_test_writer_type_name
 <<Prc external: procedures>>=
   function prc_external_test_writer_type_name () result (string)
     type(string_t) :: string
     string = "External matrix element dummy"
   end function prc_external_test_writer_type_name
 
 @ %def prc_external_test_writer_type_name
 @
 \subsubsection{Workspace}
 This looks pretty useless. Why don't we make [[prc_external_state_t]]
 nonabstract and remove this?
 <<Prc external: public>>=
   public :: prc_external_test_state_t
 <<Prc external: types>>=
   type, extends (prc_external_state_t) :: prc_external_test_state_t
   contains
   <<Prc external: external test state: TBP>>
   end type prc_external_test_state_t
 
 @ %def prc_external_test_state_t
 @
 <<Prc external: external test state: TBP>>=
   procedure :: write => prc_external_test_state_write
 <<Prc external: procedures>>=
   subroutine prc_external_test_state_write (object, unit)
     class(prc_external_test_state_t), intent(in) :: object
     integer, intent(in), optional :: unit
   end subroutine prc_external_test_state_write
 
 @ %def prc_external_test_state_write
 @
 \subsubsection{Driver}
 <<Prc external: public>>=
   public :: prc_external_test_driver_t
 <<Prc external: types>>=
   type, extends (prc_external_driver_t) :: prc_external_test_driver_t
   contains
   <<Prc external: external test driver: TBP>>
   end type prc_external_test_driver_t
 
 @ %def prc_external_test_driver_t
 @
 <<Prc external: external test driver: TBP>>=
   procedure, nopass :: type_name => prc_external_test_driver_type_name
 <<Prc external: procedures>>=
   function prc_external_test_driver_type_name () result (type)
     type(string_t) :: type
     type = "External matrix element dummy"
   end function prc_external_test_driver_type_name
 
 @ %def prc_external_test_driver_type_name
 @
 \subsubsection{Configuration}
 A external test definition.
 <<Prc external: public>>=
   public :: prc_external_test_def_t
 <<Prc external: types>>=
   type, extends (prc_external_def_t) :: prc_external_test_def_t
   contains
   <<Prc external: external test def: TBP>>
   end type prc_external_test_def_t
 
 @ %def prc_external_test_def_t
 @
 <<Prc external: external test def: TBP>>=
   procedure :: init => prc_external_test_def_init
 <<Prc external: procedures>>=
   subroutine prc_external_test_def_init (object, basename, model_name, &
        prt_in, prt_out)
     class(prc_external_test_def_t), intent(inout) :: object
     type(string_t), intent(in) :: basename, model_name
     type(string_t), dimension(:), intent(in) :: prt_in, prt_out
     object%basename = basename
     allocate (prc_external_test_writer_t :: object%writer)
     select type (writer => object%writer)
     type is (prc_external_test_writer_t)
        call writer%init (model_name, prt_in, prt_out)
     end select
   end subroutine prc_external_test_def_init
 
 @ %def prc_external_test_def_init
 @
 <<Prc external: external test def: TBP>>=
   procedure, nopass :: type_string => prc_external_test_def_type_string
 <<Prc external: procedures>>=
   function prc_external_test_def_type_string () result (string)
     type(string_t) :: string
     string = "external test dummy"
   end function prc_external_test_def_type_string
 
 @ %def prc_external_def_type_string
 @
 <<Prc external: external test def: TBP>>=
   procedure :: write => prc_external_test_def_write
 <<Prc external: procedures>>=
   subroutine prc_external_test_def_write (object, unit)
     class(prc_external_test_def_t), intent(in) :: object
     integer, intent(in) :: unit
   end subroutine prc_external_test_def_write
 
 @ %def prc_external_test_def_write
 @
 <<Prc external: external test def: TBP>>=
   procedure :: read => prc_external_test_def_read
 <<Prc external: procedures>>=
   subroutine prc_external_test_def_read (object, unit)
     class(prc_external_test_def_t), intent(out) :: object
     integer, intent(in) :: unit
   end subroutine prc_external_test_def_read
 
 @ %def prc_external_test_def_read
 @
 <<Prc external: external test def: TBP>>=
   procedure :: allocate_driver => prc_external_test_def_allocate_driver
 <<Prc external: procedures>>=
   subroutine prc_external_test_def_allocate_driver (object, driver, basename)
     class(prc_external_test_def_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     if (.not. allocated (driver)) allocate (prc_external_test_driver_t :: driver)
   end subroutine prc_external_test_def_allocate_driver
 
 @ %def prc_external_test_def_allocate_driver
 @
 \subsubsection{Core}
 This external test just returns $|\mathcal{M}|^2=1$ and thus the
 result of the integration is the n-particle-phase-space volume.
 <<Prc external: public>>=
   public :: prc_external_test_t
 <<Prc external: types>>=
   type, extends (prc_external_t) :: prc_external_test_t
   contains
   <<Prc external: prc test: TBP>>
   end type prc_external_test_t
 
 @ %def prc_external_test_t
 @
 <<Prc external: prc test: TBP>>=
   procedure :: write => prc_external_test_write
 <<Prc external: procedures>>=
   subroutine prc_external_test_write (object, unit)
     class(prc_external_test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     call msg_message ("Test external matrix elements")
   end subroutine prc_external_test_write
 
 @ %def prc_external_write
 @
 <<Prc external: prc test: TBP>>=
   procedure :: write_name => prc_external_test_write_name
 <<Prc external: procedures>>=
   subroutine prc_external_test_write_name (object, unit)
     class(prc_external_test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(1x,A)") "Core: external test"
   end subroutine prc_external_test_write_name
 
 @ %def prc_external_test_write_name
 @
 <<Prc external: prc test: TBP>>=
   procedure :: compute_amplitude => prc_external_test_compute_amplitude
 <<Prc external: procedures>>=
   function prc_external_test_compute_amplitude &
        (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
        core_state)  result (amp)
     class(prc_external_test_t), intent(in) :: object
     integer, intent(in) :: j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in) :: fac_scale, ren_scale
     real(default), intent(in), allocatable :: alpha_qcd_forced
     class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
     complex(default) :: amp
     select type (core_state)
     class is (prc_external_test_state_t)
        core_state%alpha_qcd = object%qcd%alpha%get (ren_scale)
     end select
     amp = 0.0
   end function prc_external_test_compute_amplitude
 
 @ %def prc_external_test_compute_amplitude
 @
 <<Prc external: prc test: TBP>>=
   procedure :: allocate_workspace => prc_external_test_allocate_workspace
 <<Prc external: procedures>>=
   subroutine prc_external_test_allocate_workspace (object, core_state)
     class(prc_external_test_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     allocate (prc_external_test_state_t :: core_state)
   end subroutine prc_external_test_allocate_workspace
 
 @ %def prc_external_test_allocate_workspace
 @
 <<Prc external: prc test: TBP>>=
   procedure :: includes_polarization => prc_external_test_includes_polarization
 <<Prc external: procedures>>=
   function prc_external_test_includes_polarization (object) result (polarized)
     logical :: polarized
     class(prc_external_test_t), intent(in) :: object
     polarized = .false.
   end function prc_external_test_includes_polarization
 
 @ %def prc_external_test_includes_polarization
 @
 <<Prc external: prc test: TBP>>=
   procedure :: prepare_external_code => &
        prc_external_test_prepare_external_code
 <<Prc external: procedures>>=
   subroutine prc_external_test_prepare_external_code &
        (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo)
     class(prc_external_test_t), intent(inout) :: core
     integer, intent(in), dimension(:,:), allocatable :: flv_states
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: i_core
     logical, intent(in) :: is_nlo
   end subroutine prc_external_test_prepare_external_code
 
 @ %def prc_external_test_prepare_external_code
 @
 \subsection{Threshold}
 <<[[prc_threshold.f90]]>>=
 <<File header>>
 module prc_threshold
 
   use, intrinsic :: iso_c_binding !NODEP!
 
   use kinds
   use constants
   use numeric_utils
   use string_utils, only: lower_case
   use io_units
 <<Use strings>>
 <<Use debug>>
   use physics_defs
   use system_defs, only: TAB
   use diagnostics
   use os_interface
   use lorentz
   use interactions
   use sm_qcd
   use model_data
   use variables, only: var_list_t
 
   use prclib_interfaces
   use process_libraries
   use prc_core_def
   use prc_core
   use prc_external
 
 <<Standard module head>>
 
 <<Prc Threshold: public>>
 
 <<Prc Threshold: interfaces>>
 
 <<Prc Threshold: types>>
 
 contains
 
 <<Prc Threshold: procedures>>
 
 end module prc_threshold
 @ %def prc_threshold
 @
 \subsubsection{Writer}
 <<Prc Threshold: public>>=
   public :: threshold_writer_t
 <<Prc Threshold: types>>=
   type, extends (prc_external_writer_t) :: threshold_writer_t
      integer :: nlo_type
   contains
   <<Prc Threshold: threshold writer: TBP>>
   end type threshold_writer_t
 
 @ %def threshold_writer_t
 @
 <<Prc Threshold: threshold writer: TBP>>=
   procedure :: init => threshold_writer_init
 <<Prc Threshold: procedures>>=
   pure subroutine threshold_writer_init &
        (writer, model_name, prt_in, prt_out, restrictions)
     class(threshold_writer_t), intent(inout) :: writer
     type(string_t), intent(in) :: model_name
     type(string_t), dimension(:), intent(in) :: prt_in, prt_out
     type(string_t), intent(in), optional :: restrictions
     call writer%base_init (model_name, prt_in, prt_out, restrictions)
     writer%amp_triv = .false.
   end subroutine threshold_writer_init
 
 @ %def threshold_writer_init
 @
 <<Prc Threshold: threshold writer: TBP>>=
   procedure :: write_makefile_extra => threshold_writer_write_makefile_extra
 <<Prc Threshold: procedures>>=
   subroutine threshold_writer_write_makefile_extra &
        (writer, unit, id, os_data, verbose, nlo_type)
     class(threshold_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     integer, intent(in) :: nlo_type
     type(string_t) :: f90in, f90, lo, extra
     if (debug_on) call msg_debug (D_ME_METHODS, "threshold_writer_write_makefile_extra")
     if (nlo_type /= BORN) then
        extra = "_" // component_status (nlo_type)
     else
        extra = var_str ("")
     end if
     f90 = id // "_threshold" // extra //".f90"
     f90in = f90 // ".in"
     lo = id // "_threshold" // extra // ".lo"
     write (unit, "(A)") "OBJECTS += " // char (lo)
     write (unit, "(A)") char (f90in) // ":"
     write (unit, "(A)") char (TAB // "if ! test -f " // f90in // &
          "; then cp " // os_data%whizard_sharepath // &
          "/SM_tt_threshold_data/threshold" // extra // ".f90 " // &
          f90in // "; fi")
     write (unit, "(A)") char(f90) // ": " // char (f90in)
     write (unit, "(A)") TAB // "sed 's/@ID@/" // char (id) // "/' " // &
          char (f90in) // " > " // char (f90)
     write (unit, "(5A)")  "CLEAN_SOURCES += ", char (f90)
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (f90in)
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (id), "_threshold.mod"
     write (unit, "(5A)")  "CLEAN_OBJECTS += ", char (lo)
     write (unit, "(A)") char(lo) // ": " // char (f90) // " " // &
          char(id) // ".f90"
     write (unit, "(5A)")  TAB, "$(LTFCOMPILE) $<"
     if (.not. verbose) then
        write (unit, "(5A)")  TAB // '@echo  "  FC       " $@'
     end if
   end subroutine threshold_writer_write_makefile_extra
 
 @ %def threshold_writer_write_makefile_extra
 @
 <<Prc Threshold: threshold writer: TBP>>=
   procedure :: write_makefile_code => threshold_writer_write_makefile_code
 <<Prc Threshold: procedures>>=
   subroutine threshold_writer_write_makefile_code &
        (writer, unit, id, os_data, verbose, testflag)
     class(threshold_writer_t), intent(in) :: writer
     integer, intent(in) :: unit
     type(string_t), intent(in) :: id
     type(os_data_t), intent(in) :: os_data
     logical, intent(in) :: verbose
     logical, intent(in), optional :: testflag
     if (debug_on) &
          call msg_debug (D_ME_METHODS, "threshold_writer_write_makefile_code")
     call writer%base_write_makefile_code &
          (unit, id, os_data, verbose, testflag = testflag)
     call writer%write_makefile_extra (unit, id, os_data, verbose, BORN)
     if (writer%nlo_type == NLO_VIRTUAL .and. writer%active) &
          call writer%write_makefile_extra (unit, id, os_data, verbose, writer%nlo_type)
   end subroutine threshold_writer_write_makefile_code
 
 @ %def threshold_writer_write_makefile_code
 @
 <<Prc Threshold: threshold writer: TBP>>=
   procedure, nopass :: type_name => threshold_writer_type_name
 <<Prc Threshold: procedures>>=
   function threshold_writer_type_name () result (string)
     type(string_t) :: string
     string = "Threshold"
   end function threshold_writer_type_name
 
 @ %def threshold_writer_type_name
 @
 \subsubsection{Driver}
 <<Prc Threshold: public>>=
   public :: threshold_set_process_mode
 <<Prc Threshold: interfaces>>=
   interface
     subroutine threshold_set_process_mode (mode) bind(C)
       import
       integer(kind = c_int), intent(in) :: mode
     end subroutine threshold_set_process_mode
   end interface
 
 @ %def threshold_set_process_mode
 @
 <<Prc Threshold: public>>=
   public :: threshold_get_amp_squared
 <<Prc Threshold: interfaces>>=
   interface
     subroutine threshold_get_amp_squared (amp2, p_ofs, p_ons, leg, n_tot, sel_hel_beam) bind(C)
       import
       real(c_default_float), intent(out) :: amp2
       real(c_default_float), dimension(0:3,*), intent(in) :: p_ofs
       real(c_default_float), dimension(0:3,*), intent(in) :: p_ons
       integer(kind = c_int) :: n_tot, leg, sel_hel_beam
     end subroutine threshold_get_amp_squared
   end interface
 
 @ %def threshold_get_amp_squared
 @
 <<Prc Threshold: public>>=
   public :: threshold_olp_eval2
 <<Prc Threshold: interfaces>>=
   interface
     subroutine threshold_olp_eval2 (i_flv, alpha_s_c, parray, mu_c, &
            sel_hel_beam, sqme_c, acc_c) bind(C)
       import
       integer(c_int), intent(in) :: i_flv
       real(c_default_float), intent(in) :: alpha_s_c
       real(c_default_float), dimension(0:3,*), intent(in) :: parray
       real(c_default_float), intent(in) :: mu_c
       integer, intent(in) :: sel_hel_beam
       real(c_default_float), dimension(4), intent(out) :: sqme_c
       real(c_default_float), intent(out) :: acc_c
     end subroutine threshold_olp_eval2
   end interface
 
 @ %def threshold_olp_eval2
 @
 <<Prc Threshold: public>>=
   public :: threshold_init
 <<Prc Threshold: interfaces>>=
   interface
    subroutine threshold_init (par, scheme) bind(C)
       import
       real(c_default_float), dimension(*), intent(in) :: par
       integer(c_int), intent(in) :: scheme
     end subroutine threshold_init
   end interface
 
 @ %def threshold_init
 @
 <<Prc Threshold: public>>=
   public :: threshold_start_openloops
 <<Prc Threshold: interfaces>>=
   interface
    subroutine threshold_start_openloops () bind(C)
       import
     end subroutine threshold_start_openloops
   end interface
 
 @ %def threshold_start_openloops
 @
 <<Prc Threshold: public>>=
   public :: threshold_driver_t
 <<Prc Threshold: types>>=
   type, extends (prc_external_driver_t) :: threshold_driver_t
     procedure(threshold_olp_eval2), nopass, pointer :: &
          olp_eval2 => null ()
     procedure(threshold_set_process_mode), nopass, pointer :: &
          set_process_mode => null ()
     procedure(threshold_get_amp_squared), nopass, pointer :: &
          get_amp_squared => null ()
     procedure(threshold_start_openloops), nopass, pointer :: &
          start_openloops => null ()
     procedure(threshold_init), nopass, pointer :: &
          init => null ()
     type(string_t) :: id
     integer :: nlo_type = BORN
   contains
   <<Prc Threshold: threshold driver: TBP>>
   end type threshold_driver_t
 
 @ %def threshold_driver_t
 @
 <<Prc Threshold: threshold driver: TBP>>=
   procedure, nopass :: type_name => threshold_driver_type_name
 <<Prc Threshold: procedures>>=
   function threshold_driver_type_name () result (type)
     type(string_t) :: type
     type = "Threshold"
   end function threshold_driver_type_name
 
 @ %def threshold_driver_type_name
 @
 <<Prc Threshold: threshold driver: TBP>>=
   procedure :: load => threshold_driver_load
 <<Prc Threshold: procedures>>=
   subroutine threshold_driver_load (threshold_driver, dlaccess)
     class(threshold_driver_t), intent(inout) :: threshold_driver
     type(dlaccess_t), intent(inout) :: dlaccess
     type(c_funptr) :: c_fptr
     type(string_t) :: lower_case_id
     if (debug_on) call msg_debug (D_ME_METHODS, "threshold_driver_load")
     lower_case_id = lower_case (threshold_driver%id)
     c_fptr = dlaccess_get_c_funptr (dlaccess, lower_case_id // "_set_process_mode")
     call c_f_procpointer (c_fptr, threshold_driver%set_process_mode)
     call check_for_error (lower_case_id // "_set_process_mode")
     c_fptr = dlaccess_get_c_funptr (dlaccess, lower_case_id // "_get_amp_squared")
     call c_f_procpointer (c_fptr, threshold_driver%get_amp_squared)
     call check_for_error (lower_case_id // "_get_amp_squared")
     c_fptr = dlaccess_get_c_funptr (dlaccess, lower_case_id // "_threshold_init")
     call c_f_procpointer (c_fptr, threshold_driver%init)
     call check_for_error (lower_case_id // "_threshold_init")
     select type (threshold_driver)
     type is (threshold_driver_t)
        if (threshold_driver%nlo_type == NLO_VIRTUAL) then
           c_fptr = dlaccess_get_c_funptr (dlaccess, lower_case_id // "_start_openloops")
           call c_f_procpointer (c_fptr, threshold_driver%start_openloops)
           call check_for_error (lower_case_id // "_start_openloops")
           c_fptr = dlaccess_get_c_funptr (dlaccess, lower_case_id // "_olp_eval2")
           call c_f_procpointer (c_fptr, threshold_driver%olp_eval2)
           call check_for_error (lower_case_id // "_olp_eval2")
        end if
     end select
     call msg_message ("Loaded extra threshold functions")
     contains
       subroutine check_for_error (function_name)
         type(string_t), intent(in) :: function_name
         if (dlaccess_has_error (dlaccess)) &
              call msg_fatal (char ("Loading of " // function_name // " failed!"))
      end subroutine check_for_error
   end subroutine threshold_driver_load
 
 @ %def threshold_driver_load
 @
 \subsubsection{Configuration}
 <<Prc Threshold: public>>=
   public :: threshold_def_t
 <<Prc Threshold: types>>=
   type, extends (prc_external_def_t) :: threshold_def_t
      integer :: nlo_type
   contains
   <<Prc Threshold: threshold def: TBP>>
   end type threshold_def_t
 
 @ %def threshold_def_t
 @
 <<Prc Threshold: threshold def: TBP>>=
   procedure :: init => threshold_def_init
 <<Prc Threshold: procedures>>=
   subroutine threshold_def_init (object, basename, model_name, &
        prt_in, prt_out, nlo_type, restrictions)
     class(threshold_def_t), intent(inout) :: object
     type(string_t), intent(in) :: basename, model_name
     type(string_t), dimension(:), intent(in) :: prt_in, prt_out
     integer, intent(in) :: nlo_type
     type(string_t), intent(in), optional :: restrictions
     if (debug_on) call msg_debug (D_ME_METHODS, "threshold_def_init")
     object%basename = basename
     object%nlo_type = nlo_type
     allocate (threshold_writer_t :: object%writer)
     select type (writer => object%writer)
     type is (threshold_writer_t)
        call writer%init (model_name, prt_in, prt_out, restrictions)
        writer%nlo_type = nlo_type
     end select
   end subroutine threshold_def_init
 
 @ %def threshold_def_init
 @
 <<Prc Threshold: threshold def: TBP>>=
   procedure, nopass :: type_string => threshold_def_type_string
 <<Prc Threshold: procedures>>=
   function threshold_def_type_string () result (string)
     type(string_t) :: string
     string = "threshold computation"
   end function threshold_def_type_string
 
 @ %def prc_external_def_type_string
 @ [[write]] and [[read]] could be put in the abstract version
 <<Prc Threshold: threshold def: TBP>>=
   procedure :: write => threshold_def_write
 <<Prc Threshold: procedures>>=
   subroutine threshold_def_write (object, unit)
     class(threshold_def_t), intent(in) :: object
     integer, intent(in) :: unit
   end subroutine threshold_def_write
 
 @ %def threshold_def_write
 @
 <<Prc Threshold: threshold def: TBP>>=
   procedure :: read => threshold_def_read
 <<Prc Threshold: procedures>>=
   subroutine threshold_def_read (object, unit)
     class(threshold_def_t), intent(out) :: object
     integer, intent(in) :: unit
   end subroutine threshold_def_read
 
 @ %def threshold_def_read
 @
 <<Prc Threshold: threshold def: TBP>>=
   procedure :: allocate_driver => threshold_def_allocate_driver
 <<Prc Threshold: procedures>>=
   subroutine threshold_def_allocate_driver (object, driver, basename)
     class(threshold_def_t), intent(in) :: object
     class(prc_core_driver_t), intent(out), allocatable :: driver
     type(string_t), intent(in) :: basename
     if (debug_on) call msg_debug (D_ME_METHODS, "threshold_def_allocate_driver")
     if (.not. allocated (driver)) allocate (threshold_driver_t :: driver)
     select type (driver)
     type is (threshold_driver_t)
        driver%id = basename
        driver%nlo_type = object%nlo_type
     end select
   end subroutine threshold_def_allocate_driver
 
 @ %def threshold_def_allocate_driver
 @
 <<Prc Threshold: threshold def: TBP>>=
   procedure :: connect => threshold_def_connect
 <<Prc Threshold: procedures>>=
   subroutine threshold_def_connect (def, lib_driver, i, proc_driver)
     class(threshold_def_t), intent(in) :: def
     class(prclib_driver_t), intent(in) :: lib_driver
     integer, intent(in) :: i
     class(prc_core_driver_t), intent(inout) :: proc_driver
     type(dlaccess_t) :: dlaccess
     logical :: skip
     if (debug_on) call msg_debug (D_ME_METHODS, "threshold_def_connect")
     call def%omega_connect (lib_driver, i, proc_driver)
     select type (lib_driver)
     class is (prclib_driver_dynamic_t)
        dlaccess = lib_driver%dlaccess
     end select
     select type (proc_driver)
     class is (threshold_driver_t)
        select type (writer => def%writer)
        type is (threshold_writer_t)
           skip = writer%nlo_type == NLO_VIRTUAL .and. .not. writer%active
           if (.not. skip) call proc_driver%load (dlaccess)
        end select
     end select
   end subroutine threshold_def_connect
 
 @ %def threshold_def_connect
 @
 \subsubsection{Core state}
 <<Prc Threshold: public>>=
   public :: threshold_state_t
 <<Prc Threshold: types>>=
   type, extends (prc_external_state_t) :: threshold_state_t
   contains
   <<Prc Threshold: threshold state: TBP>>
   end type threshold_state_t
 
 @ %def threshold_state_t
 @
 <<Prc Threshold: threshold state: TBP>>=
   procedure :: write => threshold_state_write
 <<Prc Threshold: procedures>>=
   subroutine threshold_state_write (object, unit)
     class(threshold_state_t), intent(in) :: object
     integer, intent(in), optional :: unit
   end subroutine threshold_state_write
 
 @ %def threshold_state_write
 @
 \subsubsection{Core}
 <<Prc Threshold: public>>=
   public :: prc_threshold_t
 <<Prc Threshold: types>>=
   type, extends (prc_external_t) :: prc_threshold_t
      real(default), dimension(:,:), allocatable :: parray_ofs
      real(default), dimension(:,:), allocatable :: parray_ons
      integer :: leg
      logical :: has_beam_pol = .false.
   contains
   <<Prc Threshold: prc threshold: TBP>>
   end type prc_threshold_t
 
 @ %def prc_threshold_t
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: write => prc_threshold_write
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_write (object, unit)
     class(prc_threshold_t), intent(in) :: object
     integer, intent(in), optional :: unit
     call msg_message ("Supply amplitudes squared for threshold computation")
   end subroutine prc_threshold_write
 
 @ %def prc_external_write
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: write_name => prc_threshold_write_name
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_write_name (object, unit)
     class(prc_threshold_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,"(1x,A)") "Core: Threshold"
   end subroutine prc_threshold_write_name
 
 @ %def prc_threshold_write_name
 @
 This core type has the beam polarization as an extra parameter.
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: set_beam_pol => prc_threshold_set_beam_pol
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_set_beam_pol (object, has_beam_pol)
     class(prc_threshold_t), intent(inout) :: object
     logical, intent(in), optional :: has_beam_pol
     if (present (has_beam_pol)) then
        object%has_beam_pol = has_beam_pol
     end if
   end subroutine prc_threshold_set_beam_pol
 
 @ %def prc_threshold_set_beam_pol
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: compute_amplitude => prc_threshold_compute_amplitude
 <<Prc Threshold: procedures>>=
   function prc_threshold_compute_amplitude &
        (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, &
        core_state)  result (amp)
     class(prc_threshold_t), intent(in) :: object
     integer, intent(in) :: j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in) :: fac_scale, ren_scale
     real(default), intent(in), allocatable :: alpha_qcd_forced
     class(prc_core_state_t), intent(inout), allocatable, optional :: core_state
     complex(default) :: amp
     select type (core_state)
     class is (prc_external_test_state_t)
        core_state%alpha_qcd = object%qcd%alpha%get (ren_scale)
     end select
     amp = 0
   end function prc_threshold_compute_amplitude
 
 @ %def prc_threshold_compute_amplitude
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: allocate_workspace => prc_threshold_allocate_workspace
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_allocate_workspace (object, core_state)
     class(prc_threshold_t), intent(in) :: object
     class(prc_core_state_t), intent(inout), allocatable :: core_state
     allocate (threshold_state_t :: core_state)
   end subroutine prc_threshold_allocate_workspace
 
 @ %def prc_threshold_allocate_workspace
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: set_offshell_momenta => prc_threshold_set_offshell_momenta
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_set_offshell_momenta (object, p)
     class(prc_threshold_t), intent(inout) :: object
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: i
     do i = 1, size(p)
        object%parray_ofs(:,i) = p(i)%p
     end do
   end subroutine prc_threshold_set_offshell_momenta
 
 @ %def prc_threshold_set_offshell_momenta
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: set_onshell_momenta => prc_threshold_set_onshell_momenta
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_set_onshell_momenta (object, p)
     class(prc_threshold_t), intent(inout) :: object
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: i
     do  i = 1, size(p)
        object%parray_ons(:,i) = p(i)%p
     end do
   end subroutine prc_threshold_set_onshell_momenta
 
 @ %def prc_threshold_set_onshell_momenta
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: set_leg => prc_threshold_set_leg
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_set_leg (object, leg)
     class(prc_threshold_t), intent(inout) :: object
     integer, intent(in) :: leg
     object%leg = leg
   end subroutine prc_threshold_set_leg
 
 @ %def prc_threshold_set_leg
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: set_process_mode => prc_threshold_set_process_mode
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_set_process_mode (object, mode)
     class(prc_threshold_t), intent(in) :: object
     integer(kind = c_int), intent(in) :: mode
     select type (driver => object%driver)
     class is (threshold_driver_t)
        if (associated (driver%set_process_mode)) &
             call driver%set_process_mode (mode)
     end select
   end subroutine prc_threshold_set_process_mode
 
 @ %def prc_threshold_set_process_mode
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: compute_sqme => prc_threshold_compute_sqme
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_compute_sqme (object, i_flv, i_hel, p, &
          ren_scale, sqme, bad_point)
     class(prc_threshold_t), intent(in) :: object
     integer, intent(in) :: i_flv, i_hel
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale
     real(default), intent(out) :: sqme
     logical, intent(out) :: bad_point
     integer :: n_tot
     if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_threshold_compute_sqme")
     n_tot = size (p)
     select type (driver => object%driver)
     class is (threshold_driver_t)
        if (object%has_beam_pol) then
           call driver%get_amp_squared (sqme, object%parray_ofs, &
                object%parray_ons, object%leg, n_tot, i_flv - 1)
        else
           call driver%get_amp_squared (sqme, object%parray_ofs, &
                object%parray_ons, object%leg, n_tot, -1)
        end if
     end select
     bad_point = .false.
   end subroutine prc_threshold_compute_sqme
 
 @ %def prc_threshold_compute_sqme
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: compute_sqme_virt => prc_threshold_compute_sqme_virt
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_compute_sqme_virt (object, i_flv, i_hel, &
          p, ren_scale, es_scale, loop_method, sqme, bad_point)
     class(prc_threshold_t), intent(in) :: object
     integer, intent(in) :: i_flv, i_hel
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: ren_scale, es_scale
     integer, intent(in) :: loop_method
     real(default), dimension(4), intent(out) :: sqme
     real(c_default_float), dimension(:,:), allocatable, save :: parray
     logical, intent(out) :: bad_point
     integer :: n_tot, i
     real(default) :: mu
     real(c_default_float), dimension(4) :: sqme_c
     real(c_default_float) :: mu_c, acc_c, alpha_s_c
     integer(c_int) :: i_flv_c
     if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_threshold_compute_sqme_virt")
     n_tot = size (p)
     if (allocated (parray)) then
        if (size(parray) /= n_tot) deallocate (parray)
     end if
     if (.not. allocated (parray))  allocate (parray (0:3, n_tot))
     forall (i = 1:n_tot)  parray(:,i) = p(i)%p
 
     if (vanishes (ren_scale)) then
       mu = sqrt (2* (p(1)*p(2)))
     else
       mu = ren_scale
     end if
     mu_c = mu
     alpha_s_c = object%qcd%alpha%get (mu)
     i_flv_c = i_flv
     select type (driver => object%driver)
     class is (threshold_driver_t)
        if (associated (driver%olp_eval2)) then
           if (object%has_beam_pol) then
              call driver%olp_eval2 (1, alpha_s_c, &
                   parray, mu_c, i_flv_c - 1, sqme_c, acc_c)
           else
              call driver%olp_eval2 (i_flv_c, alpha_s_c, &
                   parray, mu_c, -1, sqme_c, acc_c)
           end if
           bad_point = real(acc_c, kind=default) > object%maximum_accuracy
           sqme = sqme_c
        else
           sqme = 0._default
           bad_point = .true.
        end if
     end select
   end subroutine prc_threshold_compute_sqme_virt
 
 @ %def prc_threshold_compute_sqme_virt
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: init => prc_threshold_init
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_init (object, def, lib, id, i_component)
     class(prc_threshold_t), intent(inout) :: object
     class(prc_core_def_t), intent(in), target :: def
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     integer :: n_tot
     call object%base_init (def, lib, id, i_component)
     n_tot = object%data%n_in + object%data%n_out
     allocate (object%parray_ofs (0:3,n_tot), object%parray_ons (0:3,n_tot))
     if (n_tot == 4) then
        call object%set_process_mode (PROC_MODE_TT)
     else
        call object%set_process_mode (PROC_MODE_WBWB)
     end if
     call object%activate_parameters ()
   end subroutine prc_threshold_init
 
 @ %def prc_threshold_init
 @ Activate the stored parameters by transferring them to the external
 matrix element.
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: activate_parameters => prc_threshold_activate_parameters
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_activate_parameters (object)
     class (prc_threshold_t), intent(inout) :: object
     if (debug_on) call msg_debug (D_ME_METHODS, "prc_threshold_activate_parameters")
     if (allocated (object%driver)) then
        if (allocated (object%par)) then
           select type (driver => object%driver)
           type is (threshold_driver_t)
              if (associated (driver%init)) then
                 call driver%init (object%par, object%scheme)
              end if
           end select
        else
           call msg_bug ("prc_threshold_activate: parameter set is not allocated")
        end if
     else
        call msg_bug ("prc_threshold_activate: driver is not allocated")
     end if
   end subroutine prc_threshold_activate_parameters
 
 @ %def prc_threshold_activate_parameters
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: prepare_external_code => &
        prc_threshold_prepare_external_code
 <<Prc Threshold: procedures>>=
   subroutine prc_threshold_prepare_external_code &
        (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo)
     class(prc_threshold_t), intent(inout) :: core
     integer, intent(in), dimension(:,:), allocatable :: flv_states
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     integer, intent(in) :: i_core
     logical, intent(in) :: is_nlo
     if (debug_on) call msg_debug (D_ME_METHODS, &
          "prc_threshold_prepare_external_code")
     if (allocated (core%driver)) then
        select type (driver => core%driver)
        type is (threshold_driver_t)
           if (driver%nlo_type == NLO_VIRTUAL) call driver%start_openloops ()
        end select
     else
        call msg_bug ("prc_threshold_prepare_external_code: " &
             // "driver is not allocated")
     end if
   end subroutine prc_threshold_prepare_external_code
 
 @ %def prc_threshold_prepare_external_code
 @
 <<Prc Threshold: prc threshold: TBP>>=
   procedure :: includes_polarization => prc_threshold_includes_polarization
 <<Prc Threshold: procedures>>=
   function prc_threshold_includes_polarization (object) result (polarized)
     logical :: polarized
     class(prc_threshold_t), intent(in) :: object
     polarized = object%has_beam_pol
   end function prc_threshold_includes_polarization
 
 @ %def prc_threshold_includes_polarization
 @